├── .gitignore ├── ACKS ├── FPBench ├── Makefile ├── README.md ├── _CoqProject ├── carbongas.v ├── doppler1.v ├── doppler2.v ├── doppler3.v ├── himmilbeau.v ├── jetengine.v ├── kepler0.v ├── kepler1.v ├── kepler2.v ├── multivar_6.v ├── predatorprey.v ├── rigid_body1.v ├── rigid_body2.v ├── t_div_t1.v ├── turbine1.v ├── turbine2.v ├── turbine3.v └── verhulst.v ├── LICENSE ├── OLD_LICENSE ├── README ├── TODO.md ├── Test ├── .gitignore ├── Makefile ├── Nonstd.v ├── README.md ├── Test.v ├── Test2.v ├── TestFunc.v ├── TestPaper.v ├── TestRefman.v ├── _CoqProject ├── autobisect.v └── summation.v ├── coq-vcfloat.opam ├── doc ├── VCFloat-Manual.pdf ├── VCFloat-Manual.tex ├── lstlangcoq.sty └── vcfloat2.pdf ├── gpl-3.0.txt └── vcfloat ├── .depend ├── Automate.v ├── Base.v ├── BigQAux.v ├── BigRAux.v ├── FMap_lemmas.v ├── FPCompCert.v ├── FPCore.v ├── FPLang.v ├── FPLangOpt.v ├── FPLib.v ├── FPStdCompCert.v ├── FPStdLib.v ├── Float_lemmas.v ├── Float_notations.v ├── Fprop_absolute.v ├── IEEE754_extra.v ├── LibTac.v ├── Makefile ├── Prune.v ├── Q2RAux.v ├── RAux.v ├── Reify.v ├── Rounding.v ├── Summation.v ├── VCFloat.v ├── Version.v ├── _CoqProject ├── compute_tactics_ltac2.v ├── junk ├── Example.v └── Taylor.v └── klist.v /.gitignore: -------------------------------------------------------------------------------- 1 | dir-locals 2 | #Makefile 3 | *.aux 4 | .dir-locals.el 5 | *.glob 6 | *.v.d 7 | *.vo 8 | *.vos 9 | *.vok 10 | run-coqide.sh 11 | *~ 12 | *.tgz 13 | *.tar.gz 14 | rcoqlib*/* 15 | compcert*/* 16 | ssreflect*/* 17 | mathcomp*/* 18 | flocq*/* 19 | interval*/* 20 | coqopts 21 | *.crashcoqide 22 | *.cache 23 | .coq-native/ 24 | -------------------------------------------------------------------------------- /ACKS: -------------------------------------------------------------------------------- 1 | VCFloat depends on the following external libraries, 2 | which are normally supplied by the Coq Platform installation 3 | (either by opam or by other means): 4 | 5 | - The CompCert C verified compiler. 6 | 7 | Copyright (C) 2004-2022 INRIA. 8 | 9 | VCFloat can be built and used with or without CompCert. 10 | Some components of VCFloat (and some applications of VCFloat) need 11 | CompCert, other components (and applications) do not. 12 | 13 | Those parts of VCFloat that depend on CompCert, require only 14 | CompCert's dual-licensed components: that is, the portion of CompCert 15 | that is licensed by either/both the (open-source) GNU Lesser Public License 16 | and the (not open-source) INRIA License. See the CompCert 17 | distribution for explanations of licenses. 18 | 19 | - Flocq, a Floating-Point Library for Coq. 20 | 21 | Copyright (C) 2010-2022 Sylvie Boldo and Guillaume Melquiond. 22 | 23 | Flocq is distributed under the GNU Lesser General Public License, 24 | (GNU LGPL) version 3.0 (reproduced verbatim in extenso below). 25 | 26 | - Coq-Interval, an Interval Package for Coq. 27 | 28 | Copyright (C) 2007-2022 Guillaume Melquiond. 29 | 30 | Coq-Interval is distributed under the CeCILL-C free software 31 | license (reproduced verbatim in cecill-c.txt). 32 | 33 | -------------------------------------------------------------------------------- /FPBench/Makefile: -------------------------------------------------------------------------------- 1 | COQC=coqc 2 | COQDEP=coqdep 3 | VCFLOAT_LOC=../vcfloat 4 | COQFLAGS= -Q $(VCFLOAT_LOC) vcfloat 5 | 6 | all: _CoqProject target 7 | 8 | _CoqProject: Makefile 9 | echo $(COQFLAGS) >_CoqProject 10 | 11 | target: doppler1.vo doppler2.vo doppler3.vo predatorprey.vo verhulst.vo carbongas.vo t_div_t1.vo\ 12 | kepler0.vo kepler1.vo kepler2.vo rigid_body1.vo rigid_body2.vo turbine1.vo turbine2.vo\ 13 | turbine3.vo himmilbeau.vo jetengine.vo 14 | 15 | %.vo: %.v 16 | $(COQC) $(COQFLAGS) $*.v 17 | 18 | depend: 19 | $(COQDEP) $(COQFLAGS) *.v cverif/*.v > .depend 20 | 21 | all_clean: rm *.vo *.vok *.vos *.glob 22 | 23 | -include .depend 24 | 25 | 26 | vcfloat: $(VCFLOAT_LOC)/Automate.vo $(VCFLOAT_LOC)/Prune.vo 27 | cd ../vcfloat; make vcfloat2 28 | -------------------------------------------------------------------------------- /FPBench/README.md: -------------------------------------------------------------------------------- 1 | This directory contains benchmark tests from the FPBench 2 | benchmark suite for floating-point roundoff analyzers, 3 | https://github.com/FPBench/FPBench 4 | 5 | -------------------------------------------------------------------------------- /FPBench/_CoqProject: -------------------------------------------------------------------------------- 1 | -Q ../vcfloat vcfloat 2 | -------------------------------------------------------------------------------- /FPBench/carbongas.v: -------------------------------------------------------------------------------- 1 | Require Import vcfloat.VCFloat. 2 | Require Import Interval.Tactic. 3 | Import Binary Coq.Lists.List ListNotations. 4 | Set Bullet Behavior "Strict Subproofs". 5 | Section WITHNANS. 6 | Context {NANS:Nans}. 7 | Open Scope R_scope. 8 | 9 | Definition carbongas_bmap_list := [Build_varinfo Tdouble 1%positive (1e-1) (5e-1)]. 10 | 11 | Definition carbongas_bmap := 12 | ltac:(let z := compute_PTree (boundsmap_of_list carbongas_bmap_list) in exact z). 13 | 14 | Definition carbongas (v : ftype Tdouble) := 15 | cast Tdouble (let p := (35e6)%F64 in 16 | let a := (401e-3)%F64 in 17 | let b := (427e-7)%F64 in 18 | let t := (300)%F64 in 19 | let n := (1000)%F64 in 20 | let k := (13806503e-30)%F64 in 21 | (((p + ((a * (n / v)%F64)%F64 * (n / v)%F64)%F64)%F64 * (v - (n * b)%F64)%F64)%F64 - ((k * n)%F64 * t)%F64)%F64). 22 | 23 | Definition carbongas_expr := 24 | ltac:(let e' := HO_reify_float_expr constr:([1%positive]) carbongas in exact e'). 25 | 26 | 27 | Derive carbongas_b 28 | SuchThat (forall vmap, prove_roundoff_bound carbongas_bmap vmap carbongas_expr carbongas_b) 29 | As carbongas_bound. 30 | Proof. 31 | idtac "Starting carbongas". 32 | time "carbongas" ( 33 | try (subst carbongas_b; intro; prove_roundoff_bound); 34 | try (prove_rndval; interval); 35 | try (prove_roundoff_bound2; error_rewrites); 36 | try ( 37 | (prune_terms (cutoff 60); 38 | try match goal with |- (Rabs ?e <= ?a - 0)%R => 39 | rewrite Rminus_0_r (* case prune terms will fail to produce reasonable bound on goal*) 40 | end)); 41 | (try match goal with |- (Rabs ?e <= ?a - ?b)%R => 42 | try (interval_intro (Rabs e) as G; 43 | eapply Rle_trans; 44 | [apply G | apply Rminus_plus_le_minus; apply Rle_refl]) end); 45 | try ( 46 | try field_simplify_Rabs ; 47 | try match goal with |-Rabs ?a <= _ => 48 | try (interval_intro (Rabs a) upper with 49 | (i_taylor vxH, i_bisect vxH, i_depth 15) as H' ; apply H'); 50 | try (interval_intro (Rabs a) upper as H' ; apply H') end; 51 | apply Rle_refl)). 52 | Time Qed. 53 | 54 | Lemma check_carbongas_bound: ltac:(CheckBound carbongas_b 2.5e-08%F64). 55 | Proof. reflexivity. Qed. 56 | 57 | 58 | End WITHNANS. 59 | Close Scope R_scope. 60 | -------------------------------------------------------------------------------- /FPBench/doppler1.v: -------------------------------------------------------------------------------- 1 | Require Import vcfloat.VCFloat. 2 | Require Import Interval.Tactic. 3 | Import Binary Coq.Lists.List ListNotations. 4 | Set Bullet Behavior "Strict Subproofs". 5 | Section WITHNANS. 6 | Context {NANS:Nans}. 7 | Open Scope R_scope. 8 | 9 | Definition _u : ident := 1%positive. 10 | Definition _v : ident := 2%positive. 11 | Definition _t : ident := 3%positive. 12 | 13 | Definition doppler1_bmap_list := [ 14 | Build_varinfo Tdouble _u (-100) (100); 15 | Build_varinfo Tdouble _v (20) (2e4); 16 | Build_varinfo Tdouble _t (-30) (50)]. 17 | 18 | Definition doppler1_bmap := 19 | ltac:(let z := compute_PTree (boundsmap_of_list doppler1_bmap_list) in exact z). 20 | 21 | Definition doppler1 (u : ftype Tdouble) (v : ftype Tdouble) (t : ftype Tdouble) := 22 | let t1 := ((3314e-1)%F64 + ((6e-1)%F64 * t)%F64)%F64 in 23 | (((-t1) * v)%F64 / ((t1 + u)%F64 * (t1 + u)%F64)%F64)%F64. 24 | 25 | Definition doppler1_expr := 26 | ltac:(let e' := HO_reify_float_expr constr:([_u;_v;_t]) doppler1 in exact e'). 27 | 28 | Derive doppler1_b 29 | SuchThat (forall vmap, prove_roundoff_bound doppler1_bmap vmap doppler1_expr doppler1_b) 30 | As doppler1_bound. 31 | Proof. 32 | idtac "Starting doppler1". 33 | time "doppler1" ( 34 | (subst doppler1_b; intro; prove_roundoff_bound); 35 | try (prove_rndval; interval); 36 | try (prove_roundoff_bound2; error_rewrites; 37 | ((prune_terms (cutoff 30); 38 | try match goal with |- (Rabs ?e <= ?a - 0)%R => 39 | rewrite Rminus_0_r (* case prune terms will fail to produce reasonable bound on goal*) 40 | end; 41 | try match goal with |- (Rabs ?e <= ?a - ?b)%R => 42 | let G := fresh "G" in 43 | interval_intro (Rabs e) as G ; 44 | eapply Rle_trans; 45 | [apply G | apply Rminus_plus_le_minus; apply Rle_refl] end))); 46 | try match goal with |- Rabs ?a <= _ => 47 | interval_intro (Rabs a) with (i_bisect v_v, 48 | i_depth 17) as H'; apply H'; apply Rle_refl 49 | end; 50 | try match goal with |- Rabs ?a <= _ => 51 | interval_intro (Rabs a) with (i_bisect v_u, 52 | i_bisect v_t, i_depth 17) as H'; apply H'; apply Rle_refl 53 | end). 54 | Time Qed. 55 | 56 | Lemma check_doppler1_bound: ltac:(CheckBound doppler1_b 4.5e-13%F64). 57 | Proof. reflexivity. Qed. 58 | 59 | 60 | End WITHNANS. 61 | Close Scope R_scope. -------------------------------------------------------------------------------- /FPBench/doppler2.v: -------------------------------------------------------------------------------- 1 | Require Import vcfloat.VCFloat. 2 | Require Import Interval.Tactic. 3 | Import Binary Coq.Lists.List ListNotations. 4 | Set Bullet Behavior "Strict Subproofs". 5 | Section WITHNANS. 6 | Context {NANS:Nans}. 7 | Open Scope R_scope. 8 | 9 | Definition _u : ident := 1%positive. 10 | Definition _v : ident := 2%positive. 11 | Definition _t : ident := 3%positive. 12 | 13 | Definition doppler2_bmap_list := [ 14 | Build_varinfo Tdouble _u (-125) (125); 15 | Build_varinfo Tdouble _v (15) (25000); 16 | Build_varinfo Tdouble _t (-40) (60)]. 17 | 18 | Definition doppler2_bmap := 19 | ltac:(let z := compute_PTree (boundsmap_of_list doppler2_bmap_list) in exact z). 20 | 21 | Definition doppler2 (u : ftype Tdouble) (v : ftype Tdouble) (t : ftype Tdouble) := 22 | cast Tdouble (let t1 := ((3314e-1)%F64 + ((6e-1)%F64 * t)%F64)%F64 in 23 | (((-t1) * v)%F64 / ((t1 + u)%F64 * (t1 + u)%F64)%F64)%F64). 24 | 25 | Definition doppler2_expr := 26 | ltac:(let e' := HO_reify_float_expr constr:([_u;_v;_t]) doppler2 in exact e'). 27 | 28 | Derive doppler2_b 29 | SuchThat (forall vmap, prove_roundoff_bound doppler2_bmap vmap doppler2_expr doppler2_b) 30 | As doppler2_bound. 31 | Proof. 32 | idtac "Starting doppler2". 33 | time "doppler2" ( 34 | (subst doppler2_b; intro; prove_roundoff_bound); 35 | try (prove_rndval; interval); 36 | try (prove_roundoff_bound2; error_rewrites; 37 | ((prune_terms (cutoff 30); 38 | try match goal with |- (Rabs ?e <= ?a - 0)%R => 39 | rewrite Rminus_0_r (* case prune terms will fail to produce reasonable bound on goal*) 40 | end; 41 | try match goal with |- (Rabs ?e <= ?a - ?b)%R => 42 | let G := fresh "G" in 43 | interval_intro (Rabs e) as G ; 44 | eapply Rle_trans; 45 | [apply G | apply Rminus_plus_le_minus; apply Rle_refl] end))); 46 | try match goal with |- Rabs ?a <= _ => 47 | interval_intro (Rabs a) with (i_bisect v_v, 48 | i_depth 17) as H'; apply H'; apply Rle_refl 49 | end; 50 | try match goal with |- Rabs ?a <= _ => 51 | interval_intro (Rabs a) with (i_bisect v_u, 52 | i_bisect v_t, i_depth 17) as H'; apply H'; apply Rle_refl 53 | end). 54 | Time Qed. 55 | 56 | Lemma check_doppler2_bound: ltac:(CheckBound doppler2_b 1.2e-12%F64). 57 | Proof. reflexivity. Qed. 58 | 59 | End WITHNANS. 60 | Close Scope R_scope. -------------------------------------------------------------------------------- /FPBench/doppler3.v: -------------------------------------------------------------------------------- 1 | Require Import vcfloat.VCFloat. 2 | Require Import Interval.Tactic. 3 | Import Binary Coq.Lists.List ListNotations. 4 | Set Bullet Behavior "Strict Subproofs". 5 | Section WITHNANS. 6 | Context {NANS:Nans}. 7 | Open Scope R_scope. 8 | 9 | 10 | Definition _u : ident := 1%positive. 11 | Definition _v : ident := 2%positive. 12 | Definition _t : ident := 3%positive. 13 | 14 | Definition doppler3_bmap_list := [Build_varinfo Tdouble _u (-30) (120);Build_varinfo Tdouble _v (320) (20300);Build_varinfo Tdouble _t (-50) (30)]. 15 | 16 | Definition doppler3_bmap := 17 | ltac:(let z := compute_PTree (boundsmap_of_list doppler3_bmap_list) in exact z). 18 | 19 | Definition doppler3 (u : ftype Tdouble) (v : ftype Tdouble) (t : ftype Tdouble) := 20 | cast Tdouble (let t1 := ((3314e-1)%F64 + ((6e-1)%F64 * t)%F64)%F64 in 21 | (((-t1) * v)%F64 / ((t1 + u)%F64 * (t1 + u)%F64)%F64)%F64). 22 | 23 | Definition doppler3_expr := 24 | ltac:(let e' := HO_reify_float_expr constr:([_u;_v;_t]) doppler3 in exact e'). 25 | 26 | Derive doppler3_b 27 | SuchThat (forall vmap, prove_roundoff_bound doppler3_bmap vmap doppler3_expr doppler3_b) 28 | As doppler3_bound. 29 | Proof. 30 | idtac "Starting doppler3". 31 | time "doppler3" ( 32 | (subst doppler3_b; intro; prove_roundoff_bound); 33 | try (prove_rndval; interval); 34 | try (prove_roundoff_bound2; error_rewrites; 35 | ((prune_terms (cutoff 30); 36 | try match goal with |- (Rabs ?e <= ?a - 0)%R => 37 | rewrite Rminus_0_r (* case prune terms will fail to produce reasonable bound on goal*) 38 | end; 39 | try match goal with |- (Rabs ?e <= ?a - ?b)%R => 40 | let G := fresh "G" in 41 | interval_intro (Rabs e) as G ; 42 | eapply Rle_trans; 43 | [apply G | apply Rminus_plus_le_minus; apply Rle_refl] end))); 44 | try match goal with |- Rabs ?a <= _ => 45 | interval_intro (Rabs a) with (i_bisect v_v, 46 | i_depth 14) as H'; apply H'; apply Rle_refl 47 | end; 48 | try match goal with |- Rabs ?a <= _ => 49 | interval_intro (Rabs a) with (i_bisect v_t, 50 | i_bisect v_u, i_depth 14) as H'; apply H'; apply Rle_refl 51 | end). 52 | Time Qed. 53 | 54 | Lemma check_doppler3_bound: ltac:(CheckBound doppler3_b 2.0e-13%F64). 55 | Proof. reflexivity. Qed. 56 | 57 | 58 | End WITHNANS. 59 | Close Scope R_scope. -------------------------------------------------------------------------------- /FPBench/himmilbeau.v: -------------------------------------------------------------------------------- 1 | Require Import vcfloat.VCFloat. 2 | Require Import Interval.Tactic. 3 | Import Binary Coq.Lists.List ListNotations. 4 | Set Bullet Behavior "Strict Subproofs". 5 | Section WITHNANS. 6 | Context {NANS:Nans}. 7 | Open Scope R_scope. 8 | 9 | Definition himmilbeau_bmap_list := [Build_varinfo Tdouble 1%positive (-5) (5);Build_varinfo Tdouble 2%positive (-5) (5)]. 10 | 11 | Definition himmilbeau_bmap := 12 | ltac:(let z := compute_PTree (boundsmap_of_list himmilbeau_bmap_list) in exact z). 13 | 14 | Definition himmilbeau (x1 : ftype Tdouble) (x2 : ftype Tdouble) := 15 | cast Tdouble (let a := (((x1 * x1)%F64 + x2)%F64 - (11)%F64)%F64 in 16 | let b := ((x1 + (x2 * x2)%F64)%F64 - (7)%F64)%F64 in 17 | ((a * a)%F64 + (b * b)%F64)%F64). 18 | 19 | Definition himmilbeau_expr := 20 | ltac:(let e' := HO_reify_float_expr constr:([1%positive;2%positive]) himmilbeau in exact e'). 21 | 22 | Derive himmilbeau_b 23 | SuchThat (forall vmap, prove_roundoff_bound himmilbeau_bmap vmap himmilbeau_expr himmilbeau_b) 24 | As jetengine_bound. 25 | Proof. 26 | idtac "Starting himmilbeau". 27 | time "himmilbeau" ( 28 | try (subst himmilbeau_b; intro; prove_roundoff_bound); 29 | try (prove_rndval; interval); 30 | try (prove_roundoff_bound2; prune_terms (cutoff 30); do_interval)). 31 | Time Qed. 32 | 33 | Lemma check_himmilbeau_bound: ltac:(CheckBound himmilbeau_b 2.31e-12%F64). 34 | Proof. reflexivity. Qed. 35 | 36 | End WITHNANS. 37 | Close Scope R_scope. -------------------------------------------------------------------------------- /FPBench/jetengine.v: -------------------------------------------------------------------------------- 1 | Require Import vcfloat.VCFloat. 2 | Require Import Interval.Tactic. 3 | Import Binary Coq.Lists.List ListNotations. 4 | Set Bullet Behavior "Strict Subproofs". 5 | Section WITHNANS. 6 | Context {NANS:Nans}. 7 | Open Scope R_scope. 8 | 9 | Definition _x1: ident := 1%positive. 10 | Definition _x2: ident := 2%positive. 11 | 12 | Definition jetengine_bmap_list := [Build_varinfo Tdouble _x1 (-5) (5); 13 | Build_varinfo Tdouble _x2 (-20) (5)]. 14 | 15 | Definition jetengine_bmap := 16 | ltac:(let z := compute_PTree (boundsmap_of_list jetengine_bmap_list) in exact z). 17 | 18 | Definition jetengine (x1 : ftype Tdouble) (x2 : ftype Tdouble) := 19 | cast Tdouble (let t := (((((3)%F64 * x1)%F64 * x1)%F64 + ((2)%F64 * x2)%F64)%F64 - x1)%F64 in 20 | let t_42_ := (((((3)%F64 * x1)%F64 * x1)%F64 - ((2)%F64 * x2)%F64)%F64 - x1)%F64 in 21 | let d := ((x1 * x1)%F64 + (1)%F64)%F64 in 22 | let s := (t / d)%F64 in 23 | let s_42_ := (t_42_ / d)%F64 in 24 | (x1 + ((((((((((2)%F64 * x1)%F64 * s)%F64 * (s - (3)%F64)%F64)%F64 + ((x1 * x1)%F64 * (((4)%F64 * s)%F64 - (6)%F64)%F64)%F64)%F64 * d)%F64 + ((((3)%F64 * x1)%F64 * x1)%F64 * s)%F64)%F64 + ((x1 * x1)%F64 * x1)%F64)%F64 + x1)%F64 + ((3)%F64 * s_42_)%F64)%F64)%F64). 25 | 26 | Definition jetengine_expr := 27 | ltac:(let e' := HO_reify_float_expr constr:([_x1;_x2]) jetengine in exact e'). 28 | 29 | Derive jetengine_b 30 | SuchThat (forall vmap, prove_roundoff_bound jetengine_bmap vmap jetengine_expr jetengine_b) 31 | As jetengine_bound. 32 | Proof. 33 | idtac "Starting jetengine". 34 | time "jetengine" ( 35 | try (subst jetengine_b; intro; prove_roundoff_bound); 36 | try (prove_rndval; interval); 37 | try (prove_roundoff_bound2); 38 | try match goal with |- Rabs ?a <= _ => 39 | interval_intro (Rabs a) with (i_bisect v_x1, i_bisect v_x2, i_depth 12) as H 40 | end; 41 | (*match type of H with _ <= _ <= ?A => pose (b := ltac:(ShowBound A)) end. 42 | unify (Binary.Bcompare _ _ b 2.13e3%F64) (Some Lt).*) 43 | try ( 44 | eapply Rle_trans; 45 | try apply H; 46 | try apply Rle_refl)). 47 | Time Qed. 48 | 49 | Lemma check_jetengine_bound: ltac:(CheckBound jetengine_b 2.13e3%F64). 50 | Proof. reflexivity. Qed. 51 | 52 | End WITHNANS. 53 | Close Scope R_scope. -------------------------------------------------------------------------------- /FPBench/kepler0.v: -------------------------------------------------------------------------------- 1 | Require Import vcfloat.VCFloat. 2 | Require Import Interval.Tactic. 3 | Import Binary Coq.Lists.List ListNotations. 4 | Set Bullet Behavior "Strict Subproofs". 5 | Section WITHNANS. 6 | Context {NANS:Nans}. 7 | Open Scope R_scope. 8 | 9 | Definition kepler0_bmap_list := [Build_varinfo Tdouble 1%positive (4) (636e-2);Build_varinfo Tdouble 2%positive (4) (636e-2);Build_varinfo Tdouble 3%positive (4) (636e-2);Build_varinfo Tdouble 4%positive (4) (636e-2);Build_varinfo Tdouble 5%positive (4) (636e-2);Build_varinfo Tdouble 6%positive (4) (636e-2)]. 10 | 11 | Definition kepler0_bmap := 12 | ltac:(let z := compute_PTree (boundsmap_of_list kepler0_bmap_list) in exact z). 13 | 14 | Definition kepler0 (x1 : ftype Tdouble) (x2 : ftype Tdouble) (x3 : ftype Tdouble) (x4 : ftype Tdouble) (x5 : ftype Tdouble) (x6 : ftype Tdouble) := 15 | cast Tdouble ((((((x2 * x5)%F64 + (x3 * x6)%F64)%F64 - (x2 * x3)%F64)%F64 - (x5 * x6)%F64)%F64 + (x1 * ((((((-x1) + x2)%F64 + x3)%F64 - x4)%F64 + x5)%F64 + x6)%F64)%F64)%F64). 16 | 17 | Definition kepler0_expr := 18 | ltac:(let e' := HO_reify_float_expr constr:([1%positive;2%positive;3%positive;4%positive;5%positive;6%positive]) kepler0 in exact e'). 19 | 20 | Derive kepler0_b 21 | SuchThat (forall vmap, prove_roundoff_bound kepler0_bmap vmap kepler0_expr kepler0_b) 22 | As kepler0_bound. 23 | Proof. 24 | idtac "Starting kepler0". 25 | time "kepler0" ( 26 | try (subst kepler0_b; intro; prove_roundoff_bound); 27 | try (prove_rndval; interval); 28 | try (prove_roundoff_bound2; 29 | try ((prune_terms (cutoff 30)); 30 | do_interval))). 31 | Time Qed. 32 | 33 | Lemma check_kepler0_bound: ltac:(CheckBound kepler0_b 2.2005e-13%F64). 34 | Proof. reflexivity. Qed. 35 | 36 | End WITHNANS. 37 | Close Scope R_scope. -------------------------------------------------------------------------------- /FPBench/kepler1.v: -------------------------------------------------------------------------------- 1 | Require Import vcfloat.VCFloat. 2 | Require Import Interval.Tactic. 3 | Import Binary Coq.Lists.List ListNotations. 4 | Set Bullet Behavior "Strict Subproofs". 5 | Section WITHNANS. 6 | Context {NANS:Nans}. 7 | Open Scope R_scope. 8 | 9 | Definition _x1: ident := 1%positive. 10 | Definition _x2: ident := 2%positive. 11 | Definition _x3: ident := 3%positive. 12 | Definition _x4: ident := 4%positive. 13 | 14 | Definition kepler1_bmap_list := [Build_varinfo Tdouble _x1 (4) (636e-2); 15 | Build_varinfo Tdouble _x2 (4) (636e-2); 16 | Build_varinfo Tdouble _x3 (4) (636e-2); 17 | Build_varinfo Tdouble _x4 (4) (636e-2)]. 18 | 19 | Definition kepler1_bmap := 20 | ltac:(let z := compute_PTree (boundsmap_of_list kepler1_bmap_list) in exact z). 21 | 22 | Definition kepler1 (x1 : ftype Tdouble) (x2 : ftype Tdouble) (x3 : ftype Tdouble) (x4 : ftype Tdouble) := 23 | cast Tdouble (((((((((x1 * x4)%F64 * ((((-x1) + x2)%F64 + x3)%F64 - x4)%F64)%F64 + (x2 * (((x1 - x2)%F64 + x3)%F64 + x4)%F64)%F64)%F64 + (x3 * (((x1 + x2)%F64 - x3)%F64 + x4)%F64)%F64)%F64 - ((x2 * x3)%F64 * x4)%F64)%F64 - (x1 * x3)%F64)%F64 - (x1 * x2)%F64)%F64 - x4)%F64). 24 | 25 | Definition kepler1_expr := 26 | ltac:(let e' := HO_reify_float_expr constr:([_x1;_x2;_x3;_x4]) kepler1 in exact e'). 27 | 28 | Derive kepler1_b 29 | SuchThat (forall vmap, prove_roundoff_bound kepler1_bmap vmap kepler1_expr kepler1_b) 30 | As kepler1_bound. 31 | Proof. 32 | idtac "Starting kepler1"; 33 | time "kepler1" 34 | (subst kepler1_b; intro; prove_roundoff_bound; 35 | [ prove_rndval; interval 36 | | prove_roundoff_bound2; prune_terms (cutoff 50); do_interval]). 37 | Time Qed. 38 | 39 | Lemma check_kepler1_bound: ltac:(CheckBound kepler1_b 1.644e-12%F64). 40 | Proof. reflexivity. Qed. 41 | 42 | End WITHNANS. 43 | Close Scope R_scope. -------------------------------------------------------------------------------- /FPBench/kepler2.v: -------------------------------------------------------------------------------- 1 | Require Import vcfloat.VCFloat. 2 | Require Import Interval.Tactic. 3 | Import Binary Coq.Lists.List ListNotations. 4 | Set Bullet Behavior "Strict Subproofs". 5 | Section WITHNANS. 6 | Context {NANS:Nans}. 7 | Open Scope R_scope. 8 | 9 | Definition kepler2_bmap_list := [Build_varinfo Tdouble 1%positive (4) (636e-2);Build_varinfo Tdouble 2%positive (4) (636e-2);Build_varinfo Tdouble 3%positive (4) (636e-2);Build_varinfo Tdouble 4%positive (4) (636e-2);Build_varinfo Tdouble 5%positive (4) (636e-2);Build_varinfo Tdouble 6%positive (4) (636e-2)]. 10 | 11 | Definition kepler2_bmap := 12 | ltac:(let z := compute_PTree (boundsmap_of_list kepler2_bmap_list) in exact z). 13 | 14 | Definition kepler2 (x1 : ftype Tdouble) (x2 : ftype Tdouble) (x3 : ftype Tdouble) (x4 : ftype Tdouble) (x5 : ftype Tdouble) (x6 : ftype Tdouble) := 15 | cast Tdouble (((((((((x1 * x4)%F64 * ((((((-x1) + x2)%F64 + x3)%F64 - x4)%F64 + x5)%F64 + x6)%F64)%F64 + ((x2 * x5)%F64 * (((((x1 - x2)%F64 + x3)%F64 + x4)%F64 - x5)%F64 + x6)%F64)%F64)%F64 + ((x3 * x6)%F64 * (((((x1 + x2)%F64 - x3)%F64 + x4)%F64 + x5)%F64 - x6)%F64)%F64)%F64 - ((x2 * x3)%F64 * x4)%F64)%F64 - ((x1 * x3)%F64 * x5)%F64)%F64 - ((x1 * x2)%F64 * x6)%F64)%F64 - ((x4 * x5)%F64 * x6)%F64)%F64). 16 | 17 | Definition kepler2_expr := 18 | ltac:(let e' := HO_reify_float_expr constr:([1%positive;2%positive;3%positive;4%positive;5%positive;6%positive]) kepler2 in exact e'). 19 | 20 | Derive kepler2_b 21 | SuchThat (forall vmap, prove_roundoff_bound kepler2_bmap vmap kepler2_expr kepler2_b) 22 | As kepler2_bound. 23 | Proof. 24 | idtac "Starting kepler2". 25 | time "kepler2" ( 26 | try (subst kepler2_b; intro; prove_roundoff_bound); 27 | try (prove_rndval; interval); 28 | try (prove_roundoff_bound2; 29 | try ((prune_terms (cutoff 60)); 30 | do_interval))). 31 | Time Qed. 32 | 33 | Lemma check_kepler2_bound: ltac:(CheckBound kepler2_b 6.2e-12%F64). 34 | Proof. reflexivity. Qed. 35 | 36 | End WITHNANS. 37 | Close Scope R_scope. -------------------------------------------------------------------------------- /FPBench/multivar_6.v: -------------------------------------------------------------------------------- 1 | Require Import vcfloat.VCFloat. 2 | Require Import Interval.Tactic. 3 | Import Binary Coq.Lists.List ListNotations. 4 | Set Bullet Behavior "Strict Subproofs". 5 | Section WITHNANS. 6 | Context {NANS:Nans}. 7 | Open Scope R_scope. 8 | 9 | Definition delta4_bmap_list := [Build_varinfo Tdouble 1%positive (4) (63504e-4);Build_varinfo Tdouble 2%positive (4) (63504e-4);Build_varinfo Tdouble 3%positive (4) (63504e-4);Build_varinfo Tdouble 4%positive (4) (63504e-4);Build_varinfo Tdouble 5%positive (4) (63504e-4);Build_varinfo Tdouble 6%positive (4) (63504e-4)]. 10 | 11 | Definition delta4_bmap := 12 | ltac:(let z := compute_PTree (boundsmap_of_list delta4_bmap_list) in exact z). 13 | 14 | Definition delta4 (x1 : ftype Tdouble) (x2 : ftype Tdouble) (x3 : ftype Tdouble) (x4 : ftype Tdouble) (x5 : ftype Tdouble) (x6 : ftype Tdouble) := 15 | cast Tdouble ((((((((-x2) * x3)%F64 - (x1 * x4)%F64)%F64 + (x2 * x5)%F64)%F64 + (x3 * x6)%F64)%F64 - (x5 * x6)%F64)%F64 + (x1 * ((((((-x1) + x2)%F64 + x3)%F64 - x4)%F64 + x5)%F64 + x6)%F64)%F64)%F64). 16 | 17 | Definition delta4_expr := 18 | ltac:(let e' := HO_reify_float_expr constr:([1%positive;2%positive;3%positive;4%positive;5%positive;6%positive]) delta4 in exact e'). 19 | 20 | Derive delta4_b 21 | SuchThat (forall vmap, prove_roundoff_bound delta4_bmap vmap delta4_expr delta4_b) 22 | As delta4_bound. 23 | Proof. 24 | idtac "Starting delta4". 25 | subst delta4_b. intro. prove_roundoff_bound. 26 | - 27 | time "prove_rndval" prove_rndval; time "interval" interval. 28 | - 29 | time "prove_roundoff_bound2" prove_roundoff_bound2; 30 | time "prune_terms" (prune_terms (cutoff 30)). 31 | time "do_interval" do_interval. 32 | Time Qed. 33 | 34 | Lemma check_delta4_bound: ltac:(CheckBound delta4_b 2.51e-13%F64). 35 | Proof. reflexivity. Qed. 36 | 37 | Definition delta_bmap_list := [Build_varinfo Tdouble 1%positive (4) (63504e-4);Build_varinfo Tdouble 2%positive (4) (63504e-4);Build_varinfo Tdouble 3%positive (4) (63504e-4);Build_varinfo Tdouble 4%positive (4) (63504e-4);Build_varinfo Tdouble 5%positive (4) (63504e-4);Build_varinfo Tdouble 6%positive (4) (63504e-4)]. 38 | 39 | Definition delta_bmap := 40 | ltac:(let z := compute_PTree (boundsmap_of_list delta_bmap_list) in exact z). 41 | 42 | Definition delta (x1 : ftype Tdouble) (x2 : ftype Tdouble) (x3 : ftype Tdouble) (x4 : ftype Tdouble) (x5 : ftype Tdouble) (x6 : ftype Tdouble) := 43 | cast Tdouble (((((((((x1 * x4)%F64 * ((((((-x1) + x2)%F64 + x3)%F64 - x4)%F64 + x5)%F64 + x6)%F64)%F64 + ((x2 * x5)%F64 * (((((x1 - x2)%F64 + x3)%F64 + x4)%F64 - x5)%F64 + x6)%F64)%F64)%F64 + ((x3 * x6)%F64 * (((((x1 + x2)%F64 - x3)%F64 + x4)%F64 + x5)%F64 - x6)%F64)%F64)%F64 + (((-x2) * x3)%F64 * x4)%F64)%F64 + (((-x1) * x3)%F64 * x5)%F64)%F64 + (((-x1) * x2)%F64 * x6)%F64)%F64 + (((-x4) * x5)%F64 * x6)%F64)%F64). 44 | 45 | Definition delta_expr := 46 | ltac:(let e' := HO_reify_float_expr constr:([1%positive;2%positive;3%positive;4%positive;5%positive;6%positive]) delta in exact e'). 47 | 48 | Derive delta_b 49 | SuchThat (forall vmap, prove_roundoff_bound delta_bmap vmap delta_expr delta_b) 50 | As delta_bound. 51 | Proof. 52 | idtac "Starting delta". 53 | subst delta_b. intro. prove_roundoff_bound. 54 | - 55 | time "prove_rndval" prove_rndval; time "interval" interval. 56 | - 57 | time "prove_roundoff_bound2" prove_roundoff_bound2; 58 | time "prune_terms" (prune_terms (cutoff 30)). 59 | time "do_interval" do_interval. 60 | Time Qed. 61 | 62 | Lemma check_delta_bound: ltac:(CheckBound delta_b 6.2e-12%F64). 63 | Proof. reflexivity. Qed. 64 | 65 | End WITHNANS. 66 | -------------------------------------------------------------------------------- /FPBench/predatorprey.v: -------------------------------------------------------------------------------- 1 | Require Import vcfloat.VCFloat. 2 | Require Import Interval.Tactic. 3 | Import Binary Coq.Lists.List ListNotations. 4 | Set Bullet Behavior "Strict Subproofs". 5 | Section WITHNANS. 6 | Context {NANS:Nans}. 7 | Open Scope R_scope. 8 | 9 | Definition predatorprey_bmap_list := [Build_varinfo Tdouble 1%positive (1e-1) (3e-1)]. 10 | 11 | Definition predatorprey_bmap := 12 | ltac:(let z := compute_PTree (boundsmap_of_list predatorprey_bmap_list) in exact z). 13 | 14 | Definition predatorprey (x : ftype Tdouble) := 15 | cast Tdouble (let r := (4)%F64 in 16 | let k := (111e-2)%F64 in 17 | (((r * x)%F64 * x)%F64 / ((1)%F64 + ((x / k)%F64 * (x / k)%F64)%F64)%F64)%F64). 18 | 19 | Definition predatorprey_expr := 20 | ltac:(let e' := HO_reify_float_expr constr:([1%positive]) predatorprey in exact e'). 21 | 22 | Derive predatorprey_b 23 | SuchThat (forall vmap, prove_roundoff_bound predatorprey_bmap vmap predatorprey_expr predatorprey_b) 24 | As predatorprey_bound. 25 | Proof. 26 | idtac "Starting predatorprey". 27 | time "predatorprey" ( 28 | subst predatorprey_b; intro; prove_roundoff_bound; 29 | try (prove_rndval; interval); try interval; 30 | try ( prove_roundoff_bound2); try error_rewrites; 31 | try ( 32 | (prune_terms (cutoff 70); 33 | try match goal with |- (Rabs ?e <= ?a - 0)%R => 34 | rewrite Rminus_0_r (* case prune terms will fail to produce reasonable bound on goal*) 35 | end; 36 | try match goal with |- (Rabs ?e <= ?a - ?b)%R => 37 | let G := fresh "G" in 38 | try (interval_intro (Rabs e) with 39 | (i_taylor vxH, i_bisect vxH, i_depth 20) as G; 40 | eapply Rle_trans; 41 | [apply G | apply Rminus_plus_le_minus; apply Rle_refl]); 42 | try (interval_intro (Rabs e) as G; 43 | eapply Rle_trans; 44 | [apply G | apply Rminus_plus_le_minus; apply Rle_refl]) end)); 45 | try ( 46 | try rewrite Rsqr_pow2; 47 | try field_simplify_Rabs; 48 | try match goal with |-Rabs ?a <= _ => 49 | interval_intro (Rabs a) upper with 50 | (i_bisect vxH, i_depth 17) as H' 51 | end; apply H')). 52 | Time Qed. 53 | 54 | Lemma check_predatorprey_bound: ltac:(CheckBound predatorprey_b 3.1e-16%F64). 55 | Proof. reflexivity. Qed. 56 | 57 | End WITHNANS. 58 | Close Scope R_scope. -------------------------------------------------------------------------------- /FPBench/rigid_body1.v: -------------------------------------------------------------------------------- 1 | Require Import vcfloat.VCFloat. 2 | Require Import Interval.Tactic. 3 | Import Binary Coq.Lists.List ListNotations. 4 | Set Bullet Behavior "Strict Subproofs". 5 | Section WITHNANS. 6 | Context {NANS:Nans}. 7 | Open Scope R_scope. 8 | 9 | Definition rigidbody1_bmap_list := [Build_varinfo Tdouble 1%positive (-15) (15);Build_varinfo Tdouble 2%positive (-15) (15);Build_varinfo Tdouble 3%positive (-15) (15)]. 10 | 11 | Definition rigidbody1_bmap := 12 | ltac:(let z := compute_PTree (boundsmap_of_list rigidbody1_bmap_list) in exact z). 13 | 14 | Definition rigidbody1 (x1 : ftype Tdouble) (x2 : ftype Tdouble) (x3 : ftype Tdouble) := 15 | cast Tdouble (((((-(x1 * x2)%F64) - (((2)%F64 * x2)%F64 * x3)%F64)%F64 - x1)%F64 - x3)%F64). 16 | 17 | Definition rigidbody1_expr := 18 | ltac:(let e' := HO_reify_float_expr constr:([1%positive;2%positive;3%positive]) rigidbody1 in exact e'). 19 | 20 | Derive rigidbody1_b 21 | SuchThat (forall vmap, prove_roundoff_bound rigidbody1_bmap vmap rigidbody1_expr rigidbody1_b) 22 | As rigidbody1_bound. 23 | Proof. 24 | idtac "Starting rigidbody1". 25 | time "rigidbody1" ( 26 | try (subst rigidbody1_b; intro; prove_roundoff_bound); 27 | try (prove_rndval; interval); 28 | try (prove_roundoff_bound2; prune_terms (cutoff 30); do_interval)). 29 | Time Qed. 30 | 31 | Lemma check_rigidbody1_bound: ltac:(CheckBound rigidbody1_b 3.1e-13%F64). 32 | Proof. reflexivity. Qed. 33 | 34 | End WITHNANS. 35 | Close Scope R_scope. -------------------------------------------------------------------------------- /FPBench/rigid_body2.v: -------------------------------------------------------------------------------- 1 | Require Import vcfloat.VCFloat. 2 | Require Import Interval.Tactic. 3 | Import Binary Coq.Lists.List ListNotations. 4 | Set Bullet Behavior "Strict Subproofs". 5 | Section WITHNANS. 6 | Context {NANS:Nans}. 7 | Open Scope R_scope. 8 | 9 | Definition rigidbody2_bmap_list := [Build_varinfo Tdouble 1%positive (-15) (15);Build_varinfo Tdouble 2%positive (-15) (15);Build_varinfo Tdouble 3%positive (-15) (15)]. 10 | 11 | Definition rigidbody2_bmap := 12 | ltac:(let z := compute_PTree (boundsmap_of_list rigidbody2_bmap_list) in exact z). 13 | 14 | Definition rigidbody2 (x1 : ftype Tdouble) (x2 : ftype Tdouble) (x3 : ftype Tdouble) := 15 | cast Tdouble (((((((((2)%F64 * x1)%F64 * x2)%F64 * x3)%F64 + (((3)%F64 * x3)%F64 * x3)%F64)%F64 - (((x2 * x1)%F64 * x2)%F64 * x3)%F64)%F64 + (((3)%F64 * x3)%F64 * x3)%F64)%F64 - x2)%F64). 16 | 17 | Definition rigidbody2_expr := 18 | ltac:(let e' := HO_reify_float_expr constr:([1%positive;2%positive;3%positive]) rigidbody2 in exact e'). 19 | 20 | Derive rigidbody2_b 21 | SuchThat (forall vmap, prove_roundoff_bound rigidbody2_bmap vmap rigidbody2_expr rigidbody2_b) 22 | As rigidbody2_bound. 23 | Proof. 24 | idtac "Starting rigidbody2". 25 | time "rigidbody2" ( 26 | try (subst rigidbody2_b; intro; prove_roundoff_bound); 27 | try (prove_rndval; interval); 28 | try (prove_roundoff_bound2; prune_terms (cutoff 30); do_interval)). 29 | Time Qed. 30 | 31 | Lemma check_rigidbody2_bound: ltac:(CheckBound rigidbody2_b 3.9e-11%F64). 32 | Proof. reflexivity. Qed. 33 | 34 | End WITHNANS. 35 | Close Scope R_scope. -------------------------------------------------------------------------------- /FPBench/t_div_t1.v: -------------------------------------------------------------------------------- 1 | Require Import vcfloat.VCFloat. 2 | Require Import Interval.Tactic. 3 | Import Binary Coq.Lists.List ListNotations. 4 | Set Bullet Behavior "Strict Subproofs". 5 | Section WITHNANS. 6 | Context {NANS:Nans}. 7 | Open Scope R_scope. 8 | 9 | Definition t_div_t1_bmap_list := [Build_varinfo Tdouble 1%positive (0) (999)]. 10 | 11 | Definition t_div_t1_bmap := 12 | ltac:(let z := compute_PTree (boundsmap_of_list t_div_t1_bmap_list) in exact z). 13 | 14 | Definition t_div_t1 (z : ftype Tdouble) := 15 | cast Tdouble ((z / (z + (1)%F64)%F64)%F64). 16 | 17 | Definition t_div_t1_expr := 18 | ltac:(let e' := HO_reify_float_expr constr:([1%positive]) t_div_t1 in exact e'). 19 | 20 | Derive t_div_t1_b 21 | SuchThat (forall vmap, prove_roundoff_bound t_div_t1_bmap vmap t_div_t1_expr t_div_t1_b) 22 | As t_div_t1_bound. 23 | idtac "Starting t_div_t1". 24 | time "t_div_t1_bound" ( 25 | try (subst t_div_t1_b; intro; prove_roundoff_bound); 26 | try (prove_rndval; interval); 27 | try (prove_roundoff_bound2); 28 | try match goal with |-Rabs ?a <= _ => 29 | field_simplify a; try split; try field; try nra; try interval 30 | end; 31 | try match goal with |-Rabs ?a <= _ => 32 | interval_intro (Rabs a) with (i_taylor vxH, i_degree 10, i_bisect vxH, 33 | i_depth 10) 34 | end; 35 | try ( 36 | eapply Rle_trans; 37 | try apply H; 38 | try apply Rle_refl)). 39 | Time Qed. 40 | 41 | Lemma check_t_div_t1_bound: ltac:(CheckBound t_div_t1_b 4.4e-16%F64). 42 | Proof. reflexivity. Qed. 43 | 44 | End WITHNANS. 45 | Close Scope R_scope. 46 | -------------------------------------------------------------------------------- /FPBench/turbine1.v: -------------------------------------------------------------------------------- 1 | Require Import vcfloat.VCFloat. 2 | Require Import Interval.Tactic. 3 | Import Binary Coq.Lists.List ListNotations. 4 | Set Bullet Behavior "Strict Subproofs". 5 | Section WITHNANS. 6 | Context {NANS:Nans}. 7 | Open Scope R_scope. 8 | 9 | Definition _v : ident := 1%positive. 10 | Definition _w : ident := 2%positive. 11 | Definition _r : ident := 3%positive. 12 | 13 | Definition turbine1_bmap_list := [Build_varinfo Tdouble _v (-45e-1) (-3e-1);Build_varinfo Tdouble _w (4e-1) (9e-1);Build_varinfo Tdouble _r (38e-1) (78e-1)]. 14 | 15 | Definition turbine1_bmap := 16 | ltac:(let z := compute_PTree (boundsmap_of_list turbine1_bmap_list) in exact z). 17 | 18 | Definition turbine1 (v : ftype Tdouble) (w : ftype Tdouble) (r : ftype Tdouble) := 19 | cast Tdouble (((((3)%F64 + ((2)%F64 / (r * r)%F64)%F64)%F64 - ((((125e-3)%F64 * ((3)%F64 - ((2)%F64 * v)%F64)%F64)%F64 * (((w * w)%F64 * r)%F64 * r)%F64)%F64 / ((1)%F64 - v)%F64)%F64)%F64 - (45e-1)%F64)%F64). 20 | 21 | Definition turbine1_expr := 22 | ltac:(let e' := HO_reify_float_expr constr:([_v;_w;_r]) turbine1 in exact e'). 23 | 24 | Derive turbine1_b 25 | SuchThat (forall vmap, prove_roundoff_bound turbine1_bmap vmap turbine1_expr turbine1_b) 26 | As turbine1_bound. 27 | Proof. 28 | idtac "Starting turbine1". 29 | time "turbine1" ( 30 | subst turbine1_b; intro; prove_roundoff_bound; 31 | [ prove_rndval; interval 32 | | prove_roundoff_bound2; error_rewrites; 33 | try (prune_terms (cutoff 18); 34 | try match goal with |- (Rabs ?e <= ?a - 0)%R => 35 | rewrite Rminus_0_r (* case prune terms will fail to produce reasonable bound on goal*) 36 | end; 37 | try match goal with |- (Rabs ?e <= ?a - ?b)%R => 38 | let G := fresh "G" in 39 | interval_intro (Rabs e) as G ; 40 | eapply Rle_trans; 41 | [apply G | apply Rminus_plus_le_minus; apply Rle_refl] end); 42 | try rewrite Rsqr_pow2; 43 | field_simplify_Rabs; 44 | [ interval_intro (Rabs (1 / v_r ^ 2)) with (i_bisect v_r, i_depth 13) as H'; apply H' 45 | | interval_intro (Rabs (Tree.bpow' 2 1)) as H'; apply H' 46 | | interval_intro (Rabs (v_r ^ 2 / (v_r ^ 2 * e12 + v_r ^ 2 + e6))) with (i_bisect v_r, i_depth 13) as H'; apply H' 47 | | interval_intro (Rabs (1 / v_r ^ 2)) with (i_bisect v_r, i_depth 13) as H'; apply H' 48 | | interval_intro (Rabs (v_r ^ 2 * v_w ^ 2)) as H'; apply H' 49 | | interval_intro (Rabs (1 / (- v_v + 1))) with (i_bisect v_v, i_depth 13) as H'; apply H' 50 | | interval_intro (Rabs ((- v_v + 1) / (- v_v * e7 - v_v + e7 + e20 + 1))) with (i_bisect v_v, i_depth 13) as H'; apply H' 51 | | interval_intro (Rabs (1 / (- v_v + 1))) with (i_bisect v_v, i_depth 13) as H'; apply H' 52 | ]]). 53 | Time Qed. 54 | 55 | Lemma check_turbine1_bound: ltac:(CheckBound turbine1_b 7.9e-14%F64). 56 | Proof. reflexivity. Qed. 57 | 58 | End WITHNANS. 59 | Close Scope R_scope. -------------------------------------------------------------------------------- /FPBench/turbine2.v: -------------------------------------------------------------------------------- 1 | Require Import vcfloat.VCFloat. 2 | Require Import Interval.Tactic. 3 | Import Binary Coq.Lists.List ListNotations. 4 | Set Bullet Behavior "Strict Subproofs". 5 | Section WITHNANS. 6 | Context {NANS:Nans}. 7 | Open Scope R_scope. 8 | 9 | Definition turbine2_bmap_list := [Build_varinfo Tdouble 1%positive (-45e-1) (-3e-1);Build_varinfo Tdouble 2%positive (4e-1) (9e-1);Build_varinfo Tdouble 3%positive (38e-1) (78e-1)]. 10 | 11 | Definition turbine2_bmap := 12 | ltac:(let z := compute_PTree (boundsmap_of_list turbine2_bmap_list) in exact z). 13 | 14 | Definition turbine2 (v : ftype Tdouble) (w : ftype Tdouble) (r : ftype Tdouble) := 15 | cast Tdouble (((((6)%F64 * v)%F64 - ((((5e-1)%F64 * v)%F64 * (((w * w)%F64 * r)%F64 * r)%F64)%F64 / ((1)%F64 - v)%F64)%F64)%F64 - (25e-1)%F64)%F64). 16 | 17 | Definition turbine2_expr := 18 | ltac:(let e' := HO_reify_float_expr constr:([1%positive;2%positive;3%positive]) turbine2 in exact e'). 19 | 20 | Derive turbine2_b 21 | SuchThat (forall vmap, prove_roundoff_bound turbine2_bmap vmap turbine2_expr turbine2_b) 22 | As turbine2_bound. 23 | Proof. 24 | idtac "Starting turbine2". 25 | time "turbine2" ( 26 | try (subst turbine2_b; intro; prove_roundoff_bound); 27 | try (prove_rndval; interval); 28 | try prove_roundoff_bound2; 29 | try error_rewrites; 30 | try ((prune_terms (cutoff 50); 31 | try match goal with |- (Rabs ?e <= ?a - 0)%R => 32 | rewrite Rminus_0_r (* case prune terms will fail to produce reasonable bound on goal*) 33 | end; 34 | try match goal with |- (Rabs ?e <= ?a - ?b)%R => 35 | let G := fresh "G" in 36 | interval_intro (Rabs e) as G ; 37 | eapply Rle_trans; 38 | [apply G | apply Rminus_plus_le_minus; apply Rle_refl] end)); 39 | try rewrite Rsqr_pow2; 40 | try field_simplify_Rabs; 41 | try match goal with |- Rabs ?a <= _ => 42 | interval_intro (Rabs a) with ( i_bisect vxH, 43 | i_bisect v, 44 | i_bisect v0, i_depth 16) as H'; apply H'; apply Rle_refl 45 | end; 46 | try match goal with |- Rabs ?a <= _ => 47 | interval_intro (Rabs a) with ( 48 | i_bisect v, 49 | i_bisect v0, i_depth 16) as H'; apply H'; apply Rle_refl 50 | end; 51 | try match goal with |- Rabs ?a <= _ => 52 | interval_intro (Rabs a) with ( 53 | i_bisect v0, i_depth 16) as H'; apply H'; apply Rle_refl 54 | end; 55 | try match goal with |- Rabs ?a <= _ => 56 | interval_intro (Rabs a) with ( 57 | i_bisect v, i_depth 16) as H'; apply H'; apply Rle_refl 58 | end; 59 | try match goal with |- Rabs ?a <= _ => 60 | interval_intro (Rabs a) with ( 61 | i_bisect vxH, i_depth 16) as H'; apply H'; apply Rle_refl 62 | end; 63 | try match goal with |- Rabs ?a <= _ => 64 | interval_intro (Rabs a) as H'; apply H'; apply Rle_refl 65 | end). 66 | Time Qed. 67 | 68 | Lemma check_turbine2_bound: ltac:(CheckBound turbine2_b 1.2e-13%F64). 69 | Proof. reflexivity. Qed. 70 | 71 | End WITHNANS. 72 | Close Scope R_scope. -------------------------------------------------------------------------------- /FPBench/turbine3.v: -------------------------------------------------------------------------------- 1 | Require Import vcfloat.VCFloat. 2 | Require Import Interval.Tactic. 3 | Import Binary Coq.Lists.List ListNotations. 4 | Set Bullet Behavior "Strict Subproofs". 5 | Section WITHNANS. 6 | Context {NANS:Nans}. 7 | Open Scope R_scope. 8 | 9 | Definition turbine3_bmap_list := [Build_varinfo Tdouble 1%positive (-45e-1) (-3e-1);Build_varinfo Tdouble 2%positive (4e-1) (9e-1);Build_varinfo Tdouble 3%positive (38e-1) (78e-1)]. 10 | 11 | Definition turbine3_bmap := 12 | ltac:(let z := compute_PTree (boundsmap_of_list turbine3_bmap_list) in exact z). 13 | 14 | Definition turbine3 (v : ftype Tdouble) (w : ftype Tdouble) (r : ftype Tdouble) : ftype Tdouble := 15 | ((( (3 - (2 / (r * r))) - (( (125e-3 * (1 + (2 * v))) * (((w * w) * r) * r)) / (1 - v))) - (5e-1))%F64). 16 | 17 | Definition turbine3_expr := 18 | ltac:(let e' := HO_reify_float_expr constr:([1%positive;2%positive;3%positive]) turbine3 in exact e'). 19 | 20 | Derive turbine3_b 21 | SuchThat (forall vmap, prove_roundoff_bound turbine3_bmap vmap turbine3_expr turbine3_b) 22 | As turbine3_bound. 23 | Proof. 24 | idtac "Starting turbine3". 25 | time "turbine3" ( 26 | try (subst turbine3_b; intro; prove_roundoff_bound); 27 | try (prove_rndval; interval); 28 | try prove_roundoff_bound2; 29 | try error_rewrites; 30 | try ((prune_terms (cutoff 40); 31 | try match goal with |- (Rabs ?e <= ?a - 0)%R => 32 | rewrite Rminus_0_r (* case prune terms will fail to produce reasonable bound on goal*) 33 | end; 34 | try match goal with |- (Rabs ?e <= ?a - ?b)%R => 35 | let G := fresh "G" in 36 | interval_intro (Rabs e) as G ; 37 | eapply Rle_trans; 38 | [apply G | apply Rminus_plus_le_minus; apply Rle_refl] end)); 39 | (try rewrite Rsqr_pow2; 40 | try field_simplify_Rabs; 41 | try match goal with |- Rabs ?a <= _ => 42 | interval_intro (Rabs a) with ( i_bisect vxH, 43 | i_bisect v, 44 | i_bisect v0, i_depth 13) as H'; apply H'; apply Rle_refl 45 | end; 46 | try match goal with |- Rabs ?a <= _ => 47 | interval_intro (Rabs a) with ( 48 | i_bisect v, 49 | i_bisect v0, i_depth 13) as H'; apply H'; apply Rle_refl 50 | end; 51 | try match goal with |- Rabs ?a <= _ => 52 | interval_intro (Rabs a) with ( 53 | i_bisect v0, i_depth 13) as H'; apply H'; apply Rle_refl 54 | end; 55 | try match goal with |- Rabs ?a <= _ => 56 | interval_intro (Rabs a) with ( 57 | i_bisect v, i_depth 13) as H'; apply H'; apply Rle_refl 58 | end; 59 | try match goal with |- Rabs ?a <= _ => 60 | interval_intro (Rabs a) with ( 61 | i_bisect vxH, i_depth 13) as H'; apply H'; apply Rle_refl 62 | end; 63 | try match goal with |- Rabs ?a <= _ => 64 | interval_intro (Rabs a) as H'; apply H'; apply Rle_refl 65 | end)). 66 | Time Qed. 67 | 68 | Lemma check_turbine3_bound: ltac:(CheckBound turbine3_b 6.1e-14%F64). 69 | Proof. reflexivity. Qed. 70 | 71 | End WITHNANS. 72 | Close Scope R_scope. -------------------------------------------------------------------------------- /FPBench/verhulst.v: -------------------------------------------------------------------------------- 1 | Require Import vcfloat.VCFloat. 2 | Require Import Interval.Tactic. 3 | Import Binary Coq.Lists.List ListNotations. 4 | Set Bullet Behavior "Strict Subproofs". 5 | Section WITHNANS. 6 | Context {NANS:Nans}. 7 | Open Scope R_scope. 8 | 9 | Definition verhulst_bmap_list := [Build_varinfo Tdouble 1%positive (1e-1) (3e-1)]. 10 | 11 | Definition verhulst_bmap := 12 | ltac:(let z := compute_PTree (boundsmap_of_list verhulst_bmap_list) in exact z). 13 | 14 | Definition verhulst (x : ftype Tdouble) := 15 | cast Tdouble (let r := (4)%F64 in 16 | let k := (111e-2)%F64 in 17 | ((r * x)%F64 / ((1)%F64 + (x / k)%F64)%F64)%F64). 18 | 19 | Definition verhulst_expr := 20 | ltac:(let e' := HO_reify_float_expr constr:([1%positive]) verhulst in exact e'). 21 | 22 | Derive verhulst_b 23 | SuchThat (forall vmap, prove_roundoff_bound verhulst_bmap vmap verhulst_expr verhulst_b) 24 | As verhulst_bound. 25 | Proof. 26 | idtac "Starting verhulst". 27 | time "verhulst" ( 28 | try (subst verhulst_b; intro; prove_roundoff_bound); 29 | try (prove_rndval; interval); 30 | try (prove_roundoff_bound2; field_simplify_Rabs); 31 | try (eexists; intro; prove_roundoff_bound); 32 | try match goal with |- Rabs ?a <= _ => 33 | interval_intro (Rabs a) with (i_bisect vxH, i_depth 15) as H 34 | end; 35 | try ( 36 | eapply Rle_trans; 37 | try apply H; 38 | try apply Rle_refl)). 39 | Time Qed. 40 | 41 | Lemma check_verhulst_bound: ltac:(CheckBound verhulst_b 2.33e-16%F64). 42 | Proof. reflexivity. Qed. 43 | 44 | 45 | End WITHNANS. 46 | Close Scope R_scope. 47 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | 6 | Everyone is permitted to copy and distribute verbatim copies of this license 7 | document, but changing it is not allowed. 8 | 9 | This version of the GNU Lesser General Public License incorporates the terms 10 | and conditions of version 3 of the GNU General Public License, supplemented 11 | by the additional permissions listed below. 12 | 13 | 0. Additional Definitions. 14 | 15 | As used herein, “this License” refers to version 3 of the GNU Lesser General 16 | Public License, and the “GNU GPL” refers to version 3 of the 17 | GNU General Public License. 18 | 19 | “The Library” refers to a covered work governed by this License, other than 20 | an Application or a Combined Work as defined below. 21 | 22 | An “Application” is any work that makes use of an interface provided by the 23 | Library, but which is not otherwise based on the Library. Defining a subclass 24 | of a class defined by the Library is deemed a mode of using an interface 25 | provided by the Library. 26 | 27 | A “Combined Work” is a work produced by combining or linking an Application 28 | with the Library. The particular version of the Library with which the 29 | Combined Work was made is also called the “Linked Version”. 30 | 31 | The “Minimal Corresponding Source” for a Combined Work means the Corresponding 32 | Source for the Combined Work, excluding any source code for portions of the 33 | Combined Work that, considered in isolation, are based on the Application, 34 | and not on the Linked Version. 35 | 36 | The “Corresponding Application Code” for a Combined Work means the object code 37 | and/or source code for the Application, including any data and utility programs 38 | needed for reproducing the Combined Work from the Application, but excluding 39 | the System Libraries of the Combined Work. 40 | 41 | 1. Exception to Section 3 of the GNU GPL. 42 | 43 | You may convey a covered work under sections 3 and 4 of this License without 44 | being bound by section 3 of the GNU GPL. 45 | 46 | 2. Conveying Modified Versions. 47 | 48 | If you modify a copy of the Library, and, in your modifications, a facility 49 | refers to a function or data to be supplied by an Application that uses the 50 | facility (other than as an argument passed when the facility is invoked), 51 | then you may convey a copy of the modified version: 52 | 53 | a) under this License, provided that you make a good faith effort to 54 | ensure that, in the event an Application does not supply the function or 55 | data, the facility still operates, and performs whatever part of its 56 | purpose remains meaningful, or 57 | 58 | b) under the GNU GPL, with none of the additional permissions of this 59 | License applicable to that copy. 60 | 61 | 3. Object Code Incorporating Material from Library Header Files. 62 | 63 | The object code form of an Application may incorporate material from a header 64 | file that is part of the Library. You may convey such object code under terms 65 | of your choice, provided that, if the incorporated material is not limited to 66 | numerical parameters, data structure layouts and accessors, or small macros, 67 | inline functions and templates (ten or fewer lines in length), 68 | you do both of the following: 69 | 70 | a) Give prominent notice with each copy of the object code that the Library 71 | is used in it and that the Library and its use are covered by this License. 72 | 73 | b) Accompany the object code with a copy of the GNU GPL 74 | and this license document. 75 | 76 | 4. Combined Works. 77 | 78 | You may convey a Combined Work under terms of your choice that, taken together, 79 | effectively do not restrict modification of the portions of the Library 80 | contained in the Combined Work and reverse engineering for debugging such 81 | modifications, if you also do each of the following: 82 | 83 | a) Give prominent notice with each copy of the Combined Work that the 84 | Library is used in it and that the Library and its use are covered 85 | by this License. 86 | 87 | b) Accompany the Combined Work with a copy of the GNU GPL and 88 | this license document. 89 | 90 | c) For a Combined Work that displays copyright notices during execution, 91 | include the copyright notice for the Library among these notices, as well 92 | as a reference directing the user to the copies of the GNU GPL 93 | and this license document. 94 | 95 | d) Do one of the following: 96 | 97 | 0) Convey the Minimal Corresponding Source under the terms of this 98 | License, and the Corresponding Application Code in a form suitable 99 | for, and under terms that permit, the user to recombine or relink 100 | the Application with a modified version of the Linked Version to 101 | produce a modified Combined Work, in the manner specified by section 6 102 | of the GNU GPL for conveying Corresponding Source. 103 | 104 | 1) Use a suitable shared library mechanism for linking with the 105 | Library. A suitable mechanism is one that (a) uses at run time a 106 | copy of the Library already present on the user's computer system, 107 | and (b) will operate properly with a modified version of the Library 108 | that is interface-compatible with the Linked Version. 109 | 110 | e) Provide Installation Information, but only if you would otherwise be 111 | required to provide such information under section 6 of the GNU GPL, and 112 | only to the extent that such information is necessary to install and 113 | execute a modified version of the Combined Work produced by recombining 114 | or relinking the Application with a modified version of the Linked Version. 115 | (If you use option 4d0, the Installation Information must accompany the 116 | Minimal Corresponding Source and Corresponding Application Code. If you 117 | use option 4d1, you must provide the Installation Information in the 118 | manner specified by section 6 of the GNU GPL for 119 | conveying Corresponding Source.) 120 | 121 | 5. Combined Libraries. 122 | 123 | You may place library facilities that are a work based on the Library side by 124 | side in a single library together with other library facilities that are not 125 | Applications and are not covered by this License, and convey such a combined 126 | library under terms of your choice, if you do both of the following: 127 | 128 | a) Accompany the combined library with a copy of the same work based on 129 | the Library, uncombined with any other library facilities, conveyed under 130 | the terms of this License. 131 | 132 | b) Give prominent notice with the combined library that part of it is a 133 | work based on the Library, and explaining where to find the accompanying 134 | uncombined form of the same work. 135 | 136 | 6. Revised Versions of the GNU Lesser General Public License. 137 | 138 | The Free Software Foundation may publish revised and/or new versions of the 139 | GNU Lesser General Public License from time to time. Such new versions will 140 | be similar in spirit to the present version, but may differ in detail to 141 | address new problems or concerns. 142 | 143 | Each version is given a distinguishing version number. If the Library as you 144 | received it specifies that a certain numbered version of the GNU Lesser 145 | General Public License “or any later version” applies to it, you have the 146 | option of following the terms and conditions either of that published version 147 | or of any later version published by the Free Software Foundation. If the 148 | Library as you received it does not specify a version number of the GNU Lesser 149 | General Public License, you may choose any version of the GNU Lesser General 150 | Public License ever published by the Free Software Foundation. 151 | 152 | If the Library as you received it specifies that a proxy can decide whether 153 | future versions of the GNU Lesser General Public License shall apply, that 154 | proxy's public statement of acceptance of any version is permanent 155 | authorization for you to choose that version for the Library. -------------------------------------------------------------------------------- /OLD_LICENSE: -------------------------------------------------------------------------------- 1 | How VCFloat became LGPL licensed instead of GPL licensed: a History 2 | 3 | VCFloat, a Coq Framework for verifying floating-point computations, 4 | was originally developed by researchers at Reservoir Labs Inc. 5 | It was copyright (c) 2015 Reservoir Labs Inc., made open-source 6 | under the Gnu Public License (GPL), and published in a github repo. 7 | 8 | In 2021 and 2022, Andrew Appel and Ariel Kellison made contributions 9 | to the github repo, which were also (therefore) GPL Licensed. 10 | 11 | In 2022, Reservoir Labs Inc. was acquired by Qualcomm. Qualcomm determined 12 | that this was not an open-source project that they wanted to continue 13 | to maintain. Since Andrew Appel was interested in maintaining and improving 14 | VCFloat, Qualcomm generously decided to transfer all its copyright ownership 15 | in VCFloat to Andrew Appel, which was done by contract in June 2022. 16 | 17 | The maintainers of a GPL-licensed repository cannot simply change the license 18 | to some other license, even LGPL, unless every one of the copyright owners agrees. 19 | In July 2022, "every one of the copyright owners" was Andrew Appel and Ariel Kellison. 20 | On 10 July 2022, those owners hereby license their copyrighted software under the LGPL. 21 | 22 | We welcome contributions by others to VCFloat, which will continue to be LGPL licensed. 23 | 24 | Below, for historical purposes, we reproduce the license agreement as it stood 25 | in June 2022. 26 | 27 | --------------OLD, OBSOLETE LICENSE FOLLOWS--------------------------- 28 | 29 | VCFloat: A Unified Coq Framework for Verifying C Programs with 30 | Floating-Point Computations. Application to SAR Backprojection. 31 | 32 | Copyright (C) 2015 Reservoir Labs Inc. 33 | Copyright (C) 2021-22 Andrew W. Appel and Ariel Kellison 34 | 35 | This software and each of its files are free software. You can 36 | redistribute them and/or modify them under the terms of the GNU 37 | General Public License as published by the Free Software Foundation, 38 | either version 3 of the License (GNU GPL v3), or (at your option) any 39 | later version. A verbatim copy of the GNU GPL v3 is included in 40 | gpl-3.0.txt. 41 | 42 | This software is distributed in the hope that it will be useful, but 43 | WITHOUT ANY WARRANTY; without even the implied warranty of 44 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU GPL 45 | v3 (and CeCILL-C for patches/interval.patch) for more details. 46 | 47 | This work was sponsored in part by DARPA MTO as part of the Power 48 | Efficiency Revolution for Embedded Computing Technologies (PERFECT) 49 | program (issued by DARPA/CMO under Contract No: HR0011-12-C-0123). The 50 | views and conclusions contained in this work are those of the authors 51 | and should not be interpreted as representing the official policies, 52 | either expressly or implied, of the DARPA or the 53 | U.S. Government. Distribution Statement "A" (Approved for Public 54 | Release, Distribution Unlimited.) 55 | 56 | 57 | If you are using or modifying VCFloat in your work, please consider 58 | citing the following paper: 59 | 60 | Tahina Ramananandro, Paul Mountcastle, Benoit Meister and Richard 61 | Lethin. 62 | A Unified Coq Framework for Verifying C Programs with Floating-Point 63 | Computations. 64 | In CPP (5th ACM/SIGPLAN conference on Certified Programs and Proofs) 65 | 2016. 66 | 67 | VCFloat requires uses third-party libraries listed in ACKS, which 68 | have various licenses of their own. 69 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | VCFloat: A Unified Coq Framework for Verifying C Programs with 2 | Floating-Point Computations 3 | 4 | Version 1.0 (2015-12-04) Initial release 5 | Version 2.0 (2022-3-10) Many improvements, see below. 6 | 7 | Copyright (C) 2015 Reservoir Labs Inc. 8 | Copyright (C) 2021-22 Andrew W. Appel and Ariel Kellison. 9 | 10 | VCFloat is open-source licensed according to the LGPL (Gnu Lesser General 11 | Public License) version 3 or any later version. 12 | 13 | Previously it was licensed differently; see OLD_LICENSE for an explanation. 14 | 15 | This software is distributed WITHOUT ANY WARRANTY; without even the implied warranty of 16 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 17 | 18 | By making a pull-request to this repo, or by making a direct push, or by contributing 19 | by any other such means, you thereby certify that you have the rights to do 20 | so specified in the Developer Certificate of Origin, https://developercertificate.org/ 21 | and you also thereby license your contribution by the LGPL 3.0 and later. 22 | 23 | VCFloat 1.0 was implemented 2015 by Tahina Ramananandro et al (see citation below). 24 | VCFloat since 2021 is maintained and extended by Andrew Appel and Ariel Kellison. 25 | 26 | For an introduction, read 27 | VCFloat2: Floating-point error analysis in Coq, by Appel & Kellison, 2022, 28 | available as doc/vcfloat2.pdf in this repository. 29 | 30 | For more technical information on VCFloat, you can read Sections 1-4 of: 31 | 32 | Tahina Ramananandro, Paul Mountcastle, Benoit Meister and Richard Lethin. 33 | A Unified Coq Framework for Verifying C Programs with Floating-Point Computations 34 | ACM SIGPLAN Conference on Certified Programs and Proofs (CPP), 2016. 35 | https://dl.acm.org/doi/10.1145/2854065.2854066 36 | 37 | THE CORE OF VCFLOAT 38 | 39 | The core definitions and theorems are in: 40 | vcfloat/FPCore.v -- definitions of basic types 41 | vcfloat/FPLang.v -- deep-embedded description langage and rndval_with_cond theory 42 | vcfloat/FPLangOpt.v -- transformations on deep-embedded expressions 43 | 44 | APPLICATION STYLE "Clight" 45 | VCFloat 1.0 was designed for use on CompCert Clight expression trees, 46 | as described in Ramananandro et al. These files have been updated 47 | to latest versions of CompCert, Coq, and FPLang; they build in Coq 48 | but have not been tested. 49 | 50 | FILES: vcfloat/FPSolve.v, vcfloat/cverif/*.v 51 | 52 | APPLICATION STYLE "ftype" 53 | VCFloat 2.0 supports in addition a use case independent of CompCert Clight. 54 | One starts with a shallow-embedded floating-point expression, 55 | using the ordinary operators of Floqc (Binary.Bmult, Binary.Bplus, etc) 56 | but wrapped in special Coq definitions. 57 | 58 | 59 | FILES: vcfloat/Automate.v, vcfloat/Test.v 60 | 61 | See Test.v for an explanation of how to use VCFloat in this style. 62 | 63 | ------------------------- Requirements Notes ------------------------- 64 | 65 | VCFloat depends on Coq's Flocq and Interval packages. 66 | 67 | See coq-vcfloat.opam to see which versions of Coq, coq-flocq, and coq-interval are needed. 68 | 69 | 70 | To install: 71 | 72 | Use the Coq Platform (https://github.com/coq/platform) 73 | to ensure that Coq has access to all the above-named packages. 74 | Very possibly, by early 2024 coq-vcfloat will be included in the Coq platform. 75 | 76 | If vcfloat is not already in the Coq Platform, then install the Coq platform, then: 77 | 1. cd into the vcfloat/vcfloat directory 78 | 2. make depend 79 | 3. make 80 | 4. make install 81 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | # Possible future work in VCFloat 2 | 3 | - Common-subexpression elimination, by means of let-expressions, for the purposes of combining redundant deltas and epsilons 4 | - Automatically calculate annotations (Norm, Denorm, Sterbenz) 5 | - Allow relative/absolute errors on input variables 6 | - Allow generalized floating formats (double-double, etc.) 7 | - Allow flush-to-zero-on-underflow representations (i.e., without denormal numbers). 8 | Remark: In such formats, Sterbenz subtraction works only in the normal range. 9 | - Interval package could use hardware floats instead of synthesized, 10 | but only where extra precision is not neeeded 11 | - Make things a bit more efficient by better leveraging reflection and lemmas 12 | - Use the affine algorithm from FPTaylor 13 | - Avoid exponential blowup in prune_terms (might not be needed if we use the affine/FPTaylor algorithm) 14 | -------------------------------------------------------------------------------- /Test/.gitignore: -------------------------------------------------------------------------------- 1 | dir-locals 2 | #Makefile 3 | *.aux 4 | .dir-locals.el 5 | *.glob 6 | *.v.d 7 | *.vo 8 | *.vos 9 | *.vok 10 | run-coqide.sh 11 | *~ 12 | *.tgz 13 | *.tar.gz 14 | rcoqlib*/* 15 | compcert*/* 16 | ssreflect*/* 17 | mathcomp*/* 18 | flocq*/* 19 | interval*/* 20 | coqopts 21 | *.crashcoqide 22 | *.cache 23 | -------------------------------------------------------------------------------- /Test/Makefile: -------------------------------------------------------------------------------- 1 | COQC=coqc 2 | COQDEP=coqdep 3 | VCFLOAT_LOC=../vcfloat 4 | COQFLAGS= -Q $(VCFLOAT_LOC) vcfloat 5 | 6 | all: _CoqProject target 7 | 8 | _CoqProject: Makefile 9 | echo $(COQFLAGS) >_CoqProject 10 | 11 | target: summation.vo 12 | 13 | %.vo: %.v 14 | $(COQC) $(COQFLAGS) $*.v 15 | 16 | depend: 17 | $(COQDEP) $(COQFLAGS) *.v > .depend 18 | 19 | all_clean: rm *.vo *.vok *.vos *.glob 20 | 21 | -include .depend 22 | 23 | 24 | vcfloat: $(VCFLOAT_LOC)/Automate.vo $(VCFLOAT_LOC)/Prune.vo 25 | cd ../vcfloat; make vcfloat2 26 | -------------------------------------------------------------------------------- /Test/Nonstd.v: -------------------------------------------------------------------------------- 1 | (** Test.v: application demo of "ftype" usage-style of VCfloat. 2 | Copyright (C) 2021-2022 Andrew W. Appel and Ariel Kellison. 3 | *) 4 | 5 | Require Import vcfloat.VCFloat. 6 | Require Import Interval.Tactic. 7 | Import Binary. 8 | Import Coq.Lists.List ListNotations. 9 | Set Bullet Behavior "Strict Subproofs". 10 | 11 | Open Scope R_scope. 12 | 13 | 14 | Definition dub_to_F (x: ftype Tdouble) : option (Defs.float Zaux.radix2) := 15 | if FPCore.is_finite x then Some (FT2F x) else None. 16 | 17 | 18 | Definition dub_compare (x y : ftype Tdouble) : option comparison := compare' x y. 19 | 20 | Lemma dub_finite_compare: forall x, if dub_to_F x then dub_compare x x = Some Eq else True. 21 | Proof. 22 | intros. 23 | destruct x; simpl; auto. 24 | unfold dub_compare, compare'. 25 | simpl. 26 | unfold Bcompare. 27 | simpl. 28 | unfold BinarySingleNaN.Bcompare. 29 | simpl. 30 | destruct s; rewrite Z.compare_refl, Pcompare_refl; auto. 31 | Qed. 32 | 33 | Lemma dub_compare_correct: 34 | forall (f1 f2 : ftype Tdouble) (g1 g2 : Defs.float Zaux.radix2), 35 | dub_to_F f1 = Some g1 -> 36 | dub_to_F f2 = Some g2 -> 37 | dub_compare f1 f2 = Some (Rcompare (Defs.F2R g1) (Defs.F2R g2)). 38 | Proof. 39 | intros. 40 | unfold dub_to_F, dub_compare in *. 41 | destruct (FPCore.is_finite f1) eqn:?H; inversion H; clear H; subst. 42 | destruct (FPCore.is_finite f2) eqn:?H; inversion H0; clear H0; subst. 43 | rewrite compare'_correct; auto. 44 | f_equal. 45 | rewrite <- !B2R_float_of_ftype. 46 | simpl. 47 | rewrite <- !F2R_B2F by auto. 48 | rewrite !F2R_eq. 49 | auto. 50 | Qed. 51 | 52 | Lemma dub_nonempty_finite: if dub_to_F (Zconst Tdouble 0) then True else False. 53 | Proof. 54 | intros. 55 | reflexivity. 56 | Qed. 57 | 58 | Lemma dub_bounds: forall x : ftype Tdouble, 59 | - (bpow Zaux.radix2 1024 - bpow Zaux.radix2 (1024 - 53)) <= 60 | match dub_to_F x with 61 | | Some f => Defs.F2R f 62 | | None => R0 63 | end <= bpow Zaux.radix2 1024 - bpow Zaux.radix2 (1024 - 53). 64 | Proof. 65 | Admitted. 66 | 67 | 68 | Definition dub : nonstdtype 53 1024 I I := 69 | NONSTD _ _ _ _ (ftype Tdouble) (Zconst _ 0) dub_to_F dub_compare dub_finite_compare 70 | dub_compare_correct dub_nonempty_finite dub_bounds. 71 | 72 | Definition Tdub : type := GTYPE _ _ _ _ (Some dub). 73 | 74 | #[export] Instance coll : collection. 75 | exists [Tdub]. hnf; intros. destruct H; try contradiction. destruct H0; try contradiction. 76 | subst; auto. 77 | Defined. 78 | 79 | Section WITHNANS. 80 | Context {NANS: Nans}. 81 | 82 | Fixpoint always_true (args: list type) : function_type (map RR args) Prop := 83 | match args with 84 | | nil => True 85 | | _ :: args' => fun _ => always_true args' 86 | end. 87 | 88 | Parameter c_function: forall (args: list type) (res: type) (bnds: klist bounds args) (rel: N) (f: function_type (map RR args) R), 89 | {ff: function_type (map ftype' args) (ftype res) 90 | | acc_prop args res rel 1 bnds f ff /\ floatfunc_congr ff}. 91 | 92 | Ltac floatfunc' args res bnds rel f := 93 | let abs := constr:(1%N) in 94 | let cf := constr:(c_function args res bnds rel f) in 95 | let ff1 := constr:(Build_floatfunc args res _ f (proj1_sig cf) rel abs (proj1 (proj2_sig cf)) (proj2 (proj2_sig cf))) in 96 | exact (Build_floatfunc_package _ _ _ _ ff1). 97 | 98 | Definition some_bounds : bounds Tdub := 99 | ((Zconst Tdouble (-100), true), (Zconst Tdouble 100, false)). 100 | 101 | Definition cosff := ltac:(floatfunc' [Tdub] Tdub (Kcons some_bounds Knil) 3%N Rtrigo_def.cos). 102 | Definition cos := ltac:(apply_func cosff). 103 | Definition sinff := ltac:(floatfunc' [Tdub] Tdub (Kcons some_bounds Knil) 5%N Rtrigo_def.sin). 104 | Definition sin := ltac:(apply_func sinff). 105 | 106 | Definition plusff := ltac:(floatfunc' [Tdub;Tdub] Tdub (Kcons some_bounds (Kcons some_bounds Knil)) 0%N Rplus). 107 | Definition plus := ltac:(apply_func plusff). 108 | Definition multff := ltac:(floatfunc' [Tdub;Tdub] Tdub (Kcons some_bounds (Kcons some_bounds Knil)) 0%N Rmult). 109 | Definition mult := ltac:(apply_func multff). 110 | (* 111 | 112 | Definition F (x : ftype Tdub ) : ftype Tdub := 113 | plus (mult (cos x) (cos x)) (mult (sin x) (sin x)). 114 | *) 115 | 116 | Definition F (x : ftype Tdub ) : ftype Tdub := 117 | plus x x. 118 | 119 | Instance incoll_dub: incollection Tdub. 120 | hnf; auto. 121 | Defined. 122 | 123 | 124 | Definition _x : ident := 1%positive. 125 | (*Arguments Var {coll} ty {IN} _.*) 126 | 127 | (** These two lines compute a deep-embedded "expr"ession from 128 | a shallow-embedded Coq expression. *) 129 | Definition F' := ltac:(let e' := 130 | HO_reify_float_expr constr:([_x]) F in exact e'). 131 | 132 | Print F'. (* Demonstrates what x' looks like *) 133 | 134 | (** When interpreting deep-embedded expressions, "Var"iables will appear 135 | which are labeled by identifiers such as "_x" and "_v". We want a 136 | "varmap" for looking up the values of those variables. We'll compute 137 | that varmap in two stages. Step one, given values "x" and "v", 138 | make an association list mapping _x to x, and _v to v, each labeled 139 | by its floating-point type. *) 140 | 141 | Definition vmap_list (x : ftype Tdub) := 142 | [(_x, existT ftype _ x)]. 143 | 144 | 145 | (** Step two, build that into "varmap" data structure, taking care to 146 | compute it into a lookup-tree ___here___, not later in each place 147 | where we look something up. *) 148 | Definition vmap (x : ftype Tdub) : valmap := 149 | ltac:(make_valmap_of_list (vmap_list x)). 150 | 151 | (** Demonstration of reification and reflection. When you have a 152 | deep-embedded "expr"ession, you can get back the shallow embedding 153 | by applying the "fval" function *) 154 | 155 | Lemma reflect_reify_x : forall x, 156 | fval (env_ (vmap x)) F' = F x. 157 | Proof. 158 | intros. 159 | reflexivity. 160 | Qed. 161 | 162 | (** The main point of VCFloat is to prove bounds on the roundoff error of 163 | floating-point expressions. Generally those bounds are provable only if 164 | the free variables of the expression (e.g., "x" and "v") are themselves 165 | bounded in some way; otherwise, the expression might overflow. 166 | A "boundsmap" is a mapping from identifier (such as "_x") to 167 | a "varinfo", which gives its (floating-point) and its lower and upper bound. *) 168 | 169 | (** First we make an association list. This one says that 170 | -2.0 <= x <= 2.0 and -2.0 <= v <= 2.0 *) 171 | Definition bmap_list : list varinfo := 172 | [ Build_varinfo Tdub _x (-2) 2 ]. 173 | 174 | (** Then we calculate an efficient lookup table, the "boundsmap". *) 175 | Definition bmap : boundsmap := 176 | ltac:(let z := compute_PTree (boundsmap_of_list bmap_list) in exact z). 177 | 178 | (** Now we prove that the leapfrogx expression (deep-embedded as x' ) 179 | has a roundoff error less than 1.0e-5 *) 180 | Lemma prove_roundoff_bound_x: 181 | forall vmap, 182 | prove_roundoff_bound bmap vmap F' 2.3e-15. 183 | Proof. 184 | intros. 185 | prove_roundoff_bound. 186 | - 187 | prove_rndval. 188 | all: interval. 189 | - 190 | prove_roundoff_bound2. 191 | match goal with |- (Rabs ?a <= _)%R => field_simplify a end. (* improves the bound *) 192 | interval. 193 | Qed. 194 | 195 | Derive x_acc 196 | SuchThat (forall vmap, prove_roundoff_bound bmap vmap F' x_acc) 197 | As prove_roundoff_bound_x_alt. 198 | Proof. 199 | intros. 200 | prove_roundoff_bound. 201 | - 202 | prove_rndval; interval. 203 | - 204 | prove_roundoff_bound2. 205 | match goal with |- (Rabs ?a <= _)%R => field_simplify a end. 206 | match goal with |- (Rabs ?a <= _)%R => interval_intro (Rabs a) end. 207 | subst x_acc; apply H. 208 | Qed. 209 | 210 | Print x_acc. 211 | Check prove_roundoff_bound_x_alt. 212 | 213 | End WITHNANS. 214 | 215 | 216 | 217 | -------------------------------------------------------------------------------- /Test/README.md: -------------------------------------------------------------------------------- 1 | This directory contains test files for future continuous integration. 2 | 3 | -------------------------------------------------------------------------------- /Test/Test.v: -------------------------------------------------------------------------------- 1 | (** Test.v: application demo of "ftype" usage-style of VCfloat. 2 | Copyright (C) 2021-2022 Andrew W. Appel and Ariel Kellison. 3 | *) 4 | 5 | Require Import vcfloat.VCFloat. 6 | Require Import Interval.Tactic. 7 | Import Binary. 8 | Import Coq.Lists.List ListNotations. 9 | Set Bullet Behavior "Strict Subproofs". 10 | 11 | Open Scope R_scope. 12 | 13 | Section WITHNANS. 14 | 15 | (** NANS: Each different computer architecture supports the same IEEE-754 16 | floating-point standard, but with slightly different Not-a-number (NAN) behavior. 17 | That behavior is encapsulated in a Nans typeclass. You can instantiate that 18 | appropriate for your own architecture; but all the demos in this file are 19 | independent of the Nans details, so we can leave it abstract, like this: *) 20 | Context {NANS: Nans}. 21 | 22 | (** We will demonstrate VCfloat on a symplectic ODE (ordinary differential 23 | equation) integration for a simple harmonic oscillator. *) 24 | 25 | Definition h := (1 / 32)%F32. (* Time-step: 1/32 of a second *) 26 | 27 | (* Force, as a function of position *) 28 | Definition F (x : ftype Tsingle ) : ftype Tsingle := (-x)%F32. 29 | 30 | (** Compute one time-step: given "ic" which is a pair of position and velocity, 31 | calculate the new position and velocity after time "h" has elapsed. *) 32 | Definition leapfrog_step ( ic : ftype Tsingle * ftype Tsingle) : ftype Tsingle * ftype Tsingle := 33 | let x := fst ic in let v:= snd ic in 34 | let x' := ((x + h * v) + ((1/2) * (h * h)) * F x)%F32 in 35 | let v' := (v + (1/2 * h) * (F x + F x'))%F32 in 36 | (x', v'). 37 | 38 | (** Calculate a new position, as a function of position x and velocity v *) 39 | Definition leapfrog_stepx x v := fst (leapfrog_step (x,v)). 40 | 41 | (** Calculate a new velocity, as a function of position x and velocity v *) 42 | Definition leapfrog_stepv x v := snd (leapfrog_step (x,v)). 43 | 44 | (** In deep-embedded (syntactic) expressons, variables are represented 45 | by "ident"ifiers, which are actually small positive numbers. *) 46 | Definition _x : ident := 1%positive. (* Variable name for position *) 47 | Definition _v : ident := 2%positive. (* Variable name for velocity *) 48 | 49 | (** These two lines compute a deep-embedded "expr"ession from 50 | a shallow-embedded Coq expression. *) 51 | Definition x' := ltac:(let e' := 52 | HO_reify_float_expr constr:([_x; _v]) leapfrog_stepx in exact e'). 53 | Definition v' := ltac:(let e' := 54 | HO_reify_float_expr constr:([_x; _v]) leapfrog_stepv in exact e'). 55 | 56 | Print x'. (* Demonstrates what x' looks like *) 57 | 58 | (** When interpreting deep-embedded expressions, "Var"iables will appear 59 | which are labeled by identifiers such as "_x" and "_v". We want a 60 | "varmap" for looking up the values of those variables. We'll compute 61 | that varmap in two stages. Step one, given values "x" and "v", 62 | make an association list mapping _x to x, and _v to v, each labeled 63 | by its floating-point type. *) 64 | 65 | Definition leapfrog_vmap_list (x v : ftype Tsingle) := 66 | [(_x, existT ftype _ x);(_v, existT ftype _ v)]. 67 | 68 | (** Step two, build that into "varmap" data structure, taking care to 69 | compute it into a lookup-tree ___here___, not later in each place 70 | where we look something up. *) 71 | Definition leapfrog_vmap (x v : ftype Tsingle) : valmap := 72 | ltac:(make_valmap_of_list (leapfrog_vmap_list x v)). 73 | 74 | (** Demonstration of reification and reflection. When you have a 75 | deep-embedded "expr"ession, you can get back the shallow embedding 76 | by applying the "fval" function *) 77 | 78 | Lemma reflect_reify_x : forall x v, 79 | fval (env_ (leapfrog_vmap x v)) x' = leapfrog_stepx x v. 80 | Proof. 81 | intros. 82 | destruct true. (* artificial way to get two subgoals *) 83 | - 84 | unfold x', leapfrog_stepx, leapfrog_step, F, fst, snd. (* This line makes things go faster *) 85 | Time reflexivity. (* 0.01 sec *) 86 | - 87 | (* Demonstration that unfold_reflect doesn't make things any faster (or much slower). *) 88 | unfold x', leapfrog_stepx, leapfrog_step, F, fst, snd. (* This line needed here *) 89 | Time unfold_reflect. (* 0.02 secs *) 90 | Time reflexivity. (* 0.006 sec *) 91 | (* Therefore, use unfold_reflect if you wish to, for clarity, not for performance *) 92 | Qed. 93 | 94 | (** Demonstration of reification and reflection, this time on leapfrog_stepv *) 95 | Lemma reflect_reify_v : forall x v, fval (env_ (leapfrog_vmap x v)) v' = leapfrog_stepv x v. 96 | Proof. 97 | intros. 98 | unfold v'. 99 | (* without this line, things are much slower: *) unfold leapfrog_stepv, leapfrog_step, F, fst, snd. 100 | Time reflexivity. 101 | Qed. 102 | 103 | (** The main point of VCFloat is to prove bounds on the roundoff error of 104 | floating-point expressions. Generally those bounds are provable only if 105 | the free variables of the expression (e.g., "x" and "v") are themselves 106 | bounded in some way; otherwise, the expression might overflow. 107 | A "boundsmap" is a mapping from identifier (such as "_x") to 108 | a "varinfo", which gives its (floating-point) and its lower and upper bound. *) 109 | 110 | (** First we make an association list. This one says that 111 | -2.0 <= x <= 2.0 and -2.0 <= v <= 2.0 *) 112 | Definition leapfrog_bmap_list : list varinfo := 113 | [ Build_varinfo Tsingle _x (-2) 2 ; Build_varinfo Tsingle _v (-2) 2 ]. 114 | 115 | (** Then we calculate an efficient lookup table, the "boundsmap". *) 116 | Definition leapfrog_bmap : boundsmap := 117 | ltac:(let z := compute_PTree (boundsmap_of_list leapfrog_bmap_list) in exact z). 118 | 119 | (** Now we prove that the leapfrogx expression (deep-embedded as x' ) 120 | has a roundoff error less than 1.0e-5 *) 121 | Lemma prove_roundoff_bound_x: 122 | forall vmap, 123 | prove_roundoff_bound leapfrog_bmap vmap x' 124 | (/ 4068166). 125 | Proof. 126 | intros. 127 | prove_roundoff_bound. 128 | (* This divides into two proof goals. 129 | Goal 1 is "prove_rndval", which generates a list of verification conditions 130 | about subexpressions of x'; and if those can be proved, then 131 | x' evaluates equivalent to a perturbed expression. 132 | Goal 2 shows that the perturbed expression evaluates "close to" 133 | the exact real-number interpretation of expression x'. *) 134 | - 135 | (* Solve Goal 1 by the prove_rndval tactic, which generates 136 | a list of interval subgoals, and prove each one of those 137 | by the "interval" tactic *) 138 | prove_rndval. 139 | all: interval. 140 | - 141 | prove_roundoff_bound2. 142 | match goal with |- Rabs ?a <= _ => field_simplify a end. (* improves the bound *) 143 | (* Right now, just "interval" would solve the goal. 144 | but to see how we guess the bound to use, try this instead: *) 145 | match goal with |- Rabs ?a <= _ => interval_intro (Rabs a) end. 146 | eapply Rle_trans; [apply H | clear]. 147 | eapply roundoff_bound_hack; [lia|lia|lia|compute; reflexivity|]. 148 | lia. 149 | Qed. 150 | 151 | Derive x_acc 152 | SuchThat (forall vmap, prove_roundoff_bound leapfrog_bmap vmap x' x_acc) 153 | As prove_roundoff_bound_x_alt. 154 | Proof. 155 | intros. 156 | prove_roundoff_bound. 157 | - 158 | prove_rndval; interval. 159 | - 160 | prove_roundoff_bound2. 161 | match goal with |- Rabs ?a <= _ => field_simplify a end. 162 | match goal with |- Rabs ?a <= _ => interval_intro (Rabs a) end. 163 | subst x_acc; apply H. 164 | Qed. 165 | 166 | Print x_acc. 167 | Check prove_roundoff_bound_x_alt. 168 | 169 | Lemma prove_roundoff_bound_v: 170 | forall x v : ftype Tsingle, 171 | prove_roundoff_bound leapfrog_bmap (leapfrog_vmap x v) v' 172 | (/ 7662902). 173 | Proof. 174 | intros. 175 | prove_roundoff_bound. 176 | - abstract (prove_rndval; interval). 177 | - 178 | prove_roundoff_bound2. 179 | match goal with |- Rabs ?a <= _ => field_simplify a end. 180 | interval. 181 | Qed. 182 | 183 | (* This one commented out, because prove_val_bound2 needs to 184 | be brought up to date with the recent changes to prove_roundoff_bound2 185 | (** The following lemma demonstrates [val_bound], that is, 186 | compute the maximum absolute value of a floating-point expression *) 187 | Lemma prove_val_bound_x: 188 | forall vmap, 189 | prove_val_bound leapfrog_bmap vmap x' 190 | (4642138645987358 / 2251799813685248). 191 | Proof. 192 | intros. 193 | prove_val_bound. 194 | - 195 | abstract (prove_rndval; interval). 196 | - 197 | prove_val_bound2. 198 | match goal with |- Rabs ?a <= _ => field_simplify a end. 199 | match goal with |- Rabs ?a <= _ => interval_intro (Rabs a) end. 200 | eapply Rle_trans; [apply H | clear]. 201 | lra. 202 | Qed. 203 | *) 204 | End WITHNANS. 205 | 206 | 207 | 208 | -------------------------------------------------------------------------------- /Test/Test2.v: -------------------------------------------------------------------------------- 1 | (** Test2.v: application demo of "ftype" usage-style of VCfloat. 2 | Copyright (C) 2021-2022 Andrew W. Appel and Ariel Kellison. 3 | *) 4 | 5 | Require Import vcfloat.VCFloat. 6 | Require Import Interval.Tactic. 7 | Import Binary. 8 | Import Coq.Lists.List ListNotations. 9 | Set Bullet Behavior "Strict Subproofs". 10 | 11 | Open Scope R_scope. 12 | 13 | Section WITHNANS. 14 | 15 | Context {NANS: Nans}. 16 | 17 | (* Example: Sterbenz subtraction *) 18 | Definition Sterbenz_test32 a b := Sterbenz(a - b)%F32. 19 | Definition Sterbenz_test64 a b := Sterbenz(a - b)%F64. 20 | 21 | Definition _a : ident := 1%positive. 22 | Definition _b : ident := 2%positive. 23 | 24 | Definition Sterbenz_expr32 := ltac:(let e' := 25 | HO_reify_float_expr constr:([_a; _b]) Sterbenz_test32 in exact e'). 26 | Definition Sterbenz_expr64:= ltac:(let e' := 27 | HO_reify_float_expr constr:([_a; _b]) Sterbenz_test64 in exact e'). 28 | 29 | Definition vmap' {ty} (a b : ftype ty) := 30 | [(_a, existT ftype _ a);(_b, existT ftype _ b)]. 31 | (* this should be made to work more generally . . . 32 | Definition vmap (ty: type) (a b : ftype ty) : valmap := 33 | ltac:(make_valmap_of_list (vmap' a b)). 34 | *) 35 | 36 | 37 | Definition vmap (a b : ftype Tsingle) : valmap := 38 | ltac:(make_valmap_of_list (vmap' a b)). 39 | 40 | Definition bmap' (ty : type) : list varinfo := 41 | [ Build_varinfo ty _a 1 2 ; Build_varinfo ty _b 1 2 ]. 42 | Definition bmap (ty : type) : boundsmap := 43 | ltac:(let z := compute_PTree (boundsmap_of_list (bmap' ty)) in exact z). 44 | 45 | Lemma prove_roundoff_bound32: 46 | forall a b : ftype Tsingle, 47 | prove_roundoff_bound (bmap Tsingle) (vmap (*Tsingle*) a b) Sterbenz_expr32 0%R. 48 | Proof. 49 | intros. 50 | prove_roundoff_bound. 51 | - 52 | (* the VCFloat tactic "prove_rndval" creates subgoals for each of 53 | the automatically generated validity conditions. These subgoals 54 | may or may not be satisfied by the user provided bounds in the 55 | data structure bmap. The interval tactic is invoked in order to 56 | try and solve each subgoal; this tactic might require, as in this 57 | exmaple, computations done in higher-precision in order to solve 58 | the subgoal. *) 59 | prove_rndval. 60 | + (* Sterbenz goal 1 *) interval with (i_prec 128). 61 | + (* Sterbenz goal 2 *) interval with (i_prec 128). 62 | - 63 | prove_roundoff_bound2. 64 | match goal with |- Rabs ?a <= _ => field_simplify a end. 65 | interval. 66 | Qed. 67 | 68 | End WITHNANS. 69 | 70 | 71 | 72 | -------------------------------------------------------------------------------- /Test/TestFunc.v: -------------------------------------------------------------------------------- 1 | (** Test.v: application demo of "ftype" usage-style of VCfloat. 2 | Copyright (C) 2021-2022 Andrew W. Appel and Ariel Kellison. 3 | *) 4 | 5 | Require Import vcfloat.VCFloat. 6 | Require Import Interval.Tactic. 7 | Import Binary. 8 | Import Coq.Lists.List ListNotations. 9 | Set Bullet Behavior "Strict Subproofs". 10 | 11 | Open Scope R_scope. 12 | 13 | Section WITHNANS. 14 | Context {NANS: Nans}. 15 | 16 | Fixpoint always_true (args: list type) : function_type (map RR args) Prop := 17 | match args with 18 | | nil => True 19 | | _ :: args' => fun _ => always_true args' 20 | end. 21 | 22 | Parameter c_function: forall (args: list type) (res: type) (bnds: klist bounds args) (rel: N) (f: function_type (map RR args) R), 23 | {ff: function_type (map ftype' args) (ftype res) 24 | | acc_prop args res rel 1 bnds f ff /\ floatfunc_congr ff}. 25 | 26 | Ltac floatfunc' args res bnds rel f := 27 | let abs := constr:(1%N) in 28 | let cf := constr:(c_function args res bnds rel f) in 29 | let ff1 := constr:(Build_floatfunc args res _ f (proj1_sig cf) rel abs (proj1 (proj2_sig cf)) (proj2 (proj2_sig cf))) in 30 | exact (Build_floatfunc_package _ _ _ _ ff1). 31 | 32 | Definition vacuous_bnds ty `{STD: is_standard ty} : bounds ty := 33 | ((ftype_of_float (B754_infinity (fprec ty) (femax ty) true), false), 34 | (ftype_of_float (B754_infinity (fprec ty) (femax ty) false), false)). 35 | 36 | Definition silly_bnds : bounds Tdouble := 37 | ((-6, true), (99, false))%F64. 38 | 39 | 40 | Definition cosff := ltac:(floatfunc' [Tdouble] Tdouble (Kcons (vacuous_bnds Tdouble) Knil) 3%N Rtrigo_def.cos). 41 | Definition cos := ltac:(apply_func cosff). 42 | Definition sinff := ltac:(floatfunc' [Tdouble] Tdouble (Kcons silly_bnds Knil) 5%N Rtrigo_def.sin). 43 | Definition sin := ltac:(apply_func sinff). 44 | 45 | Lemma test_reify1: False. 46 | Proof. 47 | pose (e := (1 + cos 2)%F64). 48 | let u := reify_float_expr e in 49 | constr_eq u 50 | (Binop (Rounded2 PLUS None) (Const Tdouble I 1%F64) 51 | (Func Tdouble cosff 52 | (Kcons (Const Tdouble I 2%F64) Knil))). 53 | Abort. 54 | 55 | Definition F (x : ftype Tdouble ) : ftype Tdouble := 56 | (cos x * cos x + sin x * sin x)%F64. 57 | 58 | 59 | Definition _x : ident := 1%positive. 60 | (** These two lines compute a deep-embedded "expr"ession from 61 | a shallow-embedded Coq expression. *) 62 | Definition F' := ltac:(let e' := 63 | HO_reify_float_expr constr:([_x]) F in exact e'). 64 | 65 | Print F'. (* Demonstrates what x' looks like *) 66 | 67 | (** When interpreting deep-embedded expressions, "Var"iables will appear 68 | which are labeled by identifiers such as "_x" and "_v". We want a 69 | "varmap" for looking up the values of those variables. We'll compute 70 | that varmap in two stages. Step one, given values "x" and "v", 71 | make an association list mapping _x to x, and _v to v, each labeled 72 | by its floating-point type. *) 73 | 74 | Definition vmap_list (x : ftype Tdouble) := 75 | [(_x, existT ftype _ x)]. 76 | 77 | (** Step two, build that into "varmap" data structure, taking care to 78 | compute it into a lookup-tree ___here___, not later in each place 79 | where we look something up. *) 80 | Definition vmap (x : ftype Tdouble) : valmap := 81 | ltac:(make_valmap_of_list (vmap_list x)). 82 | 83 | (** Demonstration of reification and reflection. When you have a 84 | deep-embedded "expr"ession, you can get back the shallow embedding 85 | by applying the "fval" function *) 86 | 87 | Lemma reflect_reify_x : forall x, 88 | fval (env_ (vmap x)) F' = F x. 89 | Proof. 90 | intros. 91 | reflexivity. 92 | Qed. 93 | 94 | (** The main point of VCFloat is to prove bounds on the roundoff error of 95 | floating-point expressions. Generally those bounds are provable only if 96 | the free variables of the expression (e.g., "x" and "v") are themselves 97 | bounded in some way; otherwise, the expression might overflow. 98 | A "boundsmap" is a mapping from identifier (such as "_x") to 99 | a "varinfo", which gives its (floating-point) and its lower and upper bound. *) 100 | 101 | (** First we make an association list. This one says that 102 | -2.0 <= x <= 2.0 and -2.0 <= v <= 2.0 *) 103 | Definition bmap_list : list varinfo := 104 | [ Build_varinfo Tdouble _x (-2) 2 ]. 105 | 106 | (** Then we calculate an efficient lookup table, the "boundsmap". *) 107 | Definition bmap : boundsmap := 108 | ltac:(let z := compute_PTree (boundsmap_of_list bmap_list) in exact z). 109 | 110 | (** Now we prove that the leapfrogx expression (deep-embedded as x' ) 111 | has a roundoff error less than 1.0e-5 *) 112 | Lemma prove_roundoff_bound_x: 113 | forall vmap, 114 | prove_roundoff_bound bmap vmap F' 2.3e-15. 115 | Proof. 116 | intros. 117 | prove_roundoff_bound. 118 | - 119 | prove_rndval. 120 | all: interval. 121 | - 122 | prove_roundoff_bound2. 123 | match goal with |- Rabs ?a <= _ => field_simplify a end. (* improves the bound *) 124 | interval. 125 | Qed. 126 | 127 | Derive x_acc 128 | SuchThat (forall vmap, prove_roundoff_bound bmap vmap F' x_acc) 129 | As prove_roundoff_bound_x_alt. 130 | Proof. 131 | intros. 132 | prove_roundoff_bound. 133 | - 134 | prove_rndval; interval. 135 | - 136 | prove_roundoff_bound2. 137 | match goal with |- Rabs ?a <= _ => field_simplify a end. 138 | match goal with |- Rabs ?a <= _ => interval_intro (Rabs a) end. 139 | subst x_acc; apply H. 140 | Qed. 141 | 142 | Print x_acc. 143 | Check prove_roundoff_bound_x_alt. 144 | 145 | End WITHNANS. 146 | 147 | 148 | 149 | -------------------------------------------------------------------------------- /Test/TestPaper.v: -------------------------------------------------------------------------------- 1 | (** TestPaper.v: examples taken from the paper, 2 | "VCFloat2: Floating-point error analysis in Coq" 3 | Copyright (C) 2022 Andrew W. Appel and Ariel Kellison. 4 | *) 5 | 6 | Require Import vcfloat.VCFloat. 7 | Require Import Interval.Tactic. 8 | Import Binary. 9 | Import Coq.Lists.List ListNotations. 10 | Set Bullet Behavior "Strict Subproofs". 11 | 12 | Open Scope R_scope. 13 | 14 | Section WITHNANS. 15 | 16 | (** NANS: Each different computer architecture supports the same IEEE-754 17 | floating-point standard, but with slightly different Not-a-number (NAN) behavior. 18 | That behavior is encapsulated in a Nans typeclass. You can instantiate that 19 | appropriate for your own architecture; but all the demos in this file are 20 | independent of the Nans details, so we can leave it abstract, like this: *) 21 | Context {NANS: Nans}. 22 | 23 | (** We will demonstrate VCfloat on a symplectic ODE (ordinary differential 24 | equation) integration for a simple harmonic oscillator. *) 25 | 26 | Definition h := (1/32)%F32. 27 | Definition F(x: ftype Tsingle) : ftype Tsingle := Sterbenz(3.0-x)%F32. 28 | Definition step (x v: ftype Tsingle) := (Norm(x + h*(v+(h/2)*F(x))))%F32. 29 | 30 | (** In deep-embedded (syntactic) expressons, variables are represented 31 | by "ident"ifiers, which are actually small positive numbers. *) 32 | Definition _x : ident := 1%positive. (* Variable name for position *) 33 | Definition _v : ident := 2%positive. (* Variable name for velocity *) 34 | 35 | (** These two lines compute a deep-embedded "expr"ession from 36 | a shallow-embedded Coq expression. *) 37 | Definition step' := ltac:(let e' := 38 | HO_reify_float_expr constr:([_x; _v]) step in exact e'). 39 | 40 | Print step'. (* Demonstrates what step' looks like *) 41 | 42 | (** When interpreting deep-embedded expressions, "Var"iables will appear 43 | which are labeled by identifiers such as "_x" and "_v". We want a 44 | "varmap" for looking up the values of those variables. We'll compute 45 | that varmap in two stages. Step one, given values "x" and "v", 46 | make an association list mapping _x to x, and _v to v, each labeled 47 | by its floating-point type. *) 48 | 49 | Definition step_vmap_list (x v : ftype Tsingle) := 50 | [(_x, existT ftype _ x);(_v, existT ftype _ v)]. 51 | 52 | (** Step two, build that into "varmap" data structure, taking care to 53 | compute it into a lookup-tree ___here___, not later in each place 54 | where we look something up. *) 55 | Definition step_vmap (x v : ftype Tsingle) : valmap := 56 | ltac:(make_valmap_of_list (step_vmap_list x v)). 57 | 58 | (** Demonstration of reification and reflection. When you have a 59 | deep-embedded "expr"ession, you can get back the shallow embedding 60 | by applying the "fval" function *) 61 | 62 | Lemma reflect_reify : forall x v, 63 | fval (env_ (step_vmap x v)) step' = step x v. 64 | Proof. reflexivity. Qed. 65 | 66 | (** To create the boundsmap, first we make an association list. This one says 67 | that 2.0 <= x <= 4.0 and -2.0 <= v <= 2.0 *) 68 | Definition step_bmap_list : list varinfo := 69 | [ Build_varinfo Tsingle _x 2 4 ; Build_varinfo Tsingle _v (-2) 2 ]. 70 | 71 | (** Then we calculate an efficient lookup table, the "boundsmap". *) 72 | Definition step_bmap : boundsmap := 73 | ltac:(let z := compute_PTree (boundsmap_of_list step_bmap_list) in exact z). 74 | 75 | (** Now we prove that the leapfrogx expression (deep-embedded as x' ) 76 | has a roundoff error less than 1.0e-5 *) 77 | Lemma prove_roundoff_bound_step: 78 | forall vmap, 79 | prove_roundoff_bound step_bmap vmap step' (/ 4000000). 80 | Proof. 81 | intros. 82 | prove_roundoff_bound. 83 | - 84 | prove_rndval. 85 | all: interval. 86 | - 87 | prove_roundoff_bound2. 88 | prune_terms (cutoff 30). 89 | do_interval. 90 | Qed. 91 | 92 | (* The next part demonstrates that you don't have to guess the 93 | upper bound in advance, to use the tool. *) 94 | Derive acc 95 | SuchThat (forall vmap, prove_roundoff_bound step_bmap vmap step' acc) 96 | As prove_roundoff_bound_x_alt. 97 | Proof. 98 | intros. 99 | prove_roundoff_bound. 100 | - 101 | prove_rndval; interval. 102 | - 103 | subst acc. 104 | prove_roundoff_bound2. 105 | prune_terms (cutoff 100). 106 | do_interval. 107 | Qed. 108 | 109 | 110 | (* Let's check that the first component of that thing is actually 111 | simple expression containing a few constants, 112 | i.e. a concrete bound on the roundoff error of the step function. *) 113 | Print acc. 114 | 115 | (* We claimed that the roundoff error is less than 1/4000000; let's check! *) 116 | Lemma bound_less_than_one_over_four_million: acc <= 1 / 4000000. 117 | Proof. compute; lra. Qed. 118 | 119 | (* Let's make sure the second component really is a proof that 120 | this is a bound on the roundoff error of the step function *) 121 | Check prove_roundoff_bound_x_alt. 122 | 123 | End WITHNANS. 124 | 125 | (* Below are tests of the "prune_terms" tactic and various steps 126 | of the algorithm *) 127 | 128 | Lemma test1: 129 | forall 130 | (x v e0 d e1 e2 d0 e3 : R) 131 | (BOUND : -2 <= v <= 2) 132 | (BOUND0 : -2 <= x <= 2) 133 | (E : Rabs e0 <= / 713623846352979940529142984724747568191373312) 134 | (E0 : Rabs d <= / 16777216) 135 | (E1 : Rabs e1 <= / 1427247692705959881058285969449495136382746624) 136 | (E2 : Rabs e2 <= / 713623846352979940529142984724747568191373312) 137 | (E3 : Rabs d0 <= / 16777216) 138 | (E4 : Rabs e3 <= / 1427247692705959881058285969449495136382746624), 139 | Rabs 140 | (((x + (1 / 32 * v + e2)) * (1 + d) + e3 + (1 / 2048 * - x + e0)) * 141 | (1 + d0) + e1 - (x + 1 / 32 * v + 1 / 2 * (1 / 32 * (1 / 32)) * - x)) <= 142 | 2.46e-7. 143 | Proof. 144 | intros. 145 | prune_terms (cutoff 30). 146 | (*match goal with |- Rabs ?a <= _ => field_simplify a end.*) 147 | match goal with |- Rabs ?t <= ?r => interval_intro (Rabs t) as H99 end. 148 | eapply Rle_trans; [ apply H99 | clear ]. 149 | compute; lra. 150 | Qed. 151 | 152 | Import Tree. 153 | 154 | Lemma test1_double_precision: 155 | forall 156 | (x v e0 d e1 e2 d0 e3 : R) 157 | (BOUND : -2 <= v <= 2) 158 | (BOUND0 : -2 <= x <= 2) 159 | (E : Rabs e0 <= / bpow' 2 298) 160 | (E0 : Rabs d <= / bpow' 2 48) 161 | (E1 : Rabs e1 <= / bpow' 2 300) 162 | (E2 : Rabs e2 <= / bpow' 2 298) 163 | (E3 : Rabs d0 <= / bpow' 2 48) 164 | (E4 : Rabs e3 <= / bpow' 2 298), 165 | Rabs 166 | (((x + (1 / 32 * v + e2)) * (1 + d) + e3 + (1 / 2048 * - x + e0)) * 167 | (1 + d0) + e1 - (x + 1 / 32 * v + 1 / 2 * (1 / 32 * (1 / 32)) * - x)) <= 168 | 2.46e-7. 169 | Proof. 170 | intros. 171 | prune_terms (cutoff 60). 172 | (*match goal with |- Rabs ?a <= _ => field_simplify a end.*) 173 | match goal with |- Rabs ?t <= ?r => interval_intro (Rabs t) as H99 end. 174 | eapply Rle_trans; [ apply H99 | clear ]. 175 | compute; lra. 176 | Qed. 177 | 178 | Lemma test3: forall 179 | (x v d1 d2 e0 e1 e3 : R) 180 | (BOUND : -2 <= v <= 2) 181 | (BOUND0 : 2 <= x <= 4) 182 | (E : Rabs d1 <= / 16777216) 183 | (E0 : Rabs d2 <= / 16777216) 184 | (E1 : Rabs e0 <= / 713623846352979940529142984724747568191373312) 185 | (E2 : Rabs e1 <= / 1427247692705959881058285969449495136382746624) 186 | (E3 : Rabs e3 <= / 713623846352979940529142984724747568191373312), 187 | Rabs 188 | (((x + (1 / 32 * v + e0)) * (1 + d2) + (1 / 2048 * (3 - x) + e3)) * 189 | (1 + d1) + e1 - 190 | (x + 1 / 32 * v + 1 / 2 * (1 / 32 * (1 / 32)) * (3 - x))) <= 191 | / 2000000. 192 | Proof. 193 | intros. 194 | prune_terms (cutoff 30). 195 | match goal with |- Rabs ?t <= ?r => interval_intro (Rabs t) as H99 end. 196 | eapply Rle_trans; [ apply H99 | clear ]. 197 | simpl; compute; lra. 198 | Qed. 199 | 200 | 201 | Lemma test3_alt: forall 202 | (x v d1 d2 e0 e1 e3 : R) 203 | (BOUND : -2 <= v <= 2) 204 | (BOUND0 : 2 <= x <= 4) 205 | (E : Rabs e0 <= / 713623846352979940529142984724747568191373312) 206 | (E0 : Rabs d1 <= / 16777216) 207 | (E1 : Rabs e1 <= / 713623846352979940529142984724747568191373312) 208 | (E2 : Rabs d2 <= / 16777216) 209 | (E3 : Rabs e3 <= / 1427247692705959881058285969449495136382746624), 210 | Rabs 211 | ((x + (1 / 32 * ((v + (1 / 64 * (3 - x) + e1)) * (1 + d1) + e3) + e0)) * 212 | (1 + d2) - (x + 1 / 32 * (v + 1 / 32 / 2 * (3 - x)))) <= 213 | 1/4000000. 214 | Proof. 215 | intros. 216 | prune_terms (cutoff 30). 217 | match goal with |- Rabs ?t <= ?r => interval_intro (Rabs t) as H99 end. 218 | eapply Rle_trans; [ apply H99 | clear ]. 219 | compute; simpl; lra. 220 | Qed. 221 | 222 | Lemma test2: 223 | forall 224 | (d d0 d1 e0 d2 e1 e2 e3 e4 e5 d3 e6 e7 e8 e9 e10 e11 e12 e13 d4 e14 225 | e15 e16 e17 e18 d5 d6 d7 d8 e19 e20 d9 d10 d11 d12 e21 d13 e22 e23 e24 226 | x v : R) 227 | (BOUND : (-2) <= v <= 2) 228 | (BOUND0 : (-2) <= x <= 2) 229 | (E : (Rabs d) <= (/ 16777216)) 230 | ( E0 : (Rabs d0) <= (/ 16777216)) 231 | ( E1 : (Rabs d1) <= (/ 16777216)) 232 | ( E2 : (Rabs e0) <= (/ 1427247692705959881058285969449495136382746624)) 233 | (E3 : (Rabs d2) <= (/ 16777216)) 234 | (E4 : (Rabs e1) <= (/ 713623846352979940529142984724747568191373312)) 235 | ( E5 : (Rabs e2) <= (/ 1427247692705959881058285969449495136382746624)) 236 | ( E6 : (Rabs e3) <= (/ 1427247692705959881058285969449495136382746624)) 237 | ( E7 : (Rabs e4) <= (/ 1427247692705959881058285969449495136382746624)) 238 | ( E8 : (Rabs e5) <= (/ 1427247692705959881058285969449495136382746624)) 239 | ( E9 : (Rabs d3) <= (/ 16777216)) 240 | ( E10 : (Rabs e6) <= (/ 713623846352979940529142984724747568191373312)) 241 | ( E11 : (Rabs e7) <= (/ 713623846352979940529142984724747568191373312)) 242 | ( E12 : (Rabs e8) <= (/ 713623846352979940529142984724747568191373312)) 243 | ( E13 : (Rabs e9) <= (/ 713623846352979940529142984724747568191373312)) 244 | ( E14 : (Rabs e10) <= (/ 1427247692705959881058285969449495136382746624)) 245 | ( E15 : (Rabs e11) <= (/ 1427247692705959881058285969449495136382746624)) 246 | ( E16 : (Rabs e12) <= (/ 1427247692705959881058285969449495136382746624)) 247 | ( E17 : (Rabs e13) <= (/ 1427247692705959881058285969449495136382746624)) 248 | ( E18 : (Rabs d4) <= (/ 16777216)) 249 | ( E19 : (Rabs e14) <= (/ 713623846352979940529142984724747568191373312)) 250 | ( E20 : (Rabs e15) <= (/ 1427247692705959881058285969449495136382746624)) 251 | (E21 : (Rabs e16) <= (/ 1427247692705959881058285969449495136382746624) ) 252 | ( E22 : (Rabs e17) <= (/ 1427247692705959881058285969449495136382746624)) 253 | ( E23 : (Rabs e18) <= (/ 1427247692705959881058285969449495136382746624)) 254 | ( E24 : (Rabs d5) <= (/ 16777216)) 255 | (E25 : (Rabs d6) <= (/ 16777216)) 256 | (E26 : (Rabs d7) <= (/ 16777216)) 257 | (E27 : (Rabs d8) <= (/ 16777216)) 258 | (E28 : (Rabs e19) <= (/ 713623846352979940529142984724747568191373312)) 259 | (E29 : (Rabs e20) <= (/ 1427247692705959881058285969449495136382746624)) 260 | (E30 : (Rabs d9) <= (/ 16777216)) 261 | (E31 : (Rabs d10) <= (/ 16777216)) 262 | (E32 : (Rabs d11) <= (/ 16777216)) 263 | (E33 : (Rabs d12) <= (/ 16777216)) 264 | (E34 : (Rabs e21) <= (/ 713623846352979940529142984724747568191373312)) 265 | (E35 : (Rabs d13) <= (/ 16777216)) 266 | (E36 : (Rabs e22) <= (/ 713623846352979940529142984724747568191373312)) 267 | (E37 : (Rabs e23) <= (/ 713623846352979940529142984724747568191373312)) 268 | (E38 : (Rabs e24) <= (/ 1427247692705959881058285969449495136382746624)), 269 | Rabs 270 | (((((x + (1 / 32 * v + e14)) * (1 + d3) + e20 + (1 / 2048 * - x + e1)) * 271 | (1 + d5) + e10) * 272 | (((x + (1 / 32 * v + e21)) * (1 + d1) + e17 + (1 / 2048 * - x + e8)) * 273 | (1 + d11) + e4) * (1 + d8) + e13 + 274 | (((v + 275 | (1 / 64 * 276 | ((- x + 277 | - 278 | (((x + (1 / 32 * v + e23)) * (1 + d0) + e16 + 279 | (1 / 2048 * - x + e7)) * (1 + d10) + e3)) * 280 | (1 + d7) + e12) + e22)) * (1 + d2) + e18) * 281 | ((v + 282 | (1 / 64 * 283 | ((- x + 284 | - 285 | (((x + (1 / 32 * v + e9)) * (1 + d12) + e5 + 286 | (1 / 2048 * - x + e19)) * (1 + d4) + e24)) * 287 | (1 + d) + e15) + e6)) * (1 + d9) + e2) * 288 | (1 + d6) + e11)) * (1 + d13) + e0 - 289 | ((x + 1 / 32 * v + 1 / 2 * (1 / 32 * (1 / 32)) * - x) * 290 | (x + 1 / 32 * v + 1 / 2 * (1 / 32 * (1 / 32)) * - x) + 291 | (v + 292 | 1 / 2 * (1 / 32) * 293 | (- x + - (x + 1 / 32 * v + 1 / 2 * (1 / 32 * (1 / 32)) * - x))) * 294 | (v + 295 | 1 / 2 * (1 / 32) * 296 | (- x + - (x + 1 / 32 * v + 1 / 2 * (1 / 32 * (1 / 32)) * - x))))) <= 297 | 3e-6. 298 | Proof. 299 | intros. 300 | destruct true. 301 | - 302 | Time prune_terms (cutoff 30). 303 | (* before collapse_terms was added to the algorithm, this 304 | took about 1.8-2.0 sec. 305 | Now it takes 1.55-6.0 sec. *) 306 | 307 | (*Time match goal with |- Rabs ?a <= _ => field_simplify a end.*) 308 | match goal with |- Rabs ?t <= ?r => interval_intro (Rabs t) as H99 end; 309 | eapply Rle_trans; [ apply H99 | clear ]. 310 | simpl; compute; lra. 311 | - 312 | simple_reify. 313 | pose (nodes_and_terms e := (count_nodes e, count_terms e)). 314 | 315 | pose (counts0 := nodes_and_terms __expr); 316 | vm_compute in counts0; 317 | let e1 := constr:(ring_simp false 100 __expr) in 318 | let e1 := eval vm_compute in e1 in 319 | pose (counts1 := nodes_and_terms e1); 320 | vm_compute in counts1; 321 | let e2 := constr:(fst (prune (map b_hyps __hyps) e1 (cutoff 30))) in 322 | let e2 := eval vm_compute in e2 in 323 | pose (counts2 := nodes_and_terms e2); 324 | vm_compute in counts2; 325 | let e3 := constr:(cancel_terms e2) in 326 | let e3 := eval vm_compute in e3 in 327 | pose (counts3 := nodes_and_terms e3); 328 | vm_compute in counts3; 329 | let e4 := constr:(ring_simp true 100 e3) in 330 | let e4 := eval vm_compute in e4 in 331 | pose (counts4 := nodes_and_terms e4); 332 | vm_compute in counts4; 333 | pose (t3 := eval e3 __vars); 334 | pose (t4 := eval e4 __vars); 335 | cbv [eval nth nullary_real unary_real binary_real bpow' __vars] in t3, t4; 336 | exfalso; clear - t3 t4 counts0 counts1 counts2 counts3 counts4. 337 | Open Scope Z. 338 | 339 | (* 340 | counts0 := (242, 4) : Z * Z 341 | counts1 := (612284, 31759) : Z * Z 342 | counts2 := (1456, 244) : Z * Z 343 | counts3 := (289, 25) : Z * Z , before collapse_terms was added 344 | counts3 := (219, 24) : Z * Z with collapse_terms 345 | counts4 := (395, 46) : Z * Z 346 | *) 347 | Abort. 348 | 349 | 350 | 351 | 352 | -------------------------------------------------------------------------------- /Test/TestRefman.v: -------------------------------------------------------------------------------- 1 | (** TestRefman.v: examples from the reference manual. *) 2 | 3 | Require Import vcfloat.VCFloat. 4 | Require Import Interval.Tactic. 5 | Import Binary. 6 | Import Coq.Lists.List ListNotations. 7 | Set Bullet Behavior "Strict Subproofs". 8 | 9 | Open Scope R_scope. 10 | 11 | Section WITHNANS. 12 | Context {NANS: Nans}. 13 | 14 | 15 | Definition h := (1/32)%F32. 16 | Definition F(x: ftype Tsingle) : ftype Tsingle := (3.0-x)%F32. 17 | Definition step (x v: ftype Tsingle) := (x + h*(v+(h/2)*F(x)))%F32. 18 | 19 | Definition _x : ident := 1%positive. (* Variable name for position *) 20 | Definition _v : ident := 2%positive. (* Variable name for velocity *) 21 | 22 | Definition step' := ltac:(let e' := HO_reify_float_expr constr:([_x; _v]) step in exact e'). 23 | 24 | Definition step_vmap_list (x v : ftype Tsingle) := [(_x, existT ftype _ x);(_v, existT ftype _ v)]. 25 | 26 | (** Step two, build that into "varmap" data structure, taking care to 27 | compute it into a lookup-tree ___here___, not later in each place 28 | where we look something up. *) 29 | Definition step_vmap (x v : ftype Tsingle) : valmap := 30 | ltac:(let z := compute_PTree (valmap_of_list (step_vmap_list x v)) in exact z). 31 | 32 | (** Demonstration of reification and reflection. When you have a 33 | deep-embedded "expr"ession, you can get back the shallow embedding 34 | by applying the "fval" function *) 35 | 36 | Definition reflected_step (x v: ftype Tsingle) := 37 | fval (env_ (step_vmap x v)) step'. 38 | 39 | Lemma reflect_reify : forall x v, reflected_step x v = step x v. 40 | Proof. reflexivity. Qed. 41 | 42 | Definition step_realmodel' (x v: ftype Tsingle) : R := 43 | FT2R x + (1/32)*(FT2R v + ((1/32)/2)*(3- FT2R x)). 44 | 45 | 46 | Coercion FT2R: ftype >-> R. 47 | 48 | Definition step_realmodel (x v: ftype Tsingle) : R := 49 | x + (1/32)*(v + ((1/32)/2)*(3-x)). 50 | 51 | Lemma correspond_floatmodel_realmodel: 52 | forall x v, rval (env_ (step_vmap x v)) step' = step_realmodel x v. 53 | Proof. intros. 54 | unfold step_realmodel. 55 | simpl. 56 | repeat f_equal; compute; lra. 57 | Qed. 58 | 59 | (** To create the boundsmap, first we make an association list. This one says 60 | that 2.0 <= x <= 4.0 and -2.0 <= v <= 2.0 *) 61 | Definition step_bmap_list : list varinfo := 62 | [ Build_varinfo Tsingle _x 2 4 ; Build_varinfo Tsingle _v (-2) 2 ]. 63 | 64 | (** Then we calculate an efficient lookup table, the "boundsmap". *) 65 | Definition step_bmap : boundsmap := 66 | ltac:(let z := compute_PTree (boundsmap_of_list step_bmap_list) in exact z). 67 | 68 | (** Now we prove that the leapfrogx expression (deep-embedded as x' ) 69 | has a roundoff error less than 1.0e-5 *) 70 | Lemma prove_roundoff_bound_step: 71 | forall vmap, 72 | prove_roundoff_bound step_bmap vmap step' (/ 4000000). 73 | Proof. 74 | intros. 75 | prove_roundoff_bound. 76 | - 77 | prove_rndval. 78 | all: interval. 79 | - 80 | prove_roundoff_bound2. 81 | prune_terms (cutoff 30). 82 | do_interval. 83 | Qed. 84 | 85 | (* The next part demonstrates that you don't have to guess the 86 | upper bound in advance, to use the tool. *) 87 | Definition find_and_prove_roundoff_bound (bmap: boundsmap) (e: expr) := 88 | {bound: R | forall vmap, prove_roundoff_bound bmap vmap e bound}. 89 | 90 | (* This proof returns a pair, 91 | {bound | proof that it really is a bound for step } 92 | where "bound" is a simple real-valued expression with only constants. *) 93 | Derive step_b 94 | SuchThat (forall vmap, prove_roundoff_bound step_bmap vmap step' step_b) 95 | As prove_step_bound. 96 | Proof. 97 | subst step_b. 98 | intro. 99 | prove_roundoff_bound. 100 | - 101 | prove_rndval; interval. 102 | - 103 | prove_roundoff_bound2. 104 | prune_terms (cutoff 30). 105 | do_interval. 106 | Qed. 107 | 108 | (* Let's calculate the floating-point representation of the bound. *) 109 | Check ltac:(ShowBound step_b). 110 | 111 | (* We claimed that the roundoff error is less than 1/4000000; let's check! *) 112 | Lemma bound_less_than_one_over_four_million: step_b <= 1 / 4000000. 113 | Proof. compute; lra. Qed. 114 | 115 | (* Let's make sure that we really have a proof that 116 | this is a bound on the roundoff error of the step function *) 117 | Check prove_step_bound. 118 | 119 | End WITHNANS. 120 | 121 | (* Below are tests of the "prune_terms" tactic and various steps 122 | of the algorithm *) 123 | 124 | Lemma test1: 125 | forall 126 | (x v e0 d e1 e2 d0 e3 : R) 127 | (BOUND : -2 <= v <= 2) 128 | (BOUND0 : -2 <= x <= 2) 129 | (E : Rabs e0 <= / 713623846352979940529142984724747568191373312) 130 | (E0 : Rabs d <= / 16777216) 131 | (E1 : Rabs e1 <= / 1427247692705959881058285969449495136382746624) 132 | (E2 : Rabs e2 <= / 713623846352979940529142984724747568191373312) 133 | (E3 : Rabs d0 <= / 16777216) 134 | (E4 : Rabs e3 <= / 1427247692705959881058285969449495136382746624), 135 | Rabs 136 | (((x + (1 / 32 * v + e2)) * (1 + d) + e3 + (1 / 2048 * - x + e0)) * 137 | (1 + d0) + e1 - (x + 1 / 32 * v + 1 / 2 * (1 / 32 * (1 / 32)) * - x)) <= 138 | 2.46e-7. 139 | Proof. 140 | intros. 141 | prune_terms (cutoff 30). 142 | (*match goal with |- Rabs ?a <= _ => field_simplify a end.*) 143 | match goal with |- Rabs ?t <= ?r => interval_intro (Rabs t) as H99 end. 144 | eapply Rle_trans; [ apply H99 | clear ]. 145 | compute; lra. 146 | Qed. 147 | 148 | Import Tree. 149 | 150 | Lemma test1_double_precision: 151 | forall 152 | (x v e0 d e1 e2 d0 e3 : R) 153 | (BOUND : -2 <= v <= 2) 154 | (BOUND0 : -2 <= x <= 2) 155 | (E : Rabs e0 <= / bpow' 2 298) 156 | (E0 : Rabs d <= / bpow' 2 48) 157 | (E1 : Rabs e1 <= / bpow' 2 300) 158 | (E2 : Rabs e2 <= / bpow' 2 298) 159 | (E3 : Rabs d0 <= / bpow' 2 48) 160 | (E4 : Rabs e3 <= / bpow' 2 298), 161 | Rabs 162 | (((x + (1 / 32 * v + e2)) * (1 + d) + e3 + (1 / 2048 * - x + e0)) * 163 | (1 + d0) + e1 - (x + 1 / 32 * v + 1 / 2 * (1 / 32 * (1 / 32)) * - x)) <= 164 | 2.46e-7. 165 | Proof. 166 | intros. 167 | prune_terms (cutoff 60). 168 | (*match goal with |- Rabs ?a <= _ => field_simplify a end.*) 169 | match goal with |- Rabs ?t <= ?r => interval_intro (Rabs t) as H99 end. 170 | eapply Rle_trans; [ apply H99 | clear ]. 171 | compute; lra. 172 | Qed. 173 | 174 | Lemma test3: forall 175 | (x v d1 d2 e0 e1 e3 : R) 176 | (BOUND : -2 <= v <= 2) 177 | (BOUND0 : 2 <= x <= 4) 178 | (E : Rabs d1 <= / 16777216) 179 | (E0 : Rabs d2 <= / 16777216) 180 | (E1 : Rabs e0 <= / 713623846352979940529142984724747568191373312) 181 | (E2 : Rabs e1 <= / 1427247692705959881058285969449495136382746624) 182 | (E3 : Rabs e3 <= / 713623846352979940529142984724747568191373312), 183 | Rabs 184 | (((x + (1 / 32 * v + e0)) * (1 + d2) + (1 / 2048 * (3 - x) + e3)) * 185 | (1 + d1) + e1 - 186 | (x + 1 / 32 * v + 1 / 2 * (1 / 32 * (1 / 32)) * (3 - x))) <= 187 | / 2000000. 188 | Proof. 189 | intros. 190 | prune_terms (cutoff 30). 191 | match goal with |- Rabs ?t <= ?r => interval_intro (Rabs t) as H99 end. 192 | eapply Rle_trans; [ apply H99 | clear ]. 193 | simpl; compute; lra. 194 | Qed. 195 | 196 | 197 | Lemma test3_alt: forall 198 | (x v d1 d2 e0 e1 e3 : R) 199 | (BOUND : -2 <= v <= 2) 200 | (BOUND0 : 2 <= x <= 4) 201 | (E : Rabs e0 <= / 713623846352979940529142984724747568191373312) 202 | (E0 : Rabs d1 <= / 16777216) 203 | (E1 : Rabs e1 <= / 713623846352979940529142984724747568191373312) 204 | (E2 : Rabs d2 <= / 16777216) 205 | (E3 : Rabs e3 <= / 1427247692705959881058285969449495136382746624), 206 | Rabs 207 | ((x + (1 / 32 * ((v + (1 / 64 * (3 - x) + e1)) * (1 + d1) + e3) + e0)) * 208 | (1 + d2) - (x + 1 / 32 * (v + 1 / 32 / 2 * (3 - x)))) <= 209 | 1/4000000. 210 | Proof. 211 | intros. 212 | prune_terms (cutoff 30). 213 | match goal with |- Rabs ?t <= ?r => interval_intro (Rabs t) as H99 end. 214 | eapply Rle_trans; [ apply H99 | clear ]. 215 | compute; simpl; lra. 216 | Qed. 217 | 218 | Lemma test2: 219 | forall 220 | (d d0 d1 e0 d2 e1 e2 e3 e4 e5 d3 e6 e7 e8 e9 e10 e11 e12 e13 d4 e14 221 | e15 e16 e17 e18 d5 d6 d7 d8 e19 e20 d9 d10 d11 d12 e21 d13 e22 e23 e24 222 | x v : R) 223 | (BOUND : (-2) <= v <= 2) 224 | (BOUND0 : (-2) <= x <= 2) 225 | (E : (Rabs d) <= (/ 16777216)) 226 | ( E0 : (Rabs d0) <= (/ 16777216)) 227 | ( E1 : (Rabs d1) <= (/ 16777216)) 228 | ( E2 : (Rabs e0) <= (/ 1427247692705959881058285969449495136382746624)) 229 | (E3 : (Rabs d2) <= (/ 16777216)) 230 | (E4 : (Rabs e1) <= (/ 713623846352979940529142984724747568191373312)) 231 | ( E5 : (Rabs e2) <= (/ 1427247692705959881058285969449495136382746624)) 232 | ( E6 : (Rabs e3) <= (/ 1427247692705959881058285969449495136382746624)) 233 | ( E7 : (Rabs e4) <= (/ 1427247692705959881058285969449495136382746624)) 234 | ( E8 : (Rabs e5) <= (/ 1427247692705959881058285969449495136382746624)) 235 | ( E9 : (Rabs d3) <= (/ 16777216)) 236 | ( E10 : (Rabs e6) <= (/ 713623846352979940529142984724747568191373312)) 237 | ( E11 : (Rabs e7) <= (/ 713623846352979940529142984724747568191373312)) 238 | ( E12 : (Rabs e8) <= (/ 713623846352979940529142984724747568191373312)) 239 | ( E13 : (Rabs e9) <= (/ 713623846352979940529142984724747568191373312)) 240 | ( E14 : (Rabs e10) <= (/ 1427247692705959881058285969449495136382746624)) 241 | ( E15 : (Rabs e11) <= (/ 1427247692705959881058285969449495136382746624)) 242 | ( E16 : (Rabs e12) <= (/ 1427247692705959881058285969449495136382746624)) 243 | ( E17 : (Rabs e13) <= (/ 1427247692705959881058285969449495136382746624)) 244 | ( E18 : (Rabs d4) <= (/ 16777216)) 245 | ( E19 : (Rabs e14) <= (/ 713623846352979940529142984724747568191373312)) 246 | ( E20 : (Rabs e15) <= (/ 1427247692705959881058285969449495136382746624)) 247 | (E21 : (Rabs e16) <= (/ 1427247692705959881058285969449495136382746624) ) 248 | ( E22 : (Rabs e17) <= (/ 1427247692705959881058285969449495136382746624)) 249 | ( E23 : (Rabs e18) <= (/ 1427247692705959881058285969449495136382746624)) 250 | ( E24 : (Rabs d5) <= (/ 16777216)) 251 | (E25 : (Rabs d6) <= (/ 16777216)) 252 | (E26 : (Rabs d7) <= (/ 16777216)) 253 | (E27 : (Rabs d8) <= (/ 16777216)) 254 | (E28 : (Rabs e19) <= (/ 713623846352979940529142984724747568191373312)) 255 | (E29 : (Rabs e20) <= (/ 1427247692705959881058285969449495136382746624)) 256 | (E30 : (Rabs d9) <= (/ 16777216)) 257 | (E31 : (Rabs d10) <= (/ 16777216)) 258 | (E32 : (Rabs d11) <= (/ 16777216)) 259 | (E33 : (Rabs d12) <= (/ 16777216)) 260 | (E34 : (Rabs e21) <= (/ 713623846352979940529142984724747568191373312)) 261 | (E35 : (Rabs d13) <= (/ 16777216)) 262 | (E36 : (Rabs e22) <= (/ 713623846352979940529142984724747568191373312)) 263 | (E37 : (Rabs e23) <= (/ 713623846352979940529142984724747568191373312)) 264 | (E38 : (Rabs e24) <= (/ 1427247692705959881058285969449495136382746624)), 265 | Rabs 266 | (((((x + (1 / 32 * v + e14)) * (1 + d3) + e20 + (1 / 2048 * - x + e1)) * 267 | (1 + d5) + e10) * 268 | (((x + (1 / 32 * v + e21)) * (1 + d1) + e17 + (1 / 2048 * - x + e8)) * 269 | (1 + d11) + e4) * (1 + d8) + e13 + 270 | (((v + 271 | (1 / 64 * 272 | ((- x + 273 | - 274 | (((x + (1 / 32 * v + e23)) * (1 + d0) + e16 + 275 | (1 / 2048 * - x + e7)) * (1 + d10) + e3)) * 276 | (1 + d7) + e12) + e22)) * (1 + d2) + e18) * 277 | ((v + 278 | (1 / 64 * 279 | ((- x + 280 | - 281 | (((x + (1 / 32 * v + e9)) * (1 + d12) + e5 + 282 | (1 / 2048 * - x + e19)) * (1 + d4) + e24)) * 283 | (1 + d) + e15) + e6)) * (1 + d9) + e2) * 284 | (1 + d6) + e11)) * (1 + d13) + e0 - 285 | ((x + 1 / 32 * v + 1 / 2 * (1 / 32 * (1 / 32)) * - x) * 286 | (x + 1 / 32 * v + 1 / 2 * (1 / 32 * (1 / 32)) * - x) + 287 | (v + 288 | 1 / 2 * (1 / 32) * 289 | (- x + - (x + 1 / 32 * v + 1 / 2 * (1 / 32 * (1 / 32)) * - x))) * 290 | (v + 291 | 1 / 2 * (1 / 32) * 292 | (- x + - (x + 1 / 32 * v + 1 / 2 * (1 / 32 * (1 / 32)) * - x))))) <= 293 | 3e-6. 294 | Proof. 295 | intros. 296 | destruct true. 297 | - 298 | Time prune_terms (cutoff 30). 299 | (* before collapse_terms was added to the algorithm, this 300 | took about 1.8-2.0 sec. 301 | Now it takes 1.55-6.0 sec. *) 302 | 303 | (*Time match goal with |- Rabs ?a <= _ => field_simplify a end.*) 304 | match goal with |- Rabs ?t <= ?r => interval_intro (Rabs t) as H99 end; 305 | eapply Rle_trans; [ apply H99 | clear ]. 306 | simpl; compute; lra. 307 | - 308 | simple_reify. 309 | pose (nodes_and_terms e := (count_nodes e, count_terms e)). 310 | 311 | pose (counts0 := nodes_and_terms __expr); 312 | vm_compute in counts0; 313 | let e1 := constr:(ring_simp false 100 __expr) in 314 | let e1 := eval vm_compute in e1 in 315 | pose (counts1 := nodes_and_terms e1); 316 | vm_compute in counts1; 317 | let e2 := constr:(fst (prune (map b_hyps __hyps) e1 (cutoff 30))) in 318 | let e2 := eval vm_compute in e2 in 319 | pose (counts2 := nodes_and_terms e2); 320 | vm_compute in counts2; 321 | let e3 := constr:(cancel_terms e2) in 322 | let e3 := eval vm_compute in e3 in 323 | pose (counts3 := nodes_and_terms e3); 324 | vm_compute in counts3; 325 | let e4 := constr:(ring_simp true 100 e3) in 326 | let e4 := eval vm_compute in e4 in 327 | pose (counts4 := nodes_and_terms e4); 328 | vm_compute in counts4; 329 | pose (t3 := eval e3 __vars); 330 | pose (t4 := eval e4 __vars); 331 | cbv [eval nth nullary_real unary_real binary_real bpow' __vars] in t3, t4; 332 | exfalso; clear - t3 t4 counts0 counts1 counts2 counts3 counts4. 333 | Open Scope Z. 334 | 335 | (* 336 | counts0 := (242, 4) : Z * Z 337 | counts1 := (612284, 31759) : Z * Z 338 | counts2 := (1456, 244) : Z * Z 339 | counts3 := (289, 25) : Z * Z , before collapse_terms was added 340 | counts3 := (219, 24) : Z * Z with collapse_terms 341 | counts4 := (395, 46) : Z * Z 342 | *) 343 | Abort. 344 | 345 | 346 | 347 | 348 | -------------------------------------------------------------------------------- /Test/_CoqProject: -------------------------------------------------------------------------------- 1 | -Q ../vcfloat vcfloat 2 | -------------------------------------------------------------------------------- /Test/autobisect.v: -------------------------------------------------------------------------------- 1 | Require Import vcfloat.VCFloat. 2 | Require Import Interval.Tactic. 3 | Import Binary Coq.Lists.List ListNotations. 4 | Set Bullet Behavior "Strict Subproofs". 5 | Section WITHNANS. 6 | Context {NANS:Nans}. 7 | Open Scope R_scope. 8 | 9 | Definition turbine1_bmap_list := [Build_varinfo Tdouble 1%positive (-45e-1) (-3e-1);Build_varinfo Tdouble 2%positive (4e-1) (9e-1);Build_varinfo Tdouble 3%positive (38e-1) (78e-1)]. 10 | 11 | Definition turbine1_bmap := 12 | ltac:(let z := compute_PTree (boundsmap_of_list turbine1_bmap_list) in exact z). 13 | 14 | Definition turbine1 (v : ftype Tdouble) (w : ftype Tdouble) (r : ftype Tdouble) := 15 | cast Tdouble (((((3)%F64 + ((2)%F64 / (r * r)%F64)%F64)%F64 - ((((125e-3)%F64 * ((3)%F64 - ((2)%F64 * v)%F64)%F64)%F64 * (((w * w)%F64 * r)%F64 * r)%F64)%F64 / ((1)%F64 - v)%F64)%F64)%F64 - (45e-1)%F64)%F64). 16 | 17 | Definition turbine1_expr := 18 | ltac:(let e' := HO_reify_float_expr constr:([1%positive;2%positive;3%positive]) turbine1 in exact e'). 19 | 20 | Derive a 21 | SuchThat 22 | (forall (v0 e2 d7 : R) 23 | (H : 38 / 10 <= v0 <= 78 / 10) 24 | (H0 : Rabs d7 <= / 9007199254740992) 25 | (H1 : Rabs e2 <= 26 | / 27 | 404804506614621236704990693437834614099113299528284236713802716054860679135990693783920767402874248990374155728633623822779617474771586953734026799881477019843034848553132722728933815484186432682479535356945490137124014966849385397236206711298319112681620113024717539104666829230461005064372655017292012526615415482186989568), 28 | Rabs (v0 ^ 2 / (v0 ^ 2 * d7 + v0 ^ 2 + e2)) <= a - 0) 29 | As a_proof. 30 | Proof. 31 | intros. 32 | subst a. 33 | match goal with |- Rabs ?a <= _ => 34 | let G := fresh "G" in 35 | bisect_all_vars constr:(Rabs a) (@nil interval_tac_parameters); intro G; 36 | eapply Rle_trans; 37 | [apply G | apply Rminus_plus_le_minus; apply Rle_refl] 38 | end. 39 | Qed. 40 | 41 | 42 | Derive turbine1_b 43 | SuchThat (forall vmap, prove_roundoff_bound turbine1_bmap vmap turbine1_expr turbine1_b) 44 | As turbine1_bound. 45 | Proof. 46 | idtac "Starting turbine1". 47 | intro. 48 | prove_roundoff_bound. 49 | - 50 | clear. 51 | time abstract (prove_rndval; interval). 52 | - 53 | time "prove_roundoff_bound2" prove_roundoff_bound2. 54 | time "error_rewrites" error_rewrites. 55 | all: time "prune_terms" prune_terms (cutoff 70); unfold Rsqr. 56 | all: time "interval1" 57 | try match goal with |- (Rabs ?e <= ?a - ?b)%R => 58 | let G := fresh "G" in 59 | interval_intro (Rabs e) as G ; 60 | eapply Rle_trans; 61 | [apply G | apply Rminus_plus_le_minus; apply Rle_refl] 62 | end. 63 | all: time "field_simplify" field_simplify_Rabs. 64 | all: time "interval2" 65 | match goal with |- Rabs ?a <= _ => 66 | let G := fresh "G" in 67 | bisect_all_vars constr:(Rabs a) [i_depth 15]; intro G; 68 | eapply Rle_trans; 69 | [apply G | apply Rminus_plus_le_minus; apply Rle_refl] 70 | end. 71 | Time Qed. 72 | 73 | 74 | Lemma check_turbine1_bound: ltac:(CheckBound turbine1_b 7.9e-14%F64). 75 | Proof. reflexivity. Qed. 76 | 77 | End WITHNANS. 78 | Close Scope R_scope. -------------------------------------------------------------------------------- /coq-vcfloat.opam: -------------------------------------------------------------------------------- 1 | # the _real_ opam file for coq-vcfloat is at [adjusted for version number] 2 | # https://github.com/coq/opam-coq-archive/blob/master/released/packages/coq-vcfloat/coq-vcfloat.2.1.1/opam 3 | opam-version: "2.0" 4 | synopsis: "VCFloat: Floating Point Round-off Error Analysis" 5 | description: "VCFloat is a tool for Coq proofs about floating-point round-off error." 6 | authors: [ 7 | "Andrew W. Appel" 8 | "Ariel E. Kellison" 9 | "Tahina Ramananandro" 10 | "Paul Mountcastle" 11 | "Benoit Meister" 12 | "Richard Lethin" 13 | ] 14 | homepage: "https://verinum.org/vcfloat/" 15 | maintainer: "Andrew W. Appel " 16 | dev-repo: "git+https://github.com/VeriNum/vcfloat" 17 | bug-reports: "https://github.com/VeriNum/vcfloat/issues" 18 | license: "LGPL-3.0-or-later" 19 | 20 | build: [ 21 | [ make "-C" "vcfloat" "-j%{jobs}%" "vcfloat2" "COQEXTRAFLAGS=-native-compiler ondemand" {coq-native:installed & coq-compcert:version < "3.13~"}] 22 | ] 23 | install: [ 24 | [make "-C" "vcfloat" "-j%{jobs}%" "install" "INSTALLDIR=%{lib}%/coq/user-contrib/vcfloat" "COQEXTRAFLAGS=-native-compiler ondemand" {coq-native:installed & coq-compcert:version < "3.13~"}] 25 | ] 26 | run-test: [ 27 | [make "-C" "vcfloat" "-j%{jobs}%" "tests" "COQEXTRAFLAGS=-native-compiler ondemand" {coq-native:installed & coq-compcert:version < "3.13~"}] 28 | ] 29 | depends: [ 30 | "coq" {(>= "8.16" & < "8.19~") | = "dev"} 31 | "coq-flocq" {>= "4.1.1" & < "5.0"} 32 | "coq-interval" {>= "4.8.0"} 33 | "coq-compcert" {>= "3.12"} 34 | "coq-bignums" 35 | ] 36 | tags: [ 37 | "date:2023-08-31" 38 | "keyword:decision procedure" 39 | "keyword:floating-point arithmetic" 40 | "category:Computer Science/Decision Procedures and Certified Algorithms/Decision procedures" 41 | "logpath:VCFloat" 42 | ] 43 | -------------------------------------------------------------------------------- /doc/VCFloat-Manual.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/VeriNum/vcfloat/407b6588806904688b264b65fd05aa233d8fbd95/doc/VCFloat-Manual.pdf -------------------------------------------------------------------------------- /doc/lstlangcoq.sty: -------------------------------------------------------------------------------- 1 | %% 2 | %% Coq definition (c) 2001 Guillaume Dufay 3 | %% 4 | %% with some modifications by J. Charles (2005) 5 | %% and hacks by Andrew Appel (2011) 6 | %% 7 | \lstdefinelanguage{Coq}% 8 | {morekeywords={Variable,Inductive,CoInductive,Fixpoint,CoFixpoint,% 9 | Definition,Lemma,Theorem,Axiom,Local,Save,Grammar,Syntax,Intro,% 10 | Trivial,Qed,Intros,Symmetry,Simpl,Rewrite,Apply,Elim,Assumption,% 11 | Left,Cut,Case,Auto,Unfold,Exact,Right,Hypothesis,Pattern,Destruct,% 12 | Constructor,Defined,Fix,Record,Proof,Induction,Hints,Exists,let,in,% 13 | Parameter,Split,Red,Reflexivity,Transitivity,if,then,else,Opaque,% 14 | Transparent,Inversion,Absurd,Generalize,Mutual,Cases,of,end,Analyze,% 15 | AutoRewrite,Functional,Scheme,params,Refine,using,Discriminate,Try,% 16 | Require,Load,Import,Scope,Set,Open,Section,End,match,with,Ltac, %, exists, forall 17 | Declare,Instance 18 | },% 19 | sensitive, % 20 | morecomment=[n]{(*}{*)},% 21 | morestring=[d]",% 22 | literate={=>}{{$\Rightarrow$\ }}1 {>->}{{$\rightarrowtail$}}2{->}{{$\to$\ }}1 23 | {<->}{$\leftrightarrow$}1 24 | {forall}{$\forall\,$}1 25 | {forallb}{forallb}7 26 | {exists}{$\exists\,$}1 27 | {existsb}{existsb}7 28 | {existsv}{existsv}7 29 | {\/\\}{{$\wedge$\ }}1 30 | {|-}{{$\vdash$\ }}1 31 | {-*}{{$\wand$\ }}1 32 | {\\\/}{{$\vee$\ }}1 33 | {~}{{$\sim$}}1 34 | %{<>}{{$\neq$}}1 indeed... no. 35 | }[keywords,comments,strings]% 36 | -------------------------------------------------------------------------------- /doc/vcfloat2.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/VeriNum/vcfloat/407b6588806904688b264b65fd05aa233d8fbd95/doc/vcfloat2.pdf -------------------------------------------------------------------------------- /vcfloat/.depend: -------------------------------------------------------------------------------- 1 | Automate.vo Automate.glob Automate.v.beautified Automate.required_vo: Automate.v FPLang.vo FPLangOpt.vo RAux.vo Rounding.vo Reify.vo Float_notations.vo compute_tactics_ltac2.vo 2 | Automate.vio: Automate.v FPLang.vio FPLangOpt.vio RAux.vio Rounding.vio Reify.vio Float_notations.vio compute_tactics_ltac2.vio 3 | Base.vo Base.glob Base.v.beautified Base.required_vo: Base.v IEEE754_extra.vo klist.vo Float_notations.vo 4 | Base.vio: Base.v IEEE754_extra.vio klist.vio Float_notations.vio 5 | BigQAux.vo BigQAux.glob BigQAux.v.beautified BigQAux.required_vo: BigQAux.v 6 | BigQAux.vio: BigQAux.v 7 | BigRAux.vo BigRAux.glob BigRAux.v.beautified BigRAux.required_vo: BigRAux.v BigQAux.vo Q2RAux.vo 8 | BigRAux.vio: BigRAux.v BigQAux.vio Q2RAux.vio 9 | FMap_lemmas.vo FMap_lemmas.glob FMap_lemmas.v.beautified FMap_lemmas.required_vo: FMap_lemmas.v 10 | FMap_lemmas.vio: FMap_lemmas.v 11 | FPCompCert.vo FPCompCert.glob FPCompCert.v.beautified FPCompCert.required_vo: FPCompCert.v FPCore.vo 12 | FPCompCert.vio: FPCompCert.v FPCore.vio 13 | FPCore.vo FPCore.glob FPCore.v.beautified FPCore.required_vo: FPCore.v IEEE754_extra.vo klist.vo Float_notations.vo Base.vo 14 | FPCore.vio: FPCore.v IEEE754_extra.vio klist.vio Float_notations.vio Base.vio 15 | FPLang.vo FPLang.glob FPLang.v.beautified FPLang.required_vo: FPLang.v RAux.vo IEEE754_extra.vo Fprop_absolute.vo Float_lemmas.vo FPCore.vo klist.vo 16 | FPLang.vio: FPLang.v RAux.vio IEEE754_extra.vio Fprop_absolute.vio Float_lemmas.vio FPCore.vio klist.vio 17 | FPLangOpt.vo FPLangOpt.glob FPLangOpt.v.beautified FPLangOpt.required_vo: FPLangOpt.v Float_lemmas.vo FPLang.vo klist.vo LibTac.vo BigRAux.vo 18 | FPLangOpt.vio: FPLangOpt.v Float_lemmas.vio FPLang.vio klist.vio LibTac.vio BigRAux.vio 19 | FPLib.vo FPLib.glob FPLib.v.beautified FPLib.required_vo: FPLib.v FPCore.vo RAux.vo Float_notations.vo 20 | FPLib.vio: FPLib.v FPCore.vio RAux.vio Float_notations.vio 21 | FPStdCompCert.vo FPStdCompCert.glob FPStdCompCert.v.beautified FPStdCompCert.required_vo: FPStdCompCert.v FPStdLib.vo FPCompCert.vo 22 | FPStdCompCert.vio: FPStdCompCert.v FPStdLib.vio FPCompCert.vio 23 | FPStdLib.vo FPStdLib.glob FPStdLib.v.beautified FPStdLib.required_vo: FPStdLib.v IEEE754_extra.vo klist.vo Float_notations.vo Base.vo FPCore.vo RAux.vo Rounding.vo 24 | FPStdLib.vio: FPStdLib.v IEEE754_extra.vio klist.vio Float_notations.vio Base.vio FPCore.vio RAux.vio Rounding.vio 25 | Float_lemmas.vo Float_lemmas.glob Float_lemmas.v.beautified Float_lemmas.required_vo: Float_lemmas.v RAux.vo IEEE754_extra.vo Fprop_absolute.vo FPCore.vo 26 | Float_lemmas.vio: Float_lemmas.v RAux.vio IEEE754_extra.vio Fprop_absolute.vio FPCore.vio 27 | Float_notations.vo Float_notations.glob Float_notations.v.beautified Float_notations.required_vo: Float_notations.v IEEE754_extra.vo 28 | Float_notations.vio: Float_notations.v IEEE754_extra.vio 29 | Fprop_absolute.vo Fprop_absolute.glob Fprop_absolute.v.beautified Fprop_absolute.required_vo: Fprop_absolute.v 30 | Fprop_absolute.vio: Fprop_absolute.v 31 | IEEE754_extra.vo IEEE754_extra.glob IEEE754_extra.v.beautified IEEE754_extra.required_vo: IEEE754_extra.v 32 | IEEE754_extra.vio: IEEE754_extra.v 33 | LibTac.vo LibTac.glob LibTac.v.beautified LibTac.required_vo: LibTac.v RAux.vo 34 | LibTac.vio: LibTac.v RAux.vio 35 | Prune.vo Prune.glob Prune.v.beautified Prune.required_vo: Prune.v FMap_lemmas.vo 36 | Prune.vio: Prune.v FMap_lemmas.vio 37 | Q2RAux.vo Q2RAux.glob Q2RAux.v.beautified Q2RAux.required_vo: Q2RAux.v 38 | Q2RAux.vio: Q2RAux.v 39 | RAux.vo RAux.glob RAux.v.beautified RAux.required_vo: RAux.v 40 | RAux.vio: RAux.v 41 | Reify.vo Reify.glob Reify.v.beautified Reify.required_vo: Reify.v RAux.vo IEEE754_extra.vo klist.vo Fprop_absolute.vo Float_lemmas.vo FPCore.vo FPLang.vo Float_notations.vo 42 | Reify.vio: Reify.v RAux.vio IEEE754_extra.vio klist.vio Fprop_absolute.vio Float_lemmas.vio FPCore.vio FPLang.vio Float_notations.vio 43 | Rounding.vo Rounding.glob Rounding.v.beautified Rounding.required_vo: Rounding.v RAux.vo IEEE754_extra.vo Fprop_absolute.vo Float_lemmas.vo FPCore.vo FPLang.vo klist.vo 44 | Rounding.vio: Rounding.v RAux.vio IEEE754_extra.vio Fprop_absolute.vio Float_lemmas.vio FPCore.vio FPLang.vio klist.vio 45 | Summation.vo Summation.glob Summation.v.beautified Summation.required_vo: Summation.v 46 | Summation.vio: Summation.v 47 | VCFloat.vo VCFloat.glob VCFloat.v.beautified VCFloat.required_vo: VCFloat.v klist.vo FPLang.vo FPLangOpt.vo RAux.vo Rounding.vo Reify.vo Float_notations.vo Automate.vo Prune.vo Float_notations.vo 48 | VCFloat.vio: VCFloat.v klist.vio FPLang.vio FPLangOpt.vio RAux.vio Rounding.vio Reify.vio Float_notations.vio Automate.vio Prune.vio Float_notations.vio 49 | Version.vo Version.glob Version.v.beautified Version.required_vo: Version.v 50 | Version.vio: Version.v 51 | compute_tactics_ltac2.vo compute_tactics_ltac2.glob compute_tactics_ltac2.v.beautified compute_tactics_ltac2.required_vo: compute_tactics_ltac2.v 52 | compute_tactics_ltac2.vio: compute_tactics_ltac2.v 53 | klist.vo klist.glob klist.v.beautified klist.required_vo: klist.v 54 | klist.vio: klist.v 55 | ../Test/Nonstd.vo ../Test/Nonstd.glob ../Test/Nonstd.v.beautified ../Test/Nonstd.required_vo: ../Test/Nonstd.v VCFloat.vo 56 | ../Test/Nonstd.vio: ../Test/Nonstd.v VCFloat.vio 57 | ../Test/Test.vo ../Test/Test.glob ../Test/Test.v.beautified ../Test/Test.required_vo: ../Test/Test.v VCFloat.vo 58 | ../Test/Test.vio: ../Test/Test.v VCFloat.vio 59 | ../Test/Test2.vo ../Test/Test2.glob ../Test/Test2.v.beautified ../Test/Test2.required_vo: ../Test/Test2.v VCFloat.vo 60 | ../Test/Test2.vio: ../Test/Test2.v VCFloat.vio 61 | ../Test/TestFunc.vo ../Test/TestFunc.glob ../Test/TestFunc.v.beautified ../Test/TestFunc.required_vo: ../Test/TestFunc.v VCFloat.vo 62 | ../Test/TestFunc.vio: ../Test/TestFunc.v VCFloat.vio 63 | ../Test/TestPaper.vo ../Test/TestPaper.glob ../Test/TestPaper.v.beautified ../Test/TestPaper.required_vo: ../Test/TestPaper.v VCFloat.vo 64 | ../Test/TestPaper.vio: ../Test/TestPaper.v VCFloat.vio 65 | ../Test/TestRefman.vo ../Test/TestRefman.glob ../Test/TestRefman.v.beautified ../Test/TestRefman.required_vo: ../Test/TestRefman.v VCFloat.vo 66 | ../Test/TestRefman.vio: ../Test/TestRefman.v VCFloat.vio 67 | ../Test/autobisect.vo ../Test/autobisect.glob ../Test/autobisect.v.beautified ../Test/autobisect.required_vo: ../Test/autobisect.v VCFloat.vo 68 | ../Test/autobisect.vio: ../Test/autobisect.v VCFloat.vio 69 | ../Test/summation.vo ../Test/summation.glob ../Test/summation.v.beautified ../Test/summation.required_vo: ../Test/summation.v IEEE754_extra.vo VCFloat.vo 70 | ../Test/summation.vio: ../Test/summation.v IEEE754_extra.vio VCFloat.vio 71 | -------------------------------------------------------------------------------- /vcfloat/Base.v: -------------------------------------------------------------------------------- 1 | Require Import ZArith Lia Reals Coq.Lists.List. 2 | From Flocq Require Import Binary Bits Core. 3 | From vcfloat Require Import IEEE754_extra klist Float_notations. 4 | 5 | 6 | Definition ZLT a b: Prop := Bool.Is_true (Z.ltb a b). 7 | 8 | Lemma ZLT_intro a b: 9 | (a < b)%Z -> 10 | ZLT a b. 11 | Proof. 12 | intros. 13 | unfold ZLT, Bool.Is_true, Z.lt, Z.ltb in *. 14 | rewrite H. 15 | apply I. 16 | Defined. 17 | 18 | Lemma ZLT_elim a b: 19 | ZLT a b -> 20 | (a < b)%Z. 21 | Proof. 22 | intros. 23 | unfold ZLT, Bool.Is_true, Z.lt, Z.ltb in *. 24 | destruct (Z.compare a b); auto; contradiction. 25 | Defined. 26 | 27 | Lemma Is_true_eq a (h1 h2: Bool.Is_true a): 28 | h1 = h2. 29 | Proof. 30 | destruct a; try contradiction. 31 | unfold Bool.Is_true in h1, h2. 32 | destruct h1. destruct h2. reflexivity. 33 | Defined. 34 | 35 | 36 | Definition extend_comp (c: comparison) (b: bool) (d: option comparison) := 37 | match d with 38 | | None => false 39 | | Some c' => 40 | match c, b, c' with 41 | | Gt, true, Gt => true 42 | | Gt, false, Lt => true 43 | | Gt, false, Eq => true 44 | | Eq, true, Eq => true 45 | | Eq, false, Gt => true 46 | | Eq, false, Lt => true 47 | | Lt, true, Lt => true 48 | | Lt, false, Gt => true 49 | | Lt, false, Eq => true 50 | | _, _, _ => false 51 | end 52 | end. 53 | 54 | Definition nan_payload prec emax : Type := 55 | {x : binary_float prec emax | Binary.is_nan prec emax x = true}. 56 | 57 | Import Bool. 58 | 59 | Definition nan_pl_eqb {prec1 emax1 prec2 emax2} 60 | (n1: nan_payload prec1 emax1) (n2: nan_payload prec2 emax2) := 61 | match proj1_sig n1, proj1_sig n2 with 62 | | B754_nan _ _ b1 pl1 _, B754_nan _ _ b2 pl2 _ => Bool.eqb b1 b2 && Pos.eqb pl1 pl2 63 | | _, _ => true 64 | end. 65 | 66 | Definition nan_pl_eqb' {prec1 emax1 prec2 emax2} 67 | (n1: nan_payload prec1 emax1) (n2: nan_payload prec2 emax2) : bool. 68 | destruct n1 as [x1 e1]. 69 | destruct n2 as [x2 e2]. 70 | unfold Binary.is_nan in *. 71 | destruct x1; try discriminate. 72 | destruct x2; try discriminate. 73 | apply (Bool.eqb s s0 && Pos.eqb pl pl0). 74 | Defined. 75 | 76 | Lemma nan_pl_sanity_check: 77 | forall prec1 emax1 prec2 emax2 n1 n2, 78 | @nan_pl_eqb' prec1 emax1 prec2 emax2 n1 n2 = @nan_pl_eqb prec1 emax1 prec2 emax2 n1 n2. 79 | Proof. 80 | intros. 81 | destruct n1 as [x1 e1], n2 as [x2 e2]. 82 | simpl. 83 | unfold Binary.is_nan in *. 84 | destruct x1; try discriminate. 85 | destruct x2; try discriminate. 86 | unfold nan_pl_eqb. simpl. 87 | auto. 88 | Qed. 89 | 90 | Lemma nan_payload_eqb_eq prec emax (n1 n2: nan_payload prec emax): 91 | (nan_pl_eqb n1 n2 = true <-> n1 = n2). 92 | Proof. 93 | unfold nan_pl_eqb. 94 | destruct n1; destruct n2; simpl. 95 | destruct x; try discriminate. 96 | destruct x0; try discriminate. 97 | split; intros. 98 | - 99 | rewrite andb_true_iff in H. destruct H. 100 | rewrite eqb_true_iff in H. 101 | rewrite Pos.eqb_eq in H0. 102 | assert (e=e0) by 103 | (apply Eqdep_dec.eq_proofs_unicity; destruct x; destruct y; intuition congruence). 104 | subst s0 pl0 e0. 105 | assert (e1=e2) by 106 | (apply Eqdep_dec.eq_proofs_unicity; destruct x; destruct y; intuition congruence). 107 | subst e2. 108 | reflexivity. 109 | - inversion H; clear H; subst. 110 | rewrite eqb_reflx. rewrite Pos.eqb_refl. reflexivity. 111 | Qed. 112 | 113 | Definition binary_float_eqb {prec1 emax1 prec2 emax2} (b1: binary_float prec1 emax1) (b2: binary_float prec2 emax2): bool := 114 | match b1, b2 with 115 | | B754_zero _ _ b1, B754_zero _ _ b2 => Bool.eqb b1 b2 116 | | B754_infinity _ _ b1, B754_infinity _ _ b2 => Bool.eqb b1 b2 117 | | B754_nan _ _ b1 n1 _, B754_nan _ _ b2 n2 _ => Bool.eqb b1 b2 && Pos.eqb n1 n2 118 | | B754_finite _ _ b1 m1 e1 _, B754_finite _ _ b2 m2 e2 _ => 119 | Bool.eqb b1 b2 && Pos.eqb m1 m2 && Z.eqb e1 e2 120 | | _, _ => false 121 | end. 122 | 123 | Lemma binary_float_eqb_eq prec emax (b1 b2: binary_float prec emax): 124 | binary_float_eqb b1 b2 = true <-> b1 = b2. 125 | Proof. 126 | destruct b1; destruct b2; simpl; 127 | 128 | (repeat rewrite andb_true_iff); 129 | (try rewrite Bool.eqb_true_iff); 130 | (try rewrite Pos.eqb_eq); 131 | (try intuition congruence). 132 | - split; intro. 133 | + destruct H; subst; f_equal. 134 | apply Eqdep_dec.eq_proofs_unicity. 135 | destruct x; destruct y; intuition congruence. 136 | + inversion H; clear H; subst; auto. 137 | - split; intro. 138 | + destruct H as [[? ?] ?]. 139 | apply Z.eqb_eq in H1. subst. 140 | f_equal. 141 | apply Eqdep_dec.eq_proofs_unicity. 142 | destruct x; destruct y; intuition congruence. 143 | + inversion H; clear H; subst; split; auto. 144 | apply Z.eqb_eq. auto. 145 | Qed. 146 | 147 | Definition binary_float_equiv {prec emax} 148 | (b1 b2: binary_float prec emax): Prop := 149 | match b1, b2 with 150 | | B754_zero _ _ b1, B754_zero _ _ b2 => b1 = b2 151 | | B754_infinity _ _ b1, B754_infinity _ _ b2 => b1 = b2 152 | | B754_nan _ _ _ _ _, B754_nan _ _ _ _ _ => True 153 | | B754_finite _ _ b1 m1 e1 _, B754_finite _ _ b2 m2 e2 _ => 154 | b1 = b2 /\ m1 = m2 /\ e1 = e2 155 | | _, _ => False 156 | end. 157 | 158 | Lemma binary_float_equiv_refl prec emax (b1: binary_float prec emax): 159 | binary_float_equiv b1 b1. 160 | Proof. 161 | destruct b1; simpl; auto. Qed. 162 | 163 | Lemma binary_float_equiv_sym prec emax (b1 b2: binary_float prec emax): 164 | binary_float_equiv b1 b2 -> binary_float_equiv b2 b1. 165 | Proof. 166 | intros. 167 | destruct b1; destruct b2; simpl; auto. 168 | destruct H as (A & B & C); subst; auto. Qed. 169 | 170 | Lemma binary_float_equiv_trans prec emax (b1 b2 b3: binary_float prec emax): 171 | binary_float_equiv b1 b2 -> 172 | binary_float_equiv b2 b3 -> binary_float_equiv b1 b3. 173 | Proof. 174 | intros. 175 | destruct b1; destruct b2; destruct b3; simpl; auto. 176 | all: try (destruct H; destruct H0; reflexivity). 177 | destruct H; destruct H0. subst. destruct H2; destruct H1; subst; auto. 178 | Qed. 179 | 180 | Lemma binary_float_eqb_equiv prec emax (b1 b2: binary_float prec emax): 181 | binary_float_eqb b1 b2 = true -> binary_float_equiv b1 b2 . 182 | Proof. 183 | destruct b1; destruct b2; simpl; 184 | (repeat rewrite andb_true_iff); 185 | (try rewrite Bool.eqb_true_iff); 186 | (try rewrite Pos.eqb_eq); 187 | (try intuition congruence). 188 | rewrite ?Z.eqb_eq; 189 | rewrite ?and_assoc; auto. 190 | Qed. 191 | 192 | Lemma binary_float_finite_equiv_eqb prec emax (b1 b2: binary_float prec emax): 193 | Binary.is_finite prec emax b1 = true -> 194 | binary_float_equiv b1 b2 -> binary_float_eqb b1 b2 = true . 195 | Proof. 196 | destruct b1; destruct b2; simpl; 197 | (repeat rewrite andb_true_iff); 198 | (try rewrite Bool.eqb_true_iff); 199 | (try rewrite Pos.eqb_eq); 200 | (try intuition congruence). 201 | rewrite ?Z.eqb_eq; 202 | rewrite ?and_assoc; auto. 203 | Qed. 204 | 205 | Lemma binary_float_eq_equiv prec emax (b1 b2: binary_float prec emax): 206 | b1 = b2 -> binary_float_equiv b1 b2. 207 | Proof. 208 | intros. 209 | apply binary_float_eqb_eq in H. 210 | apply binary_float_eqb_equiv in H; apply H. 211 | Qed. 212 | 213 | Lemma binary_float_equiv_eq prec emax (b1 b2: binary_float prec emax): 214 | binary_float_equiv b1 b2 -> Binary.is_nan _ _ b1 = false -> b1 = b2. 215 | Proof. 216 | intros. 217 | assert (binary_float_eqb b1 b2 = true). 218 | - destruct b1; destruct b2; simpl in H; subst; simpl; auto; 219 | try discriminate; 220 | try apply eqb_reflx. 221 | rewrite ?andb_true_iff. 222 | destruct H; rewrite H. 223 | destruct H1; rewrite H1; rewrite H2; split. split; auto. 224 | apply eqb_reflx. 225 | apply Pos.eqb_eq; reflexivity. 226 | apply Z.eqb_eq; reflexivity. 227 | - apply binary_float_eqb_eq; apply H1. 228 | Qed. 229 | 230 | Lemma binary_float_inf_equiv_eqb prec emax (b1 b2: binary_float prec emax): 231 | Binary.is_finite prec emax b1 = false -> 232 | Binary.is_nan prec emax b1 = false -> 233 | binary_float_equiv b1 b2 -> binary_float_eqb b1 b2 = true . 234 | Proof. 235 | destruct b1; destruct b2; simpl; 236 | (repeat rewrite andb_true_iff); 237 | (try rewrite Bool.eqb_true_iff); 238 | (try rewrite Pos.eqb_eq); 239 | (try intuition congruence). 240 | Qed. 241 | 242 | 243 | Lemma binary_float_equiv_nan prec emax (b1 b2: binary_float prec emax): 244 | binary_float_equiv b1 b2 -> Binary.is_nan _ _ b1 = true -> Binary.is_nan _ _ b2 = true. 245 | Proof. 246 | intros. 247 | destruct b1; simpl in H0; try discriminate. 248 | destruct b2; simpl in H; try contradiction. 249 | simpl; reflexivity. 250 | Qed. 251 | 252 | Lemma exact_inverse (prec emax : Z) 253 | (prec_gt_0_ : FLX.Prec_gt_0 prec) 254 | (Hmax : (prec < emax)%Z) : 255 | forall (b1 b2: binary_float prec emax), 256 | is_finite_strict prec emax b1 = false -> 257 | Bexact_inverse prec emax prec_gt_0_ Hmax b1 = Some b2 -> False. 258 | Proof. 259 | intros. 260 | apply Bexact_inverse_correct in H0; destruct H0; rewrite H0 in H; discriminate. 261 | Qed. 262 | 263 | Definition B2F {prec emax} (f : binary_float prec emax): 264 | Defs.float Zaux.radix2 := 265 | match f with 266 | | @B754_finite _ _ s m e _ => 267 | {| 268 | Defs.Fnum := Zaux.cond_Zopp s (Z.pos m); 269 | Defs.Fexp := e |} 270 | | _ => 271 | {| 272 | Defs.Fnum := 0; 273 | Defs.Fexp := 0 274 | |} 275 | end. 276 | 277 | Lemma B2F_F2R_B2R {prec emax} f: 278 | B2R prec emax f = Defs.F2R (B2F f). 279 | Proof. 280 | destruct f; simpl; unfold Defs.F2R; simpl; ring. 281 | Qed. 282 | 283 | Definition F2R beta (f: Defs.float beta): R := 284 | match f with 285 | | Defs.Float _ Fnum Fexp => 286 | IZR Fnum * Raux.bpow beta Fexp 287 | end. 288 | 289 | Lemma F2R_eq beta f: 290 | F2R beta f = Defs.F2R f. 291 | Proof. 292 | destruct f; reflexivity. 293 | Qed. 294 | 295 | Definition build_nan_full {prec emax} (pl: nan_payload prec emax) := 296 | let n := proj1_sig pl in F754_nan (Bsign _ _ n) (get_nan_pl _ _ n). 297 | 298 | Ltac const_pos p := 299 | lazymatch p with xH => idtac | xI ?p => const_pos p | xO ?p => const_pos p end. 300 | 301 | Ltac const_Z i := 302 | lazymatch i with 303 | | Zpos ?p => const_pos p 304 | | Zneg ?p => const_pos p 305 | | Z0 => idtac 306 | end. 307 | 308 | Ltac const_bool b := lazymatch b with true => idtac | false => idtac end. 309 | 310 | Ltac const_float f := 311 | lazymatch f with 312 | | Float_notations.b32_B754_zero ?s => const_bool s 313 | | Float_notations.b32_B754_finite ?s ?m ?e _ => const_bool s; const_pos m; const_Z e 314 | | Float_notations.b32_B754_infinity ?s => const_bool s 315 | | Float_notations.b64_B754_zero ?s => const_bool s 316 | | Float_notations.b64_B754_finite ?s ?m ?e _ => const_bool s; const_pos m; const_Z e 317 | | Float_notations.b64_B754_infinity ?s => const_bool s 318 | | B754_zero ?prec ?emax ?s => const_Z prec; const_Z emax; const_bool s 319 | | B754_finite ?prec ?emax ?s ?m ?e _ => const_Z prec; const_Z emax; const_bool s; const_pos m; const_Z e 320 | | B754_infinity ?prec ?emax ?s => const_Z prec; const_Z emax; const_bool s 321 | | B754_nan ?prec ?emax ?s ?p _ => const_Z prec; const_Z emax; const_bool s; const_pos p 322 | end. 323 | 324 | Lemma B754_finite_replace_proof: 325 | forall prec emax s m e H1 H2, 326 | B754_finite prec emax s m e H1 = B754_finite prec emax s m e H2. 327 | Proof. 328 | intros. 329 | f_equal. 330 | apply Classical_Prop.proof_irrelevance. 331 | Qed . 332 | 333 | Ltac compute_float_operation E := 334 | (* E should be a float expression in the goal below the line, 335 | that is known to compute to B754_finite; 336 | for example, a binary operator (Bdiv, Bplus, etc.) applied 337 | to constant prec,emax and two constant arguments. 338 | This tactic replaces E with its computed value, and in particular 339 | where the proof of SpecFloat.bounded is simply (eq_refl true). *) 340 | let z := eval hnf in E in 341 | lazymatch z with 342 | | B754_finite ?prec ?emax ?s ?m ?e ?H => 343 | let w := constr:(B754_finite prec emax s m e) in 344 | let w := eval compute in w in 345 | let w := constr:(w (eq_refl true)) in 346 | replace E with w by apply B754_finite_replace_proof 347 | | B754_zero ?prec ?emax ?s => 348 | let w := constr:(B754_zero prec emax s) in 349 | let w := eval compute in w in 350 | change E with w 351 | end. 352 | 353 | Inductive option_rel [A B: Type] (R: A -> B -> Prop) : option A -> option B -> Prop := 354 | | option_rel_none: option_rel R None None 355 | | option_rel_some: forall x y, R x y -> option_rel R (Some x) (Some y). 356 | 357 | Inductive FF2B_gen_spec (prec emax: Z) (x: full_float): binary_float prec emax -> Prop := 358 | | FF2B_gen_spec_invalid (Hx: valid_binary prec emax x = false): 359 | FF2B_gen_spec prec emax x (B754_infinity _ _ (sign_FF x)) 360 | | FF2B_gen_spec_valid (Hx: valid_binary prec emax x = true) 361 | y (Hy: y = FF2B _ _ _ Hx): 362 | FF2B_gen_spec _ _ x y 363 | . 364 | 365 | Lemma FF2B_gen_spec_unique prec emax x y1: 366 | FF2B_gen_spec prec emax x y1 -> 367 | forall y2, 368 | FF2B_gen_spec prec emax x y2 -> 369 | y1 = y2. 370 | Proof. 371 | inversion 1; subst; 372 | inversion 1; subst; try congruence. 373 | f_equal. 374 | apply Eqdep_dec.eq_proofs_unicity. 375 | generalize bool_dec. clear. firstorder. 376 | Qed. 377 | 378 | Lemma bool_true_elim {T} a (f: _ -> T) g H: 379 | match a as a' return a = a' -> _ with 380 | | true => f 381 | | false => g 382 | end eq_refl = f H. 383 | Proof. 384 | destruct a; try congruence. 385 | f_equal. 386 | apply Eqdep_dec.eq_proofs_unicity. 387 | decide equality. 388 | Qed. 389 | 390 | Definition FF2B_gen prec emax x := 391 | match valid_binary prec emax x as y return valid_binary prec emax x = y -> _ with 392 | | true => fun Hx => FF2B _ _ _ Hx 393 | | false => fun _ => B754_infinity _ _ (sign_FF x) 394 | end eq_refl. 395 | 396 | Lemma FF2B_gen_correct prec emax x (Hx: valid_binary prec emax x = true): 397 | FF2B_gen _ _ x = FF2B _ _ _ Hx. 398 | Proof. 399 | apply bool_true_elim. 400 | Qed. 401 | 402 | Axiom prop_ext: ClassicalFacts.prop_extensionality. 403 | 404 | Lemma proof_irr : ClassicalFacts.proof_irrelevance. 405 | Proof. apply ClassicalFacts.ext_prop_dep_proof_irrel_cic. 406 | apply prop_ext. 407 | Qed. 408 | Arguments proof_irr [A] a1 a2. 409 | 410 | Ltac proof_irr := 411 | match goal with 412 | | H:?A, H':?A 413 | |- _ => generalize (proof_irr H H'); intro; subst H' 414 | end. 415 | 416 | -------------------------------------------------------------------------------- /vcfloat/BigQAux.v: -------------------------------------------------------------------------------- 1 | (* LGPL licensed; see ../LICENSE and, for historical notes, see ../OLD_LICENSE *) 2 | 3 | (** R-CoqLib: general-purpose Coq libraries and tactics. *) 4 | 5 | (* Auxiliary theorems for big rational numbers *) 6 | 7 | Require Export Morphisms. 8 | Require Export QArith. 9 | Require Export Bignums.BigQ.BigQ. 10 | 11 | Global Instance to_Q_morph: Proper (BigQ.eq ==> Qeq) BigQ.to_Q. 12 | Proof. 13 | do 2 red. 14 | intros. 15 | rewrite <- BigQ.eqb_eq in H. 16 | rewrite BigQ.spec_eq_bool in H. 17 | rewrite Qeq_bool_iff in H. 18 | assumption. 19 | Qed. 20 | 21 | Lemma to_Q_bigZ z: 22 | BigQ.to_Q (BigQ.Qz z) == inject_Z (BigZ.to_Z z). 23 | Proof. 24 | reflexivity. 25 | Qed. 26 | 27 | Definition Bnum b := 28 | match b with 29 | | BigQ.Qz t => t 30 | | BigQ.Qq n d => 31 | if (d =? BigN.zero)%bigN then 0%bigZ else n 32 | end. 33 | 34 | Definition Bden b := 35 | match b with 36 | | BigQ.Qz _ => 1%bigN 37 | | BigQ.Qq _ d => if (d =? BigN.zero)%bigN then 1%bigN else d 38 | end. 39 | -------------------------------------------------------------------------------- /vcfloat/BigRAux.v: -------------------------------------------------------------------------------- 1 | (* LGPL licensed; see ../LICENSE and, for historical notes, see ../OLD_LICENSE *) 2 | 3 | (** Auxiliary theorems for the real-number semantics of big rational numbers. *) 4 | 5 | Require Export vcfloat.BigQAux. 6 | Require Export vcfloat.Q2RAux. 7 | Require Export Flocq.Core.Raux. 8 | Open Scope R_scope. 9 | 10 | Definition BigQ2R x := Q2R (BigQ.to_Q x). 11 | 12 | Global Instance BigQ2R_proper: 13 | Proper (BigQ.eq ==> eq) BigQ2R. 14 | Proof. 15 | do 2 red. 16 | intros. 17 | unfold BigQ2R. 18 | setoid_rewrite H. 19 | reflexivity. 20 | Qed. 21 | -------------------------------------------------------------------------------- /vcfloat/FMap_lemmas.v: -------------------------------------------------------------------------------- 1 | Require FMapInterface. 2 | Require FMapAVL. 3 | Import OrderedType. 4 | 5 | 6 | (* (c) 2022 Andrew W. Appel. 7 | 8 | LEMMAS FOR REASONING ABOUT COMMUTATIVE FOLDS OVER TABLES. 9 | 10 | This module adds two extra lemmas to the FMapAVL functor. 11 | Because the lemmas rely on internal ("Raw") components of FMapAVL, 12 | this is structured as a functor that, when applied, instantiates FMapAVL. 13 | 14 | The purpose of the lemmas is to manipulate folds over tables. 15 | 16 | Suppose you have a table mapping keys to elements: 17 | tab : Table.t element. 18 | And suppose you fold a function over all the elements: 19 | fold_f (tab) := Table.fold (fun k x a => f (lift x) a) u tab 20 | where f is associative-commutative over type A, with u:A is a unit for f. 21 | 22 | Then you would think that if [Table.find k tab = None] then, 23 | fold_f (Table.add k x tab) = f x tab. 24 | And if Table.find k tab = Some y, then a slightly more complicated 25 | relation should hold. 26 | 27 | That's just the purpose of the lemmas 28 | relate_fold_add lemma and fold_add_ignore, 29 | which (when used together) can facilitate reasoning about 30 | table folds when adding elements. 31 | 32 | The second module "Demonstration" illustrates an example of its use. 33 | In that case, the associative-commutative [f] is just Z.add, 34 | the element type is positive, the "lift" function is Z.pos. 35 | We prove that when you insert a positive number into a table, 36 | the "Table.fold (fun k x a => Z.add (Z.pos x) a)" result will 37 | increase by the appropriate amount. 38 | 39 | *) 40 | 41 | Module FMapAVL_extra (Keys: OrderedType). 42 | 43 | Module Table := FMapAVL.Make Keys. 44 | 45 | Lemma fold_bal: 46 | forall [elt A] (f: Table.Raw.key -> elt -> A -> A) (t1 t2: Table.Raw.tree elt) k e x, 47 | Table.Raw.fold f (Table.Raw.bal t1 k e t2) x = 48 | Table.Raw.fold f t2 (f k e (Table.Raw.fold f t1 x)). 49 | Proof. 50 | intros. 51 | unfold Table.Raw.bal. 52 | repeat match goal with 53 | | |- context [if ?A then _ else _] => destruct A 54 | | |- context [match Table.Raw.add ?p ?x ?y with _ => _ end] => 55 | destruct (Table.Raw.add p x y) eqn:?H 56 | | |- context [match ?t with _ => _ end ] => is_var t; destruct t 57 | end; 58 | simpl; auto. 59 | Qed. 60 | 61 | Lemma raw_in_congr: 62 | forall [elt k k'] [t: Table.Raw.tree elt], 63 | Keys.eq k k' -> (Table.Raw.In k t <-> Table.Raw.In k' t). 64 | Proof. 65 | intros. 66 | induction t; simpl. 67 | split; intros; inversion H0. 68 | split; intro H0; inversion H0; clear H0; subst. 69 | - constructor; apply Keys.eq_sym in H; eapply Keys.eq_trans; eauto. 70 | - apply Table.Raw.InLeft; rewrite <- IHt1; auto. 71 | - apply Table.Raw.InRight; rewrite <- IHt2; auto. 72 | - constructor; eapply Keys.eq_trans; eauto. 73 | - apply Table.Raw.InLeft; rewrite IHt1; auto. 74 | - apply Table.Raw.InRight; rewrite IHt2; auto. 75 | Qed. 76 | 77 | Lemma relate_fold_add': 78 | forall [elt A: Type] 79 | [eqv: A -> A -> Prop] 80 | (eqv_rel: Equivalence eqv) 81 | (lift: Table.key -> elt -> A) 82 | (lift_prop: forall k k' x, Keys.eq k k' -> eqv (lift k x) (lift k' x)) 83 | (f: A -> A -> A) 84 | (f_mor: forall x1 y1, eqv x1 y1 -> 85 | forall x2 y2, eqv x2 y2 -> 86 | eqv (f x1 x2) (f y1 y2)) 87 | (f_assoc: forall x y z : A, eqv (f x (f y z)) (f (f x y) z)) 88 | (f_commut: forall x y : A, eqv (f x y) (f y x)) 89 | (u: A) 90 | (u_unit: forall x, eqv (f u x) x) 91 | (g: Table.key -> elt -> A -> A) 92 | (g_eqv: forall k x a, eqv (g k x a) (f (lift k x) a)) 93 | (tab: Table.t elt) 94 | (k: Table.key), 95 | eqv (Table.fold g tab u) 96 | (f (match Table.find k tab with Some x => lift k x | None => u end) 97 | (Table.fold (fun k' x a => 98 | match Keys.compare k k' with EQ _ => a 99 | | _ => g k' x a end) tab u)). 100 | Proof. 101 | intros. 102 | destruct tab. 103 | unfold Table.fold, Table.find; simpl. 104 | set (h := fun (k' : Table.key) (x : elt) (a : A) => 105 | match Keys.compare k k' with 106 | | EQ _ => a 107 | | _ => g k' x a 108 | end). 109 | assert (g_mor: forall k x a b, eqv a b -> eqv (g k x a) (g k x b)). { 110 | intros. rewrite !g_eqv. apply f_mor; auto; reflexivity. 111 | } 112 | assert (FOLD1: forall t a, ~Table.Raw.In k t -> 113 | Table.Raw.fold g t a = Table.Raw.fold h t a). { 114 | induction t; simpl; intros;auto. 115 | rewrite IHt1, IHt2. 116 | f_equal. set (uu := Table.Raw.fold _ _ _); clearbody uu. 117 | unfold h. clear -H. 118 | destruct (Keys.compare k k0); auto. contradiction H. 119 | constructor; auto. 120 | contradict H. constructor 3; auto. 121 | contradict H. constructor 2; auto. 122 | } 123 | assert (FOLD2: forall t a b, eqv a b -> eqv (Table.Raw.fold g t a) (Table.Raw.fold g t b)). { 124 | clear - eqv_rel g_mor. 125 | induction t; simpl; intros;auto. 126 | } 127 | assert (FOLD3: forall t k a b, 128 | eqv (Table.Raw.fold g t (g k a b)) (g k a (Table.Raw.fold g t b))). { 129 | induction t; simpl; intros. reflexivity. 130 | etransitivity; [ | apply IHt2]. apply FOLD2. 131 | transitivity (g k0 e (g k1 a (Table.Raw.fold g t1 b))). 132 | apply g_mor; auto. 133 | set (v := Table.Raw.fold _ _ _). clearbody v. 134 | rewrite (g_eqv k0). 135 | etransitivity. apply f_mor. reflexivity. 136 | apply g_eqv. 137 | etransitivity; [apply f_assoc |]. 138 | etransitivity. apply f_mor. apply f_commut. reflexivity. 139 | etransitivity; [symmetry; apply f_assoc |]. 140 | symmetry. 141 | rewrite g_eqv. apply f_mor. reflexivity. apply g_eqv. 142 | } 143 | destruct (Table.Raw.find k this) eqn:?H. 144 | - 145 | set (a:=u). clearbody a. 146 | revert a; induction is_bst; simpl; intros; [ discriminate | ]. 147 | simpl in H. 148 | unfold h at 2. 149 | destruct (Keys.compare k x). 150 | + 151 | specialize (IHis_bst1 H); clear IHis_bst2. 152 | rewrite <- FOLD1 153 | by (apply (Table.Raw.Proofs.gt_tree_trans l0) in H1; 154 | apply Table.Raw.Proofs.gt_tree_not_in; auto). 155 | etransitivity. apply FOLD2. apply g_mor. apply IHis_bst1. 156 | set (v := Table.Raw.fold h l a). clearbody v. 157 | symmetry. 158 | etransitivity. 159 | symmetry. 160 | rewrite <- g_eqv. 161 | apply FOLD3. 162 | apply FOLD2. 163 | rewrite g_eqv. 164 | etransitivity. apply f_mor. reflexivity. apply g_eqv. 165 | rewrite f_assoc. 166 | etransitivity. apply f_mor. apply f_commut. reflexivity. 167 | rewrite <- f_assoc. 168 | rewrite g_eqv. 169 | reflexivity. 170 | + 171 | assert (Hl: ~Table.Raw.In k l) 172 | by (rewrite (raw_in_congr e1); 173 | apply Table.Raw.Proofs.lt_tree_not_in; auto). 174 | assert (Hr: ~Table.Raw.In k r) 175 | by (rewrite (raw_in_congr e1); 176 | apply Table.Raw.Proofs.gt_tree_not_in; auto). 177 | inversion H; clear H; subst. 178 | clear IHis_bst1 IHis_bst2. 179 | rewrite <- !FOLD1 by auto. 180 | etransitivity. 181 | apply FOLD3. 182 | rewrite !g_eqv. 183 | apply f_mor; try reflexivity. 184 | symmetry. 185 | apply lift_prop; auto. 186 | + 187 | specialize (IHis_bst2 H); clear IHis_bst1. 188 | assert (Hl: ~Table.Raw.In k l) 189 | by (apply (Table.Raw.Proofs.lt_tree_trans l0) in H0; 190 | apply Table.Raw.Proofs.lt_tree_not_in; auto). 191 | etransitivity. apply IHis_bst2. clear IHis_bst2. 192 | apply f_mor. reflexivity. 193 | rewrite FOLD1 by auto. reflexivity. 194 | - 195 | assert (Hr: ~Table.Raw.In k this) 196 | by (apply Table.Raw.Proofs.not_find_iff; auto). 197 | rewrite FOLD1 by auto. 198 | rewrite u_unit. 199 | reflexivity. 200 | Qed. 201 | 202 | 203 | Lemma relate_fold_add: 204 | forall [elt A: Type] 205 | [eqv: A -> A -> Prop] 206 | (eqv_rel: Equivalence eqv) 207 | (lift: Table.key -> elt -> A) 208 | (lift_prop: forall k k' x, Keys.eq k k' -> eqv (lift k x) (lift k' x)) 209 | (f: A -> A -> A) 210 | (f_mor: forall x1 y1, eqv x1 y1 -> 211 | forall x2 y2, eqv x2 y2 -> 212 | eqv (f x1 x2) (f y1 y2)) 213 | (f_assoc: forall x y z : A, eqv (f x (f y z)) (f (f x y) z)) 214 | (f_commut: forall x y : A, eqv (f x y) (f y x)) 215 | (u: A) 216 | (u_unit: forall x, eqv (f u x) x) 217 | (g: Table.key -> elt -> A -> A) 218 | (g_eqv: forall k x a, eqv (g k x a) (f (lift k x) a)) 219 | (tab: Table.t elt) 220 | (k: Table.key), 221 | eqv (Table.fold g tab u) 222 | (f (match Table.find k tab with Some x => lift k x | None => u end) 223 | (Table.fold (fun k' x a => if Keys.eq_dec k k' then a else g k' x a) tab u)). 224 | Proof. 225 | intros. 226 | rewrite (relate_fold_add' eqv_rel lift lift_prop f f_mor f_assoc f_commut u u_unit g g_eqv tab k). 227 | apply f_mor. 228 | reflexivity. 229 | rewrite !Table.fold_1. 230 | clear u_unit. 231 | revert u. 232 | induction (Table.elements (elt:=elt) tab); intro. 233 | simpl. reflexivity. 234 | simpl. 235 | rewrite IHl. 236 | set (ff := fold_left _). 237 | clearbody ff. 238 | match goal with |- eqv ?A ?B => replace B with A end. 239 | reflexivity. 240 | f_equal. 241 | set (j := fst a). clearbody j. 242 | clear. 243 | destruct (Keys.compare k j); try apply Keys.lt_not_eq in l; 244 | destruct (Keys.eq_dec k j); try contradiction; auto. 245 | symmetry in e. contradiction. 246 | Qed. 247 | 248 | 249 | Lemma fold_add_ignore: 250 | forall [elt A] 251 | (f: Table.key -> elt -> A -> A) 252 | (tab: Table.t elt) 253 | (k: Table.key) 254 | (x: elt) (a0: A), 255 | (forall k' y a, Keys.eq k k' -> f k' y a = a) -> 256 | Table.fold f (Table.add k x tab) a0 = 257 | Table.fold f tab a0. 258 | Proof. 259 | intros. 260 | destruct tab. 261 | unfold Table.fold, Table.add; simpl. 262 | revert a0; induction is_bst; intros. 263 | unfold Table.Raw.add. simpl. 264 | apply H; reflexivity. 265 | simpl. 266 | destruct (Keys.compare k x0); rewrite ?fold_bal. 267 | rewrite IHis_bst1. auto. 268 | simpl. 269 | f_equal. 270 | rewrite ?H; auto. 271 | rewrite IHis_bst2. auto. 272 | Qed. 273 | 274 | 275 | 276 | Lemma relate_fold_add_alt: 277 | forall [elt A: Type] 278 | [eqv: A -> A -> Prop] 279 | (eqv_rel: Equivalence eqv) 280 | (lift: Table.key -> elt -> A) 281 | (lift_prop: forall k k' x, Keys.eq k k' -> eqv (lift k x) (lift k' x)) 282 | (f: A -> A -> A) 283 | (f_mor: forall x1 y1, eqv x1 y1 -> 284 | forall x2 y2, eqv x2 y2 -> 285 | eqv (f x1 x2) (f y1 y2)) 286 | (f_assoc: forall x y z : A, eqv (f x (f y z)) (f (f x y) z)) 287 | (f_commut: forall x y : A, eqv (f x y) (f y x)) 288 | (u: A) 289 | (u_unit: forall x, eqv (f u x) x) 290 | (g: Table.key -> elt -> A -> A) 291 | (g_eqv: forall k x a, eqv (g k x a) (f (lift k x) a)) 292 | (tab: Table.t elt) 293 | (k: Table.key) (new oldnew : elt), 294 | eqv (f (lift k new) (match Table.find k tab with Some x => lift k x | None => u end)) (lift k oldnew) -> 295 | eqv (f (lift k new) (Table.fold g tab u)) (Table.fold g (Table.add k oldnew tab) u). 296 | Proof. 297 | intros. 298 | pose proof relate_fold_add eqv_rel lift lift_prop f f_mor f_assoc f_commut u u_unit g g_eqv. 299 | etransitivity. 300 | apply f_mor. 301 | reflexivity. 302 | apply H0 with (k:=k). 303 | rewrite f_assoc. 304 | etransitivity. 305 | apply f_mor. 306 | apply H. 307 | reflexivity. 308 | rewrite H0 with (k:=k). 309 | apply f_mor. 310 | erewrite Table.find_1 by (apply Table.add_1; reflexivity). 311 | reflexivity. 312 | rewrite fold_add_ignore. 313 | reflexivity. 314 | intros. 315 | destruct (Keys.eq_dec k k'); try contradiction. 316 | auto. 317 | Qed. 318 | 319 | End FMapAVL_extra. 320 | 321 | Module Demonstration. 322 | Import ZArith. 323 | Module Keys <: OrderedType.OrderedType. 324 | Definition t := Z. 325 | Definition cmp := Z.compare. 326 | Definition lt := Z.lt. 327 | Definition eq := Z.eq. 328 | Lemma eq_refl: forall al, eq al al. exact (@eq_refl Z). Qed. 329 | Lemma eq_sym : forall al bl, eq al bl -> eq bl al. exact (@eq_sym Z). Qed. 330 | Lemma eq_trans : forall x y z, eq x y -> eq y z -> eq x z. 331 | exact (@eq_trans Z). Qed. 332 | Definition lt_trans := Z.lt_trans. 333 | Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. 334 | Proof. 335 | intros; intro. rewrite H0 in H. revert H. apply Z.lt_irrefl. 336 | Qed. 337 | 338 | Lemma cmp_antisym1: forall x y, cmp x y = Gt -> cmp y x = Lt. 339 | Proof. intros. apply Zcompare_Gt_Lt_antisym; auto. Qed. 340 | 341 | Definition compare ( x y : t) : OrderedType.Compare lt eq x y := 342 | match cmp x y as c0 return (cmp x y = c0 -> OrderedType.Compare lt eq x y) with 343 | | Eq => fun H0 : cmp x y = Eq => OrderedType.EQ (Z.compare_eq _ _ H0) 344 | | Lt => fun H0 : cmp x y = Lt => OrderedType.LT H0 345 | | Gt => fun H0 : cmp x y = Gt => OrderedType.GT (cmp_antisym1 x y H0) 346 | end (Logic.eq_refl _). 347 | 348 | Lemma eq_dec: forall x y, { eq x y } + { ~ eq x y }. 349 | Proof. apply Z.eq_dec. Qed. 350 | 351 | End Keys. 352 | 353 | Module FM := FMapAVL_extra Keys. 354 | Import FM. 355 | 356 | Definition addup_table (tab: Table.t positive) := 357 | Table.fold (fun k p i => Z.add (Z.pos p) i) tab Z0. 358 | 359 | Definition add_to_table (k: Table.key) (p: positive) (tab: Table.t positive) := 360 | match Table.find k tab with 361 | | Some x => Table.add k (p+x)%positive tab 362 | | None => Table.add k p tab 363 | end. 364 | 365 | Lemma add_to_table_correct: 366 | forall k p tab, 367 | addup_table (add_to_table k p tab) = Z.add (addup_table tab) (Z.pos p). 368 | Proof. 369 | intros. 370 | pose (lift (k: Table.key) p := Z.pos p). 371 | pose (oldnew := Z.to_pos (lift k p + match Table.find (elt:=positive) k tab with 372 | | Some x => lift k x 373 | | None => 0 374 | end)). 375 | pose proof relate_fold_add_alt Z.eq_equiv lift 376 | ltac:(intros; rewrite H; auto) 377 | Z.add 378 | ltac:(intros; subst; auto) 379 | Z.add_assoc Z.add_comm 380 | Z0 381 | Z.add_0_l 382 | (fun k p x => Z.add (lift k p) x) 383 | ltac:(intros; subst; reflexivity) 384 | tab k p oldnew. 385 | unfold addup_table, add_to_table. 386 | set (f := fun (k : Table.key) (p : positive) (x : Z) => (lift k p + x)%Z) in *. 387 | change (fun (_ : Table.key) (p1 : positive) (i : Z) => (Z.pos p1 + i)%Z) with f in *. 388 | rewrite Z.add_comm. 389 | change (Z.pos p) with (lift k p). 390 | rewrite H; clear H. 391 | f_equal. 392 | destruct (Table.find k tab) eqn:?H; auto. 393 | unfold oldnew. 394 | set (b := match Table.find (elt:=positive) k tab with 395 | | Some x => lift k x 396 | | None => 0%Z 397 | end). 398 | assert (0 <= b)%Z. 399 | subst b. 400 | unfold lift. 401 | destruct (Table.find (elt:=positive) k tab); simpl; Lia.lia. 402 | unfold lift. 403 | Lia.lia. 404 | Qed. 405 | 406 | End Demonstration. 407 | 408 | 409 | 410 | 411 | 412 | 413 | 414 | 415 | 416 | 417 | 418 | 419 | 420 | 421 | 422 | 423 | 424 | 425 | 426 | 427 | 428 | 429 | -------------------------------------------------------------------------------- /vcfloat/FPStdCompCert.v: -------------------------------------------------------------------------------- 1 | Require Import Lia. 2 | From vcfloat Require Import FPStdLib. (* FPLang Rounding FPLangOpt.*) 3 | Require compcert.common.AST compcert.common.Values. 4 | Require Import compcert.lib.Floats. 5 | Import Binary BinPos. 6 | 7 | Inductive val_inject: Values.val -> forall ty, ftype ty -> Prop := 8 | | val_inject_single (f: ftype Tsingle): 9 | val_inject (Values.Vsingle f) Tsingle f 10 | | val_inject_double f: 11 | val_inject (Values.Vfloat f) Tdouble f 12 | . 13 | 14 | Lemma val_inject_single_inv (f1: float32) (f2: ftype Tsingle): 15 | val_inject (Values.Vsingle f1) Tsingle f2 -> 16 | f1 = f2. 17 | Proof. 18 | inversion 1; subst. 19 | apply ProofIrrelevance.ProofIrrelevanceTheory.EqdepTheory.inj_pair2 in H2; auto. 20 | Qed. 21 | 22 | Lemma val_inject_double_inv f1 f2: 23 | val_inject (Values.Vfloat f1) Tdouble f2 -> 24 | f1 = f2. 25 | Proof. 26 | inversion 1; subst. 27 | apply ProofIrrelevance.ProofIrrelevanceTheory.EqdepTheory.inj_pair2 in H2; auto. 28 | Qed. 29 | 30 | Require vcfloat.FPCompCert. 31 | 32 | #[export] Instance nans: FPCore.Nans := FPCompCert.nans. 33 | 34 | Lemma val_inject_eq_rect_r v ty1 e: 35 | val_inject v ty1 e -> 36 | forall ty2 (EQ: ty2 = ty1), 37 | val_inject v ty2 (eq_rect_r _ e EQ). 38 | Proof. 39 | intros. 40 | subst. 41 | assumption. 42 | Qed. 43 | 44 | Lemma val_inject_single_inv_r v f: 45 | val_inject v Tsingle f -> 46 | v = Values.Vsingle f. 47 | Proof. 48 | inversion 1; subst. 49 | apply val_inject_single_inv in H. 50 | congruence. 51 | Qed. 52 | 53 | Lemma val_inject_double_inv_r v f: 54 | val_inject v Tdouble f -> 55 | v = Values.Vfloat f. 56 | Proof. 57 | inversion 1; subst. 58 | apply val_inject_double_inv in H. 59 | congruence. 60 | Qed. 61 | 62 | (** Why do we need this rewrite hint database? 63 | You might think that all of this could be accomplished with "change" 64 | instead of "rewrite". But if you do that, then Qed takes forever. *) 65 | Lemma Float32_add_rewrite: Float32.add = @BPLUS _ Tsingle. 66 | Proof. reflexivity. Qed. 67 | 68 | #[export] Hint Rewrite Float32_add_rewrite : float_elim. 69 | Lemma Float32_sub_rewrite: Float32.sub = @BMINUS _ Tsingle. 70 | Proof. reflexivity. Qed. 71 | #[export] Hint Rewrite Float32_sub_rewrite : float_elim. 72 | Lemma Float32_mul_rewrite: Float32.mul = @BMULT _ Tsingle. 73 | Proof. reflexivity. Qed. 74 | #[export] Hint Rewrite Float32_mul_rewrite : float_elim. 75 | Lemma Float32_div_rewrite: Float32.div = @BDIV _ Tsingle. 76 | Proof. reflexivity. Qed. 77 | #[export] Hint Rewrite Float32_div_rewrite : float_elim. 78 | Lemma Float32_neg_rewrite: Float32.neg = @BOPP _ Tsingle. 79 | Proof. reflexivity. Qed. 80 | #[export] Hint Rewrite Float32_neg_rewrite : float_elim. 81 | Lemma Float32_abs_rewrite: Float32.abs = @BABS _ Tsingle. 82 | Proof. reflexivity. Qed. 83 | #[export] Hint Rewrite Float32_abs_rewrite : float_elim. 84 | 85 | Lemma Float_add_rewrite: Float.add = @BPLUS _ Tdouble. 86 | Proof. reflexivity. Qed. 87 | #[export] Hint Rewrite Float_add_rewrite : float_elim. 88 | Lemma Float_sub_rewrite: Float.sub = @BMINUS _ Tdouble. 89 | Proof. reflexivity. Qed. 90 | #[export] Hint Rewrite Float_sub_rewrite : float_elim. 91 | Lemma Float_mul_rewrite: Float.mul = @BMULT _ Tdouble. 92 | Proof. reflexivity. Qed. 93 | #[export] Hint Rewrite Float_mul_rewrite : float_elim. 94 | Lemma Float_div_rewrite: Float.div = @BDIV _ Tdouble. 95 | Proof. reflexivity. Qed. 96 | #[export] Hint Rewrite Float_div_rewrite : float_elim. 97 | Lemma Float_neg_rewrite: Float.neg = @BOPP _ Tdouble. 98 | Proof. reflexivity. Qed. 99 | #[export] Hint Rewrite Float_neg_rewrite : float_elim. 100 | Lemma Float_abs_rewrite: Float.abs = @BABS _ Tdouble. 101 | Proof. reflexivity. Qed. 102 | #[export] Hint Rewrite Float_abs_rewrite : float_elim. 103 | 104 | Lemma float_of_single_eq: Float.of_single = @cast _ Tdouble Tsingle. 105 | Proof. reflexivity. Qed. 106 | 107 | Lemma float32_to_double_eq: Float32.to_double = @cast _ Tdouble Tsingle. 108 | Proof. reflexivity. Qed. 109 | Lemma float32_of_float_eq: Float32.of_double = @cast _ Tsingle Tdouble. 110 | Proof. reflexivity. Qed. 111 | Lemma float_to_single_eq: Float.to_single = @cast _ Tsingle Tdouble. 112 | Proof. reflexivity. Qed. 113 | #[export] Hint Rewrite float_of_single_eq float32_to_double_eq 114 | float32_of_float_eq float_to_single_eq : float_elim. 115 | 116 | Import Float_notations. 117 | 118 | Lemma B754_finite_ext: 119 | forall prec emax s m e p1 p2, 120 | Binary.B754_finite prec emax s m e p1 = Binary.B754_finite prec emax s m e p2. 121 | Proof. 122 | intros. 123 | f_equal. 124 | apply Classical_Prop.proof_irrelevance. 125 | Qed. 126 | 127 | Import Integers. 128 | 129 | Ltac canonicalize_float_constant x := 130 | match x with 131 | | Float32.of_bits (Int.repr ?a) => 132 | const_Z a; 133 | let x' := constr:(Bits.b32_of_bits a) in 134 | let y := eval compute in x' in 135 | match y with 136 | | Binary.B754_finite _ _ ?s ?m ?e _ => 137 | let z := constr:(b32_B754_finite s m e (@eq_refl bool true)) 138 | in change x with x'; 139 | replace x' with z by (apply B754_finite_ext; reflexivity) 140 | | Binary.B754_zero _ _ ?s => 141 | let z := constr:(b32_B754_zero s) in 142 | change x with z 143 | end 144 | | Float.of_bits (Int64.repr ?a) => 145 | const_Z a; 146 | let x' := constr:(Bits.b64_of_bits a) in 147 | let y := eval compute in x' in 148 | match y with 149 | | Binary.B754_finite _ _ ?s ?m ?e _ => 150 | let z := constr:(b64_B754_finite s m e (@eq_refl bool true)) 151 | in change x with x'; 152 | replace x' with z by (apply B754_finite_ext; reflexivity) 153 | | Binary.B754_zero _ _ ?s => 154 | let z := constr:(b64_B754_zero s) in 155 | change x with z 156 | end 157 | end. 158 | 159 | Ltac canonicalize_float_constants := 160 | repeat 161 | match goal with 162 | | |- context [Binary.B754_finite 24 128 ?s ?m ?e ?p] => 163 | let x := constr:(Binary.B754_finite 24 128 s m e p) in 164 | let e' := eval compute in e in 165 | let z := constr:(b32_B754_finite s m e' (@eq_refl bool true)) in 166 | replace x with z by (apply B754_finite_ext; reflexivity) 167 | | |- context [Binary.B754_finite 53 1024 ?s ?m ?e ?p] => 168 | let x := constr:(Binary.B754_finite 53 1024 s m e p) in 169 | let e' := eval compute in e in 170 | let z := constr:(b64_B754_finite s m e' (@eq_refl bool true)) in 171 | replace x with z by (apply B754_finite_ext; reflexivity) 172 | | |- context [Float32.of_bits (Int.repr ?a)] => 173 | canonicalize_float_constant constr:(Float32.of_bits (Int.repr a)) 174 | | |- context [Float.of_bits (Int64.repr ?a)] => 175 | canonicalize_float_constant constr:(Float.of_bits (Int64.repr a)) 176 | end. 177 | 178 | -------------------------------------------------------------------------------- /vcfloat/Fprop_absolute.v: -------------------------------------------------------------------------------- 1 | (* LGPL licensed; see ../LICENSE and, for historical notes, see ../OLD_LICENSE *) 2 | 3 | (** More properties of floating-point numbers: absolute error, multiply/divide by radix. *) 4 | 5 | Require Import ZArith Flocq.Core.Raux Reals. 6 | Require Import Lia Lra. 7 | 8 | Require Import Flocq.Prop.Relative. 9 | (*Require Import Flocq.Appli.Fappli_IEEE. *) 10 | 11 | Open Scope R_scope. 12 | 13 | Section I3E. 14 | Variables prec emin : Z. 15 | Context (prec_gt_0_ : Core.FLX.Prec_gt_0 prec). 16 | 17 | Let fexp := Core.FLT.FLT_exp emin prec. 18 | 19 | Import Core.FLT Generic_fmt Core.Ulp. 20 | 21 | Lemma absolute_error_N_FLT_aux beta choice : 22 | forall x, 23 | (0 < x)%R -> 24 | x < bpow beta (emin + prec) -> 25 | exists eta, 26 | (Rabs eta <= /2 * Raux.bpow beta (emin))%R /\ 27 | Generic_fmt.round beta fexp (Generic_fmt.Znearest choice) x = (x + eta)%R. 28 | Proof. 29 | (* from error_N_FLT_aux *) 30 | intros x Hx2 Hx. 31 | exists (round beta (FLT_exp emin prec) (Znearest choice) x - x)%R. 32 | split. 33 | apply Rle_trans with (/2*ulp beta (FLT_exp emin prec) x)%R. 34 | apply error_le_half_ulp. 35 | now apply FLT_exp_valid. 36 | apply Rmult_le_compat_l; auto with real. 37 | rewrite ulp_neq_0 by lra. 38 | apply bpow_le. 39 | unfold FLT_exp, cexp. 40 | rewrite Zmax_right. 41 | lia. 42 | destruct (mag beta x) as (e,He); simpl. 43 | assert (e-1 < emin+prec)%Z. 44 | apply (lt_bpow beta). 45 | apply Rle_lt_trans with (2:=Hx). 46 | rewrite <- (Rabs_right x). 47 | apply He; auto with real. 48 | apply Rle_ge; now left. 49 | lia. 50 | unfold fexp. ring. 51 | Qed. 52 | 53 | Import Morphisms. 54 | 55 | Global Instance Znearest_proper: Proper ((eq ==> eq) ==> eq ==> eq) Znearest. 56 | Proof. 57 | do 3 red. 58 | intros a b Hab u v Huv. 59 | subst. 60 | unfold Znearest. 61 | destruct (Rcompare (v - IZR (Zfloor v)) (/ 2)); auto. 62 | replace (b (Zfloor v)) with (a (Zfloor v)) by auto. 63 | reflexivity. 64 | Qed. 65 | 66 | Corollary absolute_error_N_FLT beta choice: 67 | forall x, 68 | Rabs x < bpow beta (emin + prec) -> 69 | exists eta, 70 | (Rabs eta <= /2 * Raux.bpow beta (emin))%R /\ 71 | Generic_fmt.round beta fexp (Generic_fmt.Znearest choice) x = (x + eta)%R. 72 | Proof. 73 | intros. 74 | destruct (Req_dec x 0). 75 | { 76 | subst. 77 | rewrite round_0; try typeclasses eauto. 78 | exists 0. 79 | split; try ring. 80 | rewrite Rabs_R0. 81 | generalize (bpow_ge_0 beta emin); lra. 82 | } 83 | destruct (Rle_dec x 0). 84 | { 85 | rewrite Rabs_left in H by lra. 86 | assert (0 < - x) by lra. 87 | destruct (absolute_error_N_FLT_aux _ (fun t => negb (choice (- (t + 1))%Z)) _ H1 H) as (eta & Heta & EQ). 88 | rewrite round_N_opp in EQ. 89 | apply (f_equal Ropp) in EQ. 90 | rewrite Ropp_involutive in EQ. 91 | exists (- eta). 92 | split. 93 | { 94 | rewrite Rabs_Ropp. 95 | assumption. 96 | } 97 | refine (eq_trans _ (eq_trans EQ _)). 98 | { 99 | apply round_ext. 100 | intros. 101 | apply Znearest_proper; auto. 102 | red. intros; subst. 103 | rewrite Bool.negb_involutive. 104 | f_equal. 105 | ring. 106 | } 107 | ring. 108 | } 109 | rewrite Rabs_right in H by lra. 110 | eapply absolute_error_N_FLT_aux; eauto. 111 | lra. 112 | Qed. 113 | 114 | End I3E. 115 | 116 | Lemma FLT_format_mult_beta beta emin prec x: 117 | FLT.FLT_format beta emin prec x -> 118 | FLT.FLT_format beta emin prec (IZR (Zaux.radix_val beta) * x) 119 | . 120 | Proof. 121 | intros [f Hx mantissa exponent]. 122 | subst. 123 | exists (Defs.Float _ (Defs.Fnum f) (Defs.Fexp f + 1)). 124 | simpl. 125 | unfold Defs.F2R. 126 | simpl. 127 | rewrite Core.Raux.bpow_plus_1. 128 | ring. auto. simpl. lia. 129 | Qed. 130 | 131 | Lemma FLT_format_div_beta beta emin prec 132 | (Hprec: (0 <= prec)%Z) x: 133 | FLT.FLT_format beta emin prec x -> 134 | Core.Raux.bpow beta (emin + prec) <= Rabs x -> 135 | FLT.FLT_format beta emin prec (x / IZR (Zaux.radix_val beta)) 136 | . 137 | Proof. 138 | intros [f Hx mantissa exponent]. 139 | subst. 140 | exists (Defs.Float _ (Defs.Fnum f) (Defs.Fexp f - 1)); auto. 141 | - 142 | unfold Defs.F2R. 143 | simpl. 144 | replace (Defs.Fexp f) with (Defs.Fexp f - 1 + 1)%Z at 1 by ring. 145 | rewrite bpow_plus_1. 146 | field. 147 | apply IZR_neq. 148 | generalize (Zaux.radix_gt_0 beta). lia. 149 | - 150 | simpl. 151 | destruct (Z.eq_dec emin (Defs.Fexp f)); try lia. 152 | exfalso. 153 | clear exponent. 154 | subst. 155 | revert H. 156 | unfold Defs.F2R. 157 | rewrite Rabs_mult. 158 | rewrite bpow_plus. 159 | rewrite (Rmult_comm (Raux.bpow _ _)). 160 | generalize (Raux.bpow_gt_0 beta (Defs.Fexp f)). 161 | intro. 162 | rewrite (Rabs_right (Raux.bpow _ _)) by lra. 163 | intro K. 164 | apply Rmult_le_reg_r in K; auto. 165 | rewrite <- Raux.IZR_Zpower in K by assumption. 166 | repeat rewrite IZR_IZR in K. 167 | rewrite Rabs_Zabs in K. 168 | apply le_IZR in K. 169 | lia. 170 | Qed. 171 | -------------------------------------------------------------------------------- /vcfloat/LibTac.v: -------------------------------------------------------------------------------- 1 | (* LGPL licensed; see ../LICENSE and, for historical notes, see ../OLD_LICENSE *) 2 | 3 | (** R-CoqLib: general-purpose Coq libraries and tactics. *) 4 | (** Basic tactics and logical properties. *) 5 | 6 | Ltac break K := 7 | match type of K with 8 | exists x, _ => 9 | let x := fresh "x" in 10 | destruct K as [x K]; 11 | break K 12 | | _ /\ _ => 13 | let K_ := fresh "K_" in 14 | destruct K as (K_ & K); 15 | break K_; 16 | break K 17 | | _ => idtac 18 | end. 19 | 20 | Lemma exists_and {T: Type} (P: T -> Prop) (Q: Prop): 21 | (exists x, (P x /\ Q)) -> 22 | (exists x, P x) /\ Q. 23 | Proof. 24 | intro H. 25 | break H. 26 | eauto. 27 | Qed. 28 | 29 | Lemma exists_and_assoc {T: Type} (P Q R: T -> Prop): 30 | (exists x, P x /\ Q x /\ R x) -> 31 | exists x, (P x /\ Q x) /\ R x. 32 | Proof. 33 | intro H. 34 | break H. 35 | eauto. 36 | Qed. 37 | 38 | Definition option_eqb {T} (eqb: T -> T -> bool) u1 u2 := 39 | match u1, u2 with 40 | | Some t1, Some t2 => eqb t1 t2 41 | | None, None => true 42 | | _, _ => false 43 | end. 44 | 45 | Require Setoid. 46 | 47 | Lemma option_eqb_eq {T} {eqb: T -> T -> bool}: 48 | (forall t1 t2, eqb t1 t2 = true <-> t1 = t2) -> 49 | (forall u1 u2, option_eqb eqb u1 u2 = true <-> u1 = u2). 50 | Proof. 51 | intros. 52 | destruct u1; destruct u2; simpl; try intuition congruence. 53 | rewrite H. 54 | intuition congruence. 55 | Qed. 56 | 57 | Ltac solve_trivial := 58 | match goal with 59 | |- _ /\ _ => split; [ exact I | ]; try solve_trivial 60 | | |- _ /\ _ => split; [ reflexivity | ]; try solve_trivial 61 | | |- _ /\ _ => split; [ eassumption | ]; try solve_trivial 62 | | |- exists _, _ => esplit; solve_trivial 63 | end. 64 | 65 | Definition eqpivot {A} (a: A): 66 | {o | a = o /\ o = a}. 67 | Proof. 68 | exists a; auto. 69 | Defined. 70 | 71 | 72 | Require Import Coq.Lists.List. 73 | 74 | Fixpoint list_forall {T} (P: T -> Prop) (l: list T): Prop := 75 | match l with 76 | | nil => True 77 | | a :: nil => P a 78 | | a :: l => P a /\ list_forall P l 79 | end. 80 | 81 | 82 | Lemma list_forall_spec {T} (P: T -> Prop) l: 83 | list_forall P l <-> (forall t, In t l -> P t). 84 | Proof. 85 | induction l. 86 | { 87 | simpl. 88 | tauto. 89 | } 90 | destruct l. 91 | { 92 | simpl in *. 93 | firstorder. 94 | congruence. 95 | } 96 | change (list_forall P (a :: t :: l)) with (P a /\ list_forall P (t :: l)). 97 | revert IHl. 98 | generalize (t :: l). 99 | clear t l. 100 | simpl. 101 | firstorder. 102 | congruence. 103 | Qed. 104 | 105 | Lemma list_forall_impl {T} (P Q: T -> Prop): 106 | (forall t, (P t -> Q t)) -> 107 | (forall l, (list_forall P l -> list_forall Q l)). 108 | Proof. 109 | intros. 110 | induction l. 111 | { 112 | simpl. 113 | tauto. 114 | } 115 | destruct l. 116 | { 117 | simpl. 118 | auto. 119 | } 120 | change (list_forall P (a :: t :: l)) with (P a /\ list_forall P (t :: l)) in H0. 121 | change (list_forall Q (a :: t :: l)) with (Q a /\ list_forall Q (t :: l)). 122 | revert IHl H0. 123 | generalize (t :: l). 124 | clear t l. 125 | firstorder. 126 | Qed. 127 | 128 | Lemma list_forall_ext {T} (P Q: T -> Prop): 129 | (forall t, (P t <-> Q t)) -> 130 | (forall l, (list_forall P l <-> list_forall Q l)). 131 | Proof. 132 | intros. 133 | generalize (list_forall_impl P Q). 134 | generalize (list_forall_impl Q P). 135 | firstorder. 136 | Qed. 137 | 138 | Lemma list_forall_nil {T} (P: T -> Prop): 139 | list_forall P nil. 140 | Proof. 141 | exact I. 142 | Qed. 143 | 144 | Lemma list_forall_cons {T} (P: T -> Prop) a l: 145 | P a -> 146 | list_forall P l -> 147 | list_forall P (a :: l). 148 | Proof. 149 | intros. 150 | destruct l; simpl; auto. 151 | Qed. 152 | 153 | Lemma list_forall_cons_inv {T} (P: T -> Prop) a l: 154 | list_forall P (a :: l) -> P a /\ list_forall P l. 155 | Proof. 156 | destruct l; simpl; auto. 157 | Qed. 158 | 159 | Lemma list_forall_app {T} (P: T -> Prop) l1 l2: 160 | list_forall P l1 -> 161 | list_forall P l2 -> 162 | list_forall P (l1 ++ l2). 163 | Proof. 164 | induction l1; auto. 165 | intros. 166 | apply list_forall_cons_inv in H. 167 | apply list_forall_cons; intuition. 168 | Qed. 169 | 170 | 171 | Definition sumbool_to_bool {A B} (u: {A} + {B}): bool := 172 | if u then true else false. 173 | 174 | Coercion sumbool_to_bool: sumbool >-> bool. 175 | 176 | Require Import ZArith Reals vcfloat.RAux. 177 | Import Coq.Lists.List. 178 | 179 | Lemma rememb {A} (a: A): {x | x = a}. 180 | Proof. 181 | eauto. 182 | Qed. 183 | Require Export Morphisms. 184 | 185 | Definition rememb_gen {A: Type} (R: A -> A -> Prop) {refl: Reflexive R} (a: A): 186 | {a_: A | R a a_ /\ R a_ a}. 187 | Proof. 188 | exists a; eauto. 189 | Defined. 190 | 191 | Lemma exists_modus_ponens {T} (Q P R: _ -> Prop): 192 | (exists s1: T, P s1 /\ Q s1) -> 193 | (forall s1, Q s1 -> R s1) -> 194 | exists s1, 195 | P s1 /\ R s1. 196 | Proof. 197 | firstorder. 198 | Qed. 199 | 200 | Lemma if_bool_eq_dec (b: bool): 201 | {b_: bool & {u : {b_ = true} + {~ (b_ = true)} | 202 | (b_ = true <-> b = true) /\ 203 | (forall (A: Type) (a1 a2: A), 204 | (if b then a1 else a2) = if u then a1 else a2) } }. 205 | Proof. 206 | exists b. 207 | destruct b; simpl. 208 | { 209 | exists (left Logic.eq_refl). 210 | tauto. 211 | } 212 | exists (@right _ (false <> true) ltac:( discriminate ) ). 213 | tauto. 214 | Defined. 215 | 216 | Lemma asplit (P Q: Prop): 217 | P -> (P -> Q) -> (P /\ Q). 218 | Proof. 219 | tauto. 220 | Qed. 221 | 222 | Ltac specialize_assert H := 223 | match type of H with 224 | ?P -> _ => 225 | let K := fresh in 226 | assert P as K; [ | specialize (H K); clear K ] 227 | end. 228 | 229 | Ltac vm_compute_with_meta := 230 | match goal with 231 | |- ?z = _ => 232 | let b := fresh "b" in 233 | let Hb := fresh "Hb" in 234 | destruct (rememb z) as (b & Hb); 235 | rewrite <- Hb; 236 | vm_compute in Hb; 237 | eexact Hb 238 | end. 239 | -------------------------------------------------------------------------------- /vcfloat/Makefile: -------------------------------------------------------------------------------- 1 | # This Makefile assumes that coq already has access to 2 | # Flocq, Interval, CompCert, etc., 3 | # which will be true if coq was installed through opam 4 | # or as a "Coq Platform" package. 5 | 6 | COQC=coqc 7 | COQDEP=coqdep 8 | COQFLAGS := $(shell cat _CoqProject) 9 | COQEXTRAFLAGS?= 10 | 11 | target: vcfloat2 tests 12 | 13 | tests: ../Test/Test.vo ../Test/TestFunc.vo ../Test/TestPaper.vo ../Test/Test2.vo ../Test/summation.vo ../Test/autobisect.vo ../Test/Nonstd.vo 14 | 15 | # the vcfloat2 target is the core VCFloat tool for VCFloat2 users who don't need 16 | # CompCert-based reification 17 | vcfloat2: VCFloat.vo FPCompCert.vo Version.vo FPLib.vo FPStdLib.vo FPStdCompCert.vo 18 | 19 | %.vo: %.v 20 | $(COQC) $(COQFLAGS) $(COQEXTRAFLAGS) $*.v 21 | 22 | INSTALLFILES ?= $(shell make -Bn vcfloat2 2>/dev/null | awk '/^coqc.*v$$/{print $$NF"o"}') 23 | 24 | # all the "realpath" complexity in the next line is to make it work on cygwin as well as regular unix 25 | INSTALLDIR ?= $(shell realpath `coqc -where` | tr -d [:space:])/user-contrib/vcfloat 26 | 27 | install: vcfloat2 28 | install -d $(INSTALLDIR) 29 | install -m 0644 $(INSTALLFILES) $(INSTALLDIR) 30 | 31 | depend: 32 | $(COQDEP) $(COQFLAGS) *.v ../Test/*.v > .depend 33 | 34 | ifneq ($(MAKECMDGOALS),depend) 35 | ifneq ($(MAKECMDGOALS),clean) 36 | include .depend 37 | endif 38 | endif 39 | 40 | all_clean: 41 | rm *.vo *.vok *.vos *.glob 42 | 43 | 44 | clean: 45 | rm -f {*,*/*}.{vo,vo?,glob} 46 | -------------------------------------------------------------------------------- /vcfloat/Q2RAux.v: -------------------------------------------------------------------------------- 1 | (* LGPL licensed; see ../LICENSE and, for historical notes, see ../OLD_LICENSE *) 2 | (* Helpers for computing in rational numbers. *) 3 | 4 | Require Export QArith Qreals Flocq.Core.Raux Reals. 5 | Open Scope R_scope. 6 | 7 | Global Instance Q2R_proper: 8 | Proper (Qeq ==> eq) Q2R. 9 | Proof. 10 | do 2 red. 11 | intros. 12 | apply Qreals.Qeq_eqR. 13 | assumption. 14 | Qed. 15 | 16 | Lemma Q2R_inject_Z n: 17 | Q2R (inject_Z n) = IZR n. 18 | Proof. 19 | unfold Q2R. 20 | simpl. 21 | field. 22 | Qed. 23 | -------------------------------------------------------------------------------- /vcfloat/Reify.v: -------------------------------------------------------------------------------- 1 | (* LGPL licensed; see ../LICENSE and, for historical notes, see ../OLD_LICENSE *) 2 | 3 | From vcfloat Require Export RAux. 4 | From Flocq Require Import Binary Bits Core. 5 | From vcfloat Require Import IEEE754_extra klist. 6 | Require compcert.lib.Maps. 7 | Require Coq.MSets.MSetAVL. 8 | Require vcfloat.Fprop_absolute. 9 | Require Import vcfloat.Float_lemmas. 10 | Set Bullet Behavior "Strict Subproofs". 11 | Global Unset Asymmetric Patterns. 12 | 13 | 14 | Require Import vcfloat.FPCore vcfloat.FPLang. 15 | Require Import vcfloat.Float_notations. 16 | Import Coq.Lists.List. 17 | 18 | Definition ident := positive. 19 | 20 | Definition placeholder32: ident -> ftype Tsingle. intro. apply 0%F32. Qed. 21 | 22 | Definition placeholderx ty: ident -> {x: ftype ty | is_finite x = true}. 23 | intros. 24 | destruct ty as [? ? ? ? ? [|]]. 25 | exists (nonstd_nonempty n). 26 | simpl. 27 | pose proof (nonstd_nonempty_finite n). 28 | destruct (nonstd_to_F _); auto; contradiction. 29 | exists (ftype_of_float (B754_zero _ _ false)). 30 | reflexivity. 31 | Qed. 32 | 33 | Definition placeholder ty i : ftype ty := proj1_sig (placeholderx ty i). 34 | 35 | Definition func {ty} (f: floatfunc_package ty) := ff_func (ff_ff f). 36 | Ltac apply_func ff := 37 | let f := constr:(func ff) in 38 | match type of f with ?t => 39 | let t' := eval hnf in t in 40 | let t' := eval cbv [function_type map ftype'] in t' in 41 | let f' := constr:(f : t') in 42 | exact f' 43 | end. 44 | 45 | 46 | Ltac ground_pos p := 47 | match p with 48 | | Z.pos ?p' => ground_pos p' 49 | | xH => constr:(tt) 50 | | xI ?p' => ground_pos p' 51 | | xO ?p' => ground_pos p' 52 | end. 53 | 54 | Ltac find_type prec emax := 55 | match prec with 56 | | 24%Z => match emax with 128%Z => constr:(Tsingle) end 57 | | 53%Z => match emax with 1024%Z => constr:(Tdouble) end 58 | | Z.pos ?precp => 59 | let g := ground_pos precp in let g := ground_pos emax in 60 | constr:(TYPE precp emax Logic.I Logic.I) 61 | end. 62 | 63 | Ltac prove_incollection := 64 | lazymatch goal with |- @incollection ?coll ?ty => 65 | auto with typeclass_instances; red; try apply I; 66 | repeat (try (left; reflexivity); right); 67 | fail "Failed to prove incollection" coll ty "; that is, the type is a nonstandard type that does not appear to be declared in your collection" 68 | end. 69 | 70 | Ltac reify_float_expr E := 71 | match E with 72 | | placeholder32 ?i => constr:(Var Tsingle ltac:(prove_incollection) i) 73 | | placeholder ?ty ?i => constr:(@Var ltac:(auto with typeclass_instances) ty ltac:(prove_incollection) i) 74 | | Zconst ?t ?z => constr:(Const t I (Zconst t z)) 75 | | BPLUS ?a ?b => let a' := reify_float_expr a in let b' := reify_float_expr b in 76 | constr:(Binop (Rounded2 PLUS None) a' b') 77 | | Norm (BPLUS ?a ?b) => let a' := reify_float_expr a in let b' := reify_float_expr b in 78 | constr:(Binop (Rounded2 PLUS (Some Normal)) a' b') 79 | | Denorm (BPLUS ?a ?b) => let a' := reify_float_expr a in let b' := reify_float_expr b in 80 | constr:(Binop (Rounded2 PLUS (Some Denormal)) a' b') 81 | | BMINUS ?a ?b => let a' := reify_float_expr a in let b' := reify_float_expr b in 82 | constr:(Binop (Rounded2 MINUS None) a' b') 83 | | Norm (BMINUS ?a ?b) => let a' := reify_float_expr a in let b' := reify_float_expr b in 84 | constr:(Binop (Rounded2 MINUS (Some Normal)) a' b') 85 | | Denorm (BMINUS ?a ?b) => let a' := reify_float_expr a in let b' := reify_float_expr b in 86 | constr:(Binop (Rounded2 MINUS (Some Denormal)) a' b') 87 | | BMULT ?a ?b => let a' := reify_float_expr a in let b' := reify_float_expr b in 88 | constr:(Binop (Rounded2 MULT None) a' b') 89 | | Norm (BMULT ?a ?b) => let a' := reify_float_expr a in let b' := reify_float_expr b in 90 | constr:(Binop (Rounded2 MULT (Some Normal)) a' b') 91 | | Denorm (BMULT ?a ?b) => let a' := reify_float_expr a in let b' := reify_float_expr b in 92 | constr:(Binop (Rounded2 MULT (Some Denormal)) a' b') 93 | | BDIV ?a ?b => let a' := reify_float_expr a in let b' := reify_float_expr b in 94 | constr:(Binop (Rounded2 DIV None) a' b') 95 | | Norm (BDIV ?a ?b) => let a' := reify_float_expr a in let b' := reify_float_expr b in 96 | constr:(Binop (Rounded2 DIV (Some Normal)) a' b') 97 | | Denorm (BDIV ?a ?b) => let a' := reify_float_expr a in let b' := reify_float_expr b in 98 | constr:(Binop (Rounded2 DIV (Some Denormal)) a' b') 99 | | BOPP ?a => let a' := reify_float_expr a in 100 | constr:(Unop (Exact1 Opp) a') 101 | | BABS ?a => let a' := reify_float_expr a in 102 | constr:(Unop (Exact1 Abs) a') 103 | | BSQRT ?a => let a' := reify_float_expr a in 104 | constr:(Unop (Rounded1 SQRT) a') 105 | | @cast _ Tsingle Tdouble ?f => let f':= reify_float_expr f in 106 | constr:(Cast Tdouble Tsingle None f') 107 | | @cast _ Tdouble Tsingle ?f => let f':= reify_float_expr f in 108 | constr:(Cast Tsingle Tdouble None f') 109 | | @cast _ Tsingle Tsingle ?f => let f':= reify_float_expr f in 110 | constr:(f') 111 | | @cast _ Tdouble Tdouble ?f => let f':= reify_float_expr f in 112 | constr:(f') 113 | | b32_B754_zero _ => constr:(Const Tsingle I E) 114 | | b64_B754_zero _ => constr:(Const Tdouble I E) 115 | | b64_B754_finite _ _ _ _ => constr:(Const Tdouble I E) 116 | | b32_B754_finite _ _ _ _ => constr:(Const Tsingle I E) 117 | | b64_B754_finite _ _ _ _ => constr:(Const Tdouble I E) 118 | | Sterbenz (BMINUS ?a ?b) => let a' := reify_float_expr a in let b' := reify_float_expr b in 119 | constr:(Binop SterbenzMinus a' b') 120 | | @func ?ty ?ff ?a1 => let a1' := reify_float_expr a1 in 121 | constr:(Func ty ff (Kcons a1' Knil)) 122 | | @func ?ty ?ff ?a1 ?a2 => let a1' := reify_float_expr a1 in 123 | let a2' := reify_float_expr a2 in 124 | constr:(Func ty ff (Kcons a1' (Kcons a2' Knil))) 125 | | @func ?ty ?ff ?a1 ?a2 ?a3 => let a1' := reify_float_expr a1 in 126 | let a2' := reify_float_expr a2 in 127 | let a3' := reify_float_expr a3 in 128 | constr:(Func ty ff (Kcons a1' (Kcons a2' (Kcons a3' Knil)))) 129 | | _ => let E' := eval red in E in reify_float_expr E' 130 | | _ => fail 100 "could not reify" E 131 | end. 132 | 133 | Ltac HO_reify_float_expr names E := 134 | lazymatch names with 135 | | ?n :: ?names' => 136 | lazymatch (type of E) with 137 | | ftype ?ty -> _ => 138 | let Ev := constr:(E (placeholder ty n)) in 139 | HO_reify_float_expr names' Ev 140 | | _ => fail 100 "could not reify" E 141 | end 142 | | nil => reify_float_expr E 143 | end. 144 | 145 | Ltac unfold_reflect := 146 | match goal with |- context [fval ?A ?B] => 147 | pattern (fval A B); 148 | match goal with |- ?M _ => 149 | let X := fresh "X" in set (X := M); 150 | cbv beta iota delta [ 151 | fval fop_of_binop fop_of_rounded_binop 152 | fop_of_unop fop_of_rounded_unop fop_of_exact_unop 153 | ]; 154 | repeat change (cast ?a _ ?x) with x; 155 | subst X; cbv beta 156 | end 157 | end. 158 | -------------------------------------------------------------------------------- /vcfloat/Summation.v: -------------------------------------------------------------------------------- 1 | (* LGPL licensed; see ../LICENSE and, for historical notes, see ../OLD_LICENSE *) 2 | 3 | (** 4 | Accumulation of rounding errors for naive summation. 5 | 6 | For more technical information, you can read Section 5.4 of our paper 7 | published at ACM/SIGPLAN Certified Programs and Proofs (CPP) 2016: 8 | 9 | Tahina Ramananandro, Paul Mountcastle, Benoit Meister and Richard 10 | Lethin. 11 | A Unified Coq Framework for Verifying C Programs with Floating-Point 12 | Computations 13 | 14 | *) 15 | 16 | Require Import Arith ZArith Reals Psatz Morphisms. 17 | Open Scope R_scope. 18 | 19 | Class Sum (Sf: (nat -> R) -> nat -> R): Prop := 20 | { 21 | SfO: forall f, Sf f O = 0; 22 | SfS: forall f n, Sf f (S n) = Sf f n + f n 23 | }. 24 | 25 | Section S. 26 | 27 | Context `{SUM: Sum}. 28 | 29 | Lemma Sf_ext: forall n f1 f2, 30 | (forall i, (i < n)%nat -> f1 i = f2 i) -> 31 | Sf f1 n = Sf f2 n. 32 | Proof. 33 | induction n; intros; simpl. 34 | { 35 | repeat rewrite SfO. reflexivity. 36 | } 37 | repeat rewrite SfS. 38 | f_equal; auto. 39 | Qed. 40 | 41 | Lemma Sf_left n: 42 | forall f, 43 | Sf f (S n) = f O + Sf (fun i => f (S i)) n. 44 | Proof. 45 | induction n; intros. 46 | { 47 | rewrite SfS. 48 | repeat rewrite SfO. 49 | ring. 50 | } 51 | rewrite SfS. 52 | rewrite IHn. 53 | rewrite Rplus_assoc. 54 | f_equal. 55 | rewrite SfS. 56 | reflexivity. 57 | Qed. 58 | 59 | Lemma Sf_inv n: 60 | forall f, 61 | Sf f n = Sf (fun i => f (n - S i)%nat) n. 62 | Proof. 63 | induction n; intros. 64 | { 65 | repeat rewrite SfO. 66 | reflexivity. 67 | } 68 | rewrite Sf_left. 69 | rewrite SfS. 70 | rewrite Rplus_comm. 71 | f_equal. 72 | { 73 | rewrite IHn. 74 | apply Sf_ext. 75 | intros. 76 | f_equal. 77 | lia. 78 | } 79 | f_equal. 80 | lia. 81 | Qed. 82 | 83 | Lemma Sf_scal x f n: 84 | Sf f n * x = Sf (fun i => x * f i) n. 85 | Proof. 86 | induction n. 87 | { 88 | repeat rewrite SfO. 89 | ring. 90 | } 91 | repeat rewrite SfS. 92 | rewrite Rmult_plus_distr_r. 93 | rewrite IHn. 94 | ring. 95 | Qed. 96 | 97 | Definition sumOfPowers x := Sf (pow x). 98 | Definition sumOfPowersO x: sumOfPowers x O = 0 := SfO _. 99 | Definition sumOfPowersS x n: sumOfPowers x (S n) = sumOfPowers x n + x ^ n := SfS _ _. 100 | 101 | Section U. 102 | 103 | Variable x: R. 104 | Local Notation u := (sumOfPowers x). 105 | Let uO: u O = 0 := sumOfPowersO _. 106 | Let uS n: u (S n) = u n + x ^ n := sumOfPowersS _ _. 107 | 108 | Hypothesis x_ne_1: x <> 1. 109 | 110 | Lemma u_eq n: u n = (1 - x ^ n) / (1 - x). 111 | Proof. 112 | induction n. 113 | { 114 | rewrite uO. 115 | simpl. 116 | unfold Rdiv. 117 | ring. 118 | } 119 | rewrite uS. 120 | rewrite IHn. 121 | simpl. 122 | field. 123 | lra. 124 | Qed. 125 | 126 | Lemma u_x n: 127 | u n * x = u (S n) - 1. 128 | Proof. 129 | unfold u. rewrite Sf_left. simpl. 130 | match goal with 131 | |- _ = ?z => match z with 132 | 1 + ?y - 1 => replace z with y by ring 133 | end end. 134 | apply Sf_scal. 135 | Qed. 136 | 137 | End U. 138 | 139 | Definition sumOfIPowers x := Sf (fun i => INR (S i) * pow x i). 140 | Definition sumOfIPowersO x: sumOfIPowers x O = 0 := SfO _. 141 | Definition sumOfIPowersS x n: sumOfIPowers x (S n) = sumOfIPowers x n + INR (S n) * x ^ n := SfS _ _. 142 | 143 | Section SUMDERIV. 144 | 145 | Variable x: R. 146 | Local Notation v := (sumOfIPowers x). 147 | Let v0: v O = 0 := sumOfIPowersO _. 148 | Let vS n: v (S n) = v n + INR (S n) * pow x n := sumOfIPowersS _ _. 149 | 150 | Hypothesis x_ne_1: x <> 1. 151 | 152 | Lemma v_eq n: 153 | v n = (INR n * x ^ (S n) - INR (S n) * x ^ n + 1) / (1 - x) ^ 2. 154 | Proof. 155 | induction n. 156 | { 157 | rewrite v0. 158 | simpl. 159 | field. 160 | lra. 161 | } 162 | rewrite vS. 163 | rewrite IHn. 164 | repeat rewrite S_INR. 165 | simpl. 166 | field. 167 | lra. 168 | Qed. 169 | 170 | End SUMDERIV. 171 | 172 | Class prop (K L M: R) (D: nat -> R): Prop := 173 | { 174 | DO: D O = 0; 175 | DS: forall n, D (S n) = D n * M + INR n * L + K 176 | }. 177 | 178 | Context {D_} {PROP: forall K L M, prop K L M (D_ K L M)}. 179 | 180 | Section S. 181 | 182 | Context (K L M: R). 183 | 184 | Local Notation D := (D_ K L M). 185 | 186 | Section WITH_M_hyp. 187 | 188 | Hypothesis M_neq_0: M <> 0. 189 | 190 | Lemma D_eq_aux' n: 191 | D (S (S n)) = K * sumOfPowers M (S (S n)) + L * M ^ n * sumOfIPowers (/ M) (S n). 192 | Proof. 193 | induction n. 194 | { 195 | repeat rewrite DS. 196 | rewrite DO. 197 | repeat rewrite sumOfPowersS. 198 | rewrite sumOfPowersO. 199 | repeat rewrite sumOfIPowersS. 200 | rewrite sumOfIPowersO. 201 | simpl. 202 | ring. 203 | } 204 | rewrite DS. 205 | rewrite IHn; clear IHn. 206 | repeat rewrite sumOfPowersS. 207 | repeat rewrite sumOfIPowersS. 208 | repeat rewrite S_INR. 209 | simpl. 210 | rewrite <- Rinv_pow by assumption. 211 | ring_simplify. 212 | rewrite Rmult_assoc. 213 | rewrite u_x. 214 | rewrite sumOfPowersS. 215 | field. 216 | split; auto. 217 | apply pow_nonzero. 218 | assumption. 219 | Qed. 220 | 221 | Hypothesis M_neq_1: M <> 1. 222 | 223 | Let InvM_neq_1: / M <> 1. 224 | Proof. 225 | intro ABS. 226 | generalize (f_equal Rinv ABS). 227 | rewrite Rinv_involutive by assumption. 228 | rewrite Rinv_1. 229 | assumption. 230 | Qed. 231 | 232 | Lemma tech_invert_square u: 233 | u / (1 - / M) ^ 2 = u * M ^ 2 / (1 - M) ^ 2. 234 | Proof. 235 | field. 236 | lra. 237 | Qed. 238 | 239 | Lemma tech1 n: D (S (S n)) = K * ((1 - M ^ S (S n)) / (1 - M)) + L * (INR (S n) - INR (S (S n)) * M + M ^ S (S n)) / (1 - M) ^ 2. 240 | rewrite D_eq_aux'. 241 | rewrite u_eq by assumption. 242 | rewrite v_eq by assumption. 243 | f_equal. 244 | rewrite tech_invert_square. 245 | unfold Rdiv. 246 | rewrite Rmult_assoc. 247 | symmetry. 248 | rewrite Rmult_assoc. 249 | f_equal. 250 | rewrite <- Rmult_assoc. 251 | f_equal. 252 | symmetry. 253 | replace (S (S n)) with (n + 2)%nat at 1 4 by lia. 254 | repeat rewrite pow_add. 255 | rewrite <- (tech_pow_Rmult (/ M) n). 256 | repeat rewrite <- Rinv_pow by assumption. 257 | field. 258 | split; auto. 259 | apply pow_nonzero. 260 | assumption. 261 | Qed. 262 | 263 | Lemma tech2 n: 264 | D (S (S n)) = K * ((1 - M ^ S (S n)) / (1 - M)) + L * (INR (S (S n)) - 1 - INR (S (S n)) * M + M ^ S (S n)) / (1 - M) ^ 2. 265 | Proof. 266 | rewrite tech1. 267 | repeat rewrite S_INR. 268 | field. 269 | lra. 270 | Qed. 271 | 272 | Lemma tech3 n: 273 | D n = K * ((1 - M ^ n) / (1 - M)) + L * (INR n * (1 - M) - 1 + M ^ n) / (1 - M) ^ 2. 274 | Proof. 275 | destruct n. 276 | { 277 | rewrite DO. 278 | simpl. 279 | unfold Rdiv. 280 | ring. 281 | } 282 | destruct n. 283 | { 284 | rewrite DS. 285 | rewrite DO. 286 | simpl. 287 | field. 288 | lra. 289 | } 290 | rewrite tech2. 291 | field. 292 | lra. 293 | Qed. 294 | 295 | Definition E n := (1 - M ^ n) / (1 - M) * (K - L / (1 - M)) + L * INR n / (1 - M). 296 | 297 | Theorem D_eq_aux n: 298 | D n = E n. 299 | Proof. 300 | unfold E. 301 | rewrite tech3. 302 | field. 303 | lra. 304 | Qed. 305 | 306 | End WITH_M_hyp. 307 | 308 | Theorem D_eq: 309 | M <> 1 -> 310 | forall n, 311 | D n = E n. 312 | Proof. 313 | intros HM n. 314 | destruct (Req_dec M 0) as [EQ | ]. 315 | { 316 | unfold E. 317 | rewrite EQ. 318 | destruct n. 319 | { 320 | simpl. 321 | rewrite DO. 322 | field. 323 | } 324 | rewrite DS. 325 | rewrite S_INR. 326 | simpl. 327 | field. 328 | } 329 | apply D_eq_aux; auto. 330 | Qed. 331 | 332 | End S. 333 | 334 | Lemma ub f M: 335 | (forall n, f n <= M) -> 336 | forall n, Sf f n <= INR n * M. 337 | Proof. 338 | induction n. 339 | { 340 | rewrite SfO. simpl. apply Req_le. ring. 341 | } 342 | rewrite SfS. rewrite S_INR. 343 | rewrite Rmult_plus_distr_r. 344 | rewrite Rmult_1_l. 345 | apply Rplus_le_compat; auto. 346 | Qed. 347 | 348 | Lemma ub_abs f M: 349 | (forall n, Rabs (f n) <= M) -> 350 | forall n, Rabs (Sf f n) <= INR n * M. 351 | Proof. 352 | induction n. 353 | { 354 | rewrite SfO. simpl. rewrite Rabs_R0. 355 | apply Req_le. lra. 356 | } 357 | rewrite SfS. rewrite S_INR. 358 | rewrite Rmult_plus_distr_r. 359 | rewrite Rmult_1_l. 360 | eapply Rle_trans. 361 | { 362 | apply Rabs_triang. 363 | } 364 | apply Rplus_le_compat; auto. 365 | Qed. 366 | 367 | (* Total error of a rounded sum of approximate terms *) 368 | 369 | Theorem error_rounded_sum_with_approx Q q Q_ q_ d e Mq Mdq Md Me n: 370 | Rabs q <= Mq -> 371 | Rabs d <= Md -> 372 | Rabs e <= Me -> 373 | Rabs (q_ - q) <= Mdq -> 374 | Rabs Q <= INR n * Mq -> 375 | let M := 1 + Md in 376 | let L := (Mq * Md) in 377 | let K := (Mq * Md + Mdq * (1 + Md) + Me) in 378 | Rabs (Q_ - Q) <= D_ K L M n -> 379 | Rabs ((Q_ + q_) * (1 + d) + e - (Q + q)) <= D_ K L M (S n). 380 | Proof. 381 | intros H H0 H1 H2 H3 M L K H4. 382 | pose (dq := q_ - q). 383 | assert 384 | ((Q_ + q_) * (1 + d) + e - (Q + q) 385 | = (Q_ - Q) * (1 + d) + Q * d + (q * d + dq * (1 + d) + e)) 386 | as V_m_U. 387 | { 388 | unfold dq. 389 | ring. 390 | } 391 | assert 392 | (Rabs ((Q_ + q_) * (1 + d) + e - (Q + q)) <= Rabs (Q_ - Q) * M + INR n * L + K) 393 | as V_m_U_le. 394 | { 395 | unfold K, L, M. 396 | rewrite V_m_U. 397 | eapply Rle_trans. 398 | { 399 | apply Rabs_triang. 400 | } 401 | apply Rplus_le_compat. 402 | { 403 | eapply Rle_trans. 404 | { 405 | apply Rabs_triang. 406 | } 407 | apply Rplus_le_compat. 408 | { 409 | rewrite Rabs_mult. 410 | apply Rmult_le_compat_l; auto using Rabs_pos. 411 | eapply Rle_trans. 412 | { 413 | apply Rabs_triang. 414 | } 415 | rewrite Rabs_R1. 416 | apply Rplus_le_compat_l; auto. 417 | } 418 | rewrite Rabs_mult. 419 | rewrite <- Rmult_assoc. 420 | apply Rmult_le_compat; auto using Rabs_pos. 421 | } 422 | eapply Rle_trans. 423 | { 424 | apply Rabs_triang. 425 | } 426 | apply Rplus_le_compat; auto. 427 | eapply Rle_trans. 428 | { 429 | apply Rabs_triang. 430 | } 431 | apply Rplus_le_compat. 432 | { 433 | rewrite Rabs_mult. 434 | apply Rmult_le_compat; auto using Rabs_pos. 435 | } 436 | rewrite Rabs_mult. 437 | apply Rmult_le_compat; auto using Rabs_pos. 438 | eapply Rle_trans. 439 | { 440 | apply Rabs_triang. 441 | } 442 | rewrite Rabs_R1. 443 | apply Rplus_le_compat_l; auto. 444 | } 445 | eapply Rle_trans. 446 | { 447 | apply V_m_U_le. 448 | } 449 | rewrite DS. 450 | apply Rplus_le_compat_r. 451 | apply Rplus_le_compat_r. 452 | apply Rmult_le_compat_r; auto. 453 | unfold M. 454 | generalize (Rabs_pos (d)). 455 | lra. 456 | Qed. 457 | 458 | (* Range of a sum with rounding errors. (We assume that we already know the range of each computed term of the sum.) *) 459 | 460 | Lemma next_rounded_sum_range Q n q d e Mq Md Me: 461 | Rabs q <= Mq -> 462 | Rabs d <= Md -> 463 | Rabs e <= Me -> 464 | let M := 1 + Md in 465 | let K' := (Mq * (1 + Md) + Me) in 466 | Rabs Q <= D_ K' 0 M (n) -> 467 | Rabs ((Q + q) * (1 + d) + e) <= D_ K' 0 (M) (S n). 468 | Proof. 469 | intros H H0 H1 M K' H2. 470 | assert (Rabs ((Q + q) * (1 + d) + e) <= Rabs Q * M + INR n * 0 + K') as H3. 471 | { 472 | replace ((Q + q) * (1 + d) + e) with 473 | (Q * (1 + d) + INR n * 0 + (q * (1 + d) + e)) 474 | by ring. 475 | unfold K', M. 476 | rewrite Rmult_0_r. 477 | repeat rewrite Rplus_0_r. 478 | eapply Rle_trans. 479 | { 480 | apply Rabs_triang. 481 | } 482 | apply Rplus_le_compat. 483 | { 484 | rewrite Rabs_mult. 485 | apply Rmult_le_compat_l; auto using Rabs_pos. 486 | eapply Rle_trans. 487 | { 488 | apply Rabs_triang. 489 | } 490 | rewrite Rabs_R1. 491 | apply Rplus_le_compat_l; auto. 492 | } 493 | eapply Rle_trans. 494 | { 495 | apply Rabs_triang. 496 | } 497 | apply Rplus_le_compat; auto. 498 | rewrite Rabs_mult. 499 | apply Rmult_le_compat; auto using Rabs_pos. 500 | eapply Rle_trans. 501 | { 502 | apply Rabs_triang. 503 | } 504 | rewrite Rabs_R1. 505 | apply Rplus_le_compat_l; auto. 506 | } 507 | eapply Rle_trans. 508 | { 509 | apply H3. 510 | } 511 | rewrite DS. 512 | apply Rplus_le_compat_r. 513 | apply Rplus_le_compat_r. 514 | apply Rmult_le_compat_r; auto. 515 | unfold M. 516 | generalize (Rabs_pos d). 517 | lra. 518 | Qed. 519 | 520 | End S. 521 | 522 | (* Implementations *) 523 | 524 | Fixpoint Sf (f: nat -> R) (n: nat): R := 525 | match n with 526 | | O => 0 527 | | S n' => Sf f n' + f n' 528 | end. 529 | 530 | Global Instance: Sum Sf. 531 | Proof. 532 | split; reflexivity. 533 | Qed. 534 | 535 | Fixpoint D (K L M: R) (n: nat): R := 536 | match n with 537 | | O => 0 538 | | S n' => D K L M n' * M + INR n' * L + K 539 | end. 540 | 541 | Global Instance: forall K L M, prop K L M (D K L M). 542 | Proof. 543 | split; reflexivity. 544 | Qed. 545 | -------------------------------------------------------------------------------- /vcfloat/VCFloat.v: -------------------------------------------------------------------------------- 1 | From vcfloat Require Export klist FPLang FPLangOpt RAux Rounding Reify Float_notations Automate Prune. 2 | Require Derive. 3 | Set Bullet Behavior "Strict Subproofs". 4 | 5 | (* The following RtoFloat tactics are a very crude way to convert a n 6 | expression of type R that uses only IZR, Rplus, Rmult, Rdiv, Rinv, 7 | to a primitive floating-point constant. It's crude in part because 8 | it always uses rounding-UP, which is not really appropriate, and it' 9 | does not use interval arithmetic. It could perhaps be improved to actually 10 | compute in interval arithmetic, etc. 11 | 12 | Usage: 13 | RtoFloat' x returns a float-valued expression corresponding 14 | to the real-valued expression 15 | RtoFloat x returns a float-valued constant from the real-valued expr 16 | ShowBound prints it out with its name. 17 | *) 18 | 19 | Ltac RtoFloat' x := 20 | lazymatch x with 21 | | IZR ?z => constr:(Tactic_float.Float.fromZ_UP 53%Z z) 22 | | Rplus ?a ?b => let a' := RtoFloat' a in let b' := RtoFloat' b in constr:(PrimFloat.add a' b') 23 | | Rmult ?a ?b => let a' := RtoFloat' a in let b' := RtoFloat' b in constr:(PrimFloat.mul a' b') 24 | | Rdiv ?a ?b => let a' := RtoFloat' a in let b' := RtoFloat' b in constr:(PrimFloat.div a' b') 25 | | Rinv ?a => let a' := RtoFloat' a in constr:(PrimFloat.div PrimFloat.one a') 26 | | _ => let y := eval unfold x in x in RtoFloat' y 27 | end. 28 | 29 | 30 | Ltac RtoFloat x := 31 | let y := eval simpl in x in 32 | let y := RtoFloat' y in 33 | let y := eval compute in y in 34 | exact y. 35 | 36 | Import Binary. 37 | 38 | Definition some_nan64: {x : binary_float 53 1024 | is_nan _ _ x = true}. 39 | exists (B754_nan 53 1024 false 1 (eq_refl _)). reflexivity. 40 | Defined. 41 | 42 | Require Import vcfloat.Float_notations. 43 | 44 | Ltac ShowBound bound := 45 | match type of bound with 46 | | ?t => first [unify t R | fail 1 "ShowBound expects an argument of type R but" bound "has type" t] 47 | end; 48 | let y := eval simpl in bound in 49 | let y := RtoFloat' y in 50 | let y := constr:(BSN2B _ _ some_nan64 (@BinarySingleNaN.SF2B 53 1024 (FloatOps.Prim2SF y) (eq_refl _))) in 51 | let y := eval compute in y in 52 | match y with B754_finite 53 1024 ?s ?m ?e ?H => 53 | let z := constr:(b64_B754_finite s m e H) in 54 | idtac "ShowBound" bound z; exact z 55 | end. 56 | 57 | Ltac CheckBound x hi := 58 | idtac "Checking that" x "is indeed less than" hi; 59 | exact (Binary.Bcompare _ _ ltac:(ShowBound x) hi = Some Lt). 60 | -------------------------------------------------------------------------------- /vcfloat/Version.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.Strings.String. Open Scope string. 2 | Definition version := "2.2". 3 | -------------------------------------------------------------------------------- /vcfloat/_CoqProject: -------------------------------------------------------------------------------- 1 | -Q . vcfloat 2 | 3 | -------------------------------------------------------------------------------- /vcfloat/compute_tactics_ltac2.v: -------------------------------------------------------------------------------- 1 | Require Import Ltac2.Ltac2. 2 | Require Import Ltac2.Printf. 3 | Require Import Ltac2.Bool. 4 | 5 | (** * Restricted reduction/evaluation/computation *) 6 | 7 | (** ** Ltac2 utilities *) 8 | 9 | (** Get first and second of a pair *) 10 | 11 | Ltac2 pair_first (x : 'a*'b) : 'a := let (a,b):=x in a. 12 | Ltac2 pair_second (x : 'a*'b) : 'b := let (a,b):=x in b. 13 | 14 | (** Type checker which throws an invalid argument in case the term does not type check *) 15 | 16 | Ltac2 check_throw (term : constr) : constr := 17 | match Constr.Unsafe.check term with 18 | | Val c => c 19 | | Err e => Control.throw e 20 | end. 21 | 22 | (** Print the context (useful for creating a Goal for debugging) 23 | 24 | With these options: 25 | 26 | Set Printing Depth 1000. 27 | Set Printing Width 240. 28 | Unset Printing Notations. 29 | Set Printing Implicit. 30 | 31 | print_context should produce text which Coq can parse as Goal. 32 | *) 33 | 34 | Ltac2 print_hyps () := 35 | let rec aux (hyps : (ident * constr option * constr) list) := 36 | match hyps with 37 | | [] => () 38 | | h :: t => 39 | let (id, value, type) := h in 40 | match value with 41 | | Some value => printf "let %I := %t : %t in " id value type 42 | | None => printf "forall (%I : %t), " id type 43 | end; 44 | aux t 45 | end in 46 | aux (Control.hyps ()) 47 | . 48 | 49 | Ltac2 print_goal () := 50 | lazy_match! goal with 51 | | [ |- ?g ] => printf "%t" g 52 | end. 53 | 54 | Ltac2 print_context () := 55 | printf "Goal"; 56 | print_hyps (); 57 | print_goal (); 58 | printf "." 59 | . 60 | 61 | (** ** Construction of Ltac2 reductions flag records *) 62 | 63 | Ltac2 redflags_full () := 64 | { 65 | (* beta: expand the application of an unfolded functions by substitution *) 66 | Std.rBeta := true; 67 | (* delta: true = expand all but rConst; false = expand only rConst *) 68 | Std.rDelta := true; 69 | (* Note: iota in tactics like cbv is a shorthand for match, fix and cofix *) 70 | (* iota-match: simplify matches by choosing a pattern *) 71 | Std.rMatch := true; 72 | (* iota-fix: simplify fixpoint expressions by expanding one level *) 73 | Std.rFix := true; 74 | (* iota-cofix: simplify cofixpoint expressions by expanding one level *) 75 | Std.rCofix := true; 76 | (* zeta: expand let expressions by substitution *) 77 | Std.rZeta := true; 78 | (* Symbols to expand or not to expand (depending on rDelta) *) 79 | Std.rConst := []; 80 | (* Just guessing that Norm is the right thing here: *) 81 | Std.rStrength := Std.Norm 82 | }. 83 | 84 | (** ** Ltac2 functions for evaluation restricted reductions on a term *) 85 | 86 | (** ** CBV under application of the given head term with limited recursion: 87 | - arguments and function terms in applications 88 | - bound terms of products and lambdas 89 | - bound terms and values of let in bindings 90 | - values of cast expressions 91 | - values or primitive projections 92 | - match expressions and match case functions in matches, but no match return types 93 | fixpoints, types and native arrays are copied unchanged. 94 | The function returns a pair with a bool, which indicates if the match term was found and cbv was called on a part of the term. 95 | There is an extended recusion variant of the function below. 96 | *) 97 | 98 | Ltac2 rec eval_cbv_uao_lr (head : constr) (rf : Std.red_flags) (term : constr) : constr * bool := 99 | match Constr.Unsafe.kind term with 100 | | Constr.Unsafe.App func args => 101 | if Constr.equal head func 102 | then 103 | (Std.eval_cbv rf term, true) 104 | else 105 | let (func_r, func_m) := eval_cbv_uao_lr head rf func in 106 | let args_e := Array.map (eval_cbv_uao_lr head rf) args in 107 | if func_m || (Array.exist pair_second args_e) 108 | then (Constr.Unsafe.make (Constr.Unsafe.App func_r (Array.map pair_first args_e)), true) 109 | else (term, false) 110 | 111 | | Constr.Unsafe.Prod binder bound => 112 | let (bound_r, bound_m) := eval_cbv_uao_lr head rf bound in 113 | if bound_m 114 | then (Constr.Unsafe.make (Constr.Unsafe.Prod binder bound_r), true) 115 | else (term, false) 116 | 117 | | Constr.Unsafe.Lambda binder bound => 118 | let (bound_r, bound_m) := eval_cbv_uao_lr head rf bound in 119 | if bound_m 120 | then (Constr.Unsafe.make (Constr.Unsafe.Lambda binder bound_r), true) 121 | else (term, false) 122 | 123 | | Constr.Unsafe.LetIn binder value bound => 124 | let (value_r, value_m) := eval_cbv_uao_lr head rf value in 125 | let (bound_r, bound_m) := eval_cbv_uao_lr head rf bound in 126 | if value_m || bound_m 127 | then (Constr.Unsafe.make (Constr.Unsafe.LetIn binder value_r bound_r), true) 128 | else (term, false) 129 | 130 | | Constr.Unsafe.Cast value cast type => 131 | let (value_r, value_m) := eval_cbv_uao_lr head rf value in 132 | if value_m 133 | then (Constr.Unsafe.make (Constr.Unsafe.Cast value_r cast type), true) 134 | else (term, false) 135 | 136 | (* Commented this out for Coq 8.19 137 | | Constr.Unsafe.Proj projection value => 138 | let (value_r, value_m) := eval_cbv_uao_lr head rf value in 139 | if value_m 140 | then (Constr.Unsafe.make (Constr.Unsafe.Proj projection value_r), true) 141 | else (term, false) 142 | *) 143 | 144 | | Constr.Unsafe.Case case_a constr_return case_b constr_match case_funcs => 145 | let (match_r, match_m) := eval_cbv_uao_lr head rf constr_match in 146 | let case_funcs_e := Array.map (eval_cbv_uao_lr head rf) case_funcs in 147 | if match_m || (Array.exist pair_second case_funcs_e) 148 | then (Constr.Unsafe.make (Constr.Unsafe.Case case_a constr_return case_b match_r (Array.map pair_first case_funcs_e)), true) 149 | else (term, false) 150 | 151 | | _ => (term, false) 152 | end. 153 | 154 | (** ** CBV under application of the given head term with almsot full recusion. 155 | The search does not recurse into types in binders, because with Coq 8.16 Ltac2 one cannot safely reconstruct the term (fixed in 8.17) 156 | *) 157 | 158 | Ltac2 rec eval_cbv_uao_afr (head : constr) (rf : Std.red_flags) (term : constr) : constr * bool := 159 | match Constr.Unsafe.kind term with 160 | | Constr.Unsafe.App func args => 161 | if Constr.equal head func 162 | then 163 | (Std.eval_cbv rf term, true) 164 | else 165 | let (func_r, func_m) := eval_cbv_uao_afr head rf func in 166 | let args_e := Array.map (eval_cbv_uao_afr head rf) args in 167 | if func_m || (Array.exist pair_second args_e) 168 | then (Constr.Unsafe.make (Constr.Unsafe.App func_r (Array.map pair_first args_e)), true) 169 | else (term, false) 170 | 171 | | Constr.Unsafe.Prod binder bound => 172 | let (bound_r, bound_m) := eval_cbv_uao_afr head rf bound in 173 | if bound_m 174 | then (Constr.Unsafe.make (Constr.Unsafe.Prod binder bound_r), true) 175 | else (term, false) 176 | 177 | | Constr.Unsafe.Lambda binder bound => 178 | let (bound_r, bound_m) := eval_cbv_uao_afr head rf bound in 179 | if bound_m 180 | then (Constr.Unsafe.make (Constr.Unsafe.Lambda binder bound_r), true) 181 | else (term, false) 182 | 183 | | Constr.Unsafe.LetIn binder value bound => 184 | let (value_r, value_m) := eval_cbv_uao_afr head rf value in 185 | let (bound_r, bound_m) := eval_cbv_uao_afr head rf bound in 186 | if value_m || bound_m 187 | then (Constr.Unsafe.make (Constr.Unsafe.LetIn binder value_r bound_r), true) 188 | else (term, false) 189 | 190 | | Constr.Unsafe.Cast value cast type => 191 | let (value_r, value_m) := eval_cbv_uao_afr head rf value in 192 | let (type_r, type_m) := eval_cbv_uao_afr head rf type in 193 | if value_m || type_m 194 | then (Constr.Unsafe.make (Constr.Unsafe.Cast value_r cast type_r), true) 195 | else (term, false) 196 | 197 | 198 | (* Commented this out for Coq 8.19 199 | | Constr.Unsafe.Proj projection value => 200 | let (value_r, value_m) := eval_cbv_uao_afr head rf value in 201 | if value_m 202 | then (Constr.Unsafe.make (Constr.Unsafe.Proj projection value_r), true) 203 | else (term, false) 204 | *) 205 | | Constr.Unsafe.Case case_a constr_return_rel case_b constr_match case_funcs => 206 | let (constr_return, relev) := constr_return_rel in 207 | let (return_r, return_m) := eval_cbv_uao_afr head rf constr_return in 208 | let (match_r, match_m) := eval_cbv_uao_afr head rf constr_match in 209 | let case_funcs_e := Array.map (eval_cbv_uao_afr head rf) case_funcs in 210 | if return_m || match_m || (Array.exist pair_second case_funcs_e) 211 | then (Constr.Unsafe.make (Constr.Unsafe.Case case_a (return_r,relev) case_b match_r (Array.map pair_first case_funcs_e)), true) 212 | else (term, false) 213 | 214 | | Constr.Unsafe.Fix int_arr int binder_arr constr_arr => 215 | let constr_arr_e := Array.map (eval_cbv_uao_afr head rf) constr_arr in 216 | if (Array.exist pair_second constr_arr_e) 217 | then (Constr.Unsafe.make (Constr.Unsafe.Fix int_arr int binder_arr (Array.map pair_first constr_arr_e)), true) 218 | else (term, false) 219 | 220 | | Constr.Unsafe.CoFix int binder_arr constr_arr => 221 | let constr_arr_e := Array.map (eval_cbv_uao_afr head rf) constr_arr in 222 | if (Array.exist pair_second constr_arr_e) 223 | then (Constr.Unsafe.make (Constr.Unsafe.CoFix int binder_arr (Array.map pair_first constr_arr_e)), true) 224 | else (term, false) 225 | 226 | | Constr.Unsafe.Array instance constr_arr constr_a constr_b => 227 | let (constr_a_r, constr_a_m) := eval_cbv_uao_afr head rf constr_a in 228 | let (constr_b_r, constr_b_m) := eval_cbv_uao_afr head rf constr_b in 229 | let constr_arr_e := Array.map (eval_cbv_uao_afr head rf) constr_arr in 230 | if constr_a_m || constr_b_m || (Array.exist pair_second constr_arr_e) 231 | then (Constr.Unsafe.make (Constr.Unsafe.Array instance (Array.map pair_first constr_arr_e) constr_a_r constr_b_r), true) 232 | else (term, false) 233 | 234 | | _ => (term, false) 235 | end. 236 | 237 | (** ** Ltac2 tactics for evaluation restricted reductions on a term *) 238 | 239 | Ltac2 cbv_uao_lr (head : constr) : unit := 240 | let goal := Control.goal() in 241 | let (goal_r, goal_m) := eval_cbv_uao_lr head (redflags_full ()) goal in 242 | (* The line below can be commented out for performance tests - it is just an extra debug type check*) 243 | let goal_r := check_throw goal_r in 244 | change $goal_r. 245 | 246 | Ltac2 cbv_uao_afr (head : constr) : unit := 247 | let goal := Control.goal() in 248 | let (goal_r, goal_m) := eval_cbv_uao_afr head (redflags_full ()) goal in 249 | (* The line below can be commented out for performance tests - it is just an extra debug type check*) 250 | let goal_r := check_throw goal_r in 251 | change $goal_r. 252 | 253 | (** ** Ltac1 wrapper *) 254 | 255 | (** compute_every f 256 | will find every term below the line of the form (f _) or (f _ _) etc. whose head is f, 257 | and fully reduce it using "compute". 258 | This tactic does NOT look for (f _) within types, fixpoints or native arrays. 259 | *) 260 | Ltac compute_every := 261 | ltac2:(f |- compute_tactics_ltac2.cbv_uao_lr (Option.get (Ltac1.to_constr f))). 262 | 263 | (** ** Tests / examples *) 264 | 265 | (* Switch to normal Ltac1 mode (this is only required if Ltac2.Ltac2 is imported) *) 266 | Set Default Proof Mode "Classic". 267 | 268 | (* Test limited rewrite *) 269 | Goal forall x:nat, let f := (fun x => x+2*3) in (x + (f (2*3)) + (2*3) + 2*3+4*5*6 = x + 144). 270 | ltac2:(cbv_uao_afr '@Nat.mul). 271 | (* Note: in general the head symbol can be given with just ' (Ltac2's term quotation), but definitions with implicit arguments must be given with @ ! *) 272 | Abort. 273 | -------------------------------------------------------------------------------- /vcfloat/junk/Example.v: -------------------------------------------------------------------------------- 1 | (* LGPL licensed; see ../LICENSE and, for historical notes, see ../OLD_LICENSE *) 2 | (** 3 | Author: Tahina Ramananandro 4 | 5 | Examples from Section 4 of the CPP 2016 paper. 6 | **) 7 | 8 | Require Import Clight. 9 | Require Import Clightdefs. 10 | 11 | Require Import Reals. 12 | Require Clight2FPOpt. 13 | Import Flocq.Appli.Fappli_IEEE. 14 | Require Import Maps. 15 | Require Import Values. 16 | Require ClightTac. 17 | 18 | Open Scope R_scope. 19 | 20 | (** The following ASTs have been obtained through the following process: 21 | 1. preprocess example.c 22 | 2. remove all unsupported "long double" definitions 23 | 3. use CompCert Clightgen 24 | 4. extract the expressions from the return statements of f and g. 25 | 26 | Assume x is a double-precision floating-point variable. 27 | *) 28 | 29 | (** 30 | 2.0f * (float) x - 3.0 31 | *) 32 | 33 | Definition _x : ident := 47%positive. 34 | 35 | Definition e1 := 36 | Ebinop Osub 37 | (Ebinop Omul 38 | (Econst_single (Float32.of_bits (Int.repr 1073741824)) tfloat) 39 | (Ecast (Etempvar _x tdouble) tfloat) tfloat) 40 | (Econst_float (Float.of_bits (Int64.repr 4613937818241073152)) tdouble) 41 | tdouble. 42 | 43 | Goal 44 | forall ge e x m, 45 | is_finite _ _ x = true -> 46 | 1 <= B2R _ _ x <= 2 -> 47 | exists v, 48 | eval_expr ge e (PTree.set _x (Vfloat x) (PTree.empty _)) m e1 v 49 | /\ True. 50 | Proof. 51 | intros ge e x m H H0. 52 | apply ClightTac.Vfloat_exists. 53 | 54 | (** 55 | The goal is of the form: exists y, eval_expr ? ? ? ? e1 (Vfloat y) /\ _. 56 | So, we are going to transform e2 into a non-annotated core computation ?z of VCfloat, 57 | and y will be its floating-point value, such that Hy: fval ?z = y 58 | *) 59 | Clight2FPOpt.C_to_float_as y Hy. 60 | (** Then, to annotate ?z , we are going to take Hy (where ?z appears in: fval ?z = y) 61 | and we will tentatively deduce that y is finite (to store in hypothesis Hy_finite) 62 | and the real-number value of y (to store in hypothesis Hy_val). 63 | 64 | The validity condition checks will appear during the automatic search for annotation. 65 | *) 66 | 67 | Clight2FPOpt.compute_fval_as Hy Hy_finite Hy_val. 68 | exact I. 69 | Qed. 70 | 71 | (** 72 | #include 73 | 74 | DBL_MAX * (x + .5) 75 | *) 76 | 77 | Definition e2 := 78 | Ebinop Omul 79 | (Econst_float (Float.of_bits (Int64.repr 9218868437227405311)) tdouble) 80 | (Ebinop Oadd (Etempvar _x tdouble) 81 | (Econst_float (Float.of_bits (Int64.repr 4602678819172646912)) tdouble) 82 | tdouble) tdouble. 83 | 84 | Goal 85 | forall ge e x m, 86 | is_finite _ _ x = true -> 87 | 1 <= B2R _ _ x <= 2 -> 88 | exists v, 89 | eval_expr ge e (PTree.set _x (Vfloat x) (PTree.empty _)) m e2 v 90 | /\ False. 91 | Proof. 92 | intros ge e x m H H0. 93 | apply ClightTac.Vfloat_exists. 94 | 95 | (** 96 | The goal is of the form: exists y, eval_expr ? ? ? ? e2 (Vfloat y) /\ _. 97 | So, we are going to transform e2 into a non-annotated core computation ?z of VCfloat, 98 | and y will be its floating-point value, such that Hy: fval ?z = y 99 | *) 100 | Clight2FPOpt.C_to_float_as y Hy. 101 | (** Then, to annotate ?z , we are going to take Hy (where ?z appears in: fval ?z = y) 102 | and we will tentatively deduce that y is finite (to store in hypothesis Hy_finite) 103 | and the real-number value of y (to store in hypothesis Hy_val). 104 | 105 | The validity condition checks will appear during the automatic search for annotation. 106 | *) 107 | Fail Clight2FPOpt.compute_fval_as Hy Hy_finite Hy_val. 108 | Abort. 109 | -------------------------------------------------------------------------------- /vcfloat/junk/Taylor.v: -------------------------------------------------------------------------------- 1 | (* THIS FILE IS JUST THE BEGINNING OF AN EXPERIMENTAL SKETCH! 2 | We explore whether multivariate first-order Taylor expansions, 3 | in the style of FPTaylor, might be useful. 4 | *) 5 | 6 | Require Import Reals ZArith Lra Lia IntervalFlocq3.Tactic. 7 | Import Raux. 8 | From Flocq3 Require Import IEEE754.Binary Zaux. 9 | Require Import Setoid. 10 | 11 | Import Coq.Lists.List ListNotations. 12 | Import Tree. (* must import this _after_ List *) 13 | Import Interval Private Interval_helper I2 IT2.IH I2.T Xreal Eval.Reify. 14 | 15 | Import Basic. 16 | Import Bool. 17 | From vcfloat Require Import Prune. 18 | 19 | Lemma doppler1_test: 20 | forall 21 | (v_v : R) 22 | (BOUND : 20 <= v_v <= 2e4) 23 | (v_u : R) 24 | (BOUND0 : -100 <= v_u <= 100) 25 | (v_t : R) 26 | (BOUND1 : -30 <= v_t <= 50) 27 | (e0 : R) 28 | (E : Rabs e0 <= powerRZ 2 (-1075)) 29 | (e1 : R) 30 | (E0 : Rabs e1 <= powerRZ 2 (-1075)) 31 | (e3 : R) 32 | (E2 : Rabs e3 <= powerRZ 2 (-1075)) 33 | (e4 : R) 34 | (E3 : Rabs e4 <= powerRZ 2 (-1075)) 35 | (e8 : R) 36 | (E7 : Rabs e8 <= powerRZ 2 (-1075)) 37 | (e9 : R) 38 | (E8 : Rabs e9 <= powerRZ 2 (-1075)) 39 | (d : R) 40 | (E10 : Rabs d <= powerRZ 2 (-53)) 41 | (d0 : R) 42 | (E11 : Rabs d0 <= powerRZ 2 (-53)) 43 | (d1 : R) 44 | (E12 : Rabs d1 <= powerRZ 2 (-53)) 45 | (d2 : R) 46 | (E13 : Rabs d2 <= powerRZ 2 (-53)) 47 | (d3 : R) 48 | (E14 : Rabs d3 <= powerRZ 2 (-53)) 49 | (d6 : R) 50 | (E17 : Rabs d6 <= powerRZ 2 (-53)) 51 | (a := 2915025227559731 / 8796093022208 : R) 52 | (b := 5404319552844595 / 9007199254740992 : R), 53 | {bound: R | 54 | Rabs 55 | ((- ((a + (b * v_t * (1 + d) + e1)) * (1 + d1) + e0) * v_v * 56 | (1 + d2) + e8) / 57 | ((((a + (b * v_t * (1 + d) + e1)) * (1 + d1) + e0 + v_u) * 58 | (1 + d0) + e4) * 59 | (((a + (b * v_t * (1 + d) + e1)) * (1 + d1) + e0 + v_u) * 60 | (1 + d0) + e4) * (1 + d6) + e3) * (1 + d3) + e9 - 61 | - (a + b * v_t) * v_v * 62 | / ((a + b * v_t + v_u) * (a + b * v_t + v_u))) 63 | <= bound}. 64 | Proof. intros. 65 | evar (bound: R). 66 | exists bound. (*eexists.*) 67 | unfold a, b. 68 | 69 | simple_reify. 70 | 71 | Definition bind2 (f: expr -> expr -> expr) (x1: option expr) (x2: option expr) : option expr := 72 | match x1, x2 with 73 | | Some y1, Some y2 => Some (f y1 y2) 74 | | _, _ => None 75 | end. 76 | 77 | Definition Mul' (e1 e2: expr) := 78 | match e1, e2 with 79 | | Econst (Int 0) , _ => zeroexpr 80 | | _, Econst (Int 0) => zeroexpr 81 | | Econst (Int 1) , _ => e2 82 | | _, Econst (Int 1) => e1 83 | | _, _ => Ebinary Mul e1 e2 84 | end. 85 | 86 | 87 | Definition Div' (e1 e2: expr) := 88 | match e1, e2 with 89 | | Econst (Int 0) , _ => zeroexpr 90 | | _, Econst (Int 1) => e1 91 | | _, _ => Ebinary Div e1 e2 92 | end. 93 | 94 | Definition Neg' (e1: expr) := 95 | match e1 with Econst (Int 0) => zeroexpr | _ => e1 end. 96 | 97 | Definition Sqr' (e1: expr) := 98 | match e1 with 99 | | Econst (Int 0) => zeroexpr 100 | | Econst (Int 1) => oneexpr 101 | | _ => e1 102 | end. 103 | 104 | 105 | Print Add0. 106 | 107 | Definition partial_deriv (x: nat) : expr -> option expr := 108 | fix aux (e: expr) : option expr := 109 | match e with 110 | | Evar y => Some (if Nat.eqb x y then oneexpr else zeroexpr) 111 | | Econst _ => Some zeroexpr 112 | | Eunary Neg e1 => option_map Neg' (aux e1) 113 | | Eunary Inv e1 => option_map (fun d => Neg' (Div' d (Sqr' e1))) (aux e1) 114 | | Eunary Sqr e => option_map (Mul' (Econst (Int 2))) (aux e) 115 | | Ebinary Add e1 e2 => bind2 Add0 (aux e1) (aux e2) 116 | | Ebinary Sub e1 e2 => bind2 Sub0 (aux e1) (aux e2) 117 | | Ebinary Mul e1 e2 => bind2 (fun d1 d2 => Add0 (Mul' e1 d2) (Mul' e2 d1)) (aux e1) (aux e2) 118 | | Ebinary Div e1 e2 => bind2 (fun d1 d2 => Div' (Sub0 (Mul' e2 d1) (Mul' e1 d2)) (Sqr' e2)) 119 | (aux e1) (aux e2) 120 | | e => None 121 | end. 122 | 123 | Fixpoint option_list {A} (al: list (option A)) : option (list A) := 124 | match al with 125 | | nil => Some nil 126 | | Some x :: r => option_map (cons x) (option_list r) 127 | | None :: _ => None 128 | end. 129 | 130 | Definition gradient (vars: list R) e := 131 | option_list (map (fun x => partial_deriv x e) (seq.iota 0 (length vars))). 132 | 133 | assert ( 134 | match partial_deriv 3%nat __expr with 135 | | Some d => eval d __vars = 0%R 136 | | _ => False 137 | end). 138 | cbv -[IZR]. 139 | repeat change (?A * / ?B) with (A/B). 140 | fold a. fold b. 141 | clear __expr. 142 | 143 | 144 | 145 | 146 | 147 | 148 | pose (vars := seq.iota 0 (length __vars)). 149 | 150 | Search (list (option _) -> option (list _)). 151 | assert (partial_deriv 3%nat __expr = None). 152 | cbv. 153 | 154 | cbv [partial_deriv __expr Nat.eqb ]. 155 | 156 | 157 | 158 | 159 | Check option_map. 160 | 161 | 162 | 163 | 164 | 165 | -------------------------------------------------------------------------------- /vcfloat/klist.v: -------------------------------------------------------------------------------- 1 | Require Import List. Import ListNotations. 2 | Require ProofIrrelevance. 3 | Require Import JMeq. 4 | 5 | Fixpoint function_type (args : list Type) (rhs : Type) {struct args} : Type := 6 | match args with 7 | | [] => rhs 8 | | a :: r => a -> function_type r rhs 9 | end. 10 | 11 | Section KLIST. 12 | Context {type: Type}. 13 | 14 | Inductive klist (k : type -> Type) : list type -> Type := 15 | | Knil : klist k [] 16 | | Kcons {ty tys} : k ty -> klist k tys -> klist k (ty :: tys). 17 | 18 | Arguments Knil {k}. 19 | Arguments Kcons {k ty tys}. 20 | 21 | Lemma klist_nil {k: type -> Type} (al: klist k nil): al = Knil. 22 | Proof. 23 | exact 24 | match al with 25 | | Knil => eq_refl 26 | | Kcons _ _ => idProp 27 | end. 28 | Qed. 29 | 30 | Lemma klist_cons {k: type -> Type} {t: type} {tr: list type} (al: klist k (t::tr)) : 31 | exists h: k t, exists r: klist k tr, al = Kcons h r. 32 | Proof. 33 | refine 34 | match al with Knil => idProp | Kcons _ _ => _ end. 35 | eexists. eexists. reflexivity. 36 | Qed. 37 | 38 | Definition klist_cons1 {k: type -> Type} {t: type} {tr: list type} (al: klist k (t::tr)) : k t := 39 | match al with 40 | | Knil => idProp 41 | | Kcons h _ => h 42 | end. 43 | 44 | Definition klist_cons2 {k: type -> Type} {t: type} {tr: list type} (al: klist k (t::tr)) : klist k tr := 45 | match al with 46 | | Knil =>idProp 47 | | Kcons _ tr => tr 48 | end. 49 | 50 | Inductive Kforall {k: type -> Type} (P: forall ty, k ty -> Prop): forall {tys: list type} (es: klist k tys), Prop := 51 | | Kforall_nil: Kforall P Knil 52 | | Kforall_cons: forall {t tr} (h: k t) (r: klist k tr), P _ h -> Kforall P r -> Kforall P (Kcons h r). 53 | 54 | Lemma Kforall_inv: forall (k: type -> Type) (P: forall ty, k ty -> Prop) 55 | {ty: type} {tys: list type} (e: k ty) (es: klist k tys), 56 | Kforall P (Kcons e es) -> P _ e /\ Kforall P es. 57 | Proof. 58 | intros. 59 | inversion H. 60 | subst. 61 | apply ProofIrrelevance.ProofIrrelevanceTheory.EqdepTheory.inj_pair2 in H2, H4. 62 | subst; auto. 63 | Qed. 64 | 65 | Inductive Kforall2 {k1 k2: type -> Type} (P: forall ty, k1 ty -> k2 ty -> Prop): forall {tys: list type} (al: klist k1 tys) (bl: klist k2 tys), Prop := 66 | | Kforall2_nil: Kforall2 P Knil Knil 67 | | Kforall2_cons: forall {t tr} (ah: k1 t) (bh: k2 t) (ar: klist k1 tr) (br: klist k2 tr), 68 | P _ ah bh -> Kforall2 P ar br -> Kforall2 P (Kcons ah ar) (Kcons bh br). 69 | 70 | Lemma Kforall2_inv: forall (k1 k2: type -> Type) (P: forall ty, k1 ty -> k2 ty -> Prop) 71 | {ty: type} {tys: list type} (a: k1 ty) (b: k2 ty) (al: klist k1 tys) (bl: klist k2 tys), 72 | Kforall2 P (Kcons a al) (Kcons b bl) -> P _ a b /\ Kforall2 P al bl. 73 | Proof. 74 | intros. 75 | inversion H. 76 | subst. 77 | apply ProofIrrelevance.ProofIrrelevanceTheory.EqdepTheory.inj_pair2 in H2, H4, H5, H6. 78 | subst; auto. 79 | Qed. 80 | 81 | Fixpoint kapp {tys1 tys2 : list type} {k: type -> Type} (a: klist k tys1) (b: klist k tys2) : klist k (tys1++tys2) := 82 | match a in (klist _ l) return (klist k (l ++ tys2)) with 83 | | Knil => b 84 | | Kcons a1 ar => Kcons a1 (kapp ar b) 85 | end. 86 | 87 | Lemma kapp_nil_r: forall tys1 k (al: klist k tys1), 88 | JMeq (kapp al Knil) al. 89 | Proof. 90 | induction al. 91 | reflexivity. 92 | simpl. 93 | set (u := @kapp tys [] k al (@Knil k)) in *. 94 | clearbody u. 95 | set (tys' := tys ++ nil) in *. 96 | assert (tys' = tys) by apply app_nil_r. 97 | clearbody tys'. 98 | subst tys'. 99 | apply JMeq_eq in IHal. 100 | subst. 101 | reflexivity. 102 | Qed. 103 | 104 | Lemma kapp_assoc: 105 | forall (k: type -> Type) (ta tb tc: list type) 106 | (ea: klist k ta) (eb: klist k tb) (ec: klist k tc), 107 | JMeq (kapp ea (kapp eb ec)) (kapp (kapp ea eb) ec). 108 | Proof. 109 | intros. 110 | clear. 111 | induction ea; simpl; auto. 112 | set (u := (tys++tb)++tc) in *. 113 | set (v := tys++tb++tc) in *. 114 | assert (u=v) by apply app_ass. 115 | set (tab := tys++tb) in *. 116 | set (tbc := tb++tc) in *. 117 | set (ebc := kapp eb ec) in *. clearbody ebc. 118 | set (eab := kapp ea eb) in *; clearbody eab. 119 | rename tys into ta. 120 | set (abc1 := @kapp tab tc k eab ec) in *. 121 | set (abc2 := @kapp ta tbc k ea ebc) in *. 122 | revert IHea. 123 | fold u in abc1. 124 | fold v in abc2. 125 | clearbody abc1. clearbody abc2. 126 | clearbody v. clearbody u. 127 | clearbody tab. clearbody tbc. 128 | subst u. 129 | intro. 130 | apply JMeq_eq in IHea. 131 | subst abc2. 132 | reflexivity. 133 | Qed. 134 | 135 | End KLIST. 136 | 137 | Arguments Knil {type k}. 138 | Arguments Kcons {type k ty tys}. 139 | 140 | Fixpoint mapk {type: Type} {k1 k2: type -> Type} (f: forall ty: type, k1 ty -> k2 ty) 141 | {tys: list type} (al: klist k1 tys) : klist k2 tys := 142 | match al in (klist _ l) return (l = tys -> klist k2 tys) with 143 | | Knil => 144 | fun H : [] = tys => 145 | eq_rect [] (fun l : list type => klist k2 l) Knil tys H 146 | | @Kcons _ _ ty tys' x x0 => 147 | fun (H : ty :: tys' = tys) => 148 | eq_rect (ty :: tys') 149 | (fun l : list type => k1 ty -> klist k1 tys' -> klist k2 l) 150 | (fun (X1 : k1 ty) (X2 : klist k1 tys') =>Kcons (f ty X1) (mapk f X2)) 151 | tys H x x0 152 | end eq_refl. 153 | 154 | Lemma mapk_mapk: 155 | forall {type: Type} [k1 k2 k3: type -> Type] (f: forall ty, k1 ty -> k2 ty) (g: forall ty, k2 ty -> k3 ty) 156 | (tys: list type) (l: klist k1 tys), 157 | mapk g (mapk f l) = mapk (fun ty x => g ty (f ty x)) l. 158 | Proof. 159 | induction l; simpl; auto. 160 | f_equal; auto. 161 | Qed. 162 | 163 | Definition applyk_aux {type: Type} {k: type -> Type} (typemapper : type -> Type) 164 | (arg1: type) (args : list type) (res : type) 165 | (applyk : function_type (map typemapper args) (typemapper res) -> 166 | (forall ty : type, k ty -> typemapper ty) -> 167 | klist k args -> typemapper res) 168 | (f: function_type (map typemapper (arg1:: args)) (typemapper res)) 169 | (valmapper: forall ty : type, k ty -> typemapper ty) 170 | (es: klist k (arg1::args)): 171 | typemapper res. 172 | remember (arg1::args) as args0. 173 | destruct es as [ | arg1' args' e1 er] eqn:?H. 174 | discriminate. 175 | inversion Heqargs0; clear Heqargs0; subst. 176 | apply (applyk (f (valmapper _ e1)) valmapper er). 177 | Defined. 178 | 179 | Fixpoint applyk {type: Type} {k: type -> Type} 180 | (typemapper: type -> Type) 181 | (args: list type) 182 | (res: type) 183 | {struct args} 184 | : function_type (map typemapper args) (typemapper res) -> 185 | (forall ty: type, k ty -> typemapper ty) -> 186 | klist k args -> typemapper res := 187 | match 188 | args as l 189 | return 190 | (function_type (map typemapper l) (typemapper res) -> 191 | (forall ty: type, k ty -> typemapper ty) -> 192 | klist k l -> typemapper res) 193 | with 194 | | [] =>fun f _ _ => f 195 | | arg1 :: args0 => 196 | applyk_aux typemapper arg1 args0 res 197 | (applyk typemapper args0 res) 198 | end. 199 | 200 | Module StuffNotNeeded. 201 | Require Import Recdef. 202 | 203 | Section KLIST. 204 | Context {type: Type}. 205 | 206 | Definition mapk_aux A {k: type -> Type} (f: forall ty: type, k ty -> A) 207 | (t: type) (ts: list type) 208 | (mapk: klist k ts -> list A): klist k (t::ts) -> list A := 209 | fun X: klist k (t::ts) => 210 | match 211 | X as k0 in (klist _ l) 212 | return (l = t :: ts -> list A) 213 | with 214 | | Knil => 215 | fun (H : [] = t :: ts) => 216 | False_rect (list A) (eq_ind [] (fun e => match e with [] => True | _ :: _ => False end) 217 | I (t :: ts) H) 218 | | @Kcons _ _ ty tys e k2 => 219 | fun H2 : ty :: tys = t :: ts => 220 | (eq_rect_r (fun ty1 : type => k ty1 -> list A) 221 | (fun e' : k t => 222 | eq_rect_r (fun tys2 : list type => klist k tys2 -> list A) 223 | (fun k3 : klist k ts => f t e' :: mapk k3) (f_equal (@tl type) H2) k2) 224 | (f_equal (hd ty) H2) e) 225 | end eq_refl . 226 | 227 | 228 | 229 | Function mapk_aux1 {k: type -> Type} A (f: forall (ty: type), k ty -> A) (tys: list type) {measure length tys}: 230 | (klist k tys) -> list A := 231 | match tys with 232 | | nil => fun _ => nil 233 | | t::ts => mapk_aux A f t ts (@mapk_aux1 k A f ts) 234 | end. 235 | Proof. 236 | intros. 237 | simpl. apply PeanoNat.Nat.lt_succ_diag_r. 238 | Defined. 239 | 240 | Definition mapk {A} f {tys} l := mapk_aux1 A f tys l. 241 | 242 | End KLIST. 243 | End StuffNotNeeded. 244 | 245 | --------------------------------------------------------------------------------