From e12110637730d067c216abcc86185b761189b342 Mon Sep 17 00:00:00 2001 From: vblot <24938579+vblot@users.noreply.github.com> Date: Fri, 28 May 2021 18:29:37 +0200 Subject: getting rid of native-coq (#95) --- src/Array/PArray.v | 398 +++ src/Int63/Int63.v | 23 + src/Int63/Int63Axioms.v | 313 +++ src/Int63/Int63Native.v | 144 + src/Int63/Int63Op.v | 334 +++ src/Int63/Int63Properties.v | 2768 ++++++++++++++++++++ src/Makefile.local | 36 + src/Tactics.v | 157 ++ src/Trace.v | 17 +- src/_CoqProject | 153 ++ src/bva/Bva_checker.v | 26 +- src/classes/SMT_classes_instances.v | 3 +- src/configure.sh | 42 - src/extraction/Makefile | 2 +- src/extraction/verit_checker.mli | 6 +- src/g_smtcoq.mlg | 123 + src/lfsc/lfsc.ml | 22 +- src/lia/lia.ml | 12 +- src/lia/lia.mli | 2 +- src/smtcoq_plugin.mlpack | 52 + src/smtlib2/smtlib2_genConstr.ml | 8 +- src/smtlib2/smtlib2_solver.ml | 6 +- src/trace/coqInterface.ml | 237 ++ src/trace/coqInterface.mli | 122 + src/trace/coqTerms.ml | 134 +- src/trace/coqTerms.mli | 428 +-- src/trace/satAtom.ml | 4 +- src/trace/satAtom.mli | 10 +- src/trace/smtAtom.ml | 50 +- src/trace/smtAtom.mli | 26 +- src/trace/smtBtype.ml | 42 +- src/trace/smtBtype.mli | 28 +- src/trace/smtCertif.ml | 4 +- src/trace/smtCertif.mli | 4 +- src/trace/smtCommands.ml | 432 +-- src/trace/smtCommands.mli | 22 +- src/trace/smtForm.ml | 46 +- src/trace/smtForm.mli | 10 +- src/trace/smtMisc.ml | 10 +- src/trace/smtMisc.mli | 10 +- src/trace/smtTrace.ml | 20 +- src/trace/smtTrace.mli | 38 +- src/verit/verit.ml | 14 +- src/verit/verit.mli | 16 +- src/verit/veritSyntax.ml | 2 +- src/versions/native/Make | 171 -- src/versions/native/Makefile | 505 ---- src/versions/native/Structures_native.v | 59 - src/versions/native/Tactics_native.v | 55 - src/versions/native/smtcoq_plugin_native.ml4 | 99 - src/versions/native/structures.ml | 186 -- src/versions/native/structures.mli | 117 - src/versions/standard/Array/PArray_standard.v | 398 --- src/versions/standard/Int63/Int63Axioms_standard.v | 313 --- src/versions/standard/Int63/Int63Native_standard.v | 144 - src/versions/standard/Int63/Int63Op_standard.v | 334 --- .../standard/Int63/Int63Properties_standard.v | 2768 -------------------- src/versions/standard/Int63/Int63_standard.v | 23 - src/versions/standard/Makefile.local | 36 - src/versions/standard/Structures_standard.v | 64 - src/versions/standard/Tactics_standard.v | 157 -- src/versions/standard/_CoqProject | 156 -- src/versions/standard/g_smtcoq_standard.mlg | 123 - .../standard/smtcoq_plugin_standard.mlpack | 52 - src/versions/standard/structures.ml | 237 -- src/versions/standard/structures.mli | 122 - src/zchaff/zchaff.ml | 116 +- src/zchaff/zchaff.mli | 10 +- 68 files changed, 5650 insertions(+), 6951 deletions(-) create mode 100644 src/Array/PArray.v create mode 100644 src/Int63/Int63.v create mode 100644 src/Int63/Int63Axioms.v create mode 100644 src/Int63/Int63Native.v create mode 100644 src/Int63/Int63Op.v create mode 100644 src/Int63/Int63Properties.v create mode 100644 src/Makefile.local create mode 100644 src/Tactics.v create mode 100644 src/_CoqProject delete mode 100755 src/configure.sh create mode 100644 src/g_smtcoq.mlg create mode 100644 src/smtcoq_plugin.mlpack create mode 100644 src/trace/coqInterface.ml create mode 100644 src/trace/coqInterface.mli delete mode 100644 src/versions/native/Make delete mode 100644 src/versions/native/Makefile delete mode 100644 src/versions/native/Structures_native.v delete mode 100644 src/versions/native/Tactics_native.v delete mode 100644 src/versions/native/smtcoq_plugin_native.ml4 delete mode 100644 src/versions/native/structures.ml delete mode 100644 src/versions/native/structures.mli delete mode 100644 src/versions/standard/Array/PArray_standard.v delete mode 100644 src/versions/standard/Int63/Int63Axioms_standard.v delete mode 100644 src/versions/standard/Int63/Int63Native_standard.v delete mode 100644 src/versions/standard/Int63/Int63Op_standard.v delete mode 100644 src/versions/standard/Int63/Int63Properties_standard.v delete mode 100644 src/versions/standard/Int63/Int63_standard.v delete mode 100644 src/versions/standard/Makefile.local delete mode 100644 src/versions/standard/Structures_standard.v delete mode 100644 src/versions/standard/Tactics_standard.v delete mode 100644 src/versions/standard/_CoqProject delete mode 100644 src/versions/standard/g_smtcoq_standard.mlg delete mode 100644 src/versions/standard/smtcoq_plugin_standard.mlpack delete mode 100644 src/versions/standard/structures.ml delete mode 100644 src/versions/standard/structures.mli (limited to 'src') diff --git a/src/Array/PArray.v b/src/Array/PArray.v new file mode 100644 index 0000000..25da052 --- /dev/null +++ b/src/Array/PArray.v @@ -0,0 +1,398 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2021 *) +(* *) +(* 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 *) + + +Declare Scope array_scope. + +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). + +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. + +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/Int63/Int63.v b/src/Int63/Int63.v new file mode 100644 index 0000000..acee305 --- /dev/null +++ b/src/Int63/Int63.v @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2021 *) +(* *) +(* 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/Int63/Int63Axioms.v b/src/Int63/Int63Axioms.v new file mode 100644 index 0000000..9625bce --- /dev/null +++ b/src/Int63/Int63Axioms.v @@ -0,0 +1,313 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2021 *) +(* *) +(* 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 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/Int63/Int63Native.v b/src/Int63/Int63Native.v new file mode 100644 index 0000000..0f9d6b7 --- /dev/null +++ b/src/Int63/Int63Native.v @@ -0,0 +1,144 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2021 *) +(* *) +(* 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. + +Declare Scope int63_scope. +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/Int63/Int63Op.v b/src/Int63/Int63Op.v new file mode 100644 index 0000000..bb7d9a1 --- /dev/null +++ b/src/Int63/Int63Op.v @@ -0,0 +1,334 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2021 *) +(* *) +(* 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/Int63/Int63Properties.v b/src/Int63/Int63Properties.v new file mode 100644 index 0000000..feb19b8 --- /dev/null +++ b/src/Int63/Int63Properties.v @@ -0,0 +1,2768 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2021 *) +(* *) +(* 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<>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/Makefile.local b/src/Makefile.local new file mode 100644 index 0000000..8abc72c --- /dev/null +++ b/src/Makefile.local @@ -0,0 +1,36 @@ +######################################################################## +## 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/Tactics.v b/src/Tactics.v new file mode 100644 index 0000000..f79b253 --- /dev/null +++ b/src/Tactics.v @@ -0,0 +1,157 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2021 *) +(* *) +(* 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 k := + match goal with + | [ H : ?P |- _ ] => + let T := type of P in + lazymatch T with + | Prop => + lazymatch P with + | id _ => fail + | _ => + change P with (id P) in H; + match acc with + | Some ?t => get_hyps_acc (Some (H, t)) k + | None => get_hyps_acc (Some H) k + end + end + | _ => fail + end + | _ => k 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 k := get_hyps_acc (@None nat) ltac:(fun Hs => eliminate_id; k Hs). + + +Section Test. + Variable A : Type. + Hypothesis H1 : forall a:A, a = a. + Variable n : Z. + Hypothesis H2 : n = 17%Z. + + Goal True. + Proof. + (* get_hyps ltac:(fun acc => idtac acc). *) + Abort. +End Test. + + +(** Tactics in bool *) + +Tactic Notation "verit_bool_base_auto" constr(h) := verit_bool_base h; auto with typeclass_instances. +Tactic Notation "verit_bool_no_check_base_auto" constr(h) := verit_bool_no_check_base h; auto with typeclass_instances. + +Tactic Notation "verit_bool" constr(h) := + get_hyps ltac:(fun Hs => + 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" := + get_hyps ltac:(fun Hs => verit_bool_base_auto Hs; vauto). + +Tactic Notation "verit_bool_no_check" constr(h) := + get_hyps ltac:(fun Hs => + 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" := + get_hyps ltac:(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; + [ .. | get_hyps ltac:(fun Hs => + 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; + [ .. | get_hyps ltac:(fun Hs => + 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; + [ .. | get_hyps ltac:(fun Hs => + 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; + [ .. | get_hyps ltac:(fun Hs => + 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/Trace.v b/src/Trace.v index f9731f8..b6715ab 100644 --- a/src/Trace.v +++ b/src/Trace.v @@ -11,7 +11,6 @@ Require Import Bool Int63 PArray. -Require Structures. Require Import Misc State SMT_terms. Require Import Syntactic Arithmetic Operators Assumptions. Require Import Cnf Euf Lia BVList Bva_checker Array_checker. @@ -34,7 +33,7 @@ Section trace. Variable rho : Valuation.t. - Definition _trace_ := Structures.trace step. + Definition _trace_ := ((list step) * step)%type. (* A checker for such a trace *) @@ -42,7 +41,7 @@ Section trace. Hypothesis is_false_correct : forall c, is_false c -> ~ C.interp rho c. Definition _checker_ (s: S.t) (t: _trace_) (confl:clause_id) : bool := - let s' := Structures.trace_fold check_step s t in + let s' := List.fold_left check_step (fst t) s in (* let s' := PArray.fold_left (fun s a => PArray.fold_left check_step s a) s t in *) is_false (S.get s' confl). (* Register _checker_ as PrimInline. *) @@ -78,7 +77,11 @@ Section trace. intros s t' cid Hf Hv. apply (is_false_correct Hf). apply S.valid_get. - apply Structures.trace_fold_ind; auto. + clear Hf. + rewrite <- List.fold_left_rev_right in *. + induction (List.rev (fst t')); [ apply Hv | ]. + apply valid_check_step. + apply IHl. (* apply PArray.fold_left_ind; auto. *) (* intros a i _ Ha;apply PArray.fold_left_ind;trivial. *) (* intros a0 i0 _ H1;auto. *) @@ -534,7 +537,7 @@ Inductive step := Definition setup_checker_step_debug d used_roots (c:certif) := let (nclauses, t, confl) := c in let s := add_roots (S.make nclauses) d used_roots in - (s, Structures.trace_to_list t). + (s, fst t). Definition position_of_step (st:step) := @@ -686,7 +689,7 @@ Inductive step := let (nclauses, t, confl) := c in let s := add_roots (S.make nclauses) d used_roots in let '(_, nb, failure) := - Structures.trace_fold + List.fold_left (fun acc step => match acc with | (s, nb, None) => @@ -698,7 +701,7 @@ Inductive step := else (s, nb, None) | _ => acc end - ) (s, O, None) t + ) (fst t) (s, O, None) in match failure with | Some st => Some (nb, name_of_step st) diff --git a/src/_CoqProject b/src/_CoqProject new file mode 100644 index 0000000..f7862e1 --- /dev/null +++ b/src/_CoqProject @@ -0,0 +1,153 @@ +######################################################################## +## 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 Int63 +-I Array +-I ../3rdparty/alt-ergo + +Int63/Int63.v +Int63/Int63Native.v +Int63/Int63Op.v +Int63/Int63Axioms.v +Int63/Int63Properties.v +Array/PArray.v + +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 +trace/coqInterface.ml +trace/coqInterface.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.mlg +smtcoq_plugin.mlpack diff --git a/src/bva/Bva_checker.v b/src/bva/Bva_checker.v index 7a47c70..1487453 100644 --- a/src/bva/Bva_checker.v +++ b/src/bva/Bva_checker.v @@ -12,8 +12,6 @@ (** A small checker for bit-vectors bit-blasting *) -Require Structures. - Require Import Int63 Int63Properties PArray SMT_classes ZArith. Require Import Misc State SMT_terms BVList Psatz. @@ -925,7 +923,7 @@ Definition shl_lit_be (a: list _lit) (b: list bool): list _lit := Definition check_shl (bs1: list _lit) (bs2: list bool) (bsres: list _lit) : bool := - if (Structures.nat_eqb (length bs1) (length bs2)) then + if (Nat.eqb (length bs1) (length bs2)) then if (forallb2 eq_carry_lit (lit_to_carry (shl_lit_be bs1 bs2)) bsres) then true else false else false. @@ -976,7 +974,7 @@ Definition shr_lit_be (a: list _lit) (b: list bool): list _lit := Definition check_shr (bs1: list _lit) (bs2: list bool) (bsres: list _lit) : bool := - if (Structures.nat_eqb (length bs1) (length bs2)) then + if (Nat.eqb (length bs1) (length bs2)) then if (forallb2 eq_carry_lit (lit_to_carry (shr_lit_be bs1 bs2)) bsres) then true else false else false. @@ -7946,7 +7944,7 @@ Proof. intro bs1. - simpl in *. unfold check_shl in H. simpl in H. case_eq bs2; simpl; intros; subst. simpl in H. now contradict H. - simpl in *. inversion H0. rewrite H2, Structures.nat_eqb_refl in H. + simpl in *. inversion H0. rewrite H2, Nat.eqb_refl in H. case_eq (forallb2 eq_carry_lit (lit_to_carry (shl_lit_be (a :: bs1) (b :: l))) bsres); intros. + apply prop_eq_carry_lit2 in H1. rewrite prop_interp_carry3 in H1. @@ -8016,8 +8014,8 @@ Proof. intro bs1. induction bs1 as [ | xbs1 xsbs1 IHbs1 ]. - intros. simpl. unfold check_shl, shl_lit_be in H. - case_eq (Structures.nat_eqb (@length int []) (length bs2)); intros. - rewrite Structures.nat_eqb_eq in H0. + case_eq (Nat.eqb (@length int []) (length bs2)); intros. + rewrite Nat.eqb_eq in H0. rewrite <- H0 in H. simpl in H. rewrite nshl_lit_empty in H. case_eq bsres; intros. simpl. @@ -8025,7 +8023,7 @@ Proof. intro bs1. subst; now contradict H. rewrite H0 in H; now contradict H. - intros. unfold check_shl in H. - case_eq (Structures.nat_eqb (Datatypes.length (xbs1 :: xsbs1)) (Datatypes.length bs2)); intros. + case_eq (Nat.eqb (Datatypes.length (xbs1 :: xsbs1)) (Datatypes.length bs2)); intros. rewrite H0 in H. case_eq ( forallb2 eq_carry_lit (lit_to_carry (shl_lit_be (xbs1 :: xsbs1) bs2)) bsres); intros. @@ -8033,7 +8031,7 @@ Proof. intro bs1. rewrite prop_interp_carry3 in H1. unfold RAWBITVECTOR_LIST.bv_shl. - rewrite Structures.nat_eqb_eq in H0. + rewrite Nat.eqb_eq in H0. unfold RAWBITVECTOR_LIST.size. rewrite !map_length. rewrite H0, N.eqb_refl. now rewrite <- H1, shl_interp. @@ -8287,7 +8285,7 @@ Proof. intro bs1. - simpl in *. unfold check_shr in H. simpl in H. case_eq bs2; simpl; intros; subst. simpl in H. now contradict H. - simpl in *. inversion H0. rewrite H2, Structures.nat_eqb_refl in H. + simpl in *. inversion H0. rewrite H2, Nat.eqb_refl in H. case_eq (forallb2 eq_carry_lit (lit_to_carry (shr_lit_be (a :: bs1) (b :: l))) bsres); intros. + apply prop_eq_carry_lit2 in H1. rewrite prop_interp_carry3 in H1. @@ -8345,8 +8343,8 @@ Proof. intro bs1. induction bs1 as [ | xbs1 xsbs1 IHbs1 ]. - intros. simpl. unfold check_shr, shr_lit_be in H. - case_eq (Structures.nat_eqb (@length int []) (length bs2)); intros. - rewrite Structures.nat_eqb_eq in H0. + case_eq (Nat.eqb (@length int []) (length bs2)); intros. + rewrite Nat.eqb_eq in H0. rewrite <- H0 in H. simpl in H. rewrite nshr_lit_empty in H. case_eq bsres; intros. simpl. @@ -8354,7 +8352,7 @@ Proof. intro bs1. subst; now contradict H. rewrite H0 in H; now contradict H. - intros. unfold check_shr in H. - case_eq (Structures.nat_eqb (Datatypes.length (xbs1 :: xsbs1)) (Datatypes.length bs2)); intros. + case_eq (Nat.eqb (Datatypes.length (xbs1 :: xsbs1)) (Datatypes.length bs2)); intros. rewrite H0 in H. case_eq ( forallb2 eq_carry_lit (lit_to_carry (shr_lit_be (xbs1 :: xsbs1) bs2)) bsres); intros. @@ -8362,7 +8360,7 @@ Proof. intro bs1. rewrite prop_interp_carry3 in H1. unfold RAWBITVECTOR_LIST.bv_shr. - rewrite Structures.nat_eqb_eq in H0. + rewrite Nat.eqb_eq in H0. unfold RAWBITVECTOR_LIST.size. rewrite !map_length. rewrite H0, N.eqb_refl. now rewrite <- H1, shr_interp. diff --git a/src/classes/SMT_classes_instances.v b/src/classes/SMT_classes_instances.v index aa2082e..a2831cf 100644 --- a/src/classes/SMT_classes_instances.v +++ b/src/classes/SMT_classes_instances.v @@ -13,7 +13,6 @@ Require Import Bool OrderedType BinPos ZArith OrderedTypeEx. Require Import Int63. Require Import State BVList FArray. -Require Structures. Require Export SMT_classes. @@ -253,7 +252,7 @@ Section Nat. Defined. Global Instance Nat_eqbtype : EqbType nat := - {| eqb := Structures.nat_eqb; eqb_spec := Structures.nat_eqb_eq |}. + {| eqb := Nat.eqb; eqb_spec := Nat.eqb_eq |}. Global Instance Nat_dec : DecType nat := EqbToDecType. diff --git a/src/configure.sh b/src/configure.sh deleted file mode 100755 index fb265e0..0000000 --- a/src/configure.sh +++ /dev/null @@ -1,42 +0,0 @@ -#!/bin/sh - -pre=$(echo $0 | sed "s,\(\([^/]*/\)*\)[^/]*,\1,") - -rm -f ${pre}_CoqProject -rm -f ${pre}Makefile -rm -f ${pre}Makefile.conf -rm -f ${pre}Makefile.local -rm -f ${pre}smtcoq_plugin.ml4 -rm -f ${pre}versions/native/Structures.v -rm -f ${pre}g_smtcoq.mlg -rm -f ${pre}smtcoq_plugin.mlpack -rm -f ${pre}Tactics.v -rm -f ${pre}versions/standard/Int63/Int63.v -rm -f ${pre}versions/standard/Int63/Int63Native.v -rm -f ${pre}versions/standard/Int63/Int63Op.v -rm -f ${pre}versions/standard/Int63/Int63Axioms.v -rm -f ${pre}versions/standard/Int63/Int63Properties.v -rm -f ${pre}versions/standard/Array/PArray.v -rm -f ${pre}versions/standard/Structures.v - -set -e -if [ $@ -a $@ = -native ]; then - cp ${pre}versions/native/Makefile ${pre}Makefile - cp ${pre}versions/native/smtcoq_plugin_native.ml4 ${pre}smtcoq_plugin.ml4 - cp ${pre}versions/native/Structures_native.v ${pre}versions/native/Structures.v - cp ${pre}versions/native/Tactics_native.v ${pre}Tactics.v -else - cp ${pre}versions/standard/_CoqProject ${pre}_CoqProject - cp ${pre}versions/standard/Makefile.local ${pre}Makefile.local - cp ${pre}versions/standard/g_smtcoq_standard.mlg ${pre}g_smtcoq.mlg - cp ${pre}versions/standard/smtcoq_plugin_standard.mlpack ${pre}smtcoq_plugin.mlpack - cp ${pre}versions/standard/Int63/Int63_standard.v ${pre}versions/standard/Int63/Int63.v - cp ${pre}versions/standard/Int63/Int63Native_standard.v ${pre}versions/standard/Int63/Int63Native.v - cp ${pre}versions/standard/Int63/Int63Op_standard.v ${pre}versions/standard/Int63/Int63Op.v - cp ${pre}versions/standard/Int63/Int63Axioms_standard.v ${pre}versions/standard/Int63/Int63Axioms.v - cp ${pre}versions/standard/Int63/Int63Properties_standard.v ${pre}versions/standard/Int63/Int63Properties.v - cp ${pre}versions/standard/Array/PArray_standard.v ${pre}versions/standard/Array/PArray.v - cp ${pre}versions/standard/Structures_standard.v ${pre}versions/standard/Structures.v - cp ${pre}versions/standard/Tactics_standard.v ${pre}Tactics.v - coq_makefile -f _CoqProject -o Makefile -fi diff --git a/src/extraction/Makefile b/src/extraction/Makefile index 73b0ae4..354dd53 100644 --- a/src/extraction/Makefile +++ b/src/extraction/Makefile @@ -15,7 +15,7 @@ COQTOP=$(COQBIN)../ FLAGS=-rectypes COMPILEFLAGS=-cclib -lunix -SMTLIB=-I .. -I ../zchaff -I ../verit -I ../trace -I ../smtlib2 -I ../lia -I ../euf -I ../cnf -I ../versions/native/ +SMTLIB=-I .. -I ../zchaff -I ../verit -I ../trace -I ../smtlib2 -I ../lia -I ../euf -I ../cnf -I ../../3rdparty/alt-ergo COQLIB=-I ${COQTOP}kernel -I ${COQTOP}lib -I ${COQTOP}library -I ${COQTOP}parsing -I ${COQTOP}pretyping -I ${COQTOP}interp -I ${COQTOP}proofs -I ${COQTOP}tactics -I ${COQTOP}toplevel -I ${COQTOP}plugins/btauto -I ${COQTOP}plugins/cc -I ${COQTOP}plugins/decl_mode -I ${COQTOP}plugins/extraction -I ${COQTOP}plugins/field -I ${COQTOP}plugins/firstorder -I ${COQTOP}plugins/fourier -I ${COQTOP}plugins/funind -I ${COQTOP}plugins/micromega -I ${COQTOP}plugins/nsatz -I ${COQTOP}plugins/omega -I ${COQTOP}plugins/quote -I ${COQTOP}plugins/ring -I ${COQTOP}plugins/romega -I ${COQTOP}plugins/rtauto -I ${COQTOP}plugins/setoid_ring -I ${COQTOP}plugins/syntax -I ${COQTOP}plugins/xml -I /usr/lib/ocaml/camlp5 CMXA=nums.cmxa str.cmxa unix.cmxa gramlib.cmxa dynlink.cmxa ${COQTOP}kernel/byterun/coq_fix_code.o ${COQTOP}kernel/byterun/coq_interp.o ${COQTOP}kernel/byterun/coq_memory.o ${COQTOP}kernel/byterun/coq_values.o clib.cmxa lib.cmxa kernel.cmxa library.cmxa pretyping.cmxa interp.cmxa proofs.cmxa parsing.cmxa tactics.cmxa toplevel.cmxa micromega_plugin.cmxa smtcoq.cmxa diff --git a/src/extraction/verit_checker.mli b/src/extraction/verit_checker.mli index 4491410..7b8b882 100644 --- a/src/extraction/verit_checker.mli +++ b/src/extraction/verit_checker.mli @@ -10,7 +10,7 @@ (**************************************************************************) -module Mc = Structures.Micromega_plugin_Certificate.Mc +module Mc = CoqInterface.Micromega_plugin_Certificate.Mc val mkInt : int -> ExtrNative.uint val mkArray : 'a array -> 'a ExtrNative.parray val dump_nat : Mc.nat -> Smt_checker.nat @@ -25,7 +25,7 @@ val to_coq : 'a SmtCertif.clause -> Smt_checker.Euf_Checker.step ExtrNative.parray ExtrNative.parray * 'a SmtCertif.clause -val btype_to_coq : SmtAtom.btype -> Smt_checker.Typ.coq_type +val btype_to_coq : SmtBtype.btype -> Smt_checker.Typ.coq_type val c_to_coq : SmtAtom.cop -> Smt_checker.Atom.cop val u_to_coq : SmtAtom.uop -> Smt_checker.Atom.unop val b_to_coq : SmtAtom.bop -> Smt_checker.Atom.binop @@ -42,7 +42,7 @@ val form_interp_tbl : SmtAtom.Form.reify -> Smt_checker.Form.form ExtrNative.parray val count_btype : int ref val count_op : int ref -val declare_sort : Smtlib2_ast.symbol -> SmtAtom.btype +val declare_sort : Smtlib2_ast.symbol -> SmtBtype.btype val declare_fun : Smtlib2_ast.symbol -> Smtlib2_ast.sort list -> Smtlib2_ast.sort -> SmtAtom.indexed_op diff --git a/src/g_smtcoq.mlg b/src/g_smtcoq.mlg new file mode 100644 index 0000000..c8d38db --- /dev/null +++ b/src/g_smtcoq.mlg @@ -0,0 +1,123 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2021 *) +(* *) +(* 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 +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 : CoqInterface.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/lfsc/lfsc.ml b/src/lfsc/lfsc.ml index f17eb04..f2157a4 100644 --- a/src/lfsc/lfsc.ml +++ b/src/lfsc/lfsc.ml @@ -57,7 +57,7 @@ let process_signatures_once = ) signatures with | Ast.TypingError (t1, t2) -> - Structures.error + CoqInterface.error (asprintf "@[LFSC typing error: expected %a, got %a@]@." Ast.print_term t1 Ast.print_term t2) @@ -116,7 +116,7 @@ let import_trace first parse lexbuf = with | Ast.TypingError (t1, t2) -> - Structures.error + CoqInterface.error (asprintf "@[LFSC typing error: expected %a, got %a@]@." Ast.print_term t1 Ast.print_term t2) @@ -386,13 +386,13 @@ let call_cvc4 env rt ro ra rf root _ = begin try get_proof cvc4 (import_trace (Some root) lfsc_parse_one) with - | Ast.CVC4Sat -> Structures.error "CVC4 returned SAT" - | No_proof -> Structures.error "CVC4 did not generate a proof" - | Failure s -> Structures.error ("Importing of proof failed: " ^ s) + | Ast.CVC4Sat -> CoqInterface.error "CVC4 returned SAT" + | No_proof -> CoqInterface.error "CVC4 did not generate a proof" + | Failure s -> CoqInterface.error ("Importing of proof failed: " ^ s) end | Sat -> let smodel = get_model cvc4 in - Structures.error + CoqInterface.error ("CVC4 returned sat. Here is the model:\n\n" ^ SmtCommands.model_string env rt ro ra rf smodel) (* (asprintf "CVC4 returned sat. Here is the model:\n%a" SExpr.print smodel) *) @@ -435,7 +435,7 @@ let get_model_from_file filename = let lexbuf = Lexing.from_channel chan in match SExprParser.sexps SExprLexer.main lexbuf with | [SExpr.Atom "sat"; m] -> m - | _ -> Structures.error "CVC4 returned SAT but no model" + | _ -> CoqInterface.error "CVC4 returned SAT but no model" let call_cvc4_file env rt ro ra rf root = @@ -467,17 +467,17 @@ let call_cvc4_file env rt ro ra rf root = eprintf "CVC4 = %.5f@." (t1-.t0); if exit_code <> 0 then - Structures.error ("CVC4 crashed: return code "^string_of_int exit_code); + CoqInterface.error ("CVC4 crashed: return code "^string_of_int exit_code); (* ignore (Sys.command clean_cmd); *) try import_trace_from_file (Some root) prooffilename with - | No_proof -> Structures.error "CVC4 did not generate a proof" - | Failure s -> Structures.error ("Importing of proof failed: " ^ s) + | No_proof -> CoqInterface.error "CVC4 did not generate a proof" + | Failure s -> CoqInterface.error ("Importing of proof failed: " ^ s) | Ast.CVC4Sat -> let smodel = get_model_from_file prooffilename in - Structures.error + CoqInterface.error ("CVC4 returned sat. Here is the model:\n\n" ^ SmtCommands.model_string env rt ro ra rf smodel) diff --git a/src/lia/lia.ml b/src/lia/lia.ml index 53dbf6d..e00092e 100644 --- a/src/lia/lia.ml +++ b/src/lia/lia.ml @@ -12,7 +12,7 @@ (*** Linking SMT Terms to Micromega Terms ***) open Util -open Structures.Micromega_plugin_Micromega +open CoqInterface.Micromega_plugin_Micromega open SmtForm open SmtAtom @@ -92,7 +92,7 @@ let smt_binop_to_micromega_formula tbl op ha hb = | BO_Zge -> OpGe | BO_Zgt -> OpGt | BO_eq _ -> OpEq - | _ -> Structures.error + | _ -> CoqInterface.error "lia.ml: smt_binop_to_micromega_formula expecting a formula" in let lhs = smt_Atom_to_micromega_pExpr tbl ha in @@ -102,7 +102,7 @@ let smt_binop_to_micromega_formula tbl op ha hb = let smt_Atom_to_micromega_formula tbl ha = match Atom.atom ha with | Abop (op,ha,hb) -> smt_binop_to_micromega_formula tbl op ha hb - | _ -> Structures.error + | _ -> CoqInterface.error "lia.ml: smt_Atom_to_micromega_formula was expecting an LIA formula" (* specialized fold *) @@ -152,7 +152,7 @@ let smt_clause_to_coq_micromega_formula tbl cl = binop_list tbl (fun x y -> Cj (x,y)) TT (List.map Form.neg cl) let tauto_lia ff = - let cnf_ff,_ = Structures.Micromega_plugin_Micromega.cnfZ ff in + let cnf_ff,_ = CoqInterface.Micromega_plugin_Micromega.cnfZ ff in let rec xwitness_list l = match l with | [] -> Some [] @@ -160,8 +160,8 @@ let tauto_lia ff = match xwitness_list l with | None -> None | Some l -> - match Structures.Micromega_plugin_Certificate.lia true max_int (List.map (fun ((e, o), _) -> Structures.Micromega_plugin_Micromega.denorm e, o) e) with - | Structures.Micromega_plugin_Certificate.Prf w -> Some (w::l) + match CoqInterface.Micromega_plugin_Certificate.lia true max_int (List.map (fun ((e, o), _) -> CoqInterface.Micromega_plugin_Micromega.denorm e, o) e) with + | CoqInterface.Micromega_plugin_Certificate.Prf w -> Some (w::l) | _ -> None in xwitness_list cnf_ff diff --git a/src/lia/lia.mli b/src/lia/lia.mli index 7b4c6c8..f996ac0 100644 --- a/src/lia/lia.mli +++ b/src/lia/lia.mli @@ -12,4 +12,4 @@ val build_lia_certif : SmtAtom.Form.t list -> - Structures.Micromega_plugin_Certificate.Mc.zArithProof list option + CoqInterface.Micromega_plugin_Certificate.Mc.zArithProof list option diff --git a/src/smtcoq_plugin.mlpack b/src/smtcoq_plugin.mlpack new file mode 100644 index 0000000..0907551 --- /dev/null +++ b/src/smtcoq_plugin.mlpack @@ -0,0 +1,52 @@ +CoqInterface + +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/smtlib2/smtlib2_genConstr.ml b/src/smtlib2/smtlib2_genConstr.ml index eb1c5b7..0c6e2ac 100644 --- a/src/smtlib2/smtlib2_genConstr.ml +++ b/src/smtlib2/smtlib2_genConstr.ml @@ -97,10 +97,10 @@ let rec sort_of_sort = function let declare_sort_from_name rt s = - let cons_t = Structures.declare_new_type (Structures.mkId ("Smt_sort_"^s)) in + let cons_t = CoqInterface.declare_new_type (CoqInterface.mkId ("Smt_sort_"^s)) in let compdec_type = mklApp cCompDec [| cons_t |] in let compdec_var = - Structures.declare_new_variable (Structures.mkId ("CompDec_"^s)) compdec_type in + CoqInterface.declare_new_variable (CoqInterface.mkId ("CompDec_"^s)) compdec_type in let res = SmtBtype.of_coq_compdec rt cons_t compdec_var in SmtMaps.add_btype s res; res @@ -110,9 +110,9 @@ let declare_sort rt sym = declare_sort_from_name rt (string_of_symbol sym) let declare_fun_from_name rt ro s tyl ty = let coqTy = List.fold_right (fun typ c -> - Structures.mkArrow (interp_to_coq rt typ) c) + CoqInterface.mkArrow (interp_to_coq rt typ) c) tyl (interp_to_coq rt ty) in - let cons_v = Structures.declare_new_variable (Structures.mkId ("Smt_var_"^s)) coqTy in + let cons_v = CoqInterface.declare_new_variable (CoqInterface.mkId ("Smt_var_"^s)) coqTy in let op = Op.declare ro cons_v (Array.of_list tyl) ty None in SmtMaps.add_fun s op; op diff --git a/src/smtlib2/smtlib2_solver.ml b/src/smtlib2/smtlib2_solver.ml index 99538ce..efab1c1 100644 --- a/src/smtlib2/smtlib2_solver.ml +++ b/src/smtlib2/smtlib2_solver.ml @@ -73,7 +73,7 @@ let read_response { lexbuf } = let error s sexp = kill s; - Structures.error (asprintf "Solver error: %a." SExpr.print sexp) + CoqInterface.error (asprintf "Solver error: %a." SExpr.print sexp) let read_success s = @@ -89,7 +89,7 @@ let read_check_result s = match SExprParser.sexp SExprLexer.main s.lexbuf with | SExpr.Atom "sat" -> Sat | SExpr.Atom "unsat" -> Unsat - | SExpr.Atom "unknown" -> Structures.error ("Solver returned uknown.") + | SExpr.Atom "unknown" -> CoqInterface.error ("Solver returned uknown.") | r -> error s r @@ -111,7 +111,7 @@ let send_command s cmd read = * let buf = Bytes.create err_p2 in * Unix.read s.stderr buf 0 err_p2 |> ignore; * let err_msg = Bytes.sub_string buf err_p1 len in - * Structures.error ("Solver error: "^err_msg); + * CoqInterface.error ("Solver error: "^err_msg); * end * else (kill s; raise e) *) kill s; raise e diff --git a/src/trace/coqInterface.ml b/src/trace/coqInterface.ml new file mode 100644 index 0000000..36f4337 --- /dev/null +++ b/src/trace/coqInterface.ml @@ -0,0 +1,237 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2021 *) +(* *) +(* 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 (n, t, c) = Constr.mkLambda (Context.make_annot n Sorts.Relevant, t, c) +let mkProd (n, t, c) = Constr.mkProd (Context.make_annot n Sorts.Relevant, t, c) +let mkLetIn (n, c1, t, c2) = Constr.mkLetIn (Context.make_annot n Sorts.Relevant, c1, t, c2) +let mkArrow a b = Term.mkArrow a Sorts.Relevant b + +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.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.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 ~pstate:None false (Decl_kinds.Discharge, false, Decl_kinds.Definitional) (Constr.mkSet, Entries.Monomorphic_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 ~pstate:None false (Decl_kinds.Discharge, false, Decl_kinds.Definitional) (constr_t, Evd.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_monomorphic_global will crash on universe polymorphic constants *) + UnivGen.constr_of_monomorphic_global @@ Coqlib.gen_reference_in_modules s m n +let gen_constant modules constant = lazy (gen_constant_in_modules "SMT" modules constant) +let init_modules = Coqlib.init_modules + + +(* Int63 *) +let int63_modules = [["SMTCoq";"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";"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_Certificate = Micromega_plugin.Certificate + +let micromega_coq_proofTerm = + (* Cannot contain evars *) + lazy (gen_constant_in_modules "ZMicromega" [["Coq"; "micromega";"ZMicromega"]] "ZArithProof") + +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.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, _, _) -> + Context.binder_name 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/trace/coqInterface.mli b/src/trace/coqInterface.mli new file mode 100644 index 0000000..104f3f9 --- /dev/null +++ b/src/trace/coqInterface.mli @@ -0,0 +1,122 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2021 *) +(* *) +(* 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 mkArrow : types -> types -> 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 +val init_modules : string list list + + +(* 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_Certificate = Micromega_plugin.Certificate + +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 diff --git a/src/trace/coqTerms.ml b/src/trace/coqTerms.ml index c6188b8..1c4ee81 100644 --- a/src/trace/coqTerms.ml +++ b/src/trace/coqTerms.ml @@ -13,23 +13,23 @@ open SmtMisc -let gen_constant = Structures.gen_constant +let gen_constant = CoqInterface.gen_constant (* Int63 *) -let cint = Structures.cint -let ceq63 = gen_constant Structures.int63_modules "eqb" +let cint = CoqInterface.cint +let ceq63 = gen_constant CoqInterface.int63_modules "eqb" (* PArray *) -let carray = gen_constant Structures.parray_modules "array" +let carray = gen_constant CoqInterface.parray_modules "array" (* is_true *) -let cis_true = gen_constant Structures.init_modules "is_true" +let cis_true = gen_constant CoqInterface.init_modules "is_true" (* nat *) -let cnat = gen_constant Structures.init_modules "nat" -let cO = gen_constant Structures.init_modules "O" -let cS = gen_constant Structures.init_modules "S" +let cnat = gen_constant CoqInterface.init_modules "nat" +let cO = gen_constant CoqInterface.init_modules "O" +let cS = gen_constant CoqInterface.init_modules "S" (* Positive *) let positive_modules = [["Coq";"Numbers";"BinNums"]; @@ -74,49 +74,49 @@ let ceqbZ = gen_constant z_modules "eqb" (* Booleans *) let bool_modules = [["Coq";"Bool";"Bool"]] -let cbool = gen_constant Structures.init_modules "bool" -let ctrue = gen_constant Structures.init_modules "true" -let cfalse = gen_constant Structures.init_modules "false" -let candb = gen_constant Structures.init_modules "andb" -let corb = gen_constant Structures.init_modules "orb" -let cxorb = gen_constant Structures.init_modules "xorb" -let cnegb = gen_constant Structures.init_modules "negb" -let cimplb = gen_constant Structures.init_modules "implb" +let cbool = gen_constant CoqInterface.init_modules "bool" +let ctrue = gen_constant CoqInterface.init_modules "true" +let cfalse = gen_constant CoqInterface.init_modules "false" +let candb = gen_constant CoqInterface.init_modules "andb" +let corb = gen_constant CoqInterface.init_modules "orb" +let cxorb = gen_constant CoqInterface.init_modules "xorb" +let cnegb = gen_constant CoqInterface.init_modules "negb" +let cimplb = gen_constant CoqInterface.init_modules "implb" let ceqb = gen_constant bool_modules "eqb" let cifb = gen_constant bool_modules "ifb" -let ciff = gen_constant Structures.init_modules "iff" +let ciff = gen_constant CoqInterface.init_modules "iff" let creflect = gen_constant bool_modules "reflect" (* Lists *) -let clist = gen_constant Structures.init_modules "list" -let cnil = gen_constant Structures.init_modules "nil" -let ccons = gen_constant Structures.init_modules "cons" -let clength = gen_constant Structures.init_modules "length" +let clist = gen_constant CoqInterface.init_modules "list" +let cnil = gen_constant CoqInterface.init_modules "nil" +let ccons = gen_constant CoqInterface.init_modules "cons" +let clength = gen_constant CoqInterface.init_modules "length" (* Option *) -let coption = gen_constant Structures.init_modules "option" -let cSome = gen_constant Structures.init_modules "Some" -let cNone = gen_constant Structures.init_modules "None" +let coption = gen_constant CoqInterface.init_modules "option" +let cSome = gen_constant CoqInterface.init_modules "Some" +let cNone = gen_constant CoqInterface.init_modules "None" (* Pairs *) -let cpair = gen_constant Structures.init_modules "pair" -let cprod = gen_constant Structures.init_modules "prod" +let cpair = gen_constant CoqInterface.init_modules "pair" +let cprod = gen_constant CoqInterface.init_modules "prod" (* Dependent pairs *) -let csigT = gen_constant Structures.init_modules "sigT" -(* let cprojT1 = gen_constant Structures.init_modules "projT1" *) -(* let cprojT2 = gen_constant Structures.init_modules "projT2" *) -(* let cprojT3 = gen_constant Structures.init_modules "projT3" *) +let csigT = gen_constant CoqInterface.init_modules "sigT" +(* let cprojT1 = gen_constant CoqInterface.init_modules "projT1" *) +(* let cprojT2 = gen_constant CoqInterface.init_modules "projT2" *) +(* let cprojT3 = gen_constant CoqInterface.init_modules "projT3" *) -(* let csigT2 = gen_constant Structures.init_modules "sigT2" *) -(* let csigT_of_sigT2 = gen_constant Structures.init_modules "sigT_of_sigT2" *) +(* let csigT2 = gen_constant CoqInterface.init_modules "sigT2" *) +(* let csigT_of_sigT2 = gen_constant CoqInterface.init_modules "sigT_of_sigT2" *) (* Logical Operators *) -let cnot = gen_constant Structures.init_modules "not" -let ceq = gen_constant Structures.init_modules "eq" -let crefl_equal = gen_constant Structures.init_modules "eq_refl" -let cconj = gen_constant Structures.init_modules "conj" -let cand = gen_constant Structures.init_modules "and" +let cnot = gen_constant CoqInterface.init_modules "not" +let ceq = gen_constant CoqInterface.init_modules "eq" +let crefl_equal = gen_constant CoqInterface.init_modules "eq_refl" +let cconj = gen_constant CoqInterface.init_modules "conj" +let cand = gen_constant CoqInterface.init_modules "and" (* Bit vectors *) let bv_modules = [["SMTCoq";"bva";"BVList";"BITVECTOR_LIST"]] @@ -306,8 +306,8 @@ let ceq_refl_true = let eq_refl_true () = Lazy.force ceq_refl_true let vm_cast_true_no_check t = - Structures.mkCast(eq_refl_true (), - Structures.vmcast, + CoqInterface.mkCast(eq_refl_true (), + CoqInterface.vmcast, mklApp ceq [|Lazy.force cbool; t; Lazy.force ctrue|]) (* This version checks convertibility right away instead of delaying it at @@ -315,13 +315,13 @@ let vm_cast_true_no_check t = SMTCoq's tactics. *) let vm_cast_true env t = try - Structures.vm_conv Reduction.CUMUL env + CoqInterface.vm_conv Reduction.CUMUL env (mklApp ceq [|Lazy.force cbool; Lazy.force ctrue; Lazy.force ctrue|]) (mklApp ceq [|Lazy.force cbool; t; Lazy.force ctrue|]); vm_cast_true_no_check t with Reduction.NotConvertible -> - Structures.error ("SMTCoq was not able to check the proof certificate.") + CoqInterface.error ("SMTCoq was not able to check the proof certificate.") (* Compute a nat *) @@ -355,39 +355,39 @@ let rec mk_bv_list = function (* Reification *) let mk_bool b = - let c, args = Structures.decompose_app b in - if Structures.eq_constr c (Lazy.force ctrue) then true - else if Structures.eq_constr c (Lazy.force cfalse) then false + let c, args = CoqInterface.decompose_app b in + if CoqInterface.eq_constr c (Lazy.force ctrue) then true + else if CoqInterface.eq_constr c (Lazy.force cfalse) then false else assert false let rec mk_bool_list bs = - let c, args = Structures.decompose_app bs in - if Structures.eq_constr c (Lazy.force cnil) then [] - else if Structures.eq_constr c (Lazy.force ccons) then + let c, args = CoqInterface.decompose_app bs in + if CoqInterface.eq_constr c (Lazy.force cnil) then [] + else if CoqInterface.eq_constr c (Lazy.force ccons) then match args with | [_; b; bs] -> mk_bool b :: mk_bool_list bs | _ -> assert false else assert false let rec mk_nat n = - let c, args = Structures.decompose_app n in - if Structures.eq_constr c (Lazy.force cO) then + let c, args = CoqInterface.decompose_app n in + if CoqInterface.eq_constr c (Lazy.force cO) then 0 - else if Structures.eq_constr c (Lazy.force cS) then + else if CoqInterface.eq_constr c (Lazy.force cS) then match args with | [n] -> (mk_nat n) + 1 | _ -> assert false else assert false let rec mk_positive n = - let c, args = Structures.decompose_app n in - if Structures.eq_constr c (Lazy.force cxH) then + let c, args = CoqInterface.decompose_app n in + if CoqInterface.eq_constr c (Lazy.force cxH) then 1 - else if Structures.eq_constr c (Lazy.force cxO) then + else if CoqInterface.eq_constr c (Lazy.force cxO) then match args with | [n] -> 2 * (mk_positive n) | _ -> assert false - else if Structures.eq_constr c (Lazy.force cxI) then + else if CoqInterface.eq_constr c (Lazy.force cxI) then match args with | [n] -> 2 * (mk_positive n) + 1 | _ -> assert false @@ -395,10 +395,10 @@ let rec mk_positive n = let mk_N n = - let c, args = Structures.decompose_app n in - if Structures.eq_constr c (Lazy.force cN0) then + let c, args = CoqInterface.decompose_app n in + if CoqInterface.eq_constr c (Lazy.force cN0) then 0 - else if Structures.eq_constr c (Lazy.force cNpos) then + else if CoqInterface.eq_constr c (Lazy.force cNpos) then match args with | [n] -> mk_positive n | _ -> assert false @@ -406,13 +406,13 @@ let mk_N n = let mk_Z n = - let c, args = Structures.decompose_app n in - if Structures.eq_constr c (Lazy.force cZ0) then 0 - else if Structures.eq_constr c (Lazy.force cZpos) then + let c, args = CoqInterface.decompose_app n in + if CoqInterface.eq_constr c (Lazy.force cZ0) then 0 + else if CoqInterface.eq_constr c (Lazy.force cZpos) then match args with | [n] -> mk_positive n | _ -> assert false - else if Structures.eq_constr c (Lazy.force cZneg) then + else if CoqInterface.eq_constr c (Lazy.force cZneg) then match args with | [n] -> - mk_positive n | _ -> assert false @@ -421,12 +421,12 @@ let mk_Z n = (* size of bivectors are either N.of_nat (length l) or an N *) let mk_bvsize n = - let c, args = Structures.decompose_app n in - if Structures.eq_constr c (Lazy.force cof_nat) then + let c, args = CoqInterface.decompose_app n in + if CoqInterface.eq_constr c (Lazy.force cof_nat) then match args with | [nl] -> - let c, args = Structures.decompose_app nl in - if Structures.eq_constr c (Lazy.force clength) then + let c, args = CoqInterface.decompose_app nl in + if CoqInterface.eq_constr c (Lazy.force clength) then match args with | [_; l] -> List.length (mk_bool_list l) | _ -> assert false @@ -437,7 +437,7 @@ let mk_bvsize n = (** Switches between constr and OCaml *) (* Transform a option constr into a constr option *) let option_of_constr_option co = - let c, args = Structures.decompose_app co in + let c, args = CoqInterface.decompose_app co in if c = Lazy.force cSome then match args with | [_;c] -> Some c @@ -448,7 +448,7 @@ let option_of_constr_option co = (* Transform a tuple of constr into a (reversed) list of constr *) let list_of_constr_tuple = let rec list_of_constr_tuple acc t = - let c, args = Structures.decompose_app t in + let c, args = CoqInterface.decompose_app t in if c = Lazy.force cpair then match args with | [_;_;t1;t2] -> diff --git a/src/trace/coqTerms.mli b/src/trace/coqTerms.mli index 282f8f6..92acbb6 100644 --- a/src/trace/coqTerms.mli +++ b/src/trace/coqTerms.mli @@ -10,258 +10,258 @@ (**************************************************************************) -val gen_constant : string list list -> string -> Structures.constr lazy_t +val gen_constant : string list list -> string -> CoqInterface.constr lazy_t (* Int63 *) -val cint : Structures.constr lazy_t -val ceq63 : Structures.constr lazy_t +val cint : CoqInterface.constr lazy_t +val ceq63 : CoqInterface.constr lazy_t (* PArray *) -val carray : Structures.constr lazy_t +val carray : CoqInterface.constr lazy_t (* nat *) -val cnat : Structures.constr lazy_t -val cO : Structures.constr lazy_t -val cS : Structures.constr lazy_t +val cnat : CoqInterface.constr lazy_t +val cO : CoqInterface.constr lazy_t +val cS : CoqInterface.constr lazy_t (* Positive *) -val cpositive : Structures.constr lazy_t -val cxI : Structures.constr lazy_t -val cxO : Structures.constr lazy_t -val cxH : Structures.constr lazy_t -val ceqbP : Structures.constr lazy_t +val cpositive : CoqInterface.constr lazy_t +val cxI : CoqInterface.constr lazy_t +val cxO : CoqInterface.constr lazy_t +val cxH : CoqInterface.constr lazy_t +val ceqbP : CoqInterface.constr lazy_t (* N *) -val cN : Structures.constr lazy_t -val cN0 : Structures.constr lazy_t -val cNpos : Structures.constr lazy_t -val cof_nat : Structures.constr lazy_t +val cN : CoqInterface.constr lazy_t +val cN0 : CoqInterface.constr lazy_t +val cNpos : CoqInterface.constr lazy_t +val cof_nat : CoqInterface.constr lazy_t (* Z *) -val cZ : Structures.constr lazy_t -val cZ0 : Structures.constr lazy_t -val cZpos : Structures.constr lazy_t -val cZneg : Structures.constr lazy_t -val copp : Structures.constr lazy_t -val cadd : Structures.constr lazy_t -val csub : Structures.constr lazy_t -val cmul : Structures.constr lazy_t -val cltb : Structures.constr lazy_t -val cleb : Structures.constr lazy_t -val cgeb : Structures.constr lazy_t -val cgtb : Structures.constr lazy_t -val ceqbZ : Structures.constr lazy_t +val cZ : CoqInterface.constr lazy_t +val cZ0 : CoqInterface.constr lazy_t +val cZpos : CoqInterface.constr lazy_t +val cZneg : CoqInterface.constr lazy_t +val copp : CoqInterface.constr lazy_t +val cadd : CoqInterface.constr lazy_t +val csub : CoqInterface.constr lazy_t +val cmul : CoqInterface.constr lazy_t +val cltb : CoqInterface.constr lazy_t +val cleb : CoqInterface.constr lazy_t +val cgeb : CoqInterface.constr lazy_t +val cgtb : CoqInterface.constr lazy_t +val ceqbZ : CoqInterface.constr lazy_t (* Booleans *) -val cbool : Structures.constr lazy_t -val ctrue : Structures.constr lazy_t -val cfalse : Structures.constr lazy_t -val candb : Structures.constr lazy_t -val corb : Structures.constr lazy_t -val cxorb : Structures.constr lazy_t -val cnegb : Structures.constr lazy_t -val cimplb : Structures.constr lazy_t -val ceqb : Structures.constr lazy_t -val cifb : Structures.constr lazy_t -val ciff : Structures.constr lazy_t -val creflect : Structures.constr lazy_t +val cbool : CoqInterface.constr lazy_t +val ctrue : CoqInterface.constr lazy_t +val cfalse : CoqInterface.constr lazy_t +val candb : CoqInterface.constr lazy_t +val corb : CoqInterface.constr lazy_t +val cxorb : CoqInterface.constr lazy_t +val cnegb : CoqInterface.constr lazy_t +val cimplb : CoqInterface.constr lazy_t +val ceqb : CoqInterface.constr lazy_t +val cifb : CoqInterface.constr lazy_t +val ciff : CoqInterface.constr lazy_t +val creflect : CoqInterface.constr lazy_t (* Lists *) -val clist : Structures.constr lazy_t -val cnil : Structures.constr lazy_t -val ccons : Structures.constr lazy_t -val clength : Structures.constr lazy_t +val clist : CoqInterface.constr lazy_t +val cnil : CoqInterface.constr lazy_t +val ccons : CoqInterface.constr lazy_t +val clength : CoqInterface.constr lazy_t (* Option *) -val coption : Structures.constr lazy_t -val cSome : Structures.constr lazy_t -val cNone : Structures.constr lazy_t +val coption : CoqInterface.constr lazy_t +val cSome : CoqInterface.constr lazy_t +val cNone : CoqInterface.constr lazy_t (* Pairs *) -val cpair : Structures.constr lazy_t -val cprod : Structures.constr lazy_t +val cpair : CoqInterface.constr lazy_t +val cprod : CoqInterface.constr lazy_t (* Dependent pairs *) -val csigT : Structures.constr lazy_t +val csigT : CoqInterface.constr lazy_t (* Logical Operators *) -val cnot : Structures.constr lazy_t -val ceq : Structures.constr lazy_t -val crefl_equal : Structures.constr lazy_t -val cconj : Structures.constr lazy_t -val cand : Structures.constr lazy_t +val cnot : CoqInterface.constr lazy_t +val ceq : CoqInterface.constr lazy_t +val crefl_equal : CoqInterface.constr lazy_t +val cconj : CoqInterface.constr lazy_t +val cand : CoqInterface.constr lazy_t (* Bit vectors *) -val cbitvector : Structures.constr lazy_t -val cof_bits : Structures.constr lazy_t -val cbitOf : Structures.constr lazy_t -val cbv_eq : Structures.constr lazy_t -val cbv_not : Structures.constr lazy_t -val cbv_neg : Structures.constr lazy_t -val cbv_and : Structures.constr lazy_t -val cbv_or : Structures.constr lazy_t -val cbv_xor : Structures.constr lazy_t -val cbv_add : Structures.constr lazy_t -val cbv_mult : Structures.constr lazy_t -val cbv_ult : Structures.constr lazy_t -val cbv_slt : Structures.constr lazy_t -val cbv_concat : Structures.constr lazy_t -val cbv_extr : Structures.constr lazy_t -val cbv_zextn : Structures.constr lazy_t -val cbv_sextn : Structures.constr lazy_t -val cbv_shl : Structures.constr lazy_t -val cbv_shr : Structures.constr lazy_t +val cbitvector : CoqInterface.constr lazy_t +val cof_bits : CoqInterface.constr lazy_t +val cbitOf : CoqInterface.constr lazy_t +val cbv_eq : CoqInterface.constr lazy_t +val cbv_not : CoqInterface.constr lazy_t +val cbv_neg : CoqInterface.constr lazy_t +val cbv_and : CoqInterface.constr lazy_t +val cbv_or : CoqInterface.constr lazy_t +val cbv_xor : CoqInterface.constr lazy_t +val cbv_add : CoqInterface.constr lazy_t +val cbv_mult : CoqInterface.constr lazy_t +val cbv_ult : CoqInterface.constr lazy_t +val cbv_slt : CoqInterface.constr lazy_t +val cbv_concat : CoqInterface.constr lazy_t +val cbv_extr : CoqInterface.constr lazy_t +val cbv_zextn : CoqInterface.constr lazy_t +val cbv_sextn : CoqInterface.constr lazy_t +val cbv_shl : CoqInterface.constr lazy_t +val cbv_shr : CoqInterface.constr lazy_t (* Arrays *) -val cfarray : Structures.constr lazy_t -val cselect : Structures.constr lazy_t -val cstore : Structures.constr lazy_t -val cdiff : Structures.constr lazy_t -val cequalarray : Structures.constr lazy_t +val cfarray : CoqInterface.constr lazy_t +val cselect : CoqInterface.constr lazy_t +val cstore : CoqInterface.constr lazy_t +val cdiff : CoqInterface.constr lazy_t +val cequalarray : CoqInterface.constr lazy_t (* OrderedType *) (* SMT_terms *) -val cState_C_t : Structures.constr lazy_t -val cState_S_t : Structures.constr lazy_t - -val cdistinct : Structures.constr lazy_t - -val ctype : Structures.constr lazy_t -val cTZ : Structures.constr lazy_t -val cTbool : Structures.constr lazy_t -val cTpositive : Structures.constr lazy_t -val cTBV : Structures.constr lazy_t -val cTFArray : Structures.constr lazy_t -val cTindex : Structures.constr lazy_t - -val cinterp_t : Structures.constr lazy_t -val cdec_interp : Structures.constr lazy_t -val cord_interp : Structures.constr lazy_t -val ccomp_interp : Structures.constr lazy_t -val cinh_interp : Structures.constr lazy_t - -val cinterp_eqb : Structures.constr lazy_t - -val ctyp_compdec : Structures.constr lazy_t -val cTyp_compdec : Structures.constr lazy_t -val cunit_typ_compdec : Structures.constr lazy_t -val cte_carrier : Structures.constr lazy_t -val cte_compdec : Structures.constr lazy_t -val ceqb_of_compdec : Structures.constr lazy_t -val cCompDec : Structures.constr lazy_t - -val cbool_compdec : Structures.constr lazy_t -val cZ_compdec : Structures.constr lazy_t -val cPositive_compdec : Structures.constr lazy_t -val cBV_compdec : Structures.constr lazy_t -val cFArray_compdec : Structures.constr lazy_t - -val ctval : Structures.constr lazy_t -val cTval : Structures.constr lazy_t - -val cCO_xH : Structures.constr lazy_t -val cCO_Z0 : Structures.constr lazy_t -val cCO_BV : Structures.constr lazy_t - -val cUO_xO : Structures.constr lazy_t -val cUO_xI : Structures.constr lazy_t -val cUO_Zpos : Structures.constr lazy_t -val cUO_Zneg : Structures.constr lazy_t -val cUO_Zopp : Structures.constr lazy_t -val cUO_BVbitOf : Structures.constr lazy_t -val cUO_BVnot : Structures.constr lazy_t -val cUO_BVneg : Structures.constr lazy_t -val cUO_BVextr : Structures.constr lazy_t -val cUO_BVzextn : Structures.constr lazy_t -val cUO_BVsextn : Structures.constr lazy_t - -val cBO_Zplus : Structures.constr lazy_t -val cBO_Zminus : Structures.constr lazy_t -val cBO_Zmult : Structures.constr lazy_t -val cBO_Zlt : Structures.constr lazy_t -val cBO_Zle : Structures.constr lazy_t -val cBO_Zge : Structures.constr lazy_t -val cBO_Zgt : Structures.constr lazy_t -val cBO_eq : Structures.constr lazy_t -val cBO_BVand : Structures.constr lazy_t -val cBO_BVor : Structures.constr lazy_t -val cBO_BVxor : Structures.constr lazy_t -val cBO_BVadd : Structures.constr lazy_t -val cBO_BVmult : Structures.constr lazy_t -val cBO_BVult : Structures.constr lazy_t -val cBO_BVslt : Structures.constr lazy_t -val cBO_BVconcat : Structures.constr lazy_t -val cBO_BVshl : Structures.constr lazy_t -val cBO_BVshr : Structures.constr lazy_t -val cBO_select : Structures.constr lazy_t -val cBO_diffarray : Structures.constr lazy_t - -val cTO_store : Structures.constr lazy_t - -val cNO_distinct : Structures.constr lazy_t - -val catom : Structures.constr lazy_t -val cAcop : Structures.constr lazy_t -val cAuop : Structures.constr lazy_t -val cAbop : Structures.constr lazy_t -val cAtop : Structures.constr lazy_t -val cAnop : Structures.constr lazy_t -val cAapp : Structures.constr lazy_t - -val cform : Structures.constr lazy_t -val cFatom : Structures.constr lazy_t -val cFtrue : Structures.constr lazy_t -val cFfalse : Structures.constr lazy_t -val cFnot2 : Structures.constr lazy_t -val cFand : Structures.constr lazy_t -val cFor : Structures.constr lazy_t -val cFxor : Structures.constr lazy_t -val cFimp : Structures.constr lazy_t -val cFiff : Structures.constr lazy_t -val cFite : Structures.constr lazy_t -val cFbbT : Structures.constr lazy_t - -val cis_true : Structures.constr lazy_t - -val cvalid_sat_checker : Structures.constr lazy_t -val cinterp_var_sat_checker : Structures.constr lazy_t +val cState_C_t : CoqInterface.constr lazy_t +val cState_S_t : CoqInterface.constr lazy_t + +val cdistinct : CoqInterface.constr lazy_t + +val ctype : CoqInterface.constr lazy_t +val cTZ : CoqInterface.constr lazy_t +val cTbool : CoqInterface.constr lazy_t +val cTpositive : CoqInterface.constr lazy_t +val cTBV : CoqInterface.constr lazy_t +val cTFArray : CoqInterface.constr lazy_t +val cTindex : CoqInterface.constr lazy_t + +val cinterp_t : CoqInterface.constr lazy_t +val cdec_interp : CoqInterface.constr lazy_t +val cord_interp : CoqInterface.constr lazy_t +val ccomp_interp : CoqInterface.constr lazy_t +val cinh_interp : CoqInterface.constr lazy_t + +val cinterp_eqb : CoqInterface.constr lazy_t + +val ctyp_compdec : CoqInterface.constr lazy_t +val cTyp_compdec : CoqInterface.constr lazy_t +val cunit_typ_compdec : CoqInterface.constr lazy_t +val cte_carrier : CoqInterface.constr lazy_t +val cte_compdec : CoqInterface.constr lazy_t +val ceqb_of_compdec : CoqInterface.constr lazy_t +val cCompDec : CoqInterface.constr lazy_t + +val cbool_compdec : CoqInterface.constr lazy_t +val cZ_compdec : CoqInterface.constr lazy_t +val cPositive_compdec : CoqInterface.constr lazy_t +val cBV_compdec : CoqInterface.constr lazy_t +val cFArray_compdec : CoqInterface.constr lazy_t + +val ctval : CoqInterface.constr lazy_t +val cTval : CoqInterface.constr lazy_t + +val cCO_xH : CoqInterface.constr lazy_t +val cCO_Z0 : CoqInterface.constr lazy_t +val cCO_BV : CoqInterface.constr lazy_t + +val cUO_xO : CoqInterface.constr lazy_t +val cUO_xI : CoqInterface.constr lazy_t +val cUO_Zpos : CoqInterface.constr lazy_t +val cUO_Zneg : CoqInterface.constr lazy_t +val cUO_Zopp : CoqInterface.constr lazy_t +val cUO_BVbitOf : CoqInterface.constr lazy_t +val cUO_BVnot : CoqInterface.constr lazy_t +val cUO_BVneg : CoqInterface.constr lazy_t +val cUO_BVextr : CoqInterface.constr lazy_t +val cUO_BVzextn : CoqInterface.constr lazy_t +val cUO_BVsextn : CoqInterface.constr lazy_t + +val cBO_Zplus : CoqInterface.constr lazy_t +val cBO_Zminus : CoqInterface.constr lazy_t +val cBO_Zmult : CoqInterface.constr lazy_t +val cBO_Zlt : CoqInterface.constr lazy_t +val cBO_Zle : CoqInterface.constr lazy_t +val cBO_Zge : CoqInterface.constr lazy_t +val cBO_Zgt : CoqInterface.constr lazy_t +val cBO_eq : CoqInterface.constr lazy_t +val cBO_BVand : CoqInterface.constr lazy_t +val cBO_BVor : CoqInterface.constr lazy_t +val cBO_BVxor : CoqInterface.constr lazy_t +val cBO_BVadd : CoqInterface.constr lazy_t +val cBO_BVmult : CoqInterface.constr lazy_t +val cBO_BVult : CoqInterface.constr lazy_t +val cBO_BVslt : CoqInterface.constr lazy_t +val cBO_BVconcat : CoqInterface.constr lazy_t +val cBO_BVshl : CoqInterface.constr lazy_t +val cBO_BVshr : CoqInterface.constr lazy_t +val cBO_select : CoqInterface.constr lazy_t +val cBO_diffarray : CoqInterface.constr lazy_t + +val cTO_store : CoqInterface.constr lazy_t + +val cNO_distinct : CoqInterface.constr lazy_t + +val catom : CoqInterface.constr lazy_t +val cAcop : CoqInterface.constr lazy_t +val cAuop : CoqInterface.constr lazy_t +val cAbop : CoqInterface.constr lazy_t +val cAtop : CoqInterface.constr lazy_t +val cAnop : CoqInterface.constr lazy_t +val cAapp : CoqInterface.constr lazy_t + +val cform : CoqInterface.constr lazy_t +val cFatom : CoqInterface.constr lazy_t +val cFtrue : CoqInterface.constr lazy_t +val cFfalse : CoqInterface.constr lazy_t +val cFnot2 : CoqInterface.constr lazy_t +val cFand : CoqInterface.constr lazy_t +val cFor : CoqInterface.constr lazy_t +val cFxor : CoqInterface.constr lazy_t +val cFimp : CoqInterface.constr lazy_t +val cFiff : CoqInterface.constr lazy_t +val cFite : CoqInterface.constr lazy_t +val cFbbT : CoqInterface.constr lazy_t + +val cis_true : CoqInterface.constr lazy_t + +val cvalid_sat_checker : CoqInterface.constr lazy_t +val cinterp_var_sat_checker : CoqInterface.constr lazy_t val make_certif_ops : string list list -> - Structures.constr array option -> - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t + CoqInterface.constr array option -> + CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * + CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * + CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * + CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * + CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * + CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * + CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * + CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * + CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * + CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * + CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * + CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * + CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * CoqInterface.constr lazy_t * + CoqInterface.constr lazy_t * CoqInterface.constr lazy_t (* Some constructions *) -val ceq_refl_true : Structures.constr lazy_t -val eq_refl_true : unit -> Structures.constr -val vm_cast_true_no_check : Structures.constr -> Structures.constr -val vm_cast_true : Environ.env -> Structures.constr -> Structures.constr -val mkNat : int -> Structures.constr -val mkN : int -> Structures.constr -val mk_bv_list : bool list -> Structures.constr +val ceq_refl_true : CoqInterface.constr lazy_t +val eq_refl_true : unit -> CoqInterface.constr +val vm_cast_true_no_check : CoqInterface.constr -> CoqInterface.constr +val vm_cast_true : Environ.env -> CoqInterface.constr -> CoqInterface.constr +val mkNat : int -> CoqInterface.constr +val mkN : int -> CoqInterface.constr +val mk_bv_list : bool list -> CoqInterface.constr (* Reification *) -val mk_bool : Structures.constr -> bool -val mk_bool_list : Structures.constr -> bool list -val mk_nat : Structures.constr -> int -val mk_N : Structures.constr -> int -val mk_Z : Structures.constr -> int -val mk_bvsize : Structures.constr -> int +val mk_bool : CoqInterface.constr -> bool +val mk_bool_list : CoqInterface.constr -> bool list +val mk_nat : CoqInterface.constr -> int +val mk_N : CoqInterface.constr -> int +val mk_Z : CoqInterface.constr -> int +val mk_bvsize : CoqInterface.constr -> int (* Switches between constr and OCaml *) -val option_of_constr_option : Structures.constr -> Structures.constr option -val list_of_constr_tuple : Structures.constr -> Structures.constr list +val option_of_constr_option : CoqInterface.constr -> CoqInterface.constr option +val list_of_constr_tuple : CoqInterface.constr -> CoqInterface.constr list diff --git a/src/trace/satAtom.ml b/src/trace/satAtom.ml index 6ffd752..0296c88 100644 --- a/src/trace/satAtom.ml +++ b/src/trace/satAtom.ml @@ -27,7 +27,7 @@ module Atom = type reify_tbl = { mutable count : int; - tbl : (Structures.constr, int) Hashtbl.t + tbl : (CoqInterface.constr, int) Hashtbl.t } let create () = @@ -51,7 +51,7 @@ module Atom = t let interp_tbl reify = - Structures.mkArray (Lazy.force cbool, atom_tbl reify) + CoqInterface.mkArray (Lazy.force cbool, atom_tbl reify) let logic _ = SL.empty diff --git a/src/trace/satAtom.mli b/src/trace/satAtom.mli index b6a8dea..311b147 100644 --- a/src/trace/satAtom.mli +++ b/src/trace/satAtom.mli @@ -23,13 +23,13 @@ module Atom : sig type reify_tbl = { mutable count : int; - tbl : (Structures.constr, t) Hashtbl.t; + tbl : (CoqInterface.constr, t) Hashtbl.t; } val create : unit -> reify_tbl - val declare : reify_tbl -> Structures.constr -> t - val get : reify_tbl -> Structures.constr -> t - val atom_tbl : reify_tbl -> Structures.constr array - val interp_tbl : reify_tbl -> Structures.constr + val declare : reify_tbl -> CoqInterface.constr -> t + val get : reify_tbl -> CoqInterface.constr -> t + val atom_tbl : reify_tbl -> CoqInterface.constr array + val interp_tbl : reify_tbl -> CoqInterface.constr end diff --git a/src/trace/smtAtom.ml b/src/trace/smtAtom.ml index 2710eb2..78f2eee 100644 --- a/src/trace/smtAtom.ml +++ b/src/trace/smtAtom.ml @@ -85,7 +85,7 @@ type nop = type op_def = { tparams : SmtBtype.btype array; tres : SmtBtype.btype; - op_val : Structures.constr } + op_val : CoqInterface.constr } type index = Index of int | Rel_name of string @@ -97,14 +97,14 @@ let destruct s (i, hval) = match i with | Rel_name _ -> failwith s let dummy_indexed_op i dom codom = - (i, {tparams = dom; tres = codom; op_val = Structures.mkProp}) + (i, {tparams = dom; tres = codom; op_val = CoqInterface.mkProp}) let indexed_op_index i = let index, _ = destruct "destruct on a Rel: called by indexed_op_index" i in index let debruijn_indexed_op i ty = - (Index i, {tparams = [||]; tres = ty; op_val = Structures.mkRel i}) + (Index i, {tparams = [||]; tres = ty; op_val = CoqInterface.mkRel i}) module Op = struct @@ -357,7 +357,7 @@ module Op = (* reify table *) type reify_tbl = { mutable count : int; - tbl : (Structures.constr, indexed_op) Hashtbl.t + tbl : (CoqInterface.constr, indexed_op) Hashtbl.t } let create () = @@ -385,7 +385,7 @@ module Op = let index, hval = destruct "destruct on a Rel: called by set in interp_tbl" op in t.(index) <- mk_Tval hval.tparams hval.tres hval.op_val in Hashtbl.iter set reify.tbl; - Structures.mkArray (tval, t) + CoqInterface.mkArray (tval, t) let to_list reify = let set _ op acc = @@ -713,7 +713,7 @@ module Atom = to_smt_atom (atom h) and to_smt_atom = function - | Acop (CO_BV bv) -> if List.length bv = 0 then Structures.error "Empty bit-vectors are not valid in SMT" else Format.fprintf fmt "#b%a" bv_to_smt bv + | Acop (CO_BV bv) -> if List.length bv = 0 then CoqInterface.error "Empty bit-vectors are not valid in SMT" else Format.fprintf fmt "#b%a" bv_to_smt bv | Acop _ as a -> to_smt_int fmt (compute_int a) | Auop (op,h) -> to_smt_uop op h | Abop (op,h1,h2) -> to_smt_bop op h1 h2 @@ -740,7 +740,7 @@ module Atom = Array.iter (fun bt -> SmtBtype.to_smt fmt bt; Format.fprintf fmt " ") bta; Format.fprintf fmt ") ( "; SmtBtype.to_smt fmt bt; - Format.fprintf fmt " ) ( %s )]" (Pp.string_of_ppcmds (Structures.pr_constr t)) + Format.fprintf fmt " ) ( %s )]" (Pp.string_of_ppcmds (CoqInterface.pr_constr t)) and to_smt_uop op h = match op with @@ -1107,8 +1107,8 @@ module Atom = else CCunknown_deps (gobble_of_coq_cst cc) with Not_found -> CCunknown in - let rec mk_hatom (h : Structures.constr) = - let c, args = Structures.decompose_app h in + let rec mk_hatom (h : CoqInterface.constr) = + let c, args = CoqInterface.decompose_app h in match get_cst c with | CCxH -> mk_cop CCxH args | CCZ0 -> mk_cop CCZ0 args @@ -1150,9 +1150,9 @@ module Atom = | CCselect -> mk_bop_select args | CCdiff -> mk_bop_diff args | CCstore -> mk_top_store args - | CCunknown -> mk_unknown c args (Structures.retyping_get_type_of env sigma h) + | CCunknown -> mk_unknown c args (CoqInterface.retyping_get_type_of env sigma h) | CCunknown_deps gobble -> - mk_unknown_deps c args (Structures.retyping_get_type_of env sigma h) gobble + mk_unknown_deps c args (CoqInterface.retyping_get_type_of env sigma h) gobble and mk_cop op args = match op, args with @@ -1343,10 +1343,10 @@ module Atom = let rec collect_types = function | [] -> ([],[]) | x::xs as l -> - let ty = Structures.retyping_get_type_of env sigma x in + let ty = CoqInterface.retyping_get_type_of env sigma x in if Constr.iskind ty || - let c, _ = Structures.decompose_app ty in - Structures.eq_constr c (Lazy.force cCompDec) + let c, _ = CoqInterface.decompose_app ty in + CoqInterface.eq_constr c (Lazy.force cCompDec) then let (l1, l2) = collect_types xs in (x::l1, l2) @@ -1365,10 +1365,10 @@ module Atom = with | Not_found -> let targs = Array.map type_of hargs in let tres = SmtBtype.of_coq rt known_logic ty in - let os = if Structures.isRel c then - let i = Structures.destRel c in - let n, _ = Structures.destruct_rel_decl (Environ.lookup_rel i env) in - Some (Structures.string_of_name n) + let os = if CoqInterface.isRel c then + let i = CoqInterface.destRel c in + let n, _ = CoqInterface.destruct_rel_decl (Environ.lookup_rel i env) in + Some (CoqInterface.string_of_name n) else if Vars.closed0 c then None else @@ -1391,7 +1391,7 @@ module Atom = [gobble] *) and mk_unknown_deps c args ty gobble = let deps, args = split_list_at gobble args in - let c = Structures.mkApp (c, Array.of_list deps) in + let c = CoqInterface.mkApp (c, Array.of_list deps) in mk_unknown c args ty in @@ -1432,7 +1432,7 @@ module Atom = let interp_tbl reify = let t = to_array reify (Lazy.force dft_atom) a_to_coq in - Structures.mkArray (Lazy.force catom, t) + CoqInterface.mkArray (Lazy.force catom, t) (** Producing a Coq term corresponding to the interpretation of an atom *) @@ -1444,12 +1444,12 @@ module Atom = let pc = match atom a with | Acop c -> Op.interp_cop c - | Auop (op,h) -> Structures.mkApp (Op.interp_uop op, [|interp_atom h|]) + | Auop (op,h) -> CoqInterface.mkApp (Op.interp_uop op, [|interp_atom h|]) | Abop (op,h1,h2) -> - Structures.mkApp (Op.interp_bop t_i op, + CoqInterface.mkApp (Op.interp_bop t_i op, [|interp_atom h1; interp_atom h2|]) | Atop (op,h1,h2,h3) -> - Structures.mkApp (Op.interp_top t_i op, + CoqInterface.mkApp (Op.interp_top t_i op, [|interp_atom h1; interp_atom h2; interp_atom h3|]) | Anop (NO_distinct ty as op,ha) -> let cop = Op.interp_nop t_i op in @@ -1457,9 +1457,9 @@ module Atom = let cargs = Array.fold_right (fun h l -> mklApp ccons [|typ; interp_atom h; l|]) ha (mklApp cnil [|typ|]) in - Structures.mkApp (cop,[|cargs|]) + CoqInterface.mkApp (cop,[|cargs|]) | Aapp (op,t) -> - Structures.mkApp ((snd op).op_val, Array.map interp_atom t) in + CoqInterface.mkApp ((snd op).op_val, Array.map interp_atom t) in Hashtbl.add atom_tbl l pc; pc in interp_atom a diff --git a/src/trace/smtAtom.mli b/src/trace/smtAtom.mli index 645a638..27737ff 100644 --- a/src/trace/smtAtom.mli +++ b/src/trace/smtAtom.mli @@ -76,14 +76,14 @@ module Op : val create : unit -> reify_tbl - val declare : reify_tbl -> Structures.constr -> btype array -> + val declare : reify_tbl -> CoqInterface.constr -> btype array -> btype -> string option -> indexed_op - val of_coq : reify_tbl -> Structures.constr -> indexed_op + val of_coq : reify_tbl -> CoqInterface.constr -> indexed_op - val interp_tbl : Structures.constr -> - (btype array -> btype -> Structures.constr -> Structures.constr) -> - reify_tbl -> Structures.constr + val interp_tbl : CoqInterface.constr -> + (btype array -> btype -> CoqInterface.constr -> CoqInterface.constr) -> + reify_tbl -> CoqInterface.constr val to_list : reify_tbl -> (int * (btype array) * btype * indexed_op) list @@ -142,18 +142,18 @@ module Atom : (** Given a coq term, build the corresponding atom *) exception UnknownUnderForall val of_coq : ?eqsym:bool -> SmtBtype.reify_tbl -> Op.reify_tbl -> - reify_tbl -> SmtMisc.logic -> Environ.env -> Evd.evar_map -> Structures.constr -> t + reify_tbl -> SmtMisc.logic -> Environ.env -> Evd.evar_map -> CoqInterface.constr -> t - val get_coq_term_op : int -> Structures.constr + val get_coq_term_op : int -> CoqInterface.constr - val to_coq : t -> Structures.constr + val to_coq : t -> CoqInterface.constr val to_array : reify_tbl -> 'a -> (atom -> 'a) -> 'a array - val interp_tbl : reify_tbl -> Structures.constr + val interp_tbl : reify_tbl -> CoqInterface.constr - val interp_to_coq : Structures.constr -> (int, Structures.constr) Hashtbl.t -> - t -> Structures.constr + val interp_to_coq : CoqInterface.constr -> (int, CoqInterface.constr) Hashtbl.t -> + t -> CoqInterface.constr val logic : t -> SmtMisc.logic @@ -201,5 +201,5 @@ module Trace : sig end -val make_t_i : SmtBtype.reify_tbl -> Structures.constr -val make_t_func : Op.reify_tbl -> Structures.constr -> Structures.constr +val make_t_i : SmtBtype.reify_tbl -> CoqInterface.constr +val make_t_func : Op.reify_tbl -> CoqInterface.constr -> CoqInterface.constr diff --git a/src/trace/smtBtype.ml b/src/trace/smtBtype.ml index 3b6d107..c9aad70 100644 --- a/src/trace/smtBtype.ml +++ b/src/trace/smtBtype.ml @@ -19,7 +19,7 @@ type uninterpreted_type = (* Uninterpreted type for which a CompDec is already known The constr is of type typ_compdec *) - | CompDec of Structures.constr + | CompDec of CoqInterface.constr (* Uninterpreted type for which the knowledge of a CompDec is delayed until either: - one is used @@ -27,11 +27,11 @@ type uninterpreted_type = via a cut The constr is of type Type *) - | Delayed of Structures.constr + | Delayed of CoqInterface.constr type indexed_type = uninterpreted_type gen_hashed -let dummy_indexed_type i = {index = i; hval = Delayed (Structures.mkProp)} +let dummy_indexed_type i = {index = i; hval = Delayed (CoqInterface.mkProp)} let indexed_type_index i = i.index let indexed_type_compdec i = match i.hval with @@ -105,8 +105,8 @@ let rec logic = function (* reify table *) type reify_tbl = { mutable count : int; - tbl : (Structures.constr, btype) Hashtbl.t; - mutable cuts : (Structures.id * Structures.types) list; + tbl : (CoqInterface.constr, btype) Hashtbl.t; + mutable cuts : (CoqInterface.id * CoqInterface.types) list; unsup_tbl : (btype, btype) Hashtbl.t; } @@ -145,8 +145,8 @@ let interp_tbl reify = | CompDec compdec -> t.(it.index) <- compdec; Some bt | Delayed ty -> let n = string_of_int (List.length reify.cuts) in - let compdec_name = Structures.mkId ("CompDec"^n) in - let compdec_var = Structures.mkVar compdec_name in + let compdec_name = CoqInterface.mkId ("CompDec"^n) in + let compdec_var = CoqInterface.mkVar compdec_name in let compdec_type = mklApp cCompDec [| ty |] in reify.cuts <- (compdec_name, compdec_type) :: reify.cuts; let ce = mklApp cTyp_compdec [|ty; compdec_var|] in @@ -156,7 +156,7 @@ let interp_tbl reify = | _ -> Some bt in Hashtbl.filter_map_inplace set reify.tbl; - Structures.mkArray (Lazy.force ctyp_compdec, t) + CoqInterface.mkArray (Lazy.force ctyp_compdec, t) let to_list reify = @@ -241,8 +241,8 @@ let rec compdec_btype reify = function | Tindex i -> (match i.hval with | CompDec compdec -> - let c, args = Structures.decompose_app compdec in - if Structures.eq_constr c (Lazy.force cTyp_compdec) then + let c, args = CoqInterface.decompose_app compdec in + if CoqInterface.eq_constr c (Lazy.force cTyp_compdec) then match args with | [_; tic] -> tic | _ -> assert false @@ -264,22 +264,22 @@ let declare_and_compdec reify t ty = let rec of_coq reify known_logic t = try - let c, args = Structures.decompose_app t in - if Structures.eq_constr c (Lazy.force cbool) || - Structures.eq_constr c (Lazy.force cTbool) then Tbool - else if Structures.eq_constr c (Lazy.force cZ) || - Structures.eq_constr c (Lazy.force cTZ) then + let c, args = CoqInterface.decompose_app t in + if CoqInterface.eq_constr c (Lazy.force cbool) || + CoqInterface.eq_constr c (Lazy.force cTbool) then Tbool + else if CoqInterface.eq_constr c (Lazy.force cZ) || + CoqInterface.eq_constr c (Lazy.force cTZ) then check_known TZ known_logic - else if Structures.eq_constr c (Lazy.force cpositive) || - Structures.eq_constr c (Lazy.force cTpositive) then + else if CoqInterface.eq_constr c (Lazy.force cpositive) || + CoqInterface.eq_constr c (Lazy.force cTpositive) then check_known Tpositive known_logic - else if Structures.eq_constr c (Lazy.force cbitvector) || - Structures.eq_constr c (Lazy.force cTBV) then + else if CoqInterface.eq_constr c (Lazy.force cbitvector) || + CoqInterface.eq_constr c (Lazy.force cTBV) then match args with | [s] -> check_known (TBV (mk_bvsize s)) known_logic | _ -> assert false - else if Structures.eq_constr c (Lazy.force cfarray) || - Structures.eq_constr c (Lazy.force cTFArray) then + else if CoqInterface.eq_constr c (Lazy.force cfarray) || + CoqInterface.eq_constr c (Lazy.force cTFArray) then match args with | ti :: te :: _ -> let ty = TFArray (of_coq reify known_logic ti, diff --git a/src/trace/smtBtype.mli b/src/trace/smtBtype.mli index ec73d21..7060ab6 100644 --- a/src/trace/smtBtype.mli +++ b/src/trace/smtBtype.mli @@ -17,7 +17,7 @@ type indexed_type val dummy_indexed_type: int -> indexed_type val indexed_type_index : indexed_type -> int -val indexed_type_compdec : indexed_type -> Structures.constr +val indexed_type_compdec : indexed_type -> CoqInterface.constr type btype = | TZ @@ -31,7 +31,7 @@ val indexed_type_of_int : int -> indexed_type module HashedBtype : Hashtbl.HashedType with type t = btype -val to_coq : btype -> Structures.constr +val to_coq : btype -> CoqInterface.constr val to_smt : Format.formatter -> btype -> unit @@ -40,25 +40,25 @@ type reify_tbl val create : unit -> reify_tbl val copy : reify_tbl -> reify_tbl -val of_coq : reify_tbl -> logic -> Structures.constr -> btype -val of_coq_compdec : reify_tbl -> Structures.constr -> Structures.constr -> btype +val of_coq : reify_tbl -> logic -> CoqInterface.constr -> btype +val of_coq_compdec : reify_tbl -> CoqInterface.constr -> CoqInterface.constr -> btype -val get_coq_type_op : int -> Structures.constr +val get_coq_type_op : int -> CoqInterface.constr -val interp_tbl : reify_tbl -> Structures.constr +val interp_tbl : reify_tbl -> CoqInterface.constr val to_list : reify_tbl -> (int * indexed_type) list -val make_t_i : reify_tbl -> Structures.constr +val make_t_i : reify_tbl -> CoqInterface.constr -val dec_interp : Structures.constr -> btype -> Structures.constr -val ord_interp : Structures.constr -> btype -> Structures.constr -val comp_interp : Structures.constr -> btype -> Structures.constr -val inh_interp : Structures.constr -> btype -> Structures.constr -val interp : Structures.constr -> btype -> Structures.constr +val dec_interp : CoqInterface.constr -> btype -> CoqInterface.constr +val ord_interp : CoqInterface.constr -> btype -> CoqInterface.constr +val comp_interp : CoqInterface.constr -> btype -> CoqInterface.constr +val inh_interp : CoqInterface.constr -> btype -> CoqInterface.constr +val interp : CoqInterface.constr -> btype -> CoqInterface.constr -val interp_to_coq : reify_tbl -> btype -> Structures.constr +val interp_to_coq : reify_tbl -> btype -> CoqInterface.constr -val get_cuts : reify_tbl -> (Structures.id * Structures.types) list +val get_cuts : reify_tbl -> (CoqInterface.id * CoqInterface.types) list val logic : btype -> logic diff --git a/src/trace/smtCertif.ml b/src/trace/smtCertif.ml index 2ea4ca8..24cdf78 100644 --- a/src/trace/smtCertif.ml +++ b/src/trace/smtCertif.ml @@ -98,11 +98,11 @@ type 'hform rule = *) (* Linear arithmetic *) - | LiaMicromega of 'hform list * Structures.Micromega_plugin_Certificate.Mc.zArithProof list + | LiaMicromega of 'hform list * CoqInterface.Micromega_plugin_Certificate.Mc.zArithProof list | LiaDiseq of 'hform (* Arithmetic simplifications *) - | SplArith of 'hform clause * 'hform * Structures.Micromega_plugin_Certificate.Mc.zArithProof list + | SplArith of 'hform clause * 'hform * CoqInterface.Micromega_plugin_Certificate.Mc.zArithProof list (* Elimination of operators *) | SplDistinctElim of 'hform clause * 'hform diff --git a/src/trace/smtCertif.mli b/src/trace/smtCertif.mli index 7da3097..bc2da38 100644 --- a/src/trace/smtCertif.mli +++ b/src/trace/smtCertif.mli @@ -96,11 +96,11 @@ type 'hform rule = *) (* Linear arithmetic *) - | LiaMicromega of 'hform list * Structures.Micromega_plugin_Certificate.Mc.zArithProof list + | LiaMicromega of 'hform list * CoqInterface.Micromega_plugin_Certificate.Mc.zArithProof list | LiaDiseq of 'hform (* Arithmetic simplifications *) - | SplArith of 'hform clause * 'hform * Structures.Micromega_plugin_Certificate.Mc.zArithProof list + | SplArith of 'hform clause * 'hform * CoqInterface.Micromega_plugin_Certificate.Mc.zArithProof list (* Elimination of operators *) | SplDistinctElim of 'hform clause * 'hform diff --git a/src/trace/smtCommands.ml b/src/trace/smtCommands.ml index fa2a56b..e655a9d 100644 --- a/src/trace/smtCommands.ml +++ b/src/trace/smtCommands.ml @@ -115,7 +115,7 @@ let interp_conseq_uf t_i (prem, concl) = let tf = Hashtbl.create 17 in let rec interp = function | [] -> mklApp cis_true [|interp_uf t_i ta tf concl|] - | c::prem -> Structures.mkArrow (mklApp cis_true [|interp_uf t_i ta tf c|]) (interp prem) in + | c::prem -> CoqInterface.mkArrow (mklApp cis_true [|interp_uf t_i ta tf c|]) (interp prem) in interp prem @@ -127,26 +127,26 @@ let print_assm ty = let parse_certif t_i t_func t_atom t_form root used_root trace (rt, ro, ra, rf, roots, max_id, confl) = let t_i' = make_t_i rt in - let ce5 = Structures.mkUConst t_i' in - let ct_i = Structures.mkConst (Structures.declare_constant t_i ce5) in + let ce5 = CoqInterface.mkUConst t_i' in + let ct_i = CoqInterface.mkConst (CoqInterface.declare_constant t_i ce5) in let t_func' = make_t_func ro ct_i in - let ce6 = Structures.mkUConst t_func' in - let ct_func = Structures.mkConst (Structures.declare_constant t_func ce6) in + let ce6 = CoqInterface.mkUConst t_func' in + let ct_func = CoqInterface.mkConst (CoqInterface.declare_constant t_func ce6) in let t_atom' = Atom.interp_tbl ra in - let ce1 = Structures.mkUConst t_atom' in - let ct_atom = Structures.mkConst (Structures.declare_constant t_atom ce1) in + let ce1 = CoqInterface.mkUConst t_atom' in + let ct_atom = CoqInterface.mkConst (CoqInterface.declare_constant t_atom ce1) in let t_form' = snd (Form.interp_tbl rf) in - let ce2 = Structures.mkUConst t_form' in - let ct_form = Structures.mkConst (Structures.declare_constant t_form ce2) in + let ce2 = CoqInterface.mkUConst t_form' in + let ct_form = CoqInterface.mkConst (CoqInterface.declare_constant t_form ce2) in (* EMPTY LEMMA LIST *) let (tres, last_root, cuts) = SmtTrace.to_coq (fun i -> mkInt (Form.to_lit i)) (interp_conseq_uf ct_i) (certif_ops (Some [|ct_i; ct_func; ct_atom; ct_form|])) confl None in List.iter (fun (v,ty) -> - let _ = Structures.declare_new_variable v ty in + let _ = CoqInterface.declare_new_variable v ty in print_assm ty ) cuts; @@ -155,22 +155,22 @@ let parse_certif t_i t_func t_atom t_form root used_root trace (rt, ro, ra, rf, let res = Array.make (List.length roots + 1) (mkInt 0) in let i = ref 0 in List.iter (fun j -> res.(!i) <- mkInt (Form.to_lit j); incr i) roots; - Structures.mkArray (Lazy.force cint, res) in + CoqInterface.mkArray (Lazy.force cint, res) in let used_roots = let l = List.length used_roots in let res = Array.make (l + 1) (mkInt 0) in let i = ref (l-1) in List.iter (fun j -> res.(!i) <- mkInt j; decr i) used_roots; - mklApp cSome [|mklApp carray [|Lazy.force cint|]; Structures.mkArray (Lazy.force cint, res)|] in - let ce3 = Structures.mkUConst roots in - let _ = Structures.declare_constant root ce3 in - let ce3' = Structures.mkUConst used_roots in - let _ = Structures.declare_constant used_root ce3' in + mklApp cSome [|mklApp carray [|Lazy.force cint|]; CoqInterface.mkArray (Lazy.force cint, res)|] in + let ce3 = CoqInterface.mkUConst roots in + let _ = CoqInterface.declare_constant root ce3 in + let ce3' = CoqInterface.mkUConst used_roots in + let _ = CoqInterface.declare_constant used_root ce3' in let certif = mklApp cCertif [|ct_i; ct_func; ct_atom; ct_form; mkInt (max_id + 1); tres;mkInt (get_pos confl)|] in - let ce4 = Structures.mkUConst certif in - let _ = Structures.declare_constant trace ce4 in + let ce4 = CoqInterface.mkUConst certif in + let _ = CoqInterface.declare_constant trace ce4 in () @@ -184,15 +184,15 @@ let interp_roots t_i roots = | f::roots -> List.fold_left (fun acc f -> mklApp candb [|acc; interp f|]) (interp f) roots let theorem name (rt, ro, ra, rf, roots, max_id, confl) = - let nti = Structures.mkName "t_i" in - let ntfunc = Structures.mkName "t_func" in - let ntatom = Structures.mkName "t_atom" in - let ntform = Structures.mkName "t_form" in - let nc = Structures.mkName "c" in - let nused_roots = Structures.mkName "used_roots" in - let nd = Structures.mkName "d" in + let nti = CoqInterface.mkName "t_i" in + let ntfunc = CoqInterface.mkName "t_func" in + let ntatom = CoqInterface.mkName "t_atom" in + let ntform = CoqInterface.mkName "t_form" in + let nc = CoqInterface.mkName "c" in + let nused_roots = CoqInterface.mkName "used_roots" in + let nd = CoqInterface.mkName "d" in - let v = Structures.mkRel in + let v = CoqInterface.mkRel in let t_i = make_t_i rt in let t_func = make_t_func ro (v 1 (*t_i*)) in @@ -204,7 +204,7 @@ let theorem name (rt, ro, ra, rf, roots, max_id, confl) = (interp_conseq_uf t_i) (certif_ops (Some [|v 4(*t_i*); v 3(*t_func*); v 2(*t_atom*); v 1(* t_form *)|])) confl None in List.iter (fun (v,ty) -> - let _ = Structures.declare_new_variable v ty in + let _ = CoqInterface.declare_new_variable v ty in print_assm ty ) cuts; @@ -217,59 +217,59 @@ let theorem name (rt, ro, ra, rf, roots, max_id, confl) = let res = Array.make (l + 1) (mkInt 0) in let i = ref (l-1) in List.iter (fun j -> res.(!i) <- mkInt j; decr i) used_roots; - mklApp cSome [|mklApp carray [|Lazy.force cint|]; Structures.mkArray (Lazy.force cint, res)|] in + mklApp cSome [|mklApp carray [|Lazy.force cint|]; CoqInterface.mkArray (Lazy.force cint, res)|] in let rootsCstr = let res = Array.make (List.length roots + 1) (mkInt 0) in let i = ref 0 in List.iter (fun j -> res.(!i) <- mkInt (Form.to_lit j); incr i) roots; - Structures.mkArray (Lazy.force cint, res) in + CoqInterface.mkArray (Lazy.force cint, res) in let theorem_concl = mklApp cnot [|mklApp cis_true [|interp_roots t_i roots|]|] in let theorem_proof_cast = - Structures.mkCast ( - Structures.mkLetIn (nti, t_i, mklApp carray [|Lazy.force ctyp_compdec|], - Structures.mkLetIn (ntfunc, t_func, mklApp carray [|mklApp ctval [|v 1(* t_i *)|]|], - Structures.mkLetIn (ntatom, t_atom, mklApp carray [|Lazy.force catom|], - Structures.mkLetIn (ntform, t_form, mklApp carray [|Lazy.force cform|], - Structures.mkLetIn (nc, certif, mklApp ccertif [|v 4 (*t_i*); v 3 (*t_func*); v 2 (*t_atom*); v 1 (*t_form*)|], - Structures.mkLetIn (nused_roots, used_rootsCstr, mklApp coption [|mklApp carray [|Lazy.force cint|]|], - Structures.mkLetIn (nd, rootsCstr, mklApp carray [|Lazy.force cint|], + CoqInterface.mkCast ( + CoqInterface.mkLetIn (nti, t_i, mklApp carray [|Lazy.force ctyp_compdec|], + CoqInterface.mkLetIn (ntfunc, t_func, mklApp carray [|mklApp ctval [|v 1(* t_i *)|]|], + CoqInterface.mkLetIn (ntatom, t_atom, mklApp carray [|Lazy.force catom|], + CoqInterface.mkLetIn (ntform, t_form, mklApp carray [|Lazy.force cform|], + CoqInterface.mkLetIn (nc, certif, mklApp ccertif [|v 4 (*t_i*); v 3 (*t_func*); v 2 (*t_atom*); v 1 (*t_form*)|], + CoqInterface.mkLetIn (nused_roots, used_rootsCstr, mklApp coption [|mklApp carray [|Lazy.force cint|]|], + CoqInterface.mkLetIn (nd, rootsCstr, mklApp carray [|Lazy.force cint|], mklApp cchecker_correct [|v 7 (*t_i*); v 6 (*t_func*); v 5 (*t_atom*); v 4 (*t_form*); v 1 (*d*); v 2 (*used_roots*); v 3 (*c*); vm_cast_true_no_check (mklApp cchecker [|v 7 (*t_i*); v 6 (*t_func*); v 5 (*t_atom*); v 4 (*t_form*); v 1 (*d*); v 2 (*used_roots*); v 3 (*c*)|])|]))))))), - Structures.vmcast, + CoqInterface.vmcast, theorem_concl) in let theorem_proof_nocast = - Structures.mkLetIn (nti, t_i, mklApp carray [|Lazy.force ctyp_compdec|], - Structures.mkLetIn (ntfunc, t_func, mklApp carray [|mklApp ctval [|v 1(* t_i *)|]|], - Structures.mkLetIn (ntatom, t_atom, mklApp carray [|Lazy.force catom|], - Structures.mkLetIn (ntform, t_form, mklApp carray [|Lazy.force cform|], - Structures.mkLetIn (nc, certif, mklApp ccertif [|v 4 (*t_i*); v 3 (*t_func*); v 2 (*t_atom*); v 1 (*t_form*)|], - Structures.mkLetIn (nused_roots, used_rootsCstr, mklApp coption [|mklApp carray [|Lazy.force cint|]|], - Structures.mkLetIn (nd, rootsCstr, mklApp carray [|Lazy.force cint|], + CoqInterface.mkLetIn (nti, t_i, mklApp carray [|Lazy.force ctyp_compdec|], + CoqInterface.mkLetIn (ntfunc, t_func, mklApp carray [|mklApp ctval [|v 1(* t_i *)|]|], + CoqInterface.mkLetIn (ntatom, t_atom, mklApp carray [|Lazy.force catom|], + CoqInterface.mkLetIn (ntform, t_form, mklApp carray [|Lazy.force cform|], + CoqInterface.mkLetIn (nc, certif, mklApp ccertif [|v 4 (*t_i*); v 3 (*t_func*); v 2 (*t_atom*); v 1 (*t_form*)|], + CoqInterface.mkLetIn (nused_roots, used_rootsCstr, mklApp coption [|mklApp carray [|Lazy.force cint|]|], + CoqInterface.mkLetIn (nd, rootsCstr, mklApp carray [|Lazy.force cint|], mklApp cchecker_correct [|v 7 (*t_i*); v 6 (*t_func*); v 5 (*t_atom*); v 4 (*t_form*); v 1 (*d*); v 2 (*used_roots*); v 3 (*c*)|]))))))) in - let ce = Structures.mkTConst theorem_proof_cast theorem_proof_nocast theorem_concl in - let _ = Structures.declare_constant name ce in + let ce = CoqInterface.mkTConst theorem_proof_cast theorem_proof_nocast theorem_concl in + let _ = CoqInterface.declare_constant name ce in () (* Given an SMT-LIB2 file and a certif, call the checker *) let checker (rt, ro, ra, rf, roots, max_id, confl) = - let nti = Structures.mkName "t_i" in - let ntfunc = Structures.mkName "t_func" in - let ntatom = Structures.mkName "t_atom" in - let ntform = Structures.mkName "t_form" in - let nc = Structures.mkName "c" in - let nused_roots = Structures.mkName "used_roots" in - let nd = Structures.mkName "d" in + let nti = CoqInterface.mkName "t_i" in + let ntfunc = CoqInterface.mkName "t_func" in + let ntatom = CoqInterface.mkName "t_atom" in + let ntform = CoqInterface.mkName "t_form" in + let nc = CoqInterface.mkName "c" in + let nused_roots = CoqInterface.mkName "used_roots" in + let nd = CoqInterface.mkName "d" in - let v = Structures.mkRel in + let v = CoqInterface.mkRel in let t_i = make_t_i rt in let t_func = make_t_func ro (v 1 (*t_i*)) in @@ -281,7 +281,7 @@ let checker (rt, ro, ra, rf, roots, max_id, confl) = (interp_conseq_uf t_i) (certif_ops (Some [|v 4(*t_i*); v 3(*t_func*); v 2(*t_atom*); v 1(* t_form *)|])) confl None in List.iter (fun (v,ty) -> - let _ = Structures.declare_new_variable v ty in + let _ = CoqInterface.declare_new_variable v ty in print_assm ty ) cuts; @@ -294,26 +294,26 @@ let checker (rt, ro, ra, rf, roots, max_id, confl) = let res = Array.make (l + 1) (mkInt 0) in let i = ref (l-1) in List.iter (fun j -> res.(!i) <- mkInt j; decr i) used_roots; - mklApp cSome [|mklApp carray [|Lazy.force cint|]; Structures.mkArray (Lazy.force cint, res)|] in + mklApp cSome [|mklApp carray [|Lazy.force cint|]; CoqInterface.mkArray (Lazy.force cint, res)|] in let rootsCstr = let res = Array.make (List.length roots + 1) (mkInt 0) in let i = ref 0 in List.iter (fun j -> res.(!i) <- mkInt (Form.to_lit j); incr i) roots; - Structures.mkArray (Lazy.force cint, res) in + CoqInterface.mkArray (Lazy.force cint, res) in let tm = - Structures.mkLetIn (nti, t_i, mklApp carray [|Lazy.force ctyp_compdec|], - Structures.mkLetIn (ntfunc, t_func, mklApp carray [|mklApp ctval [|v 1(* t_i *)|]|], - Structures.mkLetIn (ntatom, t_atom, mklApp carray [|Lazy.force catom|], - Structures.mkLetIn (ntform, t_form, mklApp carray [|Lazy.force cform|], - Structures.mkLetIn (nc, certif, mklApp ccertif [|v 4 (*t_i*); v 3 (*t_func*); v 2 (*t_atom*); v 1 (*t_form*)|], - Structures.mkLetIn (nused_roots, used_rootsCstr, mklApp coption [|mklApp carray [|Lazy.force cint|]|], - Structures.mkLetIn (nd, rootsCstr, mklApp carray [|Lazy.force cint|], + CoqInterface.mkLetIn (nti, t_i, mklApp carray [|Lazy.force ctyp_compdec|], + CoqInterface.mkLetIn (ntfunc, t_func, mklApp carray [|mklApp ctval [|v 1(* t_i *)|]|], + CoqInterface.mkLetIn (ntatom, t_atom, mklApp carray [|Lazy.force catom|], + CoqInterface.mkLetIn (ntform, t_form, mklApp carray [|Lazy.force cform|], + CoqInterface.mkLetIn (nc, certif, mklApp ccertif [|v 4 (*t_i*); v 3 (*t_func*); v 2 (*t_atom*); v 1 (*t_form*)|], + CoqInterface.mkLetIn (nused_roots, used_rootsCstr, mklApp coption [|mklApp carray [|Lazy.force cint|]|], + CoqInterface.mkLetIn (nd, rootsCstr, mklApp carray [|Lazy.force cint|], mklApp cchecker [|v 7 (*t_i*); v 6 (*t_func*); v 5 (*t_atom*); v 4 (*t_form*); v 1 (*d*); v 2 (*used_roots*); v 3 (*c*)|]))))))) in - let res = Structures.cbv_vm (Global.env ()) tm (Lazy.force CoqTerms.cbool) in + let res = CoqInterface.cbv_vm (Global.env ()) tm (Lazy.force CoqTerms.cbool) in Format.eprintf " = %s\n : bool@." - (if Structures.eq_constr res (Lazy.force CoqTerms.ctrue) then + (if CoqInterface.eq_constr res (Lazy.force CoqTerms.ctrue) then "true" else "false") let count_used confl = @@ -329,15 +329,15 @@ let count_used confl = let checker_debug (rt, ro, ra, rf, roots, max_id, confl) = - let nti = Structures.mkName "t_i" in - let ntfunc = Structures.mkName "t_func" in - let ntatom = Structures.mkName "t_atom" in - let ntform = Structures.mkName "t_form" in - let nc = Structures.mkName "c" in - let nused_roots = Structures.mkName "used_roots" in - let nd = Structures.mkName "d" in + let nti = CoqInterface.mkName "t_i" in + let ntfunc = CoqInterface.mkName "t_func" in + let ntatom = CoqInterface.mkName "t_atom" in + let ntform = CoqInterface.mkName "t_form" in + let nc = CoqInterface.mkName "c" in + let nused_roots = CoqInterface.mkName "used_roots" in + let nd = CoqInterface.mkName "d" in - let v = Structures.mkRel in + let v = CoqInterface.mkRel in let t_i = make_t_i rt in let t_func = make_t_func ro (v 1 (*t_i*)) in @@ -349,7 +349,7 @@ let checker_debug (rt, ro, ra, rf, roots, max_id, confl) = (certif_ops (Some [|v 4(*t_i*); v 3(*t_func*); v 2(*t_atom*); v 1(* t_form *)|])) confl None in List.iter (fun (v,ty) -> - let _ = Structures.declare_new_variable v ty in + let _ = CoqInterface.declare_new_variable v ty in print_assm ty ) cuts; @@ -364,84 +364,84 @@ let checker_debug (rt, ro, ra, rf, roots, max_id, confl) = let i = ref (l-1) in List.iter (fun j -> res.(!i) <- mkInt j; decr i) used_roots; mklApp cSome [|mklApp carray [|Lazy.force cint|]; - Structures.mkArray (Lazy.force cint, res)|] in + CoqInterface.mkArray (Lazy.force cint, res)|] in let rootsCstr = let res = Array.make (List.length roots + 1) (mkInt 0) in let i = ref 0 in List.iter (fun j -> res.(!i) <- mkInt (Form.to_lit j); incr i) roots; - Structures.mkArray (Lazy.force cint, res) in + CoqInterface.mkArray (Lazy.force cint, res) in let tm = - Structures.mkLetIn (nti, t_i, mklApp carray [|Lazy.force ctyp_compdec|], - Structures.mkLetIn (ntfunc, t_func, + CoqInterface.mkLetIn (nti, t_i, mklApp carray [|Lazy.force ctyp_compdec|], + CoqInterface.mkLetIn (ntfunc, t_func, mklApp carray [|mklApp ctval [|v 1(* t_i *)|]|], - Structures.mkLetIn (ntatom, t_atom, mklApp carray [|Lazy.force catom|], - Structures.mkLetIn (ntform, t_form, mklApp carray [|Lazy.force cform|], - Structures.mkLetIn (nc, certif, mklApp ccertif [|v 4 (*t_i*); v 3 (*t_func*); + CoqInterface.mkLetIn (ntatom, t_atom, mklApp carray [|Lazy.force catom|], + CoqInterface.mkLetIn (ntform, t_form, mklApp carray [|Lazy.force cform|], + CoqInterface.mkLetIn (nc, certif, mklApp ccertif [|v 4 (*t_i*); v 3 (*t_func*); v 2 (*t_atom*); v 1 (*t_form*)|], - Structures.mkLetIn (nused_roots, used_rootsCstr, + CoqInterface.mkLetIn (nused_roots, used_rootsCstr, mklApp coption [|mklApp carray [|Lazy.force cint|]|], - Structures.mkLetIn (nd, rootsCstr, mklApp carray [|Lazy.force cint|], + CoqInterface.mkLetIn (nd, rootsCstr, mklApp carray [|Lazy.force cint|], mklApp cchecker_debug [|v 7 (*t_i*); v 6 (*t_func*); v 5 (*t_atom*); v 4 (*t_form*); v 1 (*d*); v 2 (*used_roots*); v 3 (*c*)|]))))))) in - let res = Structures.cbv_vm (Global.env ()) tm + let res = CoqInterface.cbv_vm (Global.env ()) tm (mklApp coption [|mklApp cprod [|Lazy.force cnat; Lazy.force cname_step|]|]) in - match Structures.decompose_app res with - | c, _ when Structures.eq_constr c (Lazy.force cNone) -> - Structures.error ("Debug checker is only meant to be used for certificates \ + match CoqInterface.decompose_app res with + | c, _ when CoqInterface.eq_constr c (Lazy.force cNone) -> + CoqInterface.error ("Debug checker is only meant to be used for certificates \ that fail to be checked by SMTCoq.") - | c, [_; n] when Structures.eq_constr c (Lazy.force cSome) -> - (match Structures.decompose_app n with - | c, [_; _; cnb; cn] when Structures.eq_constr c (Lazy.force cpair) -> - let n = fst (Structures.decompose_app cn) in + | c, [_; n] when CoqInterface.eq_constr c (Lazy.force cSome) -> + (match CoqInterface.decompose_app n with + | c, [_; _; cnb; cn] when CoqInterface.eq_constr c (Lazy.force cpair) -> + let n = fst (CoqInterface.decompose_app cn) in let name = - if Structures.eq_constr n (Lazy.force cName_Res ) then "Res" - else if Structures.eq_constr n (Lazy.force cName_Weaken) then "Weaken" - else if Structures.eq_constr n (Lazy.force cName_ImmFlatten) then "ImmFlatten" - else if Structures.eq_constr n (Lazy.force cName_CTrue) then "CTrue" - else if Structures.eq_constr n (Lazy.force cName_CFalse ) then "CFalse" - else if Structures.eq_constr n (Lazy.force cName_BuildDef) then "BuildDef" - else if Structures.eq_constr n (Lazy.force cName_BuildDef2) then "BuildDef2" - else if Structures.eq_constr n (Lazy.force cName_BuildProj ) then "BuildProj" - else if Structures.eq_constr n (Lazy.force cName_ImmBuildDef) then "ImmBuildDef" - else if Structures.eq_constr n (Lazy.force cName_ImmBuildDef2) then "ImmBuildDef2" - else if Structures.eq_constr n (Lazy.force cName_ImmBuildProj ) then "ImmBuildProj" - else if Structures.eq_constr n (Lazy.force cName_EqTr ) then "EqTr" - else if Structures.eq_constr n (Lazy.force cName_EqCgr ) then "EqCgr" - else if Structures.eq_constr n (Lazy.force cName_EqCgrP) then "EqCgrP" - else if Structures.eq_constr n (Lazy.force cName_LiaMicromega ) then "LiaMicromega" - else if Structures.eq_constr n (Lazy.force cName_LiaDiseq) then "LiaDiseq" - else if Structures.eq_constr n (Lazy.force cName_SplArith) then "SplArith" - else if Structures.eq_constr n (Lazy.force cName_SplDistinctElim ) then "SplDistinctElim" - else if Structures.eq_constr n (Lazy.force cName_BBVar) then "BBVar" - else if Structures.eq_constr n (Lazy.force cName_BBConst) then "BBConst" - else if Structures.eq_constr n (Lazy.force cName_BBOp) then "BBOp" - else if Structures.eq_constr n (Lazy.force cName_BBNot) then "BBNot" - else if Structures.eq_constr n (Lazy.force cName_BBNeg) then "BBNeg" - else if Structures.eq_constr n (Lazy.force cName_BBAdd) then "BBAdd" - else if Structures.eq_constr n (Lazy.force cName_BBConcat) then "BBConcat" - else if Structures.eq_constr n (Lazy.force cName_BBMul) then "BBMul" - else if Structures.eq_constr n (Lazy.force cName_BBUlt) then "BBUlt" - else if Structures.eq_constr n (Lazy.force cName_BBSlt) then "BBSlt" - else if Structures.eq_constr n (Lazy.force cName_BBEq) then "BBEq" - else if Structures.eq_constr n (Lazy.force cName_BBDiseq) then "BBDiseq" - else if Structures.eq_constr n (Lazy.force cName_BBExtract) then "BBExtract" - else if Structures.eq_constr n (Lazy.force cName_BBZextend) then "BBZextend" - else if Structures.eq_constr n (Lazy.force cName_BBSextend) then "BBSextend" - else if Structures.eq_constr n (Lazy.force cName_BBShl) then "BBShl" - else if Structures.eq_constr n (Lazy.force cName_BBShr) then "BBShr" - else if Structures.eq_constr n (Lazy.force cName_RowEq) then "RowEq" - else if Structures.eq_constr n (Lazy.force cName_RowNeq) then "RowNeq" - else if Structures.eq_constr n (Lazy.force cName_Ext) then "Ext" - else if Structures.eq_constr n (Lazy.force cName_Hole) then "Hole" + if CoqInterface.eq_constr n (Lazy.force cName_Res ) then "Res" + else if CoqInterface.eq_constr n (Lazy.force cName_Weaken) then "Weaken" + else if CoqInterface.eq_constr n (Lazy.force cName_ImmFlatten) then "ImmFlatten" + else if CoqInterface.eq_constr n (Lazy.force cName_CTrue) then "CTrue" + else if CoqInterface.eq_constr n (Lazy.force cName_CFalse ) then "CFalse" + else if CoqInterface.eq_constr n (Lazy.force cName_BuildDef) then "BuildDef" + else if CoqInterface.eq_constr n (Lazy.force cName_BuildDef2) then "BuildDef2" + else if CoqInterface.eq_constr n (Lazy.force cName_BuildProj ) then "BuildProj" + else if CoqInterface.eq_constr n (Lazy.force cName_ImmBuildDef) then "ImmBuildDef" + else if CoqInterface.eq_constr n (Lazy.force cName_ImmBuildDef2) then "ImmBuildDef2" + else if CoqInterface.eq_constr n (Lazy.force cName_ImmBuildProj ) then "ImmBuildProj" + else if CoqInterface.eq_constr n (Lazy.force cName_EqTr ) then "EqTr" + else if CoqInterface.eq_constr n (Lazy.force cName_EqCgr ) then "EqCgr" + else if CoqInterface.eq_constr n (Lazy.force cName_EqCgrP) then "EqCgrP" + else if CoqInterface.eq_constr n (Lazy.force cName_LiaMicromega ) then "LiaMicromega" + else if CoqInterface.eq_constr n (Lazy.force cName_LiaDiseq) then "LiaDiseq" + else if CoqInterface.eq_constr n (Lazy.force cName_SplArith) then "SplArith" + else if CoqInterface.eq_constr n (Lazy.force cName_SplDistinctElim ) then "SplDistinctElim" + else if CoqInterface.eq_constr n (Lazy.force cName_BBVar) then "BBVar" + else if CoqInterface.eq_constr n (Lazy.force cName_BBConst) then "BBConst" + else if CoqInterface.eq_constr n (Lazy.force cName_BBOp) then "BBOp" + else if CoqInterface.eq_constr n (Lazy.force cName_BBNot) then "BBNot" + else if CoqInterface.eq_constr n (Lazy.force cName_BBNeg) then "BBNeg" + else if CoqInterface.eq_constr n (Lazy.force cName_BBAdd) then "BBAdd" + else if CoqInterface.eq_constr n (Lazy.force cName_BBConcat) then "BBConcat" + else if CoqInterface.eq_constr n (Lazy.force cName_BBMul) then "BBMul" + else if CoqInterface.eq_constr n (Lazy.force cName_BBUlt) then "BBUlt" + else if CoqInterface.eq_constr n (Lazy.force cName_BBSlt) then "BBSlt" + else if CoqInterface.eq_constr n (Lazy.force cName_BBEq) then "BBEq" + else if CoqInterface.eq_constr n (Lazy.force cName_BBDiseq) then "BBDiseq" + else if CoqInterface.eq_constr n (Lazy.force cName_BBExtract) then "BBExtract" + else if CoqInterface.eq_constr n (Lazy.force cName_BBZextend) then "BBZextend" + else if CoqInterface.eq_constr n (Lazy.force cName_BBSextend) then "BBSextend" + else if CoqInterface.eq_constr n (Lazy.force cName_BBShl) then "BBShl" + else if CoqInterface.eq_constr n (Lazy.force cName_BBShr) then "BBShr" + else if CoqInterface.eq_constr n (Lazy.force cName_RowEq) then "RowEq" + else if CoqInterface.eq_constr n (Lazy.force cName_RowNeq) then "RowNeq" + else if CoqInterface.eq_constr n (Lazy.force cName_Ext) then "Ext" + else if CoqInterface.eq_constr n (Lazy.force cName_Hole) then "Hole" else string_coq_constr n in let nb = mk_nat cnb + List.length roots + (confl.id + 1 - count_used confl) in - Structures.error ("Step number " ^ string_of_int nb ^ + CoqInterface.error ("Step number " ^ string_of_int nb ^ " (" ^ name ^ ") of the certificate likely failed.") | _ -> assert false ) @@ -450,9 +450,9 @@ let checker_debug (rt, ro, ra, rf, roots, max_id, confl) = (* let rec of_coq_list cl = - * match Structures.decompose_app cl with - * | c, _ when Structures.eq_constr c (Lazy.force cnil) -> [] - * | c, [_; x; cr] when Structures.eq_constr c (Lazy.force ccons) -> + * match CoqInterface.decompose_app cl with + * | c, _ when CoqInterface.eq_constr c (Lazy.force cnil) -> [] + * | c, [_; x; cr] when CoqInterface.eq_constr c (Lazy.force ccons) -> * x :: of_coq_list cr * | _ -> assert false *) @@ -461,29 +461,29 @@ let checker_debug (rt, ro, ra, rf, roots, max_id, confl) = * (rt, ro, ra, rf, roots, max_id, confl) = * * let t_i' = make_t_i rt in - * let ce5 = Structures.mkUConst t_i' in - * let ct_i = Structures.mkConst (Structures.declare_constant t_i ce5) in + * let ce5 = CoqInterface.mkUConst t_i' in + * let ct_i = CoqInterface.mkConst (CoqInterface.declare_constant t_i ce5) in * * let t_func' = make_t_func ro ct_i in - * let ce6 = Structures.mkUConst t_func' in + * let ce6 = CoqInterface.mkUConst t_func' in * let ct_func = - * Structures.mkConst (Structures.declare_constant t_func ce6) in + * CoqInterface.mkConst (CoqInterface.declare_constant t_func ce6) in * * let t_atom' = Atom.interp_tbl ra in - * let ce1 = Structures.mkUConst t_atom' in + * let ce1 = CoqInterface.mkUConst t_atom' in * let ct_atom = - * Structures.mkConst (Structures.declare_constant t_atom ce1) in + * CoqInterface.mkConst (CoqInterface.declare_constant t_atom ce1) in * * let t_form' = snd (Form.interp_tbl rf) in - * let ce2 = Structures.mkUConst t_form' in + * let ce2 = CoqInterface.mkUConst t_form' in * let ct_form = - * Structures.mkConst (Structures.declare_constant t_form ce2) in + * CoqInterface.mkConst (CoqInterface.declare_constant t_form ce2) in * * let (tres, last_root, cuts) = SmtTrace.to_coq (fun i -> mkInt (Form.to_lit i)) * (interp_conseq_uf ct_i) * (certif_ops (Some [|ct_i; ct_func; ct_atom; ct_form|])) confl None in * List.iter (fun (v,ty) -> - * let _ = Structures.declare_new_variable v ty in + * let _ = CoqInterface.declare_new_variable v ty in * print_assm ty * ) cuts; * @@ -492,37 +492,37 @@ let checker_debug (rt, ro, ra, rf, roots, max_id, confl) = * let res = Array.make (List.length roots + 1) (mkInt 0) in * let i = ref 0 in * List.iter (fun j -> res.(!i) <- mkInt (Form.to_lit j); incr i) roots; - * Structures.mkArray (Lazy.force cint, res) in + * CoqInterface.mkArray (Lazy.force cint, res) in * let cused_roots = * let l = List.length used_roots in * let res = Array.make (l + 1) (mkInt 0) in * let i = ref (l-1) in * List.iter (fun j -> res.(!i) <- mkInt j; decr i) used_roots; * mklApp cSome [|mklApp carray [|Lazy.force cint|]; - * Structures.mkArray (Lazy.force cint, res)|] in - * let ce3 = Structures.mkUConst croots in - * let _ = Structures.declare_constant root ce3 in - * let ce3' = Structures.mkUConst cused_roots in - * let _ = Structures.declare_constant used_root ce3' in + * CoqInterface.mkArray (Lazy.force cint, res)|] in + * let ce3 = CoqInterface.mkUConst croots in + * let _ = CoqInterface.declare_constant root ce3 in + * let ce3' = CoqInterface.mkUConst cused_roots in + * let _ = CoqInterface.declare_constant used_root ce3' in * * let certif = * mklApp cCertif [|ct_i; ct_func; ct_atom; ct_form; mkInt (max_id + 1); * tres;mkInt (get_pos confl)|] in - * let ce4 = Structures.mkUConst certif in - * let _ = Structures.declare_constant trace ce4 in + * let ce4 = CoqInterface.mkUConst certif in + * let _ = CoqInterface.declare_constant trace ce4 in * * let setup = * mklApp csetup_checker_step_debug * [| ct_i; ct_func; ct_atom; ct_form; croots; cused_roots; certif |] in * - * let setup = Structures.cbv_vm (Global.env ()) setup + * let setup = CoqInterface.cbv_vm (Global.env ()) setup * (mklApp cprod * [|Lazy.force cState_S_t; * mklApp clist [|mklApp cstep * [|ct_i; ct_func; ct_atom; ct_form|]|]|]) in * - * let s, steps = match Structures.decompose_app setup with - * | c, [_; _; s; csteps] when Structures.eq_constr c (Lazy.force cpair) -> + * let s, steps = match CoqInterface.decompose_app setup with + * | c, [_; _; s; csteps] when CoqInterface.eq_constr c (Lazy.force cpair) -> * s, of_coq_list csteps * | _ -> assert false * in @@ -536,22 +536,22 @@ let checker_debug (rt, ro, ra, rf, roots, max_id, confl) = * [| ct_i; ct_func; ct_atom; ct_form; s; step |] in * * let res = - * Structures.cbv_vm (Global.env ()) tm + * CoqInterface.cbv_vm (Global.env ()) tm * (mklApp cprod [|Lazy.force cState_S_t; Lazy.force cbool|]) in * - * match Structures.decompose_app res with - * | c, [_; _; s; cbad] when Structures.eq_constr c (Lazy.force cpair) -> + * match CoqInterface.decompose_app res with + * | c, [_; _; s; cbad] when CoqInterface.eq_constr c (Lazy.force cpair) -> * if not (mk_bool cbad) then s - * else Structures.error ("Step number " ^ string_of_int !cpt ^ + * else CoqInterface.error ("Step number " ^ string_of_int !cpt ^ * " (" ^ string_coq_constr - * (fst (Structures.decompose_app step)) ^ ")" ^ + * (fst (CoqInterface.decompose_app step)) ^ ")" ^ * " of the certificate likely failed." ) * | _ -> assert false * in * * List.fold_left debug_step s steps |> ignore; * - * Structures.error ("Debug checker is only meant to be used for certificates \ + * CoqInterface.error ("Debug checker is only meant to be used for certificates \ * that fail to be checked by SMTCoq.") *) @@ -559,16 +559,16 @@ let checker_debug (rt, ro, ra, rf, roots, max_id, confl) = (* Tactic *) let build_body rt ro ra rf l b (max_id, confl) vm_cast find = - let nti = Structures.mkName "t_i" in - let ntfunc = Structures.mkName "t_func" in - let ntatom = Structures.mkName "t_atom" in - let ntform = Structures.mkName "t_form" in - let nc = Structures.mkName "c" in + let nti = CoqInterface.mkName "t_i" in + let ntfunc = CoqInterface.mkName "t_func" in + let ntatom = CoqInterface.mkName "t_atom" in + let ntform = CoqInterface.mkName "t_form" in + let nc = CoqInterface.mkName "c" in - let v = Structures.mkRel in + let v = CoqInterface.mkRel in let t_i = make_t_i rt in - let t_func = Structures.lift 1 (make_t_func ro (v 0 (*t_i - 1*))) in + let t_func = CoqInterface.lift 1 (make_t_func ro (v 0 (*t_i - 1*))) in let t_atom = Atom.interp_tbl ra in let t_form = snd (Form.interp_tbl rf) in let (tres,_,cuts) = SmtTrace.to_coq Form.to_coq @@ -583,11 +583,11 @@ let build_body rt ro ra rf l b (max_id, confl) vm_cast find = mkInt (max_id + 1); tres;mkInt (get_pos confl)|] in let add_lets t = - Structures.mkLetIn (nti, t_i, mklApp carray [|Lazy.force ctyp_compdec|], - Structures.mkLetIn (ntfunc, t_func, mklApp carray [|mklApp ctval [|v 1(*t_i*)|]|], - Structures.mkLetIn (ntatom, t_atom, mklApp carray [|Lazy.force catom|], - Structures.mkLetIn (ntform, t_form, mklApp carray [|Lazy.force cform|], - Structures.mkLetIn (nc, certif, mklApp ccertif + CoqInterface.mkLetIn (nti, t_i, mklApp carray [|Lazy.force ctyp_compdec|], + CoqInterface.mkLetIn (ntfunc, t_func, mklApp carray [|mklApp ctval [|v 1(*t_i*)|]|], + CoqInterface.mkLetIn (ntatom, t_atom, mklApp carray [|Lazy.force catom|], + CoqInterface.mkLetIn (ntform, t_form, mklApp carray [|Lazy.force cform|], + CoqInterface.mkLetIn (nc, certif, mklApp ccertif [|v 4 (*t_i*); v 3 (*t_func*); v 2 (*t_atom*); v 1 (*t_form*)|], t))))) in @@ -614,16 +614,16 @@ let build_body rt ro ra rf l b (max_id, confl) vm_cast find = let build_body_eq rt ro ra rf l1 l2 l (max_id, confl) vm_cast find = - let nti = Structures.mkName "t_i" in - let ntfunc = Structures.mkName "t_func" in - let ntatom = Structures.mkName "t_atom" in - let ntform = Structures.mkName "t_form" in - let nc = Structures.mkName "c" in + let nti = CoqInterface.mkName "t_i" in + let ntfunc = CoqInterface.mkName "t_func" in + let ntatom = CoqInterface.mkName "t_atom" in + let ntform = CoqInterface.mkName "t_form" in + let nc = CoqInterface.mkName "c" in - let v = Structures.mkRel in + let v = CoqInterface.mkRel in let t_i = make_t_i rt in - let t_func = Structures.lift 1 (make_t_func ro (v 0 (*t_i*))) in + let t_func = CoqInterface.lift 1 (make_t_func ro (v 0 (*t_i*))) in let t_atom = Atom.interp_tbl ra in let t_form = snd (Form.interp_tbl rf) in let (tres,_,cuts) = SmtTrace.to_coq Form.to_coq @@ -633,11 +633,11 @@ let build_body_eq rt ro ra rf l1 l2 l (max_id, confl) vm_cast find = mklApp cCertif [|v 4 (*t_i*); v 3 (*t_func*); v 2 (*t_atom*); v 1 (*t_form*); mkInt (max_id + 1); tres;mkInt (get_pos confl)|] in let add_lets t = - Structures.mkLetIn (nti, t_i, mklApp carray [|Lazy.force ctyp_compdec|], - Structures.mkLetIn (ntfunc, t_func, mklApp carray [|mklApp ctval [|v 1(*t_i*)|]|], - Structures.mkLetIn (ntatom, t_atom, mklApp carray [|Lazy.force catom|], - Structures.mkLetIn (ntform, t_form, mklApp carray [|Lazy.force cform|], - Structures.mkLetIn (nc, certif, mklApp ccertif + CoqInterface.mkLetIn (nti, t_i, mklApp carray [|Lazy.force ctyp_compdec|], + CoqInterface.mkLetIn (ntfunc, t_func, mklApp carray [|mklApp ctval [|v 1(*t_i*)|]|], + CoqInterface.mkLetIn (ntatom, t_atom, mklApp carray [|Lazy.force catom|], + CoqInterface.mkLetIn (ntform, t_form, mklApp carray [|Lazy.force cform|], + CoqInterface.mkLetIn (nc, certif, mklApp ccertif [|v 4 (*t_i*); v 3 (*t_func*); v 2 (*t_atom*); v 1 (*t_form*)|], t))))) in @@ -665,10 +665,10 @@ let build_body_eq rt ro ra rf l1 l2 l (max_id, confl) vm_cast find = let get_arguments concl = - let f, args = Structures.decompose_app concl in + let f, args = CoqInterface.decompose_app concl in match args with - | [ty;a;b] when (Structures.eq_constr f (Lazy.force ceq)) && (Structures.eq_constr ty (Lazy.force cbool)) -> a, b - | [a] when (Structures.eq_constr f (Lazy.force cis_true)) -> a, Lazy.force ctrue + | [ty;a;b] when (CoqInterface.eq_constr f (Lazy.force ceq)) && (CoqInterface.eq_constr ty (Lazy.force cbool)) -> a, b + | [a] when (CoqInterface.eq_constr f (Lazy.force cis_true)) -> a, Lazy.force ctrue | _ -> failwith ("Verit.tactic: can only deal with equality over bool") @@ -689,7 +689,7 @@ let gen_rel_name = let of_coq_lemma rt ro ra_quant rf_quant env sigma solver_logic clemma = let warn () = - Structures.warning "Lemma" ("Discarding the following lemma (unsupported): "^(Pp.string_of_ppcmds (Ppconstr.pr_constr_expr Environ.empty_env Evd.empty (Structures.extern_constr clemma)))); + CoqInterface.warning "Lemma" ("Discarding the following lemma (unsupported): "^(Pp.string_of_ppcmds (Ppconstr.pr_constr_expr Environ.empty_env Evd.empty (CoqInterface.extern_constr clemma)))); None in @@ -698,16 +698,16 @@ let of_coq_lemma rt ro ra_quant rf_quant env sigma solver_logic clemma = let rel_context = List.map (fun rel -> Context.Rel.Declaration.set_name (Names.Name.mk_name (Names.Id.of_string (gen_rel_name ()))) rel) rel_context in let env_lemma = Environ.push_rel_context rel_context env in - let f, args = Structures.decompose_app qf_lemma in + let f, args = CoqInterface.decompose_app qf_lemma in let core_f = - if Structures.eq_constr f (Lazy.force cis_true) then + if CoqInterface.eq_constr f (Lazy.force cis_true) then match args with | [a] -> Some a | _ -> warn () - else if Structures.eq_constr f (Lazy.force ceq) then + else if CoqInterface.eq_constr f (Lazy.force ceq) then match args with - | [ty; arg1; arg2] when Structures.eq_constr ty (Lazy.force cbool) && - Structures.eq_constr arg2 (Lazy.force ctrue) -> + | [ty; arg1; arg2] when CoqInterface.eq_constr ty (Lazy.force cbool) && + CoqInterface.eq_constr arg2 (Lazy.force ctrue) -> Some arg1 | _ -> warn () else warn () in @@ -722,8 +722,8 @@ let of_coq_lemma rt ro ra_quant rf_quant env sigma solver_logic clemma = | None -> None in let forall_args = - let fmap r = let n, t = Structures.destruct_rel_decl r in - Structures.string_of_name n, SmtBtype.of_coq rt solver_logic t in + let fmap r = let n, t = CoqInterface.destruct_rel_decl r in + CoqInterface.string_of_name n, SmtBtype.of_coq rt solver_logic t in List.map fmap rel_context in match forall_args with @@ -736,11 +736,11 @@ let of_coq_lemma rt ro ra_quant rf_quant env sigma solver_logic clemma = let core_tactic call_solver solver_logic rt ro ra rf ra_quant rf_quant vm_cast lcpl lcepl env sigma concl = let a, b = get_arguments concl in - let tlcepl = List.map (Structures.interp_constr env sigma) lcepl in + let tlcepl = List.map (CoqInterface.interp_constr env sigma) lcepl in let lcpl = lcpl @ tlcepl in let create_lemma l = - let cl = Structures.retyping_get_type_of env sigma l in + let cl = CoqInterface.retyping_get_type_of env sigma l in match of_coq_lemma rt ro ra_quant rf_quant env sigma solver_logic cl with | Some smt -> Some ((cl, l), smt) | None -> None @@ -748,7 +748,7 @@ let core_tactic call_solver solver_logic rt ro ra rf ra_quant rf_quant vm_cast l let l_pl_ls = SmtMisc.filter_map create_lemma lcpl in let lsmt = List.map snd l_pl_ls in - let lem_tbl : (int, Structures.constr * Structures.constr) Hashtbl.t = + let lem_tbl : (int, CoqInterface.constr * CoqInterface.constr) Hashtbl.t = Hashtbl.create 100 in let new_ref ((l, pl), ls) = Hashtbl.add lem_tbl (Form.index ls) (l, pl) in @@ -770,11 +770,11 @@ let core_tactic call_solver solver_logic rt ro ra rf ra_quant rf_quant vm_cast l | _ -> failwith "unexpected form of root" in let (body_cast, body_nocast, cuts) = - if ((Structures.eq_constr b (Lazy.force ctrue)) || - (Structures.eq_constr b (Lazy.force cfalse))) then ( + if ((CoqInterface.eq_constr b (Lazy.force ctrue)) || + (CoqInterface.eq_constr b (Lazy.force cfalse))) then ( let l = Form.of_coq (Atom.of_coq rt ro ra solver_logic env sigma) rf a in let _ = Form.of_coq (Atom.of_coq ~eqsym:true rt ro ra_quant solver_logic env sigma) rf_quant a in - let nl = if (Structures.eq_constr b (Lazy.force ctrue)) then Form.neg l else l in + let nl = if (CoqInterface.eq_constr b (Lazy.force ctrue)) then Form.neg l else l in let lsmt = Form.flatten rf nl :: lsmt in let max_id_confl = make_proof call_solver env rt ro ra_quant rf_quant nl lsmt in build_body rt ro ra rf (Form.to_coq l) b max_id_confl (vm_cast env) (Some find_lemma) @@ -793,19 +793,19 @@ let core_tactic call_solver solver_logic rt ro ra rf ra_quant rf_quant vm_cast l let cuts = (SmtBtype.get_cuts rt) @ cuts in List.fold_right (fun (eqn, eqt) tac -> - Structures.tclTHENLAST - (Structures.assert_before (Structures.name_of_id eqn) eqt) + CoqInterface.tclTHENLAST + (CoqInterface.assert_before (CoqInterface.name_of_id eqn) eqt) tac ) cuts - (Structures.tclTHEN - (Structures.set_evars_tac body_nocast) - (Structures.vm_cast_no_check body_cast)) + (CoqInterface.tclTHEN + (CoqInterface.set_evars_tac body_nocast) + (CoqInterface.vm_cast_no_check body_cast)) let tactic call_solver solver_logic rt ro ra rf ra_quant rf_quant vm_cast lcpl lcepl = - Structures.tclTHEN + CoqInterface.tclTHEN Tactics.intros - (Structures.mk_tactic (core_tactic call_solver solver_logic rt ro ra rf ra_quant rf_quant vm_cast lcpl lcepl)) + (CoqInterface.mk_tactic (core_tactic call_solver solver_logic rt ro ra rf ra_quant rf_quant vm_cast lcpl lcepl)) (**********************************************) @@ -822,7 +822,7 @@ let string_index_of_constr env i cf = try let s = string_coq_constr cf in let nc = Environ.named_context env in - let nd = Environ.lookup_named (Structures.mkId s) env in + let nd = Environ.lookup_named (CoqInterface.mkId s) env in let cpt = ref 0 in (try List.iter (fun n -> incr cpt; if n == nd then raise Exit) nc with Exit -> ()); @@ -832,11 +832,11 @@ let string_index_of_constr env i cf = let vstring_i env i = let cf = SmtAtom.Atom.get_coq_term_op i in - if Structures.isRel cf then - let dbi = Structures.destRel cf in + if CoqInterface.isRel cf then + let dbi = CoqInterface.destRel cf in let s = Environ.lookup_rel dbi env - |> Structures.get_rel_dec_name + |> CoqInterface.get_rel_dec_name |> SmtMisc.string_of_name_def "?" in s, dbi @@ -977,14 +977,14 @@ let model_item env rt ro ra rf = * let outf = Format.formatter_of_out_channel out in * SExpr.print outf l; pp_print_flush outf (); * close_out out; *) - Structures.error ("Could not reconstruct model") + CoqInterface.error ("Could not reconstruct model") let model env rt ro ra rf = function | List (Atom "model" :: l) -> List.fold_left (fun acc m -> match model_item env rt ro ra rf m with Fun m -> m::acc | Sort -> acc) [] l |> List.sort (fun ((_ ,i1), _) ((_, i2), _) -> i2 - i1) - | _ -> Structures.error ("No model") + | _ -> CoqInterface.error ("No model") let model_string env rt ro ra rf s = diff --git a/src/trace/smtCommands.mli b/src/trace/smtCommands.mli index b643594..e885028 100644 --- a/src/trace/smtCommands.mli +++ b/src/trace/smtCommands.mli @@ -11,13 +11,13 @@ val parse_certif : - Structures.id -> - Structures.id -> - Structures.id -> - Structures.id -> - Structures.id -> - Structures.id -> - Structures.id -> + CoqInterface.id -> + CoqInterface.id -> + CoqInterface.id -> + CoqInterface.id -> + CoqInterface.id -> + CoqInterface.id -> + CoqInterface.id -> SmtBtype.reify_tbl * SmtAtom.Op.reify_tbl * SmtAtom.Atom.reify_tbl * SmtAtom.Form.reify * SmtAtom.Form.t list * int * SmtAtom.Form.t SmtCertif.clause -> @@ -29,7 +29,7 @@ val checker_debug : SmtAtom.Form.t list * int * SmtAtom.Form.t SmtCertif.clause -> 'a val theorem : - Structures.id -> + CoqInterface.id -> SmtBtype.reify_tbl * SmtAtom.Op.reify_tbl * SmtAtom.Atom.reify_tbl * SmtAtom.Form.reify * SmtAtom.Form.t list * int * SmtAtom.Form.t SmtCertif.clause -> @@ -56,8 +56,8 @@ val tactic : SmtAtom.Form.reify -> SmtAtom.Atom.reify_tbl -> SmtAtom.Form.reify -> - (Environ.env -> Structures.constr -> Structures.constr) -> - Structures.constr list -> - Structures.constr_expr list -> Structures.tactic + (Environ.env -> CoqInterface.constr -> CoqInterface.constr) -> + CoqInterface.constr list -> + CoqInterface.constr_expr list -> CoqInterface.tactic val model_string : Environ.env -> SmtBtype.reify_tbl -> 'a -> 'b -> 'c -> SExpr.t -> string diff --git a/src/trace/smtForm.ml b/src/trace/smtForm.ml index 7f2ebd8..0a7d859 100644 --- a/src/trace/smtForm.ml +++ b/src/trace/smtForm.ml @@ -81,7 +81,7 @@ module type FORM = val get : ?declare:bool -> reify -> pform -> t (** Given a coq term, build the corresponding formula *) - val of_coq : (Structures.constr -> hatom) -> reify -> Structures.constr -> t + val of_coq : (CoqInterface.constr -> hatom) -> reify -> CoqInterface.constr -> t val hash_hform : (hatom -> hatom) -> reify -> t -> t (* Flattening of [Fand] and [For], removing of [Fnot2] *) @@ -93,20 +93,20 @@ module type FORM = (** Producing Coq terms *) - val to_coq : t -> Structures.constr + val to_coq : t -> CoqInterface.constr val pform_tbl : reify -> pform array val to_array : reify -> 'a -> (pform -> 'a) -> int * 'a array - val interp_tbl : reify -> Structures.constr * Structures.constr + val interp_tbl : reify -> CoqInterface.constr * CoqInterface.constr val nvars : reify -> int (* Producing a Coq term corresponding to the interpretation of a formula *) (* [interp_atom] map [hatom] to coq term, it is better if it produce shared terms. *) val interp_to_coq : - (hatom -> Structures.constr) -> (int, Structures.constr) Hashtbl.t -> - t -> Structures.constr + (hatom -> CoqInterface.constr) -> (int, CoqInterface.constr) Hashtbl.t -> + t -> CoqInterface.constr (* Unstratified terms *) type atom_form_lit = @@ -368,9 +368,9 @@ module Make (Atom:ATOM) = | CCunknown module ConstrHash = struct - type t = Structures.constr - let equal = Structures.eq_constr - let hash = Structures.hash_constr + type t = CoqInterface.constr + let equal = CoqInterface.eq_constr + let hash = CoqInterface.hash_constr end module ConstrHashtbl = Hashtbl.Make(ConstrHash) @@ -393,7 +393,7 @@ module Make (Atom:ATOM) = let get_cst c = try ConstrHashtbl.find op_tbl c with Not_found -> CCunknown in let rec mk_hform h = - let c, args = Structures.decompose_app h in + let c, args = CoqInterface.decompose_app h in match get_cst c with | CCtrue -> get reify (Fapp(Ftrue,empty_args)) | CCfalse -> get reify (Fapp(Ffalse,empty_args)) @@ -408,7 +408,7 @@ module Make (Atom:ATOM) = let l1 = mk_hform b1 in let l2 = mk_hform b2 in get reify (Fapp (Fimp, [|l1;l2|])) - | _ -> Structures.error "SmtForm.Form.of_coq: wrong number of arguments for implb") + | _ -> CoqInterface.error "SmtForm.Form.of_coq: wrong number of arguments for implb") | CCifb -> (* We should also be able to reify if then else *) begin match args with @@ -417,7 +417,7 @@ module Make (Atom:ATOM) = let l2 = mk_hform b2 in let l3 = mk_hform b3 in get reify (Fapp (Fite, [|l1;l2;l3|])) - | _ -> Structures.error "SmtForm.Form.of_coq: wrong number of arguments for ifb" + | _ -> CoqInterface.error "SmtForm.Form.of_coq: wrong number of arguments for ifb" end | _ -> let a = atom_of_coq h in @@ -429,13 +429,13 @@ module Make (Atom:ATOM) = let l1 = mk_hform b1 in let l2 = mk_hform b2 in get reify (f [|l1; l2|]) - | _ -> Structures.error "SmtForm.Form.of_coq: wrong number of arguments" + | _ -> CoqInterface.error "SmtForm.Form.of_coq: wrong number of arguments" and mk_fnot i args = match args with | [t] -> - let c,args = Structures.decompose_app t in - if Structures.eq_constr c (Lazy.force cnegb) then + let c,args = CoqInterface.decompose_app t in + if CoqInterface.eq_constr c (Lazy.force cnegb) then mk_fnot (i+1) args else let q,r = i lsr 1 , i land 1 in @@ -443,31 +443,31 @@ module Make (Atom:ATOM) = let l = if r = 0 then l else neg l in if q = 0 then l else get reify (Fapp(Fnot2 q, [|l|])) - | _ -> Structures.error "SmtForm.Form.mk_hform: wrong number of arguments for negb" + | _ -> CoqInterface.error "SmtForm.Form.mk_hform: wrong number of arguments for negb" and mk_fand acc args = match args with | [t1;t2] -> let l2 = mk_hform t2 in - let c, args = Structures.decompose_app t1 in - if Structures.eq_constr c (Lazy.force candb) then + let c, args = CoqInterface.decompose_app t1 in + if CoqInterface.eq_constr c (Lazy.force candb) then mk_fand (l2::acc) args else let l1 = mk_hform t1 in get reify (Fapp(Fand, Array.of_list (l1::l2::acc))) - | _ -> Structures.error "SmtForm.Form.mk_hform: wrong number of arguments for andb" + | _ -> CoqInterface.error "SmtForm.Form.mk_hform: wrong number of arguments for andb" and mk_for acc args = match args with | [t1;t2] -> let l2 = mk_hform t2 in - let c, args = Structures.decompose_app t1 in - if Structures.eq_constr c (Lazy.force corb) then + let c, args = CoqInterface.decompose_app t1 in + if CoqInterface.eq_constr c (Lazy.force corb) then mk_for (l2::acc) args else let l1 = mk_hform t1 in get reify (Fapp(For, Array.of_list (l1::l2::acc))) - | _ -> Structures.error "SmtForm.Form.mk_hform: wrong number of arguments for orb" in + | _ -> CoqInterface.error "SmtForm.Form.mk_hform: wrong number of arguments for orb" in mk_hform c @@ -546,7 +546,7 @@ module Make (Atom:ATOM) = let args_to_coq args = let cargs = Array.make (Array.length args + 1) (mkInt 0) in Array.iteri (fun i hf -> cargs.(i) <- to_coq hf) args; - Structures.mkArray (Lazy.force cint, cargs) + CoqInterface.mkArray (Lazy.force cint, cargs) let pf_to_coq = function | Fatom a -> mklApp cFatom [|mkInt (Atom.index a)|] @@ -586,7 +586,7 @@ module Make (Atom:ATOM) = let interp_tbl reify = let (i,t) = to_array reify (Lazy.force cFtrue) pf_to_coq in - (mkInt i, Structures.mkArray (Lazy.force cform, t)) + (mkInt i, CoqInterface.mkArray (Lazy.force cform, t)) let nvars reify = reify.count (* Producing a Coq term corresponding to the interpretation of a formula *) diff --git a/src/trace/smtForm.mli b/src/trace/smtForm.mli index 06a867f..47b4123 100644 --- a/src/trace/smtForm.mli +++ b/src/trace/smtForm.mli @@ -77,7 +77,7 @@ module type FORM = val get : ?declare:bool -> reify -> pform -> t (** Given a coq term, build the corresponding formula *) - val of_coq : (Structures.constr -> hatom) -> reify -> Structures.constr -> t + val of_coq : (CoqInterface.constr -> hatom) -> reify -> CoqInterface.constr -> t val hash_hform : (hatom -> hatom) -> reify -> t -> t @@ -90,20 +90,20 @@ module type FORM = (** Producing Coq terms *) - val to_coq : t -> Structures.constr + val to_coq : t -> CoqInterface.constr val pform_tbl : reify -> pform array val to_array : reify -> 'a -> (pform -> 'a) -> int * 'a array - val interp_tbl : reify -> Structures.constr * Structures.constr + val interp_tbl : reify -> CoqInterface.constr * CoqInterface.constr val nvars : reify -> int (* Producing a Coq term corresponding to the interpretation of a formula *) (* [interp_atom] map [hatom] to coq term, it is better if it produce shared terms. *) val interp_to_coq : - (hatom -> Structures.constr) -> (int, Structures.constr) Hashtbl.t -> - t -> Structures.constr + (hatom -> CoqInterface.constr) -> (int, CoqInterface.constr) Hashtbl.t -> + t -> CoqInterface.constr (* Unstratified terms *) type atom_form_lit = diff --git a/src/trace/smtMisc.ml b/src/trace/smtMisc.ml index d750550..165814b 100644 --- a/src/trace/smtMisc.ml +++ b/src/trace/smtMisc.ml @@ -16,7 +16,7 @@ let cInt_tbl = Hashtbl.create 17 let mkInt i = try Hashtbl.find cInt_tbl i with Not_found -> - let ci = Structures.mkInt i in + let ci = CoqInterface.mkInt i in Hashtbl.add cInt_tbl i ci; ci @@ -25,15 +25,15 @@ type 'a gen_hashed = { index : int; hval : 'a } (** Functions over constr *) -let mklApp f args = Structures.mkApp (Lazy.force f, args) +let mklApp f args = CoqInterface.mkApp (Lazy.force f, args) -let string_of_name_def d n = try Structures.string_of_name n with | _ -> d +let string_of_name_def d n = try CoqInterface.string_of_name n with | _ -> d let string_coq_constr t = let rec fix rf x = rf (fix rf) x in let pr = fix - Ppconstr.modular_constr_pr Pp.mt Structures.ppconstr_lsimpleconstr in - Pp.string_of_ppcmds (pr (Structures.constrextern_extern_constr t)) + Ppconstr.modular_constr_pr Pp.mt CoqInterface.ppconstr_lsimpleconstr in + Pp.string_of_ppcmds (pr (CoqInterface.constrextern_extern_constr t)) (** Logics *) diff --git a/src/trace/smtMisc.mli b/src/trace/smtMisc.mli index a6f5db8..5359c15 100644 --- a/src/trace/smtMisc.mli +++ b/src/trace/smtMisc.mli @@ -10,12 +10,12 @@ (**************************************************************************) -val cInt_tbl : (int, Structures.constr) Hashtbl.t -val mkInt : int -> Structures.constr +val cInt_tbl : (int, CoqInterface.constr) Hashtbl.t +val mkInt : int -> CoqInterface.constr type 'a gen_hashed = { index : int; hval : 'a; } -val mklApp : Structures.constr Lazy.t -> Structures.constr array -> Structures.constr -val string_of_name_def : string -> Structures.name -> string -val string_coq_constr : Structures.constr -> string +val mklApp : CoqInterface.constr Lazy.t -> CoqInterface.constr array -> CoqInterface.constr +val string_of_name_def : string -> CoqInterface.name -> string +val string_coq_constr : CoqInterface.constr -> string type logic_item = LUF | LLia | LBitvectors | LArrays module SL : Set.S with type elt = logic_item type logic = SL.t diff --git a/src/trace/smtTrace.ml b/src/trace/smtTrace.ml index 65994f9..7b68a26 100644 --- a/src/trace/smtTrace.ml +++ b/src/trace/smtTrace.ml @@ -383,7 +383,7 @@ let to_coq to_lit interp (cstep, l := tl | _ -> assert false done; - mklApp cRes [|mkInt (get_pos c); Structures.mkArray (Lazy.force cint, args)|] + mklApp cRes [|mkInt (get_pos c); CoqInterface.mkArray (Lazy.force cint, args)|] | Other other -> begin match other with | Weaken (c',l') -> @@ -412,12 +412,12 @@ let to_coq to_lit interp (cstep, mklApp cEqCgrP [|out_c c; out_f f1; out_f f2; res|] | LiaMicromega (cl,d) -> let cl' = List.fold_right (fun f l -> mklApp ccons [|Lazy.force cint; out_f f; l|]) cl (mklApp cnil [|Lazy.force cint|]) in - let c' = List.fold_right (fun f l -> mklApp ccons [|Lazy.force Structures.micromega_coq_proofTerm; Structures.micromega_dump_proof_term f; l|]) d (mklApp cnil [|Lazy.force Structures.micromega_coq_proofTerm|]) in + let c' = List.fold_right (fun f l -> mklApp ccons [|Lazy.force CoqInterface.micromega_coq_proofTerm; CoqInterface.micromega_dump_proof_term f; l|]) d (mklApp cnil [|Lazy.force CoqInterface.micromega_coq_proofTerm|]) in mklApp cLiaMicromega [|out_c c; cl'; c'|] | LiaDiseq l -> mklApp cLiaDiseq [|out_c c; out_f l|] | SplArith (orig,res,l) -> let res' = out_f res in - let l' = List.fold_right (fun f l -> mklApp ccons [|Lazy.force Structures.micromega_coq_proofTerm; Structures.micromega_dump_proof_term f; l|]) l (mklApp cnil [|Lazy.force Structures.micromega_coq_proofTerm|]) in + let l' = List.fold_right (fun f l -> mklApp ccons [|Lazy.force CoqInterface.micromega_coq_proofTerm; CoqInterface.micromega_dump_proof_term f; l|]) l (mklApp cnil [|Lazy.force CoqInterface.micromega_coq_proofTerm|]) in mklApp cSplArith [|out_c c; out_c orig; res'; l'|] | SplDistinctElim (c',f) -> mklApp cSplDistinctElim [|out_c c;out_c c'; out_f f|] | BBVar res -> mklApp cBBVar [|out_c c; out_f res|] @@ -461,10 +461,10 @@ let to_coq to_lit interp (cstep, | Ext (res) -> mklApp cExt [|out_c c; out_f res|] | Hole (prem_id, concl) -> let prem = List.map (fun cl -> match cl.value with Some l -> l | None -> assert false) prem_id in - let ass_name = Structures.mkId ("ass"^(string_of_int (Hashtbl.hash concl))) in + let ass_name = CoqInterface.mkId ("ass"^(string_of_int (Hashtbl.hash concl))) in let ass_ty = interp (prem, concl) in cuts := (ass_name, ass_ty)::!cuts; - let ass_var = Structures.mkVar ass_name in + let ass_var = CoqInterface.mkVar ass_name in let prem_id' = List.fold_right (fun c l -> mklApp ccons [|Lazy.force cint; out_c c; l|]) prem_id (mklApp cnil [|Lazy.force cint|]) in let prem' = List.fold_right (fun cl l -> mklApp ccons [|Lazy.force cState_C_t; out_cl cl; l|]) prem (mklApp cnil [|Lazy.force cState_C_t|]) in let concl' = out_cl concl in @@ -474,23 +474,23 @@ let to_coq to_lit interp (cstep, | Some find -> find cl | None -> assert false in let concl' = out_cl [concl] in - let app_name = Structures.mkId ("app" ^ (string_of_int (Hashtbl.hash concl))) in - let app_var = Structures.mkVar app_name in - let app_ty = Structures.mkArrow clemma (interp ([], [concl])) in + let app_name = CoqInterface.mkId ("app" ^ (string_of_int (Hashtbl.hash concl))) in + let app_var = CoqInterface.mkVar app_name in + let app_ty = CoqInterface.mkArrow clemma (interp ([], [concl])) in cuts := (app_name, app_ty)::!cuts; mklApp cForallInst [|out_c c; clemma; cplemma; concl'; app_var|] end | _ -> assert false in let step = Lazy.force cstep in let def_step = - mklApp cRes [|mkInt 0; Structures.mkArray (Lazy.force cint, [|mkInt 0|]) |] in + mklApp cRes [|mkInt 0; CoqInterface.mkArray (Lazy.force cint, [|mkInt 0|]) |] in let r = ref confl in let nc = ref 0 in while not (isRoot !r.kind) do r := prev !r; incr nc done; let last_root = !r in (* Be careful, step_to_coq makes a side effect on cuts so it needs to be called first *) let res = - Structures.mkTrace step_to_coq next carray clist cnil ccons cpair !nc step def_step r + CoqInterface.mkTrace step_to_coq next carray clist cnil ccons cpair !nc step def_step r in (res, last_root, !cuts) diff --git a/src/trace/smtTrace.mli b/src/trace/smtTrace.mli index 2c70bbc..e79ce20 100644 --- a/src/trace/smtTrace.mli +++ b/src/trace/smtTrace.mli @@ -48,26 +48,26 @@ val alloc : 'a SmtCertif.clause -> int val naive_alloc : 'a SmtCertif.clause -> int val build_certif : 'a SmtCertif.clause -> 'b SmtCertif.clause -> int val to_coq : - ('a -> Structures.constr) -> - ('a list list * 'a list -> Structures.types) -> - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t -> + ('a -> CoqInterface.constr) -> + ('a list list * 'a list -> CoqInterface.types) -> + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t -> 'a SmtCertif.clause -> - ('a SmtCertif.clause -> Structures.types * Structures.constr) option -> - Structures.constr * 'a SmtCertif.clause * - (Structures.id * Structures.types) list + ('a SmtCertif.clause -> CoqInterface.types * CoqInterface.constr) option -> + CoqInterface.constr * 'a SmtCertif.clause * + (CoqInterface.id * CoqInterface.types) list module MakeOpt : diff --git a/src/verit/verit.ml b/src/verit/verit.ml index eed1dca..7f89943 100644 --- a/src/verit/verit.ml +++ b/src/verit/verit.ml @@ -193,25 +193,25 @@ let call_verit _ rt ro ra_quant rf_quant first lsmt = if l = "warning : proof_done: status is still open" then raise Unknown else if l = "Invalid memory reference" then - Structures.warning "verit-warning" ("veriT outputted the warning: " ^ l) + CoqInterface.warning "verit-warning" ("veriT outputted the warning: " ^ l) else if n >= 7 && String.sub l 0 7 = "warning" then - Structures.warning "verit-warning" ("veriT outputted the warning: " ^ (String.sub l 7 (n-7))) + CoqInterface.warning "verit-warning" ("veriT outputted the warning: " ^ (String.sub l 7 (n-7))) else if n >= 8 && String.sub l 0 8 = "error : " then - Structures.error ("veriT failed with the error: " ^ (String.sub l 8 (n-8))) + CoqInterface.error ("veriT failed with the error: " ^ (String.sub l 8 (n-8))) else - Structures.error ("veriT failed with the error: " ^ l) + CoqInterface.error ("veriT failed with the error: " ^ l) done with End_of_file -> () in try - if exit_code <> 0 then Structures.warning "verit-non-zero-exit-code" ("Verit.call_verit: command " ^ command ^ " exited with code " ^ string_of_int exit_code); + if exit_code <> 0 then CoqInterface.warning "verit-non-zero-exit-code" ("Verit.call_verit: command " ^ command ^ " exited with code " ^ string_of_int exit_code); raise_warnings_errors (); let res = import_trace ra_quant rf_quant logfilename (Some first) lsmt in close_in win; Sys.remove wname; res with x -> close_in win; Sys.remove wname; match x with - | Unknown -> Structures.error "veriT returns 'unknown'" - | VeritSyntax.Sat -> Structures.error "veriT found a counter-example" + | Unknown -> CoqInterface.error "veriT returns 'unknown'" + | VeritSyntax.Sat -> CoqInterface.error "veriT found a counter-example" | _ -> raise x let verit_logic = diff --git a/src/verit/verit.mli b/src/verit/verit.mli index 0560d77..f0acd0c 100644 --- a/src/verit/verit.mli +++ b/src/verit/verit.mli @@ -11,13 +11,13 @@ val parse_certif : - Structures.id -> - Structures.id -> - Structures.id -> - Structures.id -> - Structures.id -> Structures.id -> Structures.id -> string -> string -> unit + CoqInterface.id -> + CoqInterface.id -> + CoqInterface.id -> + CoqInterface.id -> + CoqInterface.id -> CoqInterface.id -> CoqInterface.id -> string -> string -> unit val checker : string -> string -> unit val checker_debug : string -> string -> unit -val theorem : Structures.id -> string -> string -> unit -val tactic : EConstr.t -> Structures.constr_expr list -> Structures.tactic -val tactic_no_check : EConstr.t -> Structures.constr_expr list -> Structures.tactic +val theorem : CoqInterface.id -> string -> string -> unit +val tactic : EConstr.t -> CoqInterface.constr_expr list -> CoqInterface.tactic +val tactic_no_check : EConstr.t -> CoqInterface.constr_expr list -> CoqInterface.tactic diff --git a/src/verit/veritSyntax.ml b/src/verit/veritSyntax.ml index 21c10e8..c5db594 100644 --- a/src/verit/veritSyntax.ml +++ b/src/verit/veritSyntax.ml @@ -493,7 +493,7 @@ let mk_clause (id,typ,value,ids_params) = let mk_clause cl = try mk_clause cl with Failure f -> - Structures.error ("SMTCoq was not able to check the certificate \ + CoqInterface.error ("SMTCoq was not able to check the certificate \ for the following reason.\n"^f) let apply_dec f (decl, a) = decl, f a diff --git a/src/versions/native/Make b/src/versions/native/Make deleted file mode 100644 index e278c82..0000000 --- a/src/versions/native/Make +++ /dev/null @@ -1,171 +0,0 @@ -######################################################################## -## This file is intended to developers, please do not use it to ## -## generate a Makefile, rather use the provided Makefile. ## -######################################################################## - - - - -######################################################################## -## To generate the Makefile: ## -## coq_makefile -f Make -o Makefile ## -## In the Makefile : ## -## 1) Suppress the "Makefile" target ## -## 2) Change the "all" target into: ## -## all: ml $(CMXFILES) $(CMXA) $(CMXS) $(VOFILES) ## -## 3) Change the "install-natdynlink" target: ## -## change CMXSFILES into CMXS and add the same block for CMXA and VCMXS. ## -## 4) Change the "install" target: change CMOFILES into CMXFILES. ## -## 5) Add to the "clean" target: ## -## - rm -f NSMTCoq* cnf/NSMTCoq* euf/NSMTCoq* lia/NSMTCoq* spl/NSMTCoq* ../unit-tests/NSMTCoq* ../unit-tests/*.vo ../unit-tests/*.zlog ../unit-tests/*.vtlog verit/veritParser.mli verit/veritParser.ml verit/veritLexer.ml ../3rdparty/alt-ergo/smtlib2_parse.mli ../3rdparty/alt-ergo/smtlib2_parse.ml ../3rdparty/alt-ergo/smtlib2_lex.ml smtlib2/sExprParser.mli smtlib2/sExprParser.ml smtlib2/sExprLexer.ml lfsc/lfscLexer.ml lfsc/lfscParser.ml lfsc/lfscParser.mli trace/smtcoq.a ## -######################################################################## - - --R . SMTCoq - --I bva --I classes --I array --I cnf --I euf --I lfsc --I lia --I smtlib2 --I trace --I verit --I zchaff --I versions/native --I ../3rdparty/alt-ergo - - --custom "cd ../unit-tests; make vernac" "" "test" --custom "cd ../unit-tests; make zchaffv" "" "ztest" --custom "cd ../unit-tests; make veritv" "" "vtest" - --custom "$(CAMLLEX) $<" "%.mll" "%.ml" --custom "$(CAMLYACC) $<" "%.mly" "%.ml %.mli" --custom "" "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" "ml" - --custom "$(CAMLOPTLINK) $(ZFLAGS) -a -o $@ $^" "versions/native/structures.cmx trace/smtMisc.cmx trace/coqTerms.cmx trace/smtBtype.cmx trace/smtForm.cmx trace/smtCertif.cmx trace/smtTrace.cmx trace/smtCnf.cmx trace/satAtom.cmx trace/smtAtom.cmx trace/smtMaps.cmx zchaff/satParser.cmx zchaff/zchaffParser.cmx zchaff/cnfParser.cmx zchaff/zchaff.cmx ../3rdparty/alt-ergo/smtlib2_util.cmx ../3rdparty/alt-ergo/smtlib2_ast.cmx ../3rdparty/alt-ergo/smtlib2_parse.cmx ../3rdparty/alt-ergo/smtlib2_lex.cmx smtlib2/sExpr.cmx smtlib2/sExprParser.cmx smtlib2/sExprLexer.cmx smtlib2/smtlib2_solver.cmx lia/lia.cmx verit/veritSyntax.cmx verit/veritParser.cmx verit/veritLexer.cmx lfsc/shashcons.cmx lfsc/hstring.cmx lfsc/type.cmx lfsc/ast.cmx lfsc/builtin.cmx lfsc/tosmtcoq.cmx lfsc/converter.cmx lfsc/lfscParser.cmx lfsc/lfscLexer.cmx smtlib2/smtlib2_genConstr.cmx trace/smtCommands.cmx verit/verit.cmx lfsc/lfsc.cmx smtcoq_plugin.cmx" "$(CMXA)" --custom "$(CAMLOPTLINK) $(ZFLAGS) -o $@ -linkall -shared $^" "$(CMXA)" "$(CMXS)" - -CMXA = smtcoq.cmxa -CMXS = smtcoq_plugin.cmxs -VCMXS = "versions/native/NSMTCoq_versions_native_Structures.cmxs NSMTCoq_State.cmxs NSMTCoq_Misc.cmxs classes/NSMTCoq_SMT_classes.cmxs classes/NSMTCoq_SMT_classes_instances.cmxs NSMTCoq_SMT_terms.cmxs cnf/NSMTCoq_cnf_Cnf.cmxs euf/NSMTCoq_euf_Euf.cmxs lia/NSMTCoq_lia_Lia.cmxs spl/NSMTCoq_spl_Syntactic.cmxs spl/NSMTCoq_spl_Assumptions.cmxs spl/NSMTCoq_spl_Arithmetic.cmxs spl/NSMTCoq_spl_Operators.cmxs NSMTCoq_Trace.cmxs NSMTCoq_Tactics.cmxs NSMTCoq_Conversion_tactics.cmxs NSMTCoq_PropToBool.cmxs NSMTCoq_BoolToProp.cmxs NSMTCoq_SMTCoq.cmxs NSMTCoq_State.cmi NSMTCoq_Misc.cmi classes/NSMTCoq_SMT_classes.cmi classes/NSMTCoq_SMT_classes_instances.cmi NSMTCoq_SMT_terms.cmi cnf/NSMTCoq_cnf_Cnf.cmi euf/NSMTCoq_euf_Euf.cmi lia/NSMTCoq_lia_Lia.cmi spl/NSMTCoq_spl_Syntactic.cmi spl/NSMTCoq_spl_Assumptions.cmi spl/NSMTCoq_spl_Arithmetic.cmi spl/NSMTCoq_spl_Operators.cmi NSMTCoq_Trace.cmi NSMTCoq_Trace.cmi NSMTCoq_Tactics.cmi NSMTCoq_Conversion_tactics.cmi NSMTCoq_PropToBool.cmi NSMTCoq_BoolToProp.cmi NSMTCoq_SMTCoq.cmi" -CAMLLEX = $(CAMLBIN)ocamllex -CAMLYACC = $(CAMLBIN)ocamlyacc - -bva/BVList.v -bva/Bva_checker.v - -classes/SMT_classes.v -classes/SMT_classes_instances.v - -array/FArray.v -array/Array_checker.v - -versions/native/Structures.v -versions/native/structures.ml -versions/native/structures.mli - -trace/coqTerms.ml -trace/coqTerms.mli -trace/satAtom.ml -trace/satAtom.mli -trace/smtAtom.ml -trace/smtAtom.mli -trace/smtBtype.ml -trace/smtBtype.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/sExprParser.ml -smtlib2/sExprParser.mli -smtlib2/sExprLexer.ml -smtlib2/sExpr.ml -smtlib2/sExpr.mli -smtlib2/smtlib2_solver.ml -smtlib2/smtlib2_solver.mli - -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/lfscLexer.ml -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 - -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 -BoolToProp.v -Tactics.v -SMT_terms.v -State.v -Trace.v - -smtcoq_plugin.ml4 diff --git a/src/versions/native/Makefile b/src/versions/native/Makefile deleted file mode 100644 index aaaab9e..0000000 --- a/src/versions/native/Makefile +++ /dev/null @@ -1,505 +0,0 @@ -############################################################################# -## v # The Coq Proof Assistant ## -## "$@" || ( RV=$$?; rm -f "$@"; exit $${RV} ) - -%.cmo: %.ml4 - $(CAMLC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $< - -%.cmx: %.ml4 - $(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $< - -%.ml4.d: %.ml4 - $(OCAMLDEP) -slash $(OCAMLLIBS) $(PP) -impl "$<" > "$@" || ( RV=$$?; rm -f "$@"; exit $${RV} ) - -%.cmo: %.ml - $(CAMLC) $(ZDEBUG) $(ZFLAGS) $< - -%.cmx: %.ml - $(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $< - -%.ml.d: %.ml - $(OCAMLDEP) -slash $(OCAMLLIBS) "$<" > "$@" || ( RV=$$?; rm -f "$@"; exit $${RV} ) - -%.cmxs: %.cmx - $(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -shared -o $@ $< - -%.vo %.glob: %.v - $(COQC) $(COQDEBUG) $(COQFLAGS) $* - -%.vi: %.v - $(COQC) -i $(COQDEBUG) $(COQFLAGS) $* - -%.g: %.v - $(GALLINA) $< - -%.tex: %.v - $(COQDOC) $(COQDOCFLAGS) -latex $< -o $@ - -%.html: %.v %.glob - $(COQDOC) $(COQDOCFLAGS) -html $< -o $@ - -%.g.tex: %.v - $(COQDOC) $(COQDOCFLAGS) -latex -g $< -o $@ - -%.g.html: %.v %.glob - $(COQDOC)$(COQDOCFLAGS) -html -g $< -o $@ - -%.v.d: %.v - $(COQDEP) -slash $(COQLIBS) "$<" > "$@" || ( RV=$$?; rm -f "$@"; exit $${RV} ) - -%.v.beautified: - $(COQC) $(COQDEBUG) $(COQFLAGS) -beautify $* - -# WARNING -# -# This Makefile has been automagically generated -# Edit at your own risks ! -# -# END OF WARNING - diff --git a/src/versions/native/Structures_native.v b/src/versions/native/Structures_native.v deleted file mode 100644 index 47ae21f..0000000 --- a/src/versions/native/Structures_native.v +++ /dev/null @@ -1,59 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2021 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -Require Import PArray. - - -Section Trace. - - (* We use [array array step] to allow bigger trace *) - Definition trace (step:Type) := array (array step). - - Definition trace_to_list {step:Type} (t:trace step) : list step := - PArray.fold_left (fun res a => List.app res (PArray.to_list a)) nil t. - - Definition trace_length {step:Type} (t:trace step) : int := - PArray.fold_left (fun l a => (l + (length a))%int63) 0%int63 t. - - Definition trace_get {step:Type} (t:trace step) (i:int) : step := - snd (PArray.fold_left (fun (jres:(option int) * step) a => - let (j,res) := jres in - match j with - | Some j' => - let l := length a in - if (j' < l)%int63 then - (None, get a j') - else - ((Some ((j' - l)%int63)),res) - | None => (None,res) - end - ) (Some i, (get (get t 0) 0)) t). - - Definition trace_fold {state step:Type} (transition: state -> step -> state) (s0:state) (t:trace step) := - PArray.fold_left (PArray.fold_left transition) s0 t. - - 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)%int63 = true -> P s0 -> P (transition s0 (trace_get t i))) : - forall s0 : state, P s0 -> P (trace_fold transition s0 t). - Proof. - apply PArray.fold_left_ind. - intros a i Hi Ha. - apply PArray.fold_left_ind;trivial. - intros a0 i0 Hi0 Ha0. (* IH applied to a0 and (sum of the lengths of the first i arrays + i0) *) - Admitted. - -End Trace. - - -Definition nat_eqb := beq_nat. -Definition nat_eqb_eq := beq_nat_true_iff. -Definition nat_eqb_refl := NPeano.Nat.eqb_refl. diff --git a/src/versions/native/Tactics_native.v b/src/versions/native/Tactics_native.v deleted file mode 100644 index 45d3603..0000000 --- a/src/versions/native/Tactics_native.v +++ /dev/null @@ -1,55 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2021 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -Require Import Psatz. - -Declare ML Module "smtcoq_plugin". - - - -Tactic Notation "verit_bool" constr_list(h) := - fail "Tactics are not supported with native-coq". - -Tactic Notation "verit_bool_no_check" constr_list(h) := - fail "Tactics are not supported with native-coq". - - -(** Tactics in Prop **) - -Ltac zchaff := - fail "Tactics are not supported with native-coq". -Ltac zchaff_no_check := - fail "Tactics are not supported with native-coq". - -Tactic Notation "verit" constr_list(h) := - fail "Tactics are not supported with native-coq". -Tactic Notation "verit_no_check" constr_list(h) := - fail "Tactics are not supported with native-coq". - -Ltac cvc4 := - fail "Tactics are not supported with native-coq". -Ltac cvc4_no_check := - fail "Tactics are not supported with native-coq". - - -Tactic Notation "smt" constr_list(h) := - fail "Tactics are not supported with native-coq". -Tactic Notation "smt_no_check" constr_list(h) := - fail "Tactics are not supported with native-coq". - - - -(* - Local Variables: - coq-load-path: ((rec "../.." "SMTCoq")) - End: -*) diff --git a/src/versions/native/smtcoq_plugin_native.ml4 b/src/versions/native/smtcoq_plugin_native.ml4 deleted file mode 100644 index ebf8511..0000000 --- a/src/versions/native/smtcoq_plugin_native.ml4 +++ /dev/null @@ -1,99 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2021 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -VERNAC COMMAND EXTEND Vernac_zchaff -| [ "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_zchaff_abs -| [ "Zchaff_Theorem_Abs" ident(name) string(fdimacs) string(fproof) ] -> - [ - Zchaff.theorem_abs name fdimacs fproof - ] -END - -VERNAC COMMAND EXTEND Vernac_verit -| [ "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 -| [ "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 = ref [] - -VERNAC COMMAND EXTEND Add_lemma -| [ "Add_lemmas" constr_list(lems) ] -> [ lemmas_list := lems @ !lemmas_list ] -| [ "Clear_lemmas" ] -> [ lemmas_list := [] ] -END - - -let error () = Structures.error "Tactics are not supported with native-coq" - -TACTIC EXTEND Tactic_verit -| [ "verit_bool_base" constr_list(lpl) ] -> [ error () ] -| [ "verit_bool_no_check_base" constr_list(lpl) ] -> [ error () ] -END - -TACTIC EXTEND Tactic_cvc4 -| [ "cvc4_bool" ] -> [ error () ] -| [ "cvc4_bool_no_check" ] -> [ error () ] -END diff --git a/src/versions/native/structures.ml b/src/versions/native/structures.ml deleted file mode 100644 index 435a1a1..0000000 --- a/src/versions/native/structures.ml +++ /dev/null @@ -1,186 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2021 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -open Entries -open Coqlib - - -(* Constr generation and manipulation *) -type id = Names.identifier -let mkId = Names.id_of_string - - -type name = Names.name -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.string_of_id id - | _ -> failwith "unnamed rel" - - -type constr = Term.constr -type types = Term.types -let eq_constr = Term.eq_constr -let hash_constr = Term.hash_constr -let mkProp = Term.mkProp -let mkConst = Term.mkConst -let mkVar = Term.mkVar -let mkRel = Term.mkRel -let isRel = Term.isRel -let destRel = Term.destRel -let lift = Term.lift -let mkApp = Term.mkApp -let decompose_app = Term.decompose_app -let mkLambda = Term.mkLambda -let mkProd = Term.mkProd -let mkLetIn = Term.mkLetIn - -let pr_constr_env = Printer.pr_constr_env -let pr_constr = Printer.pr_constr - - -let dummy_loc = Pp.dummy_loc - -let mkUConst c = - { const_entry_body = c; - const_entry_type = None; - const_entry_secctx = None; - const_entry_opaque = false; - const_entry_inline_code = false} - -let mkTConst c _ ty = - { const_entry_body = c; - const_entry_type = Some ty; - const_entry_secctx = None; - const_entry_opaque = false; - const_entry_inline_code = false} - -(* TODO : Set -> Type *) -let declare_new_type t = - Command.declare_assumption false (Decl_kinds.Local,Decl_kinds.Definitional) Term.mkSet [] false None (dummy_loc, t); - Term.mkVar t - -let declare_new_variable v constr_t = - Command.declare_assumption false (Decl_kinds.Local,Decl_kinds.Definitional) constr_t [] false None (dummy_loc, v); - Term.mkVar v - -let declare_constant n c = - Declare.declare_constant n (DefinitionEntry c, Decl_kinds.IsDefinition Decl_kinds.Definition) - - -type cast_kind = Term.cast_kind -let vmcast = Term.VMcast -let mkCast = Term.mkCast - - -(* EConstr *) -type econstr = Term.constr -let econstr_of_constr e = e - - -(* Modules *) -let gen_constant modules constant = lazy (gen_constant_in_modules "SMT" modules constant) - - -(* Int63 *) -let int63_modules = [["Coq";"Numbers";"Cyclic";"Int63";"Int63Native"]] - -let mkInt : int -> Term.constr = - fun i -> Term.mkInt (Uint63.of_int i) - -let cint = gen_constant int63_modules "int" - - -(* PArray *) -let parray_modules = [["Coq";"Array";"PArray"]] - -let max_array_size : int = - Parray.trunc_size (Uint63.of_int 4194303) -let mkArray : Term.types * Term.constr array -> Term.constr = - Term.mkArray - - -(* Traces *) -(* WARNING: side effect on r! *) -let mkTrace step_to_coq next carray _ _ _ _ size step def_step r = - let max = max_array_size - 1 in - let q,r1 = size / max, size mod max in - let trace = - let len = if r1 = 0 then q + 1 else q + 2 in - Array.make len (mkArray (step, [|def_step|])) in - for j = 0 to q - 1 do - let tracej = Array.make max_array_size def_step in - for i = 0 to max - 1 do - r := next !r; - tracej.(i) <- step_to_coq !r; - done; - trace.(j) <- mkArray (step, tracej) - done; - if r1 <> 0 then ( - let traceq = Array.make (r1 + 1) def_step in - for i = 0 to r1-1 do - r := next !r; - traceq.(i) <- step_to_coq !r; - done; - trace.(q) <- mkArray (step, traceq) - ); - mkArray (Term.mkApp (Lazy.force carray, [|step|]), trace) - - -(* Micromega *) -module Micromega_plugin_Micromega = Micromega -module Micromega_plugin_Certificate = Certificate - -let micromega_coq_proofTerm = - Coq_micromega.M.coq_proofTerm - -let micromega_dump_proof_term p = - Coq_micromega.dump_proof_term p - - -(* Tactics *) -type tactic = Proof_type.tactic -let tclTHEN = Tacticals.tclTHEN -let tclTHENLAST = Tacticals.tclTHENLAST -let assert_before = Tactics.assert_tac -let vm_cast_no_check = Tactics.vm_cast_no_check -let mk_tactic tac gl = - let env = Tacmach.pf_env gl in - let sigma = Tacmach.project gl in - let t = Tacmach.pf_concl gl in - tac env sigma t gl -let set_evars_tac _ = Tacticals.tclIDTAC - - -(* Other differences between the two versions of Coq *) -type constr_expr = Topconstr.constr_expr -let error = Errors.error -let warning _ s = Pp.warning s -let extern_constr = Constrextern.extern_constr true Environ.empty_env -let destruct_rel_decl (n, _, t) = n, t -let interp_constr env sigma = Constrintern.interp_constr sigma env -let ppconstr_lsimpleconstr = Ppconstr.lsimple -let constrextern_extern_constr = - let env = Global.env () in - Constrextern.extern_constr false env - -let get_rel_dec_name = fun _ -> Names.Anonymous - -(* Eta-expanded to get rid of optional arguments *) -let retyping_get_type_of env = Retyping.get_type_of env - -let vm_conv = Reduction.vm_conv -let cbv_vm = Vnorm.cbv_vm - - diff --git a/src/versions/native/structures.mli b/src/versions/native/structures.mli deleted file mode 100644 index f2775a6..0000000 --- a/src/versions/native/structures.mli +++ /dev/null @@ -1,117 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2021 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -(* 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 = Term.constr -type types = constr -val eq_constr : constr -> constr -> bool -val hash_constr : constr -> int -val mkProp : types -val mkConst : Names.constant -> 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.std_ppcmds -val pr_constr : constr -> Pp.std_ppcmds - -val mkUConst : constr -> Entries.definition_entry -val mkTConst : constr -> 'a -> types -> Entries.definition_entry -val declare_new_type : id -> types -val declare_new_variable : id -> types -> constr -val declare_constant : id -> Entries.definition_entry -> Names.constant - -type cast_kind -val vmcast : cast_kind -val mkCast : constr * cast_kind * constr -> constr - - -(* EConstr *) -type econstr = constr -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) -> - constr Lazy.t -> - 'b -> - 'c -> 'd -> 'e -> int -> types -> constr -> 'a ref -> constr - - -(* Micromega *) -module Micromega_plugin_Micromega = Micromega -module Micromega_plugin_Certificate = Certificate - -val micromega_coq_proofTerm : constr lazy_t -val micromega_dump_proof_term : Micromega_plugin_Certificate.Mc.zArithProof -> constr - - -(* Tactics *) -type tactic = Proof_type.tactic -val tclTHEN : Proof_type.tactic -> Proof_type.tactic -> Proof_type.tactic -val tclTHENLAST : Proof_type.tactic -> Proof_type.tactic -> Proof_type.tactic -val assert_before : name -> types -> Proof_type.tactic -val vm_cast_no_check : constr -> Proof_type.tactic -val mk_tactic : - (Environ.env -> - Evd.evar_map -> types -> Proof_type.goal Tacmach.sigma -> 'a) -> - Proof_type.goal Tacmach.sigma -> 'a -val set_evars_tac : 'a -> Proof_type.tactic - - -(* Other differences between the two versions of Coq *) -type constr_expr = Topconstr.constr_expr -val error : string -> 'a -val warning : string -> string -> unit -val extern_constr : constr -> Topconstr.constr_expr -val destruct_rel_decl : Term.rel_declaration -> name * types -val interp_constr : Environ.env -> Evd.evar_map -> Topconstr.constr_expr -> constr -val ppconstr_lsimpleconstr : Ppconstr.precedence -val constrextern_extern_constr : constr -> Topconstr.constr_expr -val get_rel_dec_name : 'a -> name -val retyping_get_type_of : Environ.env -> Evd.evar_map -> constr -> constr - -val vm_conv : Reduction.conv_pb -> types Reduction.conversion_function -val cbv_vm : Environ.env -> constr -> types -> constr diff --git a/src/versions/standard/Array/PArray_standard.v b/src/versions/standard/Array/PArray_standard.v deleted file mode 100644 index 25da052..0000000 --- a/src/versions/standard/Array/PArray_standard.v +++ /dev/null @@ -1,398 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2021 *) -(* *) -(* 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 *) - - -Declare Scope array_scope. - -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). - -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. - -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 9625bce..0000000 --- a/src/versions/standard/Int63/Int63Axioms_standard.v +++ /dev/null @@ -1,313 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2021 *) -(* *) -(* 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 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 0f9d6b7..0000000 --- a/src/versions/standard/Int63/Int63Native_standard.v +++ /dev/null @@ -1,144 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2021 *) -(* *) -(* 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. - -Declare Scope int63_scope. -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 bb7d9a1..0000000 --- a/src/versions/standard/Int63/Int63Op_standard.v +++ /dev/null @@ -1,334 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2021 *) -(* *) -(* 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 feb19b8..0000000 --- a/src/versions/standard/Int63/Int63Properties_standard.v +++ /dev/null @@ -1,2768 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2021 *) -(* *) -(* 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<>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 acee305..0000000 --- a/src/versions/standard/Int63/Int63_standard.v +++ /dev/null @@ -1,23 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2021 *) -(* *) -(* 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 1a0abf5..0000000 --- a/src/versions/standard/Structures_standard.v +++ /dev/null @@ -1,64 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2021 *) -(* *) -(* 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 f79b253..0000000 --- a/src/versions/standard/Tactics_standard.v +++ /dev/null @@ -1,157 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2021 *) -(* *) -(* 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 k := - match goal with - | [ H : ?P |- _ ] => - let T := type of P in - lazymatch T with - | Prop => - lazymatch P with - | id _ => fail - | _ => - change P with (id P) in H; - match acc with - | Some ?t => get_hyps_acc (Some (H, t)) k - | None => get_hyps_acc (Some H) k - end - end - | _ => fail - end - | _ => k 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 k := get_hyps_acc (@None nat) ltac:(fun Hs => eliminate_id; k Hs). - - -Section Test. - Variable A : Type. - Hypothesis H1 : forall a:A, a = a. - Variable n : Z. - Hypothesis H2 : n = 17%Z. - - Goal True. - Proof. - (* get_hyps ltac:(fun acc => idtac acc). *) - Abort. -End Test. - - -(** Tactics in bool *) - -Tactic Notation "verit_bool_base_auto" constr(h) := verit_bool_base h; auto with typeclass_instances. -Tactic Notation "verit_bool_no_check_base_auto" constr(h) := verit_bool_no_check_base h; auto with typeclass_instances. - -Tactic Notation "verit_bool" constr(h) := - get_hyps ltac:(fun Hs => - 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" := - get_hyps ltac:(fun Hs => verit_bool_base_auto Hs; vauto). - -Tactic Notation "verit_bool_no_check" constr(h) := - get_hyps ltac:(fun Hs => - 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" := - get_hyps ltac:(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; - [ .. | get_hyps ltac:(fun Hs => - 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; - [ .. | get_hyps ltac:(fun Hs => - 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; - [ .. | get_hyps ltac:(fun Hs => - 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; - [ .. | get_hyps ltac:(fun Hs => - 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 133565d..0000000 --- a/src/versions/standard/_CoqProject +++ /dev/null @@ -1,156 +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/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.mlg -smtcoq_plugin.mlpack diff --git a/src/versions/standard/g_smtcoq_standard.mlg b/src/versions/standard/g_smtcoq_standard.mlg deleted file mode 100644 index 5cfb287..0000000 --- a/src/versions/standard/g_smtcoq_standard.mlg +++ /dev/null @@ -1,123 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2021 *) -(* *) -(* 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 -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/smtcoq_plugin_standard.mlpack b/src/versions/standard/smtcoq_plugin_standard.mlpack deleted file mode 100644 index f210db1..0000000 --- a/src/versions/standard/smtcoq_plugin_standard.mlpack +++ /dev/null @@ -1,52 +0,0 @@ -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 863c921..0000000 --- a/src/versions/standard/structures.ml +++ /dev/null @@ -1,237 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2021 *) -(* *) -(* 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 (n, t, c) = Constr.mkLambda (Context.make_annot n Sorts.Relevant, t, c) -let mkProd (n, t, c) = Constr.mkProd (Context.make_annot n Sorts.Relevant, t, c) -let mkLetIn (n, c1, t, c2) = Constr.mkLetIn (Context.make_annot n Sorts.Relevant, c1, t, c2) -let mkArrow a b = Term.mkArrow a Sorts.Relevant b - -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.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.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 ~pstate:None false (Decl_kinds.Discharge, false, Decl_kinds.Definitional) (Constr.mkSet, Entries.Monomorphic_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 ~pstate:None false (Decl_kinds.Discharge, false, Decl_kinds.Definitional) (constr_t, Evd.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_monomorphic_global will crash on universe polymorphic constants *) - UnivGen.constr_of_monomorphic_global @@ Coqlib.gen_reference_in_modules s m n -let gen_constant modules constant = lazy (gen_constant_in_modules "SMT" modules constant) -let init_modules = Coqlib.init_modules - - -(* 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_Certificate = Micromega_plugin.Certificate - -let micromega_coq_proofTerm = - (* Cannot contain evars *) - lazy (gen_constant_in_modules "ZMicromega" [["Coq"; "micromega";"ZMicromega"]] "ZArithProof") - -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.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, _, _) -> - Context.binder_name 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 104f3f9..0000000 --- a/src/versions/standard/structures.mli +++ /dev/null @@ -1,122 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2021 *) -(* *) -(* 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 mkArrow : types -> types -> 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 -val init_modules : string list list - - -(* 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_Certificate = Micromega_plugin.Certificate - -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 diff --git a/src/zchaff/zchaff.ml b/src/zchaff/zchaff.ml index c6bdc64..1f5110b 100644 --- a/src/zchaff/zchaff.ml +++ b/src/zchaff/zchaff.ml @@ -133,7 +133,7 @@ let import_cnf_trace reloc filename first last = let make_roots first last = let cint = Lazy.force cint in - let roots = Array.make (last.id + 2) (Structures.mkArray (cint, Array.make 1 (mkInt 0))) in + let roots = Array.make (last.id + 2) (CoqInterface.mkArray (cint, Array.make 1 (mkInt 0))) in let mk_elem l = let x = match Form.pform l with | Fatom x -> x + 2 @@ -144,15 +144,15 @@ let make_roots first last = let root = Array.of_list (get_val !r) in let croot = Array.make (Array.length root + 1) (mkInt 0) in Array.iteri (fun i l -> croot.(i) <- mk_elem l) root; - roots.(!r.id) <- Structures.mkArray (cint, croot); + roots.(!r.id) <- CoqInterface.mkArray (cint, croot); r := next !r done; let root = Array.of_list (get_val !r) in let croot = Array.make (Array.length root + 1) (mkInt 0) in Array.iteri (fun i l -> croot.(i) <- mk_elem l) root; - roots.(!r.id) <- Structures.mkArray (cint, croot); + roots.(!r.id) <- CoqInterface.mkArray (cint, croot); - Structures.mkArray (mklApp carray [|cint|], roots) + CoqInterface.mkArray (mklApp carray [|cint|], roots) let interp_roots first last = let tbl = Hashtbl.create 17 in @@ -164,7 +164,7 @@ let interp_roots first last = let h = if Form.is_pos l then ph else ph lxor 1 in try Hashtbl.find tbl h with Not_found -> - let p = Structures.mkApp (Structures.mkRel 1, [|mkInt (x+1)|]) in + let p = CoqInterface.mkApp (CoqInterface.mkRel 1, [|mkInt (x+1)|]) in let np = mklApp cnegb [|p|] in Hashtbl.add tbl ph p; Hashtbl.add tbl (ph lxor 1) np; @@ -194,15 +194,15 @@ let parse_certif dimacs trace fdimacs ftrace = SmtTrace.clear (); let _,first,last,reloc = import_cnf fdimacs in let d = make_roots first last in - let ce1 = Structures.mkUConst d in - let _ = Structures.declare_constant dimacs ce1 in + let ce1 = CoqInterface.mkUConst d in + let _ = CoqInterface.declare_constant dimacs ce1 in let max_id, confl = import_cnf_trace reloc ftrace first last in let (tres,_,_) = SmtTrace.to_coq (fun _ -> assert false) (fun _ -> assert false) certif_ops confl None in let certif = mklApp cCertif [|mkInt (max_id + 1); tres;mkInt (get_pos confl)|] in - let ce2 = Structures.mkUConst certif in - let _ = Structures.declare_constant trace ce2 in + let ce2 = CoqInterface.mkUConst certif in + let _ = CoqInterface.declare_constant trace ce2 in () let cdimacs = gen_constant sat_checker_modules "dimacs" @@ -222,36 +222,36 @@ let theorems interp name fdimacs ftrace = mklApp cCertif [|mkInt (max_id + 1);tres;mkInt (get_pos confl)|] in let theorem_concl = mklApp cnot [|mklApp cis_true [|interp d first last|] |] in - let vtype = Structures.mkArrow (Lazy.force cint) (Lazy.force cbool) in + let vtype = CoqInterface.mkArrow (Lazy.force cint) (Lazy.force cbool) in let theorem_type = - Structures.mkProd (Structures.mkName "v", vtype, theorem_concl) in + CoqInterface.mkProd (CoqInterface.mkName "v", vtype, theorem_concl) in let theorem_proof_cast = - Structures.mkCast ( - Structures.mkLetIn (Structures.mkName "d", d, Lazy.force cdimacs, - Structures.mkLetIn (Structures.mkName "c", certif, Lazy.force ccertif, - Structures.mkLambda (Structures.mkName "v", vtype, + CoqInterface.mkCast ( + CoqInterface.mkLetIn (CoqInterface.mkName "d", d, Lazy.force cdimacs, + CoqInterface.mkLetIn (CoqInterface.mkName "c", certif, Lazy.force ccertif, + CoqInterface.mkLambda (CoqInterface.mkName "v", vtype, mklApp ctheorem_checker - [| Structures.mkRel 3(*d*); Structures.mkRel 2(*c*); + [| CoqInterface.mkRel 3(*d*); CoqInterface.mkRel 2(*c*); vm_cast_true_no_check - (mklApp cchecker [|Structures.mkRel 3(*d*); Structures.mkRel 2(*c*)|]); - Structures.mkRel 1(*v*)|]))), - Structures.vmcast, + (mklApp cchecker [|CoqInterface.mkRel 3(*d*); CoqInterface.mkRel 2(*c*)|]); + CoqInterface.mkRel 1(*v*)|]))), + CoqInterface.vmcast, theorem_type) in let theorem_proof_nocast = - Structures.mkLetIn (Structures.mkName "d", d, Lazy.force cdimacs, - Structures.mkLetIn (Structures.mkName "c", certif, Lazy.force ccertif, - Structures.mkLambda (Structures.mkName "v", vtype, + CoqInterface.mkLetIn (CoqInterface.mkName "d", d, Lazy.force cdimacs, + CoqInterface.mkLetIn (CoqInterface.mkName "c", certif, Lazy.force ccertif, + CoqInterface.mkLambda (CoqInterface.mkName "v", vtype, mklApp ctheorem_checker - [| Structures.mkRel 3(*d*); Structures.mkRel 2(*c*)|]))) + [| CoqInterface.mkRel 3(*d*); CoqInterface.mkRel 2(*c*)|]))) in - let ce = Structures.mkTConst theorem_proof_cast theorem_proof_nocast theorem_type in - let _ = Structures.declare_constant name ce in + let ce = CoqInterface.mkTConst theorem_proof_cast theorem_proof_nocast theorem_type in + let _ = CoqInterface.declare_constant name ce in () let theorem = theorems (fun _ -> interp_roots) let theorem_abs = - theorems (fun d _ _ -> mklApp cvalid_sat_checker [|mklApp cinterp_var_sat_checker [|Structures.mkRel 1(*v*)|]; d|]) + theorems (fun d _ _ -> mklApp cvalid_sat_checker [|mklApp cinterp_var_sat_checker [|CoqInterface.mkRel 1(*v*)|]; d|]) let checker fdimacs ftrace = @@ -267,9 +267,9 @@ let checker fdimacs ftrace = let tm = mklApp cchecker [|d; certif|] in - let res = Structures.cbv_vm (Global.env ()) tm (Lazy.force CoqTerms.cbool) in + let res = CoqInterface.cbv_vm (Global.env ()) tm (Lazy.force CoqTerms.cbool) in Format.eprintf " = %s\n : bool@." - (if Structures.eq_constr res (Lazy.force CoqTerms.ctrue) then + (if CoqInterface.eq_constr res (Lazy.force CoqTerms.ctrue) then "true" else "false") @@ -358,22 +358,22 @@ let cchecker_eq_correct = let cchecker_eq = gen_constant cnf_checker_modules "checker_eq" let build_body reify_atom reify_form l b (max_id, confl) vm_cast = - let ntvar = Structures.mkName "t_var" in - let ntform = Structures.mkName "t_form" in - let nc = Structures.mkName "c" in + let ntvar = CoqInterface.mkName "t_var" in + let ntform = CoqInterface.mkName "t_form" in + let nc = CoqInterface.mkName "c" in let tvar = Atom.interp_tbl reify_atom in let _, tform = Form.interp_tbl reify_form in let (tres,_,_) = SmtTrace.to_coq Form.to_coq (fun _ -> assert false) certif_ops confl None in let certif = mklApp cCertif [|mkInt (max_id + 1);tres;mkInt (get_pos confl)|] in - let vtvar = Structures.mkRel 3 in - let vtform = Structures.mkRel 2 in - let vc = Structures.mkRel 1 in + let vtvar = CoqInterface.mkRel 3 in + let vtform = CoqInterface.mkRel 2 in + let vc = CoqInterface.mkRel 1 in let add_lets t = - Structures.mkLetIn (ntvar, tvar, mklApp carray [|Lazy.force cbool|], - Structures.mkLetIn (ntform, tform, mklApp carray [|Lazy.force cform|], - Structures.mkLetIn (nc, certif, Lazy.force ccertif, + CoqInterface.mkLetIn (ntvar, tvar, mklApp carray [|Lazy.force cbool|], + CoqInterface.mkLetIn (ntform, tform, mklApp carray [|Lazy.force cform|], + CoqInterface.mkLetIn (nc, certif, Lazy.force ccertif, t))) in let cbc = @@ -391,22 +391,22 @@ let build_body reify_atom reify_form l b (max_id, confl) vm_cast = let build_body_eq reify_atom reify_form l1 l2 l (max_id, confl) vm_cast = - let ntvar = Structures.mkName "t_var" in - let ntform = Structures.mkName "t_form" in - let nc = Structures.mkName "c" in + let ntvar = CoqInterface.mkName "t_var" in + let ntform = CoqInterface.mkName "t_form" in + let nc = CoqInterface.mkName "c" in let tvar = Atom.interp_tbl reify_atom in let _, tform = Form.interp_tbl reify_form in let (tres,_,_) = SmtTrace.to_coq Form.to_coq (fun _ -> assert false) certif_ops confl None in let certif = mklApp cCertif [|mkInt (max_id + 1);tres;mkInt (get_pos confl)|] in - let vtvar = Structures.mkRel 3 in - let vtform = Structures.mkRel 2 in - let vc = Structures.mkRel 1 in + let vtvar = CoqInterface.mkRel 3 in + let vtform = CoqInterface.mkRel 2 in + let vc = CoqInterface.mkRel 1 in let add_lets t = - Structures.mkLetIn (ntvar, tvar, mklApp carray [|Lazy.force cbool|], - Structures.mkLetIn (ntform, tform, mklApp carray [|Lazy.force cform|], - Structures.mkLetIn (nc, certif, Lazy.force ccertif, + CoqInterface.mkLetIn (ntvar, tvar, mklApp carray [|Lazy.force cbool|], + CoqInterface.mkLetIn (ntform, tform, mklApp carray [|Lazy.force cform|], + CoqInterface.mkLetIn (nc, certif, Lazy.force ccertif, t))) in let ceqc = add_lets (mklApp cchecker_eq [|vtform;l1;l2;l;vc|]) @@ -421,10 +421,10 @@ let build_body_eq reify_atom reify_form l1 l2 l (max_id, confl) vm_cast = (proof_cast, proof_nocast) let get_arguments concl = - let f, args = Structures.decompose_app concl in + let f, args = CoqInterface.decompose_app concl in match args with - | [ty;a;b] when (Structures.eq_constr f (Lazy.force ceq)) && (Structures.eq_constr ty (Lazy.force cbool)) -> a, b - | [a] when (Structures.eq_constr f (Lazy.force cis_true)) -> a, Lazy.force ctrue + | [ty;a;b] when (CoqInterface.eq_constr f (Lazy.force ceq)) && (CoqInterface.eq_constr ty (Lazy.force cbool)) -> a, b + | [a] when (CoqInterface.eq_constr f (Lazy.force cis_true)) -> a, Lazy.force ctrue | _ -> failwith ("Zchaff.get_arguments :can only deal with equality over bool") @@ -499,7 +499,7 @@ let make_proof pform_tbl atom_tbl env reify_form l = let (reloc, resfilename, logfilename, last) = call_zchaff (Form.nvars reify_form) root in (try check_unsat resfilename with - | Sat model -> Structures.error (List.fold_left (fun acc i -> + | Sat model -> CoqInterface.error (List.fold_left (fun acc i -> let index = if i > 0 then i-1 else -i-1 in let ispos = i > 0 in try ( @@ -508,7 +508,7 @@ let make_proof pform_tbl atom_tbl env reify_form l = | Fatom a -> let t = atom_tbl.(a) in let value = if ispos then " = true" else " = false" in - acc^" "^(Pp.string_of_ppcmds (Structures.pr_constr_env env t))^value + acc^" "^(Pp.string_of_ppcmds (CoqInterface.pr_constr_env env t))^value | Fapp _ -> acc (* Nothing to do with ZChaff *) | FbbT _ -> assert false @@ -528,9 +528,9 @@ let core_tactic vm_cast env sigma concl = let reify_atom = Atom.create () in let reify_form = Form.create () in let (body_cast, body_nocast) = - if ((Structures.eq_constr b (Lazy.force ctrue)) || (Structures.eq_constr b (Lazy.force cfalse))) then + if ((CoqInterface.eq_constr b (Lazy.force ctrue)) || (CoqInterface.eq_constr b (Lazy.force cfalse))) then let l = Form.of_coq (Atom.get reify_atom) reify_form a in - let l' = if (Structures.eq_constr b (Lazy.force ctrue)) then Form.neg l else l in + let l' = if (CoqInterface.eq_constr b (Lazy.force ctrue)) then Form.neg l else l in let atom_tbl = Atom.atom_tbl reify_atom in let pform_tbl = Form.pform_tbl reify_form in let max_id_confl = make_proof pform_tbl atom_tbl (Environ.push_rel_context forall_let env) reify_form l' in @@ -551,10 +551,10 @@ let core_tactic vm_cast env sigma concl = let res_cast = compose_lam_assum forall_let body_cast in let res_nocast = compose_lam_assum forall_let body_nocast in - (Structures.tclTHEN - (Structures.set_evars_tac res_nocast) - (Structures.vm_cast_no_check res_cast)) + (CoqInterface.tclTHEN + (CoqInterface.set_evars_tac res_nocast) + (CoqInterface.vm_cast_no_check res_cast)) -let tactic () = Structures.tclTHEN Tactics.intros (Structures.mk_tactic (core_tactic vm_cast_true)) -let tactic_no_check () = Structures.tclTHEN Tactics.intros (Structures.mk_tactic (core_tactic (fun _ -> vm_cast_true_no_check))) +let tactic () = CoqInterface.tclTHEN Tactics.intros (CoqInterface.mk_tactic (core_tactic vm_cast_true)) +let tactic_no_check () = CoqInterface.tclTHEN Tactics.intros (CoqInterface.mk_tactic (core_tactic (fun _ -> vm_cast_true_no_check))) diff --git a/src/zchaff/zchaff.mli b/src/zchaff/zchaff.mli index 3f458d3..1e472fc 100644 --- a/src/zchaff/zchaff.mli +++ b/src/zchaff/zchaff.mli @@ -11,9 +11,9 @@ val pp_trace : Format.formatter -> SatAtom.Form.t SmtCertif.clause -> unit -val parse_certif : Structures.id -> Structures.id -> string -> string -> unit +val parse_certif : CoqInterface.id -> CoqInterface.id -> string -> string -> unit val checker : string -> string -> unit -val theorem : Structures.id -> string -> string -> unit -val theorem_abs : Structures.id -> string -> string -> unit -val tactic : unit -> Structures.tactic -val tactic_no_check : unit -> Structures.tactic +val theorem : CoqInterface.id -> string -> string -> unit +val theorem_abs : CoqInterface.id -> string -> string -> unit +val tactic : unit -> CoqInterface.tactic +val tactic_no_check : unit -> CoqInterface.tactic -- cgit