diff options
87 files changed, 4849 insertions, 10900 deletions
@@ -21,23 +21,9 @@ setup.log .lia.cache .nia.cache -# cp targets of src/configure.sh: -src/_CoqProject -src/Makefile +# targets of coq_makefile: src/Makefile.conf -src/Makefile.local -src/smtcoq_plugin.ml4 -src/versions/native/Structures.v -src/g_smtcoq.ml4 -src/smtcoq_plugin.mlpack -src/Tactics.v -src/versions/standard/Int63/Int63.v -src/versions/standard/Int63/Int63Native.v -src/versions/standard/Int63/Int63Op.v -src/versions/standard/Int63/Int63Axioms.v -src/versions/standard/Int63/Int63Properties.v -src/versions/standard/Array/PArray.v -src/versions/standard/Structures.v +src/g_smtcoq.ml # generated by the Makefile src/uninstall_me.sh @@ -73,12 +73,12 @@ Then follow the instructions of the previous section. ### Requirements -You need to have OCaml version >= 4.09.0 and Coq version 8.9.*. +You need to have OCaml version >= 4.08 and < 4.10 and Coq version 8.10.*. > **Warning**: The version of Coq that you plan to use must have been compiled > with the same version of OCaml that you are going to use to compile > SMTCoq. In particular this means you want a version of Coq that was compiled -> with OCaml version >= 4.09.0. +> with OCaml version >= 4.08. ### Install opam @@ -111,16 +111,16 @@ opam switch create ocaml-base-compiler.4.09.0 ### Install Coq -After OCaml is installed, you can install Coq-8.9.1 through opam. +After OCaml is installed, you can install Coq-8.10.2 through opam. ```bash -opam install coq.8.9.1 +opam install coq.8.10.2 ``` If you also want to install CoqIDE at the same time you can do ```bash -opam install coq.8.9.1 coqide.8.9.1 +opam install coq.8.10.2 coqide.8.10.2 ``` but you might need to install some extra packages and libraries for your system @@ -132,7 +132,6 @@ but you might need to install some extra packages and libraries for your system Compile and install SMTCoq by using the following commands in the src directory. ```bash -./configure.sh make make install ``` @@ -1,5 +1,5 @@ all: - cd src && ./configure.sh && $(MAKE) + cd src && $(MAKE) install: all cd src && $(MAKE) install diff --git a/ci/manifest-sources-8.11 b/ci/manifest-sources-8.11 index b93f959..043c626 100644 --- a/ci/manifest-sources-8.11 +++ b/ci/manifest-sources-8.11 @@ -27,7 +27,6 @@ tasks: cd smtcoq git checkout coq-8.11 cd src - ./configure.sh make make install cd ../.. diff --git a/doc/sources.md b/doc/sources.md index 55d2cec..045150d 100644 --- a/doc/sources.md +++ b/doc/sources.md @@ -17,14 +17,6 @@ The rest of the document describes the organization of `src`. SMTCoq sources are contained in this directory. A few Coq files can be found at top-level. -### [configure.sh](../src/configure.sh) - -This script is meant to be run when compiling SMTCoq for the first time. It -should also be run every time the Makefile is modified. It takes as argument an -optional flag `-native` which, when present, will set up the sources to use the -*native Coq* libraries. Otherwise the standard version 8.5 of Coq is used. See -section [versions](#versions). - ### [SMTCoq.v](../src/SMTCoq.v) This is the main SMTCoq entry point, it is meant to be imported by users that @@ -142,30 +134,6 @@ This module contains miscellaneous general lemmas that are used in several places throughout the development of SMTCoq. -### [versions](../src/versions) - -This directory contains everything that is dependent on the version of Coq that -one wants to use. `standard` contains libraries for the standard version of Coq -and `native` contains everything related to native Coq. Note that some -libraries are already present in the default libraries of native Coq, in this -case they have a counterpart in `standard` that replicates the functionality -(without using native integers or native arrays). - -A particular point of interest is the files -[smtcoq_plugin_standard.ml4](../src/versions/standard/smtcoq_plugin_standard.ml4) -and -[smtcoq_plugin_native.ml4](../src/versions/native/smtcoq_plugin_native.ml4). They -provide extension points for Coq by defining new vernacular commands and new -tactics. For instance the tactic `verit` tells Coq to call the OCaml function -`verit.tactic` (which in turns uses the Coq API to manipulate the goals and -call the certified checkers). - -```ocaml -TACTIC EXTEND Tactic_verit -| [ "verit" ] -> [ Verit.tactic () ] -END -``` - ### [spl](../src/spl) diff --git a/examples/Example.v b/examples/Example.v index 324d139..b405206 100644 --- a/examples/Example.v +++ b/examples/Example.v @@ -11,7 +11,7 @@ (* [Require Import SMTCoq.SMTCoq.] loads the SMTCoq library. - If you are using native-coq instead of Coq 8.9, replace it with: + If you are using native-coq instead of Coq 8.10, replace it with: Require Import SMTCoq. *) diff --git a/src/BEST_PRACTICE.md b/src/BEST_PRACTICE.md index bbfd381..f75c7aa 100644 --- a/src/BEST_PRACTICE.md +++ b/src/BEST_PRACTICE.md @@ -9,6 +9,14 @@ except: implemented as dependent types). +## Hints + +Every hint should be put in a hint database, whose name starts with +"smtcoq_". There should be a different database for each part of SMTCoq +(e.g., one for each theory). The general database that is used across +the project is named `smtcoq_core`. + + # Code organization ## Documentation Every OCaml module comes with a documented interface. diff --git a/src/Makefile b/src/Makefile new file mode 100644 index 0000000..5d24b0c --- /dev/null +++ b/src/Makefile @@ -0,0 +1,801 @@ +############################################################################### +## v # The Coq Proof Assistant ## +## <O___,, # INRIA - CNRS - LIX - LRI - PPS ## +## \VV/ # ## +## // # ## +############################################################################### +## GNUMakefile for Coq 8.10.2 + +# For debugging purposes (must stay here, don't move below) +INITIAL_VARS := $(.VARIABLES) +# To implement recursion we save the name of the main Makefile +SELF := $(lastword $(MAKEFILE_LIST)) +PARENT := $(firstword $(MAKEFILE_LIST)) + +# This file is generated by coq_makefile and contains many variable +# definitions, like the list of .v files or the path to Coq +include Makefile.conf + +# Put in place old names +VFILES := $(COQMF_VFILES) +MLIFILES := $(COQMF_MLIFILES) +MLFILES := $(COQMF_MLFILES) +MLGFILES := $(COQMF_MLGFILES) +MLPACKFILES := $(COQMF_MLPACKFILES) +MLLIBFILES := $(COQMF_MLLIBFILES) +CMDLINE_VFILES := $(COQMF_CMDLINE_VFILES) +INSTALLCOQDOCROOT := $(COQMF_INSTALLCOQDOCROOT) +OTHERFLAGS := $(COQMF_OTHERFLAGS) +COQ_SRC_SUBDIRS := $(COQMF_COQ_SRC_SUBDIRS) +OCAMLLIBS := $(COQMF_OCAMLLIBS) +SRC_SUBDIRS := $(COQMF_SRC_SUBDIRS) +COQLIBS := $(COQMF_COQLIBS) +COQLIBS_NOML := $(COQMF_COQLIBS_NOML) +CMDLINE_COQLIBS := $(COQMF_CMDLINE_COQLIBS) +LOCAL := $(COQMF_LOCAL) +COQLIB := $(COQMF_COQLIB) +DOCDIR := $(COQMF_DOCDIR) +OCAMLFIND := $(COQMF_OCAMLFIND) +CAMLFLAGS := $(COQMF_CAMLFLAGS) +HASNATDYNLINK := $(COQMF_HASNATDYNLINK) +OCAMLWARN := $(COQMF_WARN) + +Makefile.conf: _CoqProject + coq_makefile -f _CoqProject -o Makefile + +# This file can be created by the user to hook into double colon rules or +# add any other Makefile code he may need +-include Makefile.local + +# Parameters ################################################################## +# +# Parameters are make variable assignments. +# They can be passed to (each call to) make on the command line. +# They can also be put in Makefile.local once an for all. +# For retro-compatibility reasons they can be put in the _CoqProject, but this +# practice is discouraged since _CoqProject better not contain make specific +# code (be nice to user interfaces). + +# Print shell commands (set to non empty) +VERBOSE ?= + +# Time the Coq process (set to non empty), and how (see default value) +TIMED?= +TIMECMD?= +# Use command time on linux, gtime on Mac OS +TIMEFMT?="$* (real: %e, user: %U, sys: %S, mem: %M ko)" +ifneq (,$(TIMED)) +ifeq (0,$(shell command time -f $(TIMEFMT) true >/dev/null 2>/dev/null; echo $$?)) +STDTIME?=command time -f $(TIMEFMT) +else +ifeq (0,$(shell gtime -f $(TIMEFMT) true >/dev/null 2>/dev/null; echo $$?)) +STDTIME?=gtime -f $(TIMEFMT) +else +STDTIME?=command time +endif +endif +else +STDTIME?=command time -f $(TIMEFMT) +endif + +# Coq binaries +COQC ?= "$(COQBIN)coqc" +COQTOP ?= "$(COQBIN)coqtop" +COQCHK ?= "$(COQBIN)coqchk" +COQDEP ?= "$(COQBIN)coqdep" +COQDOC ?= "$(COQBIN)coqdoc" +COQPP ?= "$(COQBIN)coqpp" +COQMKFILE ?= "$(COQBIN)coq_makefile" + +# Timing scripts +COQMAKE_ONE_TIME_FILE ?= "$(COQLIB)/tools/make-one-time-file.py" +COQMAKE_BOTH_TIME_FILES ?= "$(COQLIB)/tools/make-both-time-files.py" +COQMAKE_BOTH_SINGLE_TIMING_FILES ?= "$(COQLIB)/tools/make-both-single-timing-files.py" +BEFORE ?= +AFTER ?= + +# FIXME this should be generated by Coq (modules already linked by Coq) +CAMLDONTLINK=unix,str + +# OCaml binaries +CAMLC ?= "$(OCAMLFIND)" ocamlc -c +CAMLOPTC ?= "$(OCAMLFIND)" opt -c +CAMLLINK ?= "$(OCAMLFIND)" ocamlc -linkpkg -dontlink $(CAMLDONTLINK) +CAMLOPTLINK ?= "$(OCAMLFIND)" opt -linkpkg -dontlink $(CAMLDONTLINK) +CAMLDOC ?= "$(OCAMLFIND)" ocamldoc +CAMLDEP ?= "$(OCAMLFIND)" ocamldep -slash -ml-synonym .mlpack + +# DESTDIR is prepended to all installation paths +DESTDIR ?= + +# Debug builds, typically -g to OCaml, -debug to Coq. +CAMLDEBUG ?= +COQDEBUG ?= + +# Extra packages to be linked in (as in findlib -package) +CAMLPKGS ?= + +# Option for making timing files +TIMING?= +# Option for changing sorting of timing output file +TIMING_SORT_BY ?= auto +# Output file names for timed builds +TIME_OF_BUILD_FILE ?= time-of-build.log +TIME_OF_BUILD_BEFORE_FILE ?= time-of-build-before.log +TIME_OF_BUILD_AFTER_FILE ?= time-of-build-after.log +TIME_OF_PRETTY_BUILD_FILE ?= time-of-build-pretty.log +TIME_OF_PRETTY_BOTH_BUILD_FILE ?= time-of-build-both.log +TIME_OF_PRETTY_BUILD_EXTRA_FILES ?= - # also output to the command line + +TGTS ?= + +########## End of parameters ################################################## +# What follows may be relevant to you only if you need to +# extend this Makefile. If so, look for 'Extension point' here and +# put in Makefile.local double colon rules accordingly. +# E.g. to perform some work after the all target completes you can write +# +# post-all:: +# echo "All done!" +# +# in Makefile.local +# +############################################################################### + + + + +# Flags ####################################################################### +# +# We define a bunch of variables combining the parameters. +# To add additional flags to coq, coqchk or coqdoc, set the +# {COQ,COQCHK,COQDOC}EXTRAFLAGS variable to whatever you want to add. +# To overwrite the default choice and set your own flags entirely, set the +# {COQ,COQCHK,COQDOC}FLAGS variable. + +SHOW := $(if $(VERBOSE),@true "",@echo "") +HIDE := $(if $(VERBOSE),,@) + +TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) + +OPT?= + +# The DYNOBJ and DYNLIB variables are used by "coqdep -dyndep var" in .v.d +ifeq '$(OPT)' '-byte' +USEBYTE:=true +DYNOBJ:=.cma +DYNLIB:=.cma +else +USEBYTE:= +DYNOBJ:=.cmxs +DYNLIB:=.cmxs +endif + +# these variables are meant to be overridden if you want to add *extra* flags +COQEXTRAFLAGS?= +COQCHKEXTRAFLAGS?= +COQDOCEXTRAFLAGS?= + +# these flags do NOT contain the libraries, to make them easier to overwrite +COQFLAGS?=-q $(OTHERFLAGS) $(COQEXTRAFLAGS) +COQCHKFLAGS?=-silent -o $(COQCHKEXTRAFLAGS) +COQDOCFLAGS?=-interpolate -utf8 $(COQDOCEXTRAFLAGS) + +COQDOCLIBS?=$(COQLIBS_NOML) + +# The version of Coq being run and the version of coq_makefile that +# generated this makefile +COQ_VERSION:=$(shell $(COQC) --print-version | cut -d " " -f 1) +COQMAKEFILE_VERSION:=8.10.2 + +COQSRCLIBS?= $(foreach d,$(COQ_SRC_SUBDIRS), -I "$(COQLIB)/$(d)") + +CAMLFLAGS+=$(OCAMLLIBS) $(COQSRCLIBS) +# ocamldoc fails with unknown argument otherwise +CAMLDOCFLAGS:=$(filter-out -annot, $(filter-out -bin-annot, $(CAMLFLAGS))) +CAMLFLAGS+=$(OCAMLWARN) + +ifneq (,$(TIMING)) +TIMING_ARG=-time +ifeq (after,$(TIMING)) +TIMING_EXT=after-timing +else +ifeq (before,$(TIMING)) +TIMING_EXT=before-timing +else +TIMING_EXT=timing +endif +endif +else +TIMING_ARG= +endif + +# Retro compatibility (DESTDIR is standard on Unix, DSTROOT is not) +ifdef DSTROOT +DESTDIR := $(DSTROOT) +endif + +concat_path = $(if $(1),$(1)/$(if $(COQMF_WINDRIVE),$(subst $(COQMF_WINDRIVE),/,$(2)),$(2)),$(2)) + +COQLIBINSTALL = $(call concat_path,$(DESTDIR),$(COQLIB)/user-contrib) +COQDOCINSTALL = $(call concat_path,$(DESTDIR),$(DOCDIR)/user-contrib) +COQTOPINSTALL = $(call concat_path,$(DESTDIR),$(COQLIB)/toploop) + +# Files ####################################################################### +# +# We here define a bunch of variables about the files being part of the +# Coq project in order to ease the writing of build target and build rules + +VDFILE := .coqdeps + +ALLSRCFILES := \ + $(MLGFILES) \ + $(MLFILES) \ + $(MLPACKFILES) \ + $(MLLIBFILES) \ + $(MLIFILES) + +# helpers +vo_to_obj = $(addsuffix .o,\ + $(filter-out Warning: Error:,\ + $(shell $(COQTOP) -q -noinit -batch -quiet -print-mod-uid $(1)))) +strip_dotslash = $(patsubst ./%,%,$(1)) + +# without this we get undefined variables in the expansion for the +# targets of the [deprecated,use-mllib-or-mlpack] rule +with_undef = $(if $(filter-out undefined, $(origin $(1))),$($(1))) + +VO = vo + +VOFILES = $(VFILES:.v=.$(VO)) +GLOBFILES = $(VFILES:.v=.glob) +HTMLFILES = $(VFILES:.v=.html) +GHTMLFILES = $(VFILES:.v=.g.html) +BEAUTYFILES = $(addsuffix .beautified,$(VFILES)) +TEXFILES = $(VFILES:.v=.tex) +GTEXFILES = $(VFILES:.v=.g.tex) +CMOFILES = \ + $(MLGFILES:.mlg=.cmo) \ + $(MLFILES:.ml=.cmo) \ + $(MLPACKFILES:.mlpack=.cmo) +CMXFILES = $(CMOFILES:.cmo=.cmx) +OFILES = $(CMXFILES:.cmx=.o) +CMAFILES = $(MLLIBFILES:.mllib=.cma) $(MLPACKFILES:.mlpack=.cma) +CMXAFILES = $(CMAFILES:.cma=.cmxa) +CMIFILES = \ + $(CMOFILES:.cmo=.cmi) \ + $(MLIFILES:.mli=.cmi) +# the /if/ is because old _CoqProject did not list a .ml(pack|lib) but just +# a .ml4 file +CMXSFILES = \ + $(MLPACKFILES:.mlpack=.cmxs) \ + $(CMXAFILES:.cmxa=.cmxs) \ + $(if $(MLPACKFILES)$(CMXAFILES),,\ + $(MLGFILES:.mlg=.cmxs) $(MLFILES:.ml=.cmxs)) + +# files that are packed into a plugin (no extension) +PACKEDFILES = \ + $(call strip_dotslash, \ + $(foreach lib, \ + $(call strip_dotslash, \ + $(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES)),$(call with_undef,$(lib)))) +# files that are archived into a .cma (mllib) +LIBEDFILES = \ + $(call strip_dotslash, \ + $(foreach lib, \ + $(call strip_dotslash, \ + $(MLLIBFILES:.mllib=_MLLIB_DEPENDENCIES)),$(call with_undef,$(lib)))) +CMIFILESTOINSTALL = $(filter-out $(addsuffix .cmi,$(PACKEDFILES)),$(CMIFILES)) +CMOFILESTOINSTALL = $(filter-out $(addsuffix .cmo,$(PACKEDFILES)),$(CMOFILES)) +OBJFILES = $(call vo_to_obj,$(VOFILES)) +ALLNATIVEFILES = \ + $(OBJFILES:.o=.cmi) \ + $(OBJFILES:.o=.cmx) \ + $(OBJFILES:.o=.cmxs) +# trick: wildcard filters out non-existing files, so that `install` doesn't show +# warnings and `clean` doesn't pass to rm a list of files that is too long for +# the shell. +NATIVEFILES = $(wildcard $(ALLNATIVEFILES)) +FILESTOINSTALL = \ + $(VOFILES) \ + $(VFILES) \ + $(GLOBFILES) \ + $(NATIVEFILES) \ + $(CMIFILESTOINSTALL) +BYTEFILESTOINSTALL = \ + $(CMOFILESTOINSTALL) \ + $(CMAFILES) +ifeq '$(HASNATDYNLINK)' 'true' +DO_NATDYNLINK = yes +FILESTOINSTALL += $(CMXSFILES) $(CMXAFILES) $(CMOFILESTOINSTALL:.cmo=.cmx) +else +DO_NATDYNLINK = +endif + +ALLDFILES = $(addsuffix .d,$(ALLSRCFILES) $(VDFILE)) + +# Compilation targets ######################################################### + +all: + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" pre-all + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" real-all + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" post-all +.PHONY: all + +all.timing.diff: + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" pre-all + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" real-all.timing.diff TIME_OF_PRETTY_BUILD_EXTRA_FILES="" + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" post-all +.PHONY: all.timing.diff + +make-pretty-timed-before:: TIME_OF_BUILD_FILE=$(TIME_OF_BUILD_BEFORE_FILE) +make-pretty-timed-after:: TIME_OF_BUILD_FILE=$(TIME_OF_BUILD_AFTER_FILE) +make-pretty-timed make-pretty-timed-before make-pretty-timed-after:: + $(HIDE)rm -f pretty-timed-success.ok + $(HIDE)($(MAKE) --no-print-directory -f "$(PARENT)" $(TGTS) TIMED=1 2>&1 && touch pretty-timed-success.ok) | tee -a $(TIME_OF_BUILD_FILE) + $(HIDE)rm pretty-timed-success.ok # must not be -f; must fail if the touch failed +print-pretty-timed:: + $(HIDE)$(COQMAKE_ONE_TIME_FILE) $(TIME_OF_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) +print-pretty-timed-diff:: + $(HIDE)$(COQMAKE_BOTH_TIME_FILES) --sort-by=$(TIMING_SORT_BY) $(TIME_OF_BUILD_AFTER_FILE) $(TIME_OF_BUILD_BEFORE_FILE) $(TIME_OF_PRETTY_BOTH_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) +ifeq (,$(BEFORE)) +print-pretty-single-time-diff:: + @echo 'Error: Usage: $(MAKE) print-pretty-single-time-diff AFTER=path/to/file.v.after-timing BEFORE=path/to/file.v.before-timing' + $(HIDE)false +else +ifeq (,$(AFTER)) +print-pretty-single-time-diff:: + @echo 'Error: Usage: $(MAKE) print-pretty-single-time-diff AFTER=path/to/file.v.after-timing BEFORE=path/to/file.v.before-timing' + $(HIDE)false +else +print-pretty-single-time-diff:: + $(HIDE)$(COQMAKE_BOTH_SINGLE_TIMING_FILES) --sort-by=$(TIMING_SORT_BY) $(AFTER) $(BEFORE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) +endif +endif +pretty-timed: + $(HIDE)$(MAKE) --no-print-directory -f "$(PARENT)" make-pretty-timed + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" print-pretty-timed +.PHONY: pretty-timed make-pretty-timed make-pretty-timed-before make-pretty-timed-after print-pretty-timed print-pretty-timed-diff print-pretty-single-time-diff + +# Extension points for actions to be performed before/after the all target +pre-all:: + @# Extension point + $(HIDE)if [ "$(COQMAKEFILE_VERSION)" != "$(COQ_VERSION)" ]; then\ + echo "W: This Makefile was generated by Coq $(COQMAKEFILE_VERSION)";\ + echo "W: while the current Coq version is $(COQ_VERSION)";\ + fi +.PHONY: pre-all + +post-all:: + @# Extension point +.PHONY: post-all + +real-all: $(VOFILES) $(if $(USEBYTE),bytefiles,optfiles) +.PHONY: real-all + +real-all.timing.diff: $(VOFILES:.vo=.v.timing.diff) +.PHONY: real-all.timing.diff + +bytefiles: $(CMOFILES) $(CMAFILES) +.PHONY: bytefiles + +optfiles: $(if $(DO_NATDYNLINK),$(CMXSFILES)) +.PHONY: optfiles + +# FIXME, see Ralf's bugreport +quick: $(VOFILES:.vo=.vio) +.PHONY: quick + +vio2vo: + $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) \ + -schedule-vio2vo $(J) $(VOFILES:%.vo=%.vio) +.PHONY: vio2vo + +quick2vo: + $(HIDE)make -j $(J) quick + $(HIDE)VIOFILES=$$(for vofile in $(VOFILES); do \ + viofile="$$(echo "$$vofile" | sed "s/\.vo$$/.vio/")"; \ + if [ "$$vofile" -ot "$$viofile" -o ! -e "$$vofile" ]; then printf "$$viofile "; fi; \ + done); \ + echo "VIO2VO: $$VIOFILES"; \ + if [ -n "$$VIOFILES" ]; then \ + $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) -schedule-vio2vo $(J) $$VIOFILES; \ + fi +.PHONY: quick2vo + +checkproofs: + $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) \ + -schedule-vio-checking $(J) $(VOFILES:%.vo=%.vio) +.PHONY: checkproofs + +validate: $(VOFILES) + $(TIMER) $(COQCHK) $(COQCHKFLAGS) $(COQLIBS) $^ +.PHONY: validate + +only: $(TGTS) +.PHONY: only + +# Documentation targets ####################################################### + +html: $(GLOBFILES) $(VFILES) + $(SHOW)'COQDOC -d html $(GAL)' + $(HIDE)mkdir -p html + $(HIDE)$(COQDOC) \ + -toc $(COQDOCFLAGS) -html $(GAL) $(COQDOCLIBS) -d html $(VFILES) + +mlihtml: $(MLIFILES:.mli=.cmi) + $(SHOW)'CAMLDOC -d $@' + $(HIDE)mkdir $@ || rm -rf $@/* + $(HIDE)$(CAMLDOC) -html \ + -d $@ -m A $(CAMLDEBUG) $(CAMLDOCFLAGS) $(MLIFILES) + +all-mli.tex: $(MLIFILES:.mli=.cmi) + $(SHOW)'CAMLDOC -latex $@' + $(HIDE)$(CAMLDOC) -latex \ + -o $@ -m A $(CAMLDEBUG) $(CAMLDOCFLAGS) $(MLIFILES) + +all.ps: $(VFILES) + $(SHOW)'COQDOC -ps $(GAL)' + $(HIDE)$(COQDOC) \ + -toc $(COQDOCFLAGS) -ps $(GAL) $(COQDOCLIBS) \ + -o $@ `$(COQDEP) -sort -suffix .v $(VFILES)` + +all.pdf: $(VFILES) + $(SHOW)'COQDOC -pdf $(GAL)' + $(HIDE)$(COQDOC) \ + -toc $(COQDOCFLAGS) -pdf $(GAL) $(COQDOCLIBS) \ + -o $@ `$(COQDEP) -sort -suffix .v $(VFILES)` + +# FIXME: not quite right, since the output name is different +gallinahtml: GAL=-g +gallinahtml: html + +all-gal.ps: GAL=-g +all-gal.ps: all.ps + +all-gal.pdf: GAL=-g +all-gal.pdf: all.pdf + +# ? +beautify: $(BEAUTYFILES) + for file in $^; do mv $${file%.beautified} $${file%beautified}old && mv $${file} $${file%.beautified}; done + @echo 'Do not do "make clean" until you are sure that everything went well!' + @echo 'If there were a problem, execute "for file in $$(find . -name \*.v.old -print); do mv $${file} $${file%.old}; done" in your shell/' +.PHONY: beautify + +# Installation targets ######################################################## +# +# There rules can be extended in Makefile.local +# Extensions can't assume when they run. + +install: + $(HIDE)code=0; for f in $(FILESTOINSTALL); do\ + if ! [ -f "$$f" ]; then >&2 echo $$f does not exist; code=1; fi \ + done; exit $$code + $(HIDE)for f in $(FILESTOINSTALL); do\ + df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`";\ + if [ "$$?" != "0" -o -z "$$df" ]; then\ + echo SKIP "$$f" since it has no logical path;\ + else\ + install -d "$(COQLIBINSTALL)/$$df" &&\ + install -m 0644 "$$f" "$(COQLIBINSTALL)/$$df" &&\ + echo INSTALL "$$f" "$(COQLIBINSTALL)/$$df";\ + fi;\ + done + $(HIDE)$(MAKE) install-extra -f "$(SELF)" +install-extra:: + @# Extension point +.PHONY: install install-extra + +install-byte: + $(HIDE)for f in $(BYTEFILESTOINSTALL); do\ + df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`";\ + if [ "$$?" != "0" -o -z "$$df" ]; then\ + echo SKIP "$$f" since it has no logical path;\ + else\ + install -d "$(COQLIBINSTALL)/$$df" &&\ + install -m 0644 "$$f" "$(COQLIBINSTALL)/$$df" &&\ + echo INSTALL "$$f" "$(COQLIBINSTALL)/$$df";\ + fi;\ + done + +install-doc:: html mlihtml + @# Extension point + $(HIDE)install -d "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html" + $(HIDE)for i in html/*; do \ + dest="$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/$$i";\ + install -m 0644 "$$i" "$$dest";\ + echo INSTALL "$$i" "$$dest";\ + done + $(HIDE)install -d \ + "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml" + $(HIDE)for i in mlihtml/*; do \ + dest="$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/$$i";\ + install -m 0644 "$$i" "$$dest";\ + echo INSTALL "$$i" "$$dest";\ + done +.PHONY: install-doc + +uninstall:: + @# Extension point + $(HIDE)for f in $(FILESTOINSTALL); do \ + df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`" &&\ + instf="$(COQLIBINSTALL)/$$df/`basename $$f`" &&\ + rm -f "$$instf" &&\ + echo RM "$$instf" &&\ + (rmdir "$(call concat_path,,$(COQLIBINSTALL)/$$df/)" 2>/dev/null || true); \ + done +.PHONY: uninstall + +uninstall-doc:: + @# Extension point + $(SHOW)'RM $(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html' + $(HIDE)rm -rf "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html" + $(SHOW)'RM $(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml' + $(HIDE)rm -rf "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml" + $(HIDE) rmdir "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/" || true +.PHONY: uninstall-doc + +# Cleaning #################################################################### +# +# There rules can be extended in Makefile.local +# Extensions can't assume when they run. + +clean:: + @# Extension point + $(SHOW)'CLEAN' + $(HIDE)rm -f $(CMOFILES) + $(HIDE)rm -f $(CMIFILES) + $(HIDE)rm -f $(CMAFILES) + $(HIDE)rm -f $(CMOFILES:.cmo=.cmx) + $(HIDE)rm -f $(CMXAFILES) + $(HIDE)rm -f $(CMXSFILES) + $(HIDE)rm -f $(CMOFILES:.cmo=.o) + $(HIDE)rm -f $(CMXAFILES:.cmxa=.a) + $(HIDE)rm -f $(MLGFILES:.mlg=.ml) + $(HIDE)rm -f $(ALLDFILES) + $(HIDE)rm -f $(NATIVEFILES) + $(HIDE)find . -name .coq-native -type d -empty -delete + $(HIDE)rm -f $(VOFILES) + $(HIDE)rm -f $(VOFILES:.vo=.vio) + $(HIDE)rm -f $(BEAUTYFILES) $(VFILES:=.old) + $(HIDE)rm -f all.ps all-gal.ps all.pdf all-gal.pdf all.glob all-mli.tex + $(HIDE)rm -f $(VFILES:.v=.glob) + $(HIDE)rm -f $(VFILES:.v=.tex) + $(HIDE)rm -f $(VFILES:.v=.g.tex) + $(HIDE)rm -f pretty-timed-success.ok + $(HIDE)rm -rf html mlihtml +.PHONY: clean + +cleanall:: clean + @# Extension point + $(SHOW)'CLEAN *.aux *.timing' + $(HIDE)rm -f $(foreach f,$(VFILES:.v=),$(dir $(f)).$(notdir $(f)).aux) + $(HIDE)rm -f $(TIME_OF_BUILD_FILE) $(TIME_OF_BUILD_BEFORE_FILE) $(TIME_OF_BUILD_AFTER_FILE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BOTH_BUILD_FILE) + $(HIDE)rm -f $(VOFILES:.vo=.v.timing) + $(HIDE)rm -f $(VOFILES:.vo=.v.before-timing) + $(HIDE)rm -f $(VOFILES:.vo=.v.after-timing) + $(HIDE)rm -f $(VOFILES:.vo=.v.timing.diff) +.PHONY: cleanall + +archclean:: + @# Extension point + $(SHOW)'CLEAN *.cmx *.o' + $(HIDE)rm -f $(NATIVEFILES) + $(HIDE)rm -f $(CMOFILES:%.cmo=%.cmx) +.PHONY: archclean + + +# Compilation rules ########################################################### + +$(MLIFILES:.mli=.cmi): %.cmi: %.mli + $(SHOW)'CAMLC -c $<' + $(HIDE)$(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $< + +$(MLGFILES:.mlg=.ml): %.ml: %.mlg + $(SHOW)'COQPP $<' + $(HIDE)$(COQPP) $< + +# Stupid hack around a deficient syntax: we cannot concatenate two expansions +$(filter %.cmo, $(MLFILES:.ml=.cmo) $(MLGFILES:.mlg=.cmo)): %.cmo: %.ml + $(SHOW)'CAMLC -c $<' + $(HIDE)$(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $< + +# Same hack +$(filter %.cmx, $(MLFILES:.ml=.cmx) $(MLGFILES:.mlg=.cmx)): %.cmx: %.ml + $(SHOW)'CAMLOPT -c $(FOR_PACK) $<' + $(HIDE)$(CAMLOPTC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $(FOR_PACK) $< + + +$(MLLIBFILES:.mllib=.cmxs): %.cmxs: %.cmxa + $(SHOW)'CAMLOPT -shared -o $@' + $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ + -linkall -shared -o $@ $< + +$(MLLIBFILES:.mllib=.cma): %.cma: | %.mllib + $(SHOW)'CAMLC -a -o $@' + $(HIDE)$(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) -a -o $@ $^ + +$(MLLIBFILES:.mllib=.cmxa): %.cmxa: | %.mllib + $(SHOW)'CAMLOPT -a -o $@' + $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) -a -o $@ $^ + + +$(MLPACKFILES:.mlpack=.cmxs): %.cmxs: %.cmxa + $(SHOW)'CAMLOPT -shared -o $@' + $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ + -shared -linkall -o $@ $< + +$(MLPACKFILES:.mlpack=.cmxa): %.cmxa: %.cmx + $(SHOW)'CAMLOPT -a -o $@' + $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -a -o $@ $< + +$(MLPACKFILES:.mlpack=.cma): %.cma: %.cmo | %.mlpack + $(SHOW)'CAMLC -a -o $@' + $(HIDE)$(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) -a -o $@ $^ + +$(MLPACKFILES:.mlpack=.cmo): %.cmo: | %.mlpack + $(SHOW)'CAMLC -pack -o $@' + $(HIDE)$(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) -pack -o $@ $^ + +$(MLPACKFILES:.mlpack=.cmx): %.cmx: | %.mlpack + $(SHOW)'CAMLOPT -pack -o $@' + $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -pack -o $@ $^ + +# This rule is for _CoqProject with no .mllib nor .mlpack +$(filter-out $(MLLIBFILES:.mllib=.cmxs) $(MLPACKFILES:.mlpack=.cmxs) $(addsuffix .cmxs,$(PACKEDFILES)) $(addsuffix .cmxs,$(LIBEDFILES)),$(MLFILES:.ml=.cmxs) $(MLGFILES:.mlg=.cmxs)): %.cmxs: %.cmx + $(SHOW)'[deprecated,use-mllib-or-mlpack] CAMLOPT -shared -o $@' + $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ + -shared -o $@ $< + +ifneq (,$(TIMING)) +TIMING_EXTRA = > $<.$(TIMING_EXT) +else +TIMING_EXTRA = +endif + +$(VOFILES): %.vo: %.v + $(SHOW)COQC $< + $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(TIMING_ARG) $(COQFLAGS) $(COQLIBS) $< $(TIMING_EXTRA) + +# FIXME ?merge with .vo / .vio ? +$(GLOBFILES): %.glob: %.v + $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< + +$(VFILES:.v=.vio): %.vio: %.v + $(SHOW)COQC -quick $< + $(HIDE)$(TIMER) $(COQC) -quick $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< + +$(addsuffix .timing.diff,$(VFILES)): %.timing.diff : %.before-timing %.after-timing + $(SHOW)PYTHON TIMING-DIFF $< + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" print-pretty-single-time-diff BEFORE=$*.before-timing AFTER=$*.after-timing TIME_OF_PRETTY_BUILD_FILE="$@" + +$(BEAUTYFILES): %.v.beautified: %.v + $(SHOW)'BEAUTIFY $<' + $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) -beautify $< + +$(TEXFILES): %.tex: %.v + $(SHOW)'COQDOC -latex $<' + $(HIDE)$(COQDOC) $(COQDOCFLAGS) -latex $< -o $@ + +$(GTEXFILES): %.g.tex: %.v + $(SHOW)'COQDOC -latex -g $<' + $(HIDE)$(COQDOC) $(COQDOCFLAGS) -latex -g $< -o $@ + +$(HTMLFILES): %.html: %.v %.glob + $(SHOW)'COQDOC -html $<' + $(HIDE)$(COQDOC) $(COQDOCFLAGS) -html $< -o $@ + +$(GHTMLFILES): %.g.html: %.v %.glob + $(SHOW)'COQDOC -html -g $<' + $(HIDE)$(COQDOC) $(COQDOCFLAGS) -html -g $< -o $@ + +# Dependency files ############################################################ + +ifndef MAKECMDGOALS + -include $(ALLDFILES) +else + ifneq ($(filter-out archclean clean cleanall printenv make-pretty-timed make-pretty-timed-before make-pretty-timed-after print-pretty-timed print-pretty-timed-diff print-pretty-single-time-diff,$(MAKECMDGOALS)),) + -include $(ALLDFILES) + endif +endif + +.SECONDARY: $(ALLDFILES) + +redir_if_ok = > "$@" || ( RV=$$?; rm -f "$@"; exit $$RV ) + +GENMLFILES:=$(MLGFILES:.mlg=.ml) +$(addsuffix .d,$(ALLSRCFILES)): $(GENMLFILES) + +$(addsuffix .d,$(MLIFILES)): %.mli.d: %.mli + $(SHOW)'CAMLDEP $<' + $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) + +$(addsuffix .d,$(MLGFILES)): %.mlg.d: %.ml + $(SHOW)'CAMLDEP $<' + $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) + +$(addsuffix .d,$(MLFILES)): %.ml.d: %.ml + $(SHOW)'CAMLDEP $<' + $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) + +$(addsuffix .d,$(MLLIBFILES)): %.mllib.d: %.mllib + $(SHOW)'COQDEP $<' + $(HIDE)$(COQDEP) $(OCAMLLIBS) -c "$<" $(redir_if_ok) + +$(addsuffix .d,$(MLPACKFILES)): %.mlpack.d: %.mlpack + $(SHOW)'COQDEP $<' + $(HIDE)$(COQDEP) $(OCAMLLIBS) -c "$<" $(redir_if_ok) + +# If this makefile is created using a _CoqProject we have coqdep get +# options from it. This avoids argument length limits for pathological +# projects. Note that extra options might be on the command line. +VDFILE_FLAGS:=$(if _CoqProject,-f _CoqProject,) $(CMDLINE_COQLIBS) $(CMDLINE_VFILES) + +$(VDFILE).d: $(VFILES) + $(SHOW)'COQDEP VFILES' + $(HIDE)$(COQDEP) -dyndep var $(VDFILE_FLAGS) $(redir_if_ok) + +# Misc ######################################################################## + +byte: + $(HIDE)$(MAKE) all "OPT:=-byte" -f "$(SELF)" +.PHONY: byte + +opt: + $(HIDE)$(MAKE) all "OPT:=-opt" -f "$(SELF)" +.PHONY: opt + +# This is deprecated. To extend this makefile use +# extension points and Makefile.local +printenv:: + $(warning printenv is deprecated) + $(warning write extensions in Makefile.local or include Makefile.conf) + @echo 'LOCAL = $(LOCAL)' + @echo 'COQLIB = $(COQLIB)' + @echo 'DOCDIR = $(DOCDIR)' + @echo 'OCAMLFIND = $(OCAMLFIND)' + @echo 'HASNATDYNLINK = $(HASNATDYNLINK)' + @echo 'SRC_SUBDIRS = $(SRC_SUBDIRS)' + @echo 'COQ_SRC_SUBDIRS = $(COQ_SRC_SUBDIRS)' + @echo 'OCAMLFIND = $(OCAMLFIND)' + @echo 'PP = $(PP)' + @echo 'COQFLAGS = $(COQFLAGS)' + @echo 'COQLIB = $(COQLIBS)' + @echo 'COQLIBINSTALL = $(COQLIBINSTALL)' + @echo 'COQDOCINSTALL = $(COQDOCINSTALL)' +.PHONY: printenv + +# Generate a .merlin file. If you need to append directives to this +# file you can extend the merlin-hook target in Makefile.local +.merlin: + $(SHOW)'FILL .merlin' + $(HIDE)echo 'FLG $(COQMF_CAMLFLAGS)' > .merlin + $(HIDE)echo 'B $(COQLIB)' >> .merlin + $(HIDE)echo 'S $(COQLIB)' >> .merlin + $(HIDE)$(foreach d,$(COQ_SRC_SUBDIRS), \ + echo 'B $(COQLIB)$(d)' >> .merlin;) + $(HIDE)$(foreach d,$(COQ_SRC_SUBDIRS), \ + echo 'S $(COQLIB)$(d)' >> .merlin;) + $(HIDE)$(foreach d,$(SRC_SUBDIRS), echo 'B $(d)' >> .merlin;) + $(HIDE)$(foreach d,$(SRC_SUBDIRS), echo 'S $(d)' >> .merlin;) + $(HIDE)$(MAKE) merlin-hook -f "$(SELF)" +.PHONY: merlin + +merlin-hook:: + @# Extension point +.PHONY: merlin-hook + +# prints all variables +debug: + $(foreach v,\ + $(sort $(filter-out $(INITIAL_VARS) INITIAL_VARS,\ + $(.VARIABLES))),\ + $(info $(v) = $($(v)))) +.PHONY: debug + +.DEFAULT_GOAL := all + +# Local Variables: +# mode: makefile-gmake +# End: diff --git a/src/versions/standard/Makefile.local b/src/Makefile.local index 42b2414..913f948 100644 --- a/src/versions/standard/Makefile.local +++ b/src/Makefile.local @@ -23,7 +23,7 @@ clean:: cd ../unit-tests; make clean cleanall:: - rm -f ../3rdparty/alt-ergo/smtlib2_lex.ml ../3rdparty/alt-ergo/smtlib2_parse.ml ../3rdparty/alt-ergo/smtlib2_parse.mli .lia.cache Makefile Makefile.conf Makefile.local Tactics.v _CoqProject g_smtcoq.ml4 lfsc/lfscLexer.ml lfsc/lfscParser.ml lfsc/lfscParser.mli smtcoq_plugin.mlpack smtlib2/sExprLexer.ml smtlib2/sExprParser.ml smtlib2/sExprParser.mli verit/veritLexer.ml verit/veritParser.ml verit/veritParser.mli versions/standard/Array/PArray.v versions/standard/Int63/Int63.v versions/standard/Int63/Int63Axioms.v versions/standard/Int63/Int63Native.v versions/standard/Int63/Int63Op.v versions/standard/Int63/Int63Properties.v versions/standard/Structures.v + rm -f ../3rdparty/alt-ergo/smtlib2_lex.ml ../3rdparty/alt-ergo/smtlib2_parse.ml ../3rdparty/alt-ergo/smtlib2_parse.mli .lia.cache Makefile.conf lfsc/lfscLexer.ml lfsc/lfscParser.ml lfsc/lfscParser.mli smtlib2/sExprLexer.ml smtlib2/sExprParser.ml smtlib2/sExprParser.mli verit/veritLexer.ml verit/veritParser.ml verit/veritParser.mli @@ -10,7 +10,7 @@ (**************************************************************************) -Require Import Bool List PArray Int63 ZArith Psatz. +Require Import Bool List PArray Int63 Ring63 ZArith Psatz. Local Open Scope int63_scope. Local Open Scope array_scope. @@ -23,6 +23,23 @@ Proof. intros [ | ]; reflexivity. Qed. (** Lemmas about Int63 *) +Lemma reflect_eqb : forall i j, reflect (i = j)%Z (i == j). +Proof. + intros; apply iff_reflect. + symmetry;apply eqb_spec. +Qed. + +Lemma to_Z_eq : forall x y, [|x|] = [|y|] <-> x = y. +Proof. + split;intros;subst;trivial. + apply to_Z_inj;trivial. +Qed. + +Lemma max_int_wB : [|max_int|] = (wB - 1)%Z. +Proof. + reflexivity. +Qed. + Lemma le_eq : forall i j, (j <= i) = true -> (j + 1 <= i) = false -> i = j. Proof. @@ -32,7 +49,7 @@ Proof. assert (H2: (([|j|] + 1)%Z < wB)%Z \/ ([|j|] + 1)%Z = wB). pose (H3 := to_Z_bounded j); lia. destruct H2 as [H2|H2]. - rewrite Zmod_small in H. + rewrite Z.mod_small in H. lia. split. pose (H3 := to_Z_bounded j); lia. @@ -40,6 +57,15 @@ Proof. rewrite H2, Z_mod_same_full in H; elim H; destruct (to_Z_bounded i) as [H3 _]; assumption. Qed. +Lemma leb_0 : forall x, 0 <= x = true. +Proof. + intros x;rewrite leb_spec;destruct (to_Z_bounded x);trivial. +Qed. + +Lemma leb_refl : forall n, n <= n = true. +Proof. + intros n;rewrite leb_spec;apply Z.le_refl. +Qed. Lemma lt_eq : forall i j, (i < j + 1) = true -> (i < j) = false -> i = j. @@ -50,7 +76,7 @@ Proof. assert (H2: (([|j|] + 1)%Z < wB)%Z \/ ([|j|] + 1)%Z = wB). pose (H3 := to_Z_bounded j); lia. destruct H2 as [H2|H2]. - rewrite Zmod_small in H1. + rewrite Z.mod_small in H1. lia. split. pose (H3 := to_Z_bounded j); lia. @@ -58,6 +84,100 @@ Proof. rewrite H2, Z_mod_same_full in H1; elimtype False. destruct (to_Z_bounded i) as [H3 _]. lia. Qed. +Lemma not_0_ltb : forall x, x <> 0 <-> 0 < x = true. +Proof. + intros x;rewrite ltb_spec, to_Z_0;assert (W:=to_Z_bounded x);split. + intros Hd;assert ([|x|] <> 0)%Z;[ | omega]. + intros Heq;elim Hd;apply to_Z_inj;trivial. + intros Hlt Heq;elimtype False. + assert ([|x|] = 0)%Z;[ rewrite Heq, to_Z_0;trivial | omega]. +Qed. + +Lemma ltb_0 : forall x, ~ (x < 0 = true). +Proof. + intros x;rewrite ltb_spec, to_Z_0;destruct (to_Z_bounded x);omega. +Qed. + +Lemma not_ltb_refl : forall i, ~(i < i = true). +Proof. + intros;rewrite ltb_spec;omega. +Qed. + +Lemma ltb_trans : forall x y z, x < y = true -> y < z = true -> x < z = true. +Proof. + intros x y z;rewrite !ltb_spec;apply Z.lt_trans. +Qed. + +Lemma leb_ltb_eqb : forall x y, ((x <= y) = (x < y) || (x == y)). +Proof. + intros. + apply eq_true_iff_eq. + rewrite leb_spec, orb_true_iff, ltb_spec, eqb_spec, <- to_Z_eq;omega. +Qed. + +Lemma leb_ltb_trans : forall x y z, x <= y = true -> y < z = true -> x < z = true. +Proof. + intros x y z;rewrite leb_spec, !ltb_spec;apply Z.le_lt_trans. +Qed. + +Lemma to_Z_add_1 : forall x y, x < y = true -> [|x+1|] = ([|x|] + 1)%Z. +Proof. + intros x y;assert (W:= to_Z_bounded x);assert (W0:= to_Z_bounded y); + rewrite ltb_spec;intros;rewrite add_spec, to_Z_1, Z.mod_small;omega. +Qed. + +Lemma to_Z_add_1_wB : forall x, ([|x|] < wB - 1)%Z -> [|x + 1|] = ([|x|] + 1)%Z. +Proof. + intros; assert (Bx := to_Z_bounded x); rewrite add_spec, to_Z_1, Z.mod_small; lia. +Qed. + +Lemma leb_not_gtb : forall n m, m <= n = true -> ~(n < m = true). +Proof. + intros n m; rewrite ltb_spec, leb_spec;omega. +Qed. + +Lemma leb_negb_gtb : forall x y, x <= y = negb (y < x). +Proof. + intros x y;apply Bool.eq_true_iff_eq;split;intros. + apply Bool.eq_true_not_negb;apply leb_not_gtb;trivial. + rewrite Bool.negb_true_iff, <- Bool.not_true_iff_false in H. + rewrite leb_spec; rewrite ltb_spec in H;omega. +Qed. + +Lemma ltb_negb_geb : forall x y, x < y = negb (y <= x). +Proof. + intros;rewrite leb_negb_gtb, Bool.negb_involutive;trivial. +Qed. + +Lemma to_Z_sub_gt : forall x y, y <= x = true -> [|x - y|] = ([|x|] - [|y|])%Z. +Proof. + intros x y;assert (W:= to_Z_bounded x);assert (W0:= to_Z_bounded y); + rewrite leb_spec;intros;rewrite sub_spec, Zmod_small;omega. +Qed. + +Lemma to_Z_sub_1 : forall x y, y < x = true -> ([| x - 1|] = [|x|] - 1)%Z. +Proof. + intros;apply to_Z_sub_gt. + generalize (leb_ltb_trans _ _ _ (leb_0 y) H). + rewrite ltb_spec, leb_spec, to_Z_0, to_Z_1;auto with zarith. +Qed. + +Lemma to_Z_sub_1_diff : forall x, x <> 0 -> ([| x - 1|] = [|x|] - 1)%Z. +Proof. + intros x;rewrite not_0_ltb;apply to_Z_sub_1. +Qed. + +Lemma to_Z_sub_1_0 : forall x, (0 < [|x|])%Z -> [|x - 1|] = ([|x|] - 1)%Z. +Proof. + intros; apply (to_Z_sub_1 _ 0); rewrite ltb_spec; assumption. +Qed. + +Lemma ltb_leb_sub1 : forall x i, x <> 0 -> (i < x = true <-> i <= x - 1 = true). +Proof. + intros x i Hdiff. + rewrite ltb_spec, leb_spec, to_Z_sub_1_diff;trivial. + split;auto with zarith. +Qed. Lemma minus_1_lt i : (i == 0) = false -> i - 1 < i = true. Proof. @@ -70,689 +190,1143 @@ Proof. clear -H H1. change [|0|] with 0%Z. lia. Qed. +Lemma lsr0_l i: 0 >> i = 0. +Proof. + apply to_Z_inj. + generalize (lsr_spec 0 i). + rewrite to_Z_0, Zdiv_0_l; auto. +Qed. -Lemma foldi_down_ZInd2 : - forall A (P: Z -> A -> Prop) (f:int -> A -> A) max min a, - (max < min = true -> P ([|min|])%Z a) -> - (P ([|max|]+1)%Z a) -> - (forall i a, min <= i = true -> i <= max = true -> P ([|i|]+1)%Z a -> P [|i|] (f i a)) -> - P [|min|] (foldi_down f max min a). -Proof. - unfold foldi_down;intros A P f max min a Hlt;intros. - set (P' z cont := - if Zlt_bool z ([|min|]+1)%Z then cont = (fun a0 : A => a0) - else forall a, P z a -> P [|min|] (cont a)). - assert (H1: P' ([|max|]+1)%Z (foldi_down_cont (fun (i : int) (cont : A -> A) (a0 : A) => cont (f i a0)) max - min (fun a0 : A => a0))). - apply foldi_down_cont_ZInd;intros;red. - assert (H20: (z+1 < [|min|]+1)%Z). - lia. - rewrite Zlt_is_lt_bool in H20; rewrite H20;trivial. - case_eq (Zlt_bool ([|i|]+1) ([|min|]+1));intros. - rewrite <- Zlt_is_lt_bool in H4;rewrite leb_spec in H1;elimtype False;lia. - clear H4;revert H3;unfold P'. - case_eq (Zlt_bool ([|i|] - 1 + 1) ([|min|]+1));intros;auto. - rewrite <- Zlt_is_lt_bool in H3; assert ([|i|] = [|min|]) by (rewrite leb_spec in H1;lia). - rewrite H4, <- H6. apply H0;trivial. - apply H4. replace ([|i|] - 1 + 1)%Z with [|i|] by lia. auto. - revert H1;unfold P'. - case_eq (Zlt_bool ([|max|]+1)%Z ([|min|]+1)%Z);auto. - rewrite <- Zlt_is_lt_bool. - intro H22; assert (H21: ([|max|] < [|min|])%Z). lia. - rewrite <- ltb_spec in H21. intros;rewrite foldi_down_cont_lt;auto. -Qed. - - -Lemma foldi_down_Ind2 : forall A (P : int -> A -> Prop) f max min a, - (max < max_int = true) -> - (max < min = true -> P min a) -> - P (max+1) a -> - (forall i a, min <= i = true -> i <= max = true -> - P (i+1) a -> P i (f i a)) -> - P min (foldi_down f max min a). -Proof. - intros A P f max min a H H0 H1 H2. - set (P' z a := (0 <= z < wB)%Z -> P (of_Z z) a). - assert (W:= to_Z_add_1 _ _ H). - assert (P' ([|min|])%Z (foldi_down f max min a)). - apply foldi_down_ZInd2;unfold P';intros. - rewrite of_to_Z;auto. - rewrite <- W, of_to_Z;auto. - rewrite of_to_Z. apply H2; trivial. - assert (i < max_int = true). - apply leb_ltb_trans with max; trivial. - rewrite <- (to_Z_add_1 _ _ H7) in H5. rewrite of_to_Z in H5. apply H5. apply to_Z_bounded. - unfold P' in H3; rewrite of_to_Z in H3;apply H3;apply to_Z_bounded. -Qed. - - -(** Lemmas about PArray.to_list *) +Lemma lxor_lsr i1 i2 i: (i1 lxor i2) >> i = (i1 >> i) lxor (i2 >> i). +Proof. + apply bit_ext; intros n. + rewrite lxor_spec, !bit_lsr, lxor_spec. + case (_ <= _); auto. +Qed. -Lemma to_list_In : forall {A} (t: array A) i, - i < length t = true -> In (t.[i]) (to_list t). +Lemma bit_or_split i : i = (i>>1)<<1 lor bit i 0. Proof. - intros A t i H; unfold to_list; case_eq (0 == length t); intro Heq. - unfold is_true in H; rewrite ltb_spec in H; rewrite eqb_spec in Heq; rewrite <- Heq in H; rewrite to_Z_0 in H; pose (H1 := to_Z_bounded i); elimtype False; lia. - pose (P := fun j a => i < j = true \/ In (t .[ i]) a). - pose (H1:= foldi_down_Ind2 _ P); unfold P in H1. - assert (H2: i < 0 = true \/ In (t .[ i]) (foldi_down (fun (i0 : int) (l : list A) => t .[ i0] :: l) (length t - 1) 0 nil)). - apply H1. - rewrite ltb_spec; erewrite to_Z_sub_1; try eassumption. - pose (H2 := to_Z_bounded (length t)); change [|max_int|] with (wB-1)%Z; lia. - intro H2; elimtype False; rewrite ltb_spec, to_Z_0 in H2; pose (H3 := to_Z_bounded (length t - 1)); lia. - left; unfold is_true; rewrite ltb_spec; rewrite (to_Z_add_1 _ max_int). - erewrite to_Z_sub_1; try eassumption. - unfold is_true in H; rewrite ltb_spec in H; lia. - rewrite ltb_spec; erewrite to_Z_sub_1; try eassumption. - pose (H2 := to_Z_bounded (length t)); change [|max_int|] with (wB-1)%Z; lia. - intros j a H2 H3 [H4|H4]. - case_eq (i < j); intro Heq2. - left; reflexivity. - right; rewrite (lt_eq _ _ H4 Heq2); constructor; reflexivity. - right; constructor 2; assumption. - destruct H2 as [H2|H2]; try assumption. - unfold is_true in H2; rewrite ltb_spec, to_Z_0 in H2; pose (H3 := to_Z_bounded i); elimtype False; lia. + apply bit_ext. + intros n; rewrite lor_spec. + rewrite bit_lsl, bit_lsr, bit_b2i. + case (to_Z_bounded n); intros Hi _. + case (Zle_lt_or_eq _ _ Hi). + 2: replace 0%Z with [|0|]; auto; rewrite to_Z_eq. + 2: intros H; rewrite <-H. + 2: replace (0 < 1) with true; auto. + intros H; clear Hi. + case_eq (n == 0). + rewrite eqb_spec; intros H1; generalize H; rewrite H1; discriminate. + intros _; rewrite orb_false_r. + case_eq (n < 1). + rewrite ltb_spec, to_Z_1; intros HH; contradict HH; auto with zarith. + intros _. + generalize (@bit_M i n); case (_ <= _). + intros H1; rewrite H1; auto. + intros _. + case (to_Z_bounded n); intros H1n H2n. + assert (F1: [|n - 1|] = ([|n|] - 1)%Z). + rewrite sub_spec, Zmod_small; rewrite to_Z_1; auto with zarith. + generalize (add_le_r 1 (n - 1)); case (_ <= _); rewrite F1, to_Z_1; intros HH. + replace (1 + (n -1)) with n. change (bit i n = bit i n). reflexivity. + apply to_Z_inj; rewrite add_spec, F1, Zmod_small; rewrite to_Z_1; + auto with zarith. + rewrite bit_M; auto; rewrite leb_spec. + replace [|n|] with wB; try discriminate; auto with zarith. Qed. -Lemma to_list_In_eq : forall {A} (t: array A) i x, - i < length t = true -> x = t.[i] -> In x (to_list t). +Lemma lsr_is_even_eq : forall i j, + i >> 1 = j >> 1 -> + is_even i = is_even j -> + i = j. Proof. - intros A t i x Hi ->. now apply to_list_In. + intros;apply bit_ext. + intros n;destruct (reflect_eqb n 0). + rewrite <- (negb_involutive (bit i n)), <- (negb_involutive (bit j n)). + rewrite e, <- !is_even_bit, H0;trivial. + assert (W1 : [|n|] <> 0%Z) by (intros Heq;apply n0;apply to_Z_inj;trivial). + assert (W2 := to_Z_bounded n);clear n0. + assert (W3 : [|n-1|] = ([|n|] - 1)%Z). + rewrite sub_spec, to_Z_1, Zmod_small;trivial;omega. + assert (H1 : n = (n-1)+1). + apply to_Z_inj;rewrite add_spec, W3. + rewrite Zmod_small;rewrite to_Z_1; omega. + case_eq ((n-1) < digits); intro l. + rewrite ltb_spec in l. + rewrite H1, <- !bit_half, H; trivial; rewrite ltb_spec; trivial. + assert ((digits <= n) = true). + rewrite <- Bool.not_true_iff_false, ltb_spec in l; rewrite leb_spec;omega. + rewrite !bit_M;trivial. Qed. -Lemma In_to_list : forall {A} (t: array A) x, - In x (to_list t) -> exists i, i < length t = true /\ x = t.[i]. +Lemma lsr1_bit : forall i k, bit i k >> 1 = 0. Proof. - intros A t x; unfold to_list; case_eq (0 == length t); intro Heq. - intro H; inversion H. - rewrite eqb_false_spec in Heq. - pose (P (_:int) l := In x l -> - exists i : int, (i < length t) = true /\ x = t .[ i]). - pose (H1 := foldi_down_Ind2 _ P (fun (i : int) (l : list A) => t .[ i] :: l) (length t - 1) 0); unfold P in H1; apply H1. - rewrite ltb_spec, to_Z_sub_1_diff; auto; change [|max_int|] with (wB-1)%Z; pose (H2 := to_Z_bounded (length t)); lia. - intros _ H; inversion H. - intro H; inversion H. - simpl; intros i a _ H2 IH [H3|H3]. - exists i; split; auto; rewrite ltb_spec; rewrite leb_spec, to_Z_sub_1_diff in H2; auto; lia. - destruct (IH H3) as [j [H4 H5]]; exists j; auto. + intros;destruct (bit i k);trivial. Qed. +Lemma is_even_or i j : is_even (i lor j) = is_even i && is_even j. +Proof. + rewrite !is_even_bit, lor_spec; case bit; auto. +Qed. -(** Lemmas about PArray.mapi *) +Lemma is_even_xor i j : is_even (i lxor j) = negb (xorb (is_even i) (is_even j)). +Proof. + rewrite !is_even_bit, lxor_spec; do 2 case bit; auto. +Qed. -Lemma length_mapi : forall {A B} (f:int -> A -> B) t, - length (mapi f t) = length t. +Lemma bit_xor_split: forall i : int, i = (i >> 1) << 1 lxor bit i 0. Proof. - unfold mapi; intros A B f t; case_eq (length t == 0). - rewrite Int63Properties.eqb_spec; intro Heq; rewrite Heq, length_make; auto. - rewrite eqb_false_spec; intro Heq; apply foldi_ind. - rewrite length_make, ltb_length; auto. - intros i a _ H1 H2; rewrite length_set; auto. + intros. + rewrite bit_or_split at 1. + apply lsr_is_even_eq. + rewrite lxor_lsr, lor_lsr, lsr1_bit, lxor0_r, lor0_r;trivial. + rewrite is_even_or, is_even_xor. + rewrite is_even_lsl_1;trivial. + rewrite (xorb_true_l (is_even (bit i 0))), negb_involutive;trivial. Qed. +Lemma lxor_nilpotent: forall i, i lxor i = 0. +Proof. + intros;apply bit_ext;intros. + rewrite lxor_spec, xorb_nilpotent, bit_0;trivial. +Qed. -Lemma default_mapi : forall {A B} (f:int -> A -> B) t, - default (mapi f t) = f (length t) (default t). +Lemma int_ind : forall (P : int -> Prop), + P 0 -> + (forall i, (i < max_int) = true -> P i -> P (i + 1)) -> + forall i, P i. Proof. - unfold mapi; intros A B f t; case (length t == 0). - rewrite default_make; auto. - apply foldi_ind. - rewrite default_make; auto. - intros; rewrite default_set; auto. + intros P HP0 Hrec i. + assert (Bi := to_Z_bounded i). + destruct Bi as [ Bi0 Bi ]. + rewrite <- of_to_Z. + rewrite Z2Nat.inj_lt in Bi; [ | exact Bi0 | lia ]; clear Bi0. + rewrite <- (Z2Nat.id (to_Z i)); [ | apply to_Z_bounded ]. + revert Bi. + induction (Z.to_nat (to_Z i)); clear i. + intro; apply HP0. + rewrite Nat2Z.inj_lt. + rewrite Z2Nat.id; [ | generalize wB_pos; clear IHn; lia ]. + rewrite Nat2Z.inj_succ. + rewrite <- Z.add_1_r. + rewrite <- (Nat2Z.id n) in IHn at 1. + rewrite <- Z2Nat.inj_lt in IHn; [ | clear IHn; lia | clear IHn; generalize wB_pos; lia ]. + generalize (Z.of_nat n) IHn (Nat2Z.is_nonneg n); clear n IHn; intros z IHz Hz1 Hz2. + replace (of_Z (z + 1)) with (of_Z z + 1). + apply Hrec. + apply ltb_spec. + rewrite of_Z_spec, Z.mod_small, max_int_wB; lia. + apply IHz; lia. + apply to_Z_inj. + rewrite of_Z_spec, Z.mod_small by lia. + rewrite to_Z_add_1_wB, of_Z_spec. + rewrite Z.mod_small; lia. + rewrite of_Z_spec, Z.mod_small; lia. +Qed. + +Lemma int_ind_bounded : forall (P : int -> Prop) min max, + min <= max = true -> + P min -> + (forall i, min <= i = true -> i < max = true -> P i -> P (i + 1)) -> + P max. +Proof. + intros P min max Hle Hmin Hrec. + rewrite leb_spec in Hle. + assert (Bmin := to_Z_bounded min);assert (Bmax := to_Z_bounded max). + replace max with (min + (max - min)) by ring. + generalize (leb_refl (max - min)). + pattern (max - min) at 1 3. + apply int_ind. + intros _; replace (min + 0) with min by ring; exact Hmin. + intros i Hi1 IH; revert Hi1. + rewrite ltb_spec, leb_spec. + assert (Bi := to_Z_bounded i). + rewrite max_int_wB; intro Hi1. + replace (min + (i + 1)) with (min + i + 1) by ring. + rewrite to_Z_add_1_wB, sub_spec, Z.mod_small by lia. + intro Hi2; apply Hrec. + rewrite leb_spec, add_spec, Z.mod_small; lia. + rewrite ltb_spec, add_spec, Z.mod_small; lia. + apply IH. + rewrite leb_spec, sub_spec, Z.mod_small; lia. Qed. -Lemma get_mapi : forall {A B} (f:int -> A -> B) t i, - i < length t = true -> (mapi f t).[i] = f i (t.[i]). +Lemma bit_sub1_0 : forall i, bit (i - 1) 0 = negb (bit i 0). Proof. - intros A B f t i Hi; generalize (length_mapi f t); unfold mapi; case_eq (length t == 0). - rewrite Int63Properties.eqb_spec; intro Heq; rewrite Heq in Hi; eelim ltb_0; eassumption. - rewrite eqb_false_spec; intro Heq; pose (Hi':=Hi); replace (length t) with ((length t - 1) + 1) in Hi'. - generalize Hi'; apply (foldi_Ind _ (fun j a => (i < j) = true -> length a = length t -> a.[i] = f i (t.[i]))). - rewrite ltb_spec, (to_Z_sub_1 _ i); auto; destruct (to_Z_bounded (length t)) as [_ H]; change [|max_int|] with (wB-1)%Z; lia. - intros H _; eelim ltb_0; eassumption. - intros H; eelim ltb_0; eassumption. - intros j a _ H1 IH H2 H3; rewrite length_set in H3; case_eq (j == i). - rewrite Int63Properties.eqb_spec; intro Heq2; subst i; rewrite get_set_same; auto; rewrite H3; auto. - rewrite eqb_false_spec; intro Heq2; rewrite get_set_other; auto; apply IH; auto; rewrite ltb_spec; rewrite ltb_spec, (to_Z_add_1 _ (length t)) in H2. - assert (H4: [|i|] <> [|j|]) by (intro H4; apply Heq2, to_Z_inj; auto); lia. - rewrite ltb_spec; rewrite leb_spec, (to_Z_sub_1 _ _ Hi) in H1; lia. - apply to_Z_inj; rewrite (to_Z_add_1 _ max_int). - rewrite to_Z_sub_1_diff; auto; lia. - rewrite ltb_spec, to_Z_sub_1_diff; auto; destruct (to_Z_bounded (length t)) as [_ H]; change [|max_int|] with (wB-1)%Z; lia. +intro i. +cut (b2i (bit (i - 1) 0) = b2i (negb (bit i 0))). +generalize (bit (i - 1) 0) (negb (bit i 0)); intros b1 b2. +destruct b1; destruct b2; simpl; rewrite <- eqb_spec; trivial; discriminate. +replace (b2i (negb (bit i 0))) with (1 - bit i 0); [ | destruct (bit i 0); reflexivity ]. +rewrite <- to_Z_eq. +rewrite sub_spec, to_Z_1. +rewrite 2!bit_0_spec. +rewrite sub_spec, to_Z_1. +case_eq (i == 0). +rewrite eqb_spec; intro Hi; rewrite Hi; reflexivity. +rewrite <- not_true_iff_false, eqb_spec, <- to_Z_eq, to_Z_0. +generalize (to_Z_bounded i). +intros Hi1 Hi2. +rewrite (Zmod_small _ wB); [ | lia ]. +assert (0 <= to_Z i mod 2 < 2)%Z. +apply Z_mod_lt; lia. +rewrite (Zmod_small _ wB); [ | lia ]. +rewrite 2!Zmod_even. +rewrite Z.even_sub. +case (Z.even (to_Z i)). +reflexivity. +reflexivity. Qed. +Lemma sub1_lsr : forall i, i <> 0 -> (i - 1) >> 1 = if bit i 0 then i >> 1 else i >> 1 - 1. +intro i. +rewrite <- to_Z_eq, to_Z_0; intro Hi0. +assert (Hi : (0 < to_Z i < wB)%Z). +generalize (to_Z_bounded i); lia. +clear Hi0. +rewrite <- to_Z_eq. +rewrite lsr_spec, to_Z_sub_1_0, to_Z_1; [ | lia ]. +case_eq (bit i 0); intro Hibit. +rewrite lsr_spec, to_Z_1. +change (2 ^ 1)%Z with 2%Z. +rewrite to_Z_split. +rewrite Hibit. +rewrite <- Z.add_sub_assoc. +change (to_Z true) with 1%Z. +replace (1 - 1)%Z with 0%Z by ring. +rewrite 2!Z.div_add_l; [ reflexivity | lia | lia ]. +rewrite to_Z_sub_1_0. +rewrite lsr_spec, to_Z_1. +change (2 ^ 1)%Z with 2%Z. +rewrite to_Z_split. +rewrite Hibit. +rewrite <- Z.add_sub_assoc. +change (to_Z false) with 0%Z. +rewrite 2!Z.div_add_l; [ | lia | lia ]. +rewrite <- Z.add_sub_assoc; reflexivity. +rewrite lsr_spec. +change (2 ^ to_Z 1)%Z with 2%Z. +apply Z.div_str_pos. +split; [ lia | ]. +cut (to_Z i <> 1)%Z; [ lia | ]. +change 1%Z with (to_Z 1). +rewrite to_Z_eq. +intro H; rewrite H in Hibit; discriminate. +Qed. -Lemma get_mapi_outofbound : forall {A B} (f:int -> A -> B) t i, - i < length t = false -> (mapi f t).[i] = f (length t) (default t). +Lemma pow2_lsr : forall i n, + (to_Z i < 2 ^ Z.of_nat (S n))%Z -> (to_Z (i >> 1) < 2 ^ Z.of_nat n)%Z. Proof. - intros A B f t i H1; rewrite get_outofbound. - apply default_mapi. - rewrite length_mapi; auto. +intros i n Hi. +rewrite lsr_spec. +change (2 ^ to_Z 1)%Z with 2%Z. +apply (Zmult_lt_reg_r _ _ 2); [ lia | ]. +rewrite Zmult_comm. +apply (Z.le_lt_trans _ (to_Z i)). +apply Z.mul_div_le; lia. +rewrite <- two_power_nat_equiv in *. +rewrite two_power_nat_S in Hi. +rewrite Zmult_comm; assumption. Qed. +Lemma pow2_size : forall i, (to_Z i < 2 ^ Z.of_nat size)%Z. +Proof. +intro i. +change (2 ^ Z.of_nat size)%Z with wB. +generalize (to_Z_bounded i); lia. +Qed. -(** Custom fold_left and fold_right *) +Fixpoint iter_int63_aux (n : nat) (i : int) (A : Type) (f : A -> A) : A -> A := + match n with + | O => fun x => x + | S n => + if i == 0 then fun x => x + else let g := iter_int63_aux n (i >> 1) A f in + fun x => if bit i 0 then f (g (g x)) else g (g x) + end. -Definition afold_left A B default (OP : A -> A -> A) (F : B -> A) (V : array B) := - let n := PArray.length V in - if n == 0 then default - else foldi (fun i a => OP a (F (V.[i]))) 1 (n-1) (F (V.[0])). +Definition iter_int63 := iter_int63_aux size. +Lemma iter_int63_aux_comm : forall n i A f a, + (to_Z i < 2 ^ Z.of_nat n)%Z -> + iter_int63_aux n i A f (f a) = f (iter_int63_aux n i A f a). +Proof. +intros n i A f; revert i; induction n. +intros i a Hi. +assert (i = 0). +rewrite <- to_Z_eq, to_Z_0. +generalize (to_Z_bounded i); lia. +reflexivity. +intros i a Hi; simpl. +case (i == 0); [ reflexivity | ]. +rewrite IHn; [ | apply pow2_lsr; assumption]. +rewrite IHn; [ | apply pow2_lsr; assumption]. +case (bit i 0); reflexivity. +Qed. -Definition afold_right A B default (OP : A -> A -> A) (F : B -> A) (V : array B) := - let n := PArray.length V in - if n == 0 then default else - if n <= 1 then F (V.[0]) - else foldi_down (fun i b => OP (F (V.[i])) b) (n-2) 0 (F (V.[n-1])). +Lemma iter_int63_comm : forall i A f a, + iter_int63 i A f (f a) = f (iter_int63 i A f a). +Proof. +intros i A f a. +unfold iter_int63. +apply iter_int63_aux_comm. +apply pow2_size. +Qed. +Lemma iter_int63_aux_S : forall n i A f a, + (0 < to_Z i < 2 ^ Z.of_nat n)%Z -> + iter_int63_aux n i A f a = f (iter_int63_aux n (i - 1) A f a). +Proof. +intros n i A f; revert i; induction n; intros i a Hi. +{ + lia. +} +simpl. +replace (i == 0) with false. +{ + rewrite bit_sub1_0, sub1_lsr. + { + case_eq (bit i 0); simpl. + { + intros _. + case_eq (i == 1). + { + rewrite eqb_spec; intro H; rewrite H in *; clear i H. + case n; reflexivity. + } + rewrite <- not_true_iff_false, eqb_spec, <- to_Z_eq, to_Z_1; intro Hi1. + replace (i - 1 == 0) with false. + { + reflexivity. + } + symmetry. + rewrite <- not_true_iff_false, eqb_spec, <- to_Z_eq, to_Z_sub_1_0, to_Z_0; lia. + } + intro Hibit. + case_eq (i == 1). + { + rewrite eqb_spec; intro H; rewrite H in *; clear i H; discriminate. + } + rewrite <- not_true_iff_false, eqb_spec, <- to_Z_eq, to_Z_1; intro Hi1. + replace (i - 1 == 0) with false. + { + case_eq (i == 2). + { + rewrite eqb_spec; intro H; rewrite H in *; clear i H. + destruct n; [ lia | ]. + case n; reflexivity. + } + rewrite <- not_true_iff_false, eqb_spec, <- to_Z_eq. + change (to_Z 2) with 2%Z; intro Hi2. + rewrite (IHn (i >> 1)). + { + rewrite (IHn (i >> 1)). + { + f_equal. + apply iter_int63_aux_comm. + replace (i >> 1 - 1) with ((i - 1) >> 1). + { + apply pow2_lsr. + rewrite to_Z_sub_1_0; lia. + } + rewrite sub1_lsr, Hibit; [ reflexivity | ]. + rewrite <- to_Z_eq, to_Z_0; lia. + } + split. + { + rewrite lsr_spec, to_Z_1. + change (2 ^ 1)%Z with 2%Z. + apply Z.div_str_pos; lia. + } + apply pow2_lsr; lia. + } + split. + { + rewrite lsr_spec, to_Z_1. + change (2 ^ 1)%Z with 2%Z. + apply Z.div_str_pos; lia. + } + apply pow2_lsr; lia. + } + symmetry. + rewrite <- not_true_iff_false, eqb_spec, <- to_Z_eq, to_Z_sub_1_0, to_Z_0; lia. + } + rewrite <- to_Z_eq, to_Z_0; lia. +} +symmetry. +rewrite <- not_true_iff_false, eqb_spec, <- to_Z_eq, to_Z_0; lia. +Qed. -(** Some properties about afold_left *) +Lemma iter_int63_S : forall i A f a, 0 < i = true -> iter_int63 i A f a = f (iter_int63 (i - 1) A f a). +Proof. +intros i A f a. +rewrite ltb_spec, to_Z_0; intro Hi. +unfold iter_int63. +apply iter_int63_aux_S. +split; [ lia | ]. +apply pow2_size. +Qed. -Lemma afold_left_eq : - forall A B OP def (F1 F2 : A -> B) V1 V2, - length V1 = length V2 -> - (forall i, i < length V1 = true -> F1 (V1.[i]) = F2 (V2.[i])) -> - afold_left _ _ def OP F1 V1 = afold_left _ _ def OP F2 V2. +Definition foldi + {A : Type} + (f : int -> A -> A) + (from to : int) + (a : A) + : A := + if to <= from then + a + else + let (_,r) := iter_int63 (to - from) _ (fun (jy: (int * A)%type) => + let (j,y) := jy in (j + 1, f j y) + ) (from, a) in r. + +Lemma foldi_ge : forall A f from to (a:A), + to <= from = true -> foldi f from to a = a. Proof. - unfold afold_left;intros. rewrite <- H. - destruct (Int63Properties.reflect_eqb (length V1) 0);trivial. - rewrite (H0 0); [ | unfold is_true;rewrite <- not_0_ltb;trivial]. - apply foldi_eq_compat;intros;rewrite H0;trivial. - unfold is_true;rewrite ltb_leb_sub1;trivial. + intros A f from to a; unfold foldi. + intro H; rewrite H; reflexivity. Qed. +Lemma foldi_lt_l : forall A f from to (a:A), + from < to = true -> foldi f from to a = foldi f (from + 1) to (f from a). +Proof. +intros A f from to a Hfromto. +pose proof (to_Z_bounded from) as Hfrom. +pose proof (to_Z_bounded to) as Hto. +unfold foldi. +rewrite leb_negb_gtb. +rewrite Hfromto; simpl. +rewrite ltb_spec in Hfromto. +case_eq (to <= from + 1). +rewrite leb_spec, to_Z_add_1_wB; [ | lia ]. +intro Htofrom. +assert (H : to = from + 1). +rewrite <- to_Z_eq. +rewrite to_Z_add_1_wB; lia. +rewrite H; clear H. +replace (from + 1 - from) with 1 by ring. +rewrite iter_int63_S; [ | reflexivity ]. +change (1 - 1) with 0. +reflexivity. +replace (to - (from + 1)) with (to - from - 1) by ring. +rewrite iter_int63_S. +rewrite (iter_int63_comm _ _ + (fun jy : int * A => let (j, y) := jy in (j + 1, f j y)) + (from, a)). +reflexivity. +rewrite ltb_spec, to_Z_0, sub_spec, Zmod_small; lia. +Qed. -Definition afoldi_left {A B:Type} default (OP : int -> A -> A -> A) (F : B -> A) (V : array B) := - let n := PArray.length V in - if n == 0 then default - else foldi (fun i a => OP i a (F (V.[i]))) 1 (n-1) (F (V.[0])). +Lemma foldi_lt_r : forall A f from to (a:A), + from < to = true -> foldi f from to a = f (to - 1) (foldi f from (to - 1) a). +Proof. + intros A f from to a; rewrite ltb_spec; intro Hlt. + assert (Bfrom := to_Z_bounded from); assert (Bto := to_Z_bounded to). + replace from with (max_int - (max_int - from)) by ring. + revert a; pattern (max_int - from). + apply (int_ind_bounded _ (max_int - (to - 1))). + rewrite leb_spec, sub_spec, to_Z_sub_1_0, sub_spec, max_int_wB, 2!Z.mod_small by lia; lia. + intro a; replace (max_int - (max_int - (to - 1))) with (to - 1) by ring. + rewrite foldi_lt_l by (rewrite ltb_spec, to_Z_sub_1_0; lia). + ring_simplify (to - 1 + 1). + rewrite 2!foldi_ge by (rewrite leb_spec; lia); reflexivity. + intro i; rewrite leb_spec, ltb_spec, sub_spec, to_Z_sub_1_0, sub_spec, max_int_wB, 2!Z.mod_small by lia. + intros Hi1 Hi2 IH a. + rewrite foldi_lt_l by (rewrite ltb_spec, sub_spec, to_Z_add_1_wB, max_int_wB, Z.mod_small by lia; lia). + rewrite (foldi_lt_l _ _ (max_int - (i + 1))) by (rewrite ltb_spec, sub_spec, to_Z_add_1_wB, to_Z_sub_1_0, max_int_wB, Z.mod_small by lia; lia). + replace (max_int - (i + 1) + 1) with (max_int - i) by ring. + apply IH. +Qed. +Lemma foldi_ind : forall A (P : int -> A -> Prop) f from to a, + from <= to = true -> P from a -> + (forall i a, from <= i = true -> i < to = true -> P i a -> P (i + 1) (f i a)) -> + P to (foldi f from to a). +Proof. + intros A P f from to a Hle Hfrom IH. + assert (Bfrom := to_Z_bounded from); assert (Bto := to_Z_bounded to). + pattern to; apply (int_ind_bounded _ from). + exact Hle. + rewrite foldi_ge by (rewrite leb_spec; lia). + exact Hfrom. + intro i; assert (Bi := to_Z_bounded i). + rewrite leb_spec, ltb_spec; intros Hi1 Hi2; rewrite (foldi_lt_r _ _ _ (i + 1)) by (rewrite ltb_spec, to_Z_add_1_wB; lia). + ring_simplify (i + 1 - 1); apply IH; [ rewrite leb_spec; exact Hi1 | rewrite ltb_spec; exact Hi2 ]. +Qed. -Lemma afoldi_left_Ind : - forall {A B: Type} (P : int -> A -> Prop) default (OP : int -> A -> A -> A) (F : B -> A) (t:array B), - if length t == 0 then - True - else - (forall a i, i < length t = true -> P i a -> P (i+1) (OP i a (F (t.[i])))) -> - P 1 (F (t.[0])) -> - P (length t) (afoldi_left default OP F t). +Lemma foldi_ind2 : forall A B (P : int -> A -> B -> Prop) f1 f2 from to a1 a2, + from <= to = true -> P from a1 a2 -> + (forall i a1 a2, from <= i = true -> i < to = true -> P i a1 a2 -> P (i + 1) (f1 i a1) (f2 i a2)) -> + P to (foldi f1 from to a1) (foldi f2 from to a2). Proof. - intros A B P default OP F t; case_eq (length t == 0). - intros; exact I. - intros Heq H1 H2; unfold afoldi_left; rewrite Heq; - assert (H: (length t - 1) + 1 = length t) by ring. - rewrite <- H at 1; apply foldi_Ind; auto. - assert (W:= leb_max_int (length t)); rewrite leb_spec in W. - rewrite ltb_spec, to_Z_sub_1_diff; auto with zarith. - intro H3; rewrite H3 in Heq; discriminate. - intro Hlt; assert (H3: length t - 1 = 0). - rewrite ltb_spec, to_Z_1 in Hlt; apply to_Z_inj; rewrite to_Z_0; pose (H3 := to_Z_bounded (length t - 1)); lia. - rewrite H3; assumption. - intros i a H3 H4; apply H1; trivial. - rewrite ltb_leb_sub1; auto. - intro H5; rewrite H5 in Heq; discriminate. + intros A B P f1 f2 from to a1 a2 Hle Hfrom IH. + assert (Bfrom := to_Z_bounded from); assert (Bto := to_Z_bounded to). + pattern to; apply (int_ind_bounded _ from). + exact Hle. + rewrite 2!foldi_ge by (rewrite leb_spec; lia). + exact Hfrom. + intro i; assert (Bi := to_Z_bounded i). + rewrite leb_spec, ltb_spec; intros Hi1 Hi2; rewrite 2!(foldi_lt_r _ _ _ (i + 1)) by (rewrite ltb_spec, to_Z_add_1_wB; lia). + ring_simplify (i + 1 - 1); apply IH; [ rewrite leb_spec; exact Hi1 | rewrite ltb_spec; exact Hi2 ]. Qed. +Lemma foldi_eq_compat : forall A (f1 f2:int -> A -> A) min max a, + (forall i a, min <= i = true -> i < max = true -> f1 i a = f2 i a) -> + foldi f1 min max a = foldi f2 min max a. +Proof. + intros A f1 f2 min max a Hf. + assert (Bmin := to_Z_bounded min); assert (Bmax := to_Z_bounded max). + case (Z.lt_ge_cases [|min|] [|max|]); [ intro Hlt | intro Hle ]. + apply (foldi_ind2 _ _ (fun _ a b => a = b)); [ rewrite leb_spec; lia | reflexivity | ]. + intros i a1 a2 Hi1 Hi2 Heq; rewrite Heq; apply Hf; assumption. + rewrite 2!foldi_ge by (rewrite leb_spec; lia); reflexivity. +Qed. -Lemma afold_left_Ind : - forall A B (P : int -> A -> Prop) default (OP : A -> A -> A) (F : B -> A) (t:array B), - if length t == 0 then - True - else - (forall a i, i < length t = true -> P i a -> P (i+1) (OP a (F (t.[i])))) -> - P 1 (F (t.[0])) -> - P (length t) (afold_left A B default OP F t). +(** Lemmas about to_list *) + +Definition to_list {A : Type} (t : array A) := + List.rev (foldi (fun i l => t.[i] :: l)%list 0 (length t) nil). + +Lemma foldi_to_list : forall A B (f : A -> B -> A) a e, + foldi (fun i x => f x (a.[i])) 0 (length a) e = fold_left f (to_list a) e. +Proof. + intros A B f a e; unfold to_list. + rewrite <- fold_left_rev_right, rev_involutive. + apply (foldi_ind2 _ _ (fun _ a b => a = fold_right (fun y x => f x y) e b)). + apply leb_0. + reflexivity. + intros i x l _ Hi IH. + simpl; f_equal; exact IH. +Qed. + +Lemma to_list_In : forall {A} (t: array A) i, + i < length t = true -> In (t.[i]) (to_list t). + intros A t i; assert (Bt := to_Z_bounded (length t)); assert (Bi := to_Z_bounded i); rewrite ltb_spec; unfold to_list. + rewrite <- in_rev. + apply foldi_ind. + rewrite leb_spec, to_Z_0; lia. + rewrite to_Z_0; lia. + intros j l _; assert (Bj := to_Z_bounded j). + rewrite ltb_spec; intros Hj IH. + rewrite to_Z_add_1_wB by lia; intro Hij. + case (reflect_eqb j i); [ intro Heq; rewrite Heq; clear Heq | rewrite <- to_Z_eq; intro Hneq ]. + apply in_eq. + apply in_cons. + apply IH. + lia. +Qed. + +Lemma to_list_In_eq : forall {A} (t: array A) i x, + i < length t = true -> x = t.[i] -> In x (to_list t). +Proof. + intros A t i x Hi ->. now apply to_list_In. +Qed. + +Lemma In_to_list : forall {A} (t: array A) x, + In x (to_list t) -> exists i, i < length t = true /\ x = t.[i]. +Proof. + intros A t x; assert (Bt := to_Z_bounded (length t)); unfold to_list. + rewrite <- in_rev. + set (a := foldi _ _ _ _); pattern (length t) at 0, a; subst a; apply foldi_ind. + rewrite leb_spec, to_Z_0; lia. + intro H; elim (in_nil H). + intros i a _; assert (Bi := to_Z_bounded i); rewrite ltb_spec; intros Hi IH. + intro Hin; case (in_inv Hin); clear Hin; [ | exact IH ]. + intro H; rewrite <- H; clear H. + exists i. + split; [ rewrite ltb_spec; lia | reflexivity ]. +Qed. + +(** Lemmas about amapi/amap *) + +Definition amapi {A B:Type} (f:int->A->B) (t:array A) := + let l := length t in + foldi (fun i tb => tb.[i <- f i (t.[i])]) 0 l (make l (f l (default t))). + +Definition amap {A B:Type} (f:A->B) := amapi (fun _ => f). + +Lemma length_amapi : forall {A B} (f:int -> A -> B) t, + length (amapi f t) = length t. +Proof. + unfold amapi; intros A B f t. + assert (Bt := to_Z_bounded (length t)). + apply (foldi_ind _ (fun _ a => length a = length t)). + apply leb_0. + rewrite length_make, leb_length by reflexivity; reflexivity. + intros i a _; assert (Bi := to_Z_bounded i). + rewrite ltb_spec; intros Hi IH. + rewrite length_set; exact IH. +Qed. + +Lemma length_amap : forall {A B} (f:A -> B) t, + length (amap f t) = length t. +Proof. + intros; unfold amap; apply length_amapi. +Qed. + +Lemma default_amapi : forall {A B} (f:int -> A -> B) t, + default (amapi f t) = f (length t) (default t). +Proof. + unfold amapi; intros A B f t. + assert (Bt := to_Z_bounded (length t)). + apply (foldi_ind _ (fun i a => default a = f (length t) (default t))). + apply leb_0. + rewrite default_make by reflexivity; reflexivity. + intros i a _; assert (Bi := to_Z_bounded i). + rewrite ltb_spec; intros Hi IH. + rewrite default_set; exact IH. +Qed. + +Lemma default_amap : forall {A B} (f:A -> B) t, + default (amap f t) = f (default t). Proof. - intros A B P default OP F t; - apply (afoldi_left_Ind P default (fun _ => OP)); trivial. + intros; unfold amap; apply default_amapi. Qed. +Lemma get_amapi : forall {A B} (f:int -> A -> B) t i, + i < length t = true -> (amapi f t).[i] = f i (t.[i]). +Proof. + intros A B f t. + assert (Bt := to_Z_bounded (length t)). + intro i; assert (Bi := to_Z_bounded i). + rewrite ltb_spec; intro Hi. + generalize (length_amapi f t); unfold amapi; revert Hi. + set (a := foldi _ _ _ _); pattern (length t) at 1, a; subst a; apply foldi_ind. + rewrite leb_spec, to_Z_0; lia. + rewrite to_Z_0; lia. + intros j a _; assert (Bj := to_Z_bounded j). + rewrite ltb_spec; intros Hj IH. + rewrite to_Z_add_1_wB by lia; intro Hij. + rewrite length_set; case (reflect_eqb j i); [ intro Heq; rewrite Heq | intro Hneq ]; intro Hlength. + rewrite get_set_same by (rewrite Hlength, ltb_spec; lia); reflexivity. + rewrite get_set_other by exact Hneq. + apply IH; [ rewrite <- to_Z_eq in Hneq; lia | exact Hlength ]. +Qed. -Lemma afold_left_ind : - forall A B (P : A -> Prop) default (OP : A -> A -> A) (F : B -> A) (t:array B), - (forall a i, i < length t = true -> P a -> P (OP a (F (t.[i])))) -> - P default -> P (F (t.[0])) -> - P (afold_left _ _ default OP F t). +Lemma get_amap : forall {A B} (f:A -> B) t i, + i < length t = true -> (amap f t).[i] = f (t.[i]). Proof. - intros A B P default OP F t H1 H2 H4. - pose (H3 := afold_left_Ind A B (fun _ => P) default OP F t). - case_eq (length t == 0); intro Heq. - unfold afold_left; rewrite Heq; assumption. - rewrite Heq in H3; apply H3; trivial. + intros; unfold amap; apply get_amapi; assumption. Qed. +Lemma get_amapi_outofbound : forall {A B} (f:int -> A -> B) t i, + i < length t = false -> (amapi f t).[i] = f (length t) (default t). +Proof. + intros A B f t i H1; rewrite get_outofbound. + apply default_amapi. + rewrite length_amapi; auto. +Qed. -Lemma afold_left_spec : forall A B (f:B -> A) args op e, +Lemma get_amap_outofbound : forall {A B} (f:A -> B) t i, + i < length t = false -> (amap f t).[i] = f (default t). +Proof. + intros; unfold amap; apply get_amapi_outofbound; assumption. +Qed. + +Lemma to_list_amap : forall A B (f : A -> B) t, to_list (amap f t) = List.map f (to_list t). +Proof. + intros A B f t. + assert (Bt := to_Z_bounded (length t)). + unfold to_list; rewrite length_amap. + rewrite map_rev; f_equal. + apply (foldi_ind2 _ _ (fun i a b => a = map f b)). + apply leb_0. + reflexivity. + intros i a1 a2 _; assert (Bi := to_Z_bounded i). + rewrite ltb_spec; intros Hi IH. + simpl; f_equal. + apply get_amap. + rewrite ltb_spec; lia. + apply IH. +Qed. + +(** Some properties about afold_left *) + +Definition afold_left A default (OP : A -> A -> A) (V : array A) := + if length V == 0 then default + else foldi (fun i a => OP a (V.[i])) 1 (length V) (V.[0]). + +Lemma afold_left_spec : forall A args op (e : A), (forall a, op e a = a) -> - afold_left _ _ e op f args = - fold_left (fun a v => op a (f v)) e args. + afold_left _ e op args = + foldi (fun i a => op a (args.[i])) 0 (length args) e. Proof. - unfold afold_left, fold_left;intros A B f args op neu H10. + unfold afold_left;intros A args op neu H10. destruct (reflect_eqb (length args) 0) as [e|n]. - rewrite e, eqb_refl;trivial. - apply not_eq_sym in n;rewrite (eqb_false_complete _ _ n). - case_eq (0 < (length args - 1));intros H. - rewrite foldi_lt with (from := 0);trivial. - rewrite H10; auto. - assert (H0: (0 <> [|length args|])%Z). - intros Heq;apply n;apply to_Z_inj;trivial. - assert (H1: length args = 1). - generalize (to_Z_bounded (length args)). - rewrite <- not_true_iff_false, ltb_spec, to_Z_0, to_Z_sub_1_diff in H;auto. - intros;apply to_Z_inj;rewrite to_Z_1;lia. - rewrite H1; change (1 - 1) with 0; rewrite (foldi_eq _ _ 0 0); auto. + rewrite e, foldi_ge by reflexivity;trivial. + rewrite (foldi_lt_l _ _ 0) by (apply not_0_ltb; assumption). + f_equal; rewrite H10; reflexivity. Qed. +Lemma afold_left_eq : + forall A OP (def : A) V1 V2, + length V1 = length V2 -> + (forall i, i < length V1 = true -> V1.[i] = V2.[i]) -> + afold_left _ def OP V1 = afold_left _ def OP V2. +Proof. + intros A OP def V1 V2 Heqlength HeqV. + assert (BV1 := to_Z_bounded (length V1)). + unfold afold_left. + rewrite <- Heqlength. + case (reflect_eqb (length V1) 0). + reflexivity. + rewrite <- to_Z_eq, to_Z_0; intro Hneq. + rewrite <- HeqV by (rewrite ltb_spec, to_Z_0; lia). + apply (foldi_ind2 _ _ (fun i a b => a = b)). + rewrite leb_spec, to_Z_1; lia. + reflexivity. + intros i a1 a2; assert (Bi := to_Z_bounded i). + rewrite leb_spec, to_Z_1; intro Hi1. + rewrite ltb_spec by lia; intros Hi2 IH. + f_equal;[ exact IH | apply HeqV; rewrite ltb_spec; lia ]. +Qed. + +Lemma afold_left_ind : forall A OP def V (P : int -> A -> Prop), + (length V = 0 -> P 0 def) -> + (0 < length V = true -> P 1 (V.[0])) -> + (forall a i, 0 < i = true -> i < length V = true -> P i a -> P (i + 1) (OP a (V.[i]))) -> + P (length V) (afold_left A def OP V). +Proof. + intros A OP def V P HP0 HP1 HPOP. + assert (BV := to_Z_bounded (length V)). + unfold afold_left. + case (reflect_eqb (length V) 0); [ intro Heq; rewrite Heq; tauto | intro Hneq ]. + rewrite <- to_Z_eq, to_Z_0 in Hneq. + apply foldi_ind. + rewrite leb_spec, to_Z_1; lia. + apply HP1; rewrite ltb_spec, to_Z_0; lia. + intros i a; assert (Bi := to_Z_bounded i). + rewrite leb_spec, to_Z_1, ltb_spec; intros Hi1 Hi2 IH. + apply HPOP; [ rewrite ltb_spec, to_Z_0; lia | rewrite ltb_spec; lia | exact IH ]. +Qed. (** Some properties about afold_right *) -Lemma afold_right_eq : - forall A B OP def (F1 F2 : A -> B) V1 V2, - length V1 = length V2 -> - (forall i, i < length V1 = true -> F1 (V1.[i]) = F2 (V2.[i])) -> - afold_right _ _ def OP F1 V1 = afold_right _ _ def OP F2 V2. -Proof. - unfold afold_right;intros. - rewrite <- H. - destruct (Int63Properties.reflect_eqb (length V1) 0);trivial. - destruct (reflect_leb (length V1) 1);intros. - apply H0;unfold is_true;rewrite ltb_leb_sub1;trivial. apply leb_0. - assert (length V1 - 1 < length V1 = true). - rewrite ltb_leb_sub1;auto using leb_refl. - rewrite (H0 (length V1 - 1));trivial. - apply foldi_down_eq_compat;intros;rewrite H0;trivial. - unfold is_true;rewrite ltb_leb_sub1;[ | trivial]. - apply ltb_leb_sub1;trivial. - revert n0 H3;rewrite ltb_spec, leb_spec, to_Z_1, sub_spec. - change [|2|] with 2%Z. - intros HH;assert (W:= to_Z_bounded (length V1));rewrite Zmod_small;lia. -Qed. - - -Definition afoldi_right {A B:Type} default (OP : int -> A -> A -> A) (F : B -> A) (V : array B) := - let n := PArray.length V in - if n == 0 then default - else if n <= 1 then F (V .[ 0]) - else foldi_down (fun i a => OP i (F (V.[i])) a) (n-2) 0 (F (V.[n-1])). - - -Lemma afoldi_right_Ind : - forall {A B: Type} (P : int -> A -> Prop) default (OP : int -> A -> A -> A) (F : B -> A) (t:array B), - if length t <= 1 then - True - else - (forall a i, i < length t - 1 = true -> P (i+1) a -> P i (OP i (F (t.[i])) a)) -> - P ((length t)-1) (F (t.[(length t)-1])) -> - P 0 (afoldi_right default OP F t). -Proof. - intros A B P default OP F t; case_eq (length t <= 1). - intros; exact I. - intros Heq H1 H2; unfold afoldi_right. replace (length t == 0) with false. - rewrite Heq. - set (P' z a := P (of_Z (z + 1)) a). - change (P' ([|0|] - 1)%Z (foldi_down (fun (i : int) (a : A) => OP i (F (t .[ i])) a) (length t - 2) 0 (F (t .[ length t - 1])))). - apply foldi_down_ZInd;unfold P'. - intros Hlt;elim (ltb_0 _ Hlt). - replace (length t - 2) with (length t - 1 - 1) by ring. - rewrite to_Z_sub_1_diff. - ring_simplify ([|length t - 1|] - 1 + 1)%Z;rewrite of_to_Z;trivial. - assert (H10: (1 < length t) = true) by (rewrite ltb_negb_geb, Heq; auto). - intro H11. rewrite ltb_spec in H10. assert (H12: [|length t - 1|] = 0%Z) by (rewrite H11; auto). change [|1|] with (1%Z) in H10. rewrite to_Z_sub_1_diff in H12; [lia| ]. intro H13. assert (H14: [|length t|] = 0%Z) by (rewrite H13; auto). lia. - intros;ring_simplify ([|i|] - 1 + 1)%Z;rewrite of_to_Z;auto. - assert (i < length t - 1 = true). - rewrite ltb_spec. rewrite leb_spec in H0. replace (length t - 2) with (length t - 1 - 1) in H0 by ring. rewrite to_Z_sub_1_diff in H0; [lia| ]. intro H4. assert (H5: [|length t - 1|] = 0%Z) by (rewrite H4; auto). assert (H6: 1 < length t = true) by (rewrite ltb_negb_geb, Heq; auto). rewrite ltb_spec in H6. change ([|1|]) with (1%Z) in H6. rewrite to_Z_sub_1_diff in H5; [lia| ]. intro H7. assert (H8: [|length t|] = 0%Z) by (rewrite H7; auto). lia. - apply H1; [trivial| ]. - rewrite <-(to_Z_add_1 _ _ H4), of_to_Z in H3;auto. - symmetry. rewrite eqb_false_spec. intro H. rewrite H in Heq. discriminate. -Qed. - - -Lemma afold_right_Ind : - forall A B (P : int -> A -> Prop) default (OP : A -> A -> A) (F : B -> A) (t:array B), - if length t <= 1 then - True - else - (forall a i, i < length t - 1 = true -> P (i+1) a -> P i (OP (F (t.[i])) a)) -> - P ((length t)-1) (F (t.[(length t)-1])) -> - P 0 (afold_right A B default OP F t). -Proof. - intros A B P default OP F t; - apply (afoldi_right_Ind P default (fun _ => OP) F). -Qed. - - -Lemma afold_right_ind : - forall A B (P : A -> Prop) default (OP : A -> A -> A) (F : B -> A) (t:array B), - (forall a i, i < length t - 1 = true -> P a -> P (OP (F (t.[i])) a)) -> - P default -> P (F (t.[length t - 1])) -> - P (afold_right _ _ default OP F t). -Proof. - intros A B P default OP F t H1 H2 H4. - pose (H3 := afold_right_Ind A B (fun _ => P) default OP F t). - unfold afold_right. case_eq (length t == 0); auto. intro H10. assert (H := H10). rewrite eqb_false_spec in H. case_eq (length t <= 1); intro Heq. - replace 0 with (length t - 1); auto. apply to_Z_inj. rewrite to_Z_sub_1_diff; auto. rewrite leb_spec in Heq. assert (H5 := leb_0 (length t)). rewrite leb_spec in H5. change [|0|] with 0%Z in *. change [|1|] with 1%Z in Heq. assert (H6 : [|length t|] <> 0%Z) by (intro H6; elim H; apply to_Z_inj; auto). lia. rewrite Heq in H3. unfold afold_right in H3. rewrite H10, Heq in H3. apply H3; auto. -Qed. - - -Lemma afold_right_ind_nonempty : - forall A B (P : A -> Prop) default (OP : A -> A -> A) (F : B -> A) (t:array B), - (forall a i, i < length t - 1 = true -> P a -> P (OP (F (t.[i])) a)) -> - 0 < length t = true -> P (F (t.[length t - 1])) -> - P (afold_right _ _ default OP F t). -Proof. - intros A B P default OP F t H1 H2 H4. - pose (H3 := afold_right_Ind A B (fun _ => P) default OP F t). - unfold afold_right. assert (H10 : length t == 0 = false) by (rewrite eqb_false_spec; intro H; rewrite H in H2; discriminate). rewrite H10. assert (H := H10). rewrite eqb_false_spec in H. case_eq (length t <= 1); intro Heq. - replace 0 with (length t - 1); auto. apply to_Z_inj. rewrite to_Z_sub_1_diff; auto. rewrite leb_spec in Heq. assert (H5 := leb_0 (length t)). rewrite leb_spec in H5. change [|0|] with 0%Z in *. change [|1|] with 1%Z in Heq. assert (H6 : [|length t|] <> 0%Z) by (intro H6; elim H; apply to_Z_inj; auto). lia. rewrite Heq in H3. unfold afold_right in H3. rewrite H10, Heq in H3. apply H3; auto. -Qed. - - -Lemma afold_right_spec : forall A B (f:B -> A) args op e, +Definition afold_right A default (OP : A -> A -> A) (V : array A) := + if length V == 0 then default + else foldi (fun i => OP (V.[length V - 1 - i])) 1 (length V) (V.[length V - 1]). + +Lemma afold_right_spec : forall A args op (e : A), (forall a, op a e = a) -> - afold_right _ _ e op f args = - fold_right (fun v a => op (f v) a) args e. + afold_right _ e op args = + foldi (fun i a => op (args.[length args - 1 - i]) a) 0 (length args) e. Proof. - unfold afold_right, fold_right;intros A B f args op neu H10. + unfold afold_right;intros A args op neu H10. + assert (Bargs := to_Z_bounded (length args)). destruct (reflect_eqb (length args) 0) as [e|n]. - rewrite e, eqb_refl;trivial. - apply not_eq_sym in n;rewrite (eqb_false_complete _ _ n). - case_eq (length args <= 1); intro Heq. - assert (H11: length args = 1). - apply to_Z_inj. rewrite leb_spec in Heq. assert (H11: 0%Z <> [|length args|]) by (intro H; elim n; apply to_Z_inj; auto). change [|1|] with (1%Z) in *. assert (H12 := leb_0 (length args)). rewrite leb_spec in H12. change [|0|] with 0%Z in H12. lia. - rewrite H11, foldi_down_eq; auto. - assert (H11: 1 < length args = true) by (rewrite ltb_negb_geb, Heq; auto). replace (foldi_down (fun (i : int) (b : A) => op (f (args .[ i])) b) (length args - 1) 0 neu) with (foldi_down (fun (i : int) (b : A) => op (f (args .[ i])) b) (length args - 1 - 1) 0 (op (f (args .[ length args - 1])) neu)). - replace (length args - 1 - 1) with (length args - 2) by ring. rewrite H10. auto. - symmetry. apply foldi_down_gt. rewrite ltb_spec. change [|0|] with 0%Z. rewrite to_Z_sub_1_diff; auto. rewrite ltb_spec in H11. change [|1|] with 1%Z in H11. lia. + rewrite e, foldi_ge by reflexivity;trivial. + change 1 with (0 + 1) at 2. + replace (length args - 1) with (length args - 1 - 0) at 1 by ring. + rewrite <- (H10 (args.[length args - 1 - 0])). + rewrite <- (foldi_lt_l _ (fun i => op (args.[length args - 1 - i]))) by (apply not_0_ltb; assumption). + apply foldi_eq_compat; intros; reflexivity. Qed. +Lemma afold_right_eq : + forall A OP (def : A) V1 V2, + length V1 = length V2 -> + (forall i, i < length V1 = true -> V1.[i] = V2.[i]) -> + afold_right _ def OP V1 = afold_right _ def OP V2. +Proof. + intros A OP def V1 V2 Heqlength HeqV. + assert (BV1 := to_Z_bounded (length V1)). + unfold afold_right. + rewrite <- Heqlength. + case (reflect_eqb (length V1) 0); [ reflexivity | intro Hneq ]. + rewrite <- to_Z_eq, to_Z_0 in Hneq. + rewrite <- HeqV by (rewrite ltb_spec, to_Z_sub_1_0; lia). + apply (foldi_ind2 _ _ (fun i a b => a = b)). + rewrite leb_spec, to_Z_1; lia. + reflexivity. + intros i a1 a2; assert (Bi := to_Z_bounded i). + rewrite leb_spec, to_Z_1; intro Hi1. + rewrite ltb_spec by lia; intros Hi2 IH. + f_equal;[ apply HeqV; rewrite ltb_spec, sub_spec, to_Z_sub_1_0, Z.mod_small; lia | exact IH ]. +Qed. + +Lemma afold_right_ind : forall A OP def V (P : int -> A -> Prop), + (length V = 0 -> P 0 def) -> + (0 < length V = true -> P (length V - 1) (V.[length V - 1])) -> + (forall a i, 0 < i = true -> i < length V = true -> P i a -> P (i - 1) (OP (V.[i - 1]) a)) -> + P 0 (afold_right A def OP V). +Proof. + intros A OP def V P HP0 HP1 HPOP. + assert (BV := to_Z_bounded (length V)). + unfold afold_right. + case (reflect_eqb (length V) 0); [ intro Heq; apply HP0; exact Heq | intro Hneq ]. + rewrite <- to_Z_eq, to_Z_0 in Hneq. + replace 0 with (length V - length V) at 1 by ring. + apply (foldi_ind _ (fun i a => P (length V - i) a)). + rewrite leb_spec, to_Z_1; lia. + apply HP1; rewrite ltb_spec, to_Z_0; lia. + intros i a; assert (Bi := to_Z_bounded i). + rewrite leb_spec, to_Z_1, ltb_spec; intros Hi1 Hi2 IH. + replace (length V - (i + 1)) with (length V - i - 1) by ring. + replace (length V - 1 - i) with (length V - i - 1) by ring. + apply HPOP; [ rewrite ltb_spec, to_Z_0, sub_spec, Z.mod_small; lia | rewrite ltb_spec, sub_spec, Z.mod_small; lia | exact IH ]. +Qed. (** Application to our uses of afold_left and afold_right *) (* Case andb *) -Lemma afold_left_andb_false : forall A i a f, +Lemma afold_left_andb_false : forall i a, i < length a = true -> - f (a .[ i]) = false -> - afold_left bool A true andb f a = false. + a .[ i] = false -> + afold_left bool true andb a = false. Proof. - intros A i a f; rewrite afold_left_spec; auto; apply (fold_left_Ind _ _ (fun j t => (i < j) = true -> f (a .[ i]) = false -> t = false)). - intros b j H1 H2 H3 H4; case_eq (i == j). - rewrite Int63Properties.eqb_spec; intro; subst i; rewrite H4, andb_false_r; auto. - rewrite eqb_false_spec; intro Heq; rewrite H2; auto; rewrite ltb_spec; rewrite ltb_spec in H3; rewrite (to_Z_add_1 _ (length a)) in H3; auto; assert (H5: [|i|] <> [|j|]) by (intro H5; apply Heq, to_Z_inj; auto); lia. - intro H; eelim ltb_0; eassumption. + intros i a; assert (Ba := to_Z_bounded (length a)); assert (Bi := to_Z_bounded i). + rewrite afold_left_spec by apply andb_true_l; apply foldi_ind. + apply leb_0. + rewrite ltb_spec, to_Z_0; lia. + intros j b _; assert (Bj := to_Z_bounded j). + rewrite 2!ltb_spec; intros Hj IH. + rewrite ltb_spec, to_Z_add_1_wB by lia; intro Hij. + case (reflect_eqb i j). + intros Heq Hai; rewrite <- Heq, Hai; apply andb_false_r. + rewrite <- to_Z_eq; intros Hneq Hai. + rewrite IH; [ apply andb_false_l | lia | exact Hai ]. Qed. - -Lemma afold_left_andb_false_inv : forall A a f, - afold_left bool A true andb f a = false -> - exists i, (i < length a = true) /\ (f (a .[ i]) = false). +Lemma afold_left_andb_false_inv : forall a, + afold_left bool true andb a = false -> + exists i, (i < length a = true) /\ (a .[ i] = false). Proof. - intros A a f; rewrite afold_left_spec; auto; apply fold_left_ind; try discriminate. - intros b i H1; case b; simpl. - intros _ H2; exists i; auto. - intros H2 _; destruct (H2 (refl_equal false)) as [j [H3 H4]]; exists j; auto. + intro a; assert (Ba := to_Z_bounded (length a)). + rewrite afold_left_spec by apply andb_true_l; apply foldi_ind. + apply leb_0. + discriminate. + intros i b _; assert (Bi := to_Z_bounded i). + rewrite ltb_spec; intros Hj IH. + destruct b. + rewrite andb_true_l; intro H; exists i; rewrite H. + split; [ rewrite ltb_spec, to_Z_add_1_wB; lia | reflexivity ]. + generalize (IH eq_refl); clear IH; intros [ j [ Hji Haj ] ] _. + rewrite ltb_spec in Hji; exists j. + split; [ rewrite ltb_spec, to_Z_add_1_wB; lia | exact Haj ]. Qed. - -Lemma afold_left_andb_true : forall A a f, - (forall i, i < length a = true -> f (a.[i]) = true) -> - afold_left bool A true andb f a = true. +Lemma afold_left_andb_true : forall a, + (forall i, i < length a = true -> a.[i] = true) -> + afold_left bool true andb a = true. Proof. - intros A a f H; rewrite afold_left_spec; auto; apply fold_left_ind; trivial; intros b j H1 H2; rewrite H2; simpl; rewrite H; trivial. + intros a H. + rewrite afold_left_spec by apply andb_true_l; apply foldi_ind. + apply leb_0. + reflexivity. + intros b j _ H1 H2; rewrite H2; simpl; rewrite H; trivial. Qed. - -Lemma afold_left_andb_true_inv : forall A a f, - afold_left bool A true andb f a = true -> - forall i, i < length a = true -> f (a.[i]) = true. +Lemma afold_left_andb_true_inv : forall a, + afold_left bool true andb a = true -> + forall i, i < length a = true -> a.[i] = true. Proof. - intros A a f; rewrite afold_left_spec; auto; apply (fold_left_Ind _ _ (fun j t => t = true -> forall i, (i < j) = true -> f (a .[ i]) = true)). - intros b i H1; case b; simpl; try discriminate; intros H2 H3 j Hj; case_eq (j == i); intro Heq. - rewrite Int63Properties.eqb_spec in Heq; subst j; auto. - apply H2; auto; rewrite eqb_false_spec in Heq; rewrite ltb_spec; rewrite ltb_spec in Hj; assert (H4: [|j|] <> [|i|]) by (intro H; apply Heq, to_Z_inj; auto); rewrite (to_Z_add_1 _ (length a)) in Hj; auto; lia. - intros _ i H; eelim ltb_0; eassumption. + intros a H i; assert (Ba := to_Z_bounded (length a)); assert (Bi := to_Z_bounded i). + revert H; rewrite afold_left_spec by apply andb_true_l; apply foldi_ind. + apply leb_0. + rewrite ltb_spec, to_Z_0; lia. + intros j b _; assert (Bj := to_Z_bounded j). + rewrite 2!ltb_spec; intros Hj IH. + rewrite ltb_spec, to_Z_add_1_wB by lia. + rewrite andb_true_iff. + case (reflect_eqb i j). + intro Heq; rewrite <- Heq; tauto. + rewrite <- to_Z_eq; intros Hneq [ Hb Haj ] Hij. + apply IH; [ exact Hb | lia ]. Qed. - -Lemma afold_left_and p a : - afold_left bool int true andb p a = +Lemma afold_left_and A (p : A -> bool) a : + afold_left bool true andb (amap p a) = List.forallb p (to_list a). Proof. - rewrite afold_left_spec; auto. - rewrite fold_left_to_list. - assert (H:forall l acc, List.fold_left (fun (a0 : bool) (v : int) => a0 && p v) l acc = - acc && List.forallb p l). - { - clear a. induction l; simpl. - - intros; now rewrite andb_true_r. - - intro acc. rewrite IHl. now rewrite andb_assoc. - } - now apply H. + rewrite afold_left_spec, foldi_to_list, to_list_amap by exact andb_true_l. + rewrite <- andb_true_r. + generalize true. + induction (to_list a) as [ | x l ]; clear a; intro b. + reflexivity. + simpl; rewrite IHl. + rewrite (andb_comm b (p x)), (andb_comm (p x) (forallb p l)); apply andb_assoc. Qed. - (* Case orb *) -Lemma afold_left_orb_true : forall A i a f, +Lemma afold_left_orb_true : forall i a, i < length a = true -> - f (a .[ i]) = true -> - afold_left bool A false orb f a = true. + a .[ i] = true -> + afold_left bool false orb a = true. Proof. - intros A i a f; rewrite afold_left_spec; auto; apply (fold_left_Ind _ _ (fun j t => (i < j) = true -> f (a .[ i]) = true -> t = true)). - intros b j H1 H2 H3 H4; case_eq (i == j). - rewrite Int63Properties.eqb_spec; intro; subst i; rewrite H4, orb_true_r; auto. - rewrite eqb_false_spec; intro Heq; rewrite H2; auto; rewrite ltb_spec; rewrite ltb_spec in H3; rewrite (to_Z_add_1 _ (length a)) in H3; auto; assert (H5: [|i|] <> [|j|]) by (intro H5; apply Heq, to_Z_inj; auto); lia. - intro H; eelim ltb_0; eassumption. + intros i a; assert (Ba := to_Z_bounded (length a)); assert (Bi := to_Z_bounded i). + rewrite afold_left_spec by apply orb_false_l; apply foldi_ind. + apply leb_0. + rewrite ltb_spec, to_Z_0; lia. + intros j b _; assert (Bj := to_Z_bounded j). + rewrite 2!ltb_spec; intros Hj IH. + rewrite ltb_spec, to_Z_add_1_wB by lia; intro Hij. + case (reflect_eqb i j). + intros Heq Hai; rewrite <- Heq, Hai; apply orb_true_r. + rewrite <- to_Z_eq; intros Hneq Hai. + rewrite IH; [ apply orb_true_l | lia | exact Hai ]. Qed. - -Lemma afold_left_orb_true_inv : forall A a f, - afold_left bool A false orb f a = true -> - exists i, (i < length a = true) /\ (f (a .[ i]) = true). +Lemma afold_left_orb_true_inv : forall a, + afold_left bool false orb a = true -> + exists i, i < length a = true /\ a .[ i] = true. Proof. - intros A a f; rewrite afold_left_spec; auto; apply fold_left_ind; try discriminate. - intros b i H1; case b; simpl. - intros H2 _; destruct (H2 (refl_equal true)) as [j [H3 H4]]; exists j; auto. - intros _ H2; exists i; auto. + intro a; assert (Ba := to_Z_bounded (length a)). + rewrite afold_left_spec by apply andb_true_l; apply foldi_ind. + apply leb_0. + discriminate. + intros i b _; assert (Bi := to_Z_bounded i). + rewrite ltb_spec; intros Hj IH. + destruct b. + generalize (IH eq_refl); clear IH; intros [ j [ Hji Haj ] ] _. + rewrite ltb_spec in Hji; exists j. + split; [ rewrite ltb_spec, to_Z_add_1_wB; lia | exact Haj ]. + rewrite orb_false_l; intro H; exists i; rewrite H. + split; [ rewrite ltb_spec, to_Z_add_1_wB; lia | reflexivity ]. Qed. - -Lemma afold_left_orb_false : forall A a f, - (forall i, i < length a = true -> f (a.[i]) = false) -> - afold_left bool A false orb f a = false. +Lemma afold_left_orb_false : forall a, + (forall i, i < length a = true -> a.[i] = false) -> + afold_left bool false orb a = false. Proof. - intros A a f H; rewrite afold_left_spec; auto; apply fold_left_ind; trivial; intros b j H1 H2; rewrite H2; simpl; rewrite H; trivial. + intros a H. + rewrite afold_left_spec by apply andb_true_l; apply foldi_ind. + apply leb_0. + reflexivity. + intros b j _ H1 H2; rewrite H2; simpl; rewrite H; trivial. Qed. - -Lemma afold_left_orb_false_inv : forall A a f, - afold_left bool A false orb f a = false -> - forall i, i < length a = true -> f (a.[i]) = false. +Lemma afold_left_orb_false_inv : forall a, + afold_left bool false orb a = false -> + forall i, i < length a = true -> a.[i] = false. Proof. - intros A a f; rewrite afold_left_spec; auto; apply (fold_left_Ind _ _ (fun j t => t = false -> forall i, (i < j) = true -> f (a .[ i]) = false)). - intros b i H1; case b; simpl; try discriminate; intros H2 H3 j Hj; case_eq (j == i); intro Heq. - rewrite Int63Properties.eqb_spec in Heq; subst j; auto. - apply H2; auto; rewrite eqb_false_spec in Heq; rewrite ltb_spec; rewrite ltb_spec in Hj; assert (H4: [|j|] <> [|i|]) by (intro H; apply Heq, to_Z_inj; auto); rewrite (to_Z_add_1 _ (length a)) in Hj; auto; lia. - intros _ i H; eelim ltb_0; eassumption. + intros a H i; assert (Ba := to_Z_bounded (length a)); assert (Bi := to_Z_bounded i). + revert H; rewrite afold_left_spec by apply andb_true_l; apply foldi_ind. + apply leb_0. + rewrite ltb_spec, to_Z_0; lia. + intros j b _; assert (Bj := to_Z_bounded j). + rewrite 2!ltb_spec; intros Hj IH. + rewrite ltb_spec, to_Z_add_1_wB by lia. + rewrite orb_false_iff. + case (reflect_eqb i j). + intro Heq; rewrite <- Heq; tauto. + rewrite <- to_Z_eq; intros Hneq [ Hb Haj ] Hij. + apply IH; [ exact Hb | lia ]. Qed. - -Lemma afold_left_or p a : - afold_left bool int false orb p a = +Lemma afold_left_or A (p : A -> bool) a : + afold_left bool false orb (amap p a) = List.existsb p (to_list a). Proof. - rewrite afold_left_spec; auto. - rewrite fold_left_to_list. - assert (H:forall l acc, List.fold_left (fun (a0 : bool) (v : int) => a0 || p v) l acc = - acc || List.existsb p l). - { - clear a. induction l; simpl. - - intros; now rewrite orb_false_r. - - intro acc. rewrite IHl. now rewrite orb_assoc. - } - now apply H. + rewrite afold_left_spec, foldi_to_list, to_list_amap by exact andb_true_l. + rewrite <- orb_false_r. + generalize false. + induction (to_list a) as [ | x l ]; clear a; intro b. + reflexivity. + simpl; rewrite IHl. + rewrite (orb_comm b (p x)), (orb_comm (p x) (existsb p l)); apply orb_assoc. Qed. - (* Case implb *) -Lemma afold_right_implb_false : forall A a f, +Lemma afold_right_implb_false : forall a, 0 < length a = true /\ - (forall i, i < length a - 1 = true -> f (a .[ i]) = true) /\ - f (a.[length a - 1]) = false -> - afold_right bool A true implb f a = false. + (forall i, i < length a - 1 = true -> a .[ i] = true) /\ + a.[length a - 1] = false -> + afold_right bool true implb a = false. Proof. - intros A a f; intros [H1 [H2 H3]]; apply afold_right_ind_nonempty; auto; intros b i H4 H5; rewrite H5, H2; auto. + intros a; intros [H1 [H2 H3]]. + pattern 0; apply afold_right_ind. + intro H; rewrite H in H1; discriminate. + intros _; exact H3. + intros b i H4 H5 H6; rewrite H6; clear H6. + rewrite H2; [ reflexivity | ]. + assert (Ba := to_Z_bounded (length a)); assert (Bi := to_Z_bounded i). + revert H1 H4 H5; rewrite 4!ltb_spec, to_Z_0; intros H1 H4 H5. + rewrite 2!to_Z_sub_1_0; lia. Qed. - -Lemma afold_right_implb_false_inv : forall A a f, - afold_right bool A true implb f a = false -> +Lemma afold_right_implb_false_inv : forall a, + afold_right bool true implb a = false -> 0 < length a = true /\ - (forall i, i < length a - 1 = true -> f (a .[ i]) = true) /\ - f (a.[length a - 1]) = false. -Proof. - intros A a f; case_eq (length a == 0); intro Heq1. - unfold afold_right; rewrite Heq1; discriminate. - intro H; split. - rewrite eqb_false_spec in Heq1; rewrite <- not_0_ltb; auto. - generalize H; clear H; case_eq (length a <= 1); intro Heq2. - unfold afold_right; rewrite Heq1, Heq2; intro H; replace (length a - 1) with 0. - split; auto; intros i Hi; elim (ltb_0 i); auto. - rewrite eqb_false_spec in Heq1; apply to_Z_inj; rewrite to_Z_sub_1_diff; auto; rewrite leb_spec in Heq2; change [|1|] with 1%Z in Heq2; assert ([|length a|] <> 0%Z) by (intro H1; apply Heq1, to_Z_inj; auto); generalize (leb_0 (length a)); rewrite leb_spec; change [|0|] with 0%Z; lia. - pose (P j k := k = false -> (forall i : int, (j <= i) = true -> (i < length a - 1) = true -> f (a .[ i]) = true) /\ f (a .[ length a - 1]) = false); assert (H: P 0 (afold_right bool A true implb f a)). - generalize (afold_right_Ind _ _ P true implb f a); rewrite Heq2; intro IH; apply IH; clear IH; unfold P. - intros b i H1 H2 H3; case_eq b; intro Heq3. - rewrite Heq3 in H3; generalize H3; case (f (a .[ i])); discriminate. - destruct (H2 Heq3) as [H4 H5]; split; auto; intros j H6 H7; case_eq (i == j); intro Heq4. - rewrite eqb_spec in Heq4; subst j b; generalize H3; case (f (a .[ i])); auto; discriminate. - apply H4; auto; rewrite leb_spec in *; rewrite (to_Z_add_1 _ _ H1); rewrite eqb_false_spec in Heq4; assert ([|i|] <> [|j|]) by (intro H; apply Heq4, to_Z_inj; auto); lia. - intro H; split; auto; intros i H1 H2; elimtype False; rewrite leb_spec in H1; rewrite ltb_spec in H2; lia. - unfold P in H; intro H1; destruct (H H1) as [H2 H3]; split; auto; intro i; apply H2, leb_0. -Qed. - - -Lemma afold_right_implb_true_aux : forall A a f, - (exists i, i < length a - 1 = true /\ f (a.[i]) = false) -> - afold_right bool A true implb f a = true. -Proof. - intros A a f; case_eq (length a == 0); intro Heq1. - intros _; unfold afold_right; rewrite Heq1; auto. - case_eq (length a <= 1); intro Heq2. - intros [i [Hi _]]; elim (ltb_0 i); replace 0 with (length a - 1); auto; rewrite eqb_false_spec in Heq1; apply to_Z_inj; rewrite to_Z_sub_1_diff; auto; assert (H1: [|length a|] <> 0%Z) by (intro H; apply Heq1, to_Z_inj; auto); rewrite leb_spec in Heq2; generalize (leb_0 (length a)); rewrite leb_spec; change [|0|] with 0%Z; change [|1|] with 1%Z in Heq2; lia. - pose (P j k := (exists i : int, (j <= i) = true /\ (i < length a - 1) = true /\ f (a .[ i]) = false) -> k = true); assert (H: P 0 (afold_right bool A true implb f a)). - generalize (afold_right_Ind _ _ P true implb f a); rewrite Heq2; intro IH; apply IH; clear IH; unfold P. - intros b i H1 H2 [j [H3 [H4 H5]]]; case_eq (i == j); intro Heq3. - rewrite eqb_spec in Heq3; subst i; rewrite H5; case b; auto. - rewrite H2. - case (f (a .[ i])); auto. - exists j; repeat split; auto; assert (H: i < j = true). - rewrite ltb_spec; rewrite leb_spec in H3; rewrite eqb_false_spec in Heq3; assert (H: [|i|] <> [|j|]) by (intro H; apply Heq3, to_Z_inj; auto); lia. - rewrite leb_spec, (to_Z_add_1 _ _ H); rewrite ltb_spec in H; lia. - intros [i [H1 [H2 _]]]; elimtype False; rewrite leb_spec in H1; rewrite ltb_spec in H2; lia. - unfold P in H; intros [i Hi]; apply H; exists i; split; auto; apply leb_0. -Qed. - - -Lemma afold_right_implb_true : forall A a f, - length a = 0 \/ (exists i, i < length a - 1 = true /\ f (a.[i]) = false) \/ - (forall i, i < length a = true -> f (a.[i]) = true) -> - afold_right bool A true implb f a = true. -Proof. - intros A a f; case_eq (length a == 0). - intros H _; unfold afold_right; rewrite H; auto. - intros Heq [H1|[H1|H1]]. - rewrite H1 in Heq; discriminate. + (forall i, i < length a - 1 = true -> a .[ i] = true) /\ + a.[length a - 1] = false. +Proof. + intros a H; assert (Ba := to_Z_bounded (length a)); split; [ | split ]. + revert H; unfold afold_right. + case (reflect_eqb (length a) 0). + intro Heq; rewrite Heq; discriminate. + rewrite <- to_Z_eq, to_Z_0; intros Hlength _. + rewrite ltb_spec, to_Z_0; lia. + intro i; generalize (leb_0 i); revert H i; apply afold_right_ind. + discriminate. + intros _ _ i; rewrite leb_spec, ltb_spec; lia. + intros b j; assert (Bj := to_Z_bounded j). + rewrite 2!ltb_spec, to_Z_0; intros Hj1 Hj2 IH. + unfold implb; case_eq (a.[j - 1]); [ | discriminate ]; intros Ha H; subst b; intro i. + case (reflect_eqb i (j - 1)). + intro Heq; subst i; intros; exact Ha. + rewrite <- to_Z_eq, to_Z_sub_1_0 by lia; intro Hneq. + rewrite leb_spec, to_Z_sub_1_0 by lia; intro Hji. + apply IH; [ reflexivity | rewrite leb_spec; lia ]. + revert H; unfold afold_right. + case (reflect_eqb (length a) 0). + discriminate. + rewrite <- to_Z_eq, to_Z_0; intro Hlength. + apply (foldi_ind _ (fun i b => b = false -> a.[length a - 1] = false)). + rewrite leb_spec, to_Z_1; lia. + tauto. + intros i b; assert (Bi := to_Z_bounded i). + rewrite leb_spec, to_Z_1; intro Hi1. + rewrite ltb_spec; intros Hi2 IH. + unfold implb at 1; case (a.[length a - 1 - i]); [ exact IH | discriminate ]. +Qed. + +Lemma afold_right_implb_true_aux : forall a, + (exists i, i < length a - 1 = true /\ a.[i] = false) -> + afold_right bool true implb a = true. +Proof. + intros a [ i [ Hi Hai ] ]. + assert (Bi := to_Z_bounded i). + generalize (leb_0 i); apply afold_right_ind. + reflexivity. + intros _; revert Hi; rewrite ltb_spec, leb_spec; lia. + intros b j. + assert (Bj := to_Z_bounded j). + rewrite ltb_spec, to_Z_0; intro Hj1. + rewrite ltb_spec; intro Hj2. + rewrite leb_spec; intro IH. + rewrite leb_spec, to_Z_sub_1_0 by lia; intro Hji. + case (reflect_eqb i (j - 1)). + intro Heq; rewrite Heq in Hai; rewrite Hai; reflexivity. + rewrite <- to_Z_eq, to_Z_sub_1_0 by lia; intro Hneq. + rewrite IH by lia; case (a.[j - 1]); reflexivity. +Qed. + +Lemma afold_right_implb_true : forall a, + length a = 0 \/ (exists i, i < length a - 1 = true /\ a.[i] = false) \/ + (forall i, i < length a = true -> a.[i] = true) -> + afold_right bool true implb a = true. +Proof. + intro a; assert (Ba := to_Z_bounded (length a)); case (reflect_eqb (length a) 0). + intros H _; unfold afold_right; rewrite H; reflexivity. + intro Hneq. + intros [H1|[H1|H1]]. + elim (Hneq H1). apply afold_right_implb_true_aux; auto. - apply afold_right_ind_nonempty. - intros b i H2 H3; subst b; case (f (a .[ i])); auto. - apply not_0_ltb; intro H; rewrite H in Heq; discriminate. - apply H1; rewrite ltb_spec, to_Z_sub_1_diff; [lia| ]; intro H; rewrite H in Heq; discriminate. -Qed. - - -Lemma afold_right_implb_true_inv : forall A a f, - afold_right bool A true implb f a = true -> - length a = 0 \/ (exists i, i < length a - 1 = true /\ f (a.[i]) = false) \/ - (forall i, i < length a = true -> f (a.[i]) = true). -Proof. - intros A a f; case_eq (length a == 0); intro Heq1. - intros _; left; rewrite eqb_spec in Heq1; auto. - case_eq (length a <= 1); intro Heq2. - unfold afold_right; rewrite Heq1, Heq2; intro H; right; right; intros i Hi; replace i with 0; auto; apply to_Z_inj; rewrite ltb_spec in Hi; rewrite eqb_false_spec in Heq1; assert (H1: [|length a|] <> 0%Z) by (intro H1; apply Heq1, to_Z_inj; auto); rewrite leb_spec in Heq2; change [|1|] with 1%Z in Heq2; generalize (leb_0 (length a)) (leb_0 i); rewrite !leb_spec; change [|0|] with 0%Z; lia. - pose (P j k := k = true -> (exists i : int, (j <= i) = true /\ (i < length a - 1) = true /\ f (a .[ i]) = false) \/ (forall i : int, (j <= i) = true -> (i < length a) = true -> f (a .[ i]) = true)); assert (H: P 0 (afold_right bool A true implb f a)). - generalize (afold_right_Ind _ _ P true implb f a); rewrite Heq2; intro IH; apply IH; clear IH; unfold P. - intros b i H1 H2 H3; case_eq b; intro Heq3. - destruct (H2 Heq3) as [[j [H4 [H5 H6]]]|H4]. - left; exists j; repeat split; auto; rewrite leb_spec in *; rewrite (to_Z_add_1 _ _ H1) in H4; lia. - case_eq (f (a.[i])); intro Heq4. - right; intros j H5 H6; case_eq (i == j); intro Heq5. - rewrite eqb_spec in Heq5; subst j; auto. - apply H4; auto; rewrite leb_spec in *; rewrite (to_Z_add_1 _ _ H1); rewrite eqb_false_spec in Heq5; assert ([|i|] <> [|j|]) by (intro H; apply Heq5, to_Z_inj; auto); lia. - left; exists i; repeat split; auto; apply leb_refl. - rewrite Heq3 in H3; case_eq (f (a .[ i])); intro Heq4; rewrite Heq4 in H3; try discriminate; left; exists i; repeat split; auto; apply leb_refl. - intros H1; right; intros i H2 H3; replace i with (length a - 1); auto; apply to_Z_inj; rewrite leb_spec in H2; rewrite (to_Z_sub_1 _ _ H3) in *; rewrite ltb_spec in H3; lia. - unfold P in H; intro H1; right; destruct (H H1) as [[i [_ H2]]|H2]. - left; exists i; auto. - right; intro i; apply H2, leb_0. + assert (Heq : length a == 0 = false) by (rewrite <- not_true_iff_false, eqb_spec; exact Hneq). + unfold afold_right; rewrite Heq. + revert Hneq; rewrite <- to_Z_eq, to_Z_0; intro Hneq. + apply (foldi_ind _ (fun i a => a = true)). + rewrite leb_spec, to_Z_1; lia. + apply H1; rewrite ltb_spec, to_Z_sub_1_0; lia. + intros i b; assert (Bi := to_Z_bounded i). + rewrite leb_spec, to_Z_1; intro Hi1. + rewrite ltb_spec; intros Hi2 IH. + rewrite IH; case (a.[length a - 1 - i]); reflexivity. Qed. +Lemma afold_right_implb_true_inv : forall a, + afold_right bool true implb a = true -> + length a = 0 \/ (exists i, i < length a - 1 = true /\ a.[i] = false) \/ + (forall i, i < length a = true -> a.[i] = true). +Proof. + intros a H; cut (length a = 0 + \/ (exists i, 0 <= i = true /\ i < length a - 1 = true /\ a.[i] = false) + \/ (forall i, 0 <= i = true -> i < length a = true -> a.[i] = true)). + clear H; intro H; destruct H as [ H | H ]. + left; tauto. + destruct H as [ H | H ]. + destruct H as [ i [ Hi1 Hi2 ] ]. + right; left; exists i; tauto. + right; right; intro i; apply H; apply leb_0. + assert (Ba := to_Z_bounded (length a)). + revert H; apply afold_right_ind. + left; tauto. + rewrite ltb_spec, to_Z_0; intro Hlength. + intro Ha; right; right. + intro i; assert (Bi := to_Z_bounded i). + rewrite leb_spec, to_Z_sub_1_0 by lia; intro Hi1. + rewrite ltb_spec; intro Hi2. + replace i with (length a - 1) by (rewrite <- to_Z_eq, to_Z_sub_1_0; lia); exact Ha. + intros b i; assert (Bi := to_Z_bounded i). + rewrite ltb_spec, to_Z_0; intro Hi1. + rewrite ltb_spec; intros Hi2 IH. + case_eq (a.[i - 1]); unfold implb. + intros Ha Hb; destruct (IH Hb) as [ Heq | H ]; clear IH. + rewrite Heq in Hi2; lia. + destruct H as [ [ j [ Hij Hj ] ] | H ]. + right; left; exists j. + split; [ | exact Hj ]. + revert Hij; rewrite 2!leb_spec, to_Z_sub_1_0; lia. + right; right; intro j. + rewrite leb_spec, sub_spec, to_Z_1, Z.mod_small by lia; intro Hij. + rewrite ltb_spec; intro Hj. + case (reflect_eqb j (i - 1)). + intro Heq; rewrite Heq; exact Ha. + rewrite <- to_Z_eq, to_Z_sub_1_0 by lia; intro Hneq. + apply H; [ rewrite leb_spec; lia | rewrite ltb_spec; lia ]. + intros Ha _; right; left; exists (i - 1). + split; [ rewrite leb_spec; lia | ]. + split; [ rewrite ltb_spec, 2!to_Z_sub_1_0; lia | exact Ha ]. +Qed. (* Other cases *) -Lemma afold_left_length_2 : forall A B default OP F t, +Lemma afold_left_length_2 : forall A default OP t, (length t == 2) = true -> - afold_left A B default OP F t = OP (F (t.[0])) (F (t.[1])). + afold_left A default OP t = OP (t.[0]) (t.[1]). Proof. - intros A B default OP F t H; unfold afold_left; rewrite eqb_spec in H; rewrite H; change (2 == 0) with false; simpl; change (2-1) with 1; rewrite foldi_eq; trivial. + intros A default OP t H; unfold afold_left; rewrite eqb_spec in H; rewrite H; change (2 == 0) with false; reflexivity. Qed. -Lemma afold_right_length_2 : forall A B default OP F t, +Lemma afold_right_length_2 : forall A default OP t, (length t == 2) = true -> - afold_right A B default OP F t = OP (F (t.[0])) (F (t.[1])). + afold_right A default OP t = OP (t.[0]) (t.[1]). Proof. - intros A B default OP F t H; unfold afold_right; rewrite eqb_spec in H; rewrite H; change (2 == 0) with false; simpl; change (2<=1) with false; simpl; change (2-2) with 0; rewrite foldi_down_eq; trivial. + intros A default OP t H; unfold afold_right; rewrite eqb_spec in H; rewrite H; change (2 == 0) with false; reflexivity. Qed. Ltac tac_left := - intros t f H H1 H2; rewrite afold_left_length_2; + intros t H H1 H2; rewrite afold_left_length_2; [rewrite H1, H2| ]; trivial. Ltac tac_right := - try (intros t f H H1 H2; rewrite afold_right_length_2; + try (intros t H H1 H2; rewrite afold_right_length_2; [rewrite H1, H2| ]; trivial); - try (intros t f H H1; rewrite afold_right_length_2; + try (intros t H H1; rewrite afold_right_length_2; [rewrite H1| ]; trivial); try (rewrite implb_true_r; trivial). -Lemma afold_left_xorb_false1 : forall t f, +Lemma afold_left_xorb_false1 : forall t, (PArray.length t == 2) = true -> - f (t .[ 0]) = false -> f (t .[ 1]) = false -> - afold_left bool int false xorb f t = false. + t .[ 0] = false -> t .[ 1] = false -> + afold_left bool false xorb t = false. Proof. tac_left. Qed. -Lemma afold_left_xorb_false2 : forall t f, +Lemma afold_left_xorb_false2 : forall t, (PArray.length t == 2) = true -> - f (t .[ 0]) = true -> f (t .[ 1]) = true -> - afold_left bool int false xorb f t = false. + t .[ 0] = true -> t .[ 1] = true -> + afold_left bool false xorb t = false. Proof. tac_left. Qed. -Lemma afold_left_xorb_true1 : forall t f, +Lemma afold_left_xorb_true1 : forall t, (PArray.length t == 2) = true -> - f (t .[ 0]) = false -> f (t .[ 1]) = true -> - afold_left bool int false xorb f t = true. + t .[ 0] = false -> t .[ 1] = true -> + afold_left bool false xorb t = true. Proof. tac_left. Qed. -Lemma afold_left_xorb_true2 : forall t f, +Lemma afold_left_xorb_true2 : forall t, (PArray.length t == 2) = true -> - f (t .[ 0]) = true -> f (t .[ 1]) = false -> - afold_left bool int false xorb f t = true. + t .[ 0] = true -> t .[ 1] = false -> + afold_left bool false xorb t = true. Proof. tac_left. Qed. @@ -777,31 +1351,31 @@ Proof. tac_left. Qed. (* Proof. tac_right. Qed. *) -Lemma afold_left_eqb_false1 : forall t f, +Lemma afold_left_eqb_false1 : forall t, (PArray.length t == 2) = true -> - f (t .[ 0]) = false -> f (t .[ 1]) = true -> - afold_left bool int true eqb f t = false. + t .[ 0] = false -> t .[ 1] = true -> + afold_left bool true eqb t = false. Proof. tac_left. Qed. -Lemma afold_left_eqb_false2 : forall t f, +Lemma afold_left_eqb_false2 : forall t, (PArray.length t == 2) = true -> - f (t .[ 0]) = true -> f (t .[ 1]) = false -> - afold_left bool int true eqb f t = false. + t .[ 0] = true -> t .[ 1] = false -> + afold_left bool true eqb t = false. Proof. tac_left. Qed. -Lemma afold_left_eqb_true1 : forall t f, +Lemma afold_left_eqb_true1 : forall t, (PArray.length t == 2) = true -> - f (t .[ 0]) = true -> f (t .[ 1]) = true -> - afold_left bool int true eqb f t = true. + t .[ 0] = true -> t .[ 1] = true -> + afold_left bool true eqb t = true. Proof. tac_left. Qed. -Lemma afold_left_eqb_true2 : forall t f, +Lemma afold_left_eqb_true2 : forall t, (PArray.length t == 2) = true -> - f (t .[ 0]) = false -> f (t .[ 1]) = false -> - afold_left bool int true eqb f t = true. + t .[ 0] = false -> t .[ 1] = false -> + afold_left bool true eqb t = true. Proof. tac_left. Qed. @@ -815,26 +1389,26 @@ Section List2. | In2_hd : forall l, In j l -> In2 i j (i::l) | In2_tl : forall k l, In2 i j l -> In2 i j (k::l). - Local Hint Constructors In2. + Local Hint Constructors In2 : smtcoq_in2. Lemma In2_app : forall i j l m, In2 i j (l ++ m) <-> In2 i j l \/ (In i l /\ In j m) \/ In2 i j m. Proof. - intros i j; induction l as [ |t l IHl]; simpl; intro m; split; auto. - intros [H|[[H _]|H]]; auto. + intros i j; induction l as [ |t l IHl]; simpl; intro m; split; auto with smtcoq_in2. + intros [H|[[H _]|H]]; auto with smtcoq_in2. inversion H. elim H. intro H; inversion H; clear H. - subst i l0; rewrite in_app_iff in H1; destruct H1 as [H1|H1]; auto. - subst k l0; rewrite IHl in H1; destruct H1 as [H1|[[H1 H2]|H1]]; auto. + subst i l0; rewrite in_app_iff in H1; destruct H1 as [H1|H1]; auto with smtcoq_in2. + subst k l0; rewrite IHl in H1; destruct H1 as [H1|[[H1 H2]|H1]]; auto with smtcoq_in2. intros [H|[[[H|H] H1]|H]]. inversion H; clear H. - subst i l0; constructor 1; rewrite in_app_iff; auto. - subst k l0; constructor 2; rewrite IHl; left; auto. - subst t; constructor 1; rewrite in_app_iff; auto. - constructor 2; rewrite IHl; right; left; auto. - constructor 2; rewrite IHl; right; right; auto. + subst i l0; constructor 1; rewrite in_app_iff; auto with smtcoq_in2. + subst k l0; constructor 2; rewrite IHl; left; auto with smtcoq_in2. + subst t; constructor 1; rewrite in_app_iff; auto with smtcoq_in2. + constructor 2; rewrite IHl; right; left; auto with smtcoq_in2. + constructor 2; rewrite IHl; right; right; auto with smtcoq_in2. Qed. @@ -848,17 +1422,17 @@ Section List2. Lemma In2_rev_aux : forall i j l acc, In2 i j (rev_aux acc l) <-> In2 i j acc \/ (In i l /\ In j acc) \/ In2 j i l. Proof. - intros i j; induction l as [ |t q IHq]; simpl; intro acc; split; auto. - intros [H|[[H _]|H]]; auto. + intros i j; induction l as [ |t q IHq]; simpl; intro acc; split; auto with smtcoq_in2. + intros [H|[[H _]|H]]; auto with smtcoq_in2. elim H. inversion H. - rewrite IHq; clear IHq; intros [H|[[H1 H2]|H]]; auto. - inversion H; auto. - inversion H2; auto; clear H2; subst t; right; right; auto. - intros [H|[[[H1|H1] H2]|H]]; rewrite IHq; clear IHq; auto. - subst t; auto. - right; left; split; auto; constructor 2; auto. - inversion H; clear H; auto; subst j l; right; left; split; auto; constructor 1; auto. + rewrite IHq; clear IHq; intros [H|[[H1 H2]|H]]; auto with smtcoq_in2. + inversion H; auto with smtcoq_in2. + inversion H2; auto with smtcoq_in2; clear H2; subst t; right; right; auto with smtcoq_in2. + intros [H|[[[H1|H1] H2]|H]]; rewrite IHq; clear IHq; auto with smtcoq_in2. + subst t; auto with smtcoq_in2. + right; left; split; auto with smtcoq_in2; constructor 2; auto with smtcoq_in2. + inversion H; clear H; auto with smtcoq_in2; subst j l; right; left; split; auto with smtcoq_in2; constructor 1; auto with smtcoq_in2. Qed. @@ -867,7 +1441,7 @@ Section List2. Lemma In2_rev : forall i j l, In2 i j (rev l) <-> In2 j i l. Proof. - intros i j l; unfold rev; rewrite In2_rev_aux; split; auto; intros [H|[[_ H]|H]]; auto; inversion H. + intros i j l; unfold rev; rewrite In2_rev_aux; split; auto with smtcoq_in2; intros [H|[[_ H]|H]]; auto with smtcoq_in2; inversion H. Qed. @@ -877,15 +1451,15 @@ Section List2. intros [H1 H2]; generalize H1 H2; clear H1 H2; induction l as [ |t q IHq]. intro H1; inversion H1. intros H1 H2; inversion H1; clear H1. - subst t; inversion H2; auto; elim H; auto. + subst t; inversion H2; auto with smtcoq_in2; elim H; auto with smtcoq_in2. inversion H2; clear H2. - subst t; auto. - destruct (IHq H0 H1) as [H2|H2]; auto. + subst t; auto with smtcoq_in2. + destruct (IHq H0 H1) as [H2|H2]; auto with smtcoq_in2. intros [H1|H1]; induction H1 as [H1|t q H1 [IH1 IH2]]. - split; [constructor 1|constructor 2]; auto. - split; constructor 2; auto. - split; [constructor 2|constructor 1]; auto. - split; constructor 2; auto. + split; [constructor 1|constructor 2]; auto with smtcoq_in2. + split; constructor 2; auto with smtcoq_in2. + split; [constructor 2|constructor 1]; auto with smtcoq_in2. + split; constructor 2; auto with smtcoq_in2. Qed. End List2. @@ -944,32 +1518,32 @@ Section Distinct. distinct_aux acc' q end. - Local Hint Constructors In2. + Local Hint Constructors In2 : smtcoq_in2. Lemma distinct_aux_spec : forall l acc, distinct_aux acc l = true <-> acc = true /\ (forall i j, In2 i j l -> eq i j = false). Proof. induction l as [ |t q IHq]; simpl. intro acc; split. - intro H; split; auto; intros i j H1; inversion H1. - intros [H _]; auto. + intro H; split; auto with smtcoq_in2; intros i j H1; inversion H1. + intros [H _]; auto with smtcoq_in2. intro acc; rewrite (IHq (distinct_aux2 acc t q)), distinct_aux2_spec; split. - intros [[H1 H2] H3]; split; auto; intros i j H; inversion H; auto. - intros [H1 H2]; repeat split; auto. + intros [[H1 H2] H3]; split; auto with smtcoq_in2; intros i j H; inversion H; auto with smtcoq_in2. + intros [H1 H2]; repeat split; auto with smtcoq_in2. Qed. Lemma distinct_aux_spec_neg : forall l acc, distinct_aux acc l = false <-> acc = false \/ (exists i j, In2 i j l /\ eq i j = true). Proof. induction l as [ |t q IHq]; simpl. - intro acc; split; auto; intros [H|[i [j [H _]]]]; auto; inversion H. + intro acc; split; auto with smtcoq_in2; intros [H|[i [j [H _]]]]; auto with smtcoq_in2; inversion H. intro acc; rewrite (IHq (distinct_aux2 acc t q)), distinct_aux2_spec_neg; split. - intros [[H|[i [H1 H2]]]|[i [j [H1 H2]]]]; auto. - right; exists t; exists i; auto. - right; exists i; exists j; auto. - intros [H|[i [j [H1 H2]]]]; auto; inversion H1; clear H1. - subst i l; left; right; exists j; auto. - subst k l; right; exists i; exists j; auto. + intros [[H|[i [H1 H2]]]|[i [j [H1 H2]]]]; auto with smtcoq_in2. + right; exists t; exists i; auto with smtcoq_in2. + right; exists i; exists j; auto with smtcoq_in2. + intros [H|[i [j [H1 H2]]]]; auto with smtcoq_in2; inversion H1; clear H1. + subst i l; left; right; exists j; auto with smtcoq_in2. + subst k l; right; exists i; exists j; auto with smtcoq_in2. Qed. Definition distinct := distinct_aux true. @@ -977,61 +1551,80 @@ Section Distinct. Lemma distinct_spec : forall l, distinct l = true <-> (forall i j, In2 i j l -> eq i j = false). Proof. - unfold distinct; intro l; rewrite distinct_aux_spec; split; auto; intros [_ H]; auto. + unfold distinct; intro l; rewrite distinct_aux_spec; split; auto with smtcoq_in2; intros [_ H]; auto with smtcoq_in2. Qed. Lemma distinct_false_spec : forall l, distinct l = false <-> (exists i j, In2 i j l /\ eq i j = true). Proof. - unfold distinct; intro l; rewrite distinct_aux_spec_neg; split; auto; intros [H|H]; auto; discriminate. + unfold distinct; intro l; rewrite distinct_aux_spec_neg; split; auto with smtcoq_in2; intros [H|H]; auto with smtcoq_in2; discriminate. Qed. End Distinct. Arguments distinct [A] eq l. +(** Specification of aexistsbi and aforallbi *) -(** Specification of existsb *) +Definition aexistsbi {A:Type} (f:int->A->bool) (t:array A) := + afold_left _ false orb (amapi f t). -Lemma existsb_false_spec : forall f from to, - existsb f from to = false <-> - forall i, ((from <= i) = true /\ (i <= to) = true) -> f i = false. +Lemma aexistsbi_false_spec : forall A (f : int -> A -> bool) t, + aexistsbi f t = false <-> + forall i, i < length t = true -> f i (t.[i]) = false. Proof. - unfold existsb;intros; setoid_rewrite leb_spec; apply foldi_cont_ZInd. - intros z Hz; split; auto; intros _ i [H1 H2]; assert (H3 := Z.le_trans _ _ _ H1 H2); elimtype False; lia. - intros i cont H1 H2 H3; case_eq (f i); intro Heq. - split; try discriminate; intro H; rewrite <- Heq; apply H; split; try lia; rewrite leb_spec in H2; auto. - rewrite H3; split; intros H j [Hj1 Hj2]. - case_eq (i == j); intro Heq2. - rewrite eqb_spec in Heq2; subst j; auto. - apply H; split; auto; rewrite eqb_false_spec in Heq2; assert ([|i|] <> [|j|]) by (intro; apply Heq2, to_Z_inj; auto); lia. - apply H; lia. + intros A f t; unfold aexistsbi. + split. + intro H; generalize (afold_left_orb_false_inv _ H); clear H. + rewrite length_amapi; intros H i Hi. + rewrite <- get_amapi by exact Hi. + apply H; exact Hi. + intro H; apply afold_left_orb_false. + intro i; rewrite length_amapi; intro Hi; rewrite get_amapi by exact Hi; apply H; exact Hi. Qed. - -Lemma array_existsbi_false_spec : forall A (f : int -> A -> bool) t, - existsbi f t = false <-> - forall i, i < length t = true -> f i (t.[i]) = false. +Lemma aexistsbi_spec : forall A (f : int -> A -> bool) t, + aexistsbi f t = true <-> exists i, i < length t = true /\ f i (t.[i]) = true. Proof. - unfold existsbi;intros A f t; destruct (reflect_eqb 0 (length t)). - split; auto. intros _ i Hi. elim (ltb_0 i). rewrite e. auto. - rewrite existsb_false_spec. split. - intros H i Hi. apply H. split; [apply leb_0| ]. rewrite leb_spec. rewrite (to_Z_sub_1 _ _ Hi). rewrite ltb_spec in Hi. lia. - intros H i [_ Hi]. apply H. rewrite ltb_spec. rewrite leb_spec in Hi. rewrite to_Z_sub_1_diff in Hi; auto; lia. + intros A f t; unfold aexistsbi. + split. + intro H; generalize (afold_left_orb_true_inv _ H); clear H. + intros [ i [ Hi Hf ] ]; exists i. + rewrite length_amapi in Hi; rewrite get_amapi in Hf by exact Hi. + split; [ exact Hi | exact Hf ]. + intros [ i [ Hi Hf ] ]. + apply (afold_left_orb_true i); [ rewrite length_amapi; exact Hi | rewrite get_amapi by exact Hi; exact Hf ]. Qed. +Definition aforallbi {A:Type} (f:int->A->bool) (t:array A) := + afold_left _ true andb (amapi f t). -Lemma array_existsb_false_spec : forall A (f : A -> bool) t, - PArray.existsb f t = false <-> - forall i, i < length t = true -> f (t.[i]) = false. +Lemma aforallbi_false_spec : forall A (f : int -> A -> bool) t, + aforallbi f t = false <-> exists i, i < length t = true /\ f i (t.[i]) = false. Proof. - intros A f t; unfold PArray.existsb; case_eq (0 == length t). - rewrite eqb_spec; intro H; split; auto; intros _ i Hi; elim (ltb_0 i); rewrite H; auto. - intro H; rewrite existsb_false_spec; split. - intros H1 i Hi; apply H1; split; [apply leb_0| ]; rewrite leb_spec, (to_Z_sub_1 _ _ Hi); rewrite ltb_spec in Hi; lia. - intros H1 i [_ H2]; apply H1; rewrite ltb_spec; rewrite leb_spec in H2; rewrite to_Z_sub_1_diff in H2; [lia| ]; intro H3; rewrite H3 in H; discriminate. + intros A f t; unfold aforallbi. + split. + intro H; generalize (afold_left_andb_false_inv _ H); clear H. + intros [ i [ Hi Hf ] ]; exists i. + rewrite length_amapi in Hi; rewrite get_amapi in Hf by exact Hi. + split; [ exact Hi | exact Hf ]. + intros [ i [ Hi Hf ] ]. + apply (afold_left_andb_false i); [ rewrite length_amapi; exact Hi | rewrite get_amapi by exact Hi; exact Hf ]. Qed. +Lemma aforallbi_spec : forall A (f : int -> A -> bool) t, + aforallbi f t = true <-> + forall i, i < length t = true -> f i (t.[i]) = true. +Proof. + intros A f t; unfold aforallbi. + split. + intro H; generalize (afold_left_andb_true_inv _ H); clear H. + rewrite length_amapi; intros H i Hi. + rewrite <- get_amapi by exact Hi. + apply H; exact Hi. + intro H; apply afold_left_andb_true. + intro i; rewrite length_amapi; intro Hi; rewrite get_amapi by exact Hi; apply H; exact Hi. +Qed. (** Forall of two lists at the same time *) @@ -1051,38 +1644,6 @@ End Forall2. Arguments forallb2 {A B} f l1 l2. -(* Compatibility between native-coq and Coq 8.5 *) - -Definition Nat_eqb := - fix eqb (n m : nat) {struct n} : bool := - match n with - | O => match m with - | O => true - | S _ => false - end - | S n' => match m with - | O => false - | S m' => eqb n' m' - end - end. - -Definition List_map_ext_in - : forall (A B : Type) (f g : A -> B) (l : list A), - (forall a : A, In a l -> f a = g a) -> List.map f l = List.map g l := - fun (A B : Type) (f g : A -> B) (l : list A) => - list_ind - (fun l0 : list A => - (forall a : A, In a l0 -> f a = g a) -> List.map f l0 = List.map g l0) - (fun _ : forall a : A, False -> f a = g a => eq_refl) - (fun (a : A) (l0 : list A) - (IHl : (forall a0 : A, In a0 l0 -> f a0 = g a0) -> List.map f l0 = List.map g l0) - (H : forall a0 : A, a = a0 \/ In a0 l0 -> f a0 = g a0) => - eq_ind_r (fun b : B => b :: List.map f l0 = g a :: List.map g l0) - (eq_ind_r (fun l1 : list B => g a :: l1 = g a :: List.map g l0) eq_refl - (IHl (fun (a0 : A) (H0 : In a0 l0) => H a0 (or_intror H0)))) - (H a (or_introl eq_refl))) l. - - (* Misc lemmas *) Lemma neg_eq_true_eq_false b : b = false <-> b <> true. @@ -1092,6 +1653,29 @@ Lemma is_true_iff e : e = true <-> is_true e. Proof. now unfold is_true. Qed. +(* Register constants for OCaml access *) +Register distinct as SMTCoq.Misc.distinct. + +Register Int63.eqb as num.int63.eqb. +Register PArray.array as array.array.type. +Register PArray.make as array.array.make. +Register PArray.set as array.array.set. +Register Coq.Init.Datatypes.is_true as core.is_true.is_true. +Register Coq.PArith.BinPosDef.Pos.eqb as num.pos.eqb. +Register Coq.NArith.BinNat.N.of_nat as num.N.of_nat. +Register Coq.ZArith.BinInt.Z.ltb as num.Z.ltb. +Register Coq.ZArith.BinInt.Z.leb as num.Z.leb. +Register Coq.ZArith.BinInt.Z.gtb as num.Z.gtb. +Register Coq.ZArith.BinInt.Z.geb as num.Z.geb. +Register Coq.ZArith.BinInt.Z.eqb as num.Z.eqb. +Register Coq.Init.Datatypes.implb as core.bool.implb. +Register Coq.Bool.Bool.eqb as core.bool.eqb. +Register Coq.Bool.Bool.ifb as core.bool.ifb. +Register Coq.Bool.Bool.reflect as core.bool.reflect. +Register Coq.Init.Datatypes.length as core.list.length. +Register Coq.micromega.ZMicromega.ZArithProof as micromega.ZMicromega.ZArithProof. + + (* Local Variables: coq-load-path: ((rec "." "SMTCoq")) diff --git a/src/PArray/PArray.v b/src/PArray/PArray.v new file mode 100644 index 0000000..03f1abd --- /dev/null +++ b/src/PArray/PArray.v @@ -0,0 +1,265 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2022 *) +(* *) +(* See file "AUTHORS" for the list of authors *) +(* *) +(* This file is distributed under the terms of the CeCILL-C licence *) +(* *) +(**************************************************************************) + + +(* Software implementation of arrays, based on finite maps using AVL + trees *) + +Declare Scope array_scope. + +Require Export Int63 Psatz. +Require FMapAVL. +Require Import ZArith. + +Local Open Scope int63_scope. + +Import OrderedType. + +Module IntOrderedType <: OrderedType. + + Definition t := int. + + Definition eq x y := (x == y) = true. + + Definition lt x y := (x < y) = true. + + Lemma eq_refl x : eq x x. + Proof. unfold eq. rewrite eqb_spec. reflexivity. Qed. + + Lemma eq_sym x y : eq x y -> eq y x. + Proof. unfold eq. rewrite !eqb_spec. intros ->. reflexivity. Qed. + + Lemma eq_trans x y z : eq x y -> eq y z -> eq x z. + Proof. unfold eq. rewrite !eqb_spec. intros -> ->. reflexivity. Qed. + + Lemma lt_trans x y z : lt x y -> lt y z -> lt x z. + Proof. unfold lt; rewrite !ltb_spec; apply Z.lt_trans. Qed. + + Lemma lt_not_eq x y : lt x y -> ~ eq x y. + Proof. unfold lt, eq. rewrite ltb_spec, eqb_spec. intros H1 H2. rewrite H2 in H1. lia. Qed. + + Definition compare x y : Compare lt eq x y. + Proof. + case_eq (x < y); intro e. + exact (LT e). + case_eq (x == y); intro e2. + exact (EQ e2). + apply GT. unfold lt. + rewrite <- Bool.not_false_iff_true, <- Bool.not_true_iff_false, ltb_spec, eqb_spec in *; intro e3. + apply e2, to_Z_inj; lia. + Defined. + + Definition eq_dec x y : { eq x y } + { ~ eq x y }. + Proof. + case_eq (x == y); intro e. + left; exact e. + right. intro H. rewrite H in e. discriminate. + Defined. + +End IntOrderedType. + +Module Map := FMapAVL.Make(IntOrderedType). + +(* An array is represented as a tuple of a finite map, the default + element, and the length *) +Definition array (A:Type) : Type := + (Map.t A * A * int)%type. + +Definition make {A:Type} (l:int) (d:A) : array A := (Map.empty A, d, l). + +Definition get {A:Type} (t:array A) (i:int) : A := + let (td, l) := t in + let (t, d) := td in + if i < l then + match Map.find i t with + | Some x => x + | None => d + end + else d. + +Definition default {A:Type} (t:array A) : A := + let (td,_) := t in let (_,d) := td in d. + +Definition set {A:Type} (t:array A) (i:int) (a:A) : array A := + let (td,l) := t in + if l <= i then + t + else + let (t,d) := td in + (Map.add i a t, d, l). + +Definition length {A:Type} (t:array A) : int := + let (_,l) := t in l. + +Definition copy {A:Type} (t:array A) : array A := t. + +Module Export PArrayNotations. +Delimit Scope array_scope with array. +Notation "t '.[' i ']'" := (get t i) (at level 50) : array_scope. +Notation "t '.[' i '<-' a ']'" := (set t i a) (at level 50) : array_scope. +End PArrayNotations. + +Local Open Scope array_scope. + +Definition max_length := max_int. + +(** Axioms *) +Require FSets.FMapFacts. +Module P := FSets.FMapFacts.WProperties_fun IntOrderedType Map. + +Lemma get_outofbound : forall A (t:array A) i, (i < length t) = false -> t.[i] = default t. +intros A t i; unfold get. +destruct t as ((t, d), l). +unfold length; intro Hi; rewrite Hi; clear Hi. +reflexivity. +Qed. + +Lemma get_set_same : forall A t i (a:A), (i < length t) = true -> t.[i<-a].[i] = a. +intros A t i a. +destruct t as ((t, d), l). +unfold set, get, length. +intro Hi; generalize Hi. +rewrite ltb_spec. +rewrite Z.lt_nge. +rewrite <- leb_spec. +rewrite Bool.not_true_iff_false. +intro Hi'; rewrite Hi'; clear Hi'. +rewrite Hi; clear Hi. +rewrite P.F.add_eq_o. +reflexivity. +rewrite eqb_spec. +reflexivity. +Qed. + +Lemma get_set_other : forall A t i j (a:A), i <> j -> t.[i<-a].[j] = t.[j]. +intros A t i j a Hij. +destruct t as ((t, d), l). +unfold set, get, length. +case (l <= i). +reflexivity. +rewrite P.F.add_neq_o. +reflexivity. +intro H; apply Hij; clear Hij. +rewrite eqb_spec in H. +assumption. +Qed. + +Lemma default_set : forall A t i (a:A), default (t.[i<-a]) = default t. +intros A t i a. +destruct t as ((t, d), l). +unfold default, set. +case (l <= i); reflexivity. +Qed. + +Lemma get_make : forall A (a:A) size i, (make size a).[i] = a. +intros A a size i. +unfold make, get. +rewrite P.F.empty_o. +case (i < size); reflexivity. +Qed. + +Lemma leb_length : forall A (t:array A), length t <= max_length = true. +intros A t. +generalize (length t); clear t. +intro i. +rewrite leb_spec. +apply Z.lt_succ_r. +change (Z.succ (to_Z max_length)) with wB. +apply to_Z_bounded. +Qed. + +Lemma length_make : forall A size (a:A), + length (make size a) = if size <= max_length then size else max_length. +intros A size a. +unfold length, make. +replace (size <= max_length) with true. +reflexivity. +symmetry. +rewrite leb_spec. +apply Z.lt_succ_r. +change (Z.succ (to_Z max_length)) with wB. +apply to_Z_bounded. +Qed. + +Lemma length_set : forall A t i (a:A), + length (t.[i<-a]) = length t. +intros A t i a. +destruct t as ((t, d), l). +unfold length, set. +case (l <= i); reflexivity. +Qed. + +Lemma get_copy : forall A (t:array A) i, (copy t).[i] = t.[i]. +intros A t i. +unfold copy; reflexivity. +Qed. + +Lemma length_copy : forall A (t:array A), length (copy t) = length t. +intros A t. +unfold copy; reflexivity. +Qed. + +(* Not true in this implementation (see #71, many thanks to Andres Erbsen) *) +(* +Axiom array_ext : forall A (t1 t2:array A), + length t1 = length t2 -> + (forall i, i < length t1 = true -> t1.[i] = t2.[i]) -> + default t1 = default t2 -> + t1 = t2. +*) + +(* Lemmas *) + +Lemma default_copy A (t:array A) : default (copy t) = default t. +unfold copy; reflexivity. +Qed. + +Lemma default_make A (a : A) size : default (make size a) = a. +unfold default, make; reflexivity. +Qed. + +Lemma get_set_same_default A (t : array A) (i : int) : t.[i <- default t].[i] = default t. +unfold default, get, set. +destruct t as ((t, d), l). +case_eq (i < l). +intro H; generalize H. +rewrite ltb_spec. +rewrite Z.lt_nge. +rewrite <- leb_spec. +rewrite Bool.not_true_iff_false. +intro H'; rewrite H'; clear H'. +rewrite H; clear H. +rewrite P.F.add_eq_o. +reflexivity. +rewrite eqb_spec. +reflexivity. +intro H; generalize H. +rewrite <- Bool.not_true_iff_false. +rewrite ltb_spec. +rewrite <- Z.le_ngt. +rewrite <- leb_spec. +intro H'; rewrite H'; clear H'. +rewrite H. +reflexivity. +Qed. + +Lemma get_not_default_lt A (t:array A) x : + t.[x] <> default t -> (x < length t) = true. +unfold get, default, length. +destruct t as ((t, d), l). +case (x < l); tauto. +Qed. + +(* + Local Variables: + coq-load-path: ((rec "../../.." "SMTCoq")) + End: +*) diff --git a/src/PropToBool.v b/src/PropToBool.v index 68800dd..4b4f907 100644 --- a/src/PropToBool.v +++ b/src/PropToBool.v @@ -158,7 +158,7 @@ Ltac prop2bool_hyp H := | Prop => fail | _ => intro end - | [ |- context[@eq ?A _ _] ] => instantiate (prop2bool_t_evar := A); instantiate (prop2bool_comp_evar := true) + | [ |- context[@Logic.eq ?A _ _] ] => instantiate (prop2bool_t_evar := A); instantiate (prop2bool_comp_evar := true) | _ => instantiate (prop2bool_t_evar := nat); instantiate (prop2bool_comp_evar := false) end; destruct HFalse diff --git a/src/QInst.v b/src/QInst.v index 356fe15..d891fe2 100644 --- a/src/QInst.v +++ b/src/QInst.v @@ -190,7 +190,7 @@ Ltac vauto := end ] ); - auto. + auto with smtcoq_core. diff --git a/src/SMT_terms.v b/src/SMT_terms.v index 0b9ba30..8c4ffa6 100644 --- a/src/SMT_terms.v +++ b/src/SMT_terms.v @@ -10,7 +10,7 @@ (**************************************************************************) -Require Import Bool Int63 PArray BinNat BinPos ZArith SMT_classes_instances. +Require Import Bool Int63 Psatz PArray BinNat BinPos ZArith SMT_classes_instances. Require Import Misc State BVList. (* FArray Equalities DecidableTypeEx. *) Require FArray. Require List . @@ -18,7 +18,7 @@ Local Open Scope list_scope. Local Open Scope array_scope. Local Open Scope int63_scope. -Hint Unfold is_true. +Hint Unfold is_true : smtcoq_core. (* Remark: I use Notation instead of Definition du eliminate conversion check during the type checking *) @@ -79,10 +79,10 @@ Module Form. | Fatom a => interp_atom a | Ftrue => true | Ffalse => false - | Fnot2 i l => fold (fun b => negb (negb b)) 1 i (Lit.interp interp_var l) - | Fand args => afold_left _ _ true andb (Lit.interp interp_var) args - | For args => afold_left _ _ false orb (Lit.interp interp_var) args - | Fimp args => afold_right _ _ true implb (Lit.interp interp_var) args + | Fnot2 i l => foldi (fun _ b => negb (negb b)) 0 i (Lit.interp interp_var l) + | Fand args => afold_left _ true andb (amap (Lit.interp interp_var) args) + | For args => afold_left _ false orb (amap (Lit.interp interp_var) args) + | Fimp args => afold_right _ true implb (amap (Lit.interp interp_var) args) | Fxor a b => xorb (Lit.interp interp_var a) (Lit.interp interp_var b) | Fiff a b => Bool.eqb (Lit.interp interp_var a) (Lit.interp interp_var b) | Fite a b c => @@ -98,19 +98,19 @@ Module Form. Section Interp_get. - Variable t_form : PArray.array form. + Variable t_form : array form. - Definition t_interp : PArray.array bool := - PArray.foldi_left (fun i t_b hf => - t_b.[i <- interp_aux (PArray.get t_b) hf]) - (PArray.make (PArray.length t_form) true) t_form. + Definition t_interp : array bool := + foldi (fun i t_b => + t_b.[i <- interp_aux (get t_b) (t_form.[i])]) 0 (length t_form) + (make (length t_form) true). Fixpoint lt_form i h {struct h} := match h with | Fatom _ | Ftrue | Ffalse => true | Fnot2 _ l => Lit.blit l < i | Fand args | For args | Fimp args => - PArray.forallb (fun l => Lit.blit l < i) args + aforallbi (fun _ l => Lit.blit l < i) args | Fxor a b | Fiff a b => (Lit.blit a < i) && (Lit.blit b < i) | Fite a b c => (Lit.blit a < i) && (Lit.blit b < i) && (Lit.blit c < i) | FbbT _ ls => List.forallb (fun l => Lit.blit l < i) ls @@ -123,41 +123,42 @@ Module Form. interp_aux f1 h = interp_aux f2 h. Proof. destruct h;simpl;intros;trivial; - try (apply afold_left_eq;unfold is_true in H0; - rewrite PArray.forallb_spec in H0;intros; - auto using Lit.interp_eq_compat). + try (try apply afold_left_eq; try apply afold_right_eq;unfold is_true in H0; + rewrite ?forallb_spec, ?aforallbi_spec, ?andb_true_iff in H0;intros; + rewrite ?length_amap; try rewrite length_amap in H1; + rewrite ?get_amap by assumption; + auto using Lit.interp_eq_compat with smtcoq_core). - f_equal;auto using Lit.interp_eq_compat. - - apply afold_right_eq;unfold is_true in H0; - rewrite PArray.forallb_spec in H0;intros; - auto using Lit.interp_eq_compat. - - unfold is_true in H0;rewrite !andb_true_iff in H0;decompose [and] H0; - rewrite !(Lit.interp_eq_compat f1 f2);auto. - - unfold is_true in H0;rewrite !andb_true_iff in H0;decompose [and] H0; - rewrite !(Lit.interp_eq_compat f1 f2);auto. - - unfold is_true in H0;rewrite !andb_true_iff in H0;decompose [and] H0; - rewrite !(Lit.interp_eq_compat f1 f2);auto. + - decompose [and] H0; rewrite !(Lit.interp_eq_compat f1 f2);auto. + - decompose [and] H0; rewrite !(Lit.interp_eq_compat f1 f2);auto. + - decompose [and] H0; rewrite !(Lit.interp_eq_compat f1 f2);auto. - replace (List.map (Lit.interp f2) l) with (List.map (Lit.interp f1) l); auto. unfold is_true in H0. rewrite List.forallb_forall in H0. - apply List_map_ext_in. intros x Hx. apply Lit.interp_eq_compat; auto. + apply List.map_ext_in. intros x Hx. apply Lit.interp_eq_compat; auto with smtcoq_core. Qed. - Definition wf := PArray.forallbi lt_form t_form. + Definition wf := aforallbi lt_form t_form. Hypothesis wf_t_i : wf. Lemma length_t_interp : length t_interp = length t_form. Proof. - unfold t_interp;apply PArray.foldi_left_Ind with (P := fun i a => length a = length t_form). + unfold t_interp. + assert (Bt := to_Z_bounded (length t_form)). + apply (foldi_ind _ (fun i a => length a = length t_form)). + rewrite leb_spec, to_Z_0; lia. + rewrite length_make, leb_length; reflexivity. intros;rewrite length_set;trivial. - rewrite length_make, ltb_length;trivial. Qed. Lemma default_t_interp : default t_interp = true. Proof. - unfold t_interp;apply PArray.foldi_left_Ind with - (P := fun i a => default a = true). - intros;rewrite default_set;trivial. + unfold t_interp. + assert (Bt := to_Z_bounded (length t_form)). + apply (foldi_ind _ (fun i a => default a = true)). + rewrite leb_spec, to_Z_0; lia. apply default_make. + intros;rewrite default_set;trivial. Qed. Lemma t_interp_wf : forall i, i < PArray.length t_form -> @@ -167,26 +168,27 @@ Module Form. forall j, j < i -> t.[j] = interp_aux (PArray.get t) (t_form.[j])). assert (P' (length t_form) t_interp). - unfold is_true, wf in wf_t_i;rewrite PArray.forallbi_spec in wf_t_i. - unfold t_interp;apply foldi_left_Ind;unfold P';intros. - rewrite length_set in H1. - destruct (Int63Properties.reflect_eqb j i). - rewrite e, PArray.get_set_same. - apply lt_form_interp_form_aux with (2:= wf_t_i i H). + unfold is_true, wf in wf_t_i;rewrite aforallbi_spec in wf_t_i. + unfold t_interp;apply foldi_ind;unfold P';intros. + apply leb_0. + elim (ltb_0 _ H0). + rewrite length_set in H2. + destruct (reflect_eqb j i). + rewrite e, get_set_same. + apply lt_form_interp_form_aux with (2:= wf_t_i i H0). intros;rewrite get_set_other;trivial. intros Heq;elim (not_ltb_refl i);rewrite Heq at 1;trivial. - rewrite H1;trivial. + rewrite H2;trivial. assert (j < i). assert ([|j|] <> [|i|]) by (intros Heq1;elim n;apply to_Z_inj;trivial). - generalize H2;unfold is_true;rewrite !ltb_spec, (to_Z_add_1 _ _ H); + generalize H3;unfold is_true;rewrite !ltb_spec, (to_Z_add_1 _ _ H0); auto with zarith. - rewrite get_set_other, H0;auto. + rewrite get_set_other, H1;auto. apply lt_form_interp_form_aux with - (2:= wf_t_i j (ltb_trans _ _ _ H3 H)). + (2:= wf_t_i j (ltb_trans _ _ _ H4 H0)). intros;rewrite get_set_other;trivial. intros Heq;elim (not_ltb_refl i);apply ltb_trans with j; [ rewrite Heq| ];trivial. - elim (ltb_0 _ H0). apply H;apply length_t_interp. Qed. @@ -252,7 +254,7 @@ Module Typ. Import FArray. - Notation index := int (only parsing). + Notation index := N (only parsing). Inductive type := | TFArray : type -> type -> type @@ -287,7 +289,7 @@ Module Typ. (FArray_compdec tti tte) | Tindex i => existT (fun ty : Type => CompDec ty) - (te_carrier (t_i .[ i])) (te_compdec (t_i .[ i])) + (te_carrier (t_i .[of_Z (Z.of_N i)])) (te_compdec (t_i .[of_Z (Z.of_N i)])) | TZ => existT (fun ty : Type => CompDec ty) Z Z_compdec | Tbool => existT (fun ty : Type => CompDec ty) bool bool_compdec | Tpositive => existT (fun ty : Type => CompDec ty) positive Positive_compdec @@ -360,7 +362,7 @@ Module Typ. reflect (x = y) (eqb_of_compdec c x y). Proof. intros x y. - apply reflect_eqb. + apply SMT_classes.reflect_eqb. Qed. @@ -377,7 +379,7 @@ Module Typ. Definition i_eqb_eqb (t:type) : interp t -> interp t -> bool := match t with - | Tindex i => eqb_of_compdec (t_i.[i]).(te_compdec) + | Tindex i => eqb_of_compdec (t_i.[of_Z (Z.of_N i)]).(te_compdec) | TZ => Z.eqb (* Zeq_bool *) | Tbool => Bool.eqb | Tpositive => Pos.eqb @@ -486,7 +488,7 @@ Module Typ. Fixpoint cast (A B: type) : cast_result A B := match A as C, B as D return cast_result C D with | Tindex i, Tindex j => - match Int63Op.cast i j with + match N_cast i j with | Some k => Cast (fun P => k (fun y => P (Tindex y))) | None => NoCast end @@ -524,7 +526,7 @@ Module Typ. Proof. destruct A;simpl;trivial. do 2 rewrite cast_refl. easy. - rewrite Int63Properties.cast_refl;trivial. + rewrite N_cast_refl;trivial. rewrite N_cast_refl;trivial. Qed. @@ -532,7 +534,7 @@ Module Typ. (* Remark : I use this definition because eqb will not be used only in the interpretation *) Fixpoint eqb (A B: type) : bool := match A, B with - | Tindex i, Tindex j => i == j + | Tindex i, Tindex j => N.eqb i j | TZ, TZ => true | Tbool, Tbool => true | Tpositive, Tpositive => true @@ -546,11 +548,11 @@ Module Typ. (* TODO : Move this *) Lemma not_false : ~ false. Proof. intro;discriminate. Qed. - Hint Resolve not_false. + Hint Resolve not_false : smtcoq_core. Lemma is_true_true : true. Proof. reflexivity. Qed. - Hint Resolve is_true_true. + Hint Resolve is_true_true : smtcoq_core. Lemma not_is_true_eq_false : forall b:bool, ~ b <-> b = false. Proof. exact not_true_iff_false. Qed. @@ -580,7 +582,7 @@ Module Typ. rewrite andb_false_iff in H. destruct H; apply cast_diff in H; rewrite H; auto. case (cast A1 B1); auto. - intros H. rewrite (Int63Properties.cast_diff _ _ H);trivial. + rewrite N.eqb_neq. intro Heq. now rewrite N_cast_diff. rewrite N.eqb_neq. intro Heq. now rewrite N_cast_diff. Qed. @@ -615,7 +617,7 @@ Module Typ. apply (reflect_iff _ _ (reflect_eqb x1 y1)) in H. apply (reflect_iff _ _ (reflect_eqb x2 y2)) in H0. subst; auto. - apply iff_reflect;rewrite Int63Properties.eqb_spec;split;intros H;[inversion H | subst]; trivial. + apply iff_reflect. rewrite N.eqb_eq. split;intros H;[inversion H | subst]; trivial. apply iff_reflect. rewrite N.eqb_eq. split;intros H;[inversion H | subst]; trivial. Qed. @@ -785,7 +787,7 @@ Module Atom. | UO_Zpos, UO_Zpos | UO_Zneg, UO_Zneg | UO_Zopp, UO_Zopp => true - | UO_BVbitOf s1 n, UO_BVbitOf s2 m => Nat_eqb n m && N.eqb s1 s2 + | UO_BVbitOf s1 n, UO_BVbitOf s2 m => Nat.eqb n m && N.eqb s1 s2 | UO_BVnot s1, UO_BVnot s2 => N.eqb s1 s2 | UO_BVneg s1, UO_BVneg s2 => N.eqb s1 s2 | UO_BVextr i0 n00 n01, UO_BVextr i1 n10 n11 => N.eqb i0 i1 && N.eqb n00 n10 && N.eqb n01 n11 @@ -834,10 +836,10 @@ Module Atom. | Acop o, Acop o' => cop_eqb o o' | Auop o t, Auop o' t' => uop_eqb o o' && (t == t') | Abop o t1 t2, Abop o' t1' t2' => bop_eqb o o' && (t1 == t1') && (t2 == t2') - | Anop o t, Anop o' t' => nop_eqb o o' && list_beq Int63Native.eqb t t' + | Anop o t, Anop o' t' => nop_eqb o o' && list_beq Int63.eqb t t' | Atop o t1 t2 t3, Atop o' t1' t2' t3' => top_eqb o o' && (t1 == t1') && (t2 == t2') && (t3 == t3') - | Aapp a la, Aapp b lb => (a == b) && list_beq Int63Native.eqb la lb + | Aapp a la, Aapp b lb => (a == b) && list_beq Int63.eqb la lb | _, _ => false end. @@ -861,7 +863,7 @@ Module Atom. Lemma reflect_uop_eqb : forall o1 o2, reflect (o1 = o2) (uop_eqb o1 o2). Proof. intros [ | | | | | s1 n1 | s1 | s1 | s1 | s1 | s1 ] [ | | | | |s2 n2 | s2 | s2 | s2 | s2 | s2 ];simpl; try constructor;trivial; try discriminate. - - apply iff_reflect. case_eq (Nat_eqb n1 n2). + - apply iff_reflect. case_eq (Nat.eqb n1 n2). + case_eq ((s1 =? s2)%N). * rewrite N.eqb_eq, beq_nat_true_iff. intros -> ->. split; reflexivity. @@ -963,26 +965,26 @@ Qed. (* Constants *) preflect (reflect_cop_eqb c c0);constructor;subst;trivial. (* Unary operators *) - preflect (reflect_uop_eqb u u0); preflect (Int63Properties.reflect_eqb i i0); + preflect (reflect_uop_eqb u u0); preflect (Misc.reflect_eqb i i0); constructor;subst;trivial. (* Binary operators *) preflect (reflect_bop_eqb b b0); - preflect (Int63Properties.reflect_eqb i i1); - preflect (Int63Properties.reflect_eqb i0 i2); + preflect (Misc.reflect_eqb i i1); + preflect (Misc.reflect_eqb i0 i2); constructor;subst;trivial. (* Ternary operators *) preflect (reflect_top_eqb t t0). - preflect (Int63Properties.reflect_eqb i i2). - preflect (Int63Properties.reflect_eqb i0 i3). - preflect (Int63Properties.reflect_eqb i1 i4). + preflect (Misc.reflect_eqb i i2). + preflect (Misc.reflect_eqb i0 i3). + preflect (Misc.reflect_eqb i1 i4). constructor;subst;trivial. (* N-ary operators *) preflect (reflect_nop_eqb n n0); - preflect (reflect_list_beq _ _ Int63Properties.reflect_eqb l l0); + preflect (reflect_list_beq _ _ Misc.reflect_eqb l l0); constructor; subst; reflexivity. (* Application *) - preflect (Int63Properties.reflect_eqb i i0); - preflect (reflect_list_beq _ _ Int63Properties.reflect_eqb l l0); + preflect (Misc.reflect_eqb i i0); + preflect (reflect_list_beq _ _ Misc.reflect_eqb l l0); constructor;subst;trivial. Qed. @@ -1183,8 +1185,8 @@ Qed. intros [op|op h|op h1 h2|op ha i i0|f args | i e ]; simpl. (* Constants *) left; destruct op; simpl. - exists Typ.Tpositive; auto. - exists Typ.TZ; auto. + exists Typ.Tpositive; auto with smtcoq_core. + exists Typ.TZ; auto with smtcoq_core. exists (Typ.TBV n); now rewrite N.eqb_refl. (* Unary operators *) destruct op; simpl; @@ -1386,7 +1388,7 @@ Qed. right. intros. rewrite andb_false_r. easy. (* N-ary operators *) destruct f as [ty]; simpl; case (List.forallb (fun t1 : int => Typ.eqb (get_type t1) ty) args). - left; exists Typ.Tbool; auto. + left; exists Typ.Tbool; auto with smtcoq_core. right; intro T; rewrite andb_false_r; auto. (* Application *) case (v_type Typ.ftype interp_ft (t_func .[ i])); intros; apply check_args_dec. @@ -2217,9 +2219,9 @@ Qed. Variable t_atom : PArray.array atom. - Definition t_interp : PArray.array bval := - PArray.foldi_left (fun i t_a a => t_a.[i <- interp_aux (PArray.get t_a) a]) - (PArray.make (PArray.length t_atom) (interp_cop CO_xH)) t_atom. + Definition t_interp : array bval := + foldi (fun i t_a => t_a.[i <- interp_aux (get t_a) (t_atom.[i])]) 0 (length t_atom) + (make (length t_atom) (interp_cop CO_xH)). Definition lt_atom i a := match a with @@ -2251,52 +2253,58 @@ Qed. unfold is_true in H;rewrite andb_true_iff in H;destruct H;rewrite Hf, IHl;trivial. Qed. - Definition wf := PArray.forallbi lt_atom t_atom. + Definition wf := aforallbi lt_atom t_atom. Hypothesis wf_t_i : wf. Lemma length_t_interp : length t_interp = length t_atom. Proof. - unfold t_interp;apply PArray.foldi_left_Ind with - (P := fun i a => length a = length t_atom). + unfold t_interp. + assert (Bt := to_Z_bounded (length t_atom)). + apply (foldi_ind _ (fun i a => length a = length t_atom)). + rewrite leb_spec, to_Z_0; lia. + rewrite length_make, leb_length;trivial. intros;rewrite length_set;trivial. - rewrite length_make, ltb_length;trivial. Qed. Lemma default_t_interp : default t_interp = interp_cop CO_xH. Proof. - unfold t_interp;apply PArray.foldi_left_Ind with - (P := fun i a => default a = interp_cop CO_xH). - intros;rewrite default_set;trivial. + unfold t_interp. + assert (Bt := to_Z_bounded (length t_atom)). + apply (foldi_ind _ (fun i a => default a = interp_cop CO_xH)). + rewrite leb_spec, to_Z_0; lia. apply default_make. + intros;rewrite default_set;trivial. Qed. Lemma t_interp_wf_lt : forall i, i < PArray.length t_atom -> t_interp.[i] = interp_aux (PArray.get t_interp) (t_atom.[i]). Proof. + assert (Bt := to_Z_bounded (length t_atom)). set (P' i t := length t = length t_atom -> forall j, j < i -> t.[j] = interp_aux (PArray.get t) (t_atom.[j])). assert (P' (length t_atom) t_interp). - unfold is_true, wf in wf_t_i;rewrite PArray.forallbi_spec in wf_t_i. - unfold t_interp;apply foldi_left_Ind;unfold P';intros. - rewrite length_set in H1. - destruct (Int63Properties.reflect_eqb j i). + unfold is_true, wf in wf_t_i;rewrite aforallbi_spec in wf_t_i. + unfold t_interp;apply foldi_ind;unfold P';intros. + rewrite leb_spec, to_Z_0; lia. + elim (ltb_0 _ H0). + rewrite length_set in H2. + destruct (Misc.reflect_eqb j i). rewrite e, PArray.get_set_same. - apply lt_interp_aux with (2:= wf_t_i i H). + apply lt_interp_aux with (2:= wf_t_i i H0). intros;rewrite get_set_other;trivial. intros Heq;elim (not_ltb_refl i);rewrite Heq at 1;trivial. - rewrite H1;trivial. + rewrite H2;trivial. assert (j < i). assert ([|j|] <> [|i|]) by(intros Heq1;elim n;apply to_Z_inj;trivial). - generalize H2;unfold is_true;rewrite !ltb_spec, - (to_Z_add_1 _ _ H);auto with zarith. - rewrite get_set_other, H0;auto. - apply lt_interp_aux with (2:= wf_t_i j (ltb_trans _ _ _ H3 H)). + generalize H3;unfold is_true;rewrite !ltb_spec, + (to_Z_add_1 _ _ H0);auto with zarith. + rewrite get_set_other, H1;auto. + apply lt_interp_aux with (2:= wf_t_i j (ltb_trans _ _ _ H4 H0)). intros;rewrite get_set_other;trivial. intros Heq;elim (not_ltb_refl i);apply ltb_trans with j; [ rewrite Heq| ];trivial. - elim (ltb_0 _ H0). apply H;apply length_t_interp. Qed. @@ -2355,7 +2363,7 @@ Qed. exists v, interp_aux (get a) (t_atom.[h]) = Bval (v_type _ _ (interp_aux (get a) (t_atom.[h]))) v. Proof. - unfold wf, is_true in wf_t_i; rewrite forallbi_spec in wf_t_i. + unfold wf, is_true in wf_t_i; rewrite aforallbi_spec in wf_t_i. intros h Hh a IH; generalize (wf_t_i h Hh). case (t_atom.[h]); simpl. (* Constants *) @@ -2487,22 +2495,24 @@ Qed. Lemma check_aux_interp_hatom_lt : forall h, h < length t_atom -> exists v, t_interp.[h] = Bval (get_type h) v. Proof. + assert (Bt := to_Z_bounded (length t_atom)). set (P' i t := length t = length t_atom -> forall j, j < i -> exists v, t.[j] = Bval (v_type Typ.type interp_t (t.[j])) v). assert (P' (length t_atom) t_interp). - unfold t_interp;apply foldi_left_Ind;unfold P';intros. - rewrite length_set in H1. - destruct (Int63Properties.reflect_eqb j i). + unfold t_interp;apply foldi_ind;unfold P';intros. + rewrite leb_spec, to_Z_0; lia. + elim (ltb_0 _ H0). + rewrite length_set in H2. + destruct (Misc.reflect_eqb j i). rewrite e, PArray.get_set_same. apply check_aux_interp_aux_lt; auto. - rewrite H1; auto. + rewrite H2; auto. assert (j < i). assert ([|j|] <> [|i|]) by(intros Heq1;elim n;apply to_Z_inj;trivial). - generalize H2;unfold is_true;rewrite !ltb_spec, - (to_Z_add_1 _ _ H);auto with zarith. + generalize H3;unfold is_true;rewrite !ltb_spec, + (to_Z_add_1 _ _ H0);auto with zarith. rewrite get_set_other;auto. - elim (ltb_0 _ H0). apply H;apply length_t_interp. Qed. @@ -2541,7 +2551,7 @@ Qed. Definition wt t_atom := let t_interp := t_interp t_atom in let get_type := get_type' t_interp in - PArray.forallbi (fun i h => check_aux get_type h (get_type i)) t_atom. + aforallbi (fun i h => check_aux get_type h (get_type i)) t_atom. Definition interp_hatom (t_atom : PArray.array atom) := let t_a := t_interp t_atom in @@ -2598,6 +2608,79 @@ End PredefinedArrays. *) +(* Register constants for OCaml access *) +Register Typ.type as SMTCoq.SMT_terms.Typ.type. +Register Typ.TFArray as SMTCoq.SMT_terms.Typ.TFArray. +Register Typ.Tindex as SMTCoq.SMT_terms.Typ.Tindex. +Register Typ.TZ as SMTCoq.SMT_terms.Typ.TZ. +Register Typ.Tbool as SMTCoq.SMT_terms.Typ.Tbool. +Register Typ.Tpositive as SMTCoq.SMT_terms.Typ.Tpositive. +Register Typ.TBV as SMTCoq.SMT_terms.Typ.TBV. +Register Typ.interp as SMTCoq.SMT_terms.Typ.interp. +Register Typ.dec_interp as SMTCoq.SMT_terms.Typ.dec_interp. +Register Typ.ord_interp as SMTCoq.SMT_terms.Typ.ord_interp. +Register Typ.comp_interp as SMTCoq.SMT_terms.Typ.comp_interp. +Register Typ.inh_interp as SMTCoq.SMT_terms.Typ.inh_interp. +Register Typ.i_eqb as SMTCoq.SMT_terms.Typ.i_eqb. +Register Atom.tval as SMTCoq.SMT_terms.Atom.tval. +Register Atom.Tval as SMTCoq.SMT_terms.Atom.Tval. +Register Atom.CO_xH as SMTCoq.SMT_terms.Atom.CO_xH. +Register Atom.CO_Z0 as SMTCoq.SMT_terms.Atom.CO_Z0. +Register Atom.CO_BV as SMTCoq.SMT_terms.Atom.CO_BV. +Register Atom.UO_xO as SMTCoq.SMT_terms.Atom.UO_xO. +Register Atom.UO_xI as SMTCoq.SMT_terms.Atom.UO_xI. +Register Atom.UO_Zpos as SMTCoq.SMT_terms.Atom.UO_Zpos. +Register Atom.UO_Zneg as SMTCoq.SMT_terms.Atom.UO_Zneg. +Register Atom.UO_Zopp as SMTCoq.SMT_terms.Atom.UO_Zopp. +Register Atom.UO_BVbitOf as SMTCoq.SMT_terms.Atom.UO_BVbitOf. +Register Atom.UO_BVnot as SMTCoq.SMT_terms.Atom.UO_BVnot. +Register Atom.UO_BVneg as SMTCoq.SMT_terms.Atom.UO_BVneg. +Register Atom.UO_BVextr as SMTCoq.SMT_terms.Atom.UO_BVextr. +Register Atom.UO_BVzextn as SMTCoq.SMT_terms.Atom.UO_BVzextn. +Register Atom.UO_BVsextn as SMTCoq.SMT_terms.Atom.UO_BVsextn. +Register Atom.BO_Zplus as SMTCoq.SMT_terms.Atom.BO_Zplus. +Register Atom.BO_Zminus as SMTCoq.SMT_terms.Atom.BO_Zminus. +Register Atom.BO_Zmult as SMTCoq.SMT_terms.Atom.BO_Zmult. +Register Atom.BO_Zlt as SMTCoq.SMT_terms.Atom.BO_Zlt. +Register Atom.BO_Zle as SMTCoq.SMT_terms.Atom.BO_Zle. +Register Atom.BO_Zge as SMTCoq.SMT_terms.Atom.BO_Zge. +Register Atom.BO_Zgt as SMTCoq.SMT_terms.Atom.BO_Zgt. +Register Atom.BO_eq as SMTCoq.SMT_terms.Atom.BO_eq. +Register Atom.BO_BVand as SMTCoq.SMT_terms.Atom.BO_BVand. +Register Atom.BO_BVor as SMTCoq.SMT_terms.Atom.BO_BVor. +Register Atom.BO_BVxor as SMTCoq.SMT_terms.Atom.BO_BVxor. +Register Atom.BO_BVadd as SMTCoq.SMT_terms.Atom.BO_BVadd. +Register Atom.BO_BVmult as SMTCoq.SMT_terms.Atom.BO_BVmult. +Register Atom.BO_BVult as SMTCoq.SMT_terms.Atom.BO_BVult. +Register Atom.BO_BVslt as SMTCoq.SMT_terms.Atom.BO_BVslt. +Register Atom.BO_BVconcat as SMTCoq.SMT_terms.Atom.BO_BVconcat. +Register Atom.BO_BVshl as SMTCoq.SMT_terms.Atom.BO_BVshl. +Register Atom.BO_BVshr as SMTCoq.SMT_terms.Atom.BO_BVshr. +Register Atom.BO_select as SMTCoq.SMT_terms.Atom.BO_select. +Register Atom.BO_diffarray as SMTCoq.SMT_terms.Atom.BO_diffarray. +Register Atom.TO_store as SMTCoq.SMT_terms.Atom.TO_store. +Register Atom.NO_distinct as SMTCoq.SMT_terms.Atom.NO_distinct. +Register Atom.atom as SMTCoq.SMT_terms.Atom.atom. +Register Atom.Acop as SMTCoq.SMT_terms.Atom.Acop. +Register Atom.Auop as SMTCoq.SMT_terms.Atom.Auop. +Register Atom.Abop as SMTCoq.SMT_terms.Atom.Abop. +Register Atom.Atop as SMTCoq.SMT_terms.Atom.Atop. +Register Atom.Anop as SMTCoq.SMT_terms.Atom.Anop. +Register Atom.Aapp as SMTCoq.SMT_terms.Atom.Aapp. +Register Form.form as SMTCoq.SMT_terms.Form.form. +Register Form.Fatom as SMTCoq.SMT_terms.Form.Fatom. +Register Form.Ftrue as SMTCoq.SMT_terms.Form.Ftrue. +Register Form.Ffalse as SMTCoq.SMT_terms.Form.Ffalse. +Register Form.Fnot2 as SMTCoq.SMT_terms.Form.Fnot2. +Register Form.Fand as SMTCoq.SMT_terms.Form.Fand. +Register Form.For as SMTCoq.SMT_terms.Form.For. +Register Form.Fxor as SMTCoq.SMT_terms.Form.Fxor. +Register Form.Fimp as SMTCoq.SMT_terms.Form.Fimp. +Register Form.Fiff as SMTCoq.SMT_terms.Form.Fiff. +Register Form.Fite as SMTCoq.SMT_terms.Form.Fite. +Register Form.FbbT as SMTCoq.SMT_terms.Form.FbbT. + + (* Local Variables: coq-load-path: ((rec "." "SMTCoq")) diff --git a/src/State.v b/src/State.v index a1e8437..fb1c42f 100644 --- a/src/State.v +++ b/src/State.v @@ -10,7 +10,7 @@ (**************************************************************************) -Require Import List Bool Int63 PArray Omega. +Require Import List Bool Int63 Psatz Ring63 PArray Omega Misc. (* Require Import AxiomesInt. *) @@ -88,13 +88,13 @@ Module Lit. Lemma neg_involutive : forall l, neg (neg l) = l. Proof. - unfold neg;intros; rewrite <- lxor_assoc;change (1 lxor 1) with 0;rewrite lxor_0_r;trivial. + unfold neg;intros; rewrite <- lxorA;change (1 lxor 1) with 0;rewrite lxor0_r;trivial. Qed. Lemma blit_neg : forall l, blit (neg l) = blit l. Proof. unfold blit, neg;intros l. - rewrite lxor_lsr, lxor_0_r;trivial. + rewrite lxor_lsr, lxor0_r;trivial. Qed. Lemma lit_blit: forall l, @@ -103,7 +103,7 @@ Module Lit. unfold is_pos, lit, blit;intros. rewrite (bit_xor_split l) at 2. rewrite is_even_bit, negb_true_iff in H;rewrite H. - symmetry;apply lxor_0_r. + symmetry;apply lxor0_r. Qed. Lemma lit_blit_neg: forall l, @@ -220,7 +220,7 @@ Module Lit. Lemma lxor_neg : forall l1 l2, (l1 lxor l2 == 1) = true -> l1 = Lit.neg l2. Proof. unfold Lit.neg; intros l1 l2;rewrite eqb_spec;intros Heq;rewrite <- Heq. - rewrite lxor_comm, <- lxor_assoc, lxor_nilpotent, lxor_0_r;trivial. + rewrite lxorC, <- lxorA, lxor_nilpotent, lxor0_r;trivial. Qed. End Lit. @@ -484,7 +484,7 @@ Module S. forall id, valid rho (set s id c). Proof. unfold valid, get;simpl;intros. - destruct (Int63Properties.reflect_eqb id id0);subst. + destruct (reflect_eqb id id0);subst. case_eq (id0 < length s);intros. rewrite PArray.get_set_same;trivial. rewrite PArray.get_outofbound. @@ -622,7 +622,7 @@ Module S. C.valid rho c -> valid rho (set_clause s pos c). Proof. unfold valid, get, set_clause. intros rho s Hrho Hs pos c Hc id. - destruct (Int63Properties.reflect_eqb pos id);subst. + destruct (reflect_eqb pos id);subst. case_eq (id < length s); intro H. unfold get;rewrite PArray.get_set_same; trivial. unfold C.valid;rewrite sort_correct;trivial. @@ -640,7 +640,7 @@ Module S. C.valid rho c -> valid rho (set_clause_keep s pos c). Proof. unfold valid, get, set_clause_keep. intros rho s Hrho Hs pos c Hc id. - destruct (Int63Properties.reflect_eqb pos id);subst. + destruct (reflect_eqb pos id);subst. case_eq (id < length s); intro H. unfold get;rewrite PArray.get_set_same; trivial. unfold C.valid;rewrite sort_keep_correct;trivial. @@ -657,7 +657,7 @@ Module S. let len := PArray.length r in if len == 0 then s else - let c := foldi (fun i c' => (C.resolve (get s (r.[i])) c')) 1 (len - 1) (get s (r.[0])) in + let c := foldi (fun i c' => (C.resolve (get s (r.[i])) c')) 1 len (get s (r.[0])) in (* S.set_clause *) internal_set s pos c. Lemma valid_set_resolve : @@ -665,13 +665,18 @@ Module S. forall pos r, valid rho (set_resolve s pos r). Proof. unfold set_resolve; intros rho s Hrho Hv pos r. - destruct (Int63Properties.reflect_eqb (length r) 0);[trivial | ]. + destruct (reflect_eqb (length r) 0);[trivial | ]. apply valid_internal_set;trivial. - (* apply S.valid_set_clause; auto. *) - apply foldi_ind;auto. - intros i c _ _ Hc. apply C.resolve_correct;auto;apply Hv. - Qed. - + pattern (length r); apply (int_ind_bounded _ 1). + generalize (to_Z_bounded (length r)); rewrite <- to_Z_eq, to_Z_0 in n; rewrite leb_spec, to_Z_1; lia. + rewrite foldi_ge; [ apply Hv | reflexivity ]. + intros i Hi1 Hi2 Hc. + rewrite foldi_lt_r. + apply C.resolve_correct; [ apply Hv | ring_simplify (i + 1 - 1); exact Hc ]. + rewrite ltb_spec, to_Z_add_1_wB, to_Z_1. + rewrite leb_spec, to_Z_1 in Hi1; generalize (to_Z_bounded i); omega. + rewrite ltb_spec in Hi2; generalize (to_Z_bounded (length r)); omega. + Qed. (* Weakening *) @@ -732,3 +737,8 @@ Module S. End S. + + +(* Register constants for OCaml access *) +Register C.t as SMTCoq.State.C.t. +Register S.t as SMTCoq.State.S.t. diff --git a/src/versions/standard/Tactics_standard.v b/src/Tactics.v index 14b984b..14b984b 100644 --- a/src/versions/standard/Tactics_standard.v +++ b/src/Tactics.v diff --git a/src/Trace.v b/src/Trace.v index 17338ca..1849c44 100644 --- a/src/Trace.v +++ b/src/Trace.v @@ -11,7 +11,6 @@ Require Import Bool Int63 PArray. -Require Structures. Require Import Misc State SMT_terms. Require Import Syntactic Arithmetic Operators Assumptions. Require Import Cnf Euf Lia BVList Bva_checker Array_checker. @@ -34,7 +33,7 @@ Section trace. Variable rho : Valuation.t. - Definition _trace_ := Structures.trace step. + Definition _trace_ := ((list step) * step)%type. (* A checker for such a trace *) @@ -42,7 +41,7 @@ Section trace. Hypothesis is_false_correct : forall c, is_false c -> ~ C.interp rho c. Definition _checker_ (s: S.t) (t: _trace_) (confl:clause_id) : bool := - let s' := Structures.trace_fold check_step s t in + let s' := List.fold_left check_step (fst t) s in (* let s' := PArray.fold_left (fun s a => PArray.fold_left check_step s a) s t in *) is_false (S.get s' confl). (* Register _checker_ as PrimInline. *) @@ -78,7 +77,11 @@ Section trace. intros s t' cid Hf Hv. apply (is_false_correct Hf). apply S.valid_get. - apply Structures.trace_fold_ind; auto. + clear Hf. + rewrite <- List.fold_left_rev_right in *. + induction (List.rev (fst t')); [ apply Hv | ]. + apply valid_check_step. + apply IHl. (* apply PArray.fold_left_ind; auto. *) (* intros a i _ Ha;apply PArray.fold_left_ind;trivial. *) (* intros a0 i0 _ H1;auto. *) @@ -117,37 +120,37 @@ Module Sat_Checker. Definition dimacs := PArray.array (PArray.array _lit). Definition C_interp_or rho c := - afold_left _ _ false orb (Lit.interp rho) c. + afold_left _ false orb (amap (Lit.interp rho) c). Lemma C_interp_or_spec : forall rho c, C_interp_or rho c = C.interp rho (to_list c). Proof. intros rho c; unfold C_interp_or; case_eq (C.interp rho (to_list c)). - unfold C.interp; rewrite List.existsb_exists; intros [x [H1 H2]]; destruct (In_to_list _ _ H1) as [i [H3 H4]]; subst x; apply (afold_left_orb_true _ i); auto. - unfold C.interp; intro H; apply afold_left_orb_false; intros i H1; case_eq (Lit.interp rho (c .[ i])); auto; intro Heq; assert (H2: exists x, List.In x (to_list c) /\ Lit.interp rho x = true). + unfold C.interp; rewrite List.existsb_exists; intros [x [H1 H2]]; destruct (In_to_list _ _ H1) as [i [H3 H4]]; subst x; apply (afold_left_orb_true i); rewrite ?length_amap,?get_amap;auto. + unfold C.interp; intro H; apply afold_left_orb_false; rewrite length_amap; intros i H1; rewrite get_amap; case_eq (Lit.interp rho (c .[ i])); auto; intro Heq; assert (H2: exists x, List.In x (to_list c) /\ Lit.interp rho x = true). exists (c.[i]); split; auto; apply to_list_In; auto. rewrite <- List.existsb_exists in H2; rewrite H2 in H; auto. Qed. Definition valid rho (d:dimacs) := - afold_left _ _ true andb (C_interp_or rho) d. + afold_left _ true andb (amap (C_interp_or rho) d). Lemma valid_spec : forall rho d, valid rho d <-> - (forall i : int, i < length d -> C.interp rho (PArray.to_list (d.[i]))). + (forall i : int, i < length d -> C.interp rho (to_list (d.[i]))). Proof. unfold valid; intros rho d; split; intro H. intros i Hi; case_eq (C.interp rho (to_list (d .[ i]))); try reflexivity. - intro Heq; erewrite afold_left_andb_false in H; try eassumption. + intro Heq; erewrite afold_left_andb_false in H; rewrite ?length_amap, ?get_amap; try eassumption. rewrite C_interp_or_spec; auto. - apply afold_left_andb_true; try assumption; intros i Hi; rewrite C_interp_or_spec; apply H; auto. + apply afold_left_andb_true; rewrite length_amap; intros i Hi; rewrite get_amap, C_interp_or_spec by assumption; apply H; auto. Qed. Inductive certif := | Certif : int -> _trace_ step -> clause_id -> certif. Definition add_roots s (d:dimacs) := - PArray.foldi_right (fun i c s => S.set_clause s i (PArray.to_list c)) d s. + foldi (fun i s => S.set_clause s i (to_list (d.[i]))) 0 (length d) s. Definition checker (d:dimacs) (c:certif) := let (nclauses, t, confl_id) := c in @@ -157,7 +160,8 @@ Qed. forall d s, valid rho d -> S.valid rho s -> S.valid rho (add_roots s d). Proof. - intros rho Hwr d s Hd Hs; unfold add_roots; apply (PArray.foldi_right_Ind _ _ (fun _ a => S.valid rho a)); auto; intros a i Hlt Hv; apply S.valid_set_clause; auto; rewrite valid_spec in Hd; apply Hd; auto. + intros rho Hwr d s Hd Hs; unfold add_roots. +apply (foldi_ind _ (fun _ a => S.valid rho a)); [ apply leb_0 | | ]; auto; intros i a _ Hle Hv; apply S.valid_set_clause; auto; rewrite valid_spec in Hd; apply Hd; auto. Qed. Lemma checker_correct : forall d c, @@ -230,7 +234,7 @@ Module Cnf_Checker. Proof. intros rho rhobv t_form Ht s H; destruct (Form.check_form_correct rho rhobv _ Ht) as [[Ht1 Ht2] Ht3]; intros [pos res|pos cid lf|pos|pos|pos l|pos l|pos l i|pos cid|pos cid|pos cid i]; simpl; try apply S.valid_set_clause; auto. apply S.valid_set_resolve; auto. - apply valid_check_flatten; auto; try discriminate; intros a1 a2; unfold is_true; rewrite Int63Properties.eqb_spec; intro; subst a1; auto. + apply valid_check_flatten; auto; try discriminate; intros a1 a2; unfold is_true; rewrite Int63.eqb_spec; intro; subst a1; auto. apply valid_check_True; auto. apply valid_check_False; auto. apply valid_check_BuildDef; auto. @@ -280,7 +284,7 @@ Module Cnf_Checker. checker_b t_form l b c = true -> Lit.interp (Form.interp_state_var (PArray.get t_var) (fun _ s => BITVECTOR_LIST.zeros s) t_form) l = b. Proof. - unfold checker_b; intros t_var t_form l b c; case b; case_eq (Lit.interp (Form.interp_state_var (get t_var) (fun _ s => BITVECTOR_LIST.zeros s) t_form) l); auto; intros H1 H2; elim (checker_correct H2 (rho:=get t_var) (rhobv:=fun _ s => BITVECTOR_LIST.zeros s)); auto; rewrite Lit.interp_neg, H1; auto. + unfold checker_b; intros t_var t_form l b c; case b; case_eq (Lit.interp (Form.interp_state_var (get t_var) (fun _ s => BITVECTOR_LIST.zeros s) t_form) l); auto with smtcoq_core; intros H1 H2; elim (checker_correct H2 (rho:=get t_var) (rhobv:=fun _ s => BITVECTOR_LIST.zeros s)); auto with smtcoq_core; rewrite Lit.interp_neg, H1; auto with smtcoq_core. Qed. Definition checker_eq t_form l1 l2 l (c:certif) := @@ -296,9 +300,9 @@ Module Cnf_Checker. Lit.interp (Form.interp_state_var (PArray.get t_var) (fun _ s => BITVECTOR_LIST.zeros s) t_form) l1 = Lit.interp (Form.interp_state_var (PArray.get t_var) (fun _ s => BITVECTOR_LIST.zeros s) t_form) l2. Proof. - unfold checker_eq; intros t_var t_form l1 l2 l c; rewrite !andb_true_iff; case_eq (t_form .[ Lit.blit l]); [intros _ _|intros _|intros _|intros _ _ _|intros _ _|intros _ _|intros _ _|intros _ _ _|intros l1' l2' Heq|intros _ _ _ _|intros a ls Heq]; intros [[H1 H2] H3]; try discriminate; rewrite andb_true_iff in H2; rewrite !Int63Properties.eqb_spec in H2; destruct H2 as [H2 H4]; subst l1' l2'; case_eq (Lit.is_pos l); intro Heq'; rewrite Heq' in H1; try discriminate; clear H1; assert (H:PArray.default t_form = Form.Ftrue /\ Form.wf t_form). - unfold checker in H3; destruct c as (nclauses, t, confl); rewrite andb_true_iff in H3; destruct H3 as [H3 _]; destruct (Form.check_form_correct (get t_var) (fun _ s => BITVECTOR_LIST.zeros s) _ H3) as [[Ht1 Ht2] Ht3]; split; auto. - destruct H as [H1 H2]; case_eq (Lit.interp (Form.interp_state_var (get t_var) (fun _ s => BITVECTOR_LIST.zeros s) t_form) l1); intro Heq1; case_eq (Lit.interp (Form.interp_state_var (get t_var) (fun _ s => BITVECTOR_LIST.zeros s) t_form) l2); intro Heq2; auto; elim (checker_correct H3 (rho:=get t_var) (rhobv:=fun _ s => BITVECTOR_LIST.zeros s)); unfold Lit.interp; rewrite Heq'; unfold Var.interp; rewrite Form.wf_interp_form; auto; rewrite Heq; simpl; rewrite Heq1, Heq2; auto. + unfold checker_eq; intros t_var t_form l1 l2 l c; rewrite !andb_true_iff; case_eq (t_form .[ Lit.blit l]); [intros _ _|intros _|intros _|intros _ _ _|intros _ _|intros _ _|intros _ _|intros _ _ _|intros l1' l2' Heq|intros _ _ _ _|intros a ls Heq]; intros [[H1 H2] H3]; try discriminate; rewrite andb_true_iff in H2; rewrite !Int63.eqb_spec in H2; destruct H2 as [H2 H4]; subst l1' l2'; case_eq (Lit.is_pos l); intro Heq'; rewrite Heq' in H1; try discriminate; clear H1; assert (H:PArray.default t_form = Form.Ftrue /\ Form.wf t_form). + unfold checker in H3; destruct c as (nclauses, t, confl); rewrite andb_true_iff in H3; destruct H3 as [H3 _]; destruct (Form.check_form_correct (get t_var) (fun _ s => BITVECTOR_LIST.zeros s) _ H3) as [[Ht1 Ht2] Ht3]; split; auto with smtcoq_core. + destruct H as [H1 H2]; case_eq (Lit.interp (Form.interp_state_var (get t_var) (fun _ s => BITVECTOR_LIST.zeros s) t_form) l1); intro Heq1; case_eq (Lit.interp (Form.interp_state_var (get t_var) (fun _ s => BITVECTOR_LIST.zeros s) t_form) l2); intro Heq2; auto with smtcoq_core; elim (checker_correct H3 (rho:=get t_var) (rhobv:=fun _ s => BITVECTOR_LIST.zeros s)); unfold Lit.interp; rewrite Heq'; unfold Var.interp; rewrite Form.wf_interp_form; auto with smtcoq_core; rewrite Heq; simpl; rewrite Heq1, Heq2; auto with smtcoq_core. Qed. End Cnf_Checker. @@ -433,49 +437,49 @@ Inductive step := |pos orig1 orig2 res|pos orig1 orig2 res |pos orig1 orig2 res|pos orig1 orig2 res|pos orig1 orig2 res|pos orig1 orig2 res |pos cl |pos orig res |pos orig res |pos orig res | pos orig1 orig2 res | pos orig1 orig2 res |pos res|pos res - |pos res |pos prem_id prem concl p|pos lemma plemma concl p]; simpl; try apply S.valid_set_clause; auto. - - apply S.valid_set_resolve; auto. - - apply S.valid_set_weaken; auto. - - apply valid_check_flatten; auto; intros h1 h2 H. - + rewrite (Syntactic.check_hatom_correct_bool _ _ _ Ha1 Ha2 _ _ H); auto. - + rewrite (Syntactic.check_neg_hatom_correct_bool _ _ _ H10 Ha1 Ha2 _ _ H); auto. - - apply valid_check_True; auto. - - apply valid_check_False; auto. - - apply valid_check_BuildDef; auto. - - apply valid_check_BuildDef2; auto. - - apply valid_check_BuildProj; auto. - - apply valid_check_ImmBuildDef; auto. - - apply valid_check_ImmBuildDef2; auto. - - apply valid_check_ImmBuildProj; auto. - - apply valid_check_trans; auto. - - apply valid_check_congr; auto. - - apply valid_check_congr_pred; auto. - - apply valid_check_micromega; auto. - - apply valid_check_diseq; auto. - - apply valid_check_spl_arith; auto. - - apply valid_check_distinct_elim; auto. - - eapply valid_check_bbVar; eauto. - - apply valid_check_bbConst; auto. - - apply valid_check_bbOp; auto. - - apply valid_check_bbNot; auto. - - apply valid_check_bbNeg; auto. - - apply valid_check_bbAdd; auto. - - apply valid_check_bbConcat; auto. - - apply valid_check_bbMult; auto. - - apply valid_check_bbUlt; auto. - - apply valid_check_bbSlt; auto. - - apply valid_check_bbEq; auto. - - apply valid_check_bbDiseq; auto. - - apply valid_check_bbExtract; auto. - - apply valid_check_bbZextend; auto. - - apply valid_check_bbSextend; auto. - - apply valid_check_bbShl; auto. - - apply valid_check_bbShr; auto. - - apply valid_check_roweq; auto. - - apply valid_check_rowneq; auto. - - apply valid_check_ext; auto. - - apply valid_check_hole; auto. - - apply valid_check_forall_inst with lemma; auto. + |pos res |pos prem_id prem concl p|pos lemma plemma concl p]; simpl; try apply S.valid_set_clause; auto with smtcoq_core. + - apply S.valid_set_resolve; auto with smtcoq_core. + - apply S.valid_set_weaken; auto with smtcoq_core. + - apply valid_check_flatten; auto with smtcoq_core; intros h1 h2 H. + + rewrite (Syntactic.check_hatom_correct_bool _ _ _ Ha1 Ha2 _ _ H); auto with smtcoq_core. + + rewrite (Syntactic.check_neg_hatom_correct_bool _ _ _ H10 Ha1 Ha2 _ _ H); auto with smtcoq_core. + - apply valid_check_True; auto with smtcoq_core. + - apply valid_check_False; auto with smtcoq_core. + - apply valid_check_BuildDef; auto with smtcoq_core. + - apply valid_check_BuildDef2; auto with smtcoq_core. + - apply valid_check_BuildProj; auto with smtcoq_core. + - apply valid_check_ImmBuildDef; auto with smtcoq_core. + - apply valid_check_ImmBuildDef2; auto with smtcoq_core. + - apply valid_check_ImmBuildProj; auto with smtcoq_core. + - apply valid_check_trans; auto with smtcoq_core. + - apply valid_check_congr; auto with smtcoq_core. + - apply valid_check_congr_pred; auto with smtcoq_core. + - apply valid_check_micromega; auto with smtcoq_core. + - apply valid_check_diseq; auto with smtcoq_core. + - apply valid_check_spl_arith; auto with smtcoq_core. + - apply valid_check_distinct_elim; auto with smtcoq_core. + - eapply valid_check_bbVar; eauto with smtcoq_core. + - apply valid_check_bbConst; auto with smtcoq_core. + - apply valid_check_bbOp; auto with smtcoq_core. + - apply valid_check_bbNot; auto with smtcoq_core. + - apply valid_check_bbNeg; auto with smtcoq_core. + - apply valid_check_bbAdd; auto with smtcoq_core. + - apply valid_check_bbConcat; auto with smtcoq_core. + - apply valid_check_bbMult; auto with smtcoq_core. + - apply valid_check_bbUlt; auto with smtcoq_core. + - apply valid_check_bbSlt; auto with smtcoq_core. + - apply valid_check_bbEq; auto with smtcoq_core. + - apply valid_check_bbDiseq; auto with smtcoq_core. + - apply valid_check_bbExtract; auto with smtcoq_core. + - apply valid_check_bbZextend; auto with smtcoq_core. + - apply valid_check_bbSextend; auto with smtcoq_core. + - apply valid_check_bbShl; auto with smtcoq_core. + - apply valid_check_bbShr; auto with smtcoq_core. + - apply valid_check_roweq; auto with smtcoq_core. + - apply valid_check_rowneq; auto with smtcoq_core. + - apply valid_check_ext; auto with smtcoq_core. + - apply valid_check_hole; auto with smtcoq_core. + - apply valid_check_forall_inst with lemma; auto with smtcoq_core. Qed. Definition euf_checker (* t_atom t_form *) s t := @@ -490,8 +494,8 @@ Inductive step := ~ (S.valid rho s). Proof. unfold euf_checker; intros (* t_i t_func t_atom t_form *) rho H1 H2 H10; apply _checker__correct. - intros c H; apply C.is_false_correct; auto. - apply step_checker_correct; auto. + intros c H; apply C.is_false_correct; auto with smtcoq_core. + apply step_checker_correct; auto with smtcoq_core. Qed. Inductive certif := @@ -499,15 +503,15 @@ Inductive step := Definition add_roots s d used_roots := match used_roots with - | Some ur => PArray.foldi_right (fun i c_index s => - let c := if c_index < length d then (d.[c_index])::nil else C._true in - S.set_clause s i c) ur s - | None => PArray.foldi_right (fun i c s => S.set_clause s i (c::nil)) d s + | Some ur => foldi (fun i s => + let c := if (ur.[i]) < length d then (d.[ur.[i]])::nil else C._true in + S.set_clause s i c) 0 (length ur) s + | None => foldi (fun i s => S.set_clause s i (d.[i]::nil)) 0 (length d) s end. Definition valid t_i t_func t_atom t_form d := let rho := Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) t_form in - afold_left _ _ true andb (Lit.interp rho) d. + afold_left _ true andb (amap (Lit.interp rho) d). Lemma add_roots_correct : (* forall t_i t_func t_atom t_form, *) let rho := Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) t_form in @@ -516,11 +520,11 @@ Inductive step := forall s d used_roots, S.valid rho s -> valid t_func t_atom t_form d -> S.valid rho (add_roots s d used_roots). Proof. - intros (* t_i t_func t_atom t_form *) rho H1 H2 H10 s d used_roots H3; unfold valid; intro H4; pose (H5 := (afold_left_andb_true_inv _ _ _ H4)); unfold add_roots; assert (Valuation.wf rho) by (destruct (Form.check_form_correct (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) _ H1) as [_ H]; auto); case used_roots. - intro ur; apply (foldi_right_Ind _ _ (fun _ a => S.valid rho a)); auto; intros a i H6 Ha; apply S.valid_set_clause; auto; case_eq (ur .[ i] < length d). - intro; unfold C.valid; simpl; rewrite H5; auto. - intros; apply C.interp_true; auto. - apply (foldi_right_Ind _ _ (fun _ a => S.valid rho a)); auto; intros a i H6 Ha; apply S.valid_set_clause; auto; unfold C.valid; simpl; rewrite H5; auto. + intros (* t_i t_func t_atom t_form *) rho H1 H2 H10 s d used_roots H3; unfold valid; intro H4; pose (H5 := (afold_left_andb_true_inv _ H4)); unfold add_roots; assert (Valuation.wf rho) by (destruct (Form.check_form_correct (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) _ H1) as [_ H]; auto with smtcoq_core); case used_roots. + intro ur; apply (foldi_ind _ (fun _ a => S.valid rho a)); [ apply leb_0 | | ]; auto with smtcoq_core; intros i a _ H6 Ha; apply S.valid_set_clause; auto with smtcoq_core; case_eq (ur .[ i] < length d). + intro; unfold C.valid; simpl; specialize (H5 (ur.[i])); rewrite length_amap, get_amap in H5 by assumption; unfold rho; rewrite H5; auto with smtcoq_core. + intros; apply C.interp_true; auto with smtcoq_core. + apply (foldi_ind _ (fun _ a => S.valid rho a)); [ apply leb_0 | | ]; auto with smtcoq_core; intros i a _ H6 Ha; apply S.valid_set_clause; auto with smtcoq_core; unfold C.valid; simpl; specialize (H5 i); rewrite length_amap, get_amap in H5 by assumption; unfold rho; rewrite H5; auto with smtcoq_core. Qed. Definition checker (* t_i t_func t_atom t_form *) d used_roots (c:certif) := @@ -534,7 +538,7 @@ Inductive step := Definition setup_checker_step_debug d used_roots (c:certif) := let (nclauses, t, confl) := c in let s := add_roots (S.make nclauses) d used_roots in - (s, Structures.trace_to_list t). + (s, fst t). Definition position_of_step (st:step) := @@ -686,7 +690,7 @@ Inductive step := let (nclauses, t, confl) := c in let s := add_roots (S.make nclauses) d used_roots in let '(_, nb, failure) := - Structures.trace_fold + List.fold_left (fun acc step => match acc with | (s, nb, None) => @@ -698,7 +702,7 @@ Inductive step := else (s, nb, None) | _ => acc end - ) (s, O, None) t + ) (fst t) (s, O, None) in match failure with | Some st => Some (nb, name_of_step st) @@ -711,7 +715,7 @@ Inductive step := checker (* t_i t_func t_atom t_form *) d used_roots c = true -> ~ (valid t_func t_atom t_form d). Proof. - unfold checker; intros (* t_i t_func t_atom t_form *) d used_roots (nclauses, t, confl); rewrite !andb_true_iff; intros [[[H1 H2] H10] H3] H; eelim euf_checker_correct; try eassumption; apply add_roots_correct; try eassumption; apply S.valid_make; destruct (Form.check_form_correct (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) _ H1) as [_ H4]; auto. + unfold checker; intros (* t_i t_func t_atom t_form *) d used_roots (nclauses, t, confl); rewrite !andb_true_iff; intros [[[H1 H2] H10] H3] H; eelim euf_checker_correct; try eassumption; apply add_roots_correct; try eassumption; apply S.valid_make; destruct (Form.check_form_correct (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) _ H1) as [_ H4]; auto with smtcoq_core. Qed. Definition checker_b (* t_i t_func t_atom t_form *) l (b:bool) (c:certif) := @@ -723,7 +727,7 @@ Inductive step := checker_b (* t_func t_atom t_form *) l b c = true -> Lit.interp (Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) t_form) l = b. Proof. - unfold checker_b; intros (* t_i t_func t_atom t_form *) l b (nclauses, t, confl); case b; intros H2; case_eq (Lit.interp (Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) t_form) l); auto; intros H1; elim (checker_correct H2); auto; unfold valid; apply afold_left_andb_true; intros i Hi; rewrite get_make; auto; rewrite Lit.interp_neg, H1; auto. + unfold checker_b; intros (* t_i t_func t_atom t_form *) l b (nclauses, t, confl); case b; intros H2; case_eq (Lit.interp (Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) t_form) l); auto with smtcoq_core; intros H1; elim (checker_correct H2); auto with smtcoq_core; unfold valid; apply afold_left_andb_true; rewrite length_amap; intros i Hi; rewrite get_amap by assumption; rewrite get_make; auto with smtcoq_core; rewrite Lit.interp_neg, H1; auto with smtcoq_core. Qed. Definition checker_eq (* t_i t_func t_atom t_form *) l1 l2 l (c:certif) := @@ -740,9 +744,9 @@ Inductive step := Lit.interp (Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) t_form) l1 = Lit.interp (Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) t_form) l2. Proof. - unfold checker_eq; intros (* t_i t_func t_atom t_form *) l1 l2 l (nclauses, t, confl); rewrite !andb_true_iff; case_eq (t_form .[ Lit.blit l]); [intros _ _|intros _|intros _|intros _ _ _|intros _ _|intros _ _|intros _ _|intros _ _ _|intros l1' l2' Heq|intros _ _ _ _|intros a ls Heq]; intros [[H1 H2] H3]; try discriminate; rewrite andb_true_iff in H2; rewrite !Int63Properties.eqb_spec in H2; destruct H2 as [H2 H4]; subst l1' l2'; case_eq (Lit.is_pos l); intro Heq'; rewrite Heq' in H1; try discriminate; clear H1; assert (H:PArray.default t_form = Form.Ftrue /\ Form.wf t_form). - unfold checker in H3; rewrite !andb_true_iff in H3; destruct H3 as [[[H3 _] _] _]; destruct (Form.check_form_correct (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) _ H3) as [[Ht1 Ht2] Ht3]; split; auto. - destruct H as [H1 H2]; case_eq (Lit.interp (Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) t_form) l1); intro Heq1; case_eq (Lit.interp (Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) t_form) l2); intro Heq2; auto; elim (checker_correct H3); unfold valid; apply afold_left_andb_true; intros i Hi; rewrite get_make; unfold Lit.interp; rewrite Heq'; unfold Var.interp; rewrite Form.wf_interp_form; auto; rewrite Heq; simpl; rewrite Heq1, Heq2; auto. + unfold checker_eq; intros (* t_i t_func t_atom t_form *) l1 l2 l (nclauses, t, confl); rewrite !andb_true_iff; case_eq (t_form .[ Lit.blit l]); [intros _ _|intros _|intros _|intros _ _ _|intros _ _|intros _ _|intros _ _|intros _ _ _|intros l1' l2' Heq|intros _ _ _ _|intros a ls Heq]; intros [[H1 H2] H3]; try discriminate; rewrite andb_true_iff in H2; rewrite !Int63.eqb_spec in H2; destruct H2 as [H2 H4]; subst l1' l2'; case_eq (Lit.is_pos l); intro Heq'; rewrite Heq' in H1; try discriminate; clear H1; assert (H:PArray.default t_form = Form.Ftrue /\ Form.wf t_form). + unfold checker in H3; rewrite !andb_true_iff in H3; destruct H3 as [[[H3 _] _] _]; destruct (Form.check_form_correct (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) _ H3) as [[Ht1 Ht2] Ht3]; split; auto with smtcoq_core. + destruct H as [H1 H2]; case_eq (Lit.interp (Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) t_form) l1); intro Heq1; case_eq (Lit.interp (Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) t_form) l2); intro Heq2; auto with smtcoq_core; elim (checker_correct H3); unfold valid; apply afold_left_andb_true; rewrite length_amap; intros i Hi; rewrite get_amap by assumption; rewrite get_make; unfold Lit.interp; rewrite Heq'; unfold Var.interp; rewrite Form.wf_interp_form; auto with smtcoq_core; rewrite Heq; simpl; rewrite Heq1, Heq2; auto with smtcoq_core. Qed. @@ -762,7 +766,7 @@ Inductive step := forall t_i t_func, Atom.wt t_i t_func t_atom -> ~ valid t_func t_atom t_form d. Proof. - unfold checker_ext; intros t_atom t_form d used_roots (nclauses, t, confl); rewrite !andb_true_iff; intros [[H1 H2] H3]; intros t_i t_func H10 H; eelim euf_checker_correct; try eassumption; apply add_roots_correct; try eassumption; apply S.valid_make; destruct (Form.check_form_correct (Atom.interp_form_hatom t_i t_func t_atom) _ H1) as [_ H4]; auto. + unfold checker_ext; intros t_atom t_form d used_roots (nclauses, t, confl); rewrite !andb_true_iff; intros [[H1 H2] H3]; intros t_i t_func H10 H; eelim euf_checker_correct; try eassumption; apply add_roots_correct; try eassumption; apply S.valid_make; destruct (Form.check_form_correct (Atom.interp_form_hatom t_i t_func t_atom) _ H1) as [_ H4]; auto with smtcoq_core. Qed. *) @@ -774,6 +778,127 @@ End Euf_Checker. Unset Implicit Arguments. +(* Register constants for OCaml access *) +Register Sat_Checker.valid as SMTCoq.Trace.Sat_Checker.valid. +Register Sat_Checker.interp_var as SMTCoq.Trace.Sat_Checker.interp_var. +Register Sat_Checker.Certif as SMTCoq.Trace.Sat_Checker.Certif. +Register Sat_Checker.step as SMTCoq.Trace.Sat_Checker.step. +Register Sat_Checker.Res as SMTCoq.Trace.Sat_Checker.Res. +Register Sat_Checker.dimacs as SMTCoq.Trace.Sat_Checker.dimacs. +Register Sat_Checker.certif as SMTCoq.Trace.Sat_Checker.certif. +Register Sat_Checker.theorem_checker as SMTCoq.Trace.Sat_Checker.theorem_checker. +Register Sat_Checker.checker as SMTCoq.Trace.Sat_Checker.checker. + +Register Cnf_Checker.certif as SMTCoq.Trace.Cnf_Checker.certif. +Register Cnf_Checker.Certif as SMTCoq.Trace.Cnf_Checker.Certif. +Register Cnf_Checker.checker_b_correct as SMTCoq.Trace.Cnf_Checker.checker_b_correct. +Register Cnf_Checker.checker_b as SMTCoq.Trace.Cnf_Checker.checker_b. +Register Cnf_Checker.checker_eq_correct as SMTCoq.Trace.Cnf_Checker.checker_eq_correct. +Register Cnf_Checker.checker_eq as SMTCoq.Trace.Cnf_Checker.checker_eq. +Register Cnf_Checker.step as SMTCoq.Trace.Cnf_Checker.step. +Register Cnf_Checker.Res as SMTCoq.Trace.Cnf_Checker.Res. +Register Cnf_Checker.ImmFlatten as SMTCoq.Trace.Cnf_Checker.ImmFlatten. +Register Cnf_Checker.CTrue as SMTCoq.Trace.Cnf_Checker.CTrue. +Register Cnf_Checker.CFalse as SMTCoq.Trace.Cnf_Checker.CFalse. +Register Cnf_Checker.BuildDef as SMTCoq.Trace.Cnf_Checker.BuildDef. +Register Cnf_Checker.BuildDef2 as SMTCoq.Trace.Cnf_Checker.BuildDef2. +Register Cnf_Checker.BuildProj as SMTCoq.Trace.Cnf_Checker.BuildProj. +Register Cnf_Checker.ImmBuildDef as SMTCoq.Trace.Cnf_Checker.ImmBuildDef. +Register Cnf_Checker.ImmBuildDef2 as SMTCoq.Trace.Cnf_Checker.ImmBuildDef2. +Register Cnf_Checker.ImmBuildProj as SMTCoq.Trace.Cnf_Checker.ImmBuildProj. + +Register Euf_Checker.Certif as SMTCoq.Trace.Euf_Checker.Certif. +Register Euf_Checker.certif as SMTCoq.Trace.Euf_Checker.certif. +Register Euf_Checker.checker as SMTCoq.Trace.Euf_Checker.checker. +Register Euf_Checker.checker_correct as SMTCoq.Trace.Euf_Checker.checker_correct. +Register Euf_Checker.checker_b_correct as SMTCoq.Trace.Euf_Checker.checker_b_correct. +Register Euf_Checker.checker_b as SMTCoq.Trace.Euf_Checker.checker_b. +Register Euf_Checker.checker_eq_correct as SMTCoq.Trace.Euf_Checker.checker_eq_correct. +Register Euf_Checker.checker_eq as SMTCoq.Trace.Euf_Checker.checker_eq. +Register Euf_Checker.checker_debug as SMTCoq.Trace.Euf_Checker.checker_debug. +Register Euf_Checker.name_step as SMTCoq.Trace.Euf_Checker.name_step. +Register Euf_Checker.Name_Res as SMTCoq.Trace.Euf_Checker.Name_Res. +Register Euf_Checker.Name_Weaken as SMTCoq.Trace.Euf_Checker.Name_Weaken. +Register Euf_Checker.Name_ImmFlatten as SMTCoq.Trace.Euf_Checker.Name_ImmFlatten. +Register Euf_Checker.Name_CTrue as SMTCoq.Trace.Euf_Checker.Name_CTrue. +Register Euf_Checker.Name_CFalse as SMTCoq.Trace.Euf_Checker.Name_CFalse. +Register Euf_Checker.Name_BuildDef as SMTCoq.Trace.Euf_Checker.Name_BuildDef. +Register Euf_Checker.Name_BuildDef2 as SMTCoq.Trace.Euf_Checker.Name_BuildDef2. +Register Euf_Checker.Name_BuildProj as SMTCoq.Trace.Euf_Checker.Name_BuildProj. +Register Euf_Checker.Name_ImmBuildDef as SMTCoq.Trace.Euf_Checker.Name_ImmBuildDef. +Register Euf_Checker.Name_ImmBuildDef2 as SMTCoq.Trace.Euf_Checker.Name_ImmBuildDef2. +Register Euf_Checker.Name_ImmBuildProj as SMTCoq.Trace.Euf_Checker.Name_ImmBuildProj. +Register Euf_Checker.Name_EqTr as SMTCoq.Trace.Euf_Checker.Name_EqTr. +Register Euf_Checker.Name_EqCgr as SMTCoq.Trace.Euf_Checker.Name_EqCgr. +Register Euf_Checker.Name_EqCgrP as SMTCoq.Trace.Euf_Checker.Name_EqCgrP. +Register Euf_Checker.Name_LiaMicromega as SMTCoq.Trace.Euf_Checker.Name_LiaMicromega. +Register Euf_Checker.Name_LiaDiseq as SMTCoq.Trace.Euf_Checker.Name_LiaDiseq. +Register Euf_Checker.Name_SplArith as SMTCoq.Trace.Euf_Checker.Name_SplArith. +Register Euf_Checker.Name_SplDistinctElim as SMTCoq.Trace.Euf_Checker.Name_SplDistinctElim. +Register Euf_Checker.Name_BBVar as SMTCoq.Trace.Euf_Checker.Name_BBVar. +Register Euf_Checker.Name_BBConst as SMTCoq.Trace.Euf_Checker.Name_BBConst. +Register Euf_Checker.Name_BBOp as SMTCoq.Trace.Euf_Checker.Name_BBOp. +Register Euf_Checker.Name_BBNot as SMTCoq.Trace.Euf_Checker.Name_BBNot. +Register Euf_Checker.Name_BBNeg as SMTCoq.Trace.Euf_Checker.Name_BBNeg. +Register Euf_Checker.Name_BBAdd as SMTCoq.Trace.Euf_Checker.Name_BBAdd. +Register Euf_Checker.Name_BBConcat as SMTCoq.Trace.Euf_Checker.Name_BBConcat. +Register Euf_Checker.Name_BBMul as SMTCoq.Trace.Euf_Checker.Name_BBMul. +Register Euf_Checker.Name_BBUlt as SMTCoq.Trace.Euf_Checker.Name_BBUlt. +Register Euf_Checker.Name_BBSlt as SMTCoq.Trace.Euf_Checker.Name_BBSlt. +Register Euf_Checker.Name_BBEq as SMTCoq.Trace.Euf_Checker.Name_BBEq. +Register Euf_Checker.Name_BBDiseq as SMTCoq.Trace.Euf_Checker.Name_BBDiseq. +Register Euf_Checker.Name_BBExtract as SMTCoq.Trace.Euf_Checker.Name_BBExtract. +Register Euf_Checker.Name_BBZextend as SMTCoq.Trace.Euf_Checker.Name_BBZextend. +Register Euf_Checker.Name_BBSextend as SMTCoq.Trace.Euf_Checker.Name_BBSextend. +Register Euf_Checker.Name_BBShl as SMTCoq.Trace.Euf_Checker.Name_BBShl. +Register Euf_Checker.Name_BBShr as SMTCoq.Trace.Euf_Checker.Name_BBShr. +Register Euf_Checker.Name_RowEq as SMTCoq.Trace.Euf_Checker.Name_RowEq. +Register Euf_Checker.Name_RowNeq as SMTCoq.Trace.Euf_Checker.Name_RowNeq. +Register Euf_Checker.Name_Ext as SMTCoq.Trace.Euf_Checker.Name_Ext. +Register Euf_Checker.Name_Hole as SMTCoq.Trace.Euf_Checker.Name_Hole. +Register Euf_Checker.step as SMTCoq.Trace.Euf_Checker.step. +Register Euf_Checker.Res as SMTCoq.Trace.Euf_Checker.Res. +Register Euf_Checker.Weaken as SMTCoq.Trace.Euf_Checker.Weaken. +Register Euf_Checker.ImmFlatten as SMTCoq.Trace.Euf_Checker.ImmFlatten. +Register Euf_Checker.CTrue as SMTCoq.Trace.Euf_Checker.CTrue. +Register Euf_Checker.CFalse as SMTCoq.Trace.Euf_Checker.CFalse. +Register Euf_Checker.BuildDef as SMTCoq.Trace.Euf_Checker.BuildDef. +Register Euf_Checker.BuildDef2 as SMTCoq.Trace.Euf_Checker.BuildDef2. +Register Euf_Checker.BuildProj as SMTCoq.Trace.Euf_Checker.BuildProj. +Register Euf_Checker.ImmBuildProj as SMTCoq.Trace.Euf_Checker.ImmBuildProj. +Register Euf_Checker.ImmBuildDef as SMTCoq.Trace.Euf_Checker.ImmBuildDef. +Register Euf_Checker.ImmBuildDef2 as SMTCoq.Trace.Euf_Checker.ImmBuildDef2. +Register Euf_Checker.EqTr as SMTCoq.Trace.Euf_Checker.EqTr. +Register Euf_Checker.EqCgr as SMTCoq.Trace.Euf_Checker.EqCgr. +Register Euf_Checker.EqCgrP as SMTCoq.Trace.Euf_Checker.EqCgrP. +Register Euf_Checker.LiaMicromega as SMTCoq.Trace.Euf_Checker.LiaMicromega. +Register Euf_Checker.LiaDiseq as SMTCoq.Trace.Euf_Checker.LiaDiseq. +Register Euf_Checker.SplArith as SMTCoq.Trace.Euf_Checker.SplArith. +Register Euf_Checker.SplDistinctElim as SMTCoq.Trace.Euf_Checker.SplDistinctElim. +Register Euf_Checker.BBVar as SMTCoq.Trace.Euf_Checker.BBVar. +Register Euf_Checker.BBConst as SMTCoq.Trace.Euf_Checker.BBConst. +Register Euf_Checker.BBOp as SMTCoq.Trace.Euf_Checker.BBOp. +Register Euf_Checker.BBNot as SMTCoq.Trace.Euf_Checker.BBNot. +Register Euf_Checker.BBEq as SMTCoq.Trace.Euf_Checker.BBEq. +Register Euf_Checker.BBDiseq as SMTCoq.Trace.Euf_Checker.BBDiseq. +Register Euf_Checker.BBNeg as SMTCoq.Trace.Euf_Checker.BBNeg. +Register Euf_Checker.BBAdd as SMTCoq.Trace.Euf_Checker.BBAdd. +Register Euf_Checker.BBMul as SMTCoq.Trace.Euf_Checker.BBMul. +Register Euf_Checker.BBUlt as SMTCoq.Trace.Euf_Checker.BBUlt. +Register Euf_Checker.BBSlt as SMTCoq.Trace.Euf_Checker.BBSlt. +Register Euf_Checker.BBConcat as SMTCoq.Trace.Euf_Checker.BBConcat. +Register Euf_Checker.BBExtract as SMTCoq.Trace.Euf_Checker.BBExtract. +Register Euf_Checker.BBZextend as SMTCoq.Trace.Euf_Checker.BBZextend. +Register Euf_Checker.BBSextend as SMTCoq.Trace.Euf_Checker.BBSextend. +Register Euf_Checker.BBShl as SMTCoq.Trace.Euf_Checker.BBShl. +Register Euf_Checker.BBShr as SMTCoq.Trace.Euf_Checker.BBShr. +Register Euf_Checker.RowEq as SMTCoq.Trace.Euf_Checker.RowEq. +Register Euf_Checker.RowNeq as SMTCoq.Trace.Euf_Checker.RowNeq. +Register Euf_Checker.Ext as SMTCoq.Trace.Euf_Checker.Ext. +Register Euf_Checker.Hole as SMTCoq.Trace.Euf_Checker.Hole. +Register Euf_Checker.ForallInst as SMTCoq.Trace.Euf_Checker.ForallInst. + + (* Local Variables: coq-load-path: ((rec "." "SMTCoq")) diff --git a/src/versions/standard/_CoqProject b/src/_CoqProject index 86dd443..2a883c8 100644 --- a/src/versions/standard/_CoqProject +++ b/src/_CoqProject @@ -26,24 +26,10 @@ -I trace -I verit -I zchaff --I versions/standard --I versions/standard/Int63 --I versions/standard/Array +-I PArray -I ../3rdparty/alt-ergo -versions/standard/Int63/Int63.v -versions/standard/Int63/Int63Native.v -versions/standard/Int63/Int63Op.v -versions/standard/Int63/Int63Axioms.v -versions/standard/Int63/Int63Properties.v -versions/standard/Array/PArray.v - -versions/standard/mutils_full.ml -versions/standard/mutils_full.mli -versions/standard/coq_micromega_full.ml -versions/standard/Structures.v -versions/standard/structures.ml -versions/standard/structures.mli +PArray/PArray.v bva/BVList.v bva/Bva_checker.v @@ -76,6 +62,8 @@ trace/smtMisc.ml trace/smtMisc.mli trace/smtTrace.ml trace/smtTrace.mli +trace/coqInterface.ml +trace/coqInterface.mli ../3rdparty/alt-ergo/smtlib2_parse.ml ../3rdparty/alt-ergo/smtlib2_parse.mli @@ -155,5 +143,5 @@ SMT_terms.v State.v Trace.v -g_smtcoq.ml4 +g_smtcoq.mlg smtcoq_plugin.mlpack diff --git a/src/array/Array_checker.v b/src/array/Array_checker.v index d7f196c..3e403b3 100644 --- a/src/array/Array_checker.v +++ b/src/array/Array_checker.v @@ -10,7 +10,7 @@ (**************************************************************************) -Require Import Bool List Int63 PArray Psatz. +Require Import Bool List Int63 PArray Psatz ZArith. Require Import Misc State SMT_terms FArray SMT_classes. Import Form. @@ -193,7 +193,7 @@ Section certif. rho x = Form.interp interp_form_hatom interp_form_hatom_bv t_form (t_form.[ x]). Proof. intros x;apply wf_interp_form;trivial. Qed. - Definition wf := PArray.forallbi lt_form t_form. + Definition wf := aforallbi lt_form t_form. Hypothesis wf_t_i : wf. Notation atom := int (only parsing). @@ -226,14 +226,14 @@ Section certif. apply Typ.eqb_spec in Heq6a. apply Typ.eqb_spec in Heq6b. apply Typ.eqb_spec in Heq6c. - apply Int63Properties.eqb_spec in Heq6d. - apply Int63Properties.eqb_spec in Heq6e. + apply Int63.eqb_spec in Heq6d. + apply Int63.eqb_spec in Heq6e. pose proof (rho_interp (Lit.blit lres)) as Hrho. rewrite Heq2 in Hrho. simpl in Hrho. generalize wt_t_atom. unfold Atom.wt. unfold is_true. - rewrite PArray.forallbi_spec;intros. + rewrite aforallbi_spec;intros. pose proof (H a). assert (a < PArray.length t_atom). apply PArray.get_not_default_lt. rewrite def_t_atom. rewrite Heq3. easy. @@ -440,7 +440,7 @@ Section certif. subst t1 t2 t3 t4. generalize wt_t_atom. unfold Atom.wt. unfold is_true. - rewrite PArray.forallbi_spec;intros. + rewrite aforallbi_spec;intros. assert (H15: b1 < PArray.length t_atom). apply PArray.get_not_default_lt. rewrite def_t_atom. rewrite Heq7. discriminate. @@ -629,9 +629,9 @@ Section certif. apply Typ.eqb_spec in Heq11a. apply Typ.eqb_spec in Heq11b. - apply Int63Properties.eqb_spec in Heq11c. + apply Int63.eqb_spec in Heq11c. rewrite !andb_true_iff in Heq11d. - rewrite !Int63Properties.eqb_spec in Heq11d. + rewrite !Int63.eqb_spec in Heq11d. rewrite !Atom.t_interp_wf in isif; trivial. @@ -785,9 +785,9 @@ Section certif. apply Typ.eqb_spec in Heq11a. apply Typ.eqb_spec in Heq11b. - apply Int63Properties.eqb_spec in Heq11d. + apply Int63.eqb_spec in Heq11d. rewrite !andb_true_iff in Heq11c. - rewrite !Int63Properties.eqb_spec in Heq11c. + rewrite !Int63.eqb_spec in Heq11c. rewrite !Atom.t_interp_wf in isif; trivial. @@ -955,26 +955,22 @@ Section certif. apply Typ.eqb_spec in Heq15. apply Typ.eqb_spec in Heq15a. subst t3 t5 t4 t6 t7 t8. - rewrite !Int63Properties.eqb_spec in Heq1314. + rewrite !Int63.eqb_spec in Heq1314. unfold Lit.interp. rewrite Heq. unfold Var.interp. rewrite !wf_interp_form; trivial. rewrite Heq2. simpl. rewrite afold_left_or. unfold to_list. - rewrite Int63Properties.eqb_spec in Heq3. + rewrite Int63.eqb_spec in Heq3. rewrite Heq3. - (* for native-coq compatibility *) - assert (0 == 2 = false) as NCC. - { auto. } rewrite NCC. (* simpl. *) - rewrite foldi_down_gt; auto. + rewrite foldi_lt_r by reflexivity. + rewrite foldi_lt_r by reflexivity. + rewrite foldi_ge by reflexivity. + change (2 - 1) with 1; change (2 - 1 - 1) with 0. - (* simpl. *) - assert (2 - 1 = 1). { auto. } - rewrite H. - rewrite foldi_down_eq; auto. simpl. rewrite orb_false_r. assert (1 - 1 = 0) as Has2. { auto. } rewrite Has2. @@ -985,8 +981,8 @@ Section certif. pose proof (rho_interp (Lit.blit (a .[ 0]))). pose proof (rho_interp (Lit.blit (a .[ 1]))). - rewrite Heq5 in H0. rewrite Heq6 in H1. - simpl in H0, H1. + rewrite Heq5 in H. rewrite Heq6 in H0. + simpl in H, H0. unfold Lit.interp. rewrite andb_true_iff in Heq4. destruct Heq4 as (Heq4, Heq4a). @@ -994,32 +990,32 @@ Section certif. unfold Lit.interp in Hisa. rewrite Heq4 in Hisa. unfold Var.interp in Hisa. - rewrite Hisa in H0. symmetry in H0. + rewrite Hisa in H. symmetry in H. rewrite Heq4a. unfold Var.interp. - rewrite H1. + rewrite H0. generalize wt_t_atom. unfold Atom.wt. unfold is_true. - rewrite PArray.forallbi_spec;intros. + rewrite aforallbi_spec;intros. (* b *) - pose proof (H2 b). assert (b < PArray.length t_atom). + pose proof (H1 b). assert (b < PArray.length t_atom). apply PArray.get_not_default_lt. rewrite def_t_atom. rewrite Heq7. easy. - specialize (H3 H4). simpl in H3. - rewrite Heq7 in H3. simpl in H3. - rewrite !andb_true_iff in H3. destruct H3. destruct H3. - unfold get_type' in H3, H5, H6. unfold v_type in H3, H5, H6. + specialize (H2 H3). simpl in H2. + rewrite Heq7 in H2. simpl in H2. + rewrite !andb_true_iff in H2. destruct H2. destruct H2. + unfold get_type' in H2, H4, H5. unfold v_type in H2, H4, H5. case_eq (t_interp .[ b]). - intros v_typeb v_valb Htib. rewrite Htib in H3. + intros v_typeb v_valb Htib. rewrite Htib in H2. pose proof Htib as Htib''. - case_eq v_typeb; intros; rewrite H7 in H3; try now contradict H3. + case_eq v_typeb; intros; rewrite H6 in H2; try now contradict H2. case_eq (t_interp .[ b1]). - intros v_typeb1 v_valb1 Htib1. rewrite Htib1 in H6. + intros v_typeb1 v_valb1 Htib1. rewrite Htib1 in H5. pose proof Htib1 as Htib1''. case_eq (t_interp .[ b2]). - intros v_typeb2 v_valb2 Htib2. rewrite Htib2 in H5. + intros v_typeb2 v_valb2 Htib2. rewrite Htib2 in H4. pose proof Htib2 as Htib2''. rewrite Atom.t_interp_wf in Htib; trivial. rewrite Atom.t_interp_wf in Htib1; trivial. @@ -1028,33 +1024,33 @@ Section certif. rewrite !Atom.t_interp_wf in Htib; trivial. rewrite Htib1, Htib2 in Htib. unfold apply_binop in Htib. + apply Typ.eqb_spec in H4. apply Typ.eqb_spec in H5. - apply Typ.eqb_spec in H6. generalize dependent v_valb1. generalize dependent v_valb2. generalize dependent v_valb. - rewrite H5, H6, H7. rewrite !Typ.cast_refl. intros. + rewrite H4, H5, H6. rewrite !Typ.cast_refl. intros. specialize (Atom.Bval_inj2 t_i (Typ.Tbool) (Typ.i_eqb t_i t v_valb1 v_valb2) (v_valb)). - intros. specialize (H8 Htib). + intros. specialize (H7 Htib). (* c *) - pose proof (H2 c). assert (c < PArray.length t_atom). + pose proof (H1 c). assert (c < PArray.length t_atom). apply PArray.get_not_default_lt. rewrite def_t_atom. rewrite Heq9. easy. - specialize (H9 H10). simpl in H9. - rewrite Heq9 in H9. simpl in H9. - rewrite !andb_true_iff in H9. destruct H9. destruct H9. - unfold get_type' in H9, H11, H12. unfold v_type in H9, H11, H12. + specialize (H8 H9). simpl in H8. + rewrite Heq9 in H8. simpl in H8. + rewrite !andb_true_iff in H8. destruct H8. destruct H8. + unfold get_type' in H8, H10, H11. unfold v_type in H8, H10, H11. case_eq (t_interp .[ c]). - intros v_typec v_valc Htic. rewrite Htic in H9. + intros v_typec v_valc Htic. rewrite Htic in H8. pose proof Htic as Htic''. - case_eq v_typec; intros; rewrite H13 in H9; try now contradict H9. + case_eq v_typec; intros; rewrite H12 in H8; try now contradict H8. case_eq (t_interp .[ c1]). - intros v_typec1 v_valc1 Htic1. rewrite Htic1 in H12. + intros v_typec1 v_valc1 Htic1. rewrite Htic1 in H11. case_eq (t_interp .[ c2]). - intros v_typec2 v_valc2 Htic2. rewrite Htic2 in H11. + intros v_typec2 v_valc2 Htic2. rewrite Htic2 in H10. rewrite Atom.t_interp_wf in Htic; trivial. rewrite Atom.t_interp_wf in Htic1; trivial. rewrite Atom.t_interp_wf in Htic2; trivial. @@ -1062,33 +1058,33 @@ Section certif. rewrite !Atom.t_interp_wf in Htic; trivial. rewrite Htic1, Htic2 in Htic. simpl in Htic. - apply Typ.eqb_spec in H11. apply Typ.eqb_spec in H12. + apply Typ.eqb_spec in H10. apply Typ.eqb_spec in H11. generalize dependent v_valc1. generalize dependent v_valc2. generalize dependent v_valc. - rewrite H11, H12, H13. + rewrite H10, H11, H12. rewrite !Typ.cast_refl. intros. simpl in Htic. unfold Bval in Htic. specialize (Atom.Bval_inj2 t_i (Typ.Tbool) (Typ.i_eqb t_i t2 v_valc1 v_valc2) (v_valc)). - intros. specialize (H14 Htic). + intros. specialize (H13 Htic). (* c1 *) - pose proof (H2 c1). assert (c1 < PArray.length t_atom). + pose proof (H1 c1). assert (c1 < PArray.length t_atom). apply PArray.get_not_default_lt. rewrite def_t_atom. rewrite Heq11. easy. - specialize (H15 H16). simpl in H15. - rewrite Heq11 in H15. simpl in H15. - rewrite !andb_true_iff in H15. destruct H15. destruct H15. - unfold get_type' in H15, H17, H18. unfold v_type in H15, H17, H18. + specialize (H14 H15). simpl in H14. + rewrite Heq11 in H14. simpl in H14. + rewrite !andb_true_iff in H14. destruct H14. destruct H14. + unfold get_type' in H14, H16, H17. unfold v_type in H14, H16, H17. case_eq (t_interp .[ c1]). - intros v_typec1' v_valc1' Htic1'. rewrite Htic1' in H15. + intros v_typec1' v_valc1' Htic1'. rewrite Htic1' in H14. pose proof Htic1' as Htic1'''. case_eq (t_interp .[ d1]). - intros v_typed1 v_vald1 Htid1. rewrite Htid1 in H18. + intros v_typed1 v_vald1 Htid1. rewrite Htid1 in H17. case_eq (t_interp .[ d2]). - intros v_typed2 v_vald2 Htid2. rewrite Htid2 in H17. + intros v_typed2 v_vald2 Htid2. rewrite Htid2 in H16. rewrite Atom.t_interp_wf in Htic1'; trivial. rewrite Atom.t_interp_wf in Htid1; trivial. rewrite Atom.t_interp_wf in Htid2; trivial. @@ -1096,35 +1092,35 @@ Section certif. rewrite !Atom.t_interp_wf in Htic1'; trivial. rewrite Htid1, Htid2 in Htic1'. simpl in Htic1'. - apply Typ.eqb_spec in H15. apply Typ.eqb_spec in H17. - apply Typ.eqb_spec in H18. + apply Typ.eqb_spec in H14. apply Typ.eqb_spec in H16. + apply Typ.eqb_spec in H17. generalize dependent v_vald1. generalize dependent v_vald2. generalize dependent v_valc1'. - rewrite H15, H17, H18. - unfold Bval. rewrite <- H15. + rewrite H14, H16, H17. + unfold Bval. rewrite <- H14. rewrite !Typ.cast_refl. intros. specialize (Atom.Bval_inj2 t_i t1 (select v_vald1 v_vald2) (v_valc1')). - intros. specialize (H19 Htic1'). + intros. specialize (H18 Htic1'). (* c2 *) - pose proof (H2 c2). assert (c2 < PArray.length t_atom). + pose proof (H1 c2). assert (c2 < PArray.length t_atom). apply PArray.get_not_default_lt. rewrite def_t_atom. rewrite Heq12. easy. - specialize (H20 H21). simpl in H20. - rewrite Heq12 in H20. simpl in H20. - rewrite !andb_true_iff in H20. destruct H20. destruct H20. - unfold get_type' in H20, H22, H23. unfold v_type in H20, H22, H23. + specialize (H19 H20). simpl in H19. + rewrite Heq12 in H19. simpl in H19. + rewrite !andb_true_iff in H19. destruct H19. destruct H19. + unfold get_type' in H19, H21, H22. unfold v_type in H19, H21, H22. case_eq (t_interp .[ c2]). - intros v_typec2' v_valc2' Htic2'. rewrite Htic2' in H20. + intros v_typec2' v_valc2' Htic2'. rewrite Htic2' in H19. pose proof Htic2' as Htic2'''. case_eq (t_interp .[ e1]). - intros v_typee1 v_vale1 Htie1. rewrite Htie1 in H23. + intros v_typee1 v_vale1 Htie1. rewrite Htie1 in H22. case_eq (t_interp .[ e2]). - intros v_typee2 v_vale2 Htie2. rewrite Htie2 in H22. + intros v_typee2 v_vale2 Htie2. rewrite Htie2 in H21. pose proof Htie2 as Htie2''. rewrite Atom.t_interp_wf in Htic2'; trivial. rewrite Atom.t_interp_wf in Htie1; trivial. @@ -1133,35 +1129,35 @@ Section certif. rewrite !Atom.t_interp_wf in Htic2'; trivial. rewrite Htie1, Htie2 in Htic2'. simpl in Htic2'. - apply Typ.eqb_spec in H20. apply Typ.eqb_spec in H22. - apply Typ.eqb_spec in H23. + apply Typ.eqb_spec in H19. apply Typ.eqb_spec in H21. + apply Typ.eqb_spec in H22. generalize dependent v_valc1'. generalize dependent v_valc2'. generalize dependent v_vale1. generalize dependent v_vale2. - rewrite H22. rewrite H20 in *. rewrite H23. - unfold Bval. rewrite <- H20. + rewrite H21. rewrite H19 in *. rewrite H22. + unfold Bval. rewrite <- H19. rewrite !Typ.cast_refl. intros. specialize (Atom.Bval_inj2 t_i t1 (select v_vale1 v_vale2) (v_valc2')). - intros. specialize (H24 Htic2'). + intros. specialize (H23 Htic2'). (* d2 *) - pose proof (H2 d2). assert (d2 < PArray.length t_atom). + pose proof (H1 d2). assert (d2 < PArray.length t_atom). apply PArray.get_not_default_lt. rewrite def_t_atom. rewrite Heq14. easy. - specialize (H25 H26). simpl in H25. - rewrite Heq14 in H25. simpl in H25. - rewrite !andb_true_iff in H25. destruct H25. destruct H25. - unfold get_type' in H25, H27, H28. unfold v_type in H25, H27, H28. + specialize (H24 H25). simpl in H24. + rewrite Heq14 in H24. simpl in H24. + rewrite !andb_true_iff in H24. destruct H24. destruct H24. + unfold get_type' in H24, H26, H27. unfold v_type in H24, H26, H27. case_eq (t_interp .[ d2]). - intros v_typed2' v_vald2' Htid2'. rewrite Htid2' in H25. + intros v_typed2' v_vald2' Htid2'. rewrite Htid2' in H24. pose proof Htid2' as Htid2'''. case_eq (t_interp .[ f1]). - intros v_typef1 v_valf1 Htif1. rewrite Htif1 in H28. + intros v_typef1 v_valf1 Htif1. rewrite Htif1 in H27. case_eq (t_interp .[ f2]). - intros v_typef2 v_valf2 Htif2. rewrite Htif2 in H27. + intros v_typef2 v_valf2 Htif2. rewrite Htif2 in H26. rewrite Atom.t_interp_wf in Htid2'; trivial. rewrite Atom.t_interp_wf in Htif1; trivial. rewrite Atom.t_interp_wf in Htif2; trivial. @@ -1169,21 +1165,21 @@ Section certif. rewrite !Atom.t_interp_wf in Htid2'; trivial. rewrite Htif1, Htif2 in Htid2'. simpl in Htid2'. - apply Typ.eqb_spec in H25. apply Typ.eqb_spec in H27. - apply Typ.eqb_spec in H28. + apply Typ.eqb_spec in H24. apply Typ.eqb_spec in H26. + apply Typ.eqb_spec in H27. generalize dependent v_valf1. generalize dependent v_valf2. generalize dependent v_vald2'. - rewrite H25, H27, H28. - unfold Bval. rewrite <- H25. + rewrite H24, H26, H27. + unfold Bval. rewrite <- H24. rewrite !Typ.cast_refl. intros. specialize (Atom.Bval_inj2 t_i t0 (@diff _ _ (Typ.dec_interp t_i t0) _ _ (Typ.dec_interp t_i v_typec2') _ (Typ.comp_interp t_i v_typec2') (Typ.inh_interp t_i t0) _ v_valf1 v_valf2) (v_vald2')). - intros. specialize (H29 Htid2'). + intros. specialize (H28 Htid2'). (* semantics *) @@ -1310,13 +1306,13 @@ Section certif. specialize (Atom.Bval_inj2 t_i v_typed2' (v_vale2) (v_vald2)). intros. - unfold Atom.interp_form_hatom, interp_hatom in H0. - rewrite !Atom.t_interp_wf in H0; trivial. - rewrite Heq7 in H0. simpl in H0. - rewrite !Atom.t_interp_wf in H0; trivial. - rewrite Htib1, Htib2 in H0. simpl in H0. - rewrite !Typ.cast_refl in H0. simpl in H0. - apply Typ.i_eqb_spec_false in H0. + unfold Atom.interp_form_hatom, interp_hatom in H. + rewrite !Atom.t_interp_wf in H; trivial. + rewrite Heq7 in H. simpl in H. + rewrite !Atom.t_interp_wf in H; trivial. + rewrite Htib1, Htib2 in H. simpl in H. + rewrite !Typ.cast_refl in H. simpl in H. + apply Typ.i_eqb_spec_false in H. destruct Heq1314 as [Heq1314 | Heq1314]; @@ -1350,7 +1346,7 @@ Section certif. rewrite (Atom.Bval_inj2 t_i _ _ _ Htid2) in *. apply select_at_diff. - red in H0. red. intro. apply H0. auto. + red in H. red. intro. apply H. auto. Qed. End Correct. diff --git a/src/array/FArray.v b/src/array/FArray.v index b317bec..69edf75 100644 --- a/src/array/FArray.v +++ b/src/array/FArray.v @@ -44,7 +44,7 @@ Module Raw. Lemma eqb_elt_eq x y : eqb_elt x y = true <-> x = y. Proof. unfold eqb_elt. case (eq_dec x y); split; easy. Qed. - Hint Immediate eqb_key_eq eqb_elt_eq. + Hint Immediate eqb_key_eq eqb_elt_eq : smtcoq_array. Definition farray := list (key * elt). @@ -54,8 +54,8 @@ Module Raw. Definition ltk (a b : (key * elt)) := lt (fst a) (fst b). - Hint Unfold ltk eqk eqke. - Hint Extern 2 (eqke ?a ?b) => split. + Hint Unfold ltk eqk eqke : smtcoq_array. + Hint Extern 2 (eqke ?a ?b) => split : smtcoq_array. Global Instance lt_key_strorder : StrictOrder (lt : key -> key -> Prop). Proof. apply StrictOrder_OrdType. Qed. @@ -90,7 +90,7 @@ Module Raw. Lemma ltk_right_l : forall x k e e', ltk (k,e) x -> ltk (k,e') x. Proof. auto. Qed. - Hint Immediate ltk_right_r ltk_right_l. + Hint Immediate ltk_right_r ltk_right_l : smtcoq_array. Notation Sort := (sort ltk). Notation Inf := (lelistA (ltk)). @@ -100,7 +100,7 @@ Module Raw. Notation NoDupA := (NoDupA eqk). - Hint Unfold MapsTo In. + Hint Unfold MapsTo In : smtcoq_array. Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'. Proof. @@ -110,13 +110,13 @@ Module Raw. (* eqk, eqke are equalities *) Lemma eqk_refl : forall e, eqk e e. - Proof. auto. Qed. + Proof. auto with smtcoq_array. Qed. Lemma eqke_refl : forall e, eqke e e. - Proof. auto. Qed. + Proof. auto with smtcoq_array. Qed. Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e. - Proof. auto. Qed. + Proof. auto with smtcoq_array. Qed. Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e. Proof. unfold eqke; intuition. Qed. @@ -133,35 +133,35 @@ Module Raw. Proof. unfold ltk; eauto. Qed. Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'. - Proof. unfold ltk, eqk. intros. apply lt_not_eq; auto. Qed. + Proof. unfold ltk, eqk. intros. apply lt_not_eq; auto with smtcoq_array. Qed. Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'. Proof. unfold eqke, ltk; intuition; simpl in *; subst. - apply lt_not_eq in H. auto. + apply lt_not_eq in H. auto with smtcoq_array. Qed. - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. - Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke. - Hint Immediate eqk_sym eqke_sym. + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : smtcoq_array. + Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke : smtcoq_array. + Hint Immediate eqk_sym eqke_sym : smtcoq_array. Global Instance eqk_equiv : Equivalence eqk. - Proof. split; eauto. Qed. + Proof. split; eauto with smtcoq_array. Qed. Global Instance eqke_equiv : Equivalence eqke. - Proof. split; eauto. Qed. + Proof. split; eauto with smtcoq_array. Qed. Global Instance ltk_strorder : StrictOrder ltk. Proof. split. unfold Irreflexive, Reflexive, complement. - intros. apply lt_not_eq in H; auto. + intros. apply lt_not_eq in H; auto with smtcoq_array. unfold Transitive. intros x y z. apply lt_trans. Qed. Global Instance eq_equiv : @Equivalence (key * elt) eq. Proof. - split; auto. + split; auto with smtcoq_array. unfold Transitive. apply eq_trans. Qed. @@ -173,13 +173,13 @@ Module Raw. Global Instance ltk_compatk : Proper (eqk==>eqk==>iff) ltk. Proof. intros (x,e) (x',e') Hxx' (y,f) (y',f') Hyy'; compute. - compute in Hxx'; compute in Hyy'. rewrite Hxx', Hyy'; auto. + compute in Hxx'; compute in Hyy'. rewrite Hxx', Hyy'; auto with smtcoq_array. Qed. Global Instance ltk_compat' : Proper (eqke==>eqke==>iff) ltk. Proof. intros (x,e) (x',e') (Hxx',_) (y,f) (y',f') (Hyy',_); compute. - compute in Hxx'; compute in Hyy'. rewrite Hxx', Hyy'; auto. + compute in Hxx'; compute in Hyy'. rewrite Hxx', Hyy'; auto with smtcoq_array. Qed. Global Instance ltk_asym : Asymmetric ltk. @@ -194,8 +194,8 @@ Module Raw. destruct x, x'. simpl in *. intro. symmetry in H. - apply lt_not_eq in H. auto. - subst. auto. + apply lt_not_eq in H. auto with smtcoq_array. + subst. auto with smtcoq_array. Qed. Lemma ltk_eqk : forall e e' e'', ltk e e' -> eqk e' e'' -> ltk e e''. @@ -208,8 +208,8 @@ Module Raw. intros (k,e) (k',e') (k'',e''). unfold ltk, eqk; simpl; intros; subst; trivial. Qed. - Hint Resolve eqk_not_ltk. - Hint Immediate ltk_eqk eqk_ltk. + Hint Resolve eqk_not_ltk : smtcoq_array. + Hint Immediate ltk_eqk eqk_ltk : smtcoq_array. Lemma InA_eqke_eqk : forall x m, InA eqke x m -> InA eqk x m. @@ -217,17 +217,17 @@ Module Raw. unfold eqke; induction 1; intuition. Qed. - Hint Resolve InA_eqke_eqk. + Hint Resolve InA_eqke_eqk : smtcoq_array. Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. Proof. firstorder. - exists x; auto. + exists x; auto with smtcoq_array. induction H. destruct y. - exists e; auto. + exists e; auto with smtcoq_array. destruct IHInA as [e H0]. - exists e; auto. + exists e; auto with smtcoq_array. Qed. Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. @@ -237,7 +237,7 @@ Module Raw. Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. Proof. - destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto. + destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto with smtcoq_array. Qed. Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l. @@ -246,8 +246,8 @@ Module Raw. Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l. Proof. exact (InfA_ltA ltk_strorder). Qed. - Hint Immediate Inf_eq. - Hint Resolve Inf_lt. + Hint Immediate Inf_eq : smtcoq_array. + Hint Resolve Inf_lt : smtcoq_array. Lemma Sort_Inf_In : forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p. @@ -261,11 +261,11 @@ Module Raw. intros; red; intros. destruct H1 as [e' H2]. elim (@ltk_not_eqk (k,e) (k,e')). - eapply Sort_Inf_In; eauto. - red; simpl; auto. + eapply Sort_Inf_In; eauto with smtcoq_array. + red; simpl; auto with smtcoq_array. Qed. - Hint Resolve Sort_Inf_NotIn. + Hint Resolve Sort_Inf_NotIn : smtcoq_array. Lemma Sort_NoDupA: forall l, Sort l -> NoDupA l. Proof. @@ -274,14 +274,14 @@ Module Raw. Lemma Sort_In_cons_1 : forall e l e', Sort (e::l) -> InA eqk e' l -> ltk e e'. Proof. - inversion 1; intros; eapply Sort_Inf_In; eauto. + inversion 1; intros; eapply Sort_Inf_In; eauto with smtcoq_array. Qed. Lemma Sort_In_cons_2 : forall l e e', Sort (e::l) -> InA eqk e' (e::l) -> ltk e e' \/ eqk e e'. Proof. - inversion_clear 2; auto. - left; apply Sort_In_cons_1 with l; auto. + inversion_clear 2; auto with smtcoq_array. + left; apply Sort_In_cons_1 with l; auto with smtcoq_array. Qed. Lemma Sort_In_cons_3 : @@ -294,7 +294,7 @@ Module Raw. Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. Proof. inversion 1. - inversion_clear H0; eauto. + inversion_clear H0; eauto with smtcoq_array. destruct H1; simpl in *; intuition. Qed. @@ -310,7 +310,7 @@ Module Raw. inversion_clear 1; compute in H0; intuition. Qed. - Hint Resolve In_inv_2 In_inv_3. + Hint Resolve In_inv_2 In_inv_3 : smtcoq_array. (** * FMAPLIST interface implementaion *) @@ -327,11 +327,11 @@ Module Raw. intro abs. inversion abs. Qed. - Hint Resolve empty_1. + Hint Resolve empty_1 : smtcoq_array. Lemma empty_sorted : Sort empty. Proof. - unfold empty; auto. + unfold empty; auto with smtcoq_array. Qed. Lemma MapsTo_inj : forall x e e' l (Hl:Sort l), @@ -363,7 +363,7 @@ Module Raw. + unfold eqk in H, H0. simpl in *. subst. inversion_clear HH. inversion_clear HH0. - unfold eqke in *. simpl in *. destruct H, H1; subst; auto. + unfold eqke in *. simpl in *. destruct H, H1; subst; auto with smtcoq_array. apply InA_eqke_eqk in H1. inversion_clear Hl. specialize (Sort_Inf_In H2 H3 H1). @@ -382,15 +382,15 @@ Module Raw. Proof. unfold Empty, MapsTo. intros m. - case m;auto. + case m;auto with smtcoq_array. intros (k,e) l inlist. - absurd (InA eqke (k, e) ((k, e) :: l));auto. + absurd (InA eqke (k, e) ((k, e) :: l));auto with smtcoq_array. Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. Proof. intros m. - case m;auto. + case m;auto with smtcoq_array. intros p l abs. inversion abs. Qed. @@ -416,15 +416,15 @@ Module Raw. - simpl. case_eq (compare x k'); trivial. + intros _x0 e0. absurd (In x ((k', _x) :: l));try assumption. - apply Sort_Inf_NotIn with _x;auto. + apply Sort_Inf_NotIn with _x;auto with smtcoq_array. + intros _x0 e0. apply IHb. - elim (sort_inv sorted);auto. - elim (In_inv belong1);auto. + elim (sort_inv sorted);auto with smtcoq_array. + elim (In_inv belong1);auto with smtcoq_array. intro abs. - absurd (eq x k'); auto. + absurd (eq x k'); auto with smtcoq_array. symmetry in abs. - apply lt_not_eq in abs; auto. + apply lt_not_eq in abs; auto with smtcoq_array. Qed. Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m. @@ -432,10 +432,10 @@ Module Raw. intros m Hm x; generalize Hm; clear Hm; unfold In,MapsTo. induction m as [ |[k' _x] l IHb]; intros sorted hyp;try ((inversion hyp);fail). revert hyp. simpl. case_eq (compare x k'); intros _x0 e0 hyp;try ((inversion hyp);fail). - - exists _x; auto. - - induction IHb; auto. - + exists x0; auto. - + inversion_clear sorted; auto. + - exists _x; auto with smtcoq_array. + - induction IHb; auto with smtcoq_array. + + exists x0; auto with smtcoq_array. + + inversion_clear sorted; auto with smtcoq_array. Qed. Lemma mem_3 : forall m (Hm:Sort m) x, mem x m = false -> ~ In x m. @@ -461,8 +461,8 @@ Module Raw. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. Proof. intros m x. unfold MapsTo. - induction m as [ |[k' _x] l IHb];simpl; intro e';try now (intro eqfind; inversion eqfind; auto). - case_eq (compare x k'); intros _x0 e0 eqfind; inversion eqfind; auto. + induction m as [ |[k' _x] l IHb];simpl; intro e';try now (intro eqfind; inversion eqfind; auto with smtcoq_array). + case_eq (compare x k'); intros _x0 e0 eqfind; inversion eqfind; auto with smtcoq_array. Qed. Lemma find_1 : forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e. @@ -473,11 +473,11 @@ Module Raw. - case_eq (compare x k'); intros _x0 e1; subst. + inversion_clear 2. * clear e1;compute in H0; destruct H0. - apply lt_not_eq in H; auto. now contradict H. + apply lt_not_eq in H; auto with smtcoq_array. now contradict H. * clear e1;generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute. (* order. *) intros. - apply (lt_trans k') in _x0; auto. + apply (lt_trans k') in _x0; auto with smtcoq_array. apply lt_not_eq in _x0. now contradict _x0. + clear e1;inversion_clear 2. @@ -486,7 +486,7 @@ Module Raw. (* order. *) intros. apply lt_not_eq in H. now contradict H. - + clear e1; do 2 inversion_clear 1; auto. + + clear e1; do 2 inversion_clear 1; auto with smtcoq_array. compute in H2; destruct H2. (* order. *) subst. apply lt_not_eq in _x0. now contradict _x0. @@ -509,7 +509,7 @@ Module Raw. Proof. intros m x y e; generalize y; clear y. unfold MapsTo. - induction m as [ |[k' _x] l IHb]; simpl; [ |case_eq (compare x k'); intros _x0 e1]; simpl; auto. + induction m as [ |[k' _x] l IHb]; simpl; [ |case_eq (compare x k'); intros _x0 e1]; simpl; auto with smtcoq_array. Qed. Lemma add_2 : forall m x y e e', @@ -517,14 +517,14 @@ Module Raw. Proof. intros m x y e e'. generalize y e; clear y e; unfold MapsTo. - induction m as [ |[k' _x] l IHb]; simpl; [ |case_eq (compare x k'); intros _x0 e0];simpl;auto; clear e0. - subst;auto. + induction m as [ |[k' _x] l IHb]; simpl; [ |case_eq (compare x k'); intros _x0 e0];simpl;auto with smtcoq_array; clear e0. + subst;auto with smtcoq_array. intros y' e'' eqky'; inversion_clear 1; destruct H0; simpl in *. (* order. *) subst. now contradict eqky'. - auto. - auto. + auto with smtcoq_array. + auto with smtcoq_array. intros y' e'' eqky'; inversion_clear 1; intuition. Qed. @@ -533,10 +533,10 @@ Module Raw. Proof. intros m x y e e'. generalize y e; clear y e; unfold MapsTo. induction m as [ |[k' _x] l IHb]; simpl; [ |case_eq (compare x k'); intros _x0 e1];simpl; intros. - apply (In_inv_3 H0); compute; auto. - apply (In_inv_3 H0); compute; auto. - constructor 2; apply (In_inv_3 H0); compute; auto. - inversion_clear H0; auto. + apply (In_inv_3 H0); compute; auto with smtcoq_array. + apply (In_inv_3 H0); compute; auto with smtcoq_array. + constructor 2; apply (In_inv_3 H0); compute; auto with smtcoq_array. + inversion_clear H0; auto with smtcoq_array. Qed. Lemma add_Inf : forall (m:farray)(x x':key)(e e':elt), @@ -550,7 +550,7 @@ Module Raw. compute in H0,H1. simpl; case (compare x x''); intuition. Qed. - Hint Resolve add_Inf. + Hint Resolve add_Inf : smtcoq_array. Lemma add_sorted : forall m (Hm:Sort m) x e, Sort (add x e m). Proof. @@ -558,9 +558,9 @@ Module Raw. simpl; intuition. intros. destruct a as (x',e'). - simpl; case (compare x x'); intuition; inversion_clear Hm; auto. - constructor; auto. - apply Inf_eq with (x',e'); auto. + simpl; case (compare x x'); intuition; inversion_clear Hm; auto with smtcoq_array. + constructor; auto with smtcoq_array. + apply Inf_eq with (x',e'); auto with smtcoq_array. Qed. (** * [remove] *) @@ -583,18 +583,18 @@ Module Raw. red; inversion 1; inversion H0. - apply Sort_Inf_NotIn with x0; auto. + apply Sort_Inf_NotIn with x0; auto with smtcoq_array. clear e0. inversion Hm. subst. - apply Sort_Inf_NotIn with x0; auto. + apply Sort_Inf_NotIn with x0; auto with smtcoq_array. clear e0;inversion_clear Hm. - assert (notin:~ In y (remove y l)) by auto. + assert (notin:~ In y (remove y l)) by auto with smtcoq_array. intros (x1,abs). inversion_clear abs. compute in H1; destruct H1. subst. apply lt_not_eq in _x; now contradict _x. - apply notin; exists x1; auto. + apply notin; exists x1; auto with smtcoq_array. Qed. @@ -602,41 +602,41 @@ Module Raw. ~ eq x y -> MapsTo y e m -> MapsTo y e (remove x m). Proof. intros m Hm x y e; generalize Hm; clear Hm; unfold MapsTo. - induction m as [ |[k' _x] l IHb]; simpl; [ |case_eq (compare x k'); intros _x0 e1];subst;auto; + induction m as [ |[k' _x] l IHb]; simpl; [ |case_eq (compare x k'); intros _x0 e1];subst;auto with smtcoq_array; match goal with | [H: compare _ _ = _ |- _ ] => clear H | _ => idtac end. - inversion_clear 3; auto. + inversion_clear 3; auto with smtcoq_array. compute in H1; destruct H1. subst; now contradict H. - inversion_clear 1; inversion_clear 2; auto. + inversion_clear 1; inversion_clear 2; auto with smtcoq_array. Qed. Lemma remove_3 : forall m (Hm:Sort m) x y e, MapsTo y e (remove x m) -> MapsTo y e m. Proof. intros m Hm x y e; generalize Hm; clear Hm; unfold MapsTo. - induction m as [ |[k' _x] l IHb]; simpl; [ |case_eq (compare x k'); intros _x0 e1];subst;auto. - inversion_clear 1; inversion_clear 1; auto. + induction m as [ |[k' _x] l IHb]; simpl; [ |case_eq (compare x k'); intros _x0 e1];subst;auto with smtcoq_array. + inversion_clear 1; inversion_clear 1; auto with smtcoq_array. Qed. Lemma remove_4_aux : forall m (Hm:Sort m) x y, ~ eq x y -> In y m -> In y (remove x m). Proof. intros m Hm x y; generalize Hm; clear Hm. - induction m as [ |[k' x0] l IHf]; simpl; [ |case_eq (compare x k'); intros _x e1];subst;auto; + induction m as [ |[k' x0] l IHf]; simpl; [ |case_eq (compare x k'); intros _x e1];subst;auto with smtcoq_array; match goal with | [H: compare _ _ = _ |- _ ] => clear H | _ => idtac end. rewrite In_alt. - inversion_clear 3; auto. + inversion_clear 3; auto with smtcoq_array. inversion H2. unfold eqk in H3. simpl in H3. subst. now contradict H0. apply In_alt. - exists x. auto. + exists x. auto with smtcoq_array. apply lt_not_eq in _x. intros. inversion_clear Hm. @@ -647,27 +647,27 @@ Module Raw. destruct (eq_dec k' y). exists x0. apply InA_cons_hd. - split; simpl; auto. + split; simpl; auto with smtcoq_array. inversion H3. unfold eqk in H4. simpl in H4; subst. now contradict n. assert ((exists e : elt, MapsTo y e (remove x l)) -> (exists e : elt, MapsTo y e ((k', x0) :: remove x l))). intros. destruct H6. exists x2. - apply InA_cons_tl. auto. + apply InA_cons_tl. auto with smtcoq_array. apply H6. - apply IHf; auto. + apply IHf; auto with smtcoq_array. apply In_alt. - exists x1. auto. + exists x1. auto with smtcoq_array. Qed. Lemma remove_4 : forall m (Hm:Sort m) x y, ~ eq x y -> In y m <-> In y (remove x m). Proof. split. - apply remove_4_aux; auto. + apply remove_4_aux; auto with smtcoq_array. revert H. generalize Hm; clear Hm. - induction m as [ |[k' _x] l IHb]; simpl; [ |case_eq (compare x k'); intros _x0 e1];subst;auto; + induction m as [ |[k' _x] l IHb]; simpl; [ |case_eq (compare x k'); intros _x0 e1];subst;auto with smtcoq_array; match goal with | [H: compare _ _ = _ |- _ ] => clear H | _ => idtac @@ -675,18 +675,18 @@ Module Raw. intros. destruct H0 as (e, H0). exists e. - apply InA_cons_tl. auto. + apply InA_cons_tl. auto with smtcoq_array. intros. apply lt_not_eq in _x0. inversion_clear Hm. apply In_inv in H0. destruct H0. exists _x. - apply InA_cons_hd. split; simpl; auto. + apply InA_cons_hd. split; simpl; auto with smtcoq_array. specialize (IHb H1 H H0). inversion IHb. exists x0. - apply InA_cons_tl. auto. + apply InA_cons_tl. auto with smtcoq_array. Qed. Lemma remove_Inf : forall (m:farray)(Hm : Sort m)(x x':key)(e':elt), @@ -700,9 +700,9 @@ Module Raw. compute in H0. simpl; case (compare x x''); intuition. inversion_clear Hm. - apply Inf_lt with (x'',e''); auto. + apply Inf_lt with (x'',e''); auto with smtcoq_array. Qed. - Hint Resolve remove_Inf. + Hint Resolve remove_Inf : smtcoq_array. Lemma remove_sorted : forall m (Hm:Sort m) x, Sort (remove x m). Proof. @@ -710,7 +710,7 @@ Module Raw. simpl; intuition. intros. destruct a as (x',e'). - simpl; case (compare x x'); intuition; inversion_clear Hm; auto. + simpl; case (compare x x'); intuition; inversion_clear Hm; auto with smtcoq_array. Qed. (** * [elements] *) @@ -720,25 +720,25 @@ Module Raw. Lemma elements_1 : forall m x e, MapsTo x e m -> InA eqke (x,e) (elements m). Proof. - auto. + auto with smtcoq_array. Qed. Lemma elements_2 : forall m x e, InA eqke (x,e) (elements m) -> MapsTo x e m. Proof. - auto. + auto with smtcoq_array. Qed. Lemma elements_3 : forall m (Hm:Sort m), sort ltk (elements m). Proof. - auto. + auto with smtcoq_array. Qed. Lemma elements_3w : forall m (Hm:Sort m), NoDupA (elements m). Proof. intros. apply Sort_NoDupA. - apply elements_3; auto. + apply elements_3; auto with smtcoq_array. Qed. (** * [fold] *) @@ -752,7 +752,7 @@ Module Raw. Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. - intros; revert i; induction m as [ |[k e]]; simpl; auto. + intros; revert i; induction m as [ |[k e]]; simpl; auto with smtcoq_array. Qed. (** * [equal] *) @@ -776,7 +776,7 @@ Module Raw. Equivb cmp m m' -> equal cmp m m' = true. Proof. intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'. - revert m'; induction m as [ |[x e] l IHl]; intros [ |[x' e'] l']; simpl; auto; unfold Equivb; intuition; subst. + revert m'; induction m as [ |[x e] l IHl]; intros [ |[x' e'] l']; simpl; auto with smtcoq_array; unfold Equivb; intuition; subst. - destruct (H0 x') as [_ H3]. assert (H2: In x' nil). { @@ -789,53 +789,53 @@ Module Raw. apply H3. exists e. now constructor. } elim H2. intros x0 Hx0. inversion Hx0. - - case_eq (compare x x'); simpl; subst;auto; unfold Equivb; + - case_eq (compare x x'); simpl; subst;auto with smtcoq_array; unfold Equivb; intuition; subst. + destruct (H0 x). assert (In x ((x',e')::l')). - apply H2; auto. - exists e; auto. + apply H2; auto with smtcoq_array. + exists e; auto with smtcoq_array. destruct (In_inv H4). (* order. *) clear H. apply lt_not_eq in l0; now contradict l0. inversion_clear Hm'. assert (Inf (x,e) l'). - apply Inf_lt with (x',e'); auto. + apply Inf_lt with (x',e'); auto with smtcoq_array. elim (Sort_Inf_NotIn H6 H8 H5). + match goal with H: compare _ _ = _ |- _ => clear H end. assert (cmp_e_e':cmp e e' = true). - apply H1 with x'; auto. + apply H1 with x'; auto with smtcoq_array. rewrite cmp_e_e'; simpl. - apply IHl; auto. - inversion_clear Hm; auto. - inversion_clear Hm'; auto. + apply IHl; auto with smtcoq_array. + inversion_clear Hm; auto with smtcoq_array. + inversion_clear Hm'; auto with smtcoq_array. unfold Equivb; intuition. destruct (H0 k). assert (In k ((x',e) ::l)). - destruct H as (e'', hyp); exists e''; auto. - destruct (In_inv (H2 H4)); auto. + destruct H as (e'', hyp); exists e''; auto with smtcoq_array. + destruct (In_inv (H2 H4)); auto with smtcoq_array. inversion_clear Hm. elim (Sort_Inf_NotIn H6 H7). - destruct H as (e'', hyp); exists e''; auto. - apply MapsTo_eq with k; auto. + destruct H as (e'', hyp); exists e''; auto with smtcoq_array. + apply MapsTo_eq with k; auto with smtcoq_array. destruct (H0 k). assert (In k ((x',e') ::l')). - destruct H as (e'', hyp); exists e''; auto. - destruct (In_inv (H3 H4)); auto. + destruct H as (e'', hyp); exists e''; auto with smtcoq_array. + destruct (In_inv (H3 H4)); auto with smtcoq_array. subst. inversion_clear Hm'. now elim (Sort_Inf_NotIn H5 H6). - apply H1 with k; destruct (eq_dec x' k); auto. + apply H1 with k; destruct (eq_dec x' k); auto with smtcoq_array. + destruct (H0 x'). assert (In x' ((x,e)::l)). - apply H3; auto. - exists e'; auto. + apply H3; auto with smtcoq_array. + exists e'; auto with smtcoq_array. destruct (In_inv H4). (* order. *) clear H; subst; apply lt_not_eq in l0; now contradict l0. inversion_clear Hm. assert (Inf (x',e') l). - apply Inf_lt with (x,e); auto. + apply Inf_lt with (x,e); auto with smtcoq_array. elim (Sort_Inf_NotIn H6 H8 H5). Qed. @@ -843,7 +843,7 @@ Module Raw. equal cmp m m' = true -> Equivb cmp m m'. Proof. intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'. - revert m'; induction m as [ |[x e] l IHl]; intros [ |[x' e'] l']; simpl; subst;auto; unfold Equivb; + revert m'; induction m as [ |[x e] l IHl]; intros [ |[x' e'] l']; simpl; subst;auto with smtcoq_array; unfold Equivb; intuition; try discriminate; subst; try match goal with H: compare _ _ = _ |- _ => clear H end. - inversion H0. @@ -852,19 +852,19 @@ Module Raw. destruct (andb_prop _ _ H); clear H. destruct (IHl _ H1 H4 H7). destruct (In_inv H0). - exists e'; constructor; split; trivial; apply eq_trans with x; auto. + exists e'; constructor; split; trivial; apply eq_trans with x; auto with smtcoq_array. destruct (H k). destruct (H10 H9) as (e'',hyp). - exists e''; auto. + exists e''; auto with smtcoq_array. - revert H; case_eq (compare x x'); intros _x _ H; try inversion H. inversion_clear Hm;inversion_clear Hm'. destruct (andb_prop _ _ H); clear H. destruct (IHl _ H1 H4 H7). destruct (In_inv H0). - exists e; constructor; split; trivial; apply eq_trans with x'; auto. + exists e; constructor; split; trivial; apply eq_trans with x'; auto with smtcoq_array. destruct (H k). destruct (H11 H9) as (e'',hyp). - exists e''; auto. + exists e''; auto with smtcoq_array. - revert H; case_eq (compare x x'); intros _x _ H; [inversion H| |inversion H]. inversion_clear Hm;inversion_clear Hm'. destruct (andb_prop _ _ H); clear H. @@ -872,16 +872,16 @@ Module Raw. inversion_clear H0. + destruct H9; simpl in *; subst. inversion_clear H1. - * destruct H0; simpl in *; subst; auto. + * destruct H0; simpl in *; subst; auto with smtcoq_array. * elim (Sort_Inf_NotIn H4 H5). - exists e'0; apply MapsTo_eq with x'; auto. + exists e'0; apply MapsTo_eq with x'; auto with smtcoq_array. (* order. *) + inversion_clear H1. - * destruct H0; simpl in *; subst; auto. + * destruct H0; simpl in *; subst; auto with smtcoq_array. elim (Sort_Inf_NotIn H2 H3). - exists e0; apply MapsTo_eq with x'; auto. + exists e0; apply MapsTo_eq with x'; auto with smtcoq_array. (* order. *) - * apply H8 with k; auto. + * apply H8 with k; auto with smtcoq_array. Qed. (** This lemma isn't part of the spec of [Equivb], but is used in [FMapAVL] *) @@ -895,18 +895,18 @@ Module Raw. inversion H0; subst. destruct x; destruct y; compute in H1, H2. split; intros. - apply equal_2; auto. + apply equal_2; auto with smtcoq_array. simpl. case (compare k k0); subst; intro HH; try (apply lt_not_eq in HH; now contradict HH). rewrite H2; simpl. - apply equal_1; auto. - apply equal_2; auto. + apply equal_1; auto with smtcoq_array. + apply equal_2; auto with smtcoq_array. generalize (equal_1 H H0 H3). simpl. case (compare k k0); subst; intro HH; try (apply lt_not_eq in HH; now contradict HH). - rewrite H2; simpl; auto. + rewrite H2; simpl; auto with smtcoq_array. Qed. End Array. @@ -1492,7 +1492,7 @@ Section FArray. intros. rewrite eq_option_alt. intro e'. rewrite <- 2 find_mapsto_iff. apply add_neq_mapsto_iff; auto. Qed. - Hint Resolve add_neq_o. + Hint Resolve add_neq_o : smtcoq_array. Lemma MapsTo_fun : forall m x (e e':elt), MapsTo x e m -> MapsTo x e' m -> e=e'. @@ -1854,11 +1854,21 @@ Arguments extensionality2 {_} {_} {_} {_} {_} {_} {_} {_} {_} _. Arguments select_at_diff {_} {_} {_} {_} {_} {_} {_} {_} {_} _ _ _. +Declare Scope farray_scope. + Notation "a '[' i ']'" := (select a i) (at level 1, format "a [ i ]") : farray_scope. Notation "a '[' i '<-' v ']'" := (store a i v) (at level 1, format "a [ i <- v ]") : farray_scope. +(* Register constants for OCaml access *) +Register FArray.farray as SMTCoq.array.FArray.farray. +Register select as SMTCoq.array.FArray.select. +Register store as SMTCoq.array.FArray.store. +Register diff as SMTCoq.array.FArray.diff. +Register FArray.equal as SMTCoq.array.FArray.equal. + + (* Local Variables: diff --git a/src/bva/BVList.v b/src/bva/BVList.v index 5733081..025bbd2 100644 --- a/src/bva/BVList.v +++ b/src/bva/BVList.v @@ -435,7 +435,7 @@ Fixpoint beq_listP (l m : list bool) {struct l} := Lemma bv_mk_eq l1 l2 : bv_eq l1 l2 = beq_list l1 l2. Proof. unfold bv_eq, size, bits. - case_eq (Nat_eqb (length l1) (length l2)); intro Heq. + case_eq (Nat.eqb (length l1) (length l2)); intro Heq. - now rewrite (EqNat.beq_nat_true _ _ Heq), N.eqb_refl. - replace (N.of_nat (length l1) =? N.of_nat (length l2)) with false. * revert l2 Heq. induction l1 as [ |b1 l1 IHl1]; intros [ |b2 l2]; simpl in *; auto. @@ -2526,6 +2526,8 @@ Qed. End RAWBITVECTOR_LIST. +Declare Scope bv_scope. + Module BITVECTOR_LIST <: BITVECTOR. Include RAW2BITVECTOR(RAWBITVECTOR_LIST). @@ -2539,6 +2541,29 @@ Module BITVECTOR_LIST <: BITVECTOR. End BITVECTOR_LIST. + +(* Register constants for OCaml access *) +Register BITVECTOR_LIST.bitvector as SMTCoq.bva.BVList.BITVECTOR_LIST.bitvector. +Register BITVECTOR_LIST.of_bits as SMTCoq.bva.BVList.BITVECTOR_LIST.of_bits. +Register BITVECTOR_LIST.bitOf as SMTCoq.bva.BVList.BITVECTOR_LIST.bitOf. +Register BITVECTOR_LIST.bv_eq as SMTCoq.bva.BVList.BITVECTOR_LIST.bv_eq. +Register BITVECTOR_LIST.bv_not as SMTCoq.bva.BVList.BITVECTOR_LIST.bv_not. +Register BITVECTOR_LIST.bv_neg as SMTCoq.bva.BVList.BITVECTOR_LIST.bv_neg. +Register BITVECTOR_LIST.bv_and as SMTCoq.bva.BVList.BITVECTOR_LIST.bv_and. +Register BITVECTOR_LIST.bv_or as SMTCoq.bva.BVList.BITVECTOR_LIST.bv_or. +Register BITVECTOR_LIST.bv_xor as SMTCoq.bva.BVList.BITVECTOR_LIST.bv_xor. +Register BITVECTOR_LIST.bv_add as SMTCoq.bva.BVList.BITVECTOR_LIST.bv_add. +Register BITVECTOR_LIST.bv_mult as SMTCoq.bva.BVList.BITVECTOR_LIST.bv_mult. +Register BITVECTOR_LIST.bv_ult as SMTCoq.bva.BVList.BITVECTOR_LIST.bv_ult. +Register BITVECTOR_LIST.bv_slt as SMTCoq.bva.BVList.BITVECTOR_LIST.bv_slt. +Register BITVECTOR_LIST.bv_concat as SMTCoq.bva.BVList.BITVECTOR_LIST.bv_concat. +Register BITVECTOR_LIST.bv_extr as SMTCoq.bva.BVList.BITVECTOR_LIST.bv_extr. +Register BITVECTOR_LIST.bv_zextn as SMTCoq.bva.BVList.BITVECTOR_LIST.bv_zextn. +Register BITVECTOR_LIST.bv_sextn as SMTCoq.bva.BVList.BITVECTOR_LIST.bv_sextn. +Register BITVECTOR_LIST.bv_shl as SMTCoq.bva.BVList.BITVECTOR_LIST.bv_shl. +Register BITVECTOR_LIST.bv_shr as SMTCoq.bva.BVList.BITVECTOR_LIST.bv_shr. + + (* Local Variables: coq-load-path: ((rec ".." "SMTCoq")) diff --git a/src/bva/Bva_checker.v b/src/bva/Bva_checker.v index d74b847..55c002f 100644 --- a/src/bva/Bva_checker.v +++ b/src/bva/Bva_checker.v @@ -12,9 +12,7 @@ (** A small checker for bit-vectors bit-blasting *) -Require Structures. - -Require Import Int63 Int63Properties PArray SMT_classes ZArith. +Require Import Int63 PArray SMT_classes ZArith. Require Import Misc State SMT_terms BVList Psatz. Require Import Bool List BoolEq NZParity Nnat. @@ -89,7 +87,7 @@ Section Checker. Fixpoint check_bb (a: int) (bs: list _lit) (i n: nat) := match bs with - | nil => Nat_eqb i n (* We go up to n *) + | nil => Nat.eqb i n (* We go up to n *) | b::bs => if Lit.is_pos b then match get_form (Lit.blit b) with @@ -97,10 +95,10 @@ Section Checker. match get_atom a' with | Auop (UO_BVbitOf N p) a' => (* TODO: - Do not need to check [Nat_eqb l (N.to_nat N)] at every iteration *) + Do not need to check [Nat.eqb l (N.to_nat N)] at every iteration *) if (a == a') (* We bit blast the right bv *) - && (Nat_eqb i p) (* We consider bits after bits *) - && (Nat_eqb n (N.to_nat N)) (* The bv has indeed type BV n *) + && (Nat.eqb i p) (* We consider bits after bits *) + && (Nat.eqb n (N.to_nat N)) (* The bv has indeed type BV n *) then check_bb a bs (S i) n else false | _ => false @@ -264,7 +262,7 @@ Fixpoint check_symopp (bs1 bs2 bsres : list _lit) (bvop: binop) := if Lit.is_pos bres then match get_form (Lit.blit bres) with | Fand args => - match PArray.to_list args with + match to_list args with | bres :: bsres => if Lit.is_pos bres then let ires := @@ -532,7 +530,7 @@ Fixpoint check_symopp (bs1 bs2 bsres : list _lit) (bvop: binop) := end. Definition check_mult (bs1 bs2 bsres: list _lit) : bool := - if Nat_eqb (length bs1) (length bs2)%nat then + if Nat.eqb (length bs1) (length bs2)%nat then let bvm12 := bblast_bvmult bs1 bs2 (length bs1) in forallb2 eq_carry_lit bvm12 bsres else false. @@ -925,7 +923,7 @@ Definition shl_lit_be (a: list _lit) (b: list bool): list _lit := Definition check_shl (bs1: list _lit) (bs2: list bool) (bsres: list _lit) : bool := - if (Structures.nat_eqb (length bs1) (length bs2)) then + if (Nat.eqb (length bs1) (length bs2)) then if (forallb2 eq_carry_lit (lit_to_carry (shl_lit_be bs1 bs2)) bsres) then true else false else false. @@ -976,7 +974,7 @@ Definition shr_lit_be (a: list _lit) (b: list bool): list _lit := Definition check_shr (bs1: list _lit) (bs2: list bool) (bsres: list _lit) : bool := - if (Structures.nat_eqb (length bs1) (length bs2)) then + if (Nat.eqb (length bs1) (length bs2)) then if (forallb2 eq_carry_lit (lit_to_carry (shr_lit_be bs1 bs2)) bsres) then true else false else false. @@ -1082,7 +1080,7 @@ Definition shr_lit_be (a: list _lit) (b: list bool): list _lit := Let rho_interp : forall x : int, rho x = Form.interp interp_form_hatom interp_form_hatom_bv t_form (t_form.[ x]). Proof. intros x;apply wf_interp_form;trivial. Qed. - Definition wf := PArray.forallbi lt_form t_form. + Definition wf := aforallbi lt_form t_form. Hypothesis wf_t_i : wf. Variable interp_bvatom : atom -> forall s, BITVECTOR_LIST.bitvector s. @@ -1127,17 +1125,6 @@ Qed. Lemma le_le_S_eq : forall (n m: nat), (n <= m)%nat -> (S n <= m)%nat \/ n = m. Proof le_lt_or_eq. -Lemma Nat_eqb_eq: forall n m, Nat_eqb n m = true -> n = m. -Proof. induction n. - intros n Hm. simpl in Hm. case_eq n. reflexivity. - intros. rewrite H in Hm. now contradict H. - intros m Hm. - case_eq m. intros. rewrite H in Hm. simpl in Hm. - now contradict Hm. - intros. rewrite H in Hm. simpl in Hm. - specialize (@IHn n0 Hm). now rewrite IHn. -Qed. - Lemma diseq_neg_eq: forall (la lb: list bool), List_diseqb la lb = true -> negb (RAWBITVECTOR_LIST.beq_list la lb) = true. Proof. intro la. @@ -1220,7 +1207,7 @@ Proof. rewrite Typ.N_cast_refl. simpl. generalize wt_t_atom. unfold Atom.wt. unfold is_true. - rewrite PArray.forallbi_spec;intros. + rewrite aforallbi_spec;intros. (* a *) pose proof (H a). @@ -1329,7 +1316,7 @@ Proof. intros a bs. case_eq u; try (intro Heq'; rewrite Heq' in H0; now contradict H0). intros. rewrite H2 in H0. - case_eq ((a == i2) && Nat_eqb i n1 && Nat_eqb n (N.to_nat n0)). intros Hif. + case_eq ((a == i2) && Nat.eqb i n1 && Nat.eqb n (N.to_nat n0)). intros Hif. rewrite Hif in H0. do 2 rewrite andb_true_iff in Hif. destruct Hif as ((Hif0 & Hif1) & Hif2). specialize (@IHys a (S i) n). @@ -1364,7 +1351,7 @@ Proof. intros a bs. rewrite Hif0. rewrite <- Hd. generalize wt_t_atom. unfold Atom.wt. unfold is_true. - rewrite PArray.forallbi_spec;intros. + rewrite aforallbi_spec;intros. assert (i1 < PArray.length t_atom). { apply PArray.get_not_default_lt. @@ -1414,8 +1401,8 @@ Proof. intros a bs. apply Typ.eqb_spec in H7. inversion H7. easy. - now apply Nat_eqb_eq in Hif2. - now apply Nat_eqb_eq in Hif1. + now apply Nat.eqb_eq in Hif2. + now apply Nat.eqb_eq in Hif1. omega. destruct H1. @@ -1527,7 +1514,7 @@ Proof. unfold Lit.interp. unfold Var.interp. destruct wf_rho. simpl. unfold Lit.blit. cut (0 >> 1 = 0). intros Heq0. rewrite Heq0. exact H. - now rewrite lsr_0_l. + now rewrite lsr0_l. apply is_even_0. Qed. @@ -1555,7 +1542,7 @@ Proof. intros l a H. rewrite H. unfold RAWBITVECTOR_LIST.bv_eq, RAWBITVECTOR_LIST.size, RAWBITVECTOR_LIST.bits in *. - rewrite RAWBITVECTOR_LIST.List_eq_refl; auto. + rewrite RAWBITVECTOR_LIST.List_eq_refl; auto with smtcoq_core. apply inj_iff in wf0. now do 2 rewrite id' in wf0. Qed. @@ -1761,7 +1748,7 @@ Proof. + simpl in Hcheck; now contradict Hcheck. + simpl in Hlen. inversion Hlen as [Hlen']. simpl in Hcheck. rewrite andb_true_iff in Hcheck; destruct Hcheck as (Hcheck1, Hcheck2). - apply Int63Properties.eqb_spec in Hcheck1; rewrite Hcheck1. + apply Int63.eqb_spec in Hcheck1; rewrite Hcheck1. simpl. rewrite Lit.interp_neg. apply f_equal. apply IHbs; auto. Qed. @@ -1806,7 +1793,7 @@ Proof. rewrite !andb_true_iff in Hc. destruct Hc as ((Ha, Hcheck), Hlen). rewrite N.eqb_eq in Hlen. - apply Int63Properties.eqb_spec in Ha. + apply Int63.eqb_spec in Ha. generalize (Hs pos). rewrite Hpos, Hnil. unfold C.valid, C.interp; simpl; rewrite !orb_false_r. @@ -1822,7 +1809,7 @@ Proof. generalize wt_t_atom. unfold Atom.wt. unfold is_true. - rewrite PArray.forallbi_spec;intros. + rewrite aforallbi_spec;intros. pose proof (H r). assert (r < PArray.length t_atom). @@ -1935,12 +1922,11 @@ Qed. Lemma to_list_two: forall {A:Type} (a: PArray.array A), PArray.length a = 2 -> (to_list a) = a .[0] :: a .[1] :: nil. Proof. intros A a H. - rewrite to_list_to_list_ntr. unfold to_list_ntr. + unfold to_list. rewrite H. - cut (0 == 2 = false). intro H1. - rewrite H1. - unfold foldi_ntr. rewrite foldi_cont_lt; auto. - auto. + rewrite 2!foldi_lt_r by reflexivity. + rewrite foldi_ge by reflexivity. + reflexivity. Qed. Lemma check_symopp_and: forall ibs1 ibs2 xbs1 ybs2 ibsres zbsres N, @@ -3238,7 +3224,7 @@ Proof. rewrite Atom.t_interp_wf; trivial. generalize wt_t_atom. unfold Atom.wt. unfold is_true. - rewrite PArray.forallbi_spec;intros. + rewrite aforallbi_spec;intros. pose proof (H a). assert (a < PArray.length t_atom). @@ -3571,7 +3557,7 @@ Proof. rewrite Atom.t_interp_wf; trivial. generalize wt_t_atom. unfold Atom.wt. unfold is_true. - rewrite PArray.forallbi_spec;intros. + rewrite aforallbi_spec;intros. pose proof (H a). assert (a < PArray.length t_atom). @@ -3903,7 +3889,7 @@ Proof. rewrite Atom.t_interp_wf; trivial. generalize wt_t_atom. unfold Atom.wt. unfold is_true. - rewrite PArray.forallbi_spec;intros. + rewrite aforallbi_spec;intros. pose proof (H a). assert (a < PArray.length t_atom). @@ -4531,7 +4517,7 @@ Lemma valid_check_bbEq pos1 pos2 lres : C.valid rho (check_bbEq pos1 pos2 lres). rewrite wf_interp_form; trivial. rewrite Heq8. simpl. generalize wt_t_atom. unfold Atom.wt. unfold is_true. - rewrite PArray.forallbi_spec;intros. + rewrite aforallbi_spec;intros. pose proof (H a3). assert (a3 < PArray.length t_atom). @@ -5187,7 +5173,7 @@ Proof. rewrite wf_interp_form; trivial. rewrite Heq8. simpl. generalize wt_t_atom. unfold Atom.wt. unfold is_true. - rewrite PArray.forallbi_spec;intros. + rewrite aforallbi_spec;intros. pose proof (H a3). assert (a3 < PArray.length t_atom). @@ -5412,7 +5398,7 @@ Proof. rewrite wf_interp_form; trivial. rewrite Heq8. simpl. generalize wt_t_atom. unfold Atom.wt. unfold is_true. - rewrite PArray.forallbi_spec;intros. + rewrite aforallbi_spec;intros. pose proof (H a3). assert (a3 < PArray.length t_atom). @@ -5824,7 +5810,7 @@ Proof. apply BITVECTOR_LIST.bv_eq_reflect. generalize wt_t_atom. unfold Atom.wt. unfold is_true. - rewrite PArray.forallbi_spec;intros. + rewrite aforallbi_spec;intros. pose proof (H a). assert (a < PArray.length t_atom). @@ -6272,7 +6258,7 @@ Proof. apply BITVECTOR_LIST.bv_eq_reflect. generalize wt_t_atom. unfold Atom.wt. unfold is_true. - rewrite PArray.forallbi_spec;intros. + rewrite aforallbi_spec;intros. pose proof (H a). assert (a < PArray.length t_atom). @@ -6304,7 +6290,7 @@ Proof. do 2 rewrite andb_true_iff in Heq11. destruct Heq11 as (Heq10, Heq11). destruct Heq10 as (Heq10a1 & Heq10a2). - rewrite Int63Properties.eqb_spec in Heq10a1; rewrite Heq10a1 in *. + rewrite Int63.eqb_spec in Heq10a1; rewrite Heq10a1 in *. (* interp_form_hatom_bv a = interp_bv t_i (interp_atom (t_atom .[a])) *) @@ -6558,8 +6544,8 @@ Proof. intros bs1. + unfold check_mult in H. now contradict H. - intros. unfold check_mult in H. - case_eq (Nat_eqb (Datatypes.length (a :: bs1)) ((Datatypes.length bs2))). - intros. now apply Nat_eqb_eq in H0. + case_eq (Nat.eqb (Datatypes.length (a :: bs1)) ((Datatypes.length bs2))). + intros. now apply Nat.eqb_eq in H0. intros. rewrite H0 in H. now contradict H. Qed. @@ -6583,7 +6569,7 @@ Lemma prop_main: forall bs1 bs2 bsres, map interp_carry (bblast_bvmult bs1 bs2 (Datatypes.length (map (Lit.interp rho) bs1))) = map (Lit.interp rho) bsres. Proof. intros. unfold check_mult in H. - case_eq (Nat_eqb (Datatypes.length bs1) (Datatypes.length bs2)). intros. + case_eq (Nat.eqb (Datatypes.length bs1) (Datatypes.length bs2)). intros. rewrite H0 in H. apply prop_eq_carry_lit2 in H. rewrite map_length. now rewrite H. @@ -6622,7 +6608,7 @@ Proof. generalize wt_t_atom. unfold Atom.wt. unfold is_true. - rewrite PArray.forallbi_spec;intros. + rewrite aforallbi_spec;intros. pose proof (H a). assert (a < PArray.length t_atom). @@ -6927,7 +6913,7 @@ Proof. apply BITVECTOR_LIST.bv_eq_reflect. generalize wt_t_atom. unfold Atom.wt. unfold is_true. - rewrite PArray.forallbi_spec;intros. + rewrite aforallbi_spec;intros. pose proof (H a). assert (a < PArray.length t_atom). @@ -7243,7 +7229,7 @@ Proof. apply BITVECTOR_LIST.bv_eq_reflect. generalize wt_t_atom. unfold Atom.wt. unfold is_true. - rewrite PArray.forallbi_spec;intros. + rewrite aforallbi_spec;intros. pose proof (H a). assert (a < PArray.length t_atom). @@ -7503,7 +7489,7 @@ Proof. apply BITVECTOR_LIST.bv_eq_reflect. generalize wt_t_atom. unfold Atom.wt. unfold is_true. - rewrite PArray.forallbi_spec;intros. + rewrite aforallbi_spec;intros. pose proof (H a). assert (a < PArray.length t_atom). @@ -7749,7 +7735,7 @@ Proof. apply BITVECTOR_LIST.bv_eq_reflect. generalize wt_t_atom. unfold Atom.wt. unfold is_true. - rewrite PArray.forallbi_spec;intros. + rewrite aforallbi_spec;intros. pose proof (H a). assert (a < PArray.length t_atom). @@ -7946,7 +7932,7 @@ Proof. intro bs1. - simpl in *. unfold check_shl in H. simpl in H. case_eq bs2; simpl; intros; subst. simpl in H. now contradict H. - simpl in *. inversion H0. rewrite H2, Structures.nat_eqb_refl in H. + simpl in *. inversion H0. rewrite H2, Nat.eqb_refl in H. case_eq (forallb2 eq_carry_lit (lit_to_carry (shl_lit_be (a :: bs1) (b :: l))) bsres); intros. + apply prop_eq_carry_lit2 in H1. rewrite prop_interp_carry3 in H1. @@ -8016,8 +8002,8 @@ Proof. intro bs1. induction bs1 as [ | xbs1 xsbs1 IHbs1 ]. - intros. simpl. unfold check_shl, shl_lit_be in H. - case_eq (Structures.nat_eqb (@length int []) (length bs2)); intros. - rewrite Structures.nat_eqb_eq in H0. + case_eq (Nat.eqb (@length int []) (length bs2)); intros. + rewrite Nat.eqb_eq in H0. rewrite <- H0 in H. simpl in H. rewrite nshl_lit_empty in H. case_eq bsres; intros. simpl. @@ -8025,7 +8011,7 @@ Proof. intro bs1. subst; now contradict H. rewrite H0 in H; now contradict H. - intros. unfold check_shl in H. - case_eq (Structures.nat_eqb (Datatypes.length (xbs1 :: xsbs1)) (Datatypes.length bs2)); intros. + case_eq (Nat.eqb (Datatypes.length (xbs1 :: xsbs1)) (Datatypes.length bs2)); intros. rewrite H0 in H. case_eq ( forallb2 eq_carry_lit (lit_to_carry (shl_lit_be (xbs1 :: xsbs1) bs2)) bsres); intros. @@ -8033,7 +8019,7 @@ Proof. intro bs1. rewrite prop_interp_carry3 in H1. unfold RAWBITVECTOR_LIST.bv_shl. - rewrite Structures.nat_eqb_eq in H0. + rewrite Nat.eqb_eq in H0. unfold RAWBITVECTOR_LIST.size. rewrite !map_length. rewrite H0, N.eqb_refl. now rewrite <- H1, shl_interp. @@ -8073,7 +8059,7 @@ Proof. apply BITVECTOR_LIST.bv_eq_reflect. generalize wt_t_atom. unfold Atom.wt. unfold is_true. - rewrite PArray.forallbi_spec;intros. + rewrite aforallbi_spec;intros. pose proof (H a). assert (a < PArray.length t_atom). @@ -8287,7 +8273,7 @@ Proof. intro bs1. - simpl in *. unfold check_shr in H. simpl in H. case_eq bs2; simpl; intros; subst. simpl in H. now contradict H. - simpl in *. inversion H0. rewrite H2, Structures.nat_eqb_refl in H. + simpl in *. inversion H0. rewrite H2, Nat.eqb_refl in H. case_eq (forallb2 eq_carry_lit (lit_to_carry (shr_lit_be (a :: bs1) (b :: l))) bsres); intros. + apply prop_eq_carry_lit2 in H1. rewrite prop_interp_carry3 in H1. @@ -8345,8 +8331,8 @@ Proof. intro bs1. induction bs1 as [ | xbs1 xsbs1 IHbs1 ]. - intros. simpl. unfold check_shr, shr_lit_be in H. - case_eq (Structures.nat_eqb (@length int []) (length bs2)); intros. - rewrite Structures.nat_eqb_eq in H0. + case_eq (Nat.eqb (@length int []) (length bs2)); intros. + rewrite Nat.eqb_eq in H0. rewrite <- H0 in H. simpl in H. rewrite nshr_lit_empty in H. case_eq bsres; intros. simpl. @@ -8354,7 +8340,7 @@ Proof. intro bs1. subst; now contradict H. rewrite H0 in H; now contradict H. - intros. unfold check_shr in H. - case_eq (Structures.nat_eqb (Datatypes.length (xbs1 :: xsbs1)) (Datatypes.length bs2)); intros. + case_eq (Nat.eqb (Datatypes.length (xbs1 :: xsbs1)) (Datatypes.length bs2)); intros. rewrite H0 in H. case_eq ( forallb2 eq_carry_lit (lit_to_carry (shr_lit_be (xbs1 :: xsbs1) bs2)) bsres); intros. @@ -8362,7 +8348,7 @@ Proof. intro bs1. rewrite prop_interp_carry3 in H1. unfold RAWBITVECTOR_LIST.bv_shr. - rewrite Structures.nat_eqb_eq in H0. + rewrite Nat.eqb_eq in H0. unfold RAWBITVECTOR_LIST.size. rewrite !map_length. rewrite H0, N.eqb_refl. now rewrite <- H1, shr_interp. @@ -8403,7 +8389,7 @@ Proof. apply BITVECTOR_LIST.bv_eq_reflect. generalize wt_t_atom. unfold Atom.wt. unfold is_true. - rewrite PArray.forallbi_spec;intros. + rewrite aforallbi_spec;intros. pose proof (H a). assert (a < PArray.length t_atom). diff --git a/src/classes/SMT_classes.v b/src/classes/SMT_classes.v index c6115c6..3ccd3c9 100644 --- a/src/classes/SMT_classes.v +++ b/src/classes/SMT_classes.v @@ -217,3 +217,12 @@ Section CompDec_from. Typ_compdec T CompDec_from. End CompDec_from. + + +(* Register constants for OCaml access *) +Register typ_compdec as SMTCoq.classes.SMT_classes.typ_compdec. +Register Typ_compdec as SMTCoq.classes.SMT_classes.Typ_compdec. +Register te_carrier as SMTCoq.classes.SMT_classes.te_carrier. +Register te_compdec as SMTCoq.classes.SMT_classes.te_compdec. +Register eqb_of_compdec as SMTCoq.classes.SMT_classes.eqb_of_compdec. +Register CompDec as SMTCoq.classes.SMT_classes.CompDec. diff --git a/src/classes/SMT_classes_instances.v b/src/classes/SMT_classes_instances.v index ac76a72..d5a9da9 100644 --- a/src/classes/SMT_classes_instances.v +++ b/src/classes/SMT_classes_instances.v @@ -13,7 +13,6 @@ Require Import Bool OrderedType BinPos ZArith OrderedTypeEx. Require Import Int63. Require Import State BVList FArray. -Require Structures. Require Export SMT_classes. @@ -253,7 +252,7 @@ Section Nat. Defined. Global Instance Nat_eqbtype : EqbType nat := - {| eqb := Structures.nat_eqb; eqb_spec := Structures.nat_eqb_eq |}. + {| eqb := Nat.eqb; eqb_spec := Nat.eqb_eq |}. Global Instance Nat_dec : DecType nat := EqbToDecType. @@ -475,7 +474,7 @@ Section Int63. Local Open Scope int63_scope. Let int_lt x y := - if Int63Native.ltb x y then True else False. + if x < y then True else False. Global Instance int63_ord : OrdType int. Proof. @@ -487,13 +486,13 @@ Section Int63. simpl; try easy. contradict H1. rewrite not_false_iff_true. - rewrite Int63Axioms.ltb_spec in *. + rewrite ltb_spec in *. exact (Z.lt_trans _ _ _ H H0). - intros x y. case_eq (x < y); intro; simpl; try easy. intros. - rewrite Int63Axioms.ltb_spec in *. - rewrite <- Int63Properties.to_Z_eq. + rewrite ltb_spec in *. + rewrite <- Misc.to_Z_eq. exact (Z.lt_neq _ _ H). Defined. @@ -504,19 +503,19 @@ Section Int63. intros x y. case_eq (x < y); intro; case_eq (x == y); intro; unfold lt in *; simpl. - - rewrite Int63Properties.eqb_spec in H0. + - rewrite Int63.eqb_spec in H0. contradict H0. assert (int_lt x y). unfold int_lt. rewrite H; trivial. remember lt_not_eq. unfold lt in *. simpl in n. exact (n _ _ H0). - apply LT. unfold int_lt. rewrite H; trivial. - - apply EQ. rewrite Int63Properties.eqb_spec in H0; trivial. + - apply EQ. rewrite Int63.eqb_spec in H0; trivial. - apply GT. unfold int_lt. case_eq (y < x); intro; simpl; try easy. - specialize (leb_ltb_eqb x y); intro. + specialize (Misc.leb_ltb_eqb x y); intro. contradict H2. - rewrite leb_negb_gtb. rewrite H1. simpl. + rewrite Misc.leb_negb_gtb. rewrite H1. simpl. red. intro. symmetry in H2. rewrite orb_true_iff in H2. destruct H2; contradict H2. rewrite H. auto. @@ -524,7 +523,7 @@ Section Int63. Defined. Global Instance int63_eqbtype : EqbType int := - {| eqb := Int63Native.eqb; eqb_spec := Int63Properties.eqb_spec |}. + {| eqb := Int63.eqb; eqb_spec := Int63.eqb_spec |}. Global Instance int63_dec : DecType int := EqbToDecType. @@ -748,3 +747,12 @@ Section prod. |}. End prod. + + +(* Register constants for OCaml access *) +Register unit_typ_compdec as SMTCoq.classes.SMT_classes_instances.unit_typ_compdec. +Register bool_compdec as SMTCoq.classes.SMT_classes_instances.bool_compdec. +Register Z_compdec as SMTCoq.classes.SMT_classes_instances.Z_compdec. +Register Positive_compdec as SMTCoq.classes.SMT_classes_instances.Positive_compdec. +Register BV_compdec as SMTCoq.classes.SMT_classes_instances.BV_compdec. +Register FArray_compdec as SMTCoq.classes.SMT_classes_instances.FArray_compdec. diff --git a/src/cnf/Cnf.v b/src/cnf/Cnf.v index 7618547..d98c3d6 100644 --- a/src/cnf/Cnf.v +++ b/src/cnf/Cnf.v @@ -23,48 +23,49 @@ Unset Strict Implicit. Definition or_of_imp args := let last := PArray.length args - 1 in - PArray.mapi (fun i l => if i == last then l else Lit.neg l) args. + amapi (fun i l => if i == last then l else Lit.neg l) args. (* Register or_of_imp as PrimInline. *) Lemma length_or_of_imp : forall args, PArray.length (or_of_imp args) = PArray.length args. -Proof. intro; unfold or_of_imp; apply length_mapi. Qed. +Proof. intro; unfold or_of_imp; apply length_amapi. Qed. Lemma get_or_of_imp : forall args i, i < (PArray.length args) - 1 -> (or_of_imp args).[i] = Lit.neg (args.[i]). Proof. unfold or_of_imp; intros args i H; case_eq (0 < PArray.length args). - intro Heq; rewrite get_mapi. + intro Heq; rewrite get_amapi. replace (i == PArray.length args - 1) with false; auto; symmetry; rewrite eqb_false_spec; intro; subst i; unfold is_true in H; rewrite ltb_spec, (to_Z_sub_1 _ _ Heq) in H; omega. rewrite ltb_spec; unfold is_true in H; rewrite ltb_spec, (to_Z_sub_1 _ _ Heq) in H; omega. rewrite ltb_negb_geb; case_eq (PArray.length args <= 0); try discriminate; intros Heq _; assert (H1: PArray.length args = 0). apply to_Z_inj; rewrite leb_spec in Heq; destruct (to_Z_bounded (PArray.length args)) as [H1 _]; change [|0|] with 0%Z in *; omega. rewrite !get_outofbound. - rewrite default_mapi, H1; auto. + rewrite default_amapi, H1; auto. rewrite H1; case_eq (i < 0); auto; intro H2; eelim ltb_0; eassumption. - rewrite length_mapi, H1; case_eq (i < 0); auto; intro H2; eelim ltb_0; eassumption. + rewrite length_amapi, H1; case_eq (i < 0); auto; intro H2; eelim ltb_0; eassumption. Qed. Lemma get_or_of_imp2 : forall args i, 0 < PArray.length args -> i = (PArray.length args) - 1 -> (or_of_imp args).[i] = args.[i]. Proof. - unfold or_of_imp; intros args i Heq Hi; rewrite get_mapi; subst i. - rewrite Int63Axioms.eqb_refl; auto. + unfold or_of_imp; intros args i Heq Hi; rewrite get_amapi; subst i. + rewrite Int63.eqb_refl; auto. rewrite ltb_spec, (to_Z_sub_1 _ _ Heq); omega. Qed. Lemma afold_right_impb p a : (forall x, p (Lit.neg x) = negb (p x)) -> (PArray.length a == 0) = false -> - (afold_right bool int true implb p a) = + (afold_right bool true implb (amap p a)) = List.existsb p (to_list (or_of_imp a)). Proof. intros Hp Hl. - case_eq (afold_right bool int true implb p a); intro Heq; symmetry. + case_eq (afold_right bool true implb (amap p a)); intro Heq; symmetry. - apply afold_right_implb_true_inv in Heq. + rewrite length_amap in Heq. destruct Heq as [Heq|[[i [Hi Heq]]|Heq]]. + rewrite Heq in Hl. discriminate. - + rewrite existsb_exists. exists (Lit.neg (a .[ i])). split. + + rewrite get_amap in Heq. rewrite existsb_exists. exists (Lit.neg (a .[ i])). split. * { apply (to_list_In_eq _ i). - rewrite length_or_of_imp. apply (ltb_trans _ (PArray.length a - 1)); auto. @@ -72,6 +73,8 @@ Proof. - now rewrite get_or_of_imp. } * now rewrite Hp, Heq. + * apply (ltb_trans _ (PArray.length a - 1)); auto. + now apply minus_1_lt. + rewrite existsb_exists. exists (a.[(PArray.length a) - 1]). split. * { apply (to_list_In_eq _ (PArray.length a - 1)). @@ -85,15 +88,19 @@ Proof. clear -H H1. change [|0|] with 0%Z. lia. } * { + specialize (Heq (PArray.length a - 1)); rewrite get_amap in Heq by now apply minus_1_lt. apply Heq. now apply minus_1_lt. } - apply afold_right_implb_false_inv in Heq. destruct Heq as [H1 [H2 H3]]. - case_eq (existsb p (to_list (or_of_imp a))); auto. + rewrite length_amap in H1, H3. + case_eq (List.existsb p (to_list (or_of_imp a))); auto. rewrite existsb_exists. intros [x [H4 H5]]. apply In_to_list in H4. destruct H4 as [i [H4 ->]]. case_eq (i < PArray.length a - 1); intro Heq. - + assert (H6 := H2 _ Heq). now rewrite (get_or_of_imp Heq), Hp, H6 in H5. + + specialize (H2 i). rewrite length_amap in H2. assert (H6 := H2 Heq). rewrite get_amap in H6. + now rewrite (get_or_of_imp Heq), Hp, H6 in H5. apply (ltb_trans _ (PArray.length a - 1)); auto. + now apply minus_1_lt. + assert (H6:i = PArray.length a - 1). { clear -H4 Heq H1. @@ -106,6 +113,7 @@ Proof. lia. } rewrite get_or_of_imp2 in H5; auto. + rewrite get_amap in H3 by now apply minus_1_lt. rewrite H6, H3 in H5. discriminate. Qed. @@ -140,17 +148,17 @@ Section CHECKER. Definition check_BuildDef l := match get_hash (Lit.blit l) with | Fand args => - if Lit.is_pos l then l :: List.map Lit.neg (PArray.to_list args) + if Lit.is_pos l then l :: List.map Lit.neg (to_list args) else C._true | For args => if Lit.is_pos l then C._true - else l :: PArray.to_list args + else l :: to_list args | Fimp args => if Lit.is_pos l then C._true else if PArray.length args == 0 then C._true else let args := or_of_imp args in - l :: PArray.to_list args + l :: to_list args | Fxor a b => if Lit.is_pos l then l::a::Lit.neg b::nil else l::a::b::nil @@ -180,15 +188,15 @@ Section CHECKER. match get_hash (Lit.blit l) with | Fand args => if Lit.is_pos l then C._true - else List.map Lit.neg (PArray.to_list args) + else List.map Lit.neg (to_list args) | For args => - if Lit.is_pos l then PArray.to_list args + if Lit.is_pos l then to_list args else C._true | Fimp args => if PArray.length args == 0 then C._true else if Lit.is_pos l then let args := or_of_imp args in - PArray.to_list args + to_list args else C._true | Fxor a b => if Lit.is_pos l then a::b::nil @@ -376,12 +384,12 @@ Section CHECKER. case_eq (i < PArray.length a);intros Hlt;auto using C.interp_true;simpl. - rewrite Lit.interp_nlit;unfold Var.interp;rewrite rho_interp, orb_false_r, H. simpl;rewrite afold_left_and. - case_eq (forallb (Lit.interp rho) (to_list a));trivial. + case_eq (List.forallb (Lit.interp rho) (to_list a));trivial. rewrite forallb_forall;intros Heq;rewrite Heq;trivial. apply to_list_In; auto. - rewrite Lit.interp_lit;unfold Var.interp;rewrite rho_interp, orb_false_r, H. simpl;rewrite afold_left_or. - unfold C.interp;case_eq (existsb (Lit.interp rho) (to_list a));trivial. + unfold C.interp;case_eq (List.existsb (Lit.interp rho) (to_list a));trivial. rewrite <-not_true_iff_false, existsb_exists, Lit.interp_neg. case_eq (Lit.interp rho (a .[ i]));trivial. intros Heq Hex;elim Hex;exists (a.[i]);split;trivial. @@ -405,7 +413,7 @@ Section CHECKER. by (intro H; apply Hl; now apply to_Z_inj). destruct (to_Z_bounded (PArray.length a)) as [H1 _]. lia. - + now rewrite Int63Properties.eqb_spec in Heq. + + now rewrite Int63.eqb_spec in Heq. } * now rewrite orb_true_r. + rewrite orb_false_r. @@ -487,7 +495,7 @@ Section CHECKER. existsb_exists;case_eq (Lit.interp rho (a .[ i]));trivial; intros Heq2 Hex;elim Hex. exists (a.[i]);split;trivial. - assert (H1: 0 < PArray.length a) by (apply (leb_ltb_trans _ i _); auto; apply leb_0); rewrite Int63Properties.eqb_spec in Heq'; rewrite <- (get_or_of_imp2 H1 Heq'); apply to_list_In; rewrite length_or_of_imp; auto. + assert (H1: 0 < PArray.length a) by (apply (leb_ltb_trans _ i _); auto; apply leb_0); rewrite Int63.eqb_spec in Heq'; rewrite <- (get_or_of_imp2 H1 Heq'); apply to_list_In; rewrite length_or_of_imp; auto. exists (Lit.neg (a.[i]));rewrite Lit.interp_neg, Heq2;split;trivial. assert (H1: i < PArray.length a - 1 = true) by (rewrite ltb_spec, (to_Z_sub_1 _ _ Hlt); rewrite eqb_false_spec in Heq'; assert (H1: [|i|] <> ([|PArray.length a|] - 1)%Z) by (intro H1; apply Heq', to_Z_inj; rewrite (to_Z_sub_1 _ _ Hlt); auto); rewrite ltb_spec in Hlt; omega); rewrite <- (get_or_of_imp H1); apply to_list_In; rewrite length_or_of_imp; auto. Qed. diff --git a/src/configure.sh b/src/configure.sh deleted file mode 100755 index 21b7232..0000000 --- a/src/configure.sh +++ /dev/null @@ -1,42 +0,0 @@ -#!/bin/sh - -pre=$(echo $0 | sed "s,\(\([^/]*/\)*\)[^/]*,\1,") - -rm -f ${pre}_CoqProject -rm -f ${pre}Makefile -rm -f ${pre}Makefile.conf -rm -f ${pre}Makefile.local -rm -f ${pre}smtcoq_plugin.ml4 -rm -f ${pre}versions/native/Structures.v -rm -f ${pre}g_smtcoq.ml4 -rm -f ${pre}smtcoq_plugin.mlpack -rm -f ${pre}Tactics.v -rm -f ${pre}versions/standard/Int63/Int63.v -rm -f ${pre}versions/standard/Int63/Int63Native.v -rm -f ${pre}versions/standard/Int63/Int63Op.v -rm -f ${pre}versions/standard/Int63/Int63Axioms.v -rm -f ${pre}versions/standard/Int63/Int63Properties.v -rm -f ${pre}versions/standard/Array/PArray.v -rm -f ${pre}versions/standard/Structures.v - -set -e -if [ $@ -a $@ = -native ]; then - cp ${pre}versions/native/Makefile ${pre}Makefile - cp ${pre}versions/native/smtcoq_plugin_native.ml4 ${pre}smtcoq_plugin.ml4 - cp ${pre}versions/native/Structures_native.v ${pre}versions/native/Structures.v - cp ${pre}versions/native/Tactics_native.v ${pre}Tactics.v -else - cp ${pre}versions/standard/_CoqProject ${pre}_CoqProject - cp ${pre}versions/standard/Makefile.local ${pre}Makefile.local - cp ${pre}versions/standard/g_smtcoq_standard.ml4 ${pre}g_smtcoq.ml4 - cp ${pre}versions/standard/smtcoq_plugin_standard.mlpack ${pre}smtcoq_plugin.mlpack - cp ${pre}versions/standard/Int63/Int63_standard.v ${pre}versions/standard/Int63/Int63.v - cp ${pre}versions/standard/Int63/Int63Native_standard.v ${pre}versions/standard/Int63/Int63Native.v - cp ${pre}versions/standard/Int63/Int63Op_standard.v ${pre}versions/standard/Int63/Int63Op.v - cp ${pre}versions/standard/Int63/Int63Axioms_standard.v ${pre}versions/standard/Int63/Int63Axioms.v - cp ${pre}versions/standard/Int63/Int63Properties_standard.v ${pre}versions/standard/Int63/Int63Properties.v - cp ${pre}versions/standard/Array/PArray_standard.v ${pre}versions/standard/Array/PArray.v - cp ${pre}versions/standard/Structures_standard.v ${pre}versions/standard/Structures.v - cp ${pre}versions/standard/Tactics_standard.v ${pre}Tactics.v - coq_makefile -f _CoqProject -o Makefile -fi diff --git a/src/euf/Euf.v b/src/euf/Euf.v index 83220c2..6b97f94 100644 --- a/src/euf/Euf.v +++ b/src/euf/Euf.v @@ -180,7 +180,7 @@ Section certif. apply C.interp_true. destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form);trivial. Qed. - Hint Resolve valid_C_true. + Hint Resolve valid_C_true : smtcoq_euf. Local Notation interp := (Atom.interp t_i t_func t_atom). @@ -210,11 +210,11 @@ Section certif. C.interp rho (get_eq (Lit.blit l) f). Proof. intros l f Hf;unfold get_eq. - case_eq (t_form.[Lit.blit l]);trivial;intros. - case_eq (t_atom.[i]);trivial;intros. - destruct b;trivial. + case_eq (t_form.[Lit.blit l]);trivial with smtcoq_euf;intros. + case_eq (t_atom.[i]);trivial with smtcoq_euf;intros. + destruct b;trivial with smtcoq_euf. generalize wt_t_atom;unfold Atom.wt;unfold is_true; - rewrite PArray.forallbi_spec;intros. + rewrite Misc.aforallbi_spec;intros. assert (i < length t_atom). apply PArray.get_not_default_lt. rewrite H0, def_t_atom;discriminate. @@ -279,48 +279,48 @@ Section certif. C.interp rho (check_trans_aux t1 t2 eqs res c). Proof. induction eqs;simpl;intros. - apply get_eq_interp;intros. + - apply get_eq_interp;intros. match goal with |- context [if ?b then _ else _] => case_eq b end; - intros;trivial. + intros;trivial with smtcoq_euf. simpl;rewrite Lit.interp_lit;unfold Var.interp. - destruct H1;[ | rewrite H1,orb_true_r;auto]. + destruct H1;[ | rewrite H1,orb_true_r;auto with smtcoq_euf smtcoq_core]. rewrite orb_true_iff, !andb_true_iff in H7;destruct H7 as [[H7 H8] | [H7 H8]]. rewrite eqb_spec in H7. rewrite eqb_spec in H8. subst. - tunicity. subst t. rewrite H4, H1;auto. + tunicity. subst t. rewrite H4, H1;auto with smtcoq_euf smtcoq_core. rewrite eqb_spec in H7. rewrite eqb_spec in H8. subst. - tunicity. subst t;rewrite interp_binop_eqb_sym in H1;rewrite H4, H1;auto. - apply get_eq_interp;intros. - destruct (Int63Properties.reflect_eqb t2 b);subst;tunicity; try subst t. - apply (IHeqs u);trivial. + tunicity. subst t;rewrite interp_binop_eqb_sym in H1;rewrite H4, H1;auto with smtcoq_euf smtcoq_core. + - apply get_eq_interp;intros. + destruct (Misc.reflect_eqb t2 b);subst;tunicity; try subst t. + + apply (IHeqs u);trivial. simpl;unfold is_true;rewrite orb_true_iff. rewrite Lit.interp_nlit;unfold Var.interp. - (* Attention ici on utilise la decidabilit'e de l'egalit'e sur u *) + (* Warning: here, we use decidability of equality over u *) case_eq (rho (Lit.blit a));[rewrite H4; intros | simpl;auto]. destruct H1;[left | auto]. apply interp_binop_eqb_trans with (4:= H1);trivial. rewrite interp_binop_eqb_sym;trivial. - destruct (Int63Properties.reflect_eqb t2 a0); subst;tunicity; try subst t. - apply (IHeqs u);trivial. + + destruct (Misc.reflect_eqb t2 a0); subst;tunicity; try subst t. + * apply (IHeqs u);trivial. simpl;unfold is_true;rewrite orb_true_iff. rewrite Lit.interp_nlit;unfold Var.interp. - (* Attention ici on utilise la decidabilit'e de l'egalit'e sur u *) + (* Warning: here, we use decidability of equality over u *) case_eq (rho (Lit.blit a));[rewrite H4; intros | simpl;auto]. destruct H1;[left | auto]. apply interp_binop_eqb_trans with (4:= H1);trivial. - destruct (Int63Properties.reflect_eqb t1 b);subst;tunicity; try subst t. - apply (IHeqs u);trivial. + * destruct (Misc.reflect_eqb t1 b);subst;tunicity; try subst t. + -- apply (IHeqs u);trivial. simpl;unfold is_true;rewrite orb_true_iff. rewrite Lit.interp_nlit;unfold Var.interp. - (* Attention ici on utilise la decidabilit'e de l'egalit'e sur u *) + (* Warning: here, we use decidability of equality over u *) case_eq (rho (Lit.blit a));[rewrite H4; intros | simpl;auto]. destruct H1;[left | auto]. apply interp_binop_eqb_trans with (5:= H1);trivial. - destruct (Int63Properties.reflect_eqb t1 a0);[subst;tunicity;try subst t|auto]. + -- destruct (Misc.reflect_eqb t1 a0);[subst;tunicity;try subst t|auto with smtcoq_euf smtcoq_core]. apply (IHeqs u);trivial. simpl;unfold is_true;rewrite orb_true_iff. rewrite Lit.interp_nlit;unfold Var.interp. - (* Attention ici on utilise la decidabilit'e de l'egalit'e sur u *) + (* Warning: here, we use decidability of equality over u *) case_eq (rho (Lit.blit a));[rewrite H4; intros | simpl;auto]. destruct H1;[left | auto]. apply interp_binop_eqb_trans with (5:= H1);trivial. @@ -332,9 +332,9 @@ Section certif. C.interp rho (check_trans res eqs). Proof. unfold check_trans;intros res [ | leq eqs]. - apply get_eq_interp;intros. - destruct (Int63Properties.reflect_eqb a b). - unfold C.interp; simpl; rewrite orb_false_r. + - apply get_eq_interp;intros. + destruct (Misc.reflect_eqb a b). + + unfold C.interp; simpl; rewrite orb_false_r. unfold Lit.interp; simpl; rewrite Lit.is_pos_lit. unfold Var.interp; simpl; rewrite Lit.blit_lit. rewrite H1. @@ -344,12 +344,12 @@ Section certif. unfold Atom.interp_hatom. rewrite HHb;simpl;rewrite Typ.cast_refl;simpl. apply Typ.i_eqb_refl. - auto. - apply get_eq_interp;intros. + + auto with smtcoq_euf. + - apply get_eq_interp;intros. apply check_trans_aux_correct with t;trivial. simpl;rewrite Lit.interp_nlit;unfold Var.interp. rewrite <- H1. (* Attention ici on utilise la decidabilit'e de l'egalit'e sur t *) - destruct (rho (Lit.blit leq));auto. + destruct (rho (Lit.blit leq));auto with smtcoq_core. Qed. Inductive Forall2 A B (P:A->B->Prop) : list A -> list B -> Prop := @@ -362,16 +362,16 @@ Section certif. (Forall2 _ _ (fun a b => interp_hatom a = interp_hatom b) l r -> C.interp rho c) -> C.interp rho (build_congr lp l r c). Proof. - induction lp;destruct l;destruct r;simpl;trivial;intros. + induction lp;destruct l;destruct r;simpl;trivial with smtcoq_euf smtcoq_core;intros. apply H;constructor. destruct a. apply get_eq_interp;intros. match goal with |- context [if ?x then _ else _] => - case_eq x;intros;auto end. + case_eq x;intros;auto with smtcoq_euf smtcoq_core end. apply IHlp;simpl;intros. rewrite Lit.interp_nlit;unfold Var.interp. - case_eq (rho (Lit.blit i1));intros;simpl;[ | auto]. - apply H;constructor;trivial. + case_eq (rho (Lit.blit i1));intros;simpl;[ | auto with smtcoq_euf smtcoq_core]. + apply H;constructor;trivial with smtcoq_euf smtcoq_core. generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom b). rewrite Typ.eqb_spec in H3. rewrite Typ.eqb_spec in H4. unfold Atom.get_type in H3, H4. rewrite H3,H4. intros [va HHa] [vb HHb]. revert H7;rewrite H2;unfold Atom.apply_binop; simpl. unfold Atom.interp_hatom. @@ -381,11 +381,11 @@ Section certif. rewrite orb_true_iff, !andb_true_iff in H5;destruct H5 as [ [H5 H7] | [H5 H7]]. rewrite eqb_spec in H5. rewrite eqb_spec in H7. subst. - rewrite HHa, HHb;trivial. + rewrite HHa, HHb;trivial with smtcoq_euf smtcoq_core. rewrite eqb_spec in H5. rewrite eqb_spec in H7. subst. - rewrite HHa, HHb;trivial. - destruct (Int63Properties.reflect_eqb i i0);[subst | auto]. - apply IHlp;intros;apply H;constructor;auto. + rewrite HHa, HHb;trivial with smtcoq_euf smtcoq_core. + destruct (Misc.reflect_eqb i i0);[subst | auto with smtcoq_euf smtcoq_core]. + apply IHlp;intros;apply H;constructor;auto with smtcoq_euf smtcoq_core. Qed. Lemma valid_check_congr : @@ -393,71 +393,71 @@ Section certif. C.interp rho (check_congr leq eqs). Proof. unfold check_congr;intros leq eqs;apply get_eq_interp;intros. - case_eq (t_atom .[ a]);intros;auto; - case_eq (t_atom .[ b]);intros;auto. + case_eq (t_atom .[ a]);intros;auto with smtcoq_euf smtcoq_core; + case_eq (t_atom .[ b]);intros;auto with smtcoq_euf smtcoq_core. (* uop *) - destruct (Atom.reflect_uop_eqb u u0);[subst | auto]. + destruct (Atom.reflect_uop_eqb u u0);[subst | auto with smtcoq_euf smtcoq_core]. apply build_congr_correct;intros. simpl;rewrite Lit.interp_lit, orb_false_r;unfold Var.interp. rewrite H1. generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom b). rewrite Typ.eqb_spec in H2. rewrite Typ.eqb_spec in H3. unfold Atom.get_type in H2, H3. rewrite H2,H3. intros [va HHa] [vb HHb]. unfold Atom.apply_binop;unfold Atom.interp_hatom;simpl. rewrite HHb, HHa. simpl. - rewrite Atom.t_interp_wf in HHa; auto. rewrite H4 in HHa. simpl in HHa. - rewrite Atom.t_interp_wf in HHb; auto. rewrite H5 in HHb. simpl in HHb. + rewrite Atom.t_interp_wf in HHa; auto with smtcoq_euf smtcoq_core. rewrite H4 in HHa. simpl in HHa. + rewrite Atom.t_interp_wf in HHb; auto with smtcoq_euf smtcoq_core. rewrite H5 in HHb. simpl in HHb. rewrite Typ.cast_refl;simpl. assert (Atom.Bval t_i t va = Atom.Bval t_i t vb). inversion H6;subst. unfold Atom.interp_hatom in H10. - rewrite <- HHa; rewrite <- HHb, H10;trivial. + rewrite <- HHa; rewrite <- HHb, H10;trivial with smtcoq_euf smtcoq_core. inversion H7. - apply Eqdep_dec.inj_pair2_eq_dec in H9;trivial. + apply Eqdep_dec.inj_pair2_eq_dec in H9;trivial with smtcoq_euf smtcoq_core. rewrite H9. apply Typ.i_eqb_refl. - intros x y;destruct (Typ.reflect_eqb x y);auto. + intros x y;destruct (Typ.reflect_eqb x y);auto with smtcoq_euf smtcoq_core. (* bop *) - destruct (Atom.reflect_bop_eqb b0 b1);[subst | auto]. + destruct (Atom.reflect_bop_eqb b0 b1);[subst | auto with smtcoq_euf smtcoq_core]. apply build_congr_correct;intros. simpl;rewrite Lit.interp_lit, orb_false_r;unfold Var.interp. rewrite H1. generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom b). rewrite Typ.eqb_spec in H2. rewrite Typ.eqb_spec in H3. unfold Atom.get_type in H2, H3. rewrite H2,H3. intros [va HHa] [vb HHb]. unfold Atom.apply_binop. unfold Atom.interp_hatom;simpl. rewrite HHb, HHa;simpl. - rewrite Atom.t_interp_wf in HHa; auto. rewrite H4 in HHa. simpl in HHa. - rewrite Atom.t_interp_wf in HHb; auto. rewrite H5 in HHb. simpl in HHb. + rewrite Atom.t_interp_wf in HHa; auto with smtcoq_euf smtcoq_core. rewrite H4 in HHa. simpl in HHa. + rewrite Atom.t_interp_wf in HHb; auto with smtcoq_euf smtcoq_core. rewrite H5 in HHb. simpl in HHb. rewrite Typ.cast_refl;simpl. assert (Atom.Bval t_i t va = Atom.Bval t_i t vb). inversion H6;clear H6;subst. inversion H12;clear H12;subst. unfold Atom.interp_hatom in H10, H8. - rewrite <- HHa. rewrite <- HHb, H10, H8;trivial. + rewrite <- HHa. rewrite <- HHb, H10, H8;trivial with smtcoq_euf smtcoq_core. inversion H7. - apply Eqdep_dec.inj_pair2_eq_dec in H9;trivial. + apply Eqdep_dec.inj_pair2_eq_dec in H9;trivial with smtcoq_euf smtcoq_core. rewrite H9. apply Typ.i_eqb_refl. - intros x y;destruct (Typ.reflect_eqb x y);auto. + intros x y;destruct (Typ.reflect_eqb x y);auto with smtcoq_euf smtcoq_core. (* op *) - destruct (Int63Properties.reflect_eqb i i0);[subst | auto]. + destruct (Misc.reflect_eqb i i0);[subst | auto with smtcoq_euf smtcoq_core]. apply build_congr_correct;intros. simpl;rewrite Lit.interp_lit, orb_false_r;unfold Var.interp. rewrite H1. generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom b). rewrite Typ.eqb_spec in H2. rewrite Typ.eqb_spec in H3. unfold Atom.get_type in H2, H3. rewrite H2,H3. intros [va HHa] [vb HHb]. unfold Atom.apply_binop;unfold Atom.interp_hatom;simpl. rewrite HHb, HHa;simpl. - rewrite Atom.t_interp_wf in HHa; auto. rewrite H4 in HHa. simpl in HHa. - rewrite Atom.t_interp_wf in HHb; auto. rewrite H5 in HHb. simpl in HHb. + rewrite Atom.t_interp_wf in HHa; auto with smtcoq_euf smtcoq_core. rewrite H4 in HHa. simpl in HHa. + rewrite Atom.t_interp_wf in HHb; auto with smtcoq_euf smtcoq_core. rewrite H5 in HHb. simpl in HHb. rewrite Typ.cast_refl;simpl. assert (Atom.Bval t_i t va = Atom.Bval t_i t vb). rewrite <- HHa;rewrite <- HHb;destruct (t_func.[i0]). apply f_equal;clear HHa HHb va vb H5 H4. - induction H6;simpl;trivial. + induction H6;simpl;trivial with smtcoq_euf smtcoq_core. unfold Atom.interp_hatom in H4. - rewrite IHForall2, H4;trivial. + rewrite IHForall2, H4;trivial with smtcoq_euf smtcoq_core. inversion H7. - apply Eqdep_dec.inj_pair2_eq_dec in H9;trivial. + apply Eqdep_dec.inj_pair2_eq_dec in H9;trivial with smtcoq_euf smtcoq_core. rewrite H9. apply Typ.i_eqb_refl. - intros x y;destruct (Typ.reflect_eqb x y);auto. + intros x y;destruct (Typ.reflect_eqb x y);auto with smtcoq_euf smtcoq_core. Qed. Lemma valid_check_congr_pred : @@ -465,18 +465,18 @@ Section certif. C.interp rho (check_congr_pred lpa lpb eqs). Proof. unfold check_congr_pred;intros. - case_eq (t_form.[Lit.blit lpa]);auto. - case_eq (t_form.[Lit.blit lpb]);auto;intros. - case_eq (t_atom.[i0]);auto; case_eq (t_atom.[i]);auto;intros. + case_eq (t_form.[Lit.blit lpa]);auto with smtcoq_euf smtcoq_core. + case_eq (t_form.[Lit.blit lpb]);auto with smtcoq_euf smtcoq_core;intros. + case_eq (t_atom.[i0]);auto with smtcoq_euf smtcoq_core; case_eq (t_atom.[i]);auto with smtcoq_euf smtcoq_core;intros. (* uop *) - destruct (Atom.reflect_uop_eqb u0 u);[subst | auto]. + destruct (Atom.reflect_uop_eqb u0 u);[subst | auto with smtcoq_euf smtcoq_core]. apply build_congr_correct;simpl;intros. rewrite orb_false_r, Lit.interp_lit, Lit.interp_nlit;unfold Var.interp. replace (rho (Lit.blit lpb)) with (rho (Lit.blit lpa)). destruct (rho (Lit.blit lpa));reflexivity. rewrite !wf_interp_form, H, H0;simpl. generalize wt_t_atom;unfold Atom.wt;unfold is_true; - rewrite PArray.forallbi_spec;intros. + rewrite Misc.aforallbi_spec;intros. assert (i < length t_atom). apply PArray.get_not_default_lt. rewrite H1, def_t_atom;discriminate. @@ -485,19 +485,19 @@ Section certif. rewrite H2, def_t_atom;discriminate. apply H4 in H5;apply H4 in H6;clear H4. unfold Atom.interp_form_hatom, Atom.interp_hatom;simpl. - rewrite !Atom.t_interp_wf, H1, H2;simpl;trivial. + rewrite !Atom.t_interp_wf, H1, H2;simpl;trivial with smtcoq_euf smtcoq_core. apply f_equal;apply f_equal. - inversion H3;clear H3;subst;trivial. + inversion H3;clear H3;subst;trivial with smtcoq_euf smtcoq_core. (* bop *) - destruct (Atom.reflect_bop_eqb b0 b);[subst | auto]. + destruct (Atom.reflect_bop_eqb b0 b);[subst | auto with smtcoq_euf smtcoq_core]. apply build_congr_correct;simpl;intros. rewrite orb_false_r, Lit.interp_lit, Lit.interp_nlit;unfold Var.interp. replace (rho (Lit.blit lpb)) with (rho (Lit.blit lpa)). destruct (rho (Lit.blit lpa));reflexivity. rewrite !wf_interp_form, H, H0;simpl. generalize wt_t_atom;unfold Atom.wt;unfold is_true; - rewrite PArray.forallbi_spec;intros. + rewrite Misc.aforallbi_spec;intros. assert (i < length t_atom). apply PArray.get_not_default_lt. rewrite H1, def_t_atom. discriminate. @@ -506,20 +506,20 @@ Section certif. rewrite H2, def_t_atom;discriminate. apply H4 in H5;apply H4 in H6;clear H4. unfold Atom.interp_form_hatom, Atom.interp_hatom;simpl. - rewrite !Atom.t_interp_wf, H1, H2;simpl;trivial. + rewrite !Atom.t_interp_wf, H1, H2;simpl;trivial with smtcoq_euf smtcoq_core. inversion H3;clear H3;subst. inversion H11;clear H11;subst. - apply f_equal; apply f_equal2;trivial. + apply f_equal; apply f_equal2;trivial with smtcoq_euf smtcoq_core. (* op *) - destruct (Int63Properties.reflect_eqb i2 i1);[subst | auto]. + destruct (Misc.reflect_eqb i2 i1);[subst | auto with smtcoq_euf smtcoq_core]. apply build_congr_correct;simpl;intros. rewrite orb_false_r, Lit.interp_lit, Lit.interp_nlit;unfold Var.interp. replace (rho (Lit.blit lpb)) with (rho (Lit.blit lpa)). destruct (rho (Lit.blit lpa));reflexivity. rewrite !wf_interp_form, H, H0;simpl. generalize wt_t_atom;unfold Atom.wt;unfold is_true; - rewrite PArray.forallbi_spec;intros. + rewrite Misc.aforallbi_spec;intros. assert (i < length t_atom). apply PArray.get_not_default_lt. rewrite H1, def_t_atom;discriminate. @@ -528,11 +528,11 @@ Section certif. rewrite H2, def_t_atom;discriminate. apply H4 in H5;apply H4 in H6;clear H4. unfold Atom.interp_form_hatom, Atom.interp_hatom;simpl. - rewrite !Atom.t_interp_wf, H1, H2;simpl;trivial. + rewrite !Atom.t_interp_wf, H1, H2;simpl;trivial with smtcoq_euf smtcoq_core. apply f_equal;destruct (t_func.[i1]);apply f_equal. clear H H0 H1 H2 H5 H6. - induction H3;simpl;trivial. - unfold Atom.interp_hatom in H;rewrite H, IHForall2;trivial. + induction H3;simpl;trivial with smtcoq_euf smtcoq_core. + unfold Atom.interp_hatom in H;rewrite H, IHForall2;trivial with smtcoq_euf smtcoq_core. Qed. End Proof. diff --git a/src/extraction/Makefile b/src/extraction/Makefile index 73b0ae4..354dd53 100644 --- a/src/extraction/Makefile +++ b/src/extraction/Makefile @@ -15,7 +15,7 @@ COQTOP=$(COQBIN)../ FLAGS=-rectypes COMPILEFLAGS=-cclib -lunix -SMTLIB=-I .. -I ../zchaff -I ../verit -I ../trace -I ../smtlib2 -I ../lia -I ../euf -I ../cnf -I ../versions/native/ +SMTLIB=-I .. -I ../zchaff -I ../verit -I ../trace -I ../smtlib2 -I ../lia -I ../euf -I ../cnf -I ../../3rdparty/alt-ergo COQLIB=-I ${COQTOP}kernel -I ${COQTOP}lib -I ${COQTOP}library -I ${COQTOP}parsing -I ${COQTOP}pretyping -I ${COQTOP}interp -I ${COQTOP}proofs -I ${COQTOP}tactics -I ${COQTOP}toplevel -I ${COQTOP}plugins/btauto -I ${COQTOP}plugins/cc -I ${COQTOP}plugins/decl_mode -I ${COQTOP}plugins/extraction -I ${COQTOP}plugins/field -I ${COQTOP}plugins/firstorder -I ${COQTOP}plugins/fourier -I ${COQTOP}plugins/funind -I ${COQTOP}plugins/micromega -I ${COQTOP}plugins/nsatz -I ${COQTOP}plugins/omega -I ${COQTOP}plugins/quote -I ${COQTOP}plugins/ring -I ${COQTOP}plugins/romega -I ${COQTOP}plugins/rtauto -I ${COQTOP}plugins/setoid_ring -I ${COQTOP}plugins/syntax -I ${COQTOP}plugins/xml -I /usr/lib/ocaml/camlp5 CMXA=nums.cmxa str.cmxa unix.cmxa gramlib.cmxa dynlink.cmxa ${COQTOP}kernel/byterun/coq_fix_code.o ${COQTOP}kernel/byterun/coq_interp.o ${COQTOP}kernel/byterun/coq_memory.o ${COQTOP}kernel/byterun/coq_values.o clib.cmxa lib.cmxa kernel.cmxa library.cmxa pretyping.cmxa interp.cmxa proofs.cmxa parsing.cmxa tactics.cmxa toplevel.cmxa micromega_plugin.cmxa smtcoq.cmxa diff --git a/src/extraction/verit_checker.mli b/src/extraction/verit_checker.mli index b24532e..6247001 100644 --- a/src/extraction/verit_checker.mli +++ b/src/extraction/verit_checker.mli @@ -10,7 +10,7 @@ (**************************************************************************) -module Mc = Structures.Micromega_plugin_Certificate.Mc +module Mc = CoqInterface.Micromega_plugin_Certificate.Mc val mkInt : int -> ExtrNative.uint val mkArray : 'a array -> 'a ExtrNative.parray val dump_nat : Mc.nat -> Smt_checker.nat @@ -25,7 +25,7 @@ val to_coq : 'a SmtCertif.clause -> Smt_checker.Euf_Checker.step ExtrNative.parray ExtrNative.parray * 'a SmtCertif.clause -val btype_to_coq : SmtAtom.btype -> Smt_checker.Typ.coq_type +val btype_to_coq : SmtBtype.btype -> Smt_checker.Typ.coq_type val c_to_coq : SmtAtom.cop -> Smt_checker.Atom.cop val u_to_coq : SmtAtom.uop -> Smt_checker.Atom.unop val b_to_coq : SmtAtom.bop -> Smt_checker.Atom.binop @@ -42,7 +42,7 @@ val form_interp_tbl : SmtAtom.Form.reify -> Smt_checker.Form.form ExtrNative.parray val count_btype : int ref val count_op : int ref -val declare_sort : Smtlib2_ast.symbol -> SmtAtom.btype +val declare_sort : Smtlib2_ast.symbol -> SmtBtype.btype val declare_fun : Smtlib2_ast.symbol -> Smtlib2_ast.sort list -> Smtlib2_ast.sort -> SmtAtom.indexed_op diff --git a/src/versions/standard/g_smtcoq_standard.ml4 b/src/g_smtcoq.mlg index ecc2416..7b8093b 100644 --- a/src/versions/standard/g_smtcoq_standard.ml4 +++ b/src/g_smtcoq.mlg @@ -12,80 +12,82 @@ DECLARE PLUGIN "smtcoq_plugin" -open Stdarg +{ -(* This is requires since Coq 8.7 because the Ltac machinery became a - plugin - see: https://lists.gforge.inria.fr/pipermail/coq-commits/2017-February/021276.html *) +open Stdarg open Ltac_plugin +} + VERNAC COMMAND EXTEND Vernac_zchaff CLASSIFIED AS QUERY | [ "Parse_certif_zchaff" ident(dimacs) ident(trace) string(fdimacs) string(fproof) ] -> - [ + { Zchaff.parse_certif dimacs trace fdimacs fproof - ] + } | [ "Zchaff_Checker" string(fdimacs) string(fproof) ] -> - [ + { Zchaff.checker fdimacs fproof - ] + } | [ "Zchaff_Theorem" ident(name) string(fdimacs) string(fproof) ] -> - [ + { Zchaff.theorem name fdimacs fproof - ] + } END VERNAC COMMAND EXTEND Vernac_verit CLASSIFIED AS QUERY | [ "Parse_certif_verit" ident(t_i) ident(t_func) ident(t_atom) ident(t_form) ident(root) ident(used_roots) ident(trace) string(fsmt) string(fproof) ] -> - [ + { Verit.parse_certif t_i t_func t_atom t_form root used_roots trace fsmt fproof - ] + } | [ "Verit_Checker" string(fsmt) string(fproof) ] -> - [ + { Verit.checker fsmt fproof - ] + } | [ "Verit_Checker_Debug" string(fsmt) string(fproof) ] -> - [ + { Verit.checker_debug fsmt fproof - ] + } | [ "Verit_Theorem" ident(name) string(fsmt) string(fproof) ] -> - [ + { Verit.theorem name fsmt fproof - ] + } END VERNAC COMMAND EXTEND Vernac_lfsc CLASSIFIED AS QUERY | [ "Parse_certif_lfsc" ident(t_i) ident(t_func) ident(t_atom) ident(t_form) ident(root) ident(used_roots) ident(trace) string(fsmt) string(fproof) ] -> - [ + { Lfsc.parse_certif t_i t_func t_atom t_form root used_roots trace fsmt fproof - ] + } | [ "Lfsc_Checker" string(fsmt) string(fproof) ] -> - [ + { Lfsc.checker fsmt fproof - ] + } | [ "Lfsc_Checker_Debug" string(fsmt) string(fproof) ] -> - [ + { Lfsc.checker_debug fsmt fproof - ] + } | [ "Lfsc_Theorem" ident(name) string(fsmt) string(fproof) ] -> - [ + { Lfsc.theorem name fsmt fproof - ] + } END TACTIC EXTEND Tactic_zchaff -| [ "zchaff_bool" ] -> [ Zchaff.tactic () ] -| [ "zchaff_bool_no_check" ] -> [ Zchaff.tactic_no_check () ] +| [ "zchaff_bool" ] -> { Zchaff.tactic () } +| [ "zchaff_bool_no_check" ] -> { Zchaff.tactic_no_check () } END +{ + let lemmas_list = Summary.ref ~name:"Selected lemmas" [] let cache_lemmas (_, lems) = lemmas_list := lems -let declare_lemmas : Structures.constr_expr list -> Libobject.obj = +let declare_lemmas : CoqInterface.constr_expr list -> Libobject.obj = let open Libobject in declare_object { @@ -102,18 +104,20 @@ let clear_lemmas () = let get_lemmas () = !lemmas_list +} + VERNAC COMMAND EXTEND Add_lemma CLASSIFIED AS SIDEFF -| [ "Add_lemmas" constr_list(lems) ] -> [ add_lemmas lems ] -| [ "Clear_lemmas" ] -> [ clear_lemmas () ] +| [ "Add_lemmas" constr_list(lems) ] -> { add_lemmas lems } +| [ "Clear_lemmas" ] -> { clear_lemmas () } END TACTIC EXTEND Tactic_verit -| [ "verit_bool_base" constr(lpl) ] -> [ Verit.tactic lpl (get_lemmas ()) ] -| [ "verit_bool_no_check_base" constr(lpl) ] -> [ Verit.tactic_no_check lpl (get_lemmas ()) ] +| [ "verit_bool_base" constr(lpl) ] -> { Verit.tactic lpl (get_lemmas ()) } +| [ "verit_bool_no_check_base" constr(lpl) ] -> { Verit.tactic_no_check lpl (get_lemmas ()) } END TACTIC EXTEND Tactic_cvc4 -| [ "cvc4_bool" ] -> [ Lfsc.tactic () ] -| [ "cvc4_bool_no_check" ] -> [ Lfsc.tactic_no_check () ] +| [ "cvc4_bool" ] -> { Lfsc.tactic () } +| [ "cvc4_bool_no_check" ] -> { Lfsc.tactic_no_check () } END diff --git a/src/lfsc/ast.ml b/src/lfsc/ast.ml index 7c2cd8f..d231dc6 100644 --- a/src/lfsc/ast.ml +++ b/src/lfsc/ast.ml @@ -198,7 +198,7 @@ let compare_symbol s1 s2 = match s1.sname, s2.sname with | Name n1, Name n2 -> Hstring.compare n1 n2 | Name _, _ -> -1 | _, Name _ -> 1 - | S_Hole i1, S_Hole i2 -> Pervasives.compare i1 i2 + | S_Hole i1, S_Hole i2 -> Stdlib.compare i1 i2 let rec compare_term ?(mod_eq=false) t1 t2 = match t1.value, t2.value with @@ -250,7 +250,7 @@ let rec compare_term ?(mod_eq=false) t1 t2 = match t1.value, t2.value with | SideCond (_, _, _, t), _ -> compare_term ~mod_eq t t2 | _, SideCond (_, _, _, t) -> compare_term ~mod_eq t1 t - | Hole i1, Hole i2 -> Pervasives.compare i1 i2 + | Hole i1, Hole i2 -> Stdlib.compare i1 i2 and compare_term_list ?(mod_eq=false) l1 l2 = match l1, l2 with diff --git a/src/lfsc/builtin.ml b/src/lfsc/builtin.ml index e528db3..3ee5f33 100644 --- a/src/lfsc/builtin.ml +++ b/src/lfsc/builtin.ml @@ -616,7 +616,7 @@ let cong s1 s2 a1 b1 a2 b2 u1 u2 = module MInt = Map.Make (struct type t = int - let compare = Pervasives.compare + let compare = Stdlib.compare end) module STerm = Set.Make (Term) diff --git a/src/lfsc/lfsc.ml b/src/lfsc/lfsc.ml index 906340d..10e40ed 100644 --- a/src/lfsc/lfsc.ml +++ b/src/lfsc/lfsc.ml @@ -57,7 +57,7 @@ let process_signatures_once = ) signatures with | Ast.TypingError (t1, t2) -> - Structures.error + CoqInterface.error (asprintf "@[<hov>LFSC typing error: expected %a, got %a@]@." Ast.print_term t1 Ast.print_term t2) @@ -116,7 +116,7 @@ let import_trace first parse lexbuf = with | Ast.TypingError (t1, t2) -> - Structures.error + CoqInterface.error (asprintf "@[<hov>LFSC typing error: expected %a, got %a@]@." Ast.print_term t1 Ast.print_term t2) @@ -386,13 +386,13 @@ let call_cvc4 env rt ro ra rf root _ = begin try get_proof cvc4 (import_trace (Some root) lfsc_parse_one) with - | Ast.CVC4Sat -> Structures.error "CVC4 returned SAT" - | No_proof -> Structures.error "CVC4 did not generate a proof" - | Failure s -> Structures.error ("Importing of proof failed: " ^ s) + | Ast.CVC4Sat -> CoqInterface.error "CVC4 returned SAT" + | No_proof -> CoqInterface.error "CVC4 did not generate a proof" + | Failure s -> CoqInterface.error ("Importing of proof failed: " ^ s) end | Sat -> let smodel = get_model cvc4 in - Structures.error + CoqInterface.error ("CVC4 returned sat. Here is the model:\n\n" ^ SmtCommands.model_string env rt ro ra rf smodel) (* (asprintf "CVC4 returned sat. Here is the model:\n%a" SExpr.print smodel) *) @@ -435,7 +435,7 @@ let get_model_from_file filename = let lexbuf = Lexing.from_channel chan in match SExprParser.sexps SExprLexer.main lexbuf with | [SExpr.Atom "sat"; m] -> m - | _ -> Structures.error "CVC4 returned SAT but no model" + | _ -> CoqInterface.error "CVC4 returned SAT but no model" let call_cvc4_file env rt ro ra rf root = @@ -467,17 +467,17 @@ let call_cvc4_file env rt ro ra rf root = eprintf "CVC4 = %.5f@." (t1-.t0); if exit_code <> 0 then - Structures.error ("CVC4 crashed: return code "^string_of_int exit_code); + CoqInterface.error ("CVC4 crashed: return code "^string_of_int exit_code); (* ignore (Sys.command clean_cmd); *) try import_trace_from_file (Some root) prooffilename with - | No_proof -> Structures.error "CVC4 did not generate a proof" - | Failure s -> Structures.error ("Importing of proof failed: " ^ s) + | No_proof -> CoqInterface.error "CVC4 did not generate a proof" + | Failure s -> CoqInterface.error ("Importing of proof failed: " ^ s) | Ast.CVC4Sat -> let smodel = get_model_from_file prooffilename in - Structures.error + CoqInterface.error ("CVC4 returned sat. Here is the model:\n\n" ^ SmtCommands.model_string env rt ro ra rf smodel) diff --git a/src/lfsc/shashcons.mli b/src/lfsc/shashcons.mli index 6787322..e9ba5fb 100644 --- a/src/lfsc/shashcons.mli +++ b/src/lfsc/shashcons.mli @@ -47,6 +47,7 @@ module type S = val iter : (t -> unit) -> unit (** [iter f] iterates [f] over all elements of the table . *) + val stats : unit -> int * int * int * int * int * int (** Return statistics on the table. The numbers are, in order: table length, number of entries, sum of bucket lengths, @@ -83,6 +84,7 @@ module type S_consed = val iter : (key hash_consed -> unit) -> unit (** [iter f] iterates [f] over all elements of the table . *) + val stats : unit -> int * int * int * int * int * int (** Return statistics on the table. The numbers are, in order: table length, number of entries, sum of bucket lengths, diff --git a/src/lia/Lia.v b/src/lia/Lia.v index 316f647..0246799 100644 --- a/src/lia/Lia.v +++ b/src/lia/Lia.v @@ -10,7 +10,7 @@ (**************************************************************************) -Require Import Bool List Int63 PArray ZArith. +Require Import Bool List Int63 Ring63 PArray ZArith. Require Import Misc State SMT_terms Euf. Require Import RingMicromega ZMicromega Tauto Psatz. @@ -44,10 +44,10 @@ Section certif. End BuildPositive. Definition build_positive := - foldi_down_cont + foldi (fun i cont h => build_positive_atom_aux cont (get_atom h)) - (PArray.length t_atom) 0 (fun _ => None). + 0 (PArray.length t_atom) (fun _ => None). Definition build_positive_atom := build_positive_atom_aux build_positive. (* Register build_positive_atom as PrimInline. *) @@ -113,16 +113,16 @@ Section certif. | Some z => (vm, PEc z) | None => let (vm,p) := find_var vm h in - (vm,PEX Z p) + (vm,PEX p) end end. End BuildPExpr. Definition build_pexpr := - foldi_down_cont + foldi (fun i cont vm h => build_pexpr_atom_aux cont vm (get_atom h)) - (PArray.length t_atom) 0 (fun vm _ => (vm,PEc 0%Z)). + 0 (PArray.length t_atom) (fun vm _ => (vm,PEc 0%Z)). Definition build_pexpr_atom := build_pexpr_atom_aux build_pexpr. @@ -157,7 +157,7 @@ Section certif. Section Build_form. Definition build_not2 i f := - fold (fun f' => N (N (A:=Formula Z) f')) 1 i f. + foldi (fun _ (f' : BFormula (Formula Z)) => N (N f')) 0 i f. Variable build_var : vmap -> var -> option (vmap*BFormula (Formula Z)). @@ -166,11 +166,11 @@ Section certif. match f with | Form.Fatom h => match build_formula vm h with - | Some (vm,f) => Some (vm, A f) + | Some (vm,f) => Some (vm, A f tt) | None => None end - | Form.Ftrue => Some (vm, TT (Formula Z)) - | Form.Ffalse => Some (vm, FF (Formula Z)) + | Form.Ftrue => Some (vm, TT) + | Form.Ffalse => Some (vm, FF) | Form.Fnot2 i l => match build_var vm (Lit.blit l) with | Some (vm, f) => @@ -180,23 +180,43 @@ Section certif. | None => None end | Form.Fand args => - let n := length args in - if n == 0 then Some (vm,TT (Formula Z)) - else - foldi (fun i f1 => match f1 with | Some(vm',f1') => let l := (args.[i]) in match build_var vm' (Lit.blit l) with | Some(vm2,f2) => let f2' := if Lit.is_pos l then f2 else N f2 in Some(vm2,Cj f1' f2') | None => None end | None => None end) 1 (n-1) (let l := args.[0] in - match build_var vm (Lit.blit l) with - | Some (vm',f) => if Lit.is_pos l then Some (vm',f) else Some (vm',N f) + afold_left _ + (fun vm => Some (vm, TT)) + (fun a b vm => + match a vm with + | Some (vm1, f1) => + match b vm1 with + | Some (vm2, f2) => Some (vm2, Cj f1 f2) + | None => None + end | None => None end) + (amap + (fun l vm => match build_var vm (Lit.blit l) with + | Some (vm', f) => Some (vm', if Lit.is_pos l then f else N f) + | None => None + end) + args) + vm | Form.For args => - let n := length args in - if n == 0 then Some (vm,FF (Formula Z)) - else - foldi (fun i f1 => match f1 with | Some(vm',f1') => let l := (args.[i]) in match build_var vm' (Lit.blit l) with | Some(vm2,f2) => let f2' := if Lit.is_pos l then f2 else N f2 in Some(vm2,D f1' f2') | None => None end | None => None end) 1 (n-1) (let l := args.[0] in - match build_var vm (Lit.blit l) with - | Some (vm',f) => if Lit.is_pos l then Some (vm',f) else Some (vm',N f) + afold_left _ + (fun vm => Some (vm, FF)) + (fun a b vm => + match a vm with + | Some (vm1, f1) => + match b vm1 with + | Some (vm2, f2) => Some (vm2, D f1 f2) + | None => None + end | None => None end) + (amap + (fun l vm => match build_var vm (Lit.blit l) with + | Some (vm', f) => Some (vm', if Lit.is_pos l then f else N f) + | None => None + end) + args) + vm | Form.Fxor a b => match build_var vm (Lit.blit a) with | Some (vm1, f1) => @@ -210,20 +230,24 @@ Section certif. | None => None end | Form.Fimp args => - let n := length args in - if n == 0 then Some (vm,TT (Formula Z)) - else if n <= 1 then - let l := args.[0] in - match build_var vm (Lit.blit l) with - | Some (vm',f) => if Lit.is_pos l then Some (vm',f) else Some (vm',N f) - | None => None - end - else - foldi_down (fun i f1 => match f1 with | Some(vm',f1') => let l := (args.[i]) in match build_var vm' (Lit.blit l) with | Some(vm2,f2) => let f2' := if Lit.is_pos l then f2 else N f2 in Some(vm2,I f2' f1') | None => None end | None => None end) (n-2) 0 (let l := args.[n-1] in - match build_var vm (Lit.blit l) with - | Some (vm',f) => if Lit.is_pos l then Some (vm',f) else Some (vm',N f) + afold_right _ + (fun vm => Some (vm, TT)) + (fun a b vm => + match b vm with + | Some (vm2, f2) => + match a vm2 with + | Some (vm1, f1) => Some (vm1, I f1 None f2) + | None => None + end | None => None end) + (amap + (fun l vm => match build_var vm (Lit.blit l) with + | Some (vm', f) => Some (vm', if Lit.is_pos l then f else N f) + | None => None + end) + args) + vm | Form.Fiff a b => match build_var vm (Lit.blit a) with | Some (vm1, f1) => @@ -260,9 +284,9 @@ Section certif. Definition build_var := - foldi_down_cont + foldi (fun i cont vm h => build_hform cont vm (get_form h)) - (PArray.length t_form) 0 (fun _ _ => None). + 0 (PArray.length t_form) (fun _ _ => None). Definition build_form := build_hform build_var. @@ -295,7 +319,7 @@ Section certif. Definition build_clause vm cl := match build_clause_aux vm cl with - | Some (vm, bf) => Some (vm, I bf (FF _)) + | Some (vm, bf) => Some (vm, I bf None FF) | None => None end. @@ -418,9 +442,10 @@ Section certif. t_interp.[h] = Bval t_i Typ.Tpositive p. Proof. unfold build_positive. - apply foldi_down_cont_ind;intros;try discriminate. + apply foldi_ind;intros;try discriminate. + apply leb_0. rewrite t_interp_wf;trivial. - apply build_positive_atom_aux_correct with cont;trivial. + apply (build_positive_atom_aux_correct a); trivial. Qed. Lemma build_positive_atom_correct : @@ -479,11 +504,11 @@ Section certif. Fixpoint bounded_bformula (p:positive) (bf:BFormula (Formula Z)) := match bf with - | @TT _ | @FF _ | @X _ _ => true - | A f => bounded_formula p f + | @TT _ | @FF _ | @X _ _ _ _ _ => true + | A f _ => bounded_formula p f | Cj bf1 bf2 | D bf1 bf2 - | I bf1 bf2 => bounded_bformula p bf1 && bounded_bformula p bf2 + | I bf1 _ bf2 => bounded_bformula p bf1 && bounded_bformula p bf2 | N bf => bounded_bformula p bf end. @@ -523,7 +548,7 @@ Section certif. check_atom h Typ.TZ -> match build_z_atom h with | Some z => (vm, PEc z) - | None => let (vm0, p) := find_var vm h in (vm0, PEX Z p) + | None => let (vm0, p) := find_var vm h in (vm0, PEX p) end = (vm', pe) -> wf_vmap vm -> wf_vmap vm' /\ @@ -869,26 +894,27 @@ Transparent build_z_atom. t_interp.[h] = Bval t_i Typ.TZ (Zeval_expr (interp_vmap vm') pe). Proof. unfold build_pexpr. - apply foldi_down_cont_ZInd. - intros z Hz h vm vm' pe Hh. - assert (W:=to_Z_bounded h);rewrite to_Z_0 in Hz. + apply foldi_ind. + apply leb_0. + intros h vm vm' pe Hh. + assert (W:=to_Z_bounded h);rewrite to_Z_0 in Hh. elimtype False;omega. intros i cont Hpos Hlen Hrec. intros h vm vm' pe;unfold is_true;rewrite <-ltb_spec;intros. rewrite t_interp_wf;trivial. - apply build_pexpr_atom_aux_correct with cont h i;trivial. + apply build_pexpr_atom_aux_correct with cont h (i + 1);trivial. intros;apply Hrec;auto. - unfold is_true in H3;rewrite ltb_spec in H, H3;omega. + unfold is_true in H3;rewrite ltb_spec in H, H3, Hlen; rewrite to_Z_add_1_wB in H; generalize (to_Z_bounded (length t_atom)); lia. unfold wf, is_true in wf_t_atom. - rewrite forallbi_spec in wf_t_atom. + rewrite aforallbi_spec in wf_t_atom. apply wf_t_atom. - rewrite ltb_spec in H;rewrite leb_spec in Hlen;rewrite ltb_spec;omega. + rewrite ltb_spec in H, Hlen;rewrite ltb_spec; rewrite to_Z_add_1_wB in H; generalize (to_Z_bounded (length t_atom)); lia. unfold wt, is_true in wt_t_atom. - rewrite forallbi_spec in wt_t_atom. + rewrite aforallbi_spec in wt_t_atom. change (is_true(Typ.eqb (get_type t_i t_func t_atom h) Typ.TZ)) in H0. rewrite Typ.eqb_spec in H0;rewrite <- H0. apply wt_t_atom. - rewrite ltb_spec in H;rewrite leb_spec in Hlen;rewrite ltb_spec;omega. + rewrite ltb_spec in H, Hlen; rewrite ltb_spec; rewrite to_Z_add_1_wB in H; generalize (to_Z_bounded (length t_atom)); lia. Qed. Lemma build_pexpr_correct : @@ -913,19 +939,16 @@ Transparent build_z_atom. rewrite PArray.get_outofbound, default_t_interp. revert H0. unfold build_pexpr. - case_eq (0 < length t_atom);intros Heq. - rewrite foldi_down_cont_gt;trivial. - rewrite PArray.get_outofbound;trivial. + apply foldi_ind. + apply leb_0. + discriminate. + intros i a _ Hi IH. + rewrite PArray.get_outofbound by exact H2. Opaque build_z_atom. - rewrite def_t_atom;simpl. - intros HH H;revert HH H1;apply build_pexpr_atom_aux_correct_z;trivial. - rewrite foldi_down_cont_eq;trivial. - rewrite PArray.get_outofbound;trivial. - rewrite def_t_atom;simpl. - intros HH H;revert HH H1;apply build_pexpr_atom_aux_correct_z;trivial. - rewrite <- not_true_iff_false, ltb_spec, to_Z_0 in Heq. - assert (W:= to_Z_bounded (length t_atom)). - apply to_Z_inj;rewrite to_Z_0;omega. + rewrite def_t_atom; simpl. + intros HH H. + revert HH H1. + apply build_pexpr_atom_aux_correct_z; trivial. rewrite length_t_interp;trivial. Qed. Transparent build_z_atom. @@ -1019,40 +1042,46 @@ Transparent build_z_atom. rewrite t_interp_wf;trivial. intros;apply build_formula_atom_correct with (get_type t_i t_func t_atom h);trivial. - unfold wt, is_true in wt_t_atom;rewrite forallbi_spec in wt_t_atom. - case_eq (h < length t_atom);intros Heq;unfold get_type;auto. + unfold wt, is_true in wt_t_atom;rewrite aforallbi_spec in wt_t_atom. + case_eq (h < length t_atom);intros Heq;unfold get_type;auto with smtcoq_core. unfold get_type'. rewrite !PArray.get_outofbound, default_t_interp, def_t_atom;trivial; try reflexivity. rewrite length_t_interp;trivial. Qed. + Local Notation eval_f := (eval_f (fun x => x)). + Lemma build_not2_pos_correct : forall vm f l i, bounded_bformula (fst vm) f -> (rho (Lit.blit l) <-> eval_f (Zeval_formula (interp_vmap vm)) f) -> Lit.is_pos l -> bounded_bformula (fst vm) (build_not2 i f) /\ (Form.interp interp_form_hatom interp_form_hatom_bv t_form (Form.Fnot2 i l) <-> eval_f (Zeval_formula (interp_vmap vm)) (build_not2 i f)). Proof. - simpl; intros vm f l i H1 H2 H3; split; unfold build_not2. - apply fold_ind; auto. - apply (fold_ind2 _ _ (fun b f' => b = true <-> eval_f (Zeval_formula (interp_vmap vm)) f')). + simpl; intros vm f l i H1 H2 H3; unfold build_not2. + case (Z.le_gt_cases 1 [|i|]); [ intro Hle | intro Hlt ]. + set (a := foldi _ _ _ _); set (b := foldi _ _ _ _); pattern i, a, b; subst a b; apply foldi_ind2. + apply leb_0. + unfold Lit.interp; rewrite H3; auto. + intros j f' b _ _; rewrite negb_involutive; simpl. + intros [ H H' ]; rewrite <- H'. + unfold is_true; rewrite not_true_iff_false, not_false_iff_true; tauto. + rewrite 2!foldi_ge by (rewrite leb_spec, to_Z_0; lia). unfold Lit.interp; rewrite H3; auto. - intros b f' H4; rewrite negb_involutive; simpl; split. - intros Hb H5; apply H5; rewrite <- H4; auto. - intro H5; case_eq b; auto; intro H6; elim H5; intro H7; rewrite <- H4 in H7; rewrite H7 in H6; discriminate. Qed. Lemma build_not2_neg_correct : forall vm f l i, bounded_bformula (fst vm) f -> (rho (Lit.blit l) <-> eval_f (Zeval_formula (interp_vmap vm)) f) -> Lit.is_pos l = false -> bounded_bformula (fst vm) (N (build_not2 i f)) /\ (Form.interp interp_form_hatom interp_form_hatom_bv t_form (Form.Fnot2 i l) <-> eval_f (Zeval_formula (interp_vmap vm)) (N (build_not2 i f))). Proof. - simpl; intros vm f l i H1 H2 H3; split; unfold build_not2. - apply fold_ind; auto. - apply (fold_ind2 _ _ (fun b f' => b = true <-> ~ eval_f (Zeval_formula (interp_vmap vm)) f')). - unfold Lit.interp; rewrite H3; unfold Var.interp; split. - intros H4 H5; rewrite <- H2 in H5; rewrite H5 in H4; discriminate. - intro H4; case_eq (rho (Lit.blit l)); auto; intro H5; elim H4; rewrite <- H2; auto. - intros b f' H4; rewrite negb_involutive; simpl; split. - intros Hb H5; apply H5; rewrite <- H4; auto. - intro H5; case_eq b; auto; intro H6; elim H5; intro H7; rewrite <- H4 in H7; rewrite H7 in H6; discriminate. - Qed. + simpl; intros vm f l i H1 H2 H3; unfold build_not2. + case (Z.le_gt_cases 1 [|i|]); [ intro Hle | intro Hlt ]. + set (a := foldi _ _ _ _); set (b := foldi _ _ _ _); pattern i, a, b; subst a b; apply foldi_ind2. + apply leb_0. + unfold Lit.interp; rewrite H3, <- H2; unfold is_true; rewrite negb_true_iff, not_true_iff_false; tauto. + intros j f' b _ _; rewrite negb_involutive; simpl. + intros [ H H' ]; rewrite <- H'. + unfold is_true; rewrite not_true_iff_false, not_false_iff_true; tauto. + rewrite 2!foldi_ge by (rewrite leb_spec, to_Z_0; lia). + unfold Lit.interp; rewrite H3, <- H2; unfold is_true; rewrite negb_true_iff, not_true_iff_false; tauto. +Qed. Lemma bounded_bformula_le : @@ -1083,7 +1112,7 @@ Transparent build_z_atom. Proof. intros vm vm' Hnth. unfold is_true;induction bf;simpl;try tauto. - destruct a;unfold bounded_formula;simpl. + destruct t;unfold bounded_formula;simpl. rewrite andb_true_iff;intros (H1, H2). rewrite !(interp_pexpr_le _ _ Hnth);tauto. rewrite andb_true_iff;intros (H1,H2);rewrite IHbf1, IHbf2;tauto. @@ -1123,117 +1152,91 @@ Transparent build_z_atom. (* Ftrue *) intros H H1; inversion H; subst vm'; subst bf; split; auto; split; [omega| ]; do 4 split; auto. (* Ffalse *) - intros H H1; inversion H; subst vm'; subst bf; split; auto; split; [omega| ]; do 3 (split; auto); discriminate. + intros H H1; inversion H; subst vm'; subst bf; split; auto; split; [omega| ]; do 3 (split; auto with smtcoq_core); discriminate. (* Fnot2 *) case_eq (build_var vm (Lit.blit l)); try discriminate; intros [vm0 f] Heq H H1; inversion H; subst vm0; subst bf; destruct (Hbv _ _ _ _ Heq H1) as [H2 [H3 [H4 [H5 H6]]]]; do 3 (split; auto); case_eq (Lit.is_pos l); [apply build_not2_pos_correct|apply build_not2_neg_correct]; auto. (* Fand *) - simpl; unfold afold_left; case (length l == 0). - intro H; inversion H; subst vm'; subst bf; simpl; intro H1; split; auto; split; [omega| ]; do 3 (split; auto). - revert vm' bf; apply (foldi_ind2 _ _ (fun f1 b => forall vm' bf, f1 = Some (vm', bf) -> wf_vmap vm -> wf_vmap vm' /\ (Pos.to_nat (fst vm) <= Pos.to_nat (fst vm'))%nat /\ (forall p : positive, (Pos.to_nat p < Pos.to_nat (fst vm))%nat -> nth_error (snd vm) (Pos.to_nat (fst vm - p) - 1) = nth_error (snd vm') (Pos.to_nat (fst vm' - p) - 1)) /\ bounded_bformula (fst vm') bf /\ (b = true <-> eval_f (Zeval_formula (interp_vmap vm')) bf))). + simpl; unfold afold_left; rewrite !length_amap; case_eq (length l == 0); [ rewrite Int63.eqb_spec | rewrite eqb_false_spec, not_0_ltb ]; intro Hl. + intro H; inversion H; subst vm'; subst bf; simpl; intro H1; split; auto with smtcoq_core; split; [omega| ]; do 3 (split; auto with smtcoq_core). + revert vm' bf; rewrite !get_amap by exact Hl; set (a := foldi _ _ _ _); set (b := foldi _ _ _ _); pattern (length l), a, b; subst a b; apply foldi_ind2. + rewrite ltb_spec, to_Z_0 in Hl; rewrite leb_spec, to_Z_1; lia. intros vm' bf; case_eq (build_var vm (Lit.blit (l .[ 0]))); try discriminate; intros [vm0 f] Heq; case_eq (Lit.is_pos (l .[ 0])); intros Heq2 H1 H2; inversion H1; subst vm'; subst bf; destruct (Hbv _ _ _ _ Heq H2) as [H10 [H11 [H12 [H13 H14]]]]; do 4 (split; auto); unfold Lit.interp; rewrite Heq2; auto; simpl; split. intros H3 H4; rewrite <- H14 in H4; rewrite H4 in H3; discriminate. intro H3; case_eq (Var.interp rho (Lit.blit (l .[ 0]))); auto; intro H4; elim H3; rewrite <- H14; auto. - intros i a b _ H1; case a; try discriminate; intros [vm0 f0] IH vm' bf; case_eq (build_var vm0 (Lit.blit (l .[ i]))); try discriminate; intros [vm1 f1] Heq H2 H3; inversion H2; subst vm'; subst bf; destruct (IH _ _ (refl_equal (Some (vm0, f0))) H3) as [H5 [H6 [H7 [H8 H9]]]]; destruct (Hbv _ _ _ _ Heq H5) as [H10 [H11 [H12 [H13 H14]]]]; split; auto; split; [eauto with arith| ]; split. + intros i a b _ H1; case (a vm); try discriminate; intros [vm0 f0] IH vm' bf; rewrite get_amap by exact H1; case_eq (build_var vm0 (Lit.blit (l .[ i]))); try discriminate; intros [vm1 f1] Heq H2 H3; inversion H2; subst vm'; subst bf; destruct (IH _ _ (refl_equal (Some (vm0, f0))) H3) as [H5 [H6 [H7 [H8 H9]]]]; destruct (Hbv _ _ _ _ Heq H5) as [H10 [H11 [H12 [H13 H14]]]]; split; auto; split; [eauto with arith| ]; split. intros p H15; rewrite H7; auto; apply H12; eauto with arith. split. - simpl; rewrite (bounded_bformula_le _ _ H11 _ H8); case (Lit.is_pos (l .[ i])); rewrite H13; auto. - simpl; rewrite (interp_bformula_le _ _ H12 _ H8) in H9; rewrite <- H9; case_eq (Lit.is_pos (l .[ i])); intro Heq2; simpl; rewrite <- H14; unfold Lit.interp; rewrite Heq2; split; case (Var.interp rho (Lit.blit (l .[ i]))); try rewrite andb_true_r; try rewrite andb_false_r; try (intros; split; auto); try discriminate; intros [H20 H21]; auto. + simpl; rewrite (bounded_bformula_le _ _ H11 _ H8); case (Lit.is_pos (l .[ i])); rewrite H13; auto with smtcoq_core. + simpl; rewrite (interp_bformula_le _ _ H12 _ H8) in H9; rewrite <- H9; rewrite get_amap by exact H1; case_eq (Lit.is_pos (l .[ i])); intro Heq2; simpl; rewrite <- H14; unfold Lit.interp; rewrite Heq2; split; case (Var.interp rho (Lit.blit (l .[ i]))); try rewrite andb_true_r; try rewrite andb_false_r; try (intros; split; auto with smtcoq_core); try discriminate; intros [H20 H21]; auto with smtcoq_core. (* For *) - simpl; unfold afold_left; case (length l == 0). - intro H; inversion H; subst vm'; subst bf; simpl; intro H1; split; auto; split; [omega| ]; do 3 (split; auto); discriminate. - revert vm' bf; apply (foldi_ind2 _ _ (fun f1 b => forall vm' bf, f1 = Some (vm', bf) -> wf_vmap vm -> wf_vmap vm' /\ (Pos.to_nat (fst vm) <= Pos.to_nat (fst vm'))%nat /\ (forall p : positive, (Pos.to_nat p < Pos.to_nat (fst vm))%nat -> nth_error (snd vm) (Pos.to_nat (fst vm - p) - 1) = nth_error (snd vm') (Pos.to_nat (fst vm' - p) - 1)) /\ bounded_bformula (fst vm') bf /\ (b = true <-> eval_f (Zeval_formula (interp_vmap vm')) bf))). - intros vm' bf; case_eq (build_var vm (Lit.blit (l .[ 0]))); try discriminate; intros [vm0 f] Heq; case_eq (Lit.is_pos (l .[ 0])); intros Heq2 H1 H2; inversion H1; subst vm'; subst bf; destruct (Hbv _ _ _ _ Heq H2) as [H10 [H11 [H12 [H13 H14]]]]; do 4 (split; auto); unfold Lit.interp; rewrite Heq2; auto; simpl; split. + simpl; unfold afold_left; rewrite !length_amap; case_eq (length l == 0); [ rewrite Int63.eqb_spec | rewrite eqb_false_spec, not_0_ltb ]; intro Hl. + intro H; inversion H; subst vm'; subst bf; simpl; intro H1; split; auto with smtcoq_core; split; [omega| ]; do 3 (split; auto with smtcoq_core); discriminate. + revert vm' bf; rewrite !get_amap by exact Hl; set (a := foldi _ _ _ _); set (b := foldi _ _ _ _); pattern (length l), a, b; subst a b; apply foldi_ind2. + rewrite ltb_spec, to_Z_0 in Hl; rewrite leb_spec, to_Z_1; lia. + intros vm' bf; case_eq (build_var vm (Lit.blit (l .[ 0]))); try discriminate; intros [vm0 f] Heq; case_eq (Lit.is_pos (l .[ 0])); intros Heq2 H1 H2; inversion H1; subst vm'; subst bf; destruct (Hbv _ _ _ _ Heq H2) as [H10 [H11 [H12 [H13 H14]]]]; do 4 (split; auto with smtcoq_core); unfold Lit.interp; rewrite Heq2; auto with smtcoq_core; simpl; split. intros H3 H4; rewrite <- H14 in H4; rewrite H4 in H3; discriminate. - intro H3; case_eq (Var.interp rho (Lit.blit (l .[ 0]))); auto; intro H4; elim H3; rewrite <- H14; auto. - intros i a b _ H1; case a; try discriminate; intros [vm0 f0] IH vm' bf; case_eq (build_var vm0 (Lit.blit (l .[ i]))); try discriminate; intros [vm1 f1] Heq H2 H3; inversion H2; subst vm'; subst bf; destruct (IH _ _ (refl_equal (Some (vm0, f0))) H3) as [H5 [H6 [H7 [H8 H9]]]]; destruct (Hbv _ _ _ _ Heq H5) as [H10 [H11 [H12 [H13 H14]]]]; split; auto; split; [eauto with arith| ]; split. - intros p H15; rewrite H7; auto; apply H12; eauto with arith. + intro H3; case_eq (Var.interp rho (Lit.blit (l .[ 0]))); auto with smtcoq_core; intro H4; elim H3; rewrite <- H14; auto with smtcoq_core. + intros i a b _ H1; case (a vm); try discriminate; intros [vm0 f0] IH vm' bf; rewrite get_amap by exact H1; case_eq (build_var vm0 (Lit.blit (l .[ i]))); try discriminate; intros [vm1 f1] Heq H2 H3; inversion H2; subst vm'; subst bf; destruct (IH _ _ (refl_equal (Some (vm0, f0))) H3) as [H5 [H6 [H7 [H8 H9]]]]; destruct (Hbv _ _ _ _ Heq H5) as [H10 [H11 [H12 [H13 H14]]]]; split; auto with smtcoq_core; split; [eauto with smtcoq_core arith| ]; split. + intros p H15; rewrite H7; auto with smtcoq_core; apply H12; eauto with smtcoq_core arith. split. - simpl; rewrite (bounded_bformula_le _ _ H11 _ H8); case (Lit.is_pos (l .[ i])); rewrite H13; auto. - simpl; rewrite (interp_bformula_le _ _ H12 _ H8) in H9; rewrite <- H9; case_eq (Lit.is_pos (l .[ i])); intro Heq2; simpl; rewrite <- H14; unfold Lit.interp; rewrite Heq2; split; case (Var.interp rho (Lit.blit (l .[ i]))); try rewrite orb_false_r; try rewrite orb_true_r; auto; try (intros [H20|H20]; auto; discriminate); right; intro H20; discriminate. + simpl; rewrite (bounded_bformula_le _ _ H11 _ H8); case (Lit.is_pos (l .[ i])); rewrite H13; auto with smtcoq_core. + simpl; rewrite (interp_bformula_le _ _ H12 _ H8) in H9; rewrite <- H9; rewrite get_amap by exact H1; case_eq (Lit.is_pos (l .[ i])); intro Heq2; simpl; rewrite <- H14; unfold Lit.interp; rewrite Heq2; split; case (Var.interp rho (Lit.blit (l .[ i]))); try rewrite orb_false_r; try rewrite orb_true_r; auto with smtcoq_core; try (intros [H20|H20]; auto with smtcoq_core; discriminate); right; intro H20; discriminate. (* Fimp *) - simpl; unfold afold_right; case (length l == 0). - intro H; inversion H; subst vm'; subst bf; simpl; intro H1; split; auto; split; [omega| ]; do 3 (split; auto). - case (length l <= 1). - case_eq (build_var vm (Lit.blit (l .[ 0]))); try discriminate; intros [vm0 f] Heq; case_eq (Lit.is_pos (l .[ 0])); intros Heq2 H1 H2; inversion H1; subst vm'; subst bf; destruct (Hbv _ _ _ _ Heq H2) as [H3 [H4 [H5 [H6 H7]]]]; do 4 (split; auto); unfold Lit.interp; rewrite Heq2; auto; simpl; split. - intros H8 H9; rewrite <- H7 in H9; rewrite H9 in H8; discriminate. - intro H8; case_eq (Var.interp rho (Lit.blit (l .[ 0]))); auto; intro H9; rewrite H7 in H9; elim H8; auto. - revert vm' bf; apply (foldi_down_ind2 _ _ (fun f1 b => forall vm' bf, f1 = Some (vm', bf) -> wf_vmap vm -> wf_vmap vm' /\ (Pos.to_nat (fst vm) <= Pos.to_nat (fst vm'))%nat /\ (forall p : positive, (Pos.to_nat p < Pos.to_nat (fst vm))%nat -> nth_error (snd vm) (Pos.to_nat (fst vm - p) - 1) = nth_error (snd vm') (Pos.to_nat (fst vm' - p) - 1)) /\ bounded_bformula (fst vm') bf /\ (b = true <-> eval_f (Zeval_formula (interp_vmap vm')) bf))). - intros vm' bf; case_eq (build_var vm (Lit.blit (l .[ length l - 1]))); try discriminate; intros [vm0 f] Heq; case_eq (Lit.is_pos (l .[ length l - 1])); intros Heq2 H1 H2; inversion H1; subst vm'; subst bf; destruct (Hbv _ _ _ _ Heq H2) as [H10 [H11 [H12 [H13 H14]]]]; do 4 (split; auto); unfold Lit.interp; rewrite Heq2; auto; simpl; split. + simpl; unfold afold_right; rewrite !length_amap; case_eq (length l == 0); [ rewrite Int63.eqb_spec | rewrite eqb_false_spec, not_0_ltb ]; intro Hl. + intro H; inversion H; subst vm'; subst bf; simpl; intro H1; split; auto with smtcoq_core; split; [omega| ]; do 3 (split; auto with smtcoq_core). + revert vm' bf; rewrite !get_amap by (apply minus_1_lt; rewrite eqb_false_spec, not_0_ltb; exact Hl); set (a := foldi _ _ _ _); set (b := foldi _ _ _ _); pattern (length l), a, b; subst a b; apply foldi_ind2. + rewrite ltb_spec, to_Z_0 in Hl; rewrite leb_spec, to_Z_1; lia. + intros vm' bf; case_eq (build_var vm (Lit.blit (l .[ length l - 1]))); try discriminate; intros [vm0 f] Heq; case_eq (Lit.is_pos (l .[ length l - 1])); intros Heq2 H1 H2; inversion H1; subst vm'; subst bf; destruct (Hbv _ _ _ _ Heq H2) as [H10 [H11 [H12 [H13 H14]]]]; do 4 (split; auto with smtcoq_core); unfold Lit.interp; rewrite Heq2; auto with smtcoq_core; simpl; split. intros H3 H4; rewrite <- H14 in H4; rewrite H4 in H3; discriminate. - intro H3; case_eq (Var.interp rho (Lit.blit (l .[ length l - 1]))); auto; intro H4; elim H3; rewrite <- H14; auto. - intros i a b _ H1; case a; try discriminate; intros [vm0 f0] IH vm' bf; case_eq (build_var vm0 (Lit.blit (l .[ i]))); try discriminate; intros [vm1 f1] Heq H2 H3; inversion H2; subst vm'; subst bf; destruct (IH _ _ (refl_equal (Some (vm0, f0))) H3) as [H5 [H6 [H7 [H8 H9]]]]; destruct (Hbv _ _ _ _ Heq H5) as [H10 [H11 [H12 [H13 H14]]]]; split; auto; split; [eauto with arith| ]; split. - intros p H15; rewrite H7; auto; apply H12; eauto with arith. + intro H3; case_eq (Var.interp rho (Lit.blit (l .[ length l - 1]))); auto with smtcoq_core; intro H4; elim H3; rewrite <- H14; auto with smtcoq_core. + intros i a b _ H1. + rewrite get_amap by (pose proof (to_Z_bounded i); pose proof (to_Z_bounded (length l)); revert H1 Hl; rewrite !ltb_spec, to_Z_0; intros; rewrite sub_spec, to_Z_sub_1_0, Z.mod_small; lia). + rewrite get_amap by (pose proof (to_Z_bounded i); pose proof (to_Z_bounded (length l)); revert H1 Hl; rewrite !ltb_spec, to_Z_0; intros; rewrite sub_spec, to_Z_sub_1_0, Z.mod_small; lia). + case a; try discriminate; intros [vm0 f0] IH vm' bf; case_eq (build_var vm0 (Lit.blit (l .[length l - 1 - i]))); try discriminate; intros [vm1 f1] Heq H2 H3; inversion H2; subst vm'; subst bf; destruct (IH _ _ (refl_equal (Some (vm0, f0))) H3) as [H5 [H6 [H7 [H8 H9]]]]; destruct (Hbv _ _ _ _ Heq H5) as [H10 [H11 [H12 [H13 H14]]]]; split; auto with smtcoq_core; split; [eauto with smtcoq_core arith| ]; split. + intros p H15; rewrite H7; auto with smtcoq_core; apply H12; eauto with smtcoq_core arith. split. - simpl; rewrite (bounded_bformula_le _ _ H11 _ H8); case (Lit.is_pos (l .[ i])); rewrite H13; auto. - simpl; rewrite (interp_bformula_le _ _ H12 _ H8) in H9; rewrite <- H9; case_eq (Lit.is_pos (l .[ i])); intro Heq2; simpl; rewrite <- H14; unfold Lit.interp; rewrite Heq2; split; case (Var.interp rho (Lit.blit (l .[ i]))); auto; try discriminate; simpl; intro H; apply H; discriminate. + simpl; rewrite (bounded_bformula_le _ _ H11 _ H8); case (Lit.is_pos (l .[length l - 1 - i])); rewrite H13; auto with smtcoq_core. + simpl; rewrite (interp_bformula_le _ _ H12 _ H8) in H9; rewrite <- H9; case_eq (Lit.is_pos (l .[length l - 1 - i])); intro Heq2; simpl; rewrite <- H14; unfold Lit.interp; rewrite Heq2; split; case (Var.interp rho (Lit.blit (l .[length l - 1 - i]))); auto with smtcoq_core; try discriminate; simpl; intro H; apply H; discriminate. (* Fxor *) - simpl; case_eq (build_var vm (Lit.blit a)); try discriminate; intros [vm1 f1] Heq1; case_eq (build_var vm1 (Lit.blit b)); try discriminate; intros [vm2 f2] Heq2 H1 H2; inversion H1; subst vm'; subst bf; destruct (Hbv _ _ _ _ Heq1 H2) as [H3 [H4 [H5 [H6 H7]]]]; destruct (Hbv _ _ _ _ Heq2 H3) as [H8 [H9 [H10 [H11 H12]]]]; split; auto; split; [eauto with arith| ]; split. - intros p H18; rewrite H5; auto; rewrite H10; eauto with arith. + simpl; case_eq (build_var vm (Lit.blit a)); try discriminate; intros [vm1 f1] Heq1; case_eq (build_var vm1 (Lit.blit b)); try discriminate; intros [vm2 f2] Heq2 H1 H2; inversion H1; subst vm'; subst bf; destruct (Hbv _ _ _ _ Heq1 H2) as [H3 [H4 [H5 [H6 H7]]]]; destruct (Hbv _ _ _ _ Heq2 H3) as [H8 [H9 [H10 [H11 H12]]]]; split; auto with smtcoq_core; split; [eauto with smtcoq_core arith| ]; split. + intros p H18; rewrite H5; auto with smtcoq_core; rewrite H10; eauto with smtcoq_core arith. split. - case (Lit.is_pos a); case (Lit.is_pos b); simpl; rewrite H11; rewrite (bounded_bformula_le _ _ H9 _ H6); auto. - simpl; rewrite (interp_bformula_le _ _ H10 _ H6) in H7; case_eq (Lit.is_pos a); intro Ha; case_eq (Lit.is_pos b); intro Hb; unfold Lit.interp; rewrite Ha, Hb; simpl; rewrite <- H12; rewrite <- H7; (case (Var.interp rho (Lit.blit a)); case (Var.interp rho (Lit.blit b))); split; auto; try discriminate; simpl. - intros [_ [H20|H20]]; elim H20; reflexivity. - intros _; split; [left; reflexivity|right; intro H20; discriminate]. - intros _; split; [right; reflexivity|left; intro H20; discriminate]. - intros [[H20|H20] _]; discriminate. - intros [_ [H20|H20]]; elim H20; [reflexivity|discriminate]. - intros [[H20|H20] _]; [discriminate|elim H20; reflexivity]. - intros _; split; [right|left]; discriminate. - intros [[H20|H20] _]; [elim H20; reflexivity|discriminate]. - intros [_ [H20|H20]]; elim H20; [discriminate|reflexivity]. - intros _; split; [left|right]; discriminate. - intros [[H20|H20] _]; elim H20; reflexivity. - intros _; split; [right; discriminate|left; intro H21; apply H21; reflexivity]. - intros _; split; [left; discriminate|right; intro H21; apply H21; reflexivity]. - intros [_ [H20|H20]]; elim H20; discriminate. + case (Lit.is_pos a); case (Lit.is_pos b); simpl; rewrite H11; rewrite (bounded_bformula_le _ _ H9 _ H6); auto with smtcoq_core. + simpl; rewrite (interp_bformula_le _ _ H10 _ H6) in H7; case_eq (Lit.is_pos a); intro Ha; case_eq (Lit.is_pos b); intro Hb; unfold Lit.interp; rewrite Ha, Hb; simpl; rewrite <- H12; rewrite <- H7; (case (Var.interp rho (Lit.blit a)); case (Var.interp rho (Lit.blit b))); split; auto with smtcoq_core; try discriminate; simpl; intuition. (* Fiff *) - simpl; case_eq (build_var vm (Lit.blit a)); try discriminate; intros [vm1 f1] Heq1; case_eq (build_var vm1 (Lit.blit b)); try discriminate; intros [vm2 f2] Heq2 H1 H2; inversion H1; subst vm'; subst bf; destruct (Hbv _ _ _ _ Heq1 H2) as [H3 [H4 [H5 [H6 H7]]]]; destruct (Hbv _ _ _ _ Heq2 H3) as [H8 [H9 [H10 [H11 H12]]]]; split; auto; split; [eauto with arith| ]; split. - intros p H18; rewrite H5; auto; rewrite H10; eauto with arith. + simpl; case_eq (build_var vm (Lit.blit a)); try discriminate; intros [vm1 f1] Heq1; case_eq (build_var vm1 (Lit.blit b)); try discriminate; intros [vm2 f2] Heq2 H1 H2; inversion H1; subst vm'; subst bf; destruct (Hbv _ _ _ _ Heq1 H2) as [H3 [H4 [H5 [H6 H7]]]]; destruct (Hbv _ _ _ _ Heq2 H3) as [H8 [H9 [H10 [H11 H12]]]]; split; auto with smtcoq_core; split; [eauto with smtcoq_core arith| ]; split. + intros p H18; rewrite H5; auto with smtcoq_core; rewrite H10; eauto with smtcoq_core arith. split. - case (Lit.is_pos a); case (Lit.is_pos b); simpl; rewrite H11; rewrite (bounded_bformula_le _ _ H9 _ H6); auto. - simpl; rewrite (interp_bformula_le _ _ H10 _ H6) in H7; case_eq (Lit.is_pos a); intro Ha; case_eq (Lit.is_pos b); intro Hb; unfold Lit.interp; rewrite Ha, Hb; simpl; rewrite <- H12; rewrite <- H7; (case (Var.interp rho (Lit.blit a)); case (Var.interp rho (Lit.blit b))); split; auto; try discriminate; simpl. - intros [_ [H20|H20]]; [elim H20; reflexivity|discriminate]. - intros [[H20|H20] _]; [discriminate|elim H20; reflexivity]. - intros _; split; [right|left]; discriminate. - intros [_ [H20|H20]]; elim H20; reflexivity. - intros _; split; [left; reflexivity|right; discriminate]. - intros _; split; [right; intro H20; apply H20; reflexivity|left; discriminate]. - intros [[H20|H20] _]; [ |elim H20]; discriminate. - intros [[H20|H20] _]; elim H20; reflexivity. - intros _; split; [right; discriminate|left; intro H20; apply H20; reflexivity]. - intros _; split; [left; discriminate|right; reflexivity]. - intros [_ [H20|H20]]; [elim H20| ]; discriminate. - intros [[H20|H20] _]; elim H20; [reflexivity|discriminate]. - intros [_ [H20|H20]]; elim H20; [discriminate|reflexivity]. - intros _; split; [left|right]; discriminate. + case (Lit.is_pos a); case (Lit.is_pos b); simpl; rewrite H11; rewrite (bounded_bformula_le _ _ H9 _ H6); auto with smtcoq_core. + simpl; rewrite (interp_bformula_le _ _ H10 _ H6) in H7; case_eq (Lit.is_pos a); intro Ha; case_eq (Lit.is_pos b); intro Hb; unfold Lit.interp; rewrite Ha, Hb; simpl; rewrite <- H12; rewrite <- H7; (case (Var.interp rho (Lit.blit a)); case (Var.interp rho (Lit.blit b))); split; auto with smtcoq_core; try discriminate; simpl; intuition. (* Fite *) - simpl; case_eq (build_var vm (Lit.blit a)); try discriminate; intros [vm1 f1] Heq1; case_eq (build_var vm1 (Lit.blit b)); try discriminate; intros [vm2 f2] Heq2; case_eq (build_var vm2 (Lit.blit c)); try discriminate; intros [vm3 f3] Heq3 H1 H2; inversion H1; subst vm'; subst bf; destruct (Hbv _ _ _ _ Heq1 H2) as [H3 [H4 [H5 [H6 H7]]]]; destruct (Hbv _ _ _ _ Heq2 H3) as [H8 [H9 [H10 [H11 H12]]]]; destruct (Hbv _ _ _ _ Heq3 H8) as [H13 [H14 [H15 [H16 H17]]]]; split; auto; split; [eauto with arith| ]; split. - intros p H18; rewrite H5; auto; rewrite H10; eauto with arith. - assert (H18: (Pos.to_nat (fst vm1) <= Pos.to_nat (fst vm3))%nat) by eauto with arith. + simpl; case_eq (build_var vm (Lit.blit a)); try discriminate; intros [vm1 f1] Heq1; case_eq (build_var vm1 (Lit.blit b)); try discriminate; intros [vm2 f2] Heq2; case_eq (build_var vm2 (Lit.blit c)); try discriminate; intros [vm3 f3] Heq3 H1 H2; inversion H1; subst vm'; subst bf; destruct (Hbv _ _ _ _ Heq1 H2) as [H3 [H4 [H5 [H6 H7]]]]; destruct (Hbv _ _ _ _ Heq2 H3) as [H8 [H9 [H10 [H11 H12]]]]; destruct (Hbv _ _ _ _ Heq3 H8) as [H13 [H14 [H15 [H16 H17]]]]; split; auto with smtcoq_core; split; [eauto with smtcoq_core arith| ]; split. + intros p H18; rewrite H5; auto with smtcoq_core; rewrite H10; eauto with smtcoq_core arith. + assert (H18: (Pos.to_nat (fst vm1) <= Pos.to_nat (fst vm3))%nat) by eauto with smtcoq_core arith. split. - case (Lit.is_pos a); case (Lit.is_pos b); case (Lit.is_pos c); simpl; rewrite H16; rewrite (bounded_bformula_le _ _ H14 _ H11); rewrite (bounded_bformula_le _ _ H18 _ H6); auto. - simpl; rewrite (interp_bformula_le _ _ H15 _ H11) in H12; rewrite (interp_bformula_le _ vm3) in H7; [ |intros p Hp; rewrite H10; eauto with arith|auto]; case_eq (Lit.is_pos a); intro Ha; case_eq (Lit.is_pos b); intro Hb; case_eq (Lit.is_pos c); intro Hc; unfold Lit.interp; rewrite Ha, Hb, Hc; simpl; rewrite <- H17; rewrite <- H12; rewrite <- H7; (case (Var.interp rho (Lit.blit a)); [case (Var.interp rho (Lit.blit b))|case (Var.interp rho (Lit.blit c))]); split; auto; try discriminate; try (intros [[H20 H21]|[H20 H21]]; auto); try (intros _; left; split; auto; discriminate); try (intros _; right; split; auto; discriminate); try (elim H20; discriminate); try (elim H21; discriminate); try (simpl; intro H; left; split; auto; discriminate); try (revert H; case (Var.interp rho (Lit.blit c)); discriminate); try (revert H; case (Var.interp rho (Lit.blit b)); discriminate); try (intro H20; rewrite H20 in H; discriminate); simpl. - intro H; right; split; auto. - intro H; right; split; auto. - intro H; right; split; auto. + case (Lit.is_pos a); case (Lit.is_pos b); case (Lit.is_pos c); simpl; rewrite H16; rewrite (bounded_bformula_le _ _ H14 _ H11); rewrite (bounded_bformula_le _ _ H18 _ H6); auto with smtcoq_core. + simpl; rewrite (interp_bformula_le _ _ H15 _ H11) in H12; rewrite (interp_bformula_le _ vm3) in H7; [ |intros p Hp; rewrite H10; eauto with smtcoq_core arith|auto with smtcoq_core]; case_eq (Lit.is_pos a); intro Ha; case_eq (Lit.is_pos b); intro Hb; case_eq (Lit.is_pos c); intro Hc; unfold Lit.interp; rewrite Ha, Hb, Hc; simpl; rewrite <- H17; rewrite <- H12; rewrite <- H7; (case (Var.interp rho (Lit.blit a)); [case (Var.interp rho (Lit.blit b))|case (Var.interp rho (Lit.blit c))]); split; auto with smtcoq_core; try discriminate; try (intros [[H20 H21]|[H20 H21]]; auto with smtcoq_core); try (intros _; left; split; auto with smtcoq_core; discriminate); try (intros _; right; split; auto with smtcoq_core; discriminate); try (elim H20; discriminate); try (elim H21; discriminate); try (simpl; intro H; left; split; auto with smtcoq_core; discriminate); try (revert H; case (Var.interp rho (Lit.blit c)); discriminate); try (revert H; case (Var.interp rho (Lit.blit b)); discriminate); try (intro H20; rewrite H20 in H; discriminate); simpl. + intro H; right; split; auto with smtcoq_core. + intro H; right; split; auto with smtcoq_core. + intro H; right; split; auto with smtcoq_core. intro H20; rewrite H20 in H; discriminate. - revert H21; case (Var.interp rho (Lit.blit c)); auto. - right; split; auto; intro H20; rewrite H20 in H; discriminate. - revert H21; case (Var.interp rho (Lit.blit c)); auto. - intro H; right; split; auto. - intro H; right; split; auto. + revert H21; case (Var.interp rho (Lit.blit c)); auto with smtcoq_core. + right; split; auto with smtcoq_core; intro H20; rewrite H20 in H; discriminate. + revert H21; case (Var.interp rho (Lit.blit c)); auto with smtcoq_core. + intro H; right; split; auto with smtcoq_core. + intro H; right; split; auto with smtcoq_core. intro H; left; split; try discriminate; revert H; case (Var.interp rho (Lit.blit b)); discriminate. - revert H21; case (Var.interp rho (Lit.blit b)); auto. + revert H21; case (Var.interp rho (Lit.blit b)); auto with smtcoq_core. intro H; left; split; try discriminate; revert H; case (Var.interp rho (Lit.blit b)); discriminate. - revert H21; case (Var.interp rho (Lit.blit b)); auto. - intro H; right; split; auto; revert H; case (Var.interp rho (Lit.blit c)); discriminate. - revert H21; case (Var.interp rho (Lit.blit c)); auto. - intro H; right; split; auto; revert H; case (Var.interp rho (Lit.blit c)); discriminate. - revert H21; case (Var.interp rho (Lit.blit c)); auto. - intro H; left; split; auto; revert H; case (Var.interp rho (Lit.blit b)); discriminate. - revert H21; case (Var.interp rho (Lit.blit b)); auto. - intro H; left; split; auto; revert H; case (Var.interp rho (Lit.blit b)); discriminate. - revert H21; case (Var.interp rho (Lit.blit b)); auto. + revert H21; case (Var.interp rho (Lit.blit b)); auto with smtcoq_core. + intro H; right; split; auto with smtcoq_core; revert H; case (Var.interp rho (Lit.blit c)); discriminate. + revert H21; case (Var.interp rho (Lit.blit c)); auto with smtcoq_core. + intro H; right; split; auto with smtcoq_core; revert H; case (Var.interp rho (Lit.blit c)); discriminate. + revert H21; case (Var.interp rho (Lit.blit c)); auto with smtcoq_core. + intro H; left; split; auto with smtcoq_core; revert H; case (Var.interp rho (Lit.blit b)); discriminate. + revert H21; case (Var.interp rho (Lit.blit b)); auto with smtcoq_core. + intro H; left; split; auto with smtcoq_core; revert H; case (Var.interp rho (Lit.blit b)); discriminate. + revert H21; case (Var.interp rho (Lit.blit b)); auto with smtcoq_core. Qed. @@ -1249,10 +1252,11 @@ Transparent build_z_atom. bounded_bformula (fst vm') bf /\ (Var.interp rho v <-> eval_f (Zeval_formula (interp_vmap vm')) bf). Proof. - unfold build_var; apply foldi_down_cont_ind; try discriminate. + unfold build_var; apply foldi_ind; try discriminate. + apply leb_0. intros i cont _ Hlen Hrec v vm vm' bf; unfold is_true; intros H1 H2; replace (Var.interp rho v) with (Form.interp interp_form_hatom interp_form_hatom_bv t_form (t_form.[v])). - apply (build_hform_correct cont); auto. - unfold Var.interp; rewrite <- wf_interp_form; auto. + apply (build_hform_correct cont); auto with smtcoq_core. + unfold Var.interp; rewrite <- wf_interp_form; auto with smtcoq_core. Qed. @@ -1285,17 +1289,17 @@ Transparent build_z_atom. unfold build_nlit; intros l vm vm' bf; case_eq (build_form vm (t_form .[ Lit.blit (Lit.neg l)])); try discriminate. intros [vm1 f] Heq H1 H2; inversion H1; subst vm1; subst bf; case_eq (Lit.is_pos (Lit.neg l)); intro Heq2. replace (negb (Lit.interp rho l)) with (Form.interp interp_form_hatom interp_form_hatom_bv t_form (t_form .[ Lit.blit (Lit.neg l)])). - apply build_form_correct; auto. + apply build_form_correct; auto with smtcoq_core. unfold Lit.interp; replace (Lit.is_pos l) with false. - rewrite negb_involutive; unfold Var.interp; rewrite <- wf_interp_form; auto; rewrite Lit.blit_neg; auto. - rewrite Lit.is_pos_neg in Heq2; case_eq (Lit.is_pos l); auto; intro H; rewrite H in Heq2; discriminate. - simpl; destruct (build_form_correct (t_form .[ Lit.blit (Lit.neg l)]) vm vm' f Heq H2) as [H3 [H4 [H5 [H6 [H7 H8]]]]]; do 4 (split; auto); split. + rewrite negb_involutive; unfold Var.interp; rewrite <- wf_interp_form; auto with smtcoq_core; rewrite Lit.blit_neg; auto with smtcoq_core. + rewrite Lit.is_pos_neg in Heq2; case_eq (Lit.is_pos l); auto with smtcoq_core; intro H; rewrite H in Heq2; discriminate. + simpl; destruct (build_form_correct (t_form .[ Lit.blit (Lit.neg l)]) vm vm' f Heq H2) as [H3 [H4 [H5 [H6 [H7 H8]]]]]; do 4 (split; auto with smtcoq_core); split. intros H9 H10; pose (H11 := H8 H10); unfold Lit.interp in H9; replace (Lit.is_pos l) with true in H9. - unfold Var.interp in H9; rewrite <- wf_interp_form in H11; auto; rewrite Lit.blit_neg in H11; rewrite H11 in H9; discriminate. - rewrite Lit.is_pos_neg in Heq2; case_eq (Lit.is_pos l); auto; intro H; rewrite H in Heq2; discriminate. - intro H9; case_eq (Lit.interp rho l); intro Heq3; auto; elim H9; apply H7; unfold Lit.interp in Heq3; replace (Lit.is_pos l) with true in Heq3. - unfold Var.interp in Heq3; rewrite <- wf_interp_form; auto; rewrite Lit.blit_neg; auto. - rewrite Lit.is_pos_neg in Heq2; case_eq (Lit.is_pos l); auto; intro H; rewrite H in Heq2; discriminate. + unfold Var.interp in H9; rewrite <- wf_interp_form in H11; auto with smtcoq_core; rewrite Lit.blit_neg in H11; rewrite H11 in H9; discriminate. + rewrite Lit.is_pos_neg in Heq2; case_eq (Lit.is_pos l); auto with smtcoq_core; intro H; rewrite H in Heq2; discriminate. + intro H9; case_eq (Lit.interp rho l); intro Heq3; auto with smtcoq_core; elim H9; apply H7; unfold Lit.interp in Heq3; replace (Lit.is_pos l) with true in Heq3. + unfold Var.interp in Heq3; rewrite <- wf_interp_form; auto with smtcoq_core; rewrite Lit.blit_neg; auto with smtcoq_core. + rewrite Lit.is_pos_neg in Heq2; case_eq (Lit.is_pos l); auto with smtcoq_core; intro H; rewrite H in Heq2; discriminate. Qed. @@ -1397,13 +1401,13 @@ Transparent build_z_atom. try(case_eq (t_atom.[i]);trivial;intros); try (apply valid_C_true; trivial). destruct b; try (apply valid_C_true; trivial). generalize wt_t_atom;unfold Atom.wt;unfold is_true; - rewrite PArray.forallbi_spec;intros. + rewrite aforallbi_spec;intros. assert (i < length t_atom). apply PArray.get_not_default_lt. rewrite H0, def_t_atom;discriminate. apply H1 in H2;clear H1;rewrite H0 in H2;simpl in H2. rewrite !andb_true_iff in H2;decompose [and] H2;clear H2. - apply Hf with (2:= H0);trivial. auto. + apply Hf with (2:= H0);trivial. auto with smtcoq_core. rewrite wf_interp_form, H;simpl. unfold Atom.interp_form_hatom, Atom.interp_hatom at 1;simpl. rewrite Atom.t_interp_wf, H0;simpl;trivial. @@ -1428,13 +1432,13 @@ Transparent build_z_atom. try(case_eq (t_atom.[i]);trivial;intros); try (apply valid_C_true; trivial). destruct b; try (apply valid_C_true; trivial). generalize wt_t_atom;unfold Atom.wt;unfold is_true; - rewrite PArray.forallbi_spec;intros. + rewrite aforallbi_spec;intros. assert (i < length t_atom). apply PArray.get_not_default_lt. rewrite H0, def_t_atom;discriminate. apply H1 in H2;clear H1;rewrite H0 in H2;simpl in H2. rewrite !andb_true_iff in H2;decompose [and] H2;clear H2. - simpl; apply Hf with (2:= H0);trivial. auto. + simpl; apply Hf with (2:= H0);trivial. auto with smtcoq_core. rewrite wf_interp_form, H;simpl. unfold Atom.interp_form_hatom, Atom.interp_hatom at 1;simpl. rewrite Atom.t_interp_wf, H0;simpl;trivial. @@ -1480,7 +1484,7 @@ Transparent build_z_atom. case_eq (build_clause empty_vmap cl). intros (vm1, bf) Heq. destruct (build_clause_correct _ _ _ _ Heq). - red;simpl;auto. + red;simpl;auto with smtcoq_core. decompose [and] H0. case_eq (ZTautoChecker bf c);intros Heq2. unfold C.valid;rewrite H5. @@ -1505,19 +1509,16 @@ Transparent build_z_atom. case_eq ((a0 == a1) && (a0 == b1) && (b == b0) && (b == a2)); intros; subst; try (unfold C.valid; apply valid_C_true; trivial). repeat(apply andb_prop in H19; destruct H19). - apply Int63Properties.eqb_spec in H19;apply Int63Properties.eqb_spec in H20;apply Int63Properties.eqb_spec in H21;apply Int63Properties.eqb_spec in H22; subst a0 b. + apply Int63.eqb_spec in H19;apply Int63.eqb_spec in H20;apply Int63.eqb_spec in H21;apply Int63.eqb_spec in H22; subst a0 b. unfold C.interp; simpl; rewrite orb_false_r. unfold Lit.interp; rewrite Lit.is_pos_lit. unfold Var.interp; rewrite Lit.blit_lit. rewrite wf_interp_form, H;simpl. case_eq (Lit.interp rho (a.[0]) || Lit.interp rho (a.[1]) || Lit.interp rho (a.[2])). intros;repeat (rewrite orb_true_iff in H19);destruct H19. destruct H19. - apply (afold_left_orb_true int 0); subst; auto. - apply ltb_spec;rewrite H0;compute;trivial. - apply (afold_left_orb_true int 1); auto. - apply ltb_spec;rewrite H0;compute;trivial. - apply (afold_left_orb_true int 2); auto. - apply ltb_spec;rewrite H0;compute;trivial. + apply (afold_left_orb_true 0); rewrite ?length_amap, ?get_amap; [ rewrite H0; reflexivity | assumption | rewrite H0; reflexivity ]. + apply (afold_left_orb_true 1); rewrite ?length_amap, ?get_amap; [ rewrite H0; reflexivity | assumption | rewrite H0; reflexivity ]. + apply (afold_left_orb_true 2); rewrite ?length_amap, ?get_amap; [ rewrite H0; reflexivity | assumption | rewrite H0; reflexivity ]. intros; repeat (rewrite orb_false_iff in H19);destruct H19. destruct H19. unfold Lit.interp in H19. rewrite H3 in H19; unfold Var.interp in H19; rewrite H4 in H19. @@ -1534,7 +1535,7 @@ Transparent build_z_atom. destruct (Typ.reflect_eqb (get_type t_i t_func t_atom b0) Typ.TZ) as [H12|H12]; [intros _|discriminate]. generalize H6. clear H6. destruct (Typ.reflect_eqb (get_type t_i t_func t_atom b0) t) as [H6|H6]; [intros _|discriminate]. - rewrite <- H6. auto. + rewrite <- H6. auto with smtcoq_core. rewrite H26 in H19. case_eq (interp_atom (t_atom .[ b1])); intros t1 v1 Heq1. assert (H50: t1 = Typ.TZ). @@ -1553,19 +1554,16 @@ Transparent build_z_atom. case_eq ((a0 == b0) && (a0 == a2) && (b == a1) && (b == b1)); intros; subst; try (unfold C.valid; apply valid_C_true; trivial). repeat(apply andb_prop in H19; destruct H19). - apply Int63Properties.eqb_spec in H19;apply Int63Properties.eqb_spec in H20;apply Int63Properties.eqb_spec in H21;apply Int63Properties.eqb_spec in H22;subst a0 b. + apply Int63.eqb_spec in H19;apply Int63.eqb_spec in H20;apply Int63.eqb_spec in H21;apply Int63.eqb_spec in H22;subst a0 b. unfold C.interp; simpl; rewrite orb_false_r. unfold Lit.interp; rewrite Lit.is_pos_lit. unfold Var.interp; rewrite Lit.blit_lit. rewrite wf_interp_form, H;simpl. case_eq (Lit.interp rho (a.[0]) || Lit.interp rho (a.[1]) || Lit.interp rho (a.[2])). intros;repeat (rewrite orb_true_iff in H19);destruct H19. destruct H19. - apply (afold_left_orb_true int 0); auto. - apply ltb_spec;rewrite H0;compute;trivial. - apply (afold_left_orb_true int 1); auto. - apply ltb_spec;rewrite H0;compute;trivial. - apply (afold_left_orb_true int 2); auto. - apply ltb_spec;rewrite H0;compute;trivial. + apply (afold_left_orb_true 0); rewrite ?length_amap, ?get_amap; [ rewrite H0; reflexivity | assumption | rewrite H0; reflexivity ]. + apply (afold_left_orb_true 1); rewrite ?length_amap, ?get_amap; [ rewrite H0; reflexivity | assumption | rewrite H0; reflexivity ]. + apply (afold_left_orb_true 2); rewrite ?length_amap, ?get_amap; [ rewrite H0; reflexivity | assumption | rewrite H0; reflexivity ]. intros; repeat (rewrite orb_false_iff in H19);destruct H19. destruct H19. unfold Lit.interp in H19. rewrite H3 in H19; unfold Var.interp in H19; rewrite H4 in H19. @@ -1581,7 +1579,7 @@ Transparent build_z_atom. unfold Var.interp in H23; rewrite H10 in H23. rewrite <-H22, <- H20 in H21. assert (t = Typ.TZ). - rewrite Typ.eqb_spec in H6; rewrite Typ.eqb_spec in H18; subst; auto. + rewrite Typ.eqb_spec in H6; rewrite Typ.eqb_spec in H18; subst; auto with smtcoq_core. rewrite H26 in H19. case_eq (interp_atom (t_atom .[ b0])); intros t1 v1 Heq1. assert (H50: t1 = Typ.TZ). diff --git a/src/lia/lia.ml b/src/lia/lia.ml index 86107f0..ef871f9 100644 --- a/src/lia/lia.ml +++ b/src/lia/lia.ml @@ -12,10 +12,8 @@ (*** Linking SMT Terms to Micromega Terms ***) open Util -open Structures.Micromega_plugin_Micromega -open Structures.Micromega_plugin_Coq_micromega +open CoqInterface.Micromega_plugin_Micromega -open SmtMisc open SmtForm open SmtAtom @@ -29,14 +27,6 @@ let rec pos_of_int i = then XO(pos_of_int (i lsr 1)) else XI(pos_of_int (i lsr 1)) -let z_of_int i = - if i = 0 - then Z0 - else - if i > 0 - then Zpos (pos_of_int i) - else Zneg (pos_of_int (-i)) - type my_tbl = {tbl:(hatom,int) Hashtbl.t; mutable count:int} @@ -102,7 +92,7 @@ let smt_binop_to_micromega_formula tbl op ha hb = | BO_Zge -> OpGe | BO_Zgt -> OpGt | BO_eq _ -> OpEq - | _ -> Structures.error + | _ -> CoqInterface.error "lia.ml: smt_binop_to_micromega_formula expecting a formula" in let lhs = smt_Atom_to_micromega_pExpr tbl ha in @@ -112,13 +102,11 @@ let smt_binop_to_micromega_formula tbl op ha hb = let smt_Atom_to_micromega_formula tbl ha = match Atom.atom ha with | Abop (op,ha,hb) -> smt_binop_to_micromega_formula tbl op ha hb - | _ -> Structures.error + | _ -> CoqInterface.error "lia.ml: smt_Atom_to_micromega_formula was expecting an LIA formula" (* specialized fold *) -let default_constr = lazy (Structures.econstr_of_constr (mkInt 0)) -let default_tag = Structures.Micromega_plugin_Mutils.Tag.from 0 (* morphism for general formulas *) let binop_array g tbl op def t = @@ -135,12 +123,10 @@ let binop_array g tbl op def t = let rec smt_Form_to_coq_micromega_formula tbl l = let v = match Form.pform l with - | Fatom ha -> - A (smt_Atom_to_micromega_formula tbl ha, - default_tag, Lazy.force default_constr) + | Fatom ha -> A (smt_Atom_to_micromega_formula tbl ha, Tt) | Fapp (Ftrue, _) -> TT | Fapp (Ffalse, _) -> FF - | Fapp (Fand, l) -> binop_array smt_Form_to_coq_micromega_formula tbl (fun x y -> C (x,y)) TT l + | Fapp (Fand, l) -> binop_array smt_Form_to_coq_micromega_formula tbl (fun x y -> Cj (x,y)) TT l | Fapp (For, l) -> binop_array smt_Form_to_coq_micromega_formula tbl (fun x y -> D (x,y)) FF l | Fapp (Fxor, l) -> failwith "todo:Fxor" | Fapp (Fimp, l) -> binop_array smt_Form_to_coq_micromega_formula tbl (fun x y -> I (x,None,y)) TT l @@ -162,49 +148,25 @@ let binop_list tbl op def l = | [] -> def | f::l -> List.fold_left (fun x y -> op x (smt_Form_to_coq_micromega_formula tbl y)) (smt_Form_to_coq_micromega_formula tbl f) l - -(* let rec binop_list tbl op def l = *) -(* match l with *) -(* | [] -> def *) -(* | [f] -> smt_Form_to_coq_micromega_formula tbl f *) -(* | f::l -> *) -(* op (smt_Form_to_coq_micromega_formula tbl f) (binop_list tbl op def l) *) - -(* and smt_Form_to_coq_micromega_formula tbl l = *) -(* let v = *) -(* match Form.pform l with *) -(* | Fatom ha -> *) -(* A (smt_Atom_to_micromega_formula tbl ha, *) -(* default_tag,default_constr) *) -(* | Fapp (Ftrue, _) -> TT *) -(* | Fapp (Ffalse, _) -> FF *) -(* | Fapp (Fand, l) -> binop_list tbl (fun x y -> C (x,y)) TT l *) -(* | Fapp (For, l) -> binop_list tbl (fun x y -> D (x,y)) FF l *) -(* | Fapp (Fxor, l) -> failwith "todo:Fxor" *) -(* | Fapp (Fimp, l) -> binop_list tbl (fun x y -> I (x,None,y)) TT l *) -(* | Fapp (Fiff, l) -> failwith "todo:Fiff" *) -(* | Fapp (Fite, l) -> failwith "todo:Fite" *) -(* | Fapp (Fnot2 _, l) -> smt_Form_to_coq_micromega_formula tbl l *) -(* in *) -(* if Form.is_pos l then v *) -(* else N(v) *) - - let smt_clause_to_coq_micromega_formula tbl cl = - binop_list tbl (fun x y -> C(x,y)) TT (List.map Form.neg cl) + binop_list tbl (fun x y -> Cj (x,y)) TT (List.map Form.neg cl) -(* backported from Coq-8.8.2 *) -(* val tauto_lia : Mc.z formula -> Certificate.Mc.zArithProof list option *) let tauto_lia ff = - let prover = linear_Z in - let cnf_ff,_ = Structures.Micromega_plugin_Coq_micromega.cnf Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce ff in - match witness_list_tags [prover] cnf_ff with - | None -> None - | Some l -> Some (List.map fst l) + let cnf_ff,_ = CoqInterface.Micromega_plugin_Micromega.cnfZ ff in + let rec xwitness_list l = + match l with + | [] -> Some [] + | e :: l -> + match xwitness_list l with + | None -> None + | Some l -> + match CoqInterface.Micromega_plugin_Certificate.lia true max_int (List.map (fun ((e, o), _) -> CoqInterface.Micromega_plugin_Micromega.denorm e, o) e) with + | CoqInterface.Micromega_plugin_Certificate.Prf w -> Some (w::l) + | _ -> None in + xwitness_list cnf_ff (* call to micromega solver *) let build_lia_certif cl = let tbl = create_tbl 13 in let f = I(smt_clause_to_coq_micromega_formula tbl cl, None, FF) in - tbl, f, tauto_lia f - + tauto_lia f diff --git a/src/lia/lia.mli b/src/lia/lia.mli index 8d1d691..3448f1b 100644 --- a/src/lia/lia.mli +++ b/src/lia/lia.mli @@ -10,60 +10,6 @@ (**************************************************************************) -val pos_of_int : int -> Structures.Micromega_plugin_Micromega.positive -val z_of_int : int -> Structures.Micromega_plugin_Micromega.z -type my_tbl -val get_atom_var : my_tbl -> SmtAtom.hatom -> int -val create_tbl : int -> my_tbl -val smt_Atom_to_micromega_pos : - SmtAtom.hatom -> Structures.Micromega_plugin_Micromega.positive -val smt_Atom_to_micromega_Z : - SmtAtom.hatom -> Structures.Micromega_plugin_Micromega.z -val smt_Atom_to_micromega_pExpr : - my_tbl -> - SmtAtom.hatom -> - Structures.Micromega_plugin_Micromega.z - Structures.Micromega_plugin_Micromega.pExpr -val smt_binop_to_micromega_formula : - my_tbl -> - SmtAtom.bop -> - SmtAtom.hatom -> - SmtAtom.hatom -> - Structures.Micromega_plugin_Micromega.z - Structures.Micromega_plugin_Micromega.formula -val smt_Atom_to_micromega_formula : - my_tbl -> - SmtAtom.hatom -> - Structures.Micromega_plugin_Micromega.z - Structures.Micromega_plugin_Micromega.formula -val binop_array : - ('a -> 'b -> 'c) -> 'a -> ('c -> 'c -> 'c) -> 'c -> 'b array -> 'c -val smt_Form_to_coq_micromega_formula : - my_tbl -> - SmtAtom.Form.t -> - Structures.Micromega_plugin_Micromega.z - Structures.Micromega_plugin_Coq_micromega.formula -val binop_list : - my_tbl -> - (Structures.Micromega_plugin_Micromega.z - Structures.Micromega_plugin_Coq_micromega.formula -> - Structures.Micromega_plugin_Micromega.z - Structures.Micromega_plugin_Coq_micromega.formula -> - Structures.Micromega_plugin_Micromega.z - Structures.Micromega_plugin_Coq_micromega.formula) -> - Structures.Micromega_plugin_Micromega.z - Structures.Micromega_plugin_Coq_micromega.formula -> - SmtAtom.Form.t list -> - Structures.Micromega_plugin_Micromega.z - Structures.Micromega_plugin_Coq_micromega.formula -val smt_clause_to_coq_micromega_formula : - my_tbl -> - SmtAtom.Form.t list -> - Structures.Micromega_plugin_Micromega.z - Structures.Micromega_plugin_Coq_micromega.formula val build_lia_certif : SmtAtom.Form.t list -> - my_tbl * - Structures.Micromega_plugin_Micromega.z - Structures.Micromega_plugin_Coq_micromega.formula * - Structures.Micromega_plugin_Certificate.Mc.zArithProof list option + CoqInterface.Micromega_plugin_Certificate.Mc.zArithProof list option diff --git a/src/versions/standard/smtcoq_plugin_standard.mlpack b/src/smtcoq_plugin.mlpack index 81ac24b..0907551 100644 --- a/src/versions/standard/smtcoq_plugin_standard.mlpack +++ b/src/smtcoq_plugin.mlpack @@ -1,6 +1,4 @@ -Mutils_full -Coq_micromega_full -Structures +CoqInterface SmtMisc CoqTerms diff --git a/src/smtlib2/smtlib2_genConstr.ml b/src/smtlib2/smtlib2_genConstr.ml index 0213b2e..05e02f7 100644 --- a/src/smtlib2/smtlib2_genConstr.ml +++ b/src/smtlib2/smtlib2_genConstr.ml @@ -97,10 +97,10 @@ let rec sort_of_sort = function let declare_sort_from_name rt s = - let cons_t = Structures.declare_new_type (Structures.mkId ("Smt_sort_"^s)) in + let cons_t = CoqInterface.declare_new_type (CoqInterface.mkId ("Smt_sort_"^s)) in let compdec_type = mklApp cCompDec [| cons_t |] in let compdec_var = - Structures.declare_new_variable (Structures.mkId ("CompDec_"^s)) compdec_type in + CoqInterface.declare_new_variable (CoqInterface.mkId ("CompDec_"^s)) compdec_type in let res = SmtBtype.of_coq_compdec rt cons_t compdec_var in SmtMaps.add_btype s res; res @@ -110,9 +110,9 @@ let declare_sort rt sym = declare_sort_from_name rt (string_of_symbol sym) let declare_fun_from_name rt ro s tyl ty = let coqTy = List.fold_right (fun typ c -> - Term.mkArrow (interp_to_coq rt typ) c) + CoqInterface.mkArrow (interp_to_coq rt typ) c) tyl (interp_to_coq rt ty) in - let cons_v = Structures.declare_new_variable (Structures.mkId ("Smt_var_"^s)) coqTy in + let cons_v = CoqInterface.declare_new_variable (CoqInterface.mkId ("Smt_var_"^s)) coqTy in let op = Op.declare ro cons_v (Array.of_list tyl) ty None in SmtMaps.add_fun s op; op diff --git a/src/smtlib2/smtlib2_solver.ml b/src/smtlib2/smtlib2_solver.ml index 45a30f9..68db604 100644 --- a/src/smtlib2/smtlib2_solver.ml +++ b/src/smtlib2/smtlib2_solver.ml @@ -73,7 +73,7 @@ let read_response { lexbuf } = let error s sexp = kill s; - Structures.error (asprintf "Solver error: %a." SExpr.print sexp) + CoqInterface.error (asprintf "Solver error: %a." SExpr.print sexp) let read_success s = @@ -89,7 +89,7 @@ let read_check_result s = match SExprParser.sexp SExprLexer.main s.lexbuf with | SExpr.Atom "sat" -> Sat | SExpr.Atom "unsat" -> Unsat - | SExpr.Atom "unknown" -> Structures.error ("Solver returned uknown.") + | SExpr.Atom "unknown" -> CoqInterface.error ("Solver returned uknown.") | r -> error s r @@ -111,7 +111,7 @@ let send_command s cmd read = * let buf = Bytes.create err_p2 in * Unix.read s.stderr buf 0 err_p2 |> ignore; * let err_msg = Bytes.sub_string buf err_p1 len in - * Structures.error ("Solver error: "^err_msg); + * CoqInterface.error ("Solver error: "^err_msg); * end * else (kill s; raise e) *) kill s; raise e diff --git a/src/spl/Arithmetic.v b/src/spl/Arithmetic.v index cca1c21..3a127c4 100644 --- a/src/spl/Arithmetic.v +++ b/src/spl/Arithmetic.v @@ -63,8 +63,6 @@ Section Arith. Let wf_rho : Valuation.wf rho. Proof. destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form); auto. Qed. - Hint Immediate wf_rho. - Lemma valid_check_spl_arith : forall orig, C.valid rho orig -> @@ -76,7 +74,7 @@ Section Arith. (* List with one element *) intros H res l; case_eq (build_clause Lia.empty_vmap (Lit.neg li :: res :: nil)); [ |intros; apply C.interp_true; auto]. intros (vm1, bf) Heq; destruct (Lia.build_clause_correct _ _ _ t_func ch_atom ch_form wt_t_atom _ _ _ _ Heq) as [H1 H0]. - red; simpl; auto. + red; simpl; auto with smtcoq_core. decompose [and] H0; case_eq (ZTautoChecker bf l); [intros Heq3|intros; apply C.interp_true; auto]. unfold C.valid; replace (C.interp rho (res :: nil)) with (C.interp rho (Lit.neg li :: res :: nil)). rewrite H6; apply ZTautoChecker_sound with l;trivial. diff --git a/src/spl/Assumptions.v b/src/spl/Assumptions.v index 1affa38..0a8d79e 100644 --- a/src/spl/Assumptions.v +++ b/src/spl/Assumptions.v @@ -93,7 +93,7 @@ Section Checker_correct. Proof. induction c1 as [ |l1 c1 IHc1]; simpl; intros [ |l2 c2]; simpl; auto; try discriminate. unfold is_true. rewrite andb_true_iff. intros [H1 H2]. - rewrite Int63Properties.eqb_spec in H1. now rewrite (IHc1 _ H2), H1. + rewrite Int63.eqb_spec in H1. now rewrite (IHc1 _ H2), H1. Qed. Lemma valid_check_clause cid c : diff --git a/src/spl/Operators.v b/src/spl/Operators.v index 4faee39..540de3f 100644 --- a/src/spl/Operators.v +++ b/src/spl/Operators.v @@ -52,7 +52,7 @@ Section Operators. Fixpoint check_diseqs_complete_aux a dist t := match dist with | nil => true - | b::q => if PArray.existsb (fun (x:option (int*int)) => + | b::q => if aexistsbi (fun _ (x:option (int*int)) => match x with | Some (a',b') => ((a == a') && (b == b')) || ((a == b') && (b == a')) | None => false @@ -68,10 +68,10 @@ Section Operators. Proof. intros a dist t; induction dist as [ |b q IHq]; simpl; split; auto. intros _ y H; inversion H. - case_eq (PArray.existsb (fun x : option (int * int) => match x with | Some (a', b') => (a == a') && (b == b') || (a == b') && (b == a') | None => false end) t); try discriminate; rewrite PArray.existsb_spec; intros [i [H1 H2]]; rewrite IHq; clear IHq; intros H3 y [H4|H4]; auto; subst y; exists i; split; auto; generalize H2; case (t .[ i]); try discriminate; intros [a' b']; rewrite orb_true_iff, !andb_true_iff, !Int63Properties.eqb_spec; intros [[H4 H5]|[H4 H5]]; subst a' b'; auto. - intro H1; case_eq (PArray.existsb (fun x : option (int * int) => match x with | Some (a', b') => (a == a') && (b == b') || (a == b') && (b == a') | None => false end) t). + case_eq (aexistsbi (fun _ (x : option (int * int)) => match x with | Some (a', b') => (a == a') && (b == b') || (a == b') && (b == a') | None => false end) t); try discriminate; rewrite aexistsbi_spec; intros [i [H1 H2]]; rewrite IHq; clear IHq; intros H3 y [H4|H4]; auto; subst y; exists i; split; auto; generalize H2; case (t .[ i]); try discriminate; intros [a' b']; rewrite orb_true_iff, !andb_true_iff, !Int63.eqb_spec; intros [[H4 H5]|[H4 H5]]; subst a' b'; auto. + intro H1; case_eq (aexistsbi (fun _ (x : option (int * int)) => match x with | Some (a', b') => (a == a') && (b == b') || (a == b') && (b == a') | None => false end) t). intros _; rewrite IHq; clear IHq; intros y Hy; apply H1; auto. - rewrite array_existsb_false_spec; destruct (H1 b (or_introl (refl_equal b))) as [i [H2 H3]]; intro H; rewrite <- (H _ H2); destruct H3 as [H3|H3]; rewrite H3; rewrite !eqb_refl; auto; rewrite orb_true_r; auto. + rewrite aexistsbi_false_spec; destruct (H1 b (or_introl (refl_equal b))) as [i [H2 H3]]; intro H; rewrite <- (H _ H2); destruct H3 as [H3|H3]; rewrite H3; rewrite !eqb_refl; auto; rewrite orb_true_r; auto. Qed. @@ -82,10 +82,10 @@ Section Operators. Proof. intros a dist t; induction dist as [ |b q IHq]; simpl; split; try discriminate. intros [y [H _]]; elim H. - case_eq (PArray.existsb (fun x : option (int * int) => match x with | Some (a', b') => (a == a') && (b == b') || (a == b') && (b == a') | None => false end) t). + case_eq (aexistsbi (fun _ (x : option (int * int)) => match x with | Some (a', b') => (a == a') && (b == b') || (a == b') && (b == a') | None => false end) t). intros _; rewrite IHq; clear IHq; intros [y [H3 H4]]; exists y; auto. - rewrite array_existsb_false_spec; intros H _; exists b; split; auto; intros i Hi; split; intro H1; generalize (H _ Hi); rewrite H1, !eqb_refl; try discriminate; rewrite orb_true_r; discriminate. - intros [y [H1 H2]]; case_eq (PArray.existsb (fun x : option (int * int) => match x with | Some (a', b') => (a == a') && (b == b') || (a == b') && (b == a') | None => false end) t); auto; rewrite PArray.existsb_spec; intros [i [H3 H4]]; rewrite IHq; clear IHq; exists y; destruct H1 as [H1|H1]; auto; subst y; case_eq (t.[i]); [intros [a' b'] Heq|intro Heq]; rewrite Heq in H4; try discriminate; rewrite orb_true_iff, !andb_true_iff, !eqb_spec in H4; destruct H4 as [[H4 H5]|[H4 H5]]; subst a' b'; generalize (H2 _ H3); rewrite Heq; intros [H4 H5]; [elim H4|elim H5]; auto. + rewrite aexistsbi_false_spec; intros H _; exists b; split; auto; intros i Hi; split; intro H1; generalize (H _ Hi); rewrite H1, !eqb_refl; try discriminate; rewrite orb_true_r; discriminate. + intros [y [H1 H2]]; case_eq (aexistsbi (fun _ (x : option (int * int)) => match x with | Some (a', b') => (a == a') && (b == b') || (a == b') && (b == a') | None => false end) t); auto; rewrite aexistsbi_spec; intros [i [H3 H4]]; rewrite IHq; clear IHq; exists y; destruct H1 as [H1|H1]; auto; subst y; case_eq (t.[i]); [intros [a' b'] Heq|intro Heq]; rewrite Heq in H4; try discriminate; rewrite orb_true_iff, !andb_true_iff, !eqb_spec in H4; destruct H4 as [[H4 H5]|[H4 H5]]; subst a' b'; generalize (H2 _ H3); rewrite Heq; intros [H4 H5]; [elim H4|elim H5]; auto. Qed. @@ -129,7 +129,7 @@ Section Operators. Definition check_diseqs ty dist diseq := - let t := PArray.mapi (fun _ t => + let t := amap (fun t => if Lit.is_pos t then None else match get_form (Lit.blit t) with | Fatom a => @@ -144,7 +144,7 @@ Section Operators. | _ => None end ) diseq in - PArray.forallb (fun x => match x with | None => false | _ => true end) t && + aforallbi (fun _ x => match x with | None => false | _ => true end) t && check_diseqs_complete dist t. @@ -166,17 +166,17 @@ Section Operators. get_atom a = Atom.Abop (Atom.BO_eq A) y x))). Proof. intros A dist diseq; unfold check_diseqs; rewrite andb_true_iff, - PArray.forallb_spec, check_diseqs_complete_spec, length_mapi; split; intros [H1 H2]; split. - clear H2; intros i Hi; generalize (H1 _ Hi); rewrite get_mapi; + aforallbi_spec, check_diseqs_complete_spec, length_amap; split; intros [H1 H2]; split. + clear H2; intros i Hi; generalize (H1 _ Hi); rewrite get_amap; auto; case_eq (Lit.is_pos (diseq .[ i])); try discriminate; intro Heq1; case_eq (get_form (Lit.blit (diseq .[ i]))); try discriminate; intros a Heq2; case_eq (get_atom a); try discriminate; intros [ | | | | | | | B | | | | | | | | | | | | ]; try discriminate; intros h1 h2 Heq3; case_eq (Typ.eqb A B); try discriminate; change (Typ.eqb A B = true) with (is_true (Typ.eqb A B)); rewrite Typ.eqb_spec; intro; subst B; case_eq (h1 == h2); try discriminate; rewrite eqb_false_spec; intro H2; case_eq (check_in h1 dist); try discriminate; case_eq (check_in h2 dist); try discriminate; rewrite !check_in_spec; intros H3 H4 _; split; try discriminate; exists a; split; auto; exists h1, h2; repeat split; auto; rewrite <- In2_In; auto. - clear H1; intros x y Hxy; destruct (H2 _ _ Hxy) as [i [H1 H4]]; clear H2; rewrite get_mapi in H4; auto; exists i; split; auto; generalize H4; + clear H1; intros x y Hxy; destruct (H2 _ _ Hxy) as [i [H1 H4]]; clear H2; rewrite get_amap in H4; auto; exists i; split; auto; generalize H4; case_eq (Lit.is_pos (diseq .[ i])); intro Heq; try (intros [H|H]; discriminate); case_eq (get_form (Lit.blit (diseq .[ i]))); [intros a| | |intros a1 a2|intros a1|intros a1|intros a1|intros a1 a2|intros a1 a2| intros a1 a2 a3|intros a ls]; intro Heq2; try (intros [H|H]; discriminate); case_eq (get_atom a); [intros a1|intros a1 a2|intros [ | | | | | | | B | | | | | | | | | | | | ] h1 h2|intros a1 a2|intros a1 a2 | intros a1 a2]; intro Heq3; try (intros [H|H]; discriminate); try (case_eq (Typ.eqb A B); try (intros _ [H|H]; discriminate); change (Typ.eqb A B = true) with (is_true (Typ.eqb A B)); rewrite Typ.eqb_spec; intro; subst B; case_eq (h1 == h2); try (intros _ [H|H]; discriminate); rewrite eqb_false_spec; intro H10; case (check_in h1 dist); try (intros [H|H]; discriminate); case (check_in h2 dist); try (intros [H|H]; discriminate); simpl; intro H3; split; try discriminate; exists a; split; auto; destruct H3 as [H3|H3]; inversion H3; subst; auto). intros. destruct H0; now contradict H0. - clear H2; intros i Hi; rewrite get_mapi; auto; destruct (H1 _ Hi) as [H2 [a [H3 [h1 [h2 [H4 [H5 H6]]]]]]]; clear H1; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto); rewrite H3, H4, Typ.eqb_refl; simpl; replace (h1 == h2) with false by (case_eq (h1 == h2); auto; rewrite eqb_spec; intro H; elim H5; auto); simpl; rewrite <- In2_In, <- !check_in_spec in H6; auto; destruct H6 as [H6 H7]; rewrite H6, H7; auto. - clear H1; intros x y Hxy; destruct (H2 _ _ Hxy) as [i [H1 [H3 [a [H4 [H6 H5]]]]]]; clear H2; exists i; split; auto; rewrite get_mapi; auto; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto); rewrite H4; assert (H7 := or_introl (In2 y x dist) Hxy); rewrite <- In2_In, <- !check_in_spec in H7; auto; destruct H7 as [H7 H8]; destruct H5 as [H5|H5]; rewrite H5, Typ.eqb_refl; [replace (x == y) with false by (case_eq (x == y); auto; rewrite eqb_spec; auto)|replace (y == x) with false by (case_eq (y == x); auto; rewrite eqb_spec; auto)]; simpl; rewrite H7, H8; auto. + clear H2; intros i Hi; rewrite get_amap; auto; destruct (H1 _ Hi) as [H2 [a [H3 [h1 [h2 [H4 [H5 H6]]]]]]]; clear H1; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto); rewrite H3, H4, Typ.eqb_refl; simpl; replace (h1 == h2) with false by (case_eq (h1 == h2); auto; rewrite eqb_spec; intro H; elim H5; auto); simpl; rewrite <- In2_In, <- !check_in_spec in H6; auto; destruct H6 as [H6 H7]; rewrite H6, H7; auto. + clear H1; intros x y Hxy; destruct (H2 _ _ Hxy) as [i [H1 [H3 [a [H4 [H6 H5]]]]]]; clear H2; exists i; split; auto; rewrite get_amap; auto; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto); rewrite H4; assert (H7 := or_introl (In2 y x dist) Hxy); rewrite <- In2_In, <- !check_in_spec in H7; auto; destruct H7 as [H7 H8]; destruct H5 as [H5|H5]; rewrite H5, Typ.eqb_refl; [replace (x == y) with false by (case_eq (x == y); auto; rewrite eqb_spec; auto)|replace (y == x) with false by (case_eq (y == x); auto; rewrite eqb_spec; auto)]; simpl; rewrite H7, H8; auto. Qed. @@ -247,7 +247,7 @@ intros. destruct H0; now contradict H0. get_atom hb = Atom.Abop (Atom.BO_eq ty) y x). Proof. intros f1 f2; unfold check_distinct_two_args; split. - case (get_form f1); try discriminate; intro ha; case (get_form f2); try discriminate; intro hb; case_eq (get_atom ha); try discriminate; intros [A] [ |x [ |y [ |l]]] Heq1; try discriminate; case_eq (get_atom hb); try discriminate; intros [ | | | | | | |B | | | | | | | | | | | | ] x' y' Heq2; try discriminate; rewrite !andb_true_iff, orb_true_iff, !andb_true_iff; change (Typ.eqb A B = true) with (is_true (Typ.eqb A B)); rewrite Typ.eqb_spec, !Int63Properties.eqb_spec; intros [H1 [[H2 H3]|[H2 H3]]]; subst B x' y'; exists ha, hb, A, x, y; auto. + case (get_form f1); try discriminate; intro ha; case (get_form f2); try discriminate; intro hb; case_eq (get_atom ha); try discriminate; intros [A] [ |x [ |y [ |l]]] Heq1; try discriminate; case_eq (get_atom hb); try discriminate; intros [ | | | | | | |B | | | | | | | | | | | | ] x' y' Heq2; try discriminate; rewrite !andb_true_iff, orb_true_iff, !andb_true_iff; change (Typ.eqb A B = true) with (is_true (Typ.eqb A B)); rewrite Typ.eqb_spec, !Int63.eqb_spec; intros [H1 [[H2 H3]|[H2 H3]]]; subst B x' y'; exists ha, hb, A, x, y; auto. intros [ha [hb [A [x [y [H1 [H2 [H3 [H4|H4]]]]]]]]]; rewrite H1, H2, H3, H4, Typ.eqb_refl, !eqb_refl; auto; rewrite orb_true_r; auto. Qed. @@ -279,28 +279,28 @@ intros. destruct H0; now contradict H0. Lemma wf_t_form : wf t_form. Proof. destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form) as [[_ H] _]; auto. Qed. - Local Hint Immediate wf_t_atom default_t_atom default_t_form wf_t_form. + Local Hint Immediate wf_t_atom default_t_atom default_t_form wf_t_form : smtcoq_spl_op. Lemma interp_check_distinct : forall ha diseq, check_distinct ha diseq = true -> - interp_form_hatom ha = afold_left bool int true andb (Lit.interp rho) diseq. + interp_form_hatom ha = afold_left bool true andb (amap (Lit.interp rho) diseq). Proof. - intros ha diseq; rewrite check_distinct_spec; intros [A [dist [H1 H2]]]; rewrite check_diseqs_spec in H2; destruct H2 as [H2 H3]; unfold Atom.interp_form_hatom, Atom.interp_bool, Atom.interp_hatom; rewrite Atom.t_interp_wf; auto; rewrite H1; simpl; generalize (Atom.compute_interp_spec_rev t_i (get (Atom.t_interp t_i t_func t_atom)) A dist); case (Atom.compute_interp t_i (get (Atom.t_interp t_i t_func t_atom)) A nil); simpl. + intros ha diseq; rewrite check_distinct_spec; intros [A [dist [H1 H2]]]; rewrite check_diseqs_spec in H2; destruct H2 as [H2 H3]; unfold Atom.interp_form_hatom, Atom.interp_bool, Atom.interp_hatom; rewrite Atom.t_interp_wf; auto with smtcoq_spl_op; rewrite H1; simpl; generalize (Atom.compute_interp_spec_rev t_i (get (Atom.t_interp t_i t_func t_atom)) A dist); case (Atom.compute_interp t_i (get (Atom.t_interp t_i t_func t_atom)) A nil); simpl. intros l H4; case_eq (distinct (Typ.i_eqb t_i A) (rev l)). - rewrite distinct_spec; intro H5; symmetry; apply afold_left_andb_true; intros i Hi; destruct (H2 _ Hi) as [H9 [a [H10 [h1 [h2 [H6 [H7 H8]]]]]]]; unfold Lit.interp; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto); unfold Var.interp; rewrite Form.wf_interp_form; auto; rewrite H10; simpl; rewrite Atom.t_interp_wf; auto; rewrite H6; simpl; unfold Atom.apply_binop; unfold Atom.wt in wt_t_atom; unfold is_true in wt_t_atom; rewrite forallbi_spec in wt_t_atom; assert (H11: a < length t_atom). - case_eq (a < length t_atom); auto; intro H11; rewrite (get_outofbound _ _ _ H11) in H6; rewrite default_t_atom in H6; inversion H6. - generalize (wt_t_atom _ H11); rewrite H6; simpl; rewrite !andb_true_iff; change (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) h1) A = true) with (is_true (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) h1) A)); change (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) h2) A = true) with (is_true (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) h2) A)); rewrite !Typ.eqb_spec; intros [[_ H13] H12]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom h1); rewrite H13; intros [v1 HH1]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom h2); rewrite H12; intros [v2 HH2]; rewrite HH1, HH2; simpl; rewrite Typ.cast_refl; simpl; destruct H8 as [H8|H8]; [ |rewrite Typ.i_eqb_sym]; rewrite H5; auto; rewrite H4; [exists h2; exists h1|exists h1; exists h2]; auto. - rewrite distinct_false_spec; intros [v2 [v1 [H5 H6]]]; rewrite H4 in H5; destruct H5 as [a [b [H5 [H7 H8]]]]; clear H4; change (Typ.i_eqb t_i A v2 v1 = true) with (is_true (Typ.i_eqb t_i A v2 v1)) in H6; rewrite Typ.i_eqb_spec in H6; subst v2; clear H2; destruct (H3 _ _ H5) as [i [H2 [H4 [hb [H6 [H9 H10]]]]]]; clear H3; symmetry; apply (afold_left_andb_false _ i); auto; unfold Lit.interp; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto); unfold Var.interp; rewrite Form.wf_interp_form; auto; rewrite H6; simpl; rewrite Atom.t_interp_wf; auto; destruct H10 as [H10|H10]; rewrite H10; simpl; rewrite H7, H8; simpl; rewrite Typ.cast_refl; simpl; replace (Typ.i_eqb t_i A v1 v1) with true; auto; symmetry; change (is_true (Typ.i_eqb t_i A v1 v1)); rewrite Typ.i_eqb_spec; auto. + rewrite distinct_spec; intro H5; symmetry; apply afold_left_andb_true; rewrite length_amap; intros i Hi; rewrite get_amap by exact Hi; destruct (H2 _ Hi) as [H9 [a [H10 [h1 [h2 [H6 [H7 H8]]]]]]]; unfold Lit.interp; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto with smtcoq_spl_op smtcoq_core); unfold Var.interp; rewrite Form.wf_interp_form; auto with smtcoq_spl_op smtcoq_core; rewrite H10; simpl; rewrite Atom.t_interp_wf; auto with smtcoq_spl_op smtcoq_core; rewrite H6; simpl; unfold Atom.apply_binop; unfold Atom.wt in wt_t_atom; unfold is_true in wt_t_atom; rewrite aforallbi_spec in wt_t_atom; assert (H11: a < length t_atom). + case_eq (a < length t_atom); auto with smtcoq_spl_op smtcoq_core; intro H11; rewrite (get_outofbound _ _ _ H11) in H6; rewrite default_t_atom in H6; inversion H6. + generalize (wt_t_atom _ H11); rewrite H6; simpl; rewrite !andb_true_iff; change (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) h1) A = true) with (is_true (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) h1) A)); change (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) h2) A = true) with (is_true (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) h2) A)); rewrite !Typ.eqb_spec; intros [[_ H13] H12]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom h1); rewrite H13; intros [v1 HH1]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom h2); rewrite H12; intros [v2 HH2]; rewrite HH1, HH2; simpl; rewrite Typ.cast_refl; simpl; destruct H8 as [H8|H8]; [ |rewrite Typ.i_eqb_sym]; rewrite H5; auto with smtcoq_spl_op smtcoq_core; rewrite H4; [exists h2; exists h1|exists h1; exists h2]; auto with smtcoq_spl_op smtcoq_core. + rewrite distinct_false_spec; intros [v2 [v1 [H5 H6]]]; rewrite H4 in H5; destruct H5 as [a [b [H5 [H7 H8]]]]; clear H4; change (Typ.i_eqb t_i A v2 v1 = true) with (is_true (Typ.i_eqb t_i A v2 v1)) in H6; rewrite Typ.i_eqb_spec in H6; subst v2; clear H2; destruct (H3 _ _ H5) as [i [H2 [H4 [hb [H6 [H9 H10]]]]]]; clear H3; symmetry; apply (afold_left_andb_false i); rewrite ?length_amap; auto with smtcoq_spl_op smtcoq_core; rewrite get_amap by assumption; unfold Lit.interp; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto with smtcoq_spl_op smtcoq_core); unfold Var.interp; rewrite Form.wf_interp_form; auto with smtcoq_spl_op smtcoq_core; rewrite H6; simpl; rewrite Atom.t_interp_wf; auto with smtcoq_spl_op smtcoq_core; destruct H10 as [H10|H10]; rewrite H10; simpl; rewrite H7, H8; simpl; rewrite Typ.cast_refl; simpl; replace (Typ.i_eqb t_i A v1 v1) with true; auto with smtcoq_spl_op smtcoq_core; symmetry; change (is_true (Typ.i_eqb t_i A v1 v1)); rewrite Typ.i_eqb_spec; auto with smtcoq_spl_op smtcoq_core. intros [a [H20 H21]]; assert (H4: ha < length t_atom). - case_eq (ha < length t_atom); auto; intro Heq; generalize H1; rewrite get_outofbound; auto; rewrite default_t_atom; discriminate. - unfold Atom.wt in wt_t_atom; unfold is_true in wt_t_atom; rewrite forallbi_spec in wt_t_atom; generalize (wt_t_atom _ H4); rewrite H1; simpl; rewrite andb_true_iff, forallb_forall; intros [_ H5]; assert (H6 := H5 _ H20); generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a); intros [va Ha]; rewrite Ha in H21; simpl in H21; elim H21; apply Typ.eqb_spec; auto. + case_eq (ha < length t_atom); auto with smtcoq_spl_op smtcoq_core; intro Heq; generalize H1; rewrite get_outofbound; auto with smtcoq_spl_op smtcoq_core; rewrite default_t_atom; discriminate. + unfold Atom.wt in wt_t_atom; unfold is_true in wt_t_atom; rewrite aforallbi_spec in wt_t_atom; generalize (wt_t_atom _ H4); rewrite H1; simpl; rewrite andb_true_iff, forallb_forall; intros [_ H5]; assert (H6 := H5 _ H20); generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a); intros [va Ha]; rewrite Ha in H21; simpl in H21; elim H21; apply Typ.eqb_spec; auto with smtcoq_spl_op smtcoq_core. Qed. Lemma interp_check_distinct_two_args : forall f1 f2, check_distinct_two_args f1 f2 = true -> rho f1 = negb (rho f2). Proof. - intros f1 f2; rewrite check_distinct_two_args_spec; intros [ha [hb [A [x [y [H1 [H2 [H3 [H4|H4]]]]]]]]]; unfold Form.interp_state_var; assert (H5: f1 < length t_form) by (case_eq (f1 < length t_form); auto; intro Heq; generalize H1; rewrite get_outofbound; auto; rewrite default_t_form; discriminate); assert (H6: f2 < length t_form) by (case_eq (f2 < length t_form); auto; intro Heq; generalize H2; rewrite get_outofbound; auto; rewrite default_t_form; discriminate); rewrite !Form.t_interp_wf; auto; rewrite H1, H2; simpl; unfold Atom.interp_form_hatom, Atom.interp_hatom; rewrite !Atom.t_interp_wf; auto; rewrite H3, H4; simpl; unfold Atom.wt,is_true in wt_t_atom; rewrite forallbi_spec in wt_t_atom; assert (H7: hb < length t_atom) by (case_eq (hb < length t_atom); auto; intro Heq; generalize H4; rewrite get_outofbound; auto; rewrite default_t_atom; discriminate); generalize (wt_t_atom _ H7); rewrite H4; simpl; case (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) hb); try discriminate; simpl; rewrite andb_true_iff; change (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) x) A = true) with (is_true (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) x) A)); change (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) y) A = true) with (is_true (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) y) A)); rewrite !Typ.eqb_spec; intros [H8 H9]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom x), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom y); rewrite H8, H9; intros [v1 HH1] [v2 HH2]; rewrite HH1, HH2; simpl; rewrite Typ.cast_refl; auto; rewrite Typ.i_eqb_sym; auto. + intros f1 f2; rewrite check_distinct_two_args_spec; intros [ha [hb [A [x [y [H1 [H2 [H3 [H4|H4]]]]]]]]]; unfold Form.interp_state_var; assert (H5: f1 < length t_form) by (case_eq (f1 < length t_form); auto with smtcoq_spl_op smtcoq_core; intro Heq; generalize H1; rewrite get_outofbound; auto with smtcoq_spl_op smtcoq_core; rewrite default_t_form; discriminate); assert (H6: f2 < length t_form) by (case_eq (f2 < length t_form); auto with smtcoq_spl_op smtcoq_core; intro Heq; generalize H2; rewrite get_outofbound; auto with smtcoq_spl_op smtcoq_core; rewrite default_t_form; discriminate); rewrite !Form.t_interp_wf; auto with smtcoq_spl_op smtcoq_core; rewrite H1, H2; simpl; unfold Atom.interp_form_hatom, Atom.interp_hatom; rewrite !Atom.t_interp_wf; auto with smtcoq_spl_op smtcoq_core; rewrite H3, H4; simpl; unfold Atom.wt,is_true in wt_t_atom; rewrite aforallbi_spec in wt_t_atom; assert (H7: hb < length t_atom) by (case_eq (hb < length t_atom); auto with smtcoq_spl_op smtcoq_core; intro Heq; generalize H4; rewrite get_outofbound; auto with smtcoq_spl_op smtcoq_core; rewrite default_t_atom; discriminate); generalize (wt_t_atom _ H7); rewrite H4; simpl; case (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) hb); try discriminate; simpl; rewrite andb_true_iff; change (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) x) A = true) with (is_true (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) x) A)); change (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) y) A = true) with (is_true (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) y) A)); rewrite !Typ.eqb_spec; intros [H8 H9]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom x), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom y); rewrite H8, H9; intros [v1 HH1] [v2 HH2]; rewrite HH1, HH2; simpl; rewrite Typ.cast_refl; auto with smtcoq_spl_op smtcoq_core; rewrite Typ.i_eqb_sym; auto with smtcoq_spl_op smtcoq_core. Qed. @@ -308,13 +308,13 @@ intros. destruct H0; now contradict H0. (* check_distinct ha diseq -> *) (* interp_form_hatom ha -> afold_left bool int true andb (Lit.interp rho) diseq. *) (* Proof. *) - (* intros ha diseq; rewrite check_distinct_spec; intros [A [dist [H1 H]]]; rewrite check_diseqs_spec in H; unfold Atom.interp_form_hatom, Atom.interp_bool, Atom.interp_hatom; rewrite Atom.t_interp_wf; auto; rewrite H1; simpl; generalize (Atom.compute_interp_spec_rev t_i (get (Atom.t_interp t_i t_func t_atom)) A dist); case (Atom.compute_interp t_i (get (Atom.t_interp t_i t_func t_atom)) A nil); simpl. *) - (* intros l H2; unfold is_true; rewrite distinct_spec; intro H3; apply afold_left_andb_true; intros i Hi; destruct (H _ Hi) as [H4 [a [H5 [h1 [h2 [H6 [H7 H8]]]]]]]; unfold Lit.interp; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto); unfold Var.interp; rewrite Form.wf_interp_form; auto; rewrite H5; simpl; rewrite Atom.t_interp_wf; auto; rewrite H6; simpl; unfold Atom.apply_binop; unfold Atom.wt in wt_t_atom; unfold is_true in wt_t_atom; rewrite forallbi_spec in wt_t_atom; assert (H10: a < length t_atom). *) - (* case_eq (a < length t_atom); auto; intro H10; rewrite (get_outofbound _ _ _ H10) in H6; rewrite default_t_atom in H6; inversion H6. *) - (* generalize (wt_t_atom _ H10); rewrite H6; simpl; rewrite !andb_true_iff. change (Typ.eqb (Atom.get_type t_i t_func t_atom h1) A = true) with (is_true (Typ.eqb (Atom.get_type t_i t_func t_atom h1) A)); change (Typ.eqb (Atom.get_type t_i t_func t_atom h2) A = true) with (is_true (Typ.eqb (Atom.get_type t_i t_func t_atom h2) A)); rewrite !Typ.eqb_spec; intros [[_ H11] H12]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom h1); rewrite H11; intros [v1 HH1]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom h2); rewrite H12; intros [v2 HH2]; rewrite HH1, HH2; simpl; rewrite Typ.cast_refl; simpl; destruct H8 as [H8|H8]; [ |rewrite Typ.i_eqb_sym]; rewrite H3; auto; rewrite H2; [exists h2; exists h1|exists h1; exists h2]; auto. *) + (* intros ha diseq; rewrite check_distinct_spec; intros [A [dist [H1 H]]]; rewrite check_diseqs_spec in H; unfold Atom.interp_form_hatom, Atom.interp_bool, Atom.interp_hatom; rewrite Atom.t_interp_wf; auto with smtcoq_spl_op smtcoq_core; rewrite H1; simpl; generalize (Atom.compute_interp_spec_rev t_i (get (Atom.t_interp t_i t_func t_atom)) A dist); case (Atom.compute_interp t_i (get (Atom.t_interp t_i t_func t_atom)) A nil); simpl. *) + (* intros l H2; unfold is_true; rewrite distinct_spec; intro H3; apply afold_left_andb_true; intros i Hi; destruct (H _ Hi) as [H4 [a [H5 [h1 [h2 [H6 [H7 H8]]]]]]]; unfold Lit.interp; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto with smtcoq_spl_op smtcoq_core); unfold Var.interp; rewrite Form.wf_interp_form; auto with smtcoq_spl_op smtcoq_core; rewrite H5; simpl; rewrite Atom.t_interp_wf; auto with smtcoq_spl_op smtcoq_core; rewrite H6; simpl; unfold Atom.apply_binop; unfold Atom.wt in wt_t_atom; unfold is_true in wt_t_atom; rewrite aforallbi_spec in wt_t_atom; assert (H10: a < length t_atom). *) + (* case_eq (a < length t_atom); auto with smtcoq_spl_op smtcoq_core; intro H10; rewrite (get_outofbound _ _ _ H10) in H6; rewrite default_t_atom in H6; inversion H6. *) + (* generalize (wt_t_atom _ H10); rewrite H6; simpl; rewrite !andb_true_iff. change (Typ.eqb (Atom.get_type t_i t_func t_atom h1) A = true) with (is_true (Typ.eqb (Atom.get_type t_i t_func t_atom h1) A)); change (Typ.eqb (Atom.get_type t_i t_func t_atom h2) A = true) with (is_true (Typ.eqb (Atom.get_type t_i t_func t_atom h2) A)); rewrite !Typ.eqb_spec; intros [[_ H11] H12]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom h1); rewrite H11; intros [v1 HH1]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom h2); rewrite H12; intros [v2 HH2]; rewrite HH1, HH2; simpl; rewrite Typ.cast_refl; simpl; destruct H8 as [H8|H8]; [ |rewrite Typ.i_eqb_sym]; rewrite H3; auto with smtcoq_spl_op smtcoq_core; rewrite H2; [exists h2; exists h1|exists h1; exists h2]; auto with smtcoq_spl_op smtcoq_core. *) (* intros [a [H2 H3]] _; assert (H4: ha < length t_atom). *) - (* case_eq (ha < length t_atom); auto; intro Heq; generalize H1; rewrite get_outofbound; auto; rewrite default_t_atom; discriminate. *) - (* unfold Atom.wt in wt_t_atom; unfold is_true in wt_t_atom; rewrite forallbi_spec in wt_t_atom; generalize (wt_t_atom _ H4); rewrite H1; simpl; rewrite andb_true_iff, forallb_forall; intros [_ H5]; assert (H6 := H5 _ H2); generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a); intros [va Ha]; rewrite Ha in H3; simpl in H3; elim H3; apply Typ.eqb_spec; auto. *) + (* case_eq (ha < length t_atom); auto with smtcoq_spl_op smtcoq_core; intro Heq; generalize H1; rewrite get_outofbound; auto with smtcoq_spl_op smtcoq_core; rewrite default_t_atom; discriminate. *) + (* unfold Atom.wt in wt_t_atom; unfold is_true in wt_t_atom; rewrite aforallbi_spec in wt_t_atom; generalize (wt_t_atom _ H4); rewrite H1; simpl; rewrite andb_true_iff, forallb_forall; intros [_ H5]; assert (H6 := H5 _ H2); generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a); intros [va Ha]; rewrite Ha in H3; simpl in H3; elim H3; apply Typ.eqb_spec; auto with smtcoq_spl_op smtcoq_core. *) (* Qed. *) End Valid1. @@ -337,10 +337,10 @@ intros. destruct H0; now contradict H0. | Ftrue, Ftrue => true | Ffalse, Ffalse => true | Fnot2 i1 l1, Fnot2 i2 l2 => (i1 == i2) && (check_lit l1 l2) - | Fand a1, Fand a2 => (length a1 == length a2) && (forallbi (fun i l => check_lit l (a2.[i])) a1) - | For a1, For a2 => (length a1 == length a2) && (forallbi (fun i l => check_lit l (a2.[i])) a1) - | Fimp a1, Fimp a2 => (length a1 == length a2) && (forallbi (fun i l => check_lit l (a2.[i])) a1) - (* (length a1 == length a2) && (forallbi (fun i l => if i < length a1 - 1 then check_lit (a2.[i]) l else check_lit l (a2.[i])) a1) *) + | Fand a1, Fand a2 => (length a1 == length a2) && (aforallbi (fun i l => check_lit l (a2.[i])) a1) + | For a1, For a2 => (length a1 == length a2) && (aforallbi (fun i l => check_lit l (a2.[i])) a1) + | Fimp a1, Fimp a2 => (length a1 == length a2) && (aforallbi (fun i l => check_lit l (a2.[i])) a1) + (* (length a1 == length a2) && (aforallbi (fun i l => if i < length a1 - 1 then check_lit (a2.[i]) l else check_lit l (a2.[i])) a1) *) | Fxor l1 l2, Fxor j1 j2 => check_lit l1 j1 && check_lit l2 j2 (* check_lit l1 j1 && check_lit j1 l1 && check_lit l2 j2 && check_lit j2 l2 *) (* (* let a := check_lit l1 j1 in *) *) @@ -382,18 +382,18 @@ intros. destruct H0; now contradict H0. check_lit l1 l2 -> Lit.interp rho l1 = Lit.interp rho l2. Proof. unfold check_lit; intros l1 l2; unfold is_true; rewrite !orb_true_iff, !andb_true_iff; intros [[H1|[H1 H2]]|[H1 H2]]. - rewrite eqb_spec in H1; rewrite H1; auto. - rewrite Bool.eqb_true_iff in H1; unfold Lit.interp; rewrite H1, (interp_check_var _ _ H2); auto. - generalize H1; unfold Lit.interp; case (Lit.is_pos l1); case (Lit.is_pos l2); try discriminate; intros _; unfold Var.interp; rewrite (interp_check_distinct_two_args _ t_func ch_atom ch_form wt_t_atom _ _ H2); auto; case (rho (Lit.blit l2)); auto. + rewrite eqb_spec in H1; rewrite H1; auto with smtcoq_core. + rewrite Bool.eqb_true_iff in H1; unfold Lit.interp; rewrite H1, (interp_check_var _ _ H2); auto with smtcoq_core. + generalize H1; unfold Lit.interp; case (Lit.is_pos l1); case (Lit.is_pos l2); try discriminate; intros _; unfold Var.interp; rewrite (interp_check_distinct_two_args _ t_func ch_atom ch_form wt_t_atom _ _ H2); auto with smtcoq_core; case (rho (Lit.blit l2)); auto with smtcoq_core. Qed. (* Lemma interp_check_lit : forall l1 l2, *) (* check_lit l1 l2 -> Lit.interp rho l1 -> Lit.interp rho l2 = true. *) (* Proof. *) (* unfold check_lit; intros l1 l2; unfold is_true; rewrite !orb_true_iff, !andb_true_iff; intros [[H1|[[H1 H2] H3]]|[[H1 H2] H3]]. *) - (* rewrite Int63Properties.eqb_spec in H1; subst l1; auto. *) - (* unfold Lit.interp; rewrite H1, H2; apply interp_check_var; auto. *) - (* unfold Lit.interp; case_eq (Lit.is_pos l1); intro Heq; rewrite Heq in H1; try discriminate; clear Heq H1; case_eq (Lit.is_pos l2); intro Heq; rewrite Heq in H2; try discriminate; clear Heq H2; case_eq (Var.interp rho (Lit.blit l1)); try discriminate; intros H4 _; case_eq (Var.interp rho (Lit.blit l2)); auto; intro H5; rewrite (interp_check_var _ _ H3 H5) in H4; discriminate. *) + (* rewrite Int63.eqb_spec in H1; subst l1; auto with smtcoq_core. *) + (* unfold Lit.interp; rewrite H1, H2; apply interp_check_var; auto with smtcoq_core. *) + (* unfold Lit.interp; case_eq (Lit.is_pos l1); intro Heq; rewrite Heq in H1; try discriminate; clear Heq H1; case_eq (Lit.is_pos l2); intro Heq; rewrite Heq in H2; try discriminate; clear Heq H2; case_eq (Var.interp rho (Lit.blit l1)); try discriminate; intros H4 _; case_eq (Var.interp rho (Lit.blit l2)); auto with smtcoq_core; intro H5; rewrite (interp_check_var _ _ H3 H5) in H4; discriminate. *) (* Qed. *) (* Local Hint Resolve interp_check_lit. *) @@ -402,80 +402,80 @@ intros. destruct H0; now contradict H0. check_form_aux a b -> Form.interp interp_form_hatom interp_form_hatom_bv t_form a = Form.interp interp_form_hatom interp_form_hatom_bv t_form b. Proof. - intros [a| | |i1 l1|a1|a1|a1|l1 l2|l1 l2|l1 l2 l3|a l1] [b| | |j1 m1|a2|a2|a2|j1 j2|j1 j2|j1 j2 j3|b m1]; simpl; try discriminate;auto. + intros [a| | |i1 l1|a1|a1|a1|l1 l2|l1 l2|l1 l2 l3|a l1] [b| | |j1 m1|a2|a2|a2|j1 j2|j1 j2|j1 j2 j3|b m1]; simpl; try discriminate;auto with smtcoq_core. (* Atom *) - unfold is_true; rewrite Int63Properties.eqb_spec; intro; subst a; auto. + unfold is_true; rewrite Int63.eqb_spec; intro; subst a; auto with smtcoq_core. (* Interesting case *) - apply interp_check_distinct; auto. + apply interp_check_distinct; auto with smtcoq_core. (* Double negation *) - unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H1 H2]; subst j1. rewrite (interp_check_lit _ _ H2). auto. + unfold is_true; rewrite andb_true_iff, Int63.eqb_spec; intros [H1 H2]; subst j1. rewrite (interp_check_lit _ _ H2). auto with smtcoq_core. (* Conjunction *) - unfold is_true; rewrite andb_true_iff, eqb_spec, forallbi_spec; intros [H1 H2]; apply afold_left_eq; auto; intros i Hi; apply interp_check_lit; auto. + unfold is_true; rewrite andb_true_iff, eqb_spec, aforallbi_spec; intros [H1 H2]; apply afold_left_eq; rewrite ?length_amap; auto with smtcoq_core; intros i Hi; rewrite 2!get_amap by (rewrite <- ?H1; assumption); apply interp_check_lit; auto with smtcoq_core. (* Disjunction *) - unfold is_true; rewrite andb_true_iff, eqb_spec, forallbi_spec; intros [H1 H2]; apply afold_left_eq; auto; intros i Hi; apply interp_check_lit; auto. + unfold is_true; rewrite andb_true_iff, eqb_spec, aforallbi_spec; intros [H1 H2]; apply afold_left_eq; rewrite ?length_amap; auto with smtcoq_core; intros i Hi; rewrite 2!get_amap by (rewrite <- ?H1; assumption); apply interp_check_lit; auto with smtcoq_core. (* Implication *) - unfold is_true; rewrite andb_true_iff, eqb_spec, forallbi_spec; intros [H1 H2]; apply afold_right_eq; auto; intros i Hi; apply interp_check_lit; auto. + unfold is_true; rewrite andb_true_iff, eqb_spec, aforallbi_spec; intros [H1 H2]; apply afold_right_eq; rewrite ?length_amap; auto with smtcoq_core; intros i Hi; rewrite 2!get_amap by (rewrite <- ?H1; assumption); apply interp_check_lit; auto with smtcoq_core. (* Xor *) - unfold is_true; rewrite andb_true_iff; intros [H1 H2]; rewrite (interp_check_lit _ _ H1), (interp_check_lit _ _ H2); auto. + unfold is_true; rewrite andb_true_iff; intros [H1 H2]; rewrite (interp_check_lit _ _ H1), (interp_check_lit _ _ H2); auto with smtcoq_core. (* Iff *) - unfold is_true; rewrite andb_true_iff; intros [H1 H2]; rewrite (interp_check_lit _ _ H1), (interp_check_lit _ _ H2); auto. + unfold is_true; rewrite andb_true_iff; intros [H1 H2]; rewrite (interp_check_lit _ _ H1), (interp_check_lit _ _ H2); auto with smtcoq_core. (* Ite *) - unfold is_true; rewrite !andb_true_iff; intros [[H1 H2] H3]; rewrite (interp_check_lit _ _ H1), (interp_check_lit _ _ H2), (interp_check_lit _ _ H3); auto. + unfold is_true; rewrite !andb_true_iff; intros [[H1 H2] H3]; rewrite (interp_check_lit _ _ H1), (interp_check_lit _ _ H2), (interp_check_lit _ _ H3); auto with smtcoq_core. Qed. (* Lemma interp_check_lit_equiv : forall l1 l2, *) (* check_lit l1 l2 -> check_lit l2 l1 -> *) (* Lit.interp rho l1 = Lit.interp rho l2. *) (* Proof. *) - (* intros l1 l2 H1 H2; generalize (interp_check_lit _ _ H1) (interp_check_lit _ _ H2); case (Lit.interp rho l1); case (Lit.interp rho l2); auto; symmetry; auto. *) + (* intros l1 l2 H1 H2; generalize (interp_check_lit _ _ H1) (interp_check_lit _ _ H2); case (Lit.interp rho l1); case (Lit.interp rho l2); auto with smtcoq_core; symmetry; auto with smtcoq_core. *) (* Qed. *) (* Lemma interp_check_form_aux : forall a b, *) (* check_form_aux a b -> *) (* Form.interp interp_form_hatom t_form a -> Form.interp interp_form_hatom t_form b. *) (* Proof. *) - (* intros [a| | |i1 l1|a1|a1|a1|l1 l2|l1 l2|l1 l2 l3] [b| | |j1 m1|a2|a2|a2|j1 j2|j1 j2|j1 j2 j3]; simpl; try discriminate;auto. *) + (* intros [a| | |i1 l1|a1|a1|a1|l1 l2|l1 l2|l1 l2 l3] [b| | |j1 m1|a2|a2|a2|j1 j2|j1 j2|j1 j2 j3]; simpl; try discriminate;auto with smtcoq_core. *) (* (* Atom *) *) - (* unfold is_true; rewrite Int63Properties.eqb_spec; intro; subst a; auto. *) + (* unfold is_true; rewrite Int63Properties.eqb_spec; intro; subst a; auto with smtcoq_core. *) (* (* Interesting case *) *) - (* apply interp_check_distinct; auto. *) + (* apply interp_check_distinct; auto with smtcoq_core. *) (* (* Double negation *) *) (* unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H1 H2]; subst j1; apply (fold_ind2 _ _ (fun x y => x = true -> y = true)). *) - (* apply interp_check_lit; auto. *) - (* intros a b; case a; try discriminate; intros H _; rewrite H; auto. *) + (* apply interp_check_lit; auto with smtcoq_core. *) + (* intros a b; case a; try discriminate; intros H _; rewrite H; auto with smtcoq_core. *) (* (* Conjunction *) *) - (* unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H1 H2]; rewrite forallbi_spec in H2; intro H3; assert (H4 := afold_left_andb_true_inv _ _ _ H3); clear H3; apply afold_left_andb_true; rewrite <- H1; intros i Hi; eapply interp_check_lit; eauto. *) + (* unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H1 H2]; rewrite aforallbi_spec in H2; intro H3; assert (H4 := afold_left_andb_true_inv _ _ _ H3); clear H3; apply afold_left_andb_true; rewrite <- H1; intros i Hi; eapply interp_check_lit; eauto with smtcoq_core. *) (* (* Disjunction *) *) - (* unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H1 H2]; rewrite forallbi_spec in H2; intro H3; assert (H4 := afold_left_orb_true_inv _ _ _ H3); clear H3; destruct H4 as [i [H3 H4]]; eapply afold_left_orb_true. *) - (* rewrite <- H1; eauto. *) - (* eapply interp_check_lit; eauto. *) + (* unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H1 H2]; rewrite aforallbi_spec in H2; intro H3; assert (H4 := afold_left_orb_true_inv _ _ _ H3); clear H3; destruct H4 as [i [H3 H4]]; eapply afold_left_orb_true. *) + (* rewrite <- H1; eauto with smtcoq_core. *) + (* eapply interp_check_lit; eauto with smtcoq_core. *) (* (* Implication *) *) - (* unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H1 H2]; rewrite forallbi_spec in H2; intro H3; apply afold_right_implb_true; case_eq (length a1 == 0); intro Heq. *) - (* left; rewrite eqb_spec in Heq; rewrite <- H1; auto. *) + (* unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H1 H2]; rewrite aforallbi_spec in H2; intro H3; apply afold_right_implb_true; case_eq (length a1 == 0); intro Heq. *) + (* left; rewrite eqb_spec in Heq; rewrite <- H1; auto with smtcoq_core. *) (* destruct (afold_right_implb_true_inv _ _ _ H3) as [H4|[[i [H4 H5]]|H4]]. *) (* rewrite H4 in Heq; discriminate. *) - (* right; left; exists i; rewrite <- H1; split; auto; case_eq (Lit.interp rho (a2 .[ i])); auto; intro H6; assert (H7: i < length a1 = true). *) - (* rewrite ltb_spec in *; rewrite eqb_false_spec in Heq; rewrite to_Z_sub_1_diff in H4; auto; omega. *) - (* generalize (H2 _ H7); rewrite H4; intro H8; rewrite (interp_check_lit _ _ H8 H6) in H5; auto. *) - (* right; case_eq (existsbi (fun i l => (i < length a2 - 1) && (negb (Lit.interp rho l))) a2). *) - (* rewrite existsbi_spec; intros [i [_ H5]]; rewrite andb_true_iff in H5; destruct H5 as [H5 H6]; left; exists i; split; auto; generalize H6; case (Lit.interp rho (a2 .[ i])); auto; discriminate. *) - (* rewrite existsbi_false_spec; intro H; right; intros i Hi; assert (Hi' := Hi); rewrite <- H1 in Hi'; generalize (H2 _ Hi') (H _ Hi); rewrite <- H1; case (i < length a1 - 1); simpl. *) - (* intros _; case (Lit.interp rho (a2 .[ i])); auto; discriminate. *) - (* intros H5 _; apply (interp_check_lit _ _ H5); apply H4; auto. *) + (* right; left; exists i; rewrite <- H1; split; auto with smtcoq_core; case_eq (Lit.interp rho (a2 .[ i])); auto with smtcoq_core; intro H6; assert (H7: i < length a1 = true). *) + (* rewrite ltb_spec in *; rewrite eqb_false_spec in Heq; rewrite to_Z_sub_1_diff in H4; auto with smtcoq_core; omega. *) + (* generalize (H2 _ H7); rewrite H4; intro H8; rewrite (interp_check_lit _ _ H8 H6) in H5; auto with smtcoq_core. *) + (* right; case_eq (aexistsbi (fun i l => (i < length a2 - 1) && (negb (Lit.interp rho l))) a2). *) + (* rewrite aexistsbi_spec; intros [i [_ H5]]; rewrite andb_true_iff in H5; destruct H5 as [H5 H6]; left; exists i; split; auto with smtcoq_core; generalize H6; case (Lit.interp rho (a2 .[ i])); auto with smtcoq_core; discriminate. *) + (* rewrite aexistsbi_false_spec; intro H; right; intros i Hi; assert (Hi' := Hi); rewrite <- H1 in Hi'; generalize (H2 _ Hi') (H _ Hi); rewrite <- H1; case (i < length a1 - 1); simpl. *) + (* intros _; case (Lit.interp rho (a2 .[ i])); auto with smtcoq_core; discriminate. *) + (* intros H5 _; apply (interp_check_lit _ _ H5); apply H4; auto with smtcoq_core. *) (* (* Xor *) *) - (* unfold is_true; rewrite !andb_true_iff; intros [[[H1 H2] H3] H4]; rewrite (interp_check_lit_equiv _ _ H1 H2), (interp_check_lit_equiv _ _ H3 H4); auto. *) + (* unfold is_true; rewrite !andb_true_iff; intros [[[H1 H2] H3] H4]; rewrite (interp_check_lit_equiv _ _ H1 H2), (interp_check_lit_equiv _ _ H3 H4); auto with smtcoq_core. *) (* (* Iff *) *) - (* unfold is_true; rewrite !andb_true_iff; intros [[[H1 H2] H3] H4]; rewrite (interp_check_lit_equiv _ _ H1 H2), (interp_check_lit_equiv _ _ H3 H4); auto. *) + (* unfold is_true; rewrite !andb_true_iff; intros [[[H1 H2] H3] H4]; rewrite (interp_check_lit_equiv _ _ H1 H2), (interp_check_lit_equiv _ _ H3 H4); auto with smtcoq_core. *) (* (* Ite *) *) - (* unfold is_true; rewrite !andb_true_iff; intros [[[H1 H2] H3] H4]; rewrite (interp_check_lit_equiv _ _ H1 H2); case (Lit.interp rho j1); apply interp_check_lit; auto. *) + (* unfold is_true; rewrite !andb_true_iff; intros [[[H1 H2] H3] H4]; rewrite (interp_check_lit_equiv _ _ H1 H2); case (Lit.interp rho j1); apply interp_check_lit; auto with smtcoq_core. *) (* Qed. *) End AUX. Definition check_hform h1 h2 := - foldi_down_cont + foldi (fun _ cont h1 h2 => (h1 == h2) || check_form_aux cont (get_form h1) (get_form h2)) - (PArray.length t_form) 0 (fun h1 h2 => false) h1 h2. + 0 (PArray.length t_form) (fun h1 h2 => false) h1 h2. Definition check_form := check_form_aux check_hform. @@ -505,50 +505,46 @@ intros. destruct H0; now contradict H0. Let wf_rho : Valuation.wf rho. - Proof. destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form); auto. Qed. + Proof. destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form); auto with smtcoq_core. Qed. Let default_t_form : default t_form = Ftrue. - Proof. destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form) as [[H _] _]; auto. Qed. + Proof. destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form) as [[H _] _]; auto with smtcoq_core. Qed. Let wf_t_form : wf t_form. - Proof. destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form) as [[_ H] _]; auto. Qed. - - Local Hint Immediate wf_rho default_t_form wf_t_form. + Proof. destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form) as [[_ H] _]; auto with smtcoq_core. Qed. Lemma interp_check_hform : forall h1 h2, check_hform h1 h2 -> Var.interp rho h1 = Var.interp rho h2. Proof. - unfold check_hform; apply foldi_down_cont_ind; try discriminate. intros i cont _ _ Hrec h1 h2. unfold is_true; rewrite orb_true_iff; intros [H|H]. - rewrite Int63Properties.eqb_spec in H; rewrite H; auto. - unfold Var.interp; rewrite !wf_interp_form; auto; eapply interp_check_form_aux; eauto. + unfold check_hform; apply foldi_ind; try discriminate. apply leb_0. intros i cont _ _ Hrec h1 h2. unfold is_true; rewrite orb_true_iff; intros [H|H]. + rewrite Int63.eqb_spec in H; rewrite H; auto with smtcoq_core. + unfold Var.interp; rewrite !wf_interp_form; auto with smtcoq_core; eapply interp_check_form_aux; eauto with smtcoq_core. Qed. - Local Hint Resolve interp_check_hform. - Lemma interp_check_form : forall a b, check_form a b -> Form.interp interp_form_hatom interp_form_hatom_bv t_form a = Form.interp interp_form_hatom interp_form_hatom_bv t_form b. - Proof. apply interp_check_form_aux, interp_check_hform; auto. Qed. + Proof. apply interp_check_form_aux, interp_check_hform; auto with smtcoq_core. Qed. Lemma interp_check_lit' : forall l res, check_lit' l res -> Lit.interp rho l = Lit.interp rho res. - Proof. apply interp_check_lit, interp_check_hform; auto. Qed. + Proof. apply interp_check_lit, interp_check_hform; auto with smtcoq_core. Qed. Lemma valid_check_distinct_elim : forall input, C.valid rho input -> forall res, C.valid rho (check_distinct_elim input res). Proof. - induction input as [ |l c IHc]; auto; simpl; unfold C.valid; simpl; rewrite orb_true_iff; intros [H|H] res. + induction input as [ |l c IHc]; auto with smtcoq_core; simpl; unfold C.valid; simpl; rewrite orb_true_iff; intros [H|H] res. case_eq (check_lit' l res); intro Heq; simpl. - rewrite <- (interp_check_lit' _ _ Heq), H; auto. - rewrite H; auto. + rewrite <- (interp_check_lit' _ _ Heq), H; auto with smtcoq_core. + rewrite H; auto with smtcoq_core. case (check_lit' l res). - simpl; rewrite H, orb_true_r; auto. - simpl; rewrite (IHc H), orb_true_r; auto. + simpl; rewrite H, orb_true_r; auto with smtcoq_core. + simpl; rewrite (IHc H), orb_true_r; auto with smtcoq_core. Qed. End Valid. diff --git a/src/spl/Syntactic.v b/src/spl/Syntactic.v index e50d810..eb512ee 100644 --- a/src/spl/Syntactic.v +++ b/src/spl/Syntactic.v @@ -184,15 +184,15 @@ Section CheckAtom. (* N-ary operators *) - intros [op2|op2 i2|op2 i2 j2|op2 i2 j2|op2 li2|f2 args2]; simpl; try discriminate; destruct op1 as [t1]; destruct op2 as [t2]; unfold is_true; rewrite andb_true_iff; change (Typ.eqb t1 t2 = true) with (is_true (Typ.eqb t1 t2)); rewrite Typ.eqb_spec; intros [H1 H2]; subst t2; rewrite (list_beq_compute_interp _ _ _ H2); auto. (* Application *) - - intros [op2|op2 i2|op2 i2 j2|op2 i2 j2|op2 li2|f2 args2]; simpl; try discriminate; unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H2 H1]; subst f2; rewrite (list_beq_correct _ _ H1); auto. + - intros [op2|op2 i2|op2 i2 j2|op2 i2 j2|op2 li2|f2 args2]; simpl; try discriminate; unfold is_true; rewrite andb_true_iff, Int63.eqb_spec; intros [H2 H1]; subst f2; rewrite (list_beq_correct _ _ H1); auto. Qed. End AUX. Definition check_hatom h1 h2 := - foldi_down_cont + foldi (fun _ cont h1 h2 => (h1 == h2) || check_atom_aux cont (t_atom.[h1]) (t_atom.[h2])) - (PArray.length t_atom) 0 (fun h1 h2 => false) h1 h2. + 0 (PArray.length t_atom) (fun h1 h2 => false) h1 h2. Definition check_atom := check_atom_aux check_hatom. @@ -230,10 +230,11 @@ Section CheckAtom. interp_hatom t_i t_func t_atom h1 = interp_hatom t_i t_func t_atom h2. Proof. unfold check_hatom;intros Hwf Hdef. - apply foldi_down_cont_ind;try discriminate. + apply foldi_ind;try discriminate. + apply leb_0. intros i cont _ _ Hrec h1 h2. unfold is_true; rewrite orb_true_iff; intros [H|H]. - rewrite Int63Properties.eqb_spec in H; rewrite H; reflexivity. + rewrite Int63.eqb_spec in H; rewrite H; reflexivity. unfold interp_hatom;rewrite !t_interp_wf;trivial. apply check_atom_aux_correct with cont;trivial. Qed. @@ -268,7 +269,7 @@ Section CheckAtom. | Val _ _, Val _ _ => False end. Proof. - unfold wt; unfold is_true at 1; rewrite forallbi_spec; intros Hwt Hwf Hdef h1 h2; unfold check_neg_hatom; case_eq (get_atom h1); try discriminate; intros b1 t11 t12 H1; case_eq (get_atom h2); try discriminate; intros b2 t21 t22 H2; assert (H7: h1 < length t_atom) by (apply PArray.get_not_default_lt; rewrite H1, Hdef; discriminate); generalize (Hwt _ H7); rewrite H1; simpl; generalize H1; case b1; try discriminate; clear H1 b1; simpl; intro H1; case (get_type' t_i (t_interp t_i t_func t_atom) h1); try discriminate; simpl; rewrite andb_true_iff; intros [H30 H31]; change (is_true (Typ.eqb (get_type' t_i (t_interp t_i t_func t_atom) t11) Typ.TZ)) in H30; change (is_true (Typ.eqb (get_type' t_i (t_interp t_i t_func t_atom) t12) Typ.TZ)) in H31; rewrite Typ.eqb_spec in H30, H31; generalize (check_aux_interp_hatom _ t_func _ Hwf t11), (check_aux_interp_hatom _ t_func _ Hwf t12); rewrite H30, H31; intros [v1 Hv1] [v2 Hv2]; generalize H2; case b2; try discriminate; clear H2 b2; intro H2; unfold is_true; rewrite andb_true_iff; intros [H3 H4]; generalize (check_hatom_correct Hwf Hdef _ _ H3), (check_hatom_correct Hwf Hdef _ _ H4); unfold interp_hatom; intros H5 H6; rewrite t_interp_wf; auto; rewrite H1; simpl; rewrite Hv1, Hv2; simpl; rewrite t_interp_wf; auto; rewrite H2; simpl; rewrite <- H5; rewrite <- H6, Hv1, Hv2; simpl. + unfold wt; unfold is_true at 1; rewrite aforallbi_spec; intros Hwt Hwf Hdef h1 h2; unfold check_neg_hatom; case_eq (get_atom h1); try discriminate; intros b1 t11 t12 H1; case_eq (get_atom h2); try discriminate; intros b2 t21 t22 H2; assert (H7: h1 < length t_atom) by (apply PArray.get_not_default_lt; rewrite H1, Hdef; discriminate); generalize (Hwt _ H7); rewrite H1; simpl; generalize H1; case b1; try discriminate; clear H1 b1; simpl; intro H1; case (get_type' t_i (t_interp t_i t_func t_atom) h1); try discriminate; simpl; rewrite andb_true_iff; intros [H30 H31]; change (is_true (Typ.eqb (get_type' t_i (t_interp t_i t_func t_atom) t11) Typ.TZ)) in H30; change (is_true (Typ.eqb (get_type' t_i (t_interp t_i t_func t_atom) t12) Typ.TZ)) in H31; rewrite Typ.eqb_spec in H30, H31; generalize (check_aux_interp_hatom _ t_func _ Hwf t11), (check_aux_interp_hatom _ t_func _ Hwf t12); rewrite H30, H31; intros [v1 Hv1] [v2 Hv2]; generalize H2; case b2; try discriminate; clear H2 b2; intro H2; unfold is_true; rewrite andb_true_iff; intros [H3 H4]; generalize (check_hatom_correct Hwf Hdef _ _ H3), (check_hatom_correct Hwf Hdef _ _ H4); unfold interp_hatom; intros H5 H6; rewrite t_interp_wf; auto; rewrite H1; simpl; rewrite Hv1, Hv2; simpl; rewrite t_interp_wf; auto; rewrite H2; simpl; rewrite <- H5; rewrite <- H6, Hv1, Hv2; simpl. rewrite Z.ltb_antisym; auto. rewrite Z.geb_leb, Z.ltb_antisym; auto. rewrite Z.leb_antisym; auto. @@ -332,20 +333,20 @@ Section FLATTEN. (frec : list _lit -> _lit -> list _lit) (largs:list _lit) (l:_lit) : list _lit := match get_op l with - | Some a => PArray.fold_left frec largs a + | Some a => foldi (fun i x => frec x (a.[i])) 0 (length a) largs | None => l::largs end. (* Register flatten_op_body as PrimInline. *) Definition flatten_op_lit (get_op:_lit -> option (array _lit)) max := - foldi_cont (fun _ => flatten_op_body get_op) 0 max (fun largs l => l::largs). + foldi (fun _ => flatten_op_body get_op) 0 max (fun largs l => l::largs). Definition flatten_and t := - PArray.fold_left (flatten_op_lit get_and (PArray.length t_form)) nil t. + foldi (fun i x => flatten_op_lit get_and (PArray.length t_form) x (t.[i])) 0 (length t) nil. Definition flatten_or t := - PArray.fold_left (flatten_op_lit get_or (PArray.length t_form)) nil t. + foldi (fun i x => flatten_op_lit get_or (PArray.length t_form) x (t.[i])) 0 (length t) nil. Variable check_atom check_neg_atom : atom -> atom -> bool. @@ -371,7 +372,7 @@ Section FLATTEN. frec l1 lf1 && frec l2 lf2 | Fimp args1, Fimp args2 => if PArray.length args1 == PArray.length args2 then - PArray.forallbi (fun i l => frec l (args2.[i])) args1 + aforallbi (fun i l => frec l (args2.[i])) args1 else false | Fiff l1 l2, Fiff lf1 lf2 => frec l1 lf1 && frec l2 lf2 @@ -387,7 +388,7 @@ Section FLATTEN. (* Register check_flatten_body as PrimInline. *) Definition check_flatten_aux l lf := - foldi_cont (fun _ => check_flatten_body) 0 (PArray.length t_form) (fun _ _ => false) l lf. + foldi (fun _ => check_flatten_body) 0 (PArray.length t_form) (fun _ _ => false) l lf. Definition check_flatten s cid lf := match S.get s cid with @@ -412,8 +413,11 @@ Section FLATTEN. Lemma interp_Fnot2 : forall i l, interp interp_atom interp_bvatom t_form (Fnot2 i l) = interp_lit l. Proof. - intros i l;simpl;apply fold_ind;trivial. - intros a;rewrite negb_involutive;trivial. + intros i l;simpl. + apply foldi_ind. + apply leb_0. + reflexivity. + intros; rewrite negb_involutive; assumption. Qed. Lemma remove_not_correct : @@ -452,23 +456,21 @@ Section FLATTEN. Lemma flatten_and_correct : forall args, List.fold_right (fun l res => andb res (interp_lit l)) true (flatten_and args) = - afold_left _ _ true andb interp_lit args. + afold_left _ true andb (amap interp_lit args). Proof. intros;rewrite afold_left_spec;auto;unfold flatten_and. - set (t:= true);unfold t at 2; - change true with - (List.fold_right (fun (l : int) (res : bool) => res && interp_lit l) true nil). - unfold t;clear t. - rewrite !fold_left_to_list. + change true with (List.fold_right (fun (l : int) (res : bool) => res && interp_lit l) true nil) at 2. + rewrite !foldi_to_list, to_list_amap. generalize (@nil int);induction (to_list args);simpl;trivial. intros l0;rewrite IHl. clear IHl;f_equal; unfold flatten_op_lit. - clear l;revert a l0;apply foldi_cont_ind;simpl;trivial. - intros i cont _ Hle Hrec a l;unfold flatten_op_body. + clear l;revert a l0;apply foldi_ind;simpl;trivial. + apply leb_0. + intros i cont _ Hlt Hrec a l;unfold flatten_op_body. case_eq (get_and a);intros;trivial. rewrite get_and_correct with (1:= H);simpl. - rewrite afold_left_spec; auto; rewrite !fold_left_to_list. - rewrite <- !fold_left_rev_right. + rewrite afold_left_spec; auto; rewrite !foldi_to_list. + rewrite <- !fold_left_rev_right, to_list_amap, <- map_rev. clear H a;revert l;induction (List.rev (to_list a0));simpl. intros l;rewrite andb_true_r;trivial. intros;rewrite Hrec, IHl, andb_assoc;trivial. @@ -476,23 +478,21 @@ Section FLATTEN. Lemma flatten_or_correct : forall args, List.fold_right (fun l res => orb res (interp_lit l)) false (flatten_or args) = - afold_left _ _ false orb interp_lit args. + afold_left _ false orb (amap interp_lit args). Proof. intros;rewrite afold_left_spec;auto;unfold flatten_or. - set (t:= false);unfold t at 2; - change false with - (List.fold_right (fun (l : int) (res : bool) => res || interp_lit l) false nil). - unfold t;clear t. - rewrite !fold_left_to_list. + change false with (List.fold_right (fun (l : int) (res : bool) => res || interp_lit l) false nil) at 2. + rewrite !foldi_to_list, to_list_amap. generalize (@nil int);induction (to_list args);simpl;trivial. intros l0;rewrite IHl. clear IHl;f_equal; unfold flatten_op_lit. - clear l;revert a l0;apply foldi_cont_ind;simpl;trivial. - intros i cont _ Hle Hrec a l;unfold flatten_op_body. + clear l;revert a l0;apply foldi_ind;simpl;trivial. + apply leb_0. + intros i cont _ Hlt Hrec a l;unfold flatten_op_body. case_eq (get_or a);intros;trivial. rewrite get_or_correct with (1:= H);simpl. - rewrite afold_left_spec; auto; rewrite !fold_left_to_list. - rewrite <- !fold_left_rev_right. + rewrite afold_left_spec; auto; rewrite !foldi_to_list. + rewrite <- !fold_left_rev_right, to_list_amap, <- map_rev. clear H a;revert l;induction (List.rev (to_list a0));simpl. intros l;rewrite orb_false_r;trivial. intros;rewrite Hrec, IHl, orb_assoc;trivial. @@ -503,7 +503,8 @@ Section FLATTEN. interp_lit l = interp_lit lf. Proof. unfold check_flatten_aux. - apply foldi_cont_ind. + apply foldi_ind. + apply leb_0. discriminate. intros i cont _ Hle Hrec l lf;unfold check_flatten_body. rewrite <- (remove_not_correct l), <- (remove_not_correct lf). @@ -513,7 +514,7 @@ Section FLATTEN. unfold Lit.interp. assert (Lit.is_pos l = Lit.is_pos lf). unfold Lit.is_pos. - rewrite <- eqb_spec, land_comm in e. + rewrite <- eqb_spec, landC in e. change (is_true (is_even (l lxor lf))) in e. rewrite is_even_xor in e. destruct (is_even l);destruct (is_even lf);trivial;discriminate. @@ -542,8 +543,8 @@ Section FLATTEN. rewrite (Hrec _ _ H1), (IHl0 _ H2);trivial. (* implb *) revert H;destruct (reflect_eqb (length a) (length a0));[intros|discriminate]. - apply afold_right_eq;trivial. - rewrite forallbi_spec in H;auto. + apply afold_right_eq;rewrite !length_amap;trivial. + intros;rewrite !get_amap by congruence;rewrite aforallbi_spec in H;auto. (* xorb *) unfold is_true in H;rewrite andb_true_iff in H;destruct H as [H H0]. rewrite (Hrec _ _ H), (Hrec _ _ H0);trivial. @@ -556,7 +557,7 @@ Section FLATTEN. (** opposite sign *) assert (Lit.is_pos l = negb (Lit.is_pos lf)). unfold Lit.is_pos. - rewrite <- eqb_spec, land_comm in n0. + rewrite <- eqb_spec, landC in n0. change (~is_true (is_even (l lxor lf))) in n0. rewrite is_even_xor in n0. destruct (is_even l);destruct (is_even lf);trivial;elim n0;reflexivity. diff --git a/src/versions/standard/structures.ml b/src/trace/coqInterface.ml index 137e543..9b2c72c 100644 --- a/src/versions/standard/structures.ml +++ b/src/trace/coqInterface.ml @@ -41,9 +41,10 @@ let destRel = Constr.destRel let lift = Vars.lift let mkApp = Constr.mkApp let decompose_app = Constr.decompose_app -let mkLambda = Constr.mkLambda -let mkProd = Constr.mkProd -let mkLetIn = Constr.mkLetIn +let mkLambda (n, t, c) = Constr.mkLambda (Context.make_annot n Sorts.Relevant, t, c) +let mkProd (n, t, c) = Constr.mkProd (Context.make_annot n Sorts.Relevant, t, c) +let mkLetIn (n, c1, t, c2) = Constr.mkLetIn (Context.make_annot n Sorts.Relevant, c1, t, c2) +let mkArrow a b = Term.mkArrow a Sorts.Relevant b let pr_constr_env env = Printer.pr_constr_env env Evd.empty let pr_constr = pr_constr_env Environ.empty_env @@ -58,7 +59,7 @@ let mkUConst : Constr.t -> Safe_typing.private_constants Entries.definition_entr const_entry_secctx = None; const_entry_feedback = None; const_entry_type = Some (EConstr.Unsafe.to_constr ty); (* Cannot contain evars since it comes from a Constr.t *) - const_entry_universes = Evd.const_univ_entry ~poly:false evd; + const_entry_universes = Evd.univ_entry ~poly:false evd; const_entry_opaque = false; const_entry_inline_code = false } @@ -71,20 +72,20 @@ let mkTConst c noc ty = const_entry_secctx = None; const_entry_feedback = None; const_entry_type = Some ty; - const_entry_universes = Evd.const_univ_entry ~poly:false evd; + const_entry_universes = Evd.univ_entry ~poly:false evd; const_entry_opaque = false; const_entry_inline_code = false } (* TODO : Set -> Type *) let declare_new_type t = - let _ = ComAssumption.declare_assumption false (Decl_kinds.Discharge, false, Decl_kinds.Definitional) (Constr.mkSet, Entries.Monomorphic_const_entry Univ.ContextSet.empty) UnivNames.empty_binders [] false Declaremods.NoInline (CAst.make t) in + let _ = ComAssumption.declare_assumption ~pstate:None false (Decl_kinds.Discharge, false, Decl_kinds.Definitional) (Constr.mkSet, Entries.Monomorphic_entry Univ.ContextSet.empty) UnivNames.empty_binders [] false Declaremods.NoInline (CAst.make t) in Constr.mkVar t let declare_new_variable v constr_t = let env = Global.env () in let evd = Evd.from_env env in let evd, _ = Typing.type_of env evd (EConstr.of_constr constr_t) in - let _ = ComAssumption.declare_assumption false (Decl_kinds.Discharge, false, Decl_kinds.Definitional) (constr_t, Evd.const_univ_entry ~poly:false evd) UnivNames.empty_binders [] false Declaremods.NoInline (CAst.make v) in + let _ = ComAssumption.declare_assumption ~pstate:None false (Decl_kinds.Discharge, false, Decl_kinds.Definitional) (constr_t, Evd.univ_entry ~poly:false evd) UnivNames.empty_binders [] false Declaremods.NoInline (CAst.make v) in Constr.mkVar v let declare_constant n c = @@ -102,52 +103,13 @@ type econstr = EConstr.t let econstr_of_constr = EConstr.of_constr -(* Modules *) -let gen_constant_in_modules s m n = UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules s m n -let gen_constant modules constant = lazy (gen_constant_in_modules "SMT" modules constant) - - (* Int63 *) -let int63_modules = [["SMTCoq";"versions";"standard";"Int63";"Int63Native"]] - -(* 31-bits integers are "called" 63 bits (this is sound) *) -let int31_module = [["Coq";"Numbers";"Cyclic";"Int31";"Int31"]] -let cD0 = gen_constant int31_module "D0" -let cD1 = gen_constant int31_module "D1" -let cI31 = gen_constant int31_module "I31" - -let mkInt : int -> constr = fun i -> - let a = Array.make 31 (Lazy.force cD0) in - let j = ref i in - let k = ref 30 in - while !j <> 0 do - if !j land 1 = 1 then a.(!k) <- Lazy.force cD1; - j := !j lsr 1; - decr k - done; - mkApp (Lazy.force cI31, a) - -let cint = gen_constant int31_module "int31" +let mkInt : int -> Constr.constr = + fun i -> Constr.mkInt (Uint63.of_int i) (* PArray *) -let parray_modules = [["SMTCoq";"versions";"standard";"Array";"PArray"]] - -let cmake = gen_constant parray_modules "make" -let cset = gen_constant parray_modules "set" - let max_array_size : int = 4194302 -let mkArray : Constr.types * Constr.t array -> Constr.t = - fun (ty, a) -> - let l = (Array.length a) - 1 in - snd (Array.fold_left (fun (i,acc) c -> - let acc' = - if i = l then - acc - else - mkApp (Lazy.force cset, [|ty; acc; mkInt i; c|]) in - (i+1,acc') - ) (0, mkApp (Lazy.force cmake, [|ty; mkInt l; a.(l)|])) a) (* Traces *) @@ -166,17 +128,11 @@ let mkTrace step_to_coq next _ clist cnil ccons cpair size step def_step r = (* Micromega *) module Micromega_plugin_Micromega = Micromega_plugin.Micromega -module Micromega_plugin_Mutils = Mutils_full module Micromega_plugin_Certificate = Micromega_plugin.Certificate -module Micromega_plugin_Coq_micromega = Coq_micromega_full - -let micromega_coq_proofTerm = - (* Cannot contain evars *) - lazy (EConstr.Unsafe.to_constr (Lazy.force (Micromega_plugin_Coq_micromega.M.coq_proofTerm))) let micromega_dump_proof_term p = (* Cannot contain evars *) - EConstr.Unsafe.to_constr (Micromega_plugin_Coq_micromega.dump_proof_term p) + EConstr.Unsafe.to_constr (Micromega_plugin.Coq_micromega.dump_proof_term p) (* Tactics *) @@ -188,7 +144,7 @@ let assert_before n c = Tactics.assert_before n (EConstr.of_constr c) let vm_cast_no_check c = Tactics.vm_cast_no_check (EConstr.of_constr c) let mk_tactic tac = - Proofview.Goal.nf_enter (fun gl -> + Proofview.Goal.enter (fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let t = Proofview.Goal.concl gl in @@ -222,7 +178,8 @@ let constrextern_extern_constr c = Constrextern.extern_constr false env (Evd.from_env env) (EConstr.of_constr c) let get_rel_dec_name = function - | Context.Rel.Declaration.LocalAssum (n, _) | Context.Rel.Declaration.LocalDef (n, _, _) -> n + | Context.Rel.Declaration.LocalAssum (n, _) | Context.Rel.Declaration.LocalDef (n, _, _) -> + Context.binder_name n let retyping_get_type_of env sigma c = (* Cannot contain evars since it comes from a Constr.t *) diff --git a/src/versions/standard/structures.mli b/src/trace/coqInterface.mli index 9fa4673..0536ef1 100644 --- a/src/versions/standard/structures.mli +++ b/src/trace/coqInterface.mli @@ -38,6 +38,7 @@ val decompose_app : constr -> constr * constr list val mkLambda : name * types * constr -> constr val mkProd : name * types * types -> types val mkLetIn : name * constr * types * constr -> constr +val mkArrow : types -> types -> constr val pr_constr_env : Environ.env -> constr -> Pp.t val pr_constr : constr -> Pp.t @@ -58,20 +59,12 @@ type econstr = EConstr.t val econstr_of_constr : constr -> econstr -(* Modules *) -val gen_constant : string list list -> string -> constr lazy_t - - (* Int63 *) -val int63_modules : string list list val mkInt : int -> constr -val cint : constr lazy_t (* PArray *) -val parray_modules : string list list val max_array_size : int -val mkArray : types * constr array -> constr (* Traces *) @@ -88,11 +81,7 @@ val mkTrace : (* Micromega *) module Micromega_plugin_Micromega = Micromega_plugin.Micromega -module Micromega_plugin_Mutils = Mutils_full module Micromega_plugin_Certificate = Micromega_plugin.Certificate -module Micromega_plugin_Coq_micromega = Coq_micromega_full - -val micromega_coq_proofTerm : constr lazy_t val micromega_dump_proof_term : Micromega_plugin_Micromega.zArithProof -> constr diff --git a/src/trace/coqTerms.ml b/src/trace/coqTerms.ml index dcacd4b..87a21b8 100644 --- a/src/trace/coqTerms.ml +++ b/src/trace/coqTerms.ml @@ -10,280 +10,374 @@ (**************************************************************************) -open Coqlib open SmtMisc -let gen_constant = Structures.gen_constant +type coqTerm = CoqInterface.constr lazy_t + +let gc prefix constant = + lazy (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref (prefix ^ "." ^ constant))) (* Int63 *) -let cint = Structures.cint -let ceq63 = gen_constant Structures.int63_modules "eqb" +let int63_prefix = "num.int63" +let int63_gc = gc int63_prefix +let cint = int63_gc "type" +let ceq63 = int63_gc "eqb" (* PArray *) -let carray = gen_constant Structures.parray_modules "array" +let array_prefix = "array.array" +let array_gc = gc array_prefix +let carray = array_gc "type" +let cmake = array_gc "make" +let cset = array_gc "set" (* is_true *) -let cis_true = gen_constant init_modules "is_true" +let cis_true = gc "core.is_true" "is_true" (* nat *) -let cnat = gen_constant init_modules "nat" -let cO = gen_constant init_modules "O" -let cS = gen_constant init_modules "S" +let nat_prefix = "num.nat" +let nat_gc = gc nat_prefix +let cnat = nat_gc "type" +let cO = nat_gc "O" +let cS = nat_gc "S" (* Positive *) -let positive_modules = [["Coq";"Numbers";"BinNums"]; - ["Coq";"PArith";"BinPosDef";"Pos"]] - -let cpositive = gen_constant positive_modules "positive" -let cxI = gen_constant positive_modules "xI" -let cxO = gen_constant positive_modules "xO" -let cxH = gen_constant positive_modules "xH" -let ceqbP = gen_constant positive_modules "eqb" +let positive_prefix = "num.pos" +let positive_gc = gc positive_prefix +let cpositive = positive_gc "type" +let cxI = positive_gc "xI" +let cxO = positive_gc "xO" +let cxH = positive_gc "xH" +let ceqbP = positive_gc "eqb" (* N *) -let n_modules = [["Coq";"NArith";"BinNat";"N"]] - -let cN = gen_constant positive_modules "N" -let cN0 = gen_constant positive_modules "N0" -let cNpos = gen_constant positive_modules "Npos" - -let cof_nat = gen_constant n_modules "of_nat" - +let n_prefix = "num.N" +let n_gc = gc n_prefix +let cN = n_gc "type" +let cN0 = n_gc "N0" +let cNpos = n_gc "Npos" +let cof_nat = n_gc "of_nat" (* Z *) -let z_modules = [["Coq";"Numbers";"BinNums"]; - ["Coq";"ZArith";"BinInt"]; - ["Coq";"ZArith";"BinInt";"Z"]] - -let cZ = gen_constant z_modules "Z" -let cZ0 = gen_constant z_modules "Z0" -let cZpos = gen_constant z_modules "Zpos" -let cZneg = gen_constant z_modules "Zneg" -let copp = gen_constant z_modules "opp" -let cadd = gen_constant z_modules "add" -let csub = gen_constant z_modules "sub" -let cmul = gen_constant z_modules "mul" -let cltb = gen_constant z_modules "ltb" -let cleb = gen_constant z_modules "leb" -let cgeb = gen_constant z_modules "geb" -let cgtb = gen_constant z_modules "gtb" -let ceqbZ = gen_constant z_modules "eqb" -(* let cZeqbsym = gen_constant z_modules "eqb_sym" *) +let z_prefix = "num.Z" +let z_gc = gc z_prefix +let cZ = z_gc "type" +let cZ0 = z_gc "Z0" +let cZpos = z_gc "Zpos" +let cZneg = z_gc "Zneg" +let copp = z_gc "opp" +let cadd = z_gc "add" +let csub = z_gc "sub" +let cmul = z_gc "mul" +let cltb = z_gc "ltb" +let cleb = z_gc "leb" +let cgeb = z_gc "geb" +let cgtb = z_gc "gtb" +let ceqbZ = z_gc "eqb" (* Booleans *) -let bool_modules = [["Coq";"Bool";"Bool"]] - -let cbool = gen_constant init_modules "bool" -let ctrue = gen_constant init_modules "true" -let cfalse = gen_constant init_modules "false" -let candb = gen_constant init_modules "andb" -let corb = gen_constant init_modules "orb" -let cxorb = gen_constant init_modules "xorb" -let cnegb = gen_constant init_modules "negb" -let cimplb = gen_constant init_modules "implb" -let ceqb = gen_constant bool_modules "eqb" -let cifb = gen_constant bool_modules "ifb" -let ciff = gen_constant init_modules "iff" -let creflect = gen_constant bool_modules "reflect" +let bool_prefix = "core.bool" +let bool_gc = gc bool_prefix +let cbool = bool_gc "type" +let ctrue = bool_gc "true" +let cfalse = bool_gc "false" +let candb = bool_gc "andb" +let corb = bool_gc "orb" +let cxorb = bool_gc "xorb" +let cnegb = bool_gc "negb" +let cimplb = bool_gc "implb" +let ceqb = bool_gc "eqb" +let cifb = bool_gc "ifb" +let creflect = bool_gc "reflect" (* Lists *) -let clist = gen_constant init_modules "list" -let cnil = gen_constant init_modules "nil" -let ccons = gen_constant init_modules "cons" -let clength = gen_constant init_modules "length" +let list_prefix = "core.list" +let list_gc = gc list_prefix +let clist = list_gc "type" +let cnil = list_gc "nil" +let ccons = list_gc "cons" +let clength = list_gc "length" (* Option *) -let coption = gen_constant init_modules "option" -let cSome = gen_constant init_modules "Some" -let cNone = gen_constant init_modules "None" +let option_prefix = "core.option" +let option_gc = gc option_prefix +let coption = option_gc "type" +let cSome = option_gc "Some" +let cNone = option_gc "None" (* Pairs *) -let cpair = gen_constant init_modules "pair" -let cprod = gen_constant init_modules "prod" +let pair_prefix = "core.prod" +let pair_gc = gc pair_prefix +let cpair = pair_gc "intro" +let cprod = pair_gc "type" (* Dependent pairs *) -let csigT = gen_constant init_modules "sigT" -(* let cprojT1 = gen_constant init_modules "projT1" *) -(* let cprojT2 = gen_constant init_modules "projT2" *) -(* let cprojT3 = gen_constant init_modules "projT3" *) - -(* let csigT2 = gen_constant init_modules "sigT2" *) -(* let csigT_of_sigT2 = gen_constant init_modules "sigT_of_sigT2" *) +let sigT_prefix = "core.sigT" +let sigT_gc = gc sigT_prefix +let csigT = sigT_gc "type" (* Logical Operators *) -let cnot = gen_constant init_modules "not" -let ceq = gen_constant init_modules "eq" -let crefl_equal = gen_constant init_modules "eq_refl" -let cconj = gen_constant init_modules "conj" -let cand = gen_constant init_modules "and" +let cnot = gc "core.not" "type" +let cconj = gc "core.and" "conj" +let cand = gc "core.and" "type" +let ciff = gc "core.iff" "type" + +(* Equality *) +let eq_prefix = "core.eq" +let eq_gc = gc eq_prefix +let ceq = eq_gc "type" +let crefl_equal = eq_gc "refl" + +(* Micromega *) +let micromega_prefix = "micromega.ZMicromega" +let micromega_gc = gc micromega_prefix +let micromega_coq_proofTerm = micromega_gc "ZArithProof" (* Bit vectors *) -let bv_modules = [["SMTCoq";"bva";"BVList";"BITVECTOR_LIST"]] -let cbitvector = gen_constant bv_modules "bitvector" -let cof_bits = gen_constant bv_modules "of_bits" -(* let c_of_bits = gen_constant bv_modules "_of_bits" *) -let cbitOf = gen_constant bv_modules "bitOf" -let cbv_eq = gen_constant bv_modules "bv_eq" -let cbv_not = gen_constant bv_modules "bv_not" -let cbv_neg = gen_constant bv_modules "bv_neg" -let cbv_and = gen_constant bv_modules "bv_and" -let cbv_or = gen_constant bv_modules "bv_or" -let cbv_xor = gen_constant bv_modules "bv_xor" -let cbv_add = gen_constant bv_modules "bv_add" -let cbv_mult = gen_constant bv_modules "bv_mult" -let cbv_ult = gen_constant bv_modules "bv_ult" -let cbv_slt = gen_constant bv_modules "bv_slt" -let cbv_concat = gen_constant bv_modules "bv_concat" -let cbv_extr = gen_constant bv_modules "bv_extr" -let cbv_zextn = gen_constant bv_modules "bv_zextn" -let cbv_sextn = gen_constant bv_modules "bv_sextn" -let cbv_shl = gen_constant bv_modules "bv_shl" -let cbv_shr = gen_constant bv_modules "bv_shr" - +let bv_prefix = "SMTCoq.bva.BVList.BITVECTOR_LIST" +let bv_gc = gc bv_prefix +let cbitvector = bv_gc "bitvector" +let cof_bits = bv_gc "of_bits" +let cbitOf = bv_gc "bitOf" +let cbv_eq = bv_gc "bv_eq" +let cbv_not = bv_gc "bv_not" +let cbv_neg = bv_gc "bv_neg" +let cbv_and = bv_gc "bv_and" +let cbv_or = bv_gc "bv_or" +let cbv_xor = bv_gc "bv_xor" +let cbv_add = bv_gc "bv_add" +let cbv_mult = bv_gc "bv_mult" +let cbv_ult = bv_gc "bv_ult" +let cbv_slt = bv_gc "bv_slt" +let cbv_concat = bv_gc "bv_concat" +let cbv_extr = bv_gc "bv_extr" +let cbv_zextn = bv_gc "bv_zextn" +let cbv_sextn = bv_gc "bv_sextn" +let cbv_shl = bv_gc "bv_shl" +let cbv_shr = bv_gc "bv_shr" (* Arrays *) -let array_modules = [["SMTCoq";"array";"FArray"]] -let cfarray = gen_constant array_modules "FArray.farray" -let cselect = gen_constant array_modules "select" -let cstore = gen_constant array_modules "store" -let cdiff = gen_constant array_modules "diff" -let cequalarray = gen_constant array_modules "FArray.equal" - -(* OrderedType *) -(* let cOrderedTypeCompare = - * gen_constant [["Coq";"Structures";"OrderedType"]] "Compare" *) - -(* SMT_terms *) -let smt_modules = [ ["SMTCoq";"Misc"]; - ["SMTCoq";"State"]; - ["SMTCoq";"SMT_terms"]; - ["SMTCoq";"SMT_terms";"Typ"]; - ["SMTCoq";"SMT_terms";"Form"]; - ["SMTCoq";"SMT_terms";"Atom"] - ] - -let cState_C_t = gen_constant [["SMTCoq";"State";"C"]] "t" -let cState_S_t = gen_constant [["SMTCoq";"State";"S"]] "t" - -let cdistinct = gen_constant smt_modules "distinct" - -let ctype = gen_constant smt_modules "type" -let cTZ = gen_constant smt_modules "TZ" -let cTbool = gen_constant smt_modules "Tbool" -let cTpositive = gen_constant smt_modules "Tpositive" -let cTBV = gen_constant smt_modules "TBV" -let cTFArray = gen_constant smt_modules "TFArray" -let cTindex = gen_constant smt_modules "Tindex" - -(* let ct_i = gen_constant smt_modules "t_i" *) -let cinterp_t = gen_constant smt_modules "Typ.interp" -let cdec_interp = gen_constant smt_modules "dec_interp" -let cord_interp = gen_constant smt_modules "ord_interp" -let ccomp_interp = gen_constant smt_modules "comp_interp" -let cinh_interp = gen_constant smt_modules "inh_interp" - -let cinterp_eqb = gen_constant smt_modules "i_eqb" -(* let cinterp_eqb_eqb = gen_constant smt_modules "i_eqb_eqb" *) - -let classes_modules = [["SMTCoq";"classes";"SMT_classes"]; - ["SMTCoq";"classes";"SMT_classes_instances"]] - -let ctyp_compdec = gen_constant classes_modules "typ_compdec" -let cTyp_compdec = gen_constant classes_modules "Typ_compdec" -(* let ctyp_compdec_from = gen_constant classes_modules "typ_compdec_from" *) -let cunit_typ_compdec = gen_constant classes_modules "unit_typ_compdec" -let cte_carrier = gen_constant classes_modules "te_carrier" -let cte_compdec = gen_constant classes_modules "te_compdec" -let ceqb_of_compdec = gen_constant classes_modules "eqb_of_compdec" -let cCompDec = gen_constant classes_modules "CompDec" - -let cbool_compdec = gen_constant classes_modules "bool_compdec" -let cZ_compdec = gen_constant classes_modules "Z_compdec" -let cPositive_compdec = gen_constant classes_modules "Positive_compdec" -let cBV_compdec = gen_constant classes_modules "BV_compdec" -let cFArray_compdec = gen_constant classes_modules "FArray_compdec" - -let ctval = gen_constant smt_modules "tval" -let cTval = gen_constant smt_modules "Tval" - -let cCO_xH = gen_constant smt_modules "CO_xH" -let cCO_Z0 = gen_constant smt_modules "CO_Z0" -let cCO_BV = gen_constant smt_modules "CO_BV" - -let cUO_xO = gen_constant smt_modules "UO_xO" -let cUO_xI = gen_constant smt_modules "UO_xI" -let cUO_Zpos = gen_constant smt_modules "UO_Zpos" -let cUO_Zneg = gen_constant smt_modules "UO_Zneg" -let cUO_Zopp = gen_constant smt_modules "UO_Zopp" -let cUO_BVbitOf = gen_constant smt_modules "UO_BVbitOf" -let cUO_BVnot = gen_constant smt_modules "UO_BVnot" -let cUO_BVneg = gen_constant smt_modules "UO_BVneg" -let cUO_BVextr = gen_constant smt_modules "UO_BVextr" -let cUO_BVzextn = gen_constant smt_modules "UO_BVzextn" -let cUO_BVsextn = gen_constant smt_modules "UO_BVsextn" - -let cBO_Zplus = gen_constant smt_modules "BO_Zplus" -let cBO_Zminus = gen_constant smt_modules "BO_Zminus" -let cBO_Zmult = gen_constant smt_modules "BO_Zmult" -let cBO_Zlt = gen_constant smt_modules "BO_Zlt" -let cBO_Zle = gen_constant smt_modules "BO_Zle" -let cBO_Zge = gen_constant smt_modules "BO_Zge" -let cBO_Zgt = gen_constant smt_modules "BO_Zgt" -let cBO_eq = gen_constant smt_modules "BO_eq" -let cBO_BVand = gen_constant smt_modules "BO_BVand" -let cBO_BVor = gen_constant smt_modules "BO_BVor" -let cBO_BVxor = gen_constant smt_modules "BO_BVxor" -let cBO_BVadd = gen_constant smt_modules "BO_BVadd" -let cBO_BVmult = gen_constant smt_modules "BO_BVmult" -let cBO_BVult = gen_constant smt_modules "BO_BVult" -let cBO_BVslt = gen_constant smt_modules "BO_BVslt" -let cBO_BVconcat = gen_constant smt_modules "BO_BVconcat" -let cBO_BVshl = gen_constant smt_modules "BO_BVshl" -let cBO_BVshr = gen_constant smt_modules "BO_BVshr" -let cBO_select = gen_constant smt_modules "BO_select" -let cBO_diffarray = gen_constant smt_modules "BO_diffarray" - -let cTO_store = gen_constant smt_modules "TO_store" - -let cNO_distinct = gen_constant smt_modules "NO_distinct" - -let catom = gen_constant smt_modules "atom" -let cAcop = gen_constant smt_modules "Acop" -let cAuop = gen_constant smt_modules "Auop" -let cAbop = gen_constant smt_modules "Abop" -let cAtop = gen_constant smt_modules "Atop" -let cAnop = gen_constant smt_modules "Anop" -let cAapp = gen_constant smt_modules "Aapp" - -let cform = gen_constant smt_modules "form" -let cFatom = gen_constant smt_modules "Fatom" -let cFtrue = gen_constant smt_modules "Ftrue" -let cFfalse = gen_constant smt_modules "Ffalse" -let cFnot2 = gen_constant smt_modules "Fnot2" -let cFand = gen_constant smt_modules "Fand" -let cFor = gen_constant smt_modules "For" -let cFxor = gen_constant smt_modules "Fxor" -let cFimp = gen_constant smt_modules "Fimp" -let cFiff = gen_constant smt_modules "Fiff" -let cFite = gen_constant smt_modules "Fite" -let cFbbT = gen_constant smt_modules "FbbT" - -let cvalid_sat_checker = gen_constant [["SMTCoq";"Trace";"Sat_Checker"]] "valid" -let cinterp_var_sat_checker = gen_constant [["SMTCoq";"Trace";"Sat_Checker"]] "interp_var" - -let make_certif_ops modules args = +let array_prefix = "SMTCoq.array.FArray" +let array_gc = gc array_prefix +let cfarray = array_gc "farray" +let cselect = array_gc "select" +let cstore = array_gc "store" +let cdiff = array_gc "diff" +let cequalarray = array_gc "equal" + +(* SMTCoq terms *) +let state_prefix = "SMTCoq.State" +let state_gc = gc state_prefix +let cState_C_t = state_gc "C.t" +let cState_S_t = state_gc "S.t" + +let misc_prefix = "SMTCoq.Misc" +let misc_gc = gc misc_prefix +let cdistinct = misc_gc "distinct" + +let terms_prefix = "SMTCoq.SMT_terms" +let terms_gc = gc terms_prefix + +let ctype = terms_gc "Typ.type" +let cTZ = terms_gc "Typ.TZ" +let cTbool = terms_gc "Typ.Tbool" +let cTpositive = terms_gc "Typ.Tpositive" +let cTBV = terms_gc "Typ.TBV" +let cTFArray = terms_gc "Typ.TFArray" +let cTindex = terms_gc "Typ.Tindex" + +let cinterp_t = terms_gc "Typ.interp" +let cdec_interp = terms_gc "Typ.dec_interp" +let cord_interp = terms_gc "Typ.ord_interp" +let ccomp_interp = terms_gc "Typ.comp_interp" +let cinh_interp = terms_gc "Typ.inh_interp" + +let cinterp_eqb = terms_gc "Typ.i_eqb" + +let ctval = terms_gc "Atom.tval" +let cTval = terms_gc "Atom.Tval" + +let cCO_xH = terms_gc "Atom.CO_xH" +let cCO_Z0 = terms_gc "Atom.CO_Z0" +let cCO_BV = terms_gc "Atom.CO_BV" + +let cUO_xO = terms_gc "Atom.UO_xO" +let cUO_xI = terms_gc "Atom.UO_xI" +let cUO_Zpos = terms_gc "Atom.UO_Zpos" +let cUO_Zneg = terms_gc "Atom.UO_Zneg" +let cUO_Zopp = terms_gc "Atom.UO_Zopp" +let cUO_BVbitOf = terms_gc "Atom.UO_BVbitOf" +let cUO_BVnot = terms_gc "Atom.UO_BVnot" +let cUO_BVneg = terms_gc "Atom.UO_BVneg" +let cUO_BVextr = terms_gc "Atom.UO_BVextr" +let cUO_BVzextn = terms_gc "Atom.UO_BVzextn" +let cUO_BVsextn = terms_gc "Atom.UO_BVsextn" + +let cBO_Zplus = terms_gc "Atom.BO_Zplus" +let cBO_Zminus = terms_gc "Atom.BO_Zminus" +let cBO_Zmult = terms_gc "Atom.BO_Zmult" +let cBO_Zlt = terms_gc "Atom.BO_Zlt" +let cBO_Zle = terms_gc "Atom.BO_Zle" +let cBO_Zge = terms_gc "Atom.BO_Zge" +let cBO_Zgt = terms_gc "Atom.BO_Zgt" +let cBO_eq = terms_gc "Atom.BO_eq" +let cBO_BVand = terms_gc "Atom.BO_BVand" +let cBO_BVor = terms_gc "Atom.BO_BVor" +let cBO_BVxor = terms_gc "Atom.BO_BVxor" +let cBO_BVadd = terms_gc "Atom.BO_BVadd" +let cBO_BVmult = terms_gc "Atom.BO_BVmult" +let cBO_BVult = terms_gc "Atom.BO_BVult" +let cBO_BVslt = terms_gc "Atom.BO_BVslt" +let cBO_BVconcat = terms_gc "Atom.BO_BVconcat" +let cBO_BVshl = terms_gc "Atom.BO_BVshl" +let cBO_BVshr = terms_gc "Atom.BO_BVshr" +let cBO_select = terms_gc "Atom.BO_select" +let cBO_diffarray = terms_gc "Atom.BO_diffarray" + +let cTO_store = terms_gc "Atom.TO_store" + +let cNO_distinct = terms_gc "Atom.NO_distinct" + +let catom = terms_gc "Atom.atom" +let cAcop = terms_gc "Atom.Acop" +let cAuop = terms_gc "Atom.Auop" +let cAbop = terms_gc "Atom.Abop" +let cAtop = terms_gc "Atom.Atop" +let cAnop = terms_gc "Atom.Anop" +let cAapp = terms_gc "Atom.Aapp" + +let cform = terms_gc "Form.form" +let cFatom = terms_gc "Form.Fatom" +let cFtrue = terms_gc "Form.Ftrue" +let cFfalse = terms_gc "Form.Ffalse" +let cFnot2 = terms_gc "Form.Fnot2" +let cFand = terms_gc "Form.Fand" +let cFor = terms_gc "Form.For" +let cFxor = terms_gc "Form.Fxor" +let cFimp = terms_gc "Form.Fimp" +let cFiff = terms_gc "Form.Fiff" +let cFite = terms_gc "Form.Fite" +let cFbbT = terms_gc "Form.FbbT" + +(* SMTCoq Classes *) +let classes_prefix = "SMTCoq.classes.SMT_classes" +let classes_gc = gc classes_prefix +let ctyp_compdec = classes_gc "typ_compdec" +let cTyp_compdec = classes_gc "Typ_compdec" +let cte_carrier = classes_gc "te_carrier" +let cte_compdec = classes_gc "te_compdec" +let ceqb_of_compdec = classes_gc "eqb_of_compdec" +let cCompDec = classes_gc "CompDec" + +let classesi_prefix = "SMTCoq.classes.SMT_classes_instances" +let classesi_gc = gc classesi_prefix +let cunit_typ_compdec = classesi_gc "unit_typ_compdec" +let cbool_compdec = classesi_gc "bool_compdec" +let cZ_compdec = classesi_gc "Z_compdec" +let cPositive_compdec = classesi_gc "Positive_compdec" +let cBV_compdec = classesi_gc "BV_compdec" +let cFArray_compdec = classesi_gc "FArray_compdec" + +(* SMTCoq Trace *) +let sat_checker_prefix = "SMTCoq.Trace.Sat_Checker" +let sat_checker_gc = gc sat_checker_prefix +let csat_checker_valid = sat_checker_gc "valid" +let csat_checker_interp_var = sat_checker_gc "interp_var" +let csat_checker_Certif = sat_checker_gc "Certif" +let csat_checker_dimacs = sat_checker_gc "dimacs" +let csat_checker_certif = sat_checker_gc "certif" +let csat_checker_theorem_checker = sat_checker_gc "theorem_checker" +let csat_checker_checker = sat_checker_gc "checker" + +let cnf_checker_prefix = "SMTCoq.Trace.Cnf_Checker" +let cnf_checker_gc = gc cnf_checker_prefix +let ccnf_checker_certif = cnf_checker_gc "certif" +let ccnf_checker_Certif = cnf_checker_gc "Certif" +let ccnf_checker_checker_b_correct = cnf_checker_gc "checker_b_correct" +let ccnf_checker_checker_b = cnf_checker_gc "checker_b" +let ccnf_checker_checker_eq_correct = cnf_checker_gc "checker_eq_correct" +let ccnf_checker_checker_eq = cnf_checker_gc "checker_eq" + +let euf_checker_prefix = "SMTCoq.Trace.Euf_Checker" +let euf_checker_gc = gc euf_checker_prefix +let ceuf_checker_Certif = euf_checker_gc "Certif" +let ceuf_checker_certif = euf_checker_gc "certif" +let ceuf_checker_checker = euf_checker_gc "checker" +let ceuf_checker_checker_correct = euf_checker_gc "checker_correct" +let ceuf_checker_checker_b_correct = euf_checker_gc "checker_b_correct" +let ceuf_checker_checker_b = euf_checker_gc "checker_b" +let ceuf_checker_checker_eq_correct = euf_checker_gc "checker_eq_correct" +let ceuf_checker_checker_eq = euf_checker_gc "checker_eq" +let ceuf_checker_checker_debug = euf_checker_gc "checker_debug" +let ceuf_checker_name_step = euf_checker_gc "name_step" +let ceuf_checker_Name_Res = euf_checker_gc "Name_Res" +let ceuf_checker_Name_Weaken = euf_checker_gc "Name_Weaken" +let ceuf_checker_Name_ImmFlatten = euf_checker_gc "Name_ImmFlatten" +let ceuf_checker_Name_CTrue = euf_checker_gc "Name_CTrue" +let ceuf_checker_Name_CFalse = euf_checker_gc "Name_CFalse" +let ceuf_checker_Name_BuildDef = euf_checker_gc "Name_BuildDef" +let ceuf_checker_Name_BuildDef2 = euf_checker_gc "Name_BuildDef2" +let ceuf_checker_Name_BuildProj = euf_checker_gc "Name_BuildProj" +let ceuf_checker_Name_ImmBuildDef = euf_checker_gc "Name_ImmBuildDef" +let ceuf_checker_Name_ImmBuildDef2 = euf_checker_gc "Name_ImmBuildDef2" +let ceuf_checker_Name_ImmBuildProj = euf_checker_gc "Name_ImmBuildProj" +let ceuf_checker_Name_EqTr = euf_checker_gc "Name_EqTr" +let ceuf_checker_Name_EqCgr = euf_checker_gc "Name_EqCgr" +let ceuf_checker_Name_EqCgrP = euf_checker_gc "Name_EqCgrP" +let ceuf_checker_Name_LiaMicromega = euf_checker_gc "Name_LiaMicromega" +let ceuf_checker_Name_LiaDiseq = euf_checker_gc "Name_LiaDiseq" +let ceuf_checker_Name_SplArith = euf_checker_gc "Name_SplArith" +let ceuf_checker_Name_SplDistinctElim = euf_checker_gc "Name_SplDistinctElim" +let ceuf_checker_Name_BBVar = euf_checker_gc "Name_BBVar" +let ceuf_checker_Name_BBConst = euf_checker_gc "Name_BBConst" +let ceuf_checker_Name_BBOp = euf_checker_gc "Name_BBOp" +let ceuf_checker_Name_BBNot = euf_checker_gc "Name_BBNot" +let ceuf_checker_Name_BBNeg = euf_checker_gc "Name_BBNeg" +let ceuf_checker_Name_BBAdd = euf_checker_gc "Name_BBAdd" +let ceuf_checker_Name_BBConcat = euf_checker_gc "Name_BBConcat" +let ceuf_checker_Name_BBMul = euf_checker_gc "Name_BBMul" +let ceuf_checker_Name_BBUlt = euf_checker_gc "Name_BBUlt" +let ceuf_checker_Name_BBSlt = euf_checker_gc "Name_BBSlt" +let ceuf_checker_Name_BBEq = euf_checker_gc "Name_BBEq" +let ceuf_checker_Name_BBDiseq = euf_checker_gc "Name_BBDiseq" +let ceuf_checker_Name_BBExtract = euf_checker_gc "Name_BBExtract" +let ceuf_checker_Name_BBZextend = euf_checker_gc "Name_BBZextend" +let ceuf_checker_Name_BBSextend = euf_checker_gc "Name_BBSextend" +let ceuf_checker_Name_BBShl = euf_checker_gc "Name_BBShl" +let ceuf_checker_Name_BBShr = euf_checker_gc "Name_BBShr" +let ceuf_checker_Name_RowEq = euf_checker_gc "Name_RowEq" +let ceuf_checker_Name_RowNeq = euf_checker_gc "Name_RowNeq" +let ceuf_checker_Name_Ext = euf_checker_gc "Name_Ext" +let ceuf_checker_Name_Hole = euf_checker_gc "Name_Hole" + +type certif_ops = + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm +let make_certif_ops prefix args = + let gc = gc prefix in let gen_constant c = match args with - | Some args -> lazy (mklApp (gen_constant modules c) args) - | None -> gen_constant modules c in + | Some args -> lazy (mklApp (gc c) args) + | None -> gc c in (gen_constant "step", gen_constant "Res", gen_constant "Weaken", gen_constant "ImmFlatten", gen_constant "CTrue", gen_constant "CFalse", gen_constant "BuildDef", gen_constant "BuildDef2", gen_constant "BuildProj", - gen_constant "ImmBuildProj", gen_constant"ImmBuildDef", + gen_constant "ImmBuildProj", gen_constant "ImmBuildDef", gen_constant"ImmBuildDef2", gen_constant "EqTr", gen_constant "EqCgr", gen_constant "EqCgrP", gen_constant "LiaMicromega", gen_constant "LiaDiseq", @@ -297,6 +391,9 @@ let make_certif_ops modules args = gen_constant "BBShl", gen_constant "BBShr", gen_constant "RowEq", gen_constant "RowNeq", gen_constant "Ext", gen_constant "Hole", gen_constant "ForallInst") +let csat_checker_certif_ops = make_certif_ops sat_checker_prefix None +let ccnf_checker_certif_ops = make_certif_ops cnf_checker_prefix None +let ceuf_checker_certif_ops = make_certif_ops euf_checker_prefix (** Useful constructions *) @@ -307,8 +404,8 @@ let ceq_refl_true = let eq_refl_true () = Lazy.force ceq_refl_true let vm_cast_true_no_check t = - Structures.mkCast(eq_refl_true (), - Structures.vmcast, + CoqInterface.mkCast(eq_refl_true (), + CoqInterface.vmcast, mklApp ceq [|Lazy.force cbool; t; Lazy.force ctrue|]) (* This version checks convertibility right away instead of delaying it at @@ -316,13 +413,13 @@ let vm_cast_true_no_check t = SMTCoq's tactics. *) let vm_cast_true env t = try - Structures.vm_conv Reduction.CUMUL env + CoqInterface.vm_conv Reduction.CUMUL env (mklApp ceq [|Lazy.force cbool; Lazy.force ctrue; Lazy.force ctrue|]) (mklApp ceq [|Lazy.force cbool; t; Lazy.force ctrue|]); vm_cast_true_no_check t with Reduction.NotConvertible -> - Structures.error ("SMTCoq was not able to check the proof certificate.") + CoqInterface.error ("SMTCoq was not able to check the proof certificate.") (* Compute a nat *) @@ -353,42 +450,55 @@ let rec mk_bv_list = function | b :: bv -> mklApp ccons [|Lazy.force cbool; mkBool b; mk_bv_list bv|] +(* Compute an array *) +let mkArray : Constr.types * Constr.t array -> Constr.t = + fun (ty, a) -> + let l = (Array.length a) - 1 in + snd (Array.fold_left (fun (i,acc) c -> + let acc' = + if i = l then + acc + else + mklApp cset [|ty; acc; mkInt i; c|] in + (i+1,acc') + ) (0, mklApp cmake [|ty; mkInt l; a.(l)|]) a) + (* Reification *) let mk_bool b = - let c, args = Structures.decompose_app b in - if Structures.eq_constr c (Lazy.force ctrue) then true - else if Structures.eq_constr c (Lazy.force cfalse) then false + let c, args = CoqInterface.decompose_app b in + if CoqInterface.eq_constr c (Lazy.force ctrue) then true + else if CoqInterface.eq_constr c (Lazy.force cfalse) then false else assert false let rec mk_bool_list bs = - let c, args = Structures.decompose_app bs in - if Structures.eq_constr c (Lazy.force cnil) then [] - else if Structures.eq_constr c (Lazy.force ccons) then + let c, args = CoqInterface.decompose_app bs in + if CoqInterface.eq_constr c (Lazy.force cnil) then [] + else if CoqInterface.eq_constr c (Lazy.force ccons) then match args with | [_; b; bs] -> mk_bool b :: mk_bool_list bs | _ -> assert false else assert false let rec mk_nat n = - let c, args = Structures.decompose_app n in - if Structures.eq_constr c (Lazy.force cO) then + let c, args = CoqInterface.decompose_app n in + if CoqInterface.eq_constr c (Lazy.force cO) then 0 - else if Structures.eq_constr c (Lazy.force cS) then + else if CoqInterface.eq_constr c (Lazy.force cS) then match args with | [n] -> (mk_nat n) + 1 | _ -> assert false else assert false let rec mk_positive n = - let c, args = Structures.decompose_app n in - if Structures.eq_constr c (Lazy.force cxH) then + let c, args = CoqInterface.decompose_app n in + if CoqInterface.eq_constr c (Lazy.force cxH) then 1 - else if Structures.eq_constr c (Lazy.force cxO) then + else if CoqInterface.eq_constr c (Lazy.force cxO) then match args with | [n] -> 2 * (mk_positive n) | _ -> assert false - else if Structures.eq_constr c (Lazy.force cxI) then + else if CoqInterface.eq_constr c (Lazy.force cxI) then match args with | [n] -> 2 * (mk_positive n) + 1 | _ -> assert false @@ -396,10 +506,10 @@ let rec mk_positive n = let mk_N n = - let c, args = Structures.decompose_app n in - if Structures.eq_constr c (Lazy.force cN0) then + let c, args = CoqInterface.decompose_app n in + if CoqInterface.eq_constr c (Lazy.force cN0) then 0 - else if Structures.eq_constr c (Lazy.force cNpos) then + else if CoqInterface.eq_constr c (Lazy.force cNpos) then match args with | [n] -> mk_positive n | _ -> assert false @@ -407,13 +517,13 @@ let mk_N n = let mk_Z n = - let c, args = Structures.decompose_app n in - if Structures.eq_constr c (Lazy.force cZ0) then 0 - else if Structures.eq_constr c (Lazy.force cZpos) then + let c, args = CoqInterface.decompose_app n in + if CoqInterface.eq_constr c (Lazy.force cZ0) then 0 + else if CoqInterface.eq_constr c (Lazy.force cZpos) then match args with | [n] -> mk_positive n | _ -> assert false - else if Structures.eq_constr c (Lazy.force cZneg) then + else if CoqInterface.eq_constr c (Lazy.force cZneg) then match args with | [n] -> - mk_positive n | _ -> assert false @@ -422,12 +532,12 @@ let mk_Z n = (* size of bivectors are either N.of_nat (length l) or an N *) let mk_bvsize n = - let c, args = Structures.decompose_app n in - if Structures.eq_constr c (Lazy.force cof_nat) then + let c, args = CoqInterface.decompose_app n in + if CoqInterface.eq_constr c (Lazy.force cof_nat) then match args with | [nl] -> - let c, args = Structures.decompose_app nl in - if Structures.eq_constr c (Lazy.force clength) then + let c, args = CoqInterface.decompose_app nl in + if CoqInterface.eq_constr c (Lazy.force clength) then match args with | [_; l] -> List.length (mk_bool_list l) | _ -> assert false @@ -438,7 +548,7 @@ let mk_bvsize n = (** Switches between constr and OCaml *) (* Transform a option constr into a constr option *) let option_of_constr_option co = - let c, args = Structures.decompose_app co in + let c, args = CoqInterface.decompose_app co in if c = Lazy.force cSome then match args with | [_;c] -> Some c @@ -449,7 +559,7 @@ let option_of_constr_option co = (* Transform a tuple of constr into a (reversed) list of constr *) let list_of_constr_tuple = let rec list_of_constr_tuple acc t = - let c, args = Structures.decompose_app t in + let c, args = CoqInterface.decompose_app t in if c = Lazy.force cpair then match args with | [_;_;t1;t2] -> diff --git a/src/trace/coqTerms.mli b/src/trace/coqTerms.mli index f62f01a..53622ac 100644 --- a/src/trace/coqTerms.mli +++ b/src/trace/coqTerms.mli @@ -10,258 +10,331 @@ (**************************************************************************) -val gen_constant : string list list -> string -> Structures.constr lazy_t +type coqTerm = CoqInterface.constr lazy_t (* Int63 *) -val cint : Structures.constr lazy_t -val ceq63 : Structures.constr lazy_t +val cint : coqTerm +val ceq63 : coqTerm (* PArray *) -val carray : Structures.constr lazy_t +val carray : coqTerm +val cmake : coqTerm +val cset : coqTerm + +(* is_true *) +val cis_true : coqTerm (* nat *) -val cnat : Structures.constr lazy_t -val cO : Structures.constr lazy_t -val cS : Structures.constr lazy_t +val cnat : coqTerm +val cO : coqTerm +val cS : coqTerm (* Positive *) -val cpositive : Structures.constr lazy_t -val cxI : Structures.constr lazy_t -val cxO : Structures.constr lazy_t -val cxH : Structures.constr lazy_t -val ceqbP : Structures.constr lazy_t +val cpositive : coqTerm +val cxI : coqTerm +val cxO : coqTerm +val cxH : coqTerm +val ceqbP : coqTerm (* N *) -val cN : Structures.constr lazy_t -val cN0 : Structures.constr lazy_t -val cNpos : Structures.constr lazy_t -val cof_nat : Structures.constr lazy_t +val cN : coqTerm +val cN0 : coqTerm +val cNpos : coqTerm +val cof_nat : coqTerm (* Z *) -val cZ : Structures.constr lazy_t -val cZ0 : Structures.constr lazy_t -val cZpos : Structures.constr lazy_t -val cZneg : Structures.constr lazy_t -val copp : Structures.constr lazy_t -val cadd : Structures.constr lazy_t -val csub : Structures.constr lazy_t -val cmul : Structures.constr lazy_t -val cltb : Structures.constr lazy_t -val cleb : Structures.constr lazy_t -val cgeb : Structures.constr lazy_t -val cgtb : Structures.constr lazy_t -val ceqbZ : Structures.constr lazy_t +val cZ : coqTerm +val cZ0 : coqTerm +val cZpos : coqTerm +val cZneg : coqTerm +val copp : coqTerm +val cadd : coqTerm +val csub : coqTerm +val cmul : coqTerm +val cltb : coqTerm +val cleb : coqTerm +val cgeb : coqTerm +val cgtb : coqTerm +val ceqbZ : coqTerm (* Booleans *) -val cbool : Structures.constr lazy_t -val ctrue : Structures.constr lazy_t -val cfalse : Structures.constr lazy_t -val candb : Structures.constr lazy_t -val corb : Structures.constr lazy_t -val cxorb : Structures.constr lazy_t -val cnegb : Structures.constr lazy_t -val cimplb : Structures.constr lazy_t -val ceqb : Structures.constr lazy_t -val cifb : Structures.constr lazy_t -val ciff : Structures.constr lazy_t -val creflect : Structures.constr lazy_t +val cbool : coqTerm +val ctrue : coqTerm +val cfalse : coqTerm +val candb : coqTerm +val corb : coqTerm +val cxorb : coqTerm +val cnegb : coqTerm +val cimplb : coqTerm +val ceqb : coqTerm +val cifb : coqTerm +val creflect : coqTerm (* Lists *) -val clist : Structures.constr lazy_t -val cnil : Structures.constr lazy_t -val ccons : Structures.constr lazy_t -val clength : Structures.constr lazy_t +val clist : coqTerm +val cnil : coqTerm +val ccons : coqTerm +val clength : coqTerm (* Option *) -val coption : Structures.constr lazy_t -val cSome : Structures.constr lazy_t -val cNone : Structures.constr lazy_t +val coption : coqTerm +val cSome : coqTerm +val cNone : coqTerm (* Pairs *) -val cpair : Structures.constr lazy_t -val cprod : Structures.constr lazy_t +val cpair : coqTerm +val cprod : coqTerm (* Dependent pairs *) -val csigT : Structures.constr lazy_t +val csigT : coqTerm (* Logical Operators *) -val cnot : Structures.constr lazy_t -val ceq : Structures.constr lazy_t -val crefl_equal : Structures.constr lazy_t -val cconj : Structures.constr lazy_t -val cand : Structures.constr lazy_t +val cnot : coqTerm +val cconj : coqTerm +val cand : coqTerm +val ciff : coqTerm + +(* Equality *) +val ceq : coqTerm +val crefl_equal : coqTerm + +(* Micromega *) +val micromega_coq_proofTerm : coqTerm (* Bit vectors *) -val cbitvector : Structures.constr lazy_t -val cof_bits : Structures.constr lazy_t -val cbitOf : Structures.constr lazy_t -val cbv_eq : Structures.constr lazy_t -val cbv_not : Structures.constr lazy_t -val cbv_neg : Structures.constr lazy_t -val cbv_and : Structures.constr lazy_t -val cbv_or : Structures.constr lazy_t -val cbv_xor : Structures.constr lazy_t -val cbv_add : Structures.constr lazy_t -val cbv_mult : Structures.constr lazy_t -val cbv_ult : Structures.constr lazy_t -val cbv_slt : Structures.constr lazy_t -val cbv_concat : Structures.constr lazy_t -val cbv_extr : Structures.constr lazy_t -val cbv_zextn : Structures.constr lazy_t -val cbv_sextn : Structures.constr lazy_t -val cbv_shl : Structures.constr lazy_t -val cbv_shr : Structures.constr lazy_t +val cbitvector : coqTerm +val cof_bits : coqTerm +val cbitOf : coqTerm +val cbv_eq : coqTerm +val cbv_not : coqTerm +val cbv_neg : coqTerm +val cbv_and : coqTerm +val cbv_or : coqTerm +val cbv_xor : coqTerm +val cbv_add : coqTerm +val cbv_mult : coqTerm +val cbv_ult : coqTerm +val cbv_slt : coqTerm +val cbv_concat : coqTerm +val cbv_extr : coqTerm +val cbv_zextn : coqTerm +val cbv_sextn : coqTerm +val cbv_shl : coqTerm +val cbv_shr : coqTerm (* Arrays *) -val cfarray : Structures.constr lazy_t -val cselect : Structures.constr lazy_t -val cstore : Structures.constr lazy_t -val cdiff : Structures.constr lazy_t -val cequalarray : Structures.constr lazy_t - -(* OrderedType *) - -(* SMT_terms *) -val cState_C_t : Structures.constr lazy_t -val cState_S_t : Structures.constr lazy_t - -val cdistinct : Structures.constr lazy_t - -val ctype : Structures.constr lazy_t -val cTZ : Structures.constr lazy_t -val cTbool : Structures.constr lazy_t -val cTpositive : Structures.constr lazy_t -val cTBV : Structures.constr lazy_t -val cTFArray : Structures.constr lazy_t -val cTindex : Structures.constr lazy_t - -val cinterp_t : Structures.constr lazy_t -val cdec_interp : Structures.constr lazy_t -val cord_interp : Structures.constr lazy_t -val ccomp_interp : Structures.constr lazy_t -val cinh_interp : Structures.constr lazy_t - -val cinterp_eqb : Structures.constr lazy_t - -val ctyp_compdec : Structures.constr lazy_t -val cTyp_compdec : Structures.constr lazy_t -val cunit_typ_compdec : Structures.constr lazy_t -val cte_carrier : Structures.constr lazy_t -val cte_compdec : Structures.constr lazy_t -val ceqb_of_compdec : Structures.constr lazy_t -val cCompDec : Structures.constr lazy_t - -val cbool_compdec : Structures.constr lazy_t -val cZ_compdec : Structures.constr lazy_t -val cPositive_compdec : Structures.constr lazy_t -val cBV_compdec : Structures.constr lazy_t -val cFArray_compdec : Structures.constr lazy_t - -val ctval : Structures.constr lazy_t -val cTval : Structures.constr lazy_t - -val cCO_xH : Structures.constr lazy_t -val cCO_Z0 : Structures.constr lazy_t -val cCO_BV : Structures.constr lazy_t - -val cUO_xO : Structures.constr lazy_t -val cUO_xI : Structures.constr lazy_t -val cUO_Zpos : Structures.constr lazy_t -val cUO_Zneg : Structures.constr lazy_t -val cUO_Zopp : Structures.constr lazy_t -val cUO_BVbitOf : Structures.constr lazy_t -val cUO_BVnot : Structures.constr lazy_t -val cUO_BVneg : Structures.constr lazy_t -val cUO_BVextr : Structures.constr lazy_t -val cUO_BVzextn : Structures.constr lazy_t -val cUO_BVsextn : Structures.constr lazy_t - -val cBO_Zplus : Structures.constr lazy_t -val cBO_Zminus : Structures.constr lazy_t -val cBO_Zmult : Structures.constr lazy_t -val cBO_Zlt : Structures.constr lazy_t -val cBO_Zle : Structures.constr lazy_t -val cBO_Zge : Structures.constr lazy_t -val cBO_Zgt : Structures.constr lazy_t -val cBO_eq : Structures.constr lazy_t -val cBO_BVand : Structures.constr lazy_t -val cBO_BVor : Structures.constr lazy_t -val cBO_BVxor : Structures.constr lazy_t -val cBO_BVadd : Structures.constr lazy_t -val cBO_BVmult : Structures.constr lazy_t -val cBO_BVult : Structures.constr lazy_t -val cBO_BVslt : Structures.constr lazy_t -val cBO_BVconcat : Structures.constr lazy_t -val cBO_BVshl : Structures.constr lazy_t -val cBO_BVshr : Structures.constr lazy_t -val cBO_select : Structures.constr lazy_t -val cBO_diffarray : Structures.constr lazy_t - -val cTO_store : Structures.constr lazy_t - -val cNO_distinct : Structures.constr lazy_t - -val catom : Structures.constr lazy_t -val cAcop : Structures.constr lazy_t -val cAuop : Structures.constr lazy_t -val cAbop : Structures.constr lazy_t -val cAtop : Structures.constr lazy_t -val cAnop : Structures.constr lazy_t -val cAapp : Structures.constr lazy_t - -val cform : Structures.constr lazy_t -val cFatom : Structures.constr lazy_t -val cFtrue : Structures.constr lazy_t -val cFfalse : Structures.constr lazy_t -val cFnot2 : Structures.constr lazy_t -val cFand : Structures.constr lazy_t -val cFor : Structures.constr lazy_t -val cFxor : Structures.constr lazy_t -val cFimp : Structures.constr lazy_t -val cFiff : Structures.constr lazy_t -val cFite : Structures.constr lazy_t -val cFbbT : Structures.constr lazy_t - -val cis_true : Structures.constr lazy_t - -val cvalid_sat_checker : Structures.constr lazy_t -val cinterp_var_sat_checker : Structures.constr lazy_t - -val make_certif_ops : - string list list -> - Structures.constr array option -> - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t * Structures.constr lazy_t * - Structures.constr lazy_t * Structures.constr lazy_t +val cfarray : coqTerm +val cselect : coqTerm +val cstore : coqTerm +val cdiff : coqTerm +val cequalarray : coqTerm + +(* SMTCoq terms *) +val cState_C_t : coqTerm +val cState_S_t : coqTerm + +val cdistinct : coqTerm + +val ctype : coqTerm +val cTZ : coqTerm +val cTbool : coqTerm +val cTpositive : coqTerm +val cTBV : coqTerm +val cTFArray : coqTerm +val cTindex : coqTerm + +val cinterp_t : coqTerm +val cdec_interp : coqTerm +val cord_interp : coqTerm +val ccomp_interp : coqTerm +val cinh_interp : coqTerm + +val cinterp_eqb : coqTerm + +val ctval : coqTerm +val cTval : coqTerm + +val cCO_xH : coqTerm +val cCO_Z0 : coqTerm +val cCO_BV : coqTerm + +val cUO_xO : coqTerm +val cUO_xI : coqTerm +val cUO_Zpos : coqTerm +val cUO_Zneg : coqTerm +val cUO_Zopp : coqTerm +val cUO_BVbitOf : coqTerm +val cUO_BVnot : coqTerm +val cUO_BVneg : coqTerm +val cUO_BVextr : coqTerm +val cUO_BVzextn : coqTerm +val cUO_BVsextn : coqTerm + +val cBO_Zplus : coqTerm +val cBO_Zminus : coqTerm +val cBO_Zmult : coqTerm +val cBO_Zlt : coqTerm +val cBO_Zle : coqTerm +val cBO_Zge : coqTerm +val cBO_Zgt : coqTerm +val cBO_eq : coqTerm +val cBO_BVand : coqTerm +val cBO_BVor : coqTerm +val cBO_BVxor : coqTerm +val cBO_BVadd : coqTerm +val cBO_BVmult : coqTerm +val cBO_BVult : coqTerm +val cBO_BVslt : coqTerm +val cBO_BVconcat : coqTerm +val cBO_BVshl : coqTerm +val cBO_BVshr : coqTerm +val cBO_select : coqTerm +val cBO_diffarray : coqTerm + +val cTO_store : coqTerm + +val cNO_distinct : coqTerm + +val catom : coqTerm +val cAcop : coqTerm +val cAuop : coqTerm +val cAbop : coqTerm +val cAtop : coqTerm +val cAnop : coqTerm +val cAapp : coqTerm + +val cform : coqTerm +val cFatom : coqTerm +val cFtrue : coqTerm +val cFfalse : coqTerm +val cFnot2 : coqTerm +val cFand : coqTerm +val cFor : coqTerm +val cFxor : coqTerm +val cFimp : coqTerm +val cFiff : coqTerm +val cFite : coqTerm +val cFbbT : coqTerm + +(* SMTCoq Classes *) +val ctyp_compdec : coqTerm +val cTyp_compdec : coqTerm +val cte_carrier : coqTerm +val cte_compdec : coqTerm +val ceqb_of_compdec : coqTerm +val cCompDec : coqTerm + +val cunit_typ_compdec : coqTerm +val cbool_compdec : coqTerm +val cZ_compdec : coqTerm +val cPositive_compdec : coqTerm +val cBV_compdec : coqTerm +val cFArray_compdec : coqTerm + +(* SMTCoq Trace *) +type certif_ops = + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm * coqTerm * + coqTerm * coqTerm + +val csat_checker_valid : coqTerm +val csat_checker_interp_var : coqTerm +val csat_checker_Certif : coqTerm +val csat_checker_dimacs : coqTerm +val csat_checker_certif : coqTerm +val csat_checker_theorem_checker : coqTerm +val csat_checker_checker : coqTerm +val csat_checker_certif_ops : certif_ops + +val ccnf_checker_certif : coqTerm +val ccnf_checker_Certif : coqTerm +val ccnf_checker_checker_b_correct : coqTerm +val ccnf_checker_checker_b : coqTerm +val ccnf_checker_checker_eq_correct : coqTerm +val ccnf_checker_checker_eq : coqTerm +val ccnf_checker_certif_ops : certif_ops + +val ceuf_checker_Certif : coqTerm +val ceuf_checker_certif : coqTerm +val ceuf_checker_checker : coqTerm +val ceuf_checker_checker_correct : coqTerm +val ceuf_checker_checker_b_correct : coqTerm +val ceuf_checker_checker_b : coqTerm +val ceuf_checker_checker_eq_correct : coqTerm +val ceuf_checker_checker_eq : coqTerm +val ceuf_checker_checker_debug : coqTerm +val ceuf_checker_name_step : coqTerm +val ceuf_checker_Name_Res : coqTerm +val ceuf_checker_Name_Weaken : coqTerm +val ceuf_checker_Name_ImmFlatten : coqTerm +val ceuf_checker_Name_CTrue : coqTerm +val ceuf_checker_Name_CFalse : coqTerm +val ceuf_checker_Name_BuildDef : coqTerm +val ceuf_checker_Name_BuildDef2 : coqTerm +val ceuf_checker_Name_BuildProj : coqTerm +val ceuf_checker_Name_ImmBuildDef : coqTerm +val ceuf_checker_Name_ImmBuildDef2 : coqTerm +val ceuf_checker_Name_ImmBuildProj : coqTerm +val ceuf_checker_Name_EqTr : coqTerm +val ceuf_checker_Name_EqCgr : coqTerm +val ceuf_checker_Name_EqCgrP : coqTerm +val ceuf_checker_Name_LiaMicromega : coqTerm +val ceuf_checker_Name_LiaDiseq : coqTerm +val ceuf_checker_Name_SplArith : coqTerm +val ceuf_checker_Name_SplDistinctElim : coqTerm +val ceuf_checker_Name_BBVar : coqTerm +val ceuf_checker_Name_BBConst : coqTerm +val ceuf_checker_Name_BBOp : coqTerm +val ceuf_checker_Name_BBNot : coqTerm +val ceuf_checker_Name_BBNeg : coqTerm +val ceuf_checker_Name_BBAdd : coqTerm +val ceuf_checker_Name_BBConcat : coqTerm +val ceuf_checker_Name_BBMul : coqTerm +val ceuf_checker_Name_BBUlt : coqTerm +val ceuf_checker_Name_BBSlt : coqTerm +val ceuf_checker_Name_BBEq : coqTerm +val ceuf_checker_Name_BBDiseq : coqTerm +val ceuf_checker_Name_BBExtract : coqTerm +val ceuf_checker_Name_BBZextend : coqTerm +val ceuf_checker_Name_BBSextend : coqTerm +val ceuf_checker_Name_BBShl : coqTerm +val ceuf_checker_Name_BBShr : coqTerm +val ceuf_checker_Name_RowEq : coqTerm +val ceuf_checker_Name_RowNeq : coqTerm +val ceuf_checker_Name_Ext : coqTerm +val ceuf_checker_Name_Hole : coqTerm +val ceuf_checker_certif_ops : CoqInterface.constr array option -> certif_ops + (* Some constructions *) -val ceq_refl_true : Structures.constr lazy_t -val eq_refl_true : unit -> Structures.constr -val vm_cast_true_no_check : Structures.constr -> Structures.constr -val vm_cast_true : Environ.env -> Structures.constr -> Structures.constr -val mkNat : int -> Structures.constr -val mkN : int -> Structures.constr -val mk_bv_list : bool list -> Structures.constr +val ceq_refl_true : coqTerm +val eq_refl_true : unit -> CoqInterface.constr +val vm_cast_true_no_check : CoqInterface.constr -> CoqInterface.constr +val vm_cast_true : Environ.env -> CoqInterface.constr -> CoqInterface.constr +val mkNat : int -> CoqInterface.constr +val mkN : int -> CoqInterface.constr +val mk_bv_list : bool list -> CoqInterface.constr +val mkArray : Constr.types * Constr.t array -> Constr.t (* Reification *) -val mk_bool : Structures.constr -> bool -val mk_bool_list : Structures.constr -> bool list -val mk_nat : Structures.constr -> int -val mk_N : Structures.constr -> int -val mk_Z : Structures.constr -> int -val mk_bvsize : Structures.constr -> int +val mk_bool : CoqInterface.constr -> bool +val mk_bool_list : CoqInterface.constr -> bool list +val mk_nat : CoqInterface.constr -> int +val mk_N : CoqInterface.constr -> int +val mk_Z : CoqInterface.constr -> int +val mk_bvsize : CoqInterface.constr -> int (* Switches between constr and OCaml *) -val option_of_constr_option : Structures.constr -> Structures.constr option -val list_of_constr_tuple : Structures.constr -> Structures.constr list +val option_of_constr_option : CoqInterface.constr -> CoqInterface.constr option +val list_of_constr_tuple : CoqInterface.constr -> CoqInterface.constr list diff --git a/src/trace/satAtom.ml b/src/trace/satAtom.ml index 4a3a62d..37e6a8c 100644 --- a/src/trace/satAtom.ml +++ b/src/trace/satAtom.ml @@ -27,7 +27,7 @@ module Atom = type reify_tbl = { mutable count : int; - tbl : (Structures.constr, int) Hashtbl.t + tbl : (CoqInterface.constr, int) Hashtbl.t } let create () = @@ -51,11 +51,11 @@ module Atom = t let interp_tbl reify = - Structures.mkArray (Lazy.force cbool, atom_tbl reify) + CoqTerms.mkArray (Lazy.force cbool, atom_tbl reify) let logic _ = SL.empty - let to_smt = Format.pp_print_int + let to_smt ?(debug=false) = Format.pp_print_int end diff --git a/src/trace/satAtom.mli b/src/trace/satAtom.mli index 1e14cbb..9f4272c 100644 --- a/src/trace/satAtom.mli +++ b/src/trace/satAtom.mli @@ -18,18 +18,18 @@ module Atom : sig val is_bool_type : t -> bool val is_bv_type : t -> bool - val to_smt : Format.formatter -> t -> unit + val to_smt : ?debug:bool -> Format.formatter -> t -> unit val logic : t -> SmtMisc.logic type reify_tbl = { mutable count : int; - tbl : (Structures.constr, t) Hashtbl.t; + tbl : (CoqInterface.constr, t) Hashtbl.t; } val create : unit -> reify_tbl - val declare : reify_tbl -> Structures.constr -> t - val get : reify_tbl -> Structures.constr -> t - val atom_tbl : reify_tbl -> Structures.constr array - val interp_tbl : reify_tbl -> Structures.constr + val declare : reify_tbl -> CoqInterface.constr -> t + val get : reify_tbl -> CoqInterface.constr -> t + val atom_tbl : reify_tbl -> CoqInterface.constr array + val interp_tbl : reify_tbl -> CoqInterface.constr end diff --git a/src/trace/smtAtom.ml b/src/trace/smtAtom.ml index 1befbf7..ccd9629 100644 --- a/src/trace/smtAtom.ml +++ b/src/trace/smtAtom.ml @@ -85,7 +85,7 @@ type nop = type op_def = { tparams : SmtBtype.btype array; tres : SmtBtype.btype; - op_val : Structures.constr } + op_val : CoqInterface.constr } type index = Index of int | Rel_name of string @@ -97,14 +97,14 @@ let destruct s (i, hval) = match i with | Rel_name _ -> failwith s let dummy_indexed_op i dom codom = - (i, {tparams = dom; tres = codom; op_val = Structures.mkProp}) + (i, {tparams = dom; tres = codom; op_val = CoqInterface.mkProp}) let indexed_op_index i = let index, _ = destruct "destruct on a Rel: called by indexed_op_index" i in index let debruijn_indexed_op i ty = - (Index i, {tparams = [||]; tres = ty; op_val = Structures.mkRel i}) + (Index i, {tparams = [||]; tres = ty; op_val = CoqInterface.mkRel i}) module Op = struct @@ -357,7 +357,7 @@ module Op = (* reify table *) type reify_tbl = { mutable count : int; - tbl : (Structures.constr, indexed_op) Hashtbl.t + tbl : (CoqInterface.constr, indexed_op) Hashtbl.t } let create () = @@ -385,7 +385,7 @@ module Op = let index, hval = destruct "destruct on a Rel: called by set in interp_tbl" op in t.(index) <- mk_Tval hval.tparams hval.tres hval.op_val in Hashtbl.iter set reify.tbl; - Structures.mkArray (tval, t) + CoqTerms.mkArray (tval, t) let to_list reify = let set _ op acc = @@ -707,13 +707,13 @@ module Atom = | [] -> () - let to_smt_named ?pi:(pi=false) (fmt:Format.formatter) h = + let to_smt_named ?(debug=false) ?pi:(pi=false) (fmt:Format.formatter) h = let rec to_smt fmt h = if pi then Format.fprintf fmt "%d:" (index h); - to_smt_atom (atom h) + to_smt_atom ~debug:debug (atom h) - and to_smt_atom = function - | Acop (CO_BV bv) -> if List.length bv = 0 then Structures.error "Empty bit-vectors are not valid in SMT" else Format.fprintf fmt "#b%a" bv_to_smt bv + and to_smt_atom ?(debug=false) = function + | Acop (CO_BV bv) -> if List.length bv = 0 then CoqInterface.error "Empty bit-vectors are not valid in SMT" else Format.fprintf fmt "#b%a" bv_to_smt bv | Acop _ as a -> to_smt_int fmt (compute_int a) | Auop (op,h) -> to_smt_uop op h | Abop (op,h1,h2) -> to_smt_bop op h1 h2 @@ -722,7 +722,9 @@ module Atom = | Aapp ((i,op),a) -> let op_smt () = (match i with - | Index index -> Format.fprintf fmt "op_%i" index + | Index index -> + (Format.fprintf fmt "op_%i" index; + if debug then Format.fprintf fmt " (aka %s)" (Pp.string_of_ppcmds (CoqInterface.pr_constr op.op_val));) | Rel_name name -> Format.fprintf fmt "%s" name); if pi then to_smt_op op in @@ -740,7 +742,7 @@ module Atom = Array.iter (fun bt -> SmtBtype.to_smt fmt bt; Format.fprintf fmt " ") bta; Format.fprintf fmt ") ( "; SmtBtype.to_smt fmt bt; - Format.fprintf fmt " ) ( %s )]" (Pp.string_of_ppcmds (Structures.pr_constr t)) + Format.fprintf fmt " ) ( %s )]" (Pp.string_of_ppcmds (CoqInterface.pr_constr t)) and to_smt_uop op h = match op with @@ -805,7 +807,7 @@ module Atom = in to_smt fmt h - let to_smt (fmt:Format.formatter) h = to_smt_named fmt h + let to_smt ?(debug=false) (fmt:Format.formatter) h = to_smt_named ~debug:debug fmt h type reify_tbl = @@ -855,7 +857,7 @@ module Atom = else ( Format.eprintf "Incorrect type: wanted %a, got %a@." SmtBtype.to_smt t SmtBtype.to_smt th; - failwith (Format.asprintf "Atom %a is not of the expected type" to_smt h) + failwith (Format.asprintf "Atom %a is not of the expected type" (to_smt ~debug:true) h) ) in @@ -1107,8 +1109,8 @@ module Atom = else CCunknown_deps (gobble_of_coq_cst cc) with Not_found -> CCunknown in - let rec mk_hatom (h : Structures.constr) = - let c, args = Structures.decompose_app h in + let rec mk_hatom (h : CoqInterface.constr) = + let c, args = CoqInterface.decompose_app h in match get_cst c with | CCxH -> mk_cop CCxH args | CCZ0 -> mk_cop CCZ0 args @@ -1150,9 +1152,9 @@ module Atom = | CCselect -> mk_bop_select args | CCdiff -> mk_bop_diff args | CCstore -> mk_top_store args - | CCunknown -> mk_unknown c args (Structures.retyping_get_type_of env sigma h) + | CCunknown -> mk_unknown c args (CoqInterface.retyping_get_type_of env sigma h) | CCunknown_deps gobble -> - mk_unknown_deps c args (Structures.retyping_get_type_of env sigma h) gobble + mk_unknown_deps c args (CoqInterface.retyping_get_type_of env sigma h) gobble and mk_cop op args = match op, args with @@ -1346,10 +1348,10 @@ module Atom = let (l1, l2) = collect_types xs in match l1 with | [] -> - let ty = Structures.retyping_get_type_of env sigma x in + let ty = CoqInterface.retyping_get_type_of env sigma x in if Constr.iskind ty || - let c, _ = Structures.decompose_app ty in - Structures.eq_constr c (Lazy.force cCompDec) + let c, _ = CoqInterface.decompose_app ty in + CoqInterface.eq_constr c (Lazy.force cCompDec) then ([x], xs) else @@ -1368,10 +1370,10 @@ module Atom = with | Not_found -> let targs = Array.map type_of hargs in let tres = SmtBtype.of_coq rt known_logic ty in - let os = if Structures.isRel c then - let i = Structures.destRel c in - let n, _ = Structures.destruct_rel_decl (Environ.lookup_rel i env) in - Some (Structures.string_of_name n) + let os = if CoqInterface.isRel c then + let i = CoqInterface.destRel c in + let n, _ = CoqInterface.destruct_rel_decl (Environ.lookup_rel i env) in + Some (CoqInterface.string_of_name n) else if Vars.closed0 c then None else @@ -1394,7 +1396,7 @@ module Atom = [gobble] *) and mk_unknown_deps c args ty gobble = let deps, args = split_list_at gobble args in - let c = Structures.mkApp (c, Array.of_list deps) in + let c = CoqInterface.mkApp (c, Array.of_list deps) in mk_unknown c args ty in @@ -1435,7 +1437,7 @@ module Atom = let interp_tbl reify = let t = to_array reify (Lazy.force dft_atom) a_to_coq in - Structures.mkArray (Lazy.force catom, t) + CoqTerms.mkArray (Lazy.force catom, t) (** Producing a Coq term corresponding to the interpretation of an atom *) @@ -1447,12 +1449,12 @@ module Atom = let pc = match atom a with | Acop c -> Op.interp_cop c - | Auop (op,h) -> Structures.mkApp (Op.interp_uop op, [|interp_atom h|]) + | Auop (op,h) -> CoqInterface.mkApp (Op.interp_uop op, [|interp_atom h|]) | Abop (op,h1,h2) -> - Structures.mkApp (Op.interp_bop t_i op, + CoqInterface.mkApp (Op.interp_bop t_i op, [|interp_atom h1; interp_atom h2|]) | Atop (op,h1,h2,h3) -> - Structures.mkApp (Op.interp_top t_i op, + CoqInterface.mkApp (Op.interp_top t_i op, [|interp_atom h1; interp_atom h2; interp_atom h3|]) | Anop (NO_distinct ty as op,ha) -> let cop = Op.interp_nop t_i op in @@ -1460,9 +1462,9 @@ module Atom = let cargs = Array.fold_right (fun h l -> mklApp ccons [|typ; interp_atom h; l|]) ha (mklApp cnil [|typ|]) in - Structures.mkApp (cop,[|cargs|]) + CoqInterface.mkApp (cop,[|cargs|]) | Aapp (op,t) -> - Structures.mkApp ((snd op).op_val, Array.map interp_atom t) in + CoqInterface.mkApp ((snd op).op_val, Array.map interp_atom t) in Hashtbl.add atom_tbl l pc; pc in interp_atom a diff --git a/src/trace/smtAtom.mli b/src/trace/smtAtom.mli index b430d6f..57992d2 100644 --- a/src/trace/smtAtom.mli +++ b/src/trace/smtAtom.mli @@ -76,14 +76,14 @@ module Op : val create : unit -> reify_tbl - val declare : reify_tbl -> Structures.constr -> btype array -> + val declare : reify_tbl -> CoqInterface.constr -> btype array -> btype -> string option -> indexed_op - val of_coq : reify_tbl -> Structures.constr -> indexed_op + val of_coq : reify_tbl -> CoqInterface.constr -> indexed_op - val interp_tbl : Structures.constr -> - (btype array -> btype -> Structures.constr -> Structures.constr) -> - reify_tbl -> Structures.constr + val interp_tbl : CoqInterface.constr -> + (btype array -> btype -> CoqInterface.constr -> CoqInterface.constr) -> + reify_tbl -> CoqInterface.constr val to_list : reify_tbl -> (int * (btype array) * btype * indexed_op) list @@ -119,7 +119,7 @@ module Atom : val type_of : t -> btype - val to_smt : Format.formatter -> t -> unit + val to_smt : ?debug:bool -> Format.formatter -> t -> unit type reify_tbl @@ -142,18 +142,18 @@ module Atom : (** Given a coq term, build the corresponding atom *) exception UnknownUnderForall val of_coq : ?eqsym:bool -> SmtBtype.reify_tbl -> Op.reify_tbl -> - reify_tbl -> SmtMisc.logic -> Environ.env -> Evd.evar_map -> Structures.constr -> t + reify_tbl -> SmtMisc.logic -> Environ.env -> Evd.evar_map -> CoqInterface.constr -> t - val get_coq_term_op : int -> Structures.constr + val get_coq_term_op : int -> CoqInterface.constr - val to_coq : t -> Structures.constr + val to_coq : t -> CoqInterface.constr val to_array : reify_tbl -> 'a -> (atom -> 'a) -> 'a array - val interp_tbl : reify_tbl -> Structures.constr + val interp_tbl : reify_tbl -> CoqInterface.constr - val interp_to_coq : Structures.constr -> (int, Structures.constr) Hashtbl.t -> - t -> Structures.constr + val interp_to_coq : CoqInterface.constr -> (int, CoqInterface.constr) Hashtbl.t -> + t -> CoqInterface.constr val logic : t -> SmtMisc.logic @@ -201,5 +201,5 @@ module Trace : sig end -val make_t_i : SmtBtype.reify_tbl -> Structures.constr -val make_t_func : Op.reify_tbl -> Structures.constr -> Structures.constr +val make_t_i : SmtBtype.reify_tbl -> CoqInterface.constr +val make_t_func : Op.reify_tbl -> CoqInterface.constr -> CoqInterface.constr diff --git a/src/trace/smtBtype.ml b/src/trace/smtBtype.ml index 71f7c14..fa3ed5f 100644 --- a/src/trace/smtBtype.ml +++ b/src/trace/smtBtype.ml @@ -19,7 +19,7 @@ type uninterpreted_type = (* Uninterpreted type for which a CompDec is already known The constr is of type typ_compdec *) - | CompDec of Structures.constr + | CompDec of CoqInterface.constr (* Uninterpreted type for which the knowledge of a CompDec is delayed until either: - one is used @@ -27,11 +27,11 @@ type uninterpreted_type = via a cut The constr is of type Type *) - | Delayed of Structures.constr + | Delayed of CoqInterface.constr type indexed_type = uninterpreted_type gen_hashed -let dummy_indexed_type i = {index = i; hval = Delayed (Structures.mkProp)} +let dummy_indexed_type i = {index = i; hval = Delayed (CoqInterface.mkProp)} let indexed_type_index i = i.index let indexed_type_compdec i = match i.hval with @@ -51,7 +51,7 @@ let index_tbl = Hashtbl.create 17 let index_to_coq i = try Hashtbl.find index_tbl i with Not_found -> - let interp = mklApp cTindex [|mkInt i|] in + let interp = mklApp cTindex [|mkN i|] in Hashtbl.add index_tbl i interp; interp @@ -105,8 +105,8 @@ let rec logic = function (* reify table *) type reify_tbl = { mutable count : int; - tbl : (Structures.constr, btype) Hashtbl.t; - mutable cuts : (Structures.id * Structures.types) list; + tbl : (CoqInterface.constr, btype) Hashtbl.t; + mutable cuts : (CoqInterface.id * CoqInterface.types) list; unsup_tbl : (btype, btype) Hashtbl.t; } @@ -145,8 +145,8 @@ let interp_tbl reify = | CompDec compdec -> t.(it.index) <- compdec; Some bt | Delayed ty -> let n = string_of_int (List.length reify.cuts) in - let compdec_name = Structures.mkId ("CompDec"^n) in - let compdec_var = Structures.mkVar compdec_name in + let compdec_name = CoqInterface.mkId ("CompDec"^n) in + let compdec_var = CoqInterface.mkVar compdec_name in let compdec_type = mklApp cCompDec [| ty |] in reify.cuts <- (compdec_name, compdec_type) :: reify.cuts; let ce = mklApp cTyp_compdec [|ty; compdec_var|] in @@ -156,7 +156,7 @@ let interp_tbl reify = | _ -> Some bt in Hashtbl.filter_map_inplace set reify.tbl; - Structures.mkArray (Lazy.force ctyp_compdec, t) + CoqTerms.mkArray (Lazy.force ctyp_compdec, t) let to_list reify = @@ -241,8 +241,8 @@ let rec compdec_btype reify = function | Tindex i -> (match i.hval with | CompDec compdec -> - let c, args = Structures.decompose_app compdec in - if Structures.eq_constr c (Lazy.force cTyp_compdec) then + let c, args = CoqInterface.decompose_app compdec in + if CoqInterface.eq_constr c (Lazy.force cTyp_compdec) then match args with | [_; tic] -> tic | _ -> assert false @@ -264,22 +264,22 @@ let declare_and_compdec reify t ty = let rec of_coq reify known_logic t = try - let c, args = Structures.decompose_app t in - if Structures.eq_constr c (Lazy.force cbool) || - Structures.eq_constr c (Lazy.force cTbool) then Tbool - else if Structures.eq_constr c (Lazy.force cZ) || - Structures.eq_constr c (Lazy.force cTZ) then + let c, args = CoqInterface.decompose_app t in + if CoqInterface.eq_constr c (Lazy.force cbool) || + CoqInterface.eq_constr c (Lazy.force cTbool) then Tbool + else if CoqInterface.eq_constr c (Lazy.force cZ) || + CoqInterface.eq_constr c (Lazy.force cTZ) then check_known TZ known_logic - else if Structures.eq_constr c (Lazy.force cpositive) || - Structures.eq_constr c (Lazy.force cTpositive) then + else if CoqInterface.eq_constr c (Lazy.force cpositive) || + CoqInterface.eq_constr c (Lazy.force cTpositive) then check_known Tpositive known_logic - else if Structures.eq_constr c (Lazy.force cbitvector) || - Structures.eq_constr c (Lazy.force cTBV) then + else if CoqInterface.eq_constr c (Lazy.force cbitvector) || + CoqInterface.eq_constr c (Lazy.force cTBV) then match args with | [s] -> check_known (TBV (mk_bvsize s)) known_logic | _ -> assert false - else if Structures.eq_constr c (Lazy.force cfarray) || - Structures.eq_constr c (Lazy.force cTFArray) then + else if CoqInterface.eq_constr c (Lazy.force cfarray) || + CoqInterface.eq_constr c (Lazy.force cTFArray) then match args with | ti :: te :: _ -> let ty = TFArray (of_coq reify known_logic ti, diff --git a/src/trace/smtBtype.mli b/src/trace/smtBtype.mli index 05a8486..9503645 100644 --- a/src/trace/smtBtype.mli +++ b/src/trace/smtBtype.mli @@ -17,7 +17,7 @@ type indexed_type val dummy_indexed_type: int -> indexed_type val indexed_type_index : indexed_type -> int -val indexed_type_compdec : indexed_type -> Structures.constr +val indexed_type_compdec : indexed_type -> CoqInterface.constr type btype = | TZ @@ -31,7 +31,7 @@ val indexed_type_of_int : int -> indexed_type module HashedBtype : Hashtbl.HashedType with type t = btype -val to_coq : btype -> Structures.constr +val to_coq : btype -> CoqInterface.constr val to_smt : Format.formatter -> btype -> unit @@ -40,25 +40,25 @@ type reify_tbl val create : unit -> reify_tbl val copy : reify_tbl -> reify_tbl -val of_coq : reify_tbl -> logic -> Structures.constr -> btype -val of_coq_compdec : reify_tbl -> Structures.constr -> Structures.constr -> btype +val of_coq : reify_tbl -> logic -> CoqInterface.constr -> btype +val of_coq_compdec : reify_tbl -> CoqInterface.constr -> CoqInterface.constr -> btype -val get_coq_type_op : int -> Structures.constr +val get_coq_type_op : int -> CoqInterface.constr -val interp_tbl : reify_tbl -> Structures.constr +val interp_tbl : reify_tbl -> CoqInterface.constr val to_list : reify_tbl -> (int * indexed_type) list -val make_t_i : reify_tbl -> Structures.constr +val make_t_i : reify_tbl -> CoqInterface.constr -val dec_interp : Structures.constr -> btype -> Structures.constr -val ord_interp : Structures.constr -> btype -> Structures.constr -val comp_interp : Structures.constr -> btype -> Structures.constr -val inh_interp : Structures.constr -> btype -> Structures.constr -val interp : Structures.constr -> btype -> Structures.constr +val dec_interp : CoqInterface.constr -> btype -> CoqInterface.constr +val ord_interp : CoqInterface.constr -> btype -> CoqInterface.constr +val comp_interp : CoqInterface.constr -> btype -> CoqInterface.constr +val inh_interp : CoqInterface.constr -> btype -> CoqInterface.constr +val interp : CoqInterface.constr -> btype -> CoqInterface.constr -val interp_to_coq : reify_tbl -> btype -> Structures.constr +val interp_to_coq : reify_tbl -> btype -> CoqInterface.constr -val get_cuts : reify_tbl -> (Structures.id * Structures.types) list +val get_cuts : reify_tbl -> (CoqInterface.id * CoqInterface.types) list val logic : btype -> logic diff --git a/src/trace/smtCertif.ml b/src/trace/smtCertif.ml index 33437bf..3264d9e 100644 --- a/src/trace/smtCertif.ml +++ b/src/trace/smtCertif.ml @@ -98,11 +98,11 @@ type 'hform rule = *) (* Linear arithmetic *) - | LiaMicromega of 'hform list * Structures.Micromega_plugin_Certificate.Mc.zArithProof list + | LiaMicromega of 'hform list * CoqInterface.Micromega_plugin_Certificate.Mc.zArithProof list | LiaDiseq of 'hform (* Arithmetic simplifications *) - | SplArith of 'hform clause * 'hform * Structures.Micromega_plugin_Certificate.Mc.zArithProof list + | SplArith of 'hform clause * 'hform * CoqInterface.Micromega_plugin_Certificate.Mc.zArithProof list (* Elimination of operators *) | SplDistinctElim of 'hform clause * 'hform diff --git a/src/trace/smtCertif.mli b/src/trace/smtCertif.mli index ef25b1f..999131c 100644 --- a/src/trace/smtCertif.mli +++ b/src/trace/smtCertif.mli @@ -96,11 +96,11 @@ type 'hform rule = *) (* Linear arithmetic *) - | LiaMicromega of 'hform list * Structures.Micromega_plugin_Certificate.Mc.zArithProof list + | LiaMicromega of 'hform list * CoqInterface.Micromega_plugin_Certificate.Mc.zArithProof list | LiaDiseq of 'hform (* Arithmetic simplifications *) - | SplArith of 'hform clause * 'hform * Structures.Micromega_plugin_Certificate.Mc.zArithProof list + | SplArith of 'hform clause * 'hform * CoqInterface.Micromega_plugin_Certificate.Mc.zArithProof list (* Elimination of operators *) | SplDistinctElim of 'hform clause * 'hform diff --git a/src/trace/smtCommands.ml b/src/trace/smtCommands.ml index d15ae68..2108da4 100644 --- a/src/trace/smtCommands.ml +++ b/src/trace/smtCommands.ml @@ -18,65 +18,57 @@ open SmtTrace open SmtCertif -let euf_checker_modules = [ ["SMTCoq";"Trace";"Euf_Checker"] ] -let certif_ops args = CoqTerms.make_certif_ops euf_checker_modules args -let cCertif = gen_constant euf_checker_modules "Certif" -let ccertif = gen_constant euf_checker_modules "certif" -let cchecker = gen_constant euf_checker_modules "checker" -let cchecker_correct = gen_constant euf_checker_modules "checker_correct" -let cchecker_b_correct = - gen_constant euf_checker_modules "checker_b_correct" -let cchecker_b = gen_constant euf_checker_modules "checker_b" -let cchecker_eq_correct = - gen_constant euf_checker_modules "checker_eq_correct" -let cchecker_eq = gen_constant euf_checker_modules "checker_eq" -(* let csetup_checker_step_debug = - * gen_constant euf_checker_modules "setup_checker_step_debug" *) -(* let cchecker_step_debug = gen_constant euf_checker_modules "checker_step_debug" *) -(* let cstep = gen_constant euf_checker_modules "step" *) -let cchecker_debug = gen_constant euf_checker_modules "checker_debug" - -let cname_step = gen_constant euf_checker_modules "name_step" - -let cName_Res = gen_constant euf_checker_modules "Name_Res" -let cName_Weaken= gen_constant euf_checker_modules "Name_Weaken" -let cName_ImmFlatten= gen_constant euf_checker_modules "Name_ImmFlatten" -let cName_CTrue= gen_constant euf_checker_modules "Name_CTrue" -let cName_CFalse = gen_constant euf_checker_modules "Name_CFalse" -let cName_BuildDef= gen_constant euf_checker_modules "Name_BuildDef" -let cName_BuildDef2= gen_constant euf_checker_modules "Name_BuildDef2" -let cName_BuildProj = gen_constant euf_checker_modules "Name_BuildProj" -let cName_ImmBuildDef= gen_constant euf_checker_modules "Name_ImmBuildDef" -let cName_ImmBuildDef2= gen_constant euf_checker_modules "Name_ImmBuildDef2" -let cName_ImmBuildProj = gen_constant euf_checker_modules "Name_ImmBuildProj" -let cName_EqTr = gen_constant euf_checker_modules "Name_EqTr" -let cName_EqCgr = gen_constant euf_checker_modules "Name_EqCgr" -let cName_EqCgrP= gen_constant euf_checker_modules "Name_EqCgrP" -let cName_LiaMicromega = gen_constant euf_checker_modules "Name_LiaMicromega" -let cName_LiaDiseq= gen_constant euf_checker_modules "Name_LiaDiseq" -let cName_SplArith= gen_constant euf_checker_modules "Name_SplArith" -let cName_SplDistinctElim = gen_constant euf_checker_modules "Name_SplDistinctElim" -let cName_BBVar= gen_constant euf_checker_modules "Name_BBVar" -let cName_BBConst= gen_constant euf_checker_modules "Name_BBConst" -let cName_BBOp= gen_constant euf_checker_modules "Name_BBOp" -let cName_BBNot= gen_constant euf_checker_modules "Name_BBNot" -let cName_BBNeg= gen_constant euf_checker_modules "Name_BBNeg" -let cName_BBAdd= gen_constant euf_checker_modules "Name_BBAdd" -let cName_BBConcat= gen_constant euf_checker_modules "Name_BBConcat" -let cName_BBMul= gen_constant euf_checker_modules "Name_BBMul" -let cName_BBUlt= gen_constant euf_checker_modules "Name_BBUlt" -let cName_BBSlt= gen_constant euf_checker_modules "Name_BBSlt" -let cName_BBEq= gen_constant euf_checker_modules "Name_BBEq" -let cName_BBDiseq= gen_constant euf_checker_modules "Name_BBDiseq" -let cName_BBExtract= gen_constant euf_checker_modules "Name_BBExtract" -let cName_BBZextend= gen_constant euf_checker_modules "Name_BBZextend" -let cName_BBSextend= gen_constant euf_checker_modules "Name_BBSextend" -let cName_BBShl= gen_constant euf_checker_modules "Name_BBShl" -let cName_BBShr= gen_constant euf_checker_modules "Name_BBShr" -let cName_RowEq= gen_constant euf_checker_modules "Name_RowEq" -let cName_RowNeq= gen_constant euf_checker_modules "Name_RowNeq" -let cName_Ext= gen_constant euf_checker_modules "Name_Ext" -let cName_Hole= gen_constant euf_checker_modules "Name_Hole" +let certif_ops = CoqTerms.ceuf_checker_certif_ops +let cCertif = CoqTerms.ceuf_checker_Certif +let ccertif = CoqTerms.ceuf_checker_certif +let cchecker = CoqTerms.ceuf_checker_checker +let cchecker_correct = CoqTerms.ceuf_checker_checker_correct +let cchecker_b_correct = CoqTerms.ceuf_checker_checker_b_correct +let cchecker_b = CoqTerms.ceuf_checker_checker_b +let cchecker_eq_correct = CoqTerms.ceuf_checker_checker_eq_correct +let cchecker_eq = CoqTerms.ceuf_checker_checker_eq +let cchecker_debug = CoqTerms.ceuf_checker_checker_debug +let cname_step = CoqTerms.ceuf_checker_name_step +let cName_Res = CoqTerms.ceuf_checker_Name_Res +let cName_Weaken = CoqTerms.ceuf_checker_Name_Weaken +let cName_ImmFlatten = CoqTerms.ceuf_checker_Name_ImmFlatten +let cName_CTrue = CoqTerms.ceuf_checker_Name_CTrue +let cName_CFalse = CoqTerms.ceuf_checker_Name_CFalse +let cName_BuildDef = CoqTerms.ceuf_checker_Name_BuildDef +let cName_BuildDef2 = CoqTerms.ceuf_checker_Name_BuildDef2 +let cName_BuildProj = CoqTerms.ceuf_checker_Name_BuildProj +let cName_ImmBuildDef = CoqTerms.ceuf_checker_Name_ImmBuildDef +let cName_ImmBuildDef2 = CoqTerms.ceuf_checker_Name_ImmBuildDef2 +let cName_ImmBuildProj = CoqTerms.ceuf_checker_Name_ImmBuildProj +let cName_EqTr = CoqTerms.ceuf_checker_Name_EqTr +let cName_EqCgr = CoqTerms.ceuf_checker_Name_EqCgr +let cName_EqCgrP = CoqTerms.ceuf_checker_Name_EqCgrP +let cName_LiaMicromega = CoqTerms.ceuf_checker_Name_LiaMicromega +let cName_LiaDiseq = CoqTerms.ceuf_checker_Name_LiaDiseq +let cName_SplArith = CoqTerms.ceuf_checker_Name_SplArith +let cName_SplDistinctElim = CoqTerms.ceuf_checker_Name_SplDistinctElim +let cName_BBVar = CoqTerms.ceuf_checker_Name_BBVar +let cName_BBConst = CoqTerms.ceuf_checker_Name_BBConst +let cName_BBOp = CoqTerms.ceuf_checker_Name_BBOp +let cName_BBNot = CoqTerms.ceuf_checker_Name_BBNot +let cName_BBNeg = CoqTerms.ceuf_checker_Name_BBNeg +let cName_BBAdd = CoqTerms.ceuf_checker_Name_BBAdd +let cName_BBConcat = CoqTerms.ceuf_checker_Name_BBConcat +let cName_BBMul = CoqTerms.ceuf_checker_Name_BBMul +let cName_BBUlt = CoqTerms.ceuf_checker_Name_BBUlt +let cName_BBSlt = CoqTerms.ceuf_checker_Name_BBSlt +let cName_BBEq = CoqTerms.ceuf_checker_Name_BBEq +let cName_BBDiseq = CoqTerms.ceuf_checker_Name_BBDiseq +let cName_BBExtract = CoqTerms.ceuf_checker_Name_BBExtract +let cName_BBZextend = CoqTerms.ceuf_checker_Name_BBZextend +let cName_BBSextend = CoqTerms.ceuf_checker_Name_BBSextend +let cName_BBShl = CoqTerms.ceuf_checker_Name_BBShl +let cName_BBShr = CoqTerms.ceuf_checker_Name_BBShr +let cName_RowEq = CoqTerms.ceuf_checker_Name_RowEq +let cName_RowNeq = CoqTerms.ceuf_checker_Name_RowNeq +let cName_Ext = CoqTerms.ceuf_checker_Name_Ext +let cName_Hole = CoqTerms.ceuf_checker_Name_Hole + (* Given an SMT-LIB2 file and a certif, build the corresponding objects *) @@ -115,7 +107,7 @@ let interp_conseq_uf t_i (prem, concl) = let tf = Hashtbl.create 17 in let rec interp = function | [] -> mklApp cis_true [|interp_uf t_i ta tf concl|] - | c::prem -> Term.mkArrow (mklApp cis_true [|interp_uf t_i ta tf c|]) (interp prem) in + | c::prem -> CoqInterface.mkArrow (mklApp cis_true [|interp_uf t_i ta tf c|]) (interp prem) in interp prem @@ -127,26 +119,26 @@ let print_assm ty = let parse_certif t_i t_func t_atom t_form root used_root trace (rt, ro, ra, rf, roots, max_id, confl) = let t_i' = make_t_i rt in - let ce5 = Structures.mkUConst t_i' in - let ct_i = Structures.mkConst (Structures.declare_constant t_i ce5) in + let ce5 = CoqInterface.mkUConst t_i' in + let ct_i = CoqInterface.mkConst (CoqInterface.declare_constant t_i ce5) in let t_func' = make_t_func ro ct_i in - let ce6 = Structures.mkUConst t_func' in - let ct_func = Structures.mkConst (Structures.declare_constant t_func ce6) in + let ce6 = CoqInterface.mkUConst t_func' in + let ct_func = CoqInterface.mkConst (CoqInterface.declare_constant t_func ce6) in let t_atom' = Atom.interp_tbl ra in - let ce1 = Structures.mkUConst t_atom' in - let ct_atom = Structures.mkConst (Structures.declare_constant t_atom ce1) in + let ce1 = CoqInterface.mkUConst t_atom' in + let ct_atom = CoqInterface.mkConst (CoqInterface.declare_constant t_atom ce1) in let t_form' = snd (Form.interp_tbl rf) in - let ce2 = Structures.mkUConst t_form' in - let ct_form = Structures.mkConst (Structures.declare_constant t_form ce2) in + let ce2 = CoqInterface.mkUConst t_form' in + let ct_form = CoqInterface.mkConst (CoqInterface.declare_constant t_form ce2) in (* EMPTY LEMMA LIST *) let (tres, last_root, cuts) = SmtTrace.to_coq (fun i -> mkInt (Form.to_lit i)) (interp_conseq_uf ct_i) (certif_ops (Some [|ct_i; ct_func; ct_atom; ct_form|])) confl None in List.iter (fun (v,ty) -> - let _ = Structures.declare_new_variable v ty in + let _ = CoqInterface.declare_new_variable v ty in print_assm ty ) cuts; @@ -155,22 +147,22 @@ let parse_certif t_i t_func t_atom t_form root used_root trace (rt, ro, ra, rf, let res = Array.make (List.length roots + 1) (mkInt 0) in let i = ref 0 in List.iter (fun j -> res.(!i) <- mkInt (Form.to_lit j); incr i) roots; - Structures.mkArray (Lazy.force cint, res) in + CoqTerms.mkArray (Lazy.force cint, res) in let used_roots = let l = List.length used_roots in let res = Array.make (l + 1) (mkInt 0) in let i = ref (l-1) in List.iter (fun j -> res.(!i) <- mkInt j; decr i) used_roots; - mklApp cSome [|mklApp carray [|Lazy.force cint|]; Structures.mkArray (Lazy.force cint, res)|] in - let ce3 = Structures.mkUConst roots in - let _ = Structures.declare_constant root ce3 in - let ce3' = Structures.mkUConst used_roots in - let _ = Structures.declare_constant used_root ce3' in + mklApp cSome [|mklApp carray [|Lazy.force cint|]; CoqTerms.mkArray (Lazy.force cint, res)|] in + let ce3 = CoqInterface.mkUConst roots in + let _ = CoqInterface.declare_constant root ce3 in + let ce3' = CoqInterface.mkUConst used_roots in + let _ = CoqInterface.declare_constant used_root ce3' in let certif = mklApp cCertif [|ct_i; ct_func; ct_atom; ct_form; mkInt (max_id + 1); tres;mkInt (get_pos confl)|] in - let ce4 = Structures.mkUConst certif in - let _ = Structures.declare_constant trace ce4 in + let ce4 = CoqInterface.mkUConst certif in + let _ = CoqInterface.declare_constant trace ce4 in () @@ -184,15 +176,15 @@ let interp_roots t_i roots = | f::roots -> List.fold_left (fun acc f -> mklApp candb [|acc; interp f|]) (interp f) roots let theorem name (rt, ro, ra, rf, roots, max_id, confl) = - let nti = Structures.mkName "t_i" in - let ntfunc = Structures.mkName "t_func" in - let ntatom = Structures.mkName "t_atom" in - let ntform = Structures.mkName "t_form" in - let nc = Structures.mkName "c" in - let nused_roots = Structures.mkName "used_roots" in - let nd = Structures.mkName "d" in + let nti = CoqInterface.mkName "t_i" in + let ntfunc = CoqInterface.mkName "t_func" in + let ntatom = CoqInterface.mkName "t_atom" in + let ntform = CoqInterface.mkName "t_form" in + let nc = CoqInterface.mkName "c" in + let nused_roots = CoqInterface.mkName "used_roots" in + let nd = CoqInterface.mkName "d" in - let v = Structures.mkRel in + let v = CoqInterface.mkRel in let t_i = make_t_i rt in let t_func = make_t_func ro (v 1 (*t_i*)) in @@ -204,7 +196,7 @@ let theorem name (rt, ro, ra, rf, roots, max_id, confl) = (interp_conseq_uf t_i) (certif_ops (Some [|v 4(*t_i*); v 3(*t_func*); v 2(*t_atom*); v 1(* t_form *)|])) confl None in List.iter (fun (v,ty) -> - let _ = Structures.declare_new_variable v ty in + let _ = CoqInterface.declare_new_variable v ty in print_assm ty ) cuts; @@ -217,59 +209,59 @@ let theorem name (rt, ro, ra, rf, roots, max_id, confl) = let res = Array.make (l + 1) (mkInt 0) in let i = ref (l-1) in List.iter (fun j -> res.(!i) <- mkInt j; decr i) used_roots; - mklApp cSome [|mklApp carray [|Lazy.force cint|]; Structures.mkArray (Lazy.force cint, res)|] in + mklApp cSome [|mklApp carray [|Lazy.force cint|]; CoqTerms.mkArray (Lazy.force cint, res)|] in let rootsCstr = let res = Array.make (List.length roots + 1) (mkInt 0) in let i = ref 0 in List.iter (fun j -> res.(!i) <- mkInt (Form.to_lit j); incr i) roots; - Structures.mkArray (Lazy.force cint, res) in + CoqTerms.mkArray (Lazy.force cint, res) in let theorem_concl = mklApp cnot [|mklApp cis_true [|interp_roots t_i roots|]|] in let theorem_proof_cast = - Structures.mkCast ( - Structures.mkLetIn (nti, t_i, mklApp carray [|Lazy.force ctyp_compdec|], - Structures.mkLetIn (ntfunc, t_func, mklApp carray [|mklApp ctval [|v 1(* t_i *)|]|], - Structures.mkLetIn (ntatom, t_atom, mklApp carray [|Lazy.force catom|], - Structures.mkLetIn (ntform, t_form, mklApp carray [|Lazy.force cform|], - Structures.mkLetIn (nc, certif, mklApp ccertif [|v 4 (*t_i*); v 3 (*t_func*); v 2 (*t_atom*); v 1 (*t_form*)|], - Structures.mkLetIn (nused_roots, used_rootsCstr, mklApp coption [|mklApp carray [|Lazy.force cint|]|], - Structures.mkLetIn (nd, rootsCstr, mklApp carray [|Lazy.force cint|], + CoqInterface.mkCast ( + CoqInterface.mkLetIn (nti, t_i, mklApp carray [|Lazy.force ctyp_compdec|], + CoqInterface.mkLetIn (ntfunc, t_func, mklApp carray [|mklApp ctval [|v 1(* t_i *)|]|], + CoqInterface.mkLetIn (ntatom, t_atom, mklApp carray [|Lazy.force catom|], + CoqInterface.mkLetIn (ntform, t_form, mklApp carray [|Lazy.force cform|], + CoqInterface.mkLetIn (nc, certif, mklApp ccertif [|v 4 (*t_i*); v 3 (*t_func*); v 2 (*t_atom*); v 1 (*t_form*)|], + CoqInterface.mkLetIn (nused_roots, used_rootsCstr, mklApp coption [|mklApp carray [|Lazy.force cint|]|], + CoqInterface.mkLetIn (nd, rootsCstr, mklApp carray [|Lazy.force cint|], mklApp cchecker_correct [|v 7 (*t_i*); v 6 (*t_func*); v 5 (*t_atom*); v 4 (*t_form*); v 1 (*d*); v 2 (*used_roots*); v 3 (*c*); vm_cast_true_no_check (mklApp cchecker [|v 7 (*t_i*); v 6 (*t_func*); v 5 (*t_atom*); v 4 (*t_form*); v 1 (*d*); v 2 (*used_roots*); v 3 (*c*)|])|]))))))), - Structures.vmcast, + CoqInterface.vmcast, theorem_concl) in let theorem_proof_nocast = - Structures.mkLetIn (nti, t_i, mklApp carray [|Lazy.force ctyp_compdec|], - Structures.mkLetIn (ntfunc, t_func, mklApp carray [|mklApp ctval [|v 1(* t_i *)|]|], - Structures.mkLetIn (ntatom, t_atom, mklApp carray [|Lazy.force catom|], - Structures.mkLetIn (ntform, t_form, mklApp carray [|Lazy.force cform|], - Structures.mkLetIn (nc, certif, mklApp ccertif [|v 4 (*t_i*); v 3 (*t_func*); v 2 (*t_atom*); v 1 (*t_form*)|], - Structures.mkLetIn (nused_roots, used_rootsCstr, mklApp coption [|mklApp carray [|Lazy.force cint|]|], - Structures.mkLetIn (nd, rootsCstr, mklApp carray [|Lazy.force cint|], + CoqInterface.mkLetIn (nti, t_i, mklApp carray [|Lazy.force ctyp_compdec|], + CoqInterface.mkLetIn (ntfunc, t_func, mklApp carray [|mklApp ctval [|v 1(* t_i *)|]|], + CoqInterface.mkLetIn (ntatom, t_atom, mklApp carray [|Lazy.force catom|], + CoqInterface.mkLetIn (ntform, t_form, mklApp carray [|Lazy.force cform|], + CoqInterface.mkLetIn (nc, certif, mklApp ccertif [|v 4 (*t_i*); v 3 (*t_func*); v 2 (*t_atom*); v 1 (*t_form*)|], + CoqInterface.mkLetIn (nused_roots, used_rootsCstr, mklApp coption [|mklApp carray [|Lazy.force cint|]|], + CoqInterface.mkLetIn (nd, rootsCstr, mklApp carray [|Lazy.force cint|], mklApp cchecker_correct [|v 7 (*t_i*); v 6 (*t_func*); v 5 (*t_atom*); v 4 (*t_form*); v 1 (*d*); v 2 (*used_roots*); v 3 (*c*)|]))))))) in - let ce = Structures.mkTConst theorem_proof_cast theorem_proof_nocast theorem_concl in - let _ = Structures.declare_constant name ce in + let ce = CoqInterface.mkTConst theorem_proof_cast theorem_proof_nocast theorem_concl in + let _ = CoqInterface.declare_constant name ce in () (* Given an SMT-LIB2 file and a certif, call the checker *) let checker (rt, ro, ra, rf, roots, max_id, confl) = - let nti = Structures.mkName "t_i" in - let ntfunc = Structures.mkName "t_func" in - let ntatom = Structures.mkName "t_atom" in - let ntform = Structures.mkName "t_form" in - let nc = Structures.mkName "c" in - let nused_roots = Structures.mkName "used_roots" in - let nd = Structures.mkName "d" in + let nti = CoqInterface.mkName "t_i" in + let ntfunc = CoqInterface.mkName "t_func" in + let ntatom = CoqInterface.mkName "t_atom" in + let ntform = CoqInterface.mkName "t_form" in + let nc = CoqInterface.mkName "c" in + let nused_roots = CoqInterface.mkName "used_roots" in + let nd = CoqInterface.mkName "d" in - let v = Structures.mkRel in + let v = CoqInterface.mkRel in let t_i = make_t_i rt in let t_func = make_t_func ro (v 1 (*t_i*)) in @@ -281,7 +273,7 @@ let checker (rt, ro, ra, rf, roots, max_id, confl) = (interp_conseq_uf t_i) (certif_ops (Some [|v 4(*t_i*); v 3(*t_func*); v 2(*t_atom*); v 1(* t_form *)|])) confl None in List.iter (fun (v,ty) -> - let _ = Structures.declare_new_variable v ty in + let _ = CoqInterface.declare_new_variable v ty in print_assm ty ) cuts; @@ -294,26 +286,26 @@ let checker (rt, ro, ra, rf, roots, max_id, confl) = let res = Array.make (l + 1) (mkInt 0) in let i = ref (l-1) in List.iter (fun j -> res.(!i) <- mkInt j; decr i) used_roots; - mklApp cSome [|mklApp carray [|Lazy.force cint|]; Structures.mkArray (Lazy.force cint, res)|] in + mklApp cSome [|mklApp carray [|Lazy.force cint|]; CoqTerms.mkArray (Lazy.force cint, res)|] in let rootsCstr = let res = Array.make (List.length roots + 1) (mkInt 0) in let i = ref 0 in List.iter (fun j -> res.(!i) <- mkInt (Form.to_lit j); incr i) roots; - Structures.mkArray (Lazy.force cint, res) in + CoqTerms.mkArray (Lazy.force cint, res) in let tm = - Structures.mkLetIn (nti, t_i, mklApp carray [|Lazy.force ctyp_compdec|], - Structures.mkLetIn (ntfunc, t_func, mklApp carray [|mklApp ctval [|v 1(* t_i *)|]|], - Structures.mkLetIn (ntatom, t_atom, mklApp carray [|Lazy.force catom|], - Structures.mkLetIn (ntform, t_form, mklApp carray [|Lazy.force cform|], - Structures.mkLetIn (nc, certif, mklApp ccertif [|v 4 (*t_i*); v 3 (*t_func*); v 2 (*t_atom*); v 1 (*t_form*)|], - Structures.mkLetIn (nused_roots, used_rootsCstr, mklApp coption [|mklApp carray [|Lazy.force cint|]|], - Structures.mkLetIn (nd, rootsCstr, mklApp carray [|Lazy.force cint|], + CoqInterface.mkLetIn (nti, t_i, mklApp carray [|Lazy.force ctyp_compdec|], + CoqInterface.mkLetIn (ntfunc, t_func, mklApp carray [|mklApp ctval [|v 1(* t_i *)|]|], + CoqInterface.mkLetIn (ntatom, t_atom, mklApp carray [|Lazy.force catom|], + CoqInterface.mkLetIn (ntform, t_form, mklApp carray [|Lazy.force cform|], + CoqInterface.mkLetIn (nc, certif, mklApp ccertif [|v 4 (*t_i*); v 3 (*t_func*); v 2 (*t_atom*); v 1 (*t_form*)|], + CoqInterface.mkLetIn (nused_roots, used_rootsCstr, mklApp coption [|mklApp carray [|Lazy.force cint|]|], + CoqInterface.mkLetIn (nd, rootsCstr, mklApp carray [|Lazy.force cint|], mklApp cchecker [|v 7 (*t_i*); v 6 (*t_func*); v 5 (*t_atom*); v 4 (*t_form*); v 1 (*d*); v 2 (*used_roots*); v 3 (*c*)|]))))))) in - let res = Structures.cbv_vm (Global.env ()) tm (Lazy.force CoqTerms.cbool) in + let res = CoqInterface.cbv_vm (Global.env ()) tm (Lazy.force CoqTerms.cbool) in Format.eprintf " = %s\n : bool@." - (if Structures.eq_constr res (Lazy.force CoqTerms.ctrue) then + (if CoqInterface.eq_constr res (Lazy.force CoqTerms.ctrue) then "true" else "false") let count_used confl = @@ -329,15 +321,15 @@ let count_used confl = let checker_debug (rt, ro, ra, rf, roots, max_id, confl) = - let nti = Structures.mkName "t_i" in - let ntfunc = Structures.mkName "t_func" in - let ntatom = Structures.mkName "t_atom" in - let ntform = Structures.mkName "t_form" in - let nc = Structures.mkName "c" in - let nused_roots = Structures.mkName "used_roots" in - let nd = Structures.mkName "d" in + let nti = CoqInterface.mkName "t_i" in + let ntfunc = CoqInterface.mkName "t_func" in + let ntatom = CoqInterface.mkName "t_atom" in + let ntform = CoqInterface.mkName "t_form" in + let nc = CoqInterface.mkName "c" in + let nused_roots = CoqInterface.mkName "used_roots" in + let nd = CoqInterface.mkName "d" in - let v = Structures.mkRel in + let v = CoqInterface.mkRel in let t_i = make_t_i rt in let t_func = make_t_func ro (v 1 (*t_i*)) in @@ -349,7 +341,7 @@ let checker_debug (rt, ro, ra, rf, roots, max_id, confl) = (certif_ops (Some [|v 4(*t_i*); v 3(*t_func*); v 2(*t_atom*); v 1(* t_form *)|])) confl None in List.iter (fun (v,ty) -> - let _ = Structures.declare_new_variable v ty in + let _ = CoqInterface.declare_new_variable v ty in print_assm ty ) cuts; @@ -364,84 +356,84 @@ let checker_debug (rt, ro, ra, rf, roots, max_id, confl) = let i = ref (l-1) in List.iter (fun j -> res.(!i) <- mkInt j; decr i) used_roots; mklApp cSome [|mklApp carray [|Lazy.force cint|]; - Structures.mkArray (Lazy.force cint, res)|] in + CoqTerms.mkArray (Lazy.force cint, res)|] in let rootsCstr = let res = Array.make (List.length roots + 1) (mkInt 0) in let i = ref 0 in List.iter (fun j -> res.(!i) <- mkInt (Form.to_lit j); incr i) roots; - Structures.mkArray (Lazy.force cint, res) in + CoqTerms.mkArray (Lazy.force cint, res) in let tm = - Structures.mkLetIn (nti, t_i, mklApp carray [|Lazy.force ctyp_compdec|], - Structures.mkLetIn (ntfunc, t_func, + CoqInterface.mkLetIn (nti, t_i, mklApp carray [|Lazy.force ctyp_compdec|], + CoqInterface.mkLetIn (ntfunc, t_func, mklApp carray [|mklApp ctval [|v 1(* t_i *)|]|], - Structures.mkLetIn (ntatom, t_atom, mklApp carray [|Lazy.force catom|], - Structures.mkLetIn (ntform, t_form, mklApp carray [|Lazy.force cform|], - Structures.mkLetIn (nc, certif, mklApp ccertif [|v 4 (*t_i*); v 3 (*t_func*); + CoqInterface.mkLetIn (ntatom, t_atom, mklApp carray [|Lazy.force catom|], + CoqInterface.mkLetIn (ntform, t_form, mklApp carray [|Lazy.force cform|], + CoqInterface.mkLetIn (nc, certif, mklApp ccertif [|v 4 (*t_i*); v 3 (*t_func*); v 2 (*t_atom*); v 1 (*t_form*)|], - Structures.mkLetIn (nused_roots, used_rootsCstr, + CoqInterface.mkLetIn (nused_roots, used_rootsCstr, mklApp coption [|mklApp carray [|Lazy.force cint|]|], - Structures.mkLetIn (nd, rootsCstr, mklApp carray [|Lazy.force cint|], + CoqInterface.mkLetIn (nd, rootsCstr, mklApp carray [|Lazy.force cint|], mklApp cchecker_debug [|v 7 (*t_i*); v 6 (*t_func*); v 5 (*t_atom*); v 4 (*t_form*); v 1 (*d*); v 2 (*used_roots*); v 3 (*c*)|]))))))) in - let res = Structures.cbv_vm (Global.env ()) tm + let res = CoqInterface.cbv_vm (Global.env ()) tm (mklApp coption [|mklApp cprod [|Lazy.force cnat; Lazy.force cname_step|]|]) in - match Structures.decompose_app res with - | c, _ when Structures.eq_constr c (Lazy.force cNone) -> - Structures.error ("Debug checker is only meant to be used for certificates \ + match CoqInterface.decompose_app res with + | c, _ when CoqInterface.eq_constr c (Lazy.force cNone) -> + CoqInterface.error ("Debug checker is only meant to be used for certificates \ that fail to be checked by SMTCoq.") - | c, [_; n] when Structures.eq_constr c (Lazy.force cSome) -> - (match Structures.decompose_app n with - | c, [_; _; cnb; cn] when Structures.eq_constr c (Lazy.force cpair) -> - let n = fst (Structures.decompose_app cn) in + | c, [_; n] when CoqInterface.eq_constr c (Lazy.force cSome) -> + (match CoqInterface.decompose_app n with + | c, [_; _; cnb; cn] when CoqInterface.eq_constr c (Lazy.force cpair) -> + let n = fst (CoqInterface.decompose_app cn) in let name = - if Structures.eq_constr n (Lazy.force cName_Res ) then "Res" - else if Structures.eq_constr n (Lazy.force cName_Weaken) then "Weaken" - else if Structures.eq_constr n (Lazy.force cName_ImmFlatten) then "ImmFlatten" - else if Structures.eq_constr n (Lazy.force cName_CTrue) then "CTrue" - else if Structures.eq_constr n (Lazy.force cName_CFalse ) then "CFalse" - else if Structures.eq_constr n (Lazy.force cName_BuildDef) then "BuildDef" - else if Structures.eq_constr n (Lazy.force cName_BuildDef2) then "BuildDef2" - else if Structures.eq_constr n (Lazy.force cName_BuildProj ) then "BuildProj" - else if Structures.eq_constr n (Lazy.force cName_ImmBuildDef) then "ImmBuildDef" - else if Structures.eq_constr n (Lazy.force cName_ImmBuildDef2) then "ImmBuildDef2" - else if Structures.eq_constr n (Lazy.force cName_ImmBuildProj ) then "ImmBuildProj" - else if Structures.eq_constr n (Lazy.force cName_EqTr ) then "EqTr" - else if Structures.eq_constr n (Lazy.force cName_EqCgr ) then "EqCgr" - else if Structures.eq_constr n (Lazy.force cName_EqCgrP) then "EqCgrP" - else if Structures.eq_constr n (Lazy.force cName_LiaMicromega ) then "LiaMicromega" - else if Structures.eq_constr n (Lazy.force cName_LiaDiseq) then "LiaDiseq" - else if Structures.eq_constr n (Lazy.force cName_SplArith) then "SplArith" - else if Structures.eq_constr n (Lazy.force cName_SplDistinctElim ) then "SplDistinctElim" - else if Structures.eq_constr n (Lazy.force cName_BBVar) then "BBVar" - else if Structures.eq_constr n (Lazy.force cName_BBConst) then "BBConst" - else if Structures.eq_constr n (Lazy.force cName_BBOp) then "BBOp" - else if Structures.eq_constr n (Lazy.force cName_BBNot) then "BBNot" - else if Structures.eq_constr n (Lazy.force cName_BBNeg) then "BBNeg" - else if Structures.eq_constr n (Lazy.force cName_BBAdd) then "BBAdd" - else if Structures.eq_constr n (Lazy.force cName_BBConcat) then "BBConcat" - else if Structures.eq_constr n (Lazy.force cName_BBMul) then "BBMul" - else if Structures.eq_constr n (Lazy.force cName_BBUlt) then "BBUlt" - else if Structures.eq_constr n (Lazy.force cName_BBSlt) then "BBSlt" - else if Structures.eq_constr n (Lazy.force cName_BBEq) then "BBEq" - else if Structures.eq_constr n (Lazy.force cName_BBDiseq) then "BBDiseq" - else if Structures.eq_constr n (Lazy.force cName_BBExtract) then "BBExtract" - else if Structures.eq_constr n (Lazy.force cName_BBZextend) then "BBZextend" - else if Structures.eq_constr n (Lazy.force cName_BBSextend) then "BBSextend" - else if Structures.eq_constr n (Lazy.force cName_BBShl) then "BBShl" - else if Structures.eq_constr n (Lazy.force cName_BBShr) then "BBShr" - else if Structures.eq_constr n (Lazy.force cName_RowEq) then "RowEq" - else if Structures.eq_constr n (Lazy.force cName_RowNeq) then "RowNeq" - else if Structures.eq_constr n (Lazy.force cName_Ext) then "Ext" - else if Structures.eq_constr n (Lazy.force cName_Hole) then "Hole" + if CoqInterface.eq_constr n (Lazy.force cName_Res ) then "Res" + else if CoqInterface.eq_constr n (Lazy.force cName_Weaken) then "Weaken" + else if CoqInterface.eq_constr n (Lazy.force cName_ImmFlatten) then "ImmFlatten" + else if CoqInterface.eq_constr n (Lazy.force cName_CTrue) then "CTrue" + else if CoqInterface.eq_constr n (Lazy.force cName_CFalse ) then "CFalse" + else if CoqInterface.eq_constr n (Lazy.force cName_BuildDef) then "BuildDef" + else if CoqInterface.eq_constr n (Lazy.force cName_BuildDef2) then "BuildDef2" + else if CoqInterface.eq_constr n (Lazy.force cName_BuildProj ) then "BuildProj" + else if CoqInterface.eq_constr n (Lazy.force cName_ImmBuildDef) then "ImmBuildDef" + else if CoqInterface.eq_constr n (Lazy.force cName_ImmBuildDef2) then "ImmBuildDef2" + else if CoqInterface.eq_constr n (Lazy.force cName_ImmBuildProj ) then "ImmBuildProj" + else if CoqInterface.eq_constr n (Lazy.force cName_EqTr ) then "EqTr" + else if CoqInterface.eq_constr n (Lazy.force cName_EqCgr ) then "EqCgr" + else if CoqInterface.eq_constr n (Lazy.force cName_EqCgrP) then "EqCgrP" + else if CoqInterface.eq_constr n (Lazy.force cName_LiaMicromega ) then "LiaMicromega" + else if CoqInterface.eq_constr n (Lazy.force cName_LiaDiseq) then "LiaDiseq" + else if CoqInterface.eq_constr n (Lazy.force cName_SplArith) then "SplArith" + else if CoqInterface.eq_constr n (Lazy.force cName_SplDistinctElim ) then "SplDistinctElim" + else if CoqInterface.eq_constr n (Lazy.force cName_BBVar) then "BBVar" + else if CoqInterface.eq_constr n (Lazy.force cName_BBConst) then "BBConst" + else if CoqInterface.eq_constr n (Lazy.force cName_BBOp) then "BBOp" + else if CoqInterface.eq_constr n (Lazy.force cName_BBNot) then "BBNot" + else if CoqInterface.eq_constr n (Lazy.force cName_BBNeg) then "BBNeg" + else if CoqInterface.eq_constr n (Lazy.force cName_BBAdd) then "BBAdd" + else if CoqInterface.eq_constr n (Lazy.force cName_BBConcat) then "BBConcat" + else if CoqInterface.eq_constr n (Lazy.force cName_BBMul) then "BBMul" + else if CoqInterface.eq_constr n (Lazy.force cName_BBUlt) then "BBUlt" + else if CoqInterface.eq_constr n (Lazy.force cName_BBSlt) then "BBSlt" + else if CoqInterface.eq_constr n (Lazy.force cName_BBEq) then "BBEq" + else if CoqInterface.eq_constr n (Lazy.force cName_BBDiseq) then "BBDiseq" + else if CoqInterface.eq_constr n (Lazy.force cName_BBExtract) then "BBExtract" + else if CoqInterface.eq_constr n (Lazy.force cName_BBZextend) then "BBZextend" + else if CoqInterface.eq_constr n (Lazy.force cName_BBSextend) then "BBSextend" + else if CoqInterface.eq_constr n (Lazy.force cName_BBShl) then "BBShl" + else if CoqInterface.eq_constr n (Lazy.force cName_BBShr) then "BBShr" + else if CoqInterface.eq_constr n (Lazy.force cName_RowEq) then "RowEq" + else if CoqInterface.eq_constr n (Lazy.force cName_RowNeq) then "RowNeq" + else if CoqInterface.eq_constr n (Lazy.force cName_Ext) then "Ext" + else if CoqInterface.eq_constr n (Lazy.force cName_Hole) then "Hole" else string_coq_constr n in let nb = mk_nat cnb + List.length roots + (confl.id + 1 - count_used confl) in - Structures.error ("Step number " ^ string_of_int nb ^ + CoqInterface.error ("Step number " ^ string_of_int nb ^ " (" ^ name ^ ") of the certificate likely failed.") | _ -> assert false ) @@ -450,9 +442,9 @@ let checker_debug (rt, ro, ra, rf, roots, max_id, confl) = (* let rec of_coq_list cl = - * match Structures.decompose_app cl with - * | c, _ when Structures.eq_constr c (Lazy.force cnil) -> [] - * | c, [_; x; cr] when Structures.eq_constr c (Lazy.force ccons) -> + * match CoqInterface.decompose_app cl with + * | c, _ when CoqInterface.eq_constr c (Lazy.force cnil) -> [] + * | c, [_; x; cr] when CoqInterface.eq_constr c (Lazy.force ccons) -> * x :: of_coq_list cr * | _ -> assert false *) @@ -461,29 +453,29 @@ let checker_debug (rt, ro, ra, rf, roots, max_id, confl) = * (rt, ro, ra, rf, roots, max_id, confl) = * * let t_i' = make_t_i rt in - * let ce5 = Structures.mkUConst t_i' in - * let ct_i = Structures.mkConst (Structures.declare_constant t_i ce5) in + * let ce5 = CoqInterface.mkUConst t_i' in + * let ct_i = CoqInterface.mkConst (CoqInterface.declare_constant t_i ce5) in * * let t_func' = make_t_func ro ct_i in - * let ce6 = Structures.mkUConst t_func' in + * let ce6 = CoqInterface.mkUConst t_func' in * let ct_func = - * Structures.mkConst (Structures.declare_constant t_func ce6) in + * CoqInterface.mkConst (CoqInterface.declare_constant t_func ce6) in * * let t_atom' = Atom.interp_tbl ra in - * let ce1 = Structures.mkUConst t_atom' in + * let ce1 = CoqInterface.mkUConst t_atom' in * let ct_atom = - * Structures.mkConst (Structures.declare_constant t_atom ce1) in + * CoqInterface.mkConst (CoqInterface.declare_constant t_atom ce1) in * * let t_form' = snd (Form.interp_tbl rf) in - * let ce2 = Structures.mkUConst t_form' in + * let ce2 = CoqInterface.mkUConst t_form' in * let ct_form = - * Structures.mkConst (Structures.declare_constant t_form ce2) in + * CoqInterface.mkConst (CoqInterface.declare_constant t_form ce2) in * * let (tres, last_root, cuts) = SmtTrace.to_coq (fun i -> mkInt (Form.to_lit i)) * (interp_conseq_uf ct_i) * (certif_ops (Some [|ct_i; ct_func; ct_atom; ct_form|])) confl None in * List.iter (fun (v,ty) -> - * let _ = Structures.declare_new_variable v ty in + * let _ = CoqInterface.declare_new_variable v ty in * print_assm ty * ) cuts; * @@ -492,37 +484,37 @@ let checker_debug (rt, ro, ra, rf, roots, max_id, confl) = * let res = Array.make (List.length roots + 1) (mkInt 0) in * let i = ref 0 in * List.iter (fun j -> res.(!i) <- mkInt (Form.to_lit j); incr i) roots; - * Structures.mkArray (Lazy.force cint, res) in + * CoqTerms.mkArray (Lazy.force cint, res) in * let cused_roots = * let l = List.length used_roots in * let res = Array.make (l + 1) (mkInt 0) in * let i = ref (l-1) in * List.iter (fun j -> res.(!i) <- mkInt j; decr i) used_roots; * mklApp cSome [|mklApp carray [|Lazy.force cint|]; - * Structures.mkArray (Lazy.force cint, res)|] in - * let ce3 = Structures.mkUConst croots in - * let _ = Structures.declare_constant root ce3 in - * let ce3' = Structures.mkUConst cused_roots in - * let _ = Structures.declare_constant used_root ce3' in + * CoqTerms.mkArray (Lazy.force cint, res)|] in + * let ce3 = CoqInterface.mkUConst croots in + * let _ = CoqInterface.declare_constant root ce3 in + * let ce3' = CoqInterface.mkUConst cused_roots in + * let _ = CoqInterface.declare_constant used_root ce3' in * * let certif = * mklApp cCertif [|ct_i; ct_func; ct_atom; ct_form; mkInt (max_id + 1); * tres;mkInt (get_pos confl)|] in - * let ce4 = Structures.mkUConst certif in - * let _ = Structures.declare_constant trace ce4 in + * let ce4 = CoqInterface.mkUConst certif in + * let _ = CoqInterface.declare_constant trace ce4 in * * let setup = * mklApp csetup_checker_step_debug * [| ct_i; ct_func; ct_atom; ct_form; croots; cused_roots; certif |] in * - * let setup = Structures.cbv_vm (Global.env ()) setup + * let setup = CoqInterface.cbv_vm (Global.env ()) setup * (mklApp cprod * [|Lazy.force cState_S_t; * mklApp clist [|mklApp cstep * [|ct_i; ct_func; ct_atom; ct_form|]|]|]) in * - * let s, steps = match Structures.decompose_app setup with - * | c, [_; _; s; csteps] when Structures.eq_constr c (Lazy.force cpair) -> + * let s, steps = match CoqInterface.decompose_app setup with + * | c, [_; _; s; csteps] when CoqInterface.eq_constr c (Lazy.force cpair) -> * s, of_coq_list csteps * | _ -> assert false * in @@ -536,22 +528,22 @@ let checker_debug (rt, ro, ra, rf, roots, max_id, confl) = * [| ct_i; ct_func; ct_atom; ct_form; s; step |] in * * let res = - * Structures.cbv_vm (Global.env ()) tm + * CoqInterface.cbv_vm (Global.env ()) tm * (mklApp cprod [|Lazy.force cState_S_t; Lazy.force cbool|]) in * - * match Structures.decompose_app res with - * | c, [_; _; s; cbad] when Structures.eq_constr c (Lazy.force cpair) -> + * match CoqInterface.decompose_app res with + * | c, [_; _; s; cbad] when CoqInterface.eq_constr c (Lazy.force cpair) -> * if not (mk_bool cbad) then s - * else Structures.error ("Step number " ^ string_of_int !cpt ^ + * else CoqInterface.error ("Step number " ^ string_of_int !cpt ^ * " (" ^ string_coq_constr - * (fst (Structures.decompose_app step)) ^ ")" ^ + * (fst (CoqInterface.decompose_app step)) ^ ")" ^ * " of the certificate likely failed." ) * | _ -> assert false * in * * List.fold_left debug_step s steps |> ignore; * - * Structures.error ("Debug checker is only meant to be used for certificates \ + * CoqInterface.error ("Debug checker is only meant to be used for certificates \ * that fail to be checked by SMTCoq.") *) @@ -559,16 +551,16 @@ let checker_debug (rt, ro, ra, rf, roots, max_id, confl) = (* Tactic *) let build_body rt ro ra rf l b (max_id, confl) vm_cast find = - let nti = Structures.mkName "t_i" in - let ntfunc = Structures.mkName "t_func" in - let ntatom = Structures.mkName "t_atom" in - let ntform = Structures.mkName "t_form" in - let nc = Structures.mkName "c" in + let nti = CoqInterface.mkName "t_i" in + let ntfunc = CoqInterface.mkName "t_func" in + let ntatom = CoqInterface.mkName "t_atom" in + let ntform = CoqInterface.mkName "t_form" in + let nc = CoqInterface.mkName "c" in - let v = Structures.mkRel in + let v = CoqInterface.mkRel in let t_i = make_t_i rt in - let t_func = Structures.lift 1 (make_t_func ro (v 0 (*t_i - 1*))) in + let t_func = CoqInterface.lift 1 (make_t_func ro (v 0 (*t_i - 1*))) in let t_atom = Atom.interp_tbl ra in let t_form = snd (Form.interp_tbl rf) in let (tres,_,cuts) = SmtTrace.to_coq Form.to_coq @@ -583,11 +575,11 @@ let build_body rt ro ra rf l b (max_id, confl) vm_cast find = mkInt (max_id + 1); tres;mkInt (get_pos confl)|] in let add_lets t = - Structures.mkLetIn (nti, t_i, mklApp carray [|Lazy.force ctyp_compdec|], - Structures.mkLetIn (ntfunc, t_func, mklApp carray [|mklApp ctval [|v 1(*t_i*)|]|], - Structures.mkLetIn (ntatom, t_atom, mklApp carray [|Lazy.force catom|], - Structures.mkLetIn (ntform, t_form, mklApp carray [|Lazy.force cform|], - Structures.mkLetIn (nc, certif, mklApp ccertif + CoqInterface.mkLetIn (nti, t_i, mklApp carray [|Lazy.force ctyp_compdec|], + CoqInterface.mkLetIn (ntfunc, t_func, mklApp carray [|mklApp ctval [|v 1(*t_i*)|]|], + CoqInterface.mkLetIn (ntatom, t_atom, mklApp carray [|Lazy.force catom|], + CoqInterface.mkLetIn (ntform, t_form, mklApp carray [|Lazy.force cform|], + CoqInterface.mkLetIn (nc, certif, mklApp ccertif [|v 4 (*t_i*); v 3 (*t_func*); v 2 (*t_atom*); v 1 (*t_form*)|], t))))) in @@ -614,16 +606,16 @@ let build_body rt ro ra rf l b (max_id, confl) vm_cast find = let build_body_eq rt ro ra rf l1 l2 l (max_id, confl) vm_cast find = - let nti = Structures.mkName "t_i" in - let ntfunc = Structures.mkName "t_func" in - let ntatom = Structures.mkName "t_atom" in - let ntform = Structures.mkName "t_form" in - let nc = Structures.mkName "c" in + let nti = CoqInterface.mkName "t_i" in + let ntfunc = CoqInterface.mkName "t_func" in + let ntatom = CoqInterface.mkName "t_atom" in + let ntform = CoqInterface.mkName "t_form" in + let nc = CoqInterface.mkName "c" in - let v = Structures.mkRel in + let v = CoqInterface.mkRel in let t_i = make_t_i rt in - let t_func = Structures.lift 1 (make_t_func ro (v 0 (*t_i*))) in + let t_func = CoqInterface.lift 1 (make_t_func ro (v 0 (*t_i*))) in let t_atom = Atom.interp_tbl ra in let t_form = snd (Form.interp_tbl rf) in let (tres,_,cuts) = SmtTrace.to_coq Form.to_coq @@ -633,11 +625,11 @@ let build_body_eq rt ro ra rf l1 l2 l (max_id, confl) vm_cast find = mklApp cCertif [|v 4 (*t_i*); v 3 (*t_func*); v 2 (*t_atom*); v 1 (*t_form*); mkInt (max_id + 1); tres;mkInt (get_pos confl)|] in let add_lets t = - Structures.mkLetIn (nti, t_i, mklApp carray [|Lazy.force ctyp_compdec|], - Structures.mkLetIn (ntfunc, t_func, mklApp carray [|mklApp ctval [|v 1(*t_i*)|]|], - Structures.mkLetIn (ntatom, t_atom, mklApp carray [|Lazy.force catom|], - Structures.mkLetIn (ntform, t_form, mklApp carray [|Lazy.force cform|], - Structures.mkLetIn (nc, certif, mklApp ccertif + CoqInterface.mkLetIn (nti, t_i, mklApp carray [|Lazy.force ctyp_compdec|], + CoqInterface.mkLetIn (ntfunc, t_func, mklApp carray [|mklApp ctval [|v 1(*t_i*)|]|], + CoqInterface.mkLetIn (ntatom, t_atom, mklApp carray [|Lazy.force catom|], + CoqInterface.mkLetIn (ntform, t_form, mklApp carray [|Lazy.force cform|], + CoqInterface.mkLetIn (nc, certif, mklApp ccertif [|v 4 (*t_i*); v 3 (*t_func*); v 2 (*t_atom*); v 1 (*t_form*)|], t))))) in @@ -665,10 +657,10 @@ let build_body_eq rt ro ra rf l1 l2 l (max_id, confl) vm_cast find = let get_arguments concl = - let f, args = Structures.decompose_app concl in + let f, args = CoqInterface.decompose_app concl in match args with - | [ty;a;b] when (Structures.eq_constr f (Lazy.force ceq)) && (Structures.eq_constr ty (Lazy.force cbool)) -> a, b - | [a] when (Structures.eq_constr f (Lazy.force cis_true)) -> a, Lazy.force ctrue + | [ty;a;b] when (CoqInterface.eq_constr f (Lazy.force ceq)) && (CoqInterface.eq_constr ty (Lazy.force cbool)) -> a, b + | [a] when (CoqInterface.eq_constr f (Lazy.force cis_true)) -> a, Lazy.force ctrue | _ -> failwith ("Verit.tactic: can only deal with equality over bool") @@ -689,7 +681,7 @@ let gen_rel_name = let of_coq_lemma rt ro ra_quant rf_quant env sigma solver_logic clemma = let warn () = - Structures.warning "Lemma" ("Discarding the following lemma (unsupported): "^(Pp.string_of_ppcmds (Ppconstr.pr_constr_expr (Structures.extern_constr clemma)))); + CoqInterface.warning "Lemma" ("Discarding the following lemma (unsupported): "^(Pp.string_of_ppcmds (Ppconstr.pr_constr_expr Environ.empty_env Evd.empty (CoqInterface.extern_constr clemma)))); None in @@ -698,16 +690,16 @@ let of_coq_lemma rt ro ra_quant rf_quant env sigma solver_logic clemma = let rel_context = List.map (fun rel -> Context.Rel.Declaration.set_name (Names.Name.mk_name (Names.Id.of_string (gen_rel_name ()))) rel) rel_context in let env_lemma = Environ.push_rel_context rel_context env in - let f, args = Structures.decompose_app qf_lemma in + let f, args = CoqInterface.decompose_app qf_lemma in let core_f = - if Structures.eq_constr f (Lazy.force cis_true) then + if CoqInterface.eq_constr f (Lazy.force cis_true) then match args with | [a] -> Some a | _ -> warn () - else if Structures.eq_constr f (Lazy.force ceq) then + else if CoqInterface.eq_constr f (Lazy.force ceq) then match args with - | [ty; arg1; arg2] when Structures.eq_constr ty (Lazy.force cbool) && - Structures.eq_constr arg2 (Lazy.force ctrue) -> + | [ty; arg1; arg2] when CoqInterface.eq_constr ty (Lazy.force cbool) && + CoqInterface.eq_constr arg2 (Lazy.force ctrue) -> Some arg1 | _ -> warn () else warn () in @@ -722,8 +714,8 @@ let of_coq_lemma rt ro ra_quant rf_quant env sigma solver_logic clemma = | None -> None in let forall_args = - let fmap r = let n, t = Structures.destruct_rel_decl r in - Structures.string_of_name n, SmtBtype.of_coq rt solver_logic t in + let fmap r = let n, t = CoqInterface.destruct_rel_decl r in + CoqInterface.string_of_name n, SmtBtype.of_coq rt solver_logic t in List.map fmap rel_context in match forall_args with @@ -736,11 +728,11 @@ let of_coq_lemma rt ro ra_quant rf_quant env sigma solver_logic clemma = let core_tactic call_solver solver_logic rt ro ra rf ra_quant rf_quant vm_cast lcpl lcepl env sigma concl = let a, b = get_arguments concl in - let tlcepl = List.map (Structures.interp_constr env sigma) lcepl in + let tlcepl = List.map (CoqInterface.interp_constr env sigma) lcepl in let lcpl = lcpl @ tlcepl in let create_lemma l = - let cl = Structures.retyping_get_type_of env sigma l in + let cl = CoqInterface.retyping_get_type_of env sigma l in match of_coq_lemma rt ro ra_quant rf_quant env sigma solver_logic cl with | Some smt -> Some ((cl, l), smt) | None -> None @@ -748,7 +740,7 @@ let core_tactic call_solver solver_logic rt ro ra rf ra_quant rf_quant vm_cast l let l_pl_ls = SmtMisc.filter_map create_lemma lcpl in let lsmt = List.map snd l_pl_ls in - let lem_tbl : (int, Structures.constr * Structures.constr) Hashtbl.t = + let lem_tbl : (int, CoqInterface.constr * CoqInterface.constr) Hashtbl.t = Hashtbl.create 100 in let new_ref ((l, pl), ls) = Hashtbl.add lem_tbl (Form.index ls) (l, pl) in @@ -770,11 +762,11 @@ let core_tactic call_solver solver_logic rt ro ra rf ra_quant rf_quant vm_cast l | _ -> failwith "unexpected form of root" in let (body_cast, body_nocast, cuts) = - if ((Structures.eq_constr b (Lazy.force ctrue)) || - (Structures.eq_constr b (Lazy.force cfalse))) then ( + if ((CoqInterface.eq_constr b (Lazy.force ctrue)) || + (CoqInterface.eq_constr b (Lazy.force cfalse))) then ( let l = Form.of_coq (Atom.of_coq rt ro ra solver_logic env sigma) rf a in let _ = Form.of_coq (Atom.of_coq ~eqsym:true rt ro ra_quant solver_logic env sigma) rf_quant a in - let nl = if (Structures.eq_constr b (Lazy.force ctrue)) then Form.neg l else l in + let nl = if (CoqInterface.eq_constr b (Lazy.force ctrue)) then Form.neg l else l in let lsmt = Form.flatten rf nl :: lsmt in let max_id_confl = make_proof call_solver env rt ro ra_quant rf_quant nl lsmt in build_body rt ro ra rf (Form.to_coq l) b max_id_confl (vm_cast env) (Some find_lemma) @@ -793,19 +785,19 @@ let core_tactic call_solver solver_logic rt ro ra rf ra_quant rf_quant vm_cast l let cuts = (SmtBtype.get_cuts rt) @ cuts in List.fold_right (fun (eqn, eqt) tac -> - Structures.tclTHENLAST - (Structures.assert_before (Structures.name_of_id eqn) eqt) + CoqInterface.tclTHENLAST + (CoqInterface.assert_before (CoqInterface.name_of_id eqn) eqt) tac ) cuts - (Structures.tclTHEN - (Structures.set_evars_tac body_nocast) - (Structures.vm_cast_no_check body_cast)) + (CoqInterface.tclTHEN + (CoqInterface.set_evars_tac body_nocast) + (CoqInterface.vm_cast_no_check body_cast)) let tactic call_solver solver_logic rt ro ra rf ra_quant rf_quant vm_cast lcpl lcepl = - Structures.tclTHEN + CoqInterface.tclTHEN Tactics.intros - (Structures.mk_tactic (core_tactic call_solver solver_logic rt ro ra rf ra_quant rf_quant vm_cast lcpl lcepl)) + (CoqInterface.mk_tactic (core_tactic call_solver solver_logic rt ro ra rf ra_quant rf_quant vm_cast lcpl lcepl)) (**********************************************) @@ -822,7 +814,7 @@ let string_index_of_constr env i cf = try let s = string_coq_constr cf in let nc = Environ.named_context env in - let nd = Environ.lookup_named (Structures.mkId s) env in + let nd = Environ.lookup_named (CoqInterface.mkId s) env in let cpt = ref 0 in (try List.iter (fun n -> incr cpt; if n == nd then raise Exit) nc with Exit -> ()); @@ -832,11 +824,11 @@ let string_index_of_constr env i cf = let vstring_i env i = let cf = SmtAtom.Atom.get_coq_term_op i in - if Structures.isRel cf then - let dbi = Structures.destRel cf in + if CoqInterface.isRel cf then + let dbi = CoqInterface.destRel cf in let s = Environ.lookup_rel dbi env - |> Structures.get_rel_dec_name + |> CoqInterface.get_rel_dec_name |> SmtMisc.string_of_name_def "?" in s, dbi @@ -977,14 +969,14 @@ let model_item env rt ro ra rf = * let outf = Format.formatter_of_out_channel out in * SExpr.print outf l; pp_print_flush outf (); * close_out out; *) - Structures.error ("Could not reconstruct model") + CoqInterface.error ("Could not reconstruct model") let model env rt ro ra rf = function | List (Atom "model" :: l) -> List.fold_left (fun acc m -> match model_item env rt ro ra rf m with Fun m -> m::acc | Sort -> acc) [] l |> List.sort (fun ((_ ,i1), _) ((_, i2), _) -> i2 - i1) - | _ -> Structures.error ("No model") + | _ -> CoqInterface.error ("No model") let model_string env rt ro ra rf s = diff --git a/src/trace/smtCommands.mli b/src/trace/smtCommands.mli index eddf576..d0ebb61 100644 --- a/src/trace/smtCommands.mli +++ b/src/trace/smtCommands.mli @@ -11,13 +11,13 @@ val parse_certif : - Structures.id -> - Structures.id -> - Structures.id -> - Structures.id -> - Structures.id -> - Structures.id -> - Structures.id -> + CoqInterface.id -> + CoqInterface.id -> + CoqInterface.id -> + CoqInterface.id -> + CoqInterface.id -> + CoqInterface.id -> + CoqInterface.id -> SmtBtype.reify_tbl * SmtAtom.Op.reify_tbl * SmtAtom.Atom.reify_tbl * SmtAtom.Form.reify * SmtAtom.Form.t list * int * SmtAtom.Form.t SmtCertif.clause -> @@ -29,7 +29,7 @@ val checker_debug : SmtAtom.Form.t list * int * SmtAtom.Form.t SmtCertif.clause -> 'a val theorem : - Structures.id -> + CoqInterface.id -> SmtBtype.reify_tbl * SmtAtom.Op.reify_tbl * SmtAtom.Atom.reify_tbl * SmtAtom.Form.reify * SmtAtom.Form.t list * int * SmtAtom.Form.t SmtCertif.clause -> @@ -56,8 +56,8 @@ val tactic : SmtAtom.Form.reify -> SmtAtom.Atom.reify_tbl -> SmtAtom.Form.reify -> - (Environ.env -> Structures.constr -> Structures.constr) -> - Structures.constr list -> - Structures.constr_expr list -> Structures.tactic + (Environ.env -> CoqInterface.constr -> CoqInterface.constr) -> + CoqInterface.constr list -> + CoqInterface.constr_expr list -> CoqInterface.tactic val model_string : Environ.env -> SmtBtype.reify_tbl -> 'a -> 'b -> 'c -> SExpr.t -> string diff --git a/src/trace/smtForm.ml b/src/trace/smtForm.ml index 6f26f24..2d68252 100644 --- a/src/trace/smtForm.ml +++ b/src/trace/smtForm.ml @@ -25,7 +25,7 @@ module type ATOM = val is_bool_type : t -> bool val is_bv_type : t -> bool - val to_smt : Format.formatter -> t -> unit + val to_smt : ?debug:bool -> Format.formatter -> t -> unit val logic : t -> logic end @@ -80,11 +80,11 @@ module type FORM = val clear : reify -> unit val get : ?declare:bool -> reify -> pform -> t - (** Give a coq term, build the corresponding formula *) - val of_coq : (Structures.constr -> hatom) -> reify -> Structures.constr -> t + (** Given a coq term, build the corresponding formula *) + val of_coq : (CoqInterface.constr -> hatom) -> reify -> CoqInterface.constr -> t val hash_hform : (hatom -> hatom) -> reify -> t -> t - (** Flattening of [Fand] and [For], removing of [Fnot2] *) + (* Flattening of [Fand] and [For], removing of [Fnot2] *) val flatten : reify -> t -> t (** Turn n-ary [Fand] and [For] into their right-associative @@ -93,20 +93,20 @@ module type FORM = (** Producing Coq terms *) - val to_coq : t -> Structures.constr + val to_coq : t -> CoqInterface.constr val pform_tbl : reify -> pform array val to_array : reify -> 'a -> (pform -> 'a) -> int * 'a array - val interp_tbl : reify -> Structures.constr * Structures.constr + val interp_tbl : reify -> CoqInterface.constr * CoqInterface.constr val nvars : reify -> int - (** Producing a Coq term corresponding to the interpretation - of a formula *) - (** [interp_atom] map [hatom] to coq term, it is better if it produce - shared terms. *) + (* Producing a Coq term corresponding to the interpretation + of a formula *) + (* [interp_atom] map [hatom] to coq term, it is better if it produce + shared terms. *) val interp_to_coq : - (hatom -> Structures.constr) -> (int, Structures.constr) Hashtbl.t -> - t -> Structures.constr + (hatom -> CoqInterface.constr) -> (int, CoqInterface.constr) Hashtbl.t -> + t -> CoqInterface.constr (* Unstratified terms *) type atom_form_lit = @@ -173,12 +173,12 @@ module Make (Atom:ATOM) = to_smt_pform fmt hp.hval; Format.fprintf fmt ")" - and to_smt_pform fmt = function - | Fatom a -> Atom.to_smt fmt a + and to_smt_pform ?(debug=false) fmt = function + | Fatom a -> Atom.to_smt ~debug:debug fmt a | Fapp (op,args) -> to_smt_op fmt op args (* This is an intermediate object of proofs, it correspond to nothing in SMT *) | FbbT (a, l) -> - Format.fprintf fmt "(bbT %a [" Atom.to_smt a; + Format.fprintf fmt "(bbT %a [" (Atom.to_smt ~debug:debug) a; let fi = ref true in List.iter (fun f -> Format.fprintf fmt "%s%a" (if !fi then "" else "; ") @@ -296,34 +296,34 @@ module Make (Atom:ATOM) = let check pf = match pf with | Fatom ha -> if not (Atom.is_bool_type ha) then - raise (Format.eprintf "nwt: %a" to_smt_pform pf; + raise (Format.eprintf "nwt: %a" (to_smt_pform ~debug:true) pf; NotWellTyped pf) | Fapp (op, args) -> (match op with | Ftrue | Ffalse -> if Array.length args <> 0 then - raise (Format.eprintf "nwt: %a" to_smt_pform pf; + raise (Format.eprintf "nwt: %a" (to_smt_pform ~debug:true) pf; NotWellTyped pf) | Fnot2 _ -> if Array.length args <> 1 then - raise (Format.eprintf "nwt: %a" to_smt_pform pf; + raise (Format.eprintf "nwt: %a" (to_smt_pform ~debug:true) pf; NotWellTyped pf) | Fand | For -> () | Fxor | Fimp | Fiff -> if Array.length args <> 2 then - raise (Format.eprintf "nwt: %a" to_smt_pform pf; + raise (Format.eprintf "nwt: %a" (to_smt_pform ~debug:true) pf; NotWellTyped pf) | Fite -> if Array.length args <> 3 then - raise (Format.eprintf "nwt: %a" to_smt_pform pf; + raise (Format.eprintf "nwt: %a" (to_smt_pform ~debug:true) pf; NotWellTyped pf) | Fforall l -> () ) | FbbT (ha, l) -> if not (Atom.is_bv_type ha) then - raise (Format.eprintf "nwt: %a" to_smt_pform pf; + raise (Format.eprintf "nwt: %a" (to_smt_pform ~debug:true) pf; NotWellTyped pf) let declare reify pf = @@ -368,9 +368,9 @@ module Make (Atom:ATOM) = | CCunknown module ConstrHash = struct - type t = Structures.constr - let equal = Structures.eq_constr - let hash = Structures.hash_constr + type t = CoqInterface.constr + let equal = CoqInterface.eq_constr + let hash = CoqInterface.hash_constr end module ConstrHashtbl = Hashtbl.Make(ConstrHash) @@ -393,7 +393,7 @@ module Make (Atom:ATOM) = let get_cst c = try ConstrHashtbl.find op_tbl c with Not_found -> CCunknown in let rec mk_hform h = - let c, args = Structures.decompose_app h in + let c, args = CoqInterface.decompose_app h in match get_cst c with | CCtrue -> get reify (Fapp(Ftrue,empty_args)) | CCfalse -> get reify (Fapp(Ffalse,empty_args)) @@ -408,7 +408,7 @@ module Make (Atom:ATOM) = let l1 = mk_hform b1 in let l2 = mk_hform b2 in get reify (Fapp (Fimp, [|l1;l2|])) - | _ -> Structures.error "SmtForm.Form.of_coq: wrong number of arguments for implb") + | _ -> CoqInterface.error "SmtForm.Form.of_coq: wrong number of arguments for implb") | CCifb -> (* We should also be able to reify if then else *) begin match args with @@ -417,7 +417,7 @@ module Make (Atom:ATOM) = let l2 = mk_hform b2 in let l3 = mk_hform b3 in get reify (Fapp (Fite, [|l1;l2;l3|])) - | _ -> Structures.error "SmtForm.Form.of_coq: wrong number of arguments for ifb" + | _ -> CoqInterface.error "SmtForm.Form.of_coq: wrong number of arguments for ifb" end | _ -> let a = atom_of_coq h in @@ -429,13 +429,13 @@ module Make (Atom:ATOM) = let l1 = mk_hform b1 in let l2 = mk_hform b2 in get reify (f [|l1; l2|]) - | _ -> Structures.error "SmtForm.Form.of_coq: wrong number of arguments" + | _ -> CoqInterface.error "SmtForm.Form.of_coq: wrong number of arguments" and mk_fnot i args = match args with | [t] -> - let c,args = Structures.decompose_app t in - if Structures.eq_constr c (Lazy.force cnegb) then + let c,args = CoqInterface.decompose_app t in + if CoqInterface.eq_constr c (Lazy.force cnegb) then mk_fnot (i+1) args else let q,r = i lsr 1 , i land 1 in @@ -443,31 +443,31 @@ module Make (Atom:ATOM) = let l = if r = 0 then l else neg l in if q = 0 then l else get reify (Fapp(Fnot2 q, [|l|])) - | _ -> Structures.error "SmtForm.Form.mk_hform: wrong number of arguments for negb" + | _ -> CoqInterface.error "SmtForm.Form.mk_hform: wrong number of arguments for negb" and mk_fand acc args = match args with | [t1;t2] -> let l2 = mk_hform t2 in - let c, args = Structures.decompose_app t1 in - if Structures.eq_constr c (Lazy.force candb) then + let c, args = CoqInterface.decompose_app t1 in + if CoqInterface.eq_constr c (Lazy.force candb) then mk_fand (l2::acc) args else let l1 = mk_hform t1 in get reify (Fapp(Fand, Array.of_list (l1::l2::acc))) - | _ -> Structures.error "SmtForm.Form.mk_hform: wrong number of arguments for andb" + | _ -> CoqInterface.error "SmtForm.Form.mk_hform: wrong number of arguments for andb" and mk_for acc args = match args with | [t1;t2] -> let l2 = mk_hform t2 in - let c, args = Structures.decompose_app t1 in - if Structures.eq_constr c (Lazy.force corb) then + let c, args = CoqInterface.decompose_app t1 in + if CoqInterface.eq_constr c (Lazy.force corb) then mk_for (l2::acc) args else let l1 = mk_hform t1 in get reify (Fapp(For, Array.of_list (l1::l2::acc))) - | _ -> Structures.error "SmtForm.Form.mk_hform: wrong number of arguments for orb" in + | _ -> CoqInterface.error "SmtForm.Form.mk_hform: wrong number of arguments for orb" in mk_hform c @@ -546,7 +546,7 @@ module Make (Atom:ATOM) = let args_to_coq args = let cargs = Array.make (Array.length args + 1) (mkInt 0) in Array.iteri (fun i hf -> cargs.(i) <- to_coq hf) args; - Structures.mkArray (Lazy.force cint, cargs) + CoqTerms.mkArray (Lazy.force cint, cargs) let pf_to_coq = function | Fatom a -> mklApp cFatom [|mkInt (Atom.index a)|] @@ -586,12 +586,12 @@ module Make (Atom:ATOM) = let interp_tbl reify = let (i,t) = to_array reify (Lazy.force cFtrue) pf_to_coq in - (mkInt i, Structures.mkArray (Lazy.force cform, t)) + (mkInt i, CoqTerms.mkArray (Lazy.force cform, t)) let nvars reify = reify.count - (** Producing a Coq term corresponding to the interpretation of a formula *) - (** [interp_atom] map [Atom.t] to coq term, it is better if it produce - shared terms. *) + (* Producing a Coq term corresponding to the interpretation of a formula *) + (* [interp_atom] map [Atom.t] to coq term, it is better if it produce + shared terms. *) let interp_to_coq interp_atom form_tbl f = let rec interp_form f = let l = to_lit f in diff --git a/src/trace/smtForm.mli b/src/trace/smtForm.mli index 9678b4c..6a5fca8 100644 --- a/src/trace/smtForm.mli +++ b/src/trace/smtForm.mli @@ -22,7 +22,7 @@ module type ATOM = val is_bool_type : t -> bool val is_bv_type : t -> bool - val to_smt : Format.formatter -> t -> unit + val to_smt : ?debug:bool -> Format.formatter -> t -> unit val logic : t -> logic end @@ -77,7 +77,7 @@ module type FORM = val get : ?declare:bool -> reify -> pform -> t (** Given a coq term, build the corresponding formula *) - val of_coq : (Structures.constr -> hatom) -> reify -> Structures.constr -> t + val of_coq : (CoqInterface.constr -> hatom) -> reify -> CoqInterface.constr -> t val hash_hform : (hatom -> hatom) -> reify -> t -> t @@ -90,20 +90,20 @@ module type FORM = (** Producing Coq terms *) - val to_coq : t -> Structures.constr + val to_coq : t -> CoqInterface.constr val pform_tbl : reify -> pform array val to_array : reify -> 'a -> (pform -> 'a) -> int * 'a array - val interp_tbl : reify -> Structures.constr * Structures.constr + val interp_tbl : reify -> CoqInterface.constr * CoqInterface.constr val nvars : reify -> int - (** Producing a Coq term corresponding to the interpretation - of a formula *) - (** [interp_atom] map [hatom] to coq term, it is better if it produce - shared terms. *) + (* Producing a Coq term corresponding to the interpretation + of a formula *) + (* [interp_atom] map [hatom] to coq term, it is better if it produce + shared terms. *) val interp_to_coq : - (hatom -> Structures.constr) -> (int, Structures.constr) Hashtbl.t -> - t -> Structures.constr + (hatom -> CoqInterface.constr) -> (int, CoqInterface.constr) Hashtbl.t -> + t -> CoqInterface.constr (* Unstratified terms *) type atom_form_lit = diff --git a/src/trace/smtMisc.ml b/src/trace/smtMisc.ml index 227f2ff..e82001c 100644 --- a/src/trace/smtMisc.ml +++ b/src/trace/smtMisc.ml @@ -16,7 +16,7 @@ let cInt_tbl = Hashtbl.create 17 let mkInt i = try Hashtbl.find cInt_tbl i with Not_found -> - let ci = Structures.mkInt i in + let ci = CoqInterface.mkInt i in Hashtbl.add cInt_tbl i ci; ci @@ -25,15 +25,15 @@ type 'a gen_hashed = { index : int; mutable hval : 'a } (** Functions over constr *) -let mklApp f args = Structures.mkApp (Lazy.force f, args) +let mklApp f args = CoqInterface.mkApp (Lazy.force f, args) -let string_of_name_def d n = try Structures.string_of_name n with | _ -> d +let string_of_name_def d n = try CoqInterface.string_of_name n with | _ -> d let string_coq_constr t = let rec fix rf x = rf (fix rf) x in let pr = fix - Ppconstr.modular_constr_pr Pp.mt Structures.ppconstr_lsimpleconstr in - Pp.string_of_ppcmds (pr (Structures.constrextern_extern_constr t)) + Ppconstr.modular_constr_pr Pp.mt CoqInterface.ppconstr_lsimpleconstr in + Pp.string_of_ppcmds (pr (CoqInterface.constrextern_extern_constr t)) (** Logics *) @@ -46,7 +46,7 @@ type logic_item = module SL = Set.Make (struct type t = logic_item - let compare = Pervasives.compare + let compare = Stdlib.compare end) type logic = SL.t diff --git a/src/trace/smtMisc.mli b/src/trace/smtMisc.mli index 149e377..3517018 100644 --- a/src/trace/smtMisc.mli +++ b/src/trace/smtMisc.mli @@ -10,12 +10,12 @@ (**************************************************************************) -val cInt_tbl : (int, Structures.constr) Hashtbl.t -val mkInt : int -> Structures.constr +val cInt_tbl : (int, CoqInterface.constr) Hashtbl.t +val mkInt : int -> CoqInterface.constr type 'a gen_hashed = { index : int; mutable hval : 'a; } -val mklApp : Structures.constr Lazy.t -> Structures.constr array -> Structures.constr -val string_of_name_def : string -> Structures.name -> string -val string_coq_constr : Structures.constr -> string +val mklApp : CoqInterface.constr Lazy.t -> CoqInterface.constr array -> CoqInterface.constr +val string_of_name_def : string -> CoqInterface.name -> string +val string_coq_constr : CoqInterface.constr -> string type logic_item = LUF | LLia | LBitvectors | LArrays module SL : Set.S with type elt = logic_item type logic = SL.t diff --git a/src/trace/smtTrace.ml b/src/trace/smtTrace.ml index e637b5c..650424f 100644 --- a/src/trace/smtTrace.ml +++ b/src/trace/smtTrace.ml @@ -159,7 +159,7 @@ let order_roots init_index first = r := n | _ -> failwith "root value has unexpected form" end done; - let _, lr = List.sort (fun (i1, _) (i2, _) -> Pervasives.compare i1 i2) !acc + let _, lr = List.sort (fun (i1, _) (i2, _) -> Stdlib.compare i1 i2) !acc |> List.split in let link_to c1 c2 = let curr_id = c2.id -1 in @@ -383,7 +383,7 @@ let to_coq to_lit interp (cstep, l := tl | _ -> assert false done; - mklApp cRes [|mkInt (get_pos c); Structures.mkArray (Lazy.force cint, args)|] + mklApp cRes [|mkInt (get_pos c); CoqTerms.mkArray (Lazy.force cint, args)|] | Other other -> begin match other with | Weaken (c',l') -> @@ -412,12 +412,12 @@ let to_coq to_lit interp (cstep, mklApp cEqCgrP [|out_c c; out_f f1; out_f f2; res|] | LiaMicromega (cl,d) -> let cl' = List.fold_right (fun f l -> mklApp ccons [|Lazy.force cint; out_f f; l|]) cl (mklApp cnil [|Lazy.force cint|]) in - let c' = List.fold_right (fun f l -> mklApp ccons [|Lazy.force Structures.micromega_coq_proofTerm; Structures.micromega_dump_proof_term f; l|]) d (mklApp cnil [|Lazy.force Structures.micromega_coq_proofTerm|]) in + let c' = List.fold_right (fun f l -> mklApp ccons [|Lazy.force CoqTerms.micromega_coq_proofTerm; CoqInterface.micromega_dump_proof_term f; l|]) d (mklApp cnil [|Lazy.force CoqTerms.micromega_coq_proofTerm|]) in mklApp cLiaMicromega [|out_c c; cl'; c'|] | LiaDiseq l -> mklApp cLiaDiseq [|out_c c; out_f l|] | SplArith (orig,res,l) -> let res' = out_f res in - let l' = List.fold_right (fun f l -> mklApp ccons [|Lazy.force Structures.micromega_coq_proofTerm; Structures.micromega_dump_proof_term f; l|]) l (mklApp cnil [|Lazy.force Structures.micromega_coq_proofTerm|]) in + let l' = List.fold_right (fun f l -> mklApp ccons [|Lazy.force CoqTerms.micromega_coq_proofTerm; CoqInterface.micromega_dump_proof_term f; l|]) l (mklApp cnil [|Lazy.force CoqTerms.micromega_coq_proofTerm|]) in mklApp cSplArith [|out_c c; out_c orig; res'; l'|] | SplDistinctElim (c',f) -> mklApp cSplDistinctElim [|out_c c;out_c c'; out_f f|] | BBVar res -> mklApp cBBVar [|out_c c; out_f res|] @@ -461,10 +461,10 @@ let to_coq to_lit interp (cstep, | Ext (res) -> mklApp cExt [|out_c c; out_f res|] | Hole (prem_id, concl) -> let prem = List.map (fun cl -> match cl.value with Some l -> l | None -> assert false) prem_id in - let ass_name = Structures.mkId ("ass"^(string_of_int (Hashtbl.hash concl))) in + let ass_name = CoqInterface.mkId ("ass"^(string_of_int (Hashtbl.hash concl))) in let ass_ty = interp (prem, concl) in cuts := (ass_name, ass_ty)::!cuts; - let ass_var = Structures.mkVar ass_name in + let ass_var = CoqInterface.mkVar ass_name in let prem_id' = List.fold_right (fun c l -> mklApp ccons [|Lazy.force cint; out_c c; l|]) prem_id (mklApp cnil [|Lazy.force cint|]) in let prem' = List.fold_right (fun cl l -> mklApp ccons [|Lazy.force cState_C_t; out_cl cl; l|]) prem (mklApp cnil [|Lazy.force cState_C_t|]) in let concl' = out_cl concl in @@ -474,23 +474,23 @@ let to_coq to_lit interp (cstep, | Some find -> find cl | None -> assert false in let concl' = out_cl [concl] in - let app_name = Structures.mkId ("app" ^ (string_of_int (Hashtbl.hash concl))) in - let app_var = Structures.mkVar app_name in - let app_ty = Term.mkArrow clemma (interp ([], [concl])) in + let app_name = CoqInterface.mkId ("app" ^ (string_of_int (Hashtbl.hash concl))) in + let app_var = CoqInterface.mkVar app_name in + let app_ty = CoqInterface.mkArrow clemma (interp ([], [concl])) in cuts := (app_name, app_ty)::!cuts; mklApp cForallInst [|out_c c; clemma; cplemma; concl'; app_var|] end | _ -> assert false in let step = Lazy.force cstep in let def_step = - mklApp cRes [|mkInt 0; Structures.mkArray (Lazy.force cint, [|mkInt 0|]) |] in + mklApp cRes [|mkInt 0; CoqTerms.mkArray (Lazy.force cint, [|mkInt 0|]) |] in let r = ref confl in let nc = ref 0 in while not (isRoot !r.kind) do r := prev !r; incr nc done; let last_root = !r in (* Be careful, step_to_coq makes a side effect on cuts so it needs to be called first *) let res = - Structures.mkTrace step_to_coq next carray clist cnil ccons cpair !nc step def_step r + CoqInterface.mkTrace step_to_coq next carray clist cnil ccons cpair !nc step def_step r in (res, last_root, !cuts) diff --git a/src/trace/smtTrace.mli b/src/trace/smtTrace.mli index 06dc6a3..895cdc9 100644 --- a/src/trace/smtTrace.mli +++ b/src/trace/smtTrace.mli @@ -48,26 +48,26 @@ val alloc : 'a SmtCertif.clause -> int val naive_alloc : 'a SmtCertif.clause -> int val build_certif : 'a SmtCertif.clause -> 'b SmtCertif.clause -> int val to_coq : - ('a -> Structures.constr) -> - ('a list list * 'a list -> Structures.types) -> - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t * Structures.constr Lazy.t * - Structures.constr Lazy.t * Structures.constr Lazy.t -> + ('a -> CoqInterface.constr) -> + ('a list list * 'a list -> CoqInterface.types) -> + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t * + CoqInterface.constr Lazy.t * CoqInterface.constr Lazy.t -> 'a SmtCertif.clause -> - ('a SmtCertif.clause -> Structures.types * Structures.constr) option -> - Structures.constr * 'a SmtCertif.clause * - (Structures.id * Structures.types) list + ('a SmtCertif.clause -> CoqInterface.types * CoqInterface.constr) option -> + CoqInterface.constr * 'a SmtCertif.clause * + (CoqInterface.id * CoqInterface.types) list module MakeOpt : diff --git a/src/verit/verit.ml b/src/verit/verit.ml index 3a5308b..c2fb186 100644 --- a/src/verit/verit.ml +++ b/src/verit/verit.ml @@ -193,25 +193,25 @@ let call_verit _ rt ro ra_quant rf_quant first lsmt = if l = "warning : proof_done: status is still open" then raise Unknown else if l = "Invalid memory reference" then - Structures.warning "verit-warning" ("veriT outputted the warning: " ^ l) + CoqInterface.warning "verit-warning" ("veriT outputted the warning: " ^ l) else if n >= 7 && String.sub l 0 7 = "warning" then - Structures.warning "verit-warning" ("veriT outputted the warning: " ^ (String.sub l 7 (n-7))) + CoqInterface.warning "verit-warning" ("veriT outputted the warning: " ^ (String.sub l 7 (n-7))) else if n >= 8 && String.sub l 0 8 = "error : " then - Structures.error ("veriT failed with the error: " ^ (String.sub l 8 (n-8))) + CoqInterface.error ("veriT failed with the error: " ^ (String.sub l 8 (n-8))) else - Structures.error ("veriT failed with the error: " ^ l) + CoqInterface.error ("veriT failed with the error: " ^ l) done with End_of_file -> () in try - if exit_code <> 0 then Structures.warning "verit-non-zero-exit-code" ("Verit.call_verit: command " ^ command ^ " exited with code " ^ string_of_int exit_code); + if exit_code <> 0 then CoqInterface.warning "verit-non-zero-exit-code" ("Verit.call_verit: command " ^ command ^ " exited with code " ^ string_of_int exit_code); raise_warnings_errors (); let res = import_trace ra_quant rf_quant logfilename (Some first) lsmt in close_in win; Sys.remove wname; res with x -> close_in win; Sys.remove wname; match x with - | Unknown -> Structures.error "veriT returns 'unknown'" - | VeritSyntax.Sat -> Structures.error "veriT found a counter-example" + | Unknown -> CoqInterface.error "veriT returns 'unknown'" + | VeritSyntax.Sat -> CoqInterface.error "veriT found a counter-example" | _ -> raise x let verit_logic = diff --git a/src/verit/verit.mli b/src/verit/verit.mli index 4583bbd..72566d2 100644 --- a/src/verit/verit.mli +++ b/src/verit/verit.mli @@ -11,13 +11,13 @@ val parse_certif : - Structures.id -> - Structures.id -> - Structures.id -> - Structures.id -> - Structures.id -> Structures.id -> Structures.id -> string -> string -> unit + CoqInterface.id -> + CoqInterface.id -> + CoqInterface.id -> + CoqInterface.id -> + CoqInterface.id -> CoqInterface.id -> CoqInterface.id -> string -> string -> unit val checker : string -> string -> unit val checker_debug : string -> string -> unit -val theorem : Structures.id -> string -> string -> unit -val tactic : EConstr.t -> Structures.constr_expr list -> Structures.tactic -val tactic_no_check : EConstr.t -> Structures.constr_expr list -> Structures.tactic +val theorem : CoqInterface.id -> string -> string -> unit +val tactic : EConstr.t -> CoqInterface.constr_expr list -> CoqInterface.tactic +val tactic_no_check : EConstr.t -> CoqInterface.constr_expr list -> CoqInterface.tactic diff --git a/src/verit/veritSyntax.ml b/src/verit/veritSyntax.ml index cb5b9a6..6ac88aa 100644 --- a/src/verit/veritSyntax.ml +++ b/src/verit/veritSyntax.ml @@ -150,7 +150,7 @@ let mkCongrPred p = (* Linear arithmetic *) let mkMicromega cl = - let _tbl, _f, cert = Lia.build_lia_certif cl in + let cert = Lia.build_lia_certif cl in let c = match cert with | None -> failwith "VeritSyntax.mkMicromega: micromega can't solve this" @@ -168,7 +168,7 @@ let mkSplArith orig cl = match orig.value with | Some [orig'] -> orig' | _ -> failwith "VeritSyntax.mkSplArith: wrong number of literals in the premise clause" in - let _tbl, _f, cert = Lia.build_lia_certif [Form.neg orig';res] in + let cert = Lia.build_lia_certif [Form.neg orig';res] in let c = match cert with | None -> failwith "VeritSyntax.mkSplArith: micromega can't solve this" @@ -493,7 +493,7 @@ let mk_clause (id,typ,value,ids_params) = let mk_clause cl = try mk_clause cl with Failure f -> - Structures.error ("SMTCoq was not able to check the certificate \ + CoqInterface.error ("SMTCoq was not able to check the certificate \ for the following reason.\n"^f) let apply_dec f (decl, a) = decl, f a diff --git a/src/versions/native/Make b/src/versions/native/Make deleted file mode 100644 index e278c82..0000000 --- a/src/versions/native/Make +++ /dev/null @@ -1,171 +0,0 @@ -######################################################################## -## This file is intended to developers, please do not use it to ## -## generate a Makefile, rather use the provided Makefile. ## -######################################################################## - - - - -######################################################################## -## To generate the Makefile: ## -## coq_makefile -f Make -o Makefile ## -## In the Makefile : ## -## 1) Suppress the "Makefile" target ## -## 2) Change the "all" target into: ## -## all: ml $(CMXFILES) $(CMXA) $(CMXS) $(VOFILES) ## -## 3) Change the "install-natdynlink" target: ## -## change CMXSFILES into CMXS and add the same block for CMXA and VCMXS. ## -## 4) Change the "install" target: change CMOFILES into CMXFILES. ## -## 5) Add to the "clean" target: ## -## - rm -f NSMTCoq* cnf/NSMTCoq* euf/NSMTCoq* lia/NSMTCoq* spl/NSMTCoq* ../unit-tests/NSMTCoq* ../unit-tests/*.vo ../unit-tests/*.zlog ../unit-tests/*.vtlog verit/veritParser.mli verit/veritParser.ml verit/veritLexer.ml ../3rdparty/alt-ergo/smtlib2_parse.mli ../3rdparty/alt-ergo/smtlib2_parse.ml ../3rdparty/alt-ergo/smtlib2_lex.ml smtlib2/sExprParser.mli smtlib2/sExprParser.ml smtlib2/sExprLexer.ml lfsc/lfscLexer.ml lfsc/lfscParser.ml lfsc/lfscParser.mli trace/smtcoq.a ## -######################################################################## - - --R . SMTCoq - --I bva --I classes --I array --I cnf --I euf --I lfsc --I lia --I smtlib2 --I trace --I verit --I zchaff --I versions/native --I ../3rdparty/alt-ergo - - --custom "cd ../unit-tests; make vernac" "" "test" --custom "cd ../unit-tests; make zchaffv" "" "ztest" --custom "cd ../unit-tests; make veritv" "" "vtest" - --custom "$(CAMLLEX) $<" "%.mll" "%.ml" --custom "$(CAMLYACC) $<" "%.mly" "%.ml %.mli" --custom "" "verit/veritParser.ml verit/veritLexer.ml ../3rdparty/alt-ergo/smtlib2_parse.ml ../3rdparty/alt-ergo/smtlib2_lex.ml smtlib2/sExprParser.ml smtlib2/sExprLexer.ml lfsc/lfscParser.ml lfsc/lfscLexer.ml" "ml" - --custom "$(CAMLOPTLINK) $(ZFLAGS) -a -o $@ $^" "versions/native/structures.cmx trace/smtMisc.cmx trace/coqTerms.cmx trace/smtBtype.cmx trace/smtForm.cmx trace/smtCertif.cmx trace/smtTrace.cmx trace/smtCnf.cmx trace/satAtom.cmx trace/smtAtom.cmx trace/smtMaps.cmx zchaff/satParser.cmx zchaff/zchaffParser.cmx zchaff/cnfParser.cmx zchaff/zchaff.cmx ../3rdparty/alt-ergo/smtlib2_util.cmx ../3rdparty/alt-ergo/smtlib2_ast.cmx ../3rdparty/alt-ergo/smtlib2_parse.cmx ../3rdparty/alt-ergo/smtlib2_lex.cmx smtlib2/sExpr.cmx smtlib2/sExprParser.cmx smtlib2/sExprLexer.cmx smtlib2/smtlib2_solver.cmx lia/lia.cmx verit/veritSyntax.cmx verit/veritParser.cmx verit/veritLexer.cmx lfsc/shashcons.cmx lfsc/hstring.cmx lfsc/type.cmx lfsc/ast.cmx lfsc/builtin.cmx lfsc/tosmtcoq.cmx lfsc/converter.cmx lfsc/lfscParser.cmx lfsc/lfscLexer.cmx smtlib2/smtlib2_genConstr.cmx trace/smtCommands.cmx verit/verit.cmx lfsc/lfsc.cmx smtcoq_plugin.cmx" "$(CMXA)" --custom "$(CAMLOPTLINK) $(ZFLAGS) -o $@ -linkall -shared $^" "$(CMXA)" "$(CMXS)" - -CMXA = smtcoq.cmxa -CMXS = smtcoq_plugin.cmxs -VCMXS = "versions/native/NSMTCoq_versions_native_Structures.cmxs NSMTCoq_State.cmxs NSMTCoq_Misc.cmxs classes/NSMTCoq_SMT_classes.cmxs classes/NSMTCoq_SMT_classes_instances.cmxs NSMTCoq_SMT_terms.cmxs cnf/NSMTCoq_cnf_Cnf.cmxs euf/NSMTCoq_euf_Euf.cmxs lia/NSMTCoq_lia_Lia.cmxs spl/NSMTCoq_spl_Syntactic.cmxs spl/NSMTCoq_spl_Assumptions.cmxs spl/NSMTCoq_spl_Arithmetic.cmxs spl/NSMTCoq_spl_Operators.cmxs NSMTCoq_Trace.cmxs NSMTCoq_Tactics.cmxs NSMTCoq_Conversion_tactics.cmxs NSMTCoq_PropToBool.cmxs NSMTCoq_BoolToProp.cmxs NSMTCoq_SMTCoq.cmxs NSMTCoq_State.cmi NSMTCoq_Misc.cmi classes/NSMTCoq_SMT_classes.cmi classes/NSMTCoq_SMT_classes_instances.cmi NSMTCoq_SMT_terms.cmi cnf/NSMTCoq_cnf_Cnf.cmi euf/NSMTCoq_euf_Euf.cmi lia/NSMTCoq_lia_Lia.cmi spl/NSMTCoq_spl_Syntactic.cmi spl/NSMTCoq_spl_Assumptions.cmi spl/NSMTCoq_spl_Arithmetic.cmi spl/NSMTCoq_spl_Operators.cmi NSMTCoq_Trace.cmi NSMTCoq_Trace.cmi NSMTCoq_Tactics.cmi NSMTCoq_Conversion_tactics.cmi NSMTCoq_PropToBool.cmi NSMTCoq_BoolToProp.cmi NSMTCoq_SMTCoq.cmi" -CAMLLEX = $(CAMLBIN)ocamllex -CAMLYACC = $(CAMLBIN)ocamlyacc - -bva/BVList.v -bva/Bva_checker.v - -classes/SMT_classes.v -classes/SMT_classes_instances.v - -array/FArray.v -array/Array_checker.v - -versions/native/Structures.v -versions/native/structures.ml -versions/native/structures.mli - -trace/coqTerms.ml -trace/coqTerms.mli -trace/satAtom.ml -trace/satAtom.mli -trace/smtAtom.ml -trace/smtAtom.mli -trace/smtBtype.ml -trace/smtBtype.mli -trace/smtCertif.ml -trace/smtCertif.mli -trace/smtCnf.ml -trace/smtCnf.mli -trace/smtCommands.ml -trace/smtCommands.mli -trace/smtForm.ml -trace/smtForm.mli -trace/smtMaps.ml -trace/smtMaps.mli -trace/smtMisc.ml -trace/smtMisc.mli -trace/smtTrace.ml -trace/smtTrace.mli - -../3rdparty/alt-ergo/smtlib2_parse.ml -../3rdparty/alt-ergo/smtlib2_parse.mli -../3rdparty/alt-ergo/smtlib2_lex.ml -../3rdparty/alt-ergo/smtlib2_lex.mli -../3rdparty/alt-ergo/smtlib2_ast.ml -../3rdparty/alt-ergo/smtlib2_ast.mli -../3rdparty/alt-ergo/smtlib2_util.ml -../3rdparty/alt-ergo/smtlib2_util.mli - -smtlib2/smtlib2_genConstr.ml -smtlib2/smtlib2_genConstr.mli -smtlib2/sExprParser.ml -smtlib2/sExprParser.mli -smtlib2/sExprLexer.ml -smtlib2/sExpr.ml -smtlib2/sExpr.mli -smtlib2/smtlib2_solver.ml -smtlib2/smtlib2_solver.mli - -verit/veritParser.ml -verit/veritParser.mli -verit/veritLexer.ml -verit/veritLexer.mli -verit/verit.ml -verit/verit.mli -verit/veritSyntax.ml -verit/veritSyntax.mli - -lfsc/shashcons.mli -lfsc/shashcons.ml -lfsc/hstring.mli -lfsc/hstring.ml -lfsc/lfscParser.ml -lfsc/lfscLexer.ml -lfsc/type.ml -lfsc/ast.ml -lfsc/ast.mli -lfsc/translator_sig.mli -lfsc/builtin.ml -lfsc/tosmtcoq.ml -lfsc/tosmtcoq.mli -lfsc/converter.ml -lfsc/lfsc.ml - -zchaff/cnfParser.ml -zchaff/cnfParser.mli -zchaff/satParser.ml -zchaff/satParser.mli -zchaff/zchaff.ml -zchaff/zchaff.mli -zchaff/zchaffParser.ml -zchaff/zchaffParser.mli - -cnf/Cnf.v - -euf/Euf.v - -lia/lia.ml -lia/lia.mli -lia/Lia.v - -spl/Assumptions.v -spl/Syntactic.v -spl/Arithmetic.v -spl/Operators.v - -Conversion_tactics.v -Misc.v -SMTCoq.v -ReflectFacts.v -PropToBool.v -BoolToProp.v -Tactics.v -SMT_terms.v -State.v -Trace.v - -smtcoq_plugin.ml4 diff --git a/src/versions/native/Makefile b/src/versions/native/Makefile deleted file mode 100644 index aaaab9e..0000000 --- a/src/versions/native/Makefile +++ /dev/null @@ -1,505 +0,0 @@ -############################################################################# -## v # The Coq Proof Assistant ## -## <O___,, # INRIA - CNRS - LIX - LRI - PPS ## -## \VV/ # ## -## // # Makefile automagically generated by coq_makefile Vtrunk ## -############################################################################# - -# WARNING -# -# This Makefile has been automagically generated -# Edit at your own risks ! -# -# END OF WARNING - -# -# This Makefile was generated by the command line : -# coq_makefile -f Make -o Makefile -# - -.DEFAULT_GOAL := all - -# -# This Makefile may take arguments passed as environment variables: -# COQBIN to specify the directory where Coq binaries resides; -# ZDEBUG/COQDEBUG to specify debug flags for ocamlc&ocamlopt/coqc; -# DSTROOT to specify a prefix to install path. - -# Here is a hack to make $(eval $(shell works: -define donewline - - -endef -includecmdwithout@ = $(eval $(subst @,$(donewline),$(shell { $(1) | tr '\n' '@'; }))) -$(call includecmdwithout@,$(COQBIN)coqtop -config) - -########################## -# # -# Libraries definitions. # -# # -########################## - -OCAMLLIBS?=-I ../3rdparty/alt-ergo\ - -I versions/native\ - -I zchaff\ - -I verit\ - -I trace\ - -I smtlib2\ - -I lia\ - -I lfsc\ - -I euf\ - -I cnf\ - -I array\ - -I classes\ - -I bva -COQLIBS?=-I ../3rdparty/alt-ergo\ - -I versions/native\ - -I zchaff\ - -I verit\ - -I trace\ - -I smtlib2\ - -I lia\ - -I lfsc\ - -I euf\ - -I cnf\ - -I array\ - -I classes\ - -I bva -R . SMTCoq -COQDOCLIBS?=-R . SMTCoq - -########################## -# # -# Variables definitions. # -# # -########################## - -CAMLYACC=$(CAMLBIN)ocamlyacc -CAMLLEX=$(CAMLBIN)ocamllex -VCMXS=versions/native/NSMTCoq_versions_native_Structures.cmxs NSMTCoq_State.cmxs NSMTCoq_Misc.cmxs classes/NSMTCoq_SMT_classes.cmxs classes/NSMTCoq_SMT_classes_instances.cmxs NSMTCoq_SMT_terms.cmxs cnf/NSMTCoq_cnf_Cnf.cmxs euf/NSMTCoq_euf_Euf.cmxs lia/NSMTCoq_lia_Lia.cmxs spl/NSMTCoq_spl_Syntactic.cmxs spl/NSMTCoq_spl_Assumptions.cmxs spl/NSMTCoq_spl_Arithmetic.cmxs spl/NSMTCoq_spl_Operators.cmxs NSMTCoq_Trace.cmxs NSMTCoq_Tactics.cmxs NSMTCoq_Conversion_tactics.cmxs NSMTCoq_PropToBool.cmxs NSMTCoq_BoolToProp.cmxs NSMTCoq_SMTCoq.cmxs NSMTCoq_State.cmi NSMTCoq_Misc.cmi classes/NSMTCoq_SMT_classes.cmi classes/NSMTCoq_SMT_classes_instances.cmi NSMTCoq_SMT_terms.cmi cnf/NSMTCoq_cnf_Cnf.cmi euf/NSMTCoq_euf_Euf.cmi lia/NSMTCoq_lia_Lia.cmi spl/NSMTCoq_spl_Syntactic.cmi spl/NSMTCoq_spl_Assumptions.cmi spl/NSMTCoq_spl_Arithmetic.cmi spl/NSMTCoq_spl_Operators.cmi NSMTCoq_Trace.cmi NSMTCoq_Trace.cmi NSMTCoq_Tactics.cmi NSMTCoq_Conversion_tactics.cmi NSMTCoq_PropToBool.cmi NSMTCoq_BoolToProp.cmi NSMTCoq_SMTCoq.cmi -CMXS=smtcoq_plugin.cmxs -CMXA=smtcoq.cmxa - -OPT?= -COQDEP?=$(COQBIN)coqdep -c -COQFLAGS?=-q $(OPT) $(COQLIBS) $(OTHERFLAGS) $(COQ_XML) -COQCHKFLAGS?=-silent -o -COQDOCFLAGS?=-interpolate -utf8 -COQC?=$(COQBIN)coqc -GALLINA?=$(COQBIN)gallina -COQDOC?=$(COQBIN)coqdoc -COQCHK?=$(COQBIN)coqchk - -COQSRCLIBS?=-I $(COQLIB)kernel -I $(COQLIB)lib \ - -I $(COQLIB)library -I $(COQLIB)parsing \ - -I $(COQLIB)pretyping -I $(COQLIB)interp \ - -I $(COQLIB)proofs -I $(COQLIB)tactics \ - -I $(COQLIB)toplevel \ - -I $(COQLIB)plugins/btauto \ - -I $(COQLIB)plugins/cc \ - -I $(COQLIB)plugins/decl_mode \ - -I $(COQLIB)plugins/extraction \ - -I $(COQLIB)plugins/field \ - -I $(COQLIB)plugins/firstorder \ - -I $(COQLIB)plugins/fourier \ - -I $(COQLIB)plugins/funind \ - -I $(COQLIB)plugins/micromega \ - -I $(COQLIB)plugins/nsatz \ - -I $(COQLIB)plugins/omega \ - -I $(COQLIB)plugins/quote \ - -I $(COQLIB)plugins/ring \ - -I $(COQLIB)plugins/romega \ - -I $(COQLIB)plugins/rtauto \ - -I $(COQLIB)plugins/setoid_ring \ - -I $(COQLIB)plugins/syntax \ - -I $(COQLIB)plugins/xml -ZFLAGS=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP4LIB) - -CAMLC?=$(OCAMLC) -c -rectypes -CAMLOPTC?=$(OCAMLOPT) -c -rectypes -CAMLLINK?=$(OCAMLC) -rectypes -CAMLOPTLINK?=$(OCAMLOPT) -rectypes -GRAMMARS?=grammar.cma -CAMLP4EXTEND?=pa_extend.cmo pa_macro.cmo q_MLast.cmo -CAMLP4OPTIONS?=-loc loc -PP?=-pp "$(CAMLP4BIN)$(CAMLP4)o -I $(CAMLLIB) -I . $(COQSRCLIBS) $(CAMLP4EXTEND) $(GRAMMARS) $(CAMLP4OPTIONS) -impl" - -################## -# # -# Install Paths. # -# # -################## - -ifdef USERINSTALL -XDG_DATA_HOME?=$(HOME)/.local/share -COQLIBINSTALL=$(XDG_DATA_HOME)/coq -COQDOCINSTALL=$(XDG_DATA_HOME)/doc/coq -else -COQLIBINSTALL=${COQLIB}user-contrib -COQDOCINSTALL=${DOCDIR}user-contrib -endif - -###################### -# # -# Files dispatching. # -# # -###################### - -VFILES:=Trace.v\ - State.v\ - SMT_terms.v\ - Tactics.v\ - BoolToProp.v\ - PropToBool.v\ - ReflectFacts.v\ - SMTCoq.v\ - Misc.v\ - Conversion_tactics.v\ - spl/Operators.v\ - spl/Arithmetic.v\ - spl/Syntactic.v\ - spl/Assumptions.v\ - lia/Lia.v\ - euf/Euf.v\ - cnf/Cnf.v\ - versions/native/Structures.v\ - array/Array_checker.v\ - array/FArray.v\ - classes/SMT_classes_instances.v\ - classes/SMT_classes.v\ - bva/Bva_checker.v\ - bva/BVList.v - --include $(addsuffix .d,$(VFILES)) -.SECONDARY: $(addsuffix .d,$(VFILES)) - -vo_to_obj = $(addsuffix .o,$(foreach vo,$(1),$(addprefix $(dir $(vo)),$(filter-out Warning: Error:,$(firstword $(shell $(COQBIN)coqtop -batch -quiet -print-mod-uid $(vo:.vo=))))))) -VOFILES:=$(foreach vo,$(VFILES:.v=.vo),$(dir $(vo))$(notdir $(vo))) -GLOBFILES:=$(VFILES:.v=.glob) -VIFILES:=$(VFILES:.v=.vi) -GFILES:=$(VFILES:.v=.g) -HTMLFILES:=$(VFILES:.v=.html) -GHTMLFILES:=$(VFILES:.v=.g.html) -OBJFILES:=$(call vo_to_obj,$(VOFILES)) -ML4FILES:=smtcoq_plugin.ml4 - --include $(addsuffix .d,$(ML4FILES)) -.SECONDARY: $(addsuffix .d,$(ML4FILES)) - -MLFILES:=lia/lia.ml\ - zchaff/zchaffParser.ml\ - zchaff/zchaff.ml\ - zchaff/satParser.ml\ - zchaff/cnfParser.ml\ - lfsc/lfsc.ml\ - lfsc/converter.ml\ - lfsc/tosmtcoq.ml\ - lfsc/builtin.ml\ - lfsc/ast.ml\ - lfsc/type.ml\ - lfsc/lfscLexer.ml\ - lfsc/lfscParser.ml\ - lfsc/hstring.ml\ - lfsc/shashcons.ml\ - verit/veritSyntax.ml\ - verit/verit.ml\ - verit/veritLexer.ml\ - verit/veritParser.ml\ - smtlib2/smtlib2_solver.ml\ - smtlib2/sExpr.ml\ - smtlib2/sExprLexer.ml\ - smtlib2/sExprParser.ml\ - smtlib2/smtlib2_genConstr.ml\ - ../3rdparty/alt-ergo/smtlib2_util.ml\ - ../3rdparty/alt-ergo/smtlib2_ast.ml\ - ../3rdparty/alt-ergo/smtlib2_lex.ml\ - ../3rdparty/alt-ergo/smtlib2_parse.ml\ - trace/smtTrace.ml\ - trace/smtMisc.ml\ - trace/smtMaps.ml\ - trace/smtForm.ml\ - trace/smtCommands.ml\ - trace/smtCnf.ml\ - trace/smtCertif.ml\ - trace/smtBtype.ml\ - trace/smtAtom.ml\ - trace/satAtom.ml\ - trace/coqTerms.ml\ - versions/native/structures.ml - --include $(addsuffix .d,$(MLFILES)) -.SECONDARY: $(addsuffix .d,$(MLFILES)) - -MLIFILES:=lia/lia.mli\ - zchaff/zchaffParser.mli\ - zchaff/zchaff.mli\ - zchaff/satParser.mli\ - zchaff/cnfParser.mli\ - lfsc/tosmtcoq.mli\ - lfsc/translator_sig.mli\ - lfsc/ast.mli\ - lfsc/hstring.mli\ - lfsc/shashcons.mli\ - verit/veritSyntax.mli\ - verit/verit.mli\ - verit/veritLexer.mli\ - verit/veritParser.mli\ - smtlib2/smtlib2_solver.mli\ - smtlib2/sExpr.mli\ - smtlib2/sExprParser.mli\ - smtlib2/smtlib2_genConstr.mli\ - ../3rdparty/alt-ergo/smtlib2_util.mli\ - ../3rdparty/alt-ergo/smtlib2_ast.mli\ - ../3rdparty/alt-ergo/smtlib2_lex.mli\ - ../3rdparty/alt-ergo/smtlib2_parse.mli\ - trace/smtTrace.mli\ - trace/smtMisc.mli\ - trace/smtMaps.mli\ - trace/smtForm.mli\ - trace/smtCommands.mli\ - trace/smtCnf.mli\ - trace/smtCertif.mli\ - trace/smtBtype.mli\ - trace/smtAtom.mli\ - trace/satAtom.mli\ - trace/coqTerms.mli\ - versions/native/structures.mli - --include $(addsuffix .d,$(MLIFILES)) -.SECONDARY: $(addsuffix .d,$(MLIFILES)) - -ALLCMOFILES:=$(ML4FILES:.ml4=.cmo) $(MLFILES:.ml=.cmo) -CMOFILES=$(filter-out $(addsuffix .cmo,$(foreach lib,$(MLLIBFILES:.mllib=_MLLIB_DEPENDENCIES) $(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES),$($(lib)))),$(ALLCMOFILES)) -CMXFILES=$(CMOFILES:.cmo=.cmx) -CMIFILES=$(sort $(ALLCMOFILES:.cmo=.cmi) $(MLIFILES:.mli=.cmi)) -CMXSFILES=$(CMXFILES:.cmx=.cmxs) - -####################################### -# # -# Definition of the toplevel targets. # -# # -####################################### - -all: ml $(CMXFILES) $(CMXA) $(CMXS) $(VOFILES) - -mlihtml: $(MLIFILES:.mli=.cmi) - mkdir $@ || rm -rf $@/* - $(OCAMLDOC) -html -rectypes -d $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli) - -all-mli.tex: $(MLIFILES:.mli=.cmi) - $(OCAMLDOC) -latex -rectypes -o $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli) - -spec: $(VIFILES) - -gallina: $(GFILES) - -html: $(GLOBFILES) $(VFILES) - - mkdir -p html - $(COQDOC) -toc $(COQDOCFLAGS) -html $(COQDOCLIBS) -d html $(VFILES) - -gallinahtml: $(GLOBFILES) $(VFILES) - - mkdir -p html - $(COQDOC) -toc $(COQDOCFLAGS) -html -g $(COQDOCLIBS) -d html $(VFILES) - -all.ps: $(VFILES) - $(COQDOC) -toc $(COQDOCFLAGS) -ps $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^` - -all-gal.ps: $(VFILES) - $(COQDOC) -toc $(COQDOCFLAGS) -ps -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^` - -all.pdf: $(VFILES) - $(COQDOC) -toc $(COQDOCFLAGS) -pdf $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^` - -all-gal.pdf: $(VFILES) - $(COQDOC) -toc $(COQDOCFLAGS) -pdf -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^` - -validate: $(VOFILES) - $(COQCHK) $(COQCHKFLAGS) $(COQLIBS) $(notdir $(^:.vo=)) - -beautify: $(VFILES:=.beautified) - for file in $^; do mv $${file%.beautified} $${file%beautified}old && mv $${file} $${file%.beautified}; done - @echo 'Do not do "make clean" until you are sure that everything went well!' - @echo 'If there were a problem, execute "for file in $$(find . -name \*.v.old -print); do mv $${file} $${file%.old}; done" in your shell/' - -.PHONY: all opt byte archclean clean install userinstall depend html validate - -################### -# # -# Custom targets. # -# # -################### - -$(CMXS): $(CMXA) - $(CAMLOPTLINK) $(ZFLAGS) -o $@ -linkall -shared $^ - -$(CMXA): versions/native/structures.cmx trace/smtMisc.cmx trace/coqTerms.cmx trace/smtBtype.cmx trace/smtForm.cmx trace/smtCertif.cmx trace/smtTrace.cmx trace/smtCnf.cmx trace/satAtom.cmx trace/smtAtom.cmx trace/smtMaps.cmx zchaff/satParser.cmx zchaff/zchaffParser.cmx zchaff/cnfParser.cmx zchaff/zchaff.cmx ../3rdparty/alt-ergo/smtlib2_util.cmx ../3rdparty/alt-ergo/smtlib2_ast.cmx ../3rdparty/alt-ergo/smtlib2_parse.cmx ../3rdparty/alt-ergo/smtlib2_lex.cmx smtlib2/sExpr.cmx smtlib2/sExprParser.cmx smtlib2/sExprLexer.cmx smtlib2/smtlib2_solver.cmx lia/lia.cmx verit/veritSyntax.cmx verit/veritParser.cmx verit/veritLexer.cmx lfsc/shashcons.cmx lfsc/hstring.cmx lfsc/type.cmx lfsc/ast.cmx lfsc/builtin.cmx lfsc/tosmtcoq.cmx lfsc/converter.cmx lfsc/lfscParser.cmx lfsc/lfscLexer.cmx smtlib2/smtlib2_genConstr.cmx trace/smtCommands.cmx verit/verit.cmx lfsc/lfsc.cmx smtcoq_plugin.cmx - $(CAMLOPTLINK) $(ZFLAGS) -a -o $@ $^ - -ml: verit/veritParser.ml verit/veritLexer.ml ../3rdparty/alt-ergo/smtlib2_parse.ml ../3rdparty/alt-ergo/smtlib2_lex.ml smtlib2/sExprParser.ml smtlib2/sExprLexer.ml lfsc/lfscParser.ml lfsc/lfscLexer.ml - - -%.ml %.mli: %.mly - $(CAMLYACC) $< - -%.ml: %.mll - $(CAMLLEX) $< - -vtest: - cd ../unit-tests; make veritv - -ztest: - cd ../unit-tests; make zchaffv - -test: - cd ../unit-tests; make vernac - -#################### -# # -# Special targets. # -# # -#################### - -byte: - $(MAKE) all "OPT:=-byte" - -opt: - $(MAKE) all "OPT:=-opt" - -userinstall: - +$(MAKE) USERINSTALL=true install - -install-natdynlink: - for i in $(CMXS); do \ - install -d `dirname $(DSTROOT)$(COQLIBINSTALL)/SMTCoq/$$i`; \ - install -m 0644 $$i $(DSTROOT)$(COQLIBINSTALL)/SMTCoq/$$i; \ - done - for i in $(CMXA); do \ - install -d `dirname $(DSTROOT)$(COQLIBINSTALL)/SMTCoq/$$i`; \ - install -m 0644 $$i $(DSTROOT)$(COQLIBINSTALL)/SMTCoq/$$i; \ - done - for i in $(VCMXS); do \ - install -d `dirname $(DSTROOT)$(COQLIBINSTALL)/SMTCoq/$$i`; \ - install -m 0644 $$i $(DSTROOT)$(COQLIBINSTALL)/SMTCoq/$$i; \ - done - -install:$(if ifeq '$(HASNATDYNLINK)' 'true',install-natdynlink) - for i in $(VOFILES) $(OBJFILES) $(OBJFILES:.o=.cm*); do \ - install -d `dirname $(DSTROOT)$(COQLIBINSTALL)/SMTCoq/$$i`; \ - install -m 0644 $$i $(DSTROOT)$(COQLIBINSTALL)/SMTCoq/$$i; \ - done - for i in $(CMXFILES); do \ - install -d `dirname $(DSTROOT)$(COQLIBINSTALL)/SMTCoq/$$i`; \ - install -m 0644 $$i $(DSTROOT)$(COQLIBINSTALL)/SMTCoq/$$i; \ - done - for i in $(CMIFILES); do \ - install -d `dirname $(DSTROOT)$(COQLIBINSTALL)/SMTCoq/$$i`; \ - install -m 0644 $$i $(DSTROOT)$(COQLIBINSTALL)/SMTCoq/$$i; \ - done - -install-doc: - install -d $(DSTROOT)$(COQDOCINSTALL)/SMTCoq/html - for i in html/*; do \ - install -m 0644 $$i $(DSTROOT)$(COQDOCINSTALL)/SMTCoq/$$i;\ - done - install -d $(DSTROOT)$(COQDOCINSTALL)/SMTCoq/mlihtml - for i in mlihtml/*; do \ - install -m 0644 $$i $(DSTROOT)$(COQDOCINSTALL)/SMTCoq/$$i;\ - done - -clean: - rm -f $(ALLCMOFILES) $(CMIFILES) $(CMAFILES) - rm -f $(ALLCMOFILES:.cmo=.cmx) $(CMXAFILES) $(CMXSFILES) $(ALLCMOFILES:.cmo=.o) $(CMXAFILES:.cmxa=.a) - rm -f $(addsuffix .d,$(MLFILES) $(MLIFILES) $(ML4FILES) $(MLLIBFILES) $(MLPACKFILES)) - rm -f $(OBJFILES) $(OBJFILES:.o=.native) - rm -f $(OBJFILES:.o=.cmi) $(OBJFILES:.o=.cmo) - rm -f $(OBJFILES:.o=.cmx) $(OBJFILES:.o=.cmxs) - rm -f $(VOFILES) $(VIFILES) $(GFILES) $(VFILES:.v=.v.d) $(VFILES:=.beautified) $(VFILES:=.old) - rm -f all.ps all-gal.ps all.pdf all-gal.pdf all.glob $(VFILES:.v=.glob) $(VFILES:.v=.tex) $(VFILES:.v=.g.tex) all-mli.tex - - rm -rf html mlihtml - - rm -rf $(CMXS) - - rm -rf $(CMXA) - - rm -rf ml - - rm -rf vtest - - rm -rf ztest - - rm -rf test - - rm -f NSMTCoq* cnf/NSMTCoq* euf/NSMTCoq* lia/NSMTCoq* spl/NSMTCoq* ../unit-tests/NSMTCoq* ../unit-tests/*.vo ../unit-tests/*.zlog ../unit-tests/*.vtlog verit/veritParser.mli verit/veritParser.ml verit/veritLexer.ml ../3rdparty/alt-ergo/smtlib2_parse.mli ../3rdparty/alt-ergo/smtlib2_parse.ml ../3rdparty/alt-ergo/smtlib2_lex.ml smtlib2/sExprParser.mli smtlib2/sExprParser.ml smtlib2/sExprLexer.ml lfsc/lfscLexer.ml lfsc/lfscParser.ml lfsc/lfscParser.mli trace/smtcoq.a - -archclean: - rm -f *.cmx *.o - -printenv: - @$(COQBIN)coqtop -config - @echo CAMLC = $(CAMLC) - @echo CAMLOPTC = $(CAMLOPTC) - @echo PP = $(PP) - @echo COQFLAGS = $(COQFLAGS) - @echo COQLIBINSTALL = $(COQLIBINSTALL) - @echo COQDOCINSTALL = $(COQDOCINSTALL) - - -################### -# # -# Implicit rules. # -# # -################### - -%.cmi: %.mli - $(CAMLC) $(ZDEBUG) $(ZFLAGS) $< - -%.mli.d: %.mli - $(OCAMLDEP) -slash $(OCAMLLIBS) "$<" > "$@" || ( RV=$$?; rm -f "$@"; exit $${RV} ) - -%.cmo: %.ml4 - $(CAMLC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $< - -%.cmx: %.ml4 - $(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $< - -%.ml4.d: %.ml4 - $(OCAMLDEP) -slash $(OCAMLLIBS) $(PP) -impl "$<" > "$@" || ( RV=$$?; rm -f "$@"; exit $${RV} ) - -%.cmo: %.ml - $(CAMLC) $(ZDEBUG) $(ZFLAGS) $< - -%.cmx: %.ml - $(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $< - -%.ml.d: %.ml - $(OCAMLDEP) -slash $(OCAMLLIBS) "$<" > "$@" || ( RV=$$?; rm -f "$@"; exit $${RV} ) - -%.cmxs: %.cmx - $(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -shared -o $@ $< - -%.vo %.glob: %.v - $(COQC) $(COQDEBUG) $(COQFLAGS) $* - -%.vi: %.v - $(COQC) -i $(COQDEBUG) $(COQFLAGS) $* - -%.g: %.v - $(GALLINA) $< - -%.tex: %.v - $(COQDOC) $(COQDOCFLAGS) -latex $< -o $@ - -%.html: %.v %.glob - $(COQDOC) $(COQDOCFLAGS) -html $< -o $@ - -%.g.tex: %.v - $(COQDOC) $(COQDOCFLAGS) -latex -g $< -o $@ - -%.g.html: %.v %.glob - $(COQDOC)$(COQDOCFLAGS) -html -g $< -o $@ - -%.v.d: %.v - $(COQDEP) -slash $(COQLIBS) "$<" > "$@" || ( RV=$$?; rm -f "$@"; exit $${RV} ) - -%.v.beautified: - $(COQC) $(COQDEBUG) $(COQFLAGS) -beautify $* - -# WARNING -# -# This Makefile has been automagically generated -# Edit at your own risks ! -# -# END OF WARNING - diff --git a/src/versions/native/Structures_native.v b/src/versions/native/Structures_native.v deleted file mode 100644 index a77832d..0000000 --- a/src/versions/native/Structures_native.v +++ /dev/null @@ -1,59 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2022 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -Require Import PArray. - - -Section Trace. - - (* We use [array array step] to allow bigger trace *) - Definition trace (step:Type) := array (array step). - - Definition trace_to_list {step:Type} (t:trace step) : list step := - PArray.fold_left (fun res a => List.app res (PArray.to_list a)) nil t. - - Definition trace_length {step:Type} (t:trace step) : int := - PArray.fold_left (fun l a => (l + (length a))%int63) 0%int63 t. - - Definition trace_get {step:Type} (t:trace step) (i:int) : step := - snd (PArray.fold_left (fun (jres:(option int) * step) a => - let (j,res) := jres in - match j with - | Some j' => - let l := length a in - if (j' < l)%int63 then - (None, get a j') - else - ((Some ((j' - l)%int63)),res) - | None => (None,res) - end - ) (Some i, (get (get t 0) 0)) t). - - Definition trace_fold {state step:Type} (transition: state -> step -> state) (s0:state) (t:trace step) := - PArray.fold_left (PArray.fold_left transition) s0 t. - - Lemma trace_fold_ind (state step : Type) (P : state -> Prop) (transition : state -> step -> state) (t : trace step) - (IH: forall (s0 : state) (i : int), (i < trace_length t)%int63 = true -> P s0 -> P (transition s0 (trace_get t i))) : - forall s0 : state, P s0 -> P (trace_fold transition s0 t). - Proof. - apply PArray.fold_left_ind. - intros a i Hi Ha. - apply PArray.fold_left_ind;trivial. - intros a0 i0 Hi0 Ha0. (* IH applied to a0 and (sum of the lengths of the first i arrays + i0) *) - Admitted. - -End Trace. - - -Definition nat_eqb := beq_nat. -Definition nat_eqb_eq := beq_nat_true_iff. -Definition nat_eqb_refl := NPeano.Nat.eqb_refl. diff --git a/src/versions/native/Tactics_native.v b/src/versions/native/Tactics_native.v deleted file mode 100644 index 9b8d670..0000000 --- a/src/versions/native/Tactics_native.v +++ /dev/null @@ -1,55 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2022 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -Require Import Psatz. - -Declare ML Module "smtcoq_plugin". - - - -Tactic Notation "verit_bool" constr_list(h) := - fail "Tactics are not supported with native-coq". - -Tactic Notation "verit_bool_no_check" constr_list(h) := - fail "Tactics are not supported with native-coq". - - -(** Tactics in Prop **) - -Ltac zchaff := - fail "Tactics are not supported with native-coq". -Ltac zchaff_no_check := - fail "Tactics are not supported with native-coq". - -Tactic Notation "verit" constr_list(h) := - fail "Tactics are not supported with native-coq". -Tactic Notation "verit_no_check" constr_list(h) := - fail "Tactics are not supported with native-coq". - -Ltac cvc4 := - fail "Tactics are not supported with native-coq". -Ltac cvc4_no_check := - fail "Tactics are not supported with native-coq". - - -Tactic Notation "smt" constr_list(h) := - fail "Tactics are not supported with native-coq". -Tactic Notation "smt_no_check" constr_list(h) := - fail "Tactics are not supported with native-coq". - - - -(* - Local Variables: - coq-load-path: ((rec "../.." "SMTCoq")) - End: -*) diff --git a/src/versions/native/smtcoq_plugin_native.ml4 b/src/versions/native/smtcoq_plugin_native.ml4 deleted file mode 100644 index 6b05900..0000000 --- a/src/versions/native/smtcoq_plugin_native.ml4 +++ /dev/null @@ -1,99 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2022 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -VERNAC COMMAND EXTEND Vernac_zchaff -| [ "Parse_certif_zchaff" - ident(dimacs) ident(trace) string(fdimacs) string(fproof) ] -> - [ - Zchaff.parse_certif dimacs trace fdimacs fproof - ] -| [ "Zchaff_Checker" string(fdimacs) string(fproof) ] -> - [ - Zchaff.checker fdimacs fproof - ] -| [ "Zchaff_Theorem" ident(name) string(fdimacs) string(fproof) ] -> - [ - Zchaff.theorem name fdimacs fproof - ] -END - -VERNAC COMMAND EXTEND Vernac_zchaff_abs -| [ "Zchaff_Theorem_Abs" ident(name) string(fdimacs) string(fproof) ] -> - [ - Zchaff.theorem_abs name fdimacs fproof - ] -END - -VERNAC COMMAND EXTEND Vernac_verit -| [ "Parse_certif_verit" - ident(t_i) ident(t_func) ident(t_atom) ident(t_form) ident(root) ident(used_roots) ident(trace) string(fsmt) string(fproof) ] -> - [ - Verit.parse_certif t_i t_func t_atom t_form root used_roots trace fsmt fproof - ] -| [ "Verit_Checker" string(fsmt) string(fproof) ] -> - [ - Verit.checker fsmt fproof - ] -| [ "Verit_Checker_Debug" string(fsmt) string(fproof) ] -> - [ - Verit.checker_debug fsmt fproof - ] -| [ "Verit_Theorem" ident(name) string(fsmt) string(fproof) ] -> - [ - Verit.theorem name fsmt fproof - ] -END - -VERNAC COMMAND EXTEND Vernac_lfsc -| [ "Parse_certif_lfsc" - ident(t_i) ident(t_func) ident(t_atom) ident(t_form) ident(root) ident(used_roots) ident(trace) string(fsmt) string(fproof) ] -> - [ - Lfsc.parse_certif t_i t_func t_atom t_form root used_roots trace fsmt fproof - ] -| [ "Lfsc_Checker" string(fsmt) string(fproof) ] -> - [ - Lfsc.checker fsmt fproof - ] -| [ "Lfsc_Checker_Debug" string(fsmt) string(fproof) ] -> - [ - Lfsc.checker_debug fsmt fproof - ] -| [ "Lfsc_Theorem" ident(name) string(fsmt) string(fproof) ] -> - [ - Lfsc.theorem name fsmt fproof - ] -END - -TACTIC EXTEND Tactic_zchaff -| [ "zchaff_bool" ] -> [ Zchaff.tactic () ] -| [ "zchaff_bool_no_check" ] -> [ Zchaff.tactic_no_check () ] -END - -let lemmas_list = ref [] - -VERNAC COMMAND EXTEND Add_lemma -| [ "Add_lemmas" constr_list(lems) ] -> [ lemmas_list := lems @ !lemmas_list ] -| [ "Clear_lemmas" ] -> [ lemmas_list := [] ] -END - - -let error () = Structures.error "Tactics are not supported with native-coq" - -TACTIC EXTEND Tactic_verit -| [ "verit_bool_base" constr_list(lpl) ] -> [ error () ] -| [ "verit_bool_no_check_base" constr_list(lpl) ] -> [ error () ] -END - -TACTIC EXTEND Tactic_cvc4 -| [ "cvc4_bool" ] -> [ error () ] -| [ "cvc4_bool_no_check" ] -> [ error () ] -END diff --git a/src/versions/native/structures.ml b/src/versions/native/structures.ml deleted file mode 100644 index d34f3f3..0000000 --- a/src/versions/native/structures.ml +++ /dev/null @@ -1,188 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2022 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -open Entries -open Coqlib - - -(* Constr generation and manipulation *) -type id = Names.identifier -let mkId = Names.id_of_string - - -type name = Names.name -let name_of_id i = Names.Name i -let mkName s = - let id = mkId s in - name_of_id id -let string_of_name = function - Names.Name id -> Names.string_of_id id - | _ -> failwith "unnamed rel" - - -type constr = Term.constr -type types = Term.types -let eq_constr = Term.eq_constr -let hash_constr = Term.hash_constr -let mkProp = Term.mkProp -let mkConst = Term.mkConst -let mkVar = Term.mkVar -let mkRel = Term.mkRel -let isRel = Term.isRel -let destRel = Term.destRel -let lift = Term.lift -let mkApp = Term.mkApp -let decompose_app = Term.decompose_app -let mkLambda = Term.mkLambda -let mkProd = Term.mkProd -let mkLetIn = Term.mkLetIn - -let pr_constr_env = Printer.pr_constr_env -let pr_constr = Printer.pr_constr - - -let dummy_loc = Pp.dummy_loc - -let mkUConst c = - { const_entry_body = c; - const_entry_type = None; - const_entry_secctx = None; - const_entry_opaque = false; - const_entry_inline_code = false} - -let mkTConst c _ ty = - { const_entry_body = c; - const_entry_type = Some ty; - const_entry_secctx = None; - const_entry_opaque = false; - const_entry_inline_code = false} - -(* TODO : Set -> Type *) -let declare_new_type t = - Command.declare_assumption false (Decl_kinds.Local,Decl_kinds.Definitional) Term.mkSet [] false None (dummy_loc, t); - Term.mkVar t - -let declare_new_variable v constr_t = - Command.declare_assumption false (Decl_kinds.Local,Decl_kinds.Definitional) constr_t [] false None (dummy_loc, v); - Term.mkVar v - -let declare_constant n c = - Declare.declare_constant n (DefinitionEntry c, Decl_kinds.IsDefinition Decl_kinds.Definition) - - -type cast_kind = Term.cast_kind -let vmcast = Term.VMcast -let mkCast = Term.mkCast - - -(* EConstr *) -type econstr = Term.constr -let econstr_of_constr e = e - - -(* Modules *) -let gen_constant modules constant = lazy (gen_constant_in_modules "SMT" modules constant) - - -(* Int63 *) -let int63_modules = [["Coq";"Numbers";"Cyclic";"Int63";"Int63Native"]] - -let mkInt : int -> Term.constr = - fun i -> Term.mkInt (Uint63.of_int i) - -let cint = gen_constant int63_modules "int" - - -(* PArray *) -let parray_modules = [["Coq";"Array";"PArray"]] - -let max_array_size : int = - Parray.trunc_size (Uint63.of_int 4194303) -let mkArray : Term.types * Term.constr array -> Term.constr = - Term.mkArray - - -(* Traces *) -(* WARNING: side effect on r! *) -let mkTrace step_to_coq next carray _ _ _ _ size step def_step r = - let max = max_array_size - 1 in - let q,r1 = size / max, size mod max in - let trace = - let len = if r1 = 0 then q + 1 else q + 2 in - Array.make len (mkArray (step, [|def_step|])) in - for j = 0 to q - 1 do - let tracej = Array.make max_array_size def_step in - for i = 0 to max - 1 do - r := next !r; - tracej.(i) <- step_to_coq !r; - done; - trace.(j) <- mkArray (step, tracej) - done; - if r1 <> 0 then ( - let traceq = Array.make (r1 + 1) def_step in - for i = 0 to r1-1 do - r := next !r; - traceq.(i) <- step_to_coq !r; - done; - trace.(q) <- mkArray (step, traceq) - ); - mkArray (Term.mkApp (Lazy.force carray, [|step|]), trace) - - -(* Micromega *) -module Micromega_plugin_Micromega = Micromega -module Micromega_plugin_Mutils = Mutils -module Micromega_plugin_Certificate = Certificate -module Micromega_plugin_Coq_micromega = Coq_micromega - -let micromega_coq_proofTerm = - Coq_micromega.M.coq_proofTerm - -let micromega_dump_proof_term p = - Coq_micromega.dump_proof_term p - - -(* Tactics *) -type tactic = Proof_type.tactic -let tclTHEN = Tacticals.tclTHEN -let tclTHENLAST = Tacticals.tclTHENLAST -let assert_before = Tactics.assert_tac -let vm_cast_no_check = Tactics.vm_cast_no_check -let mk_tactic tac gl = - let env = Tacmach.pf_env gl in - let sigma = Tacmach.project gl in - let t = Tacmach.pf_concl gl in - tac env sigma t gl -let set_evars_tac _ = Tacticals.tclIDTAC - - -(* Other differences between the two versions of Coq *) -type constr_expr = Topconstr.constr_expr -let error = Errors.error -let warning _ s = Pp.warning s -let extern_constr = Constrextern.extern_constr true Environ.empty_env -let destruct_rel_decl (n, _, t) = n, t -let interp_constr env sigma = Constrintern.interp_constr sigma env -let ppconstr_lsimpleconstr = Ppconstr.lsimple -let constrextern_extern_constr = - let env = Global.env () in - Constrextern.extern_constr false env - -let get_rel_dec_name = fun _ -> Names.Anonymous - -(* Eta-expanded to get rid of optional arguments *) -let retyping_get_type_of env = Retyping.get_type_of env - -let vm_conv = Reduction.vm_conv -let cbv_vm = Vnorm.cbv_vm - - diff --git a/src/versions/native/structures.mli b/src/versions/native/structures.mli deleted file mode 100644 index e54f8e8..0000000 --- a/src/versions/native/structures.mli +++ /dev/null @@ -1,119 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2022 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -(* Constr generation and manipulation *) -type id = Names.variable -val mkId : string -> id - -type name -val name_of_id : id -> name -val mkName : string -> name -val string_of_name : name -> string - -type constr = Term.constr -type types = constr -val eq_constr : constr -> constr -> bool -val hash_constr : constr -> int -val mkProp : types -val mkConst : Names.constant -> constr -val mkVar : id -> constr -val mkRel : int -> constr -val isRel : constr -> bool -val destRel : constr -> int -val lift : int -> constr -> constr -val mkApp : constr * constr array -> constr -val decompose_app : constr -> constr * constr list -val mkLambda : name * types * constr -> constr -val mkProd : name * types * types -> types -val mkLetIn : name * constr * types * constr -> constr - -val pr_constr_env : Environ.env -> constr -> Pp.std_ppcmds -val pr_constr : constr -> Pp.std_ppcmds - -val mkUConst : constr -> Entries.definition_entry -val mkTConst : constr -> 'a -> types -> Entries.definition_entry -val declare_new_type : id -> types -val declare_new_variable : id -> types -> constr -val declare_constant : id -> Entries.definition_entry -> Names.constant - -type cast_kind -val vmcast : cast_kind -val mkCast : constr * cast_kind * constr -> constr - - -(* EConstr *) -type econstr = constr -val econstr_of_constr : constr -> econstr - - -(* Modules *) -val gen_constant : string list list -> string -> constr lazy_t - - -(* Int63 *) -val int63_modules : string list list -val mkInt : int -> constr -val cint : constr lazy_t - - -(* PArray *) -val parray_modules : string list list -val max_array_size : int -val mkArray : types * constr array -> constr - - -(* Traces *) -val mkTrace : - ('a -> constr) -> - ('a -> 'a) -> - constr Lazy.t -> - 'b -> - 'c -> 'd -> 'e -> int -> types -> constr -> 'a ref -> constr - - -(* Micromega *) -module Micromega_plugin_Micromega = Micromega -module Micromega_plugin_Mutils = Mutils -module Micromega_plugin_Certificate = Certificate -module Micromega_plugin_Coq_micromega = Coq_micromega - -val micromega_coq_proofTerm : constr lazy_t -val micromega_dump_proof_term : Micromega_plugin_Certificate.Mc.zArithProof -> constr - - -(* Tactics *) -type tactic = Proof_type.tactic -val tclTHEN : Proof_type.tactic -> Proof_type.tactic -> Proof_type.tactic -val tclTHENLAST : Proof_type.tactic -> Proof_type.tactic -> Proof_type.tactic -val assert_before : name -> types -> Proof_type.tactic -val vm_cast_no_check : constr -> Proof_type.tactic -val mk_tactic : - (Environ.env -> - Evd.evar_map -> types -> Proof_type.goal Tacmach.sigma -> 'a) -> - Proof_type.goal Tacmach.sigma -> 'a -val set_evars_tac : 'a -> Proof_type.tactic - - -(* Other differences between the two versions of Coq *) -type constr_expr = Topconstr.constr_expr -val error : string -> 'a -val warning : string -> string -> unit -val extern_constr : constr -> Topconstr.constr_expr -val destruct_rel_decl : Term.rel_declaration -> name * types -val interp_constr : Environ.env -> Evd.evar_map -> Topconstr.constr_expr -> constr -val ppconstr_lsimpleconstr : Ppconstr.precedence -val constrextern_extern_constr : constr -> Topconstr.constr_expr -val get_rel_dec_name : 'a -> name -val retyping_get_type_of : Environ.env -> Evd.evar_map -> constr -> constr - -val vm_conv : Reduction.conv_pb -> types Reduction.conversion_function -val cbv_vm : Environ.env -> constr -> types -> constr diff --git a/src/versions/standard/Array/PArray_standard.v b/src/versions/standard/Array/PArray_standard.v deleted file mode 100644 index 4ebcd63..0000000 --- a/src/versions/standard/Array/PArray_standard.v +++ /dev/null @@ -1,398 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2022 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -(* Software implementation of arrays, based on finite maps using AVL - trees *) - - -Require Import Int31. -Require Export Int63. -Require FMapAVL. - -Local Open Scope int63_scope. - - -Module Map := FMapAVL.Make(IntOrderedType). - -(* An array is represented as a tuple of a finite map, the default - element, and the length *) -Definition array (A:Type) : Type := - (Map.t A * A * int)%type. - -Definition make {A:Type} (l:int) (d:A) : array A := (Map.empty A, d, l). - -Definition get {A:Type} (t:array A) (i:int) : A := - let (td,_) := t in - let (t,d) := td in - match Map.find i t with - | Some x => x - | None => d - end. - -Definition default {A:Type} (t:array A) : A := - let (td,_) := t in let (_,d) := td in d. - -Definition set {A:Type} (t:array A) (i:int) (a:A) : array A := - let (td,l) := t in - if l <= i then - t - else - let (t,d) := td in - (Map.add i a t, d, l). - -Definition length {A:Type} (t:array A) : int := - let (_,l) := t in l. - -Definition copy {A:Type} (t:array A) : array A := t. - -Definition reroot : forall {A:Type}, array A -> array A := @copy. - -Definition init {A:Type} (l:int) (f:int -> A) (d:A) : array A := - let r := - if l == 0 then - Map.empty A - else - foldi (fun j m => Map.add j (f j) m) 0 (l-1) (Map.empty A) in - (r, d, l). - -Definition map {A B:Type} (f:A -> B) (t:array A) : array B := - let (td,l) := t in - let (t,d) := td in - (Map.map f t, f d, l). - -Module Export PArrayNotations. -Delimit Scope array_scope with array. -Notation "t '.[' i ']'" := (get t i) (at level 50) : array_scope. -Notation "t '.[' i '<-' a ']'" := (set t i a) (at level 50) : array_scope. -End PArrayNotations. - -Local Open Scope array_scope. - -Definition max_array_length := 4194302%int31. - -(** Axioms *) -Axiom get_outofbound : forall A (t:array A) i, (i < length t) = false -> t.[i] = default t. - -Axiom get_set_same : forall A t i (a:A), (i < length t) = true -> t.[i<-a].[i] = a. -Axiom get_set_other : forall A t i j (a:A), i <> j -> t.[i<-a].[j] = t.[j]. -Axiom default_set : forall A t i (a:A), default (t.[i<-a]) = default t. - - -Axiom get_make : forall A (a:A) size i, (make size a).[i] = a. -Axiom default_make : forall A (a:A) size, (default (make size a)) = a. - -Axiom ltb_length : forall A (t:array A), length t <= max_array_length = true. - -Axiom length_make : forall A size (a:A), - length (make size a) = if size <= max_array_length then size else max_array_length. -Axiom length_set : forall A t i (a:A), - length (t.[i<-a]) = length t. - -Axiom get_copy : forall A (t:array A) i, (copy t).[i] = t.[i]. -Axiom length_copy : forall A (t:array A), length (copy t) = length t. - -Axiom get_reroot : forall A (t:array A) i, (reroot t).[i] = t.[i]. -Axiom length_reroot : forall A (t:array A), length (reroot t) = length t. - - -Axiom length_init : forall A f size (def:A), - length (init size f def) = if size <= max_array_length then size else max_array_length. - -Axiom get_init : forall A f size (def:A) i, - (init size f def).[i] = if i < length (init size f def) then f i else def. - -Axiom default_init : forall A f size (def:A), default (init size f def) = def. - -(* Not true in this implementation (see #71, many thanks to Andres Erbsen) *) -(* -Axiom get_ext : forall A (t1 t2:array A), - length t1 = length t2 -> - (forall i, i < length t1 = true -> t1.[i] = t2.[i]) -> - default t1 = default t2 -> - t1 = t2. -*) - -(* Definition *) -Definition to_list {A:Type} (t:array A) := - let len := length t in - if 0 == len then nil - else foldi_down (fun i l => t.[i] :: l)%list (len - 1) 0 nil. - -Definition forallbi {A:Type} (f:int-> A->bool) (t:array A) := - let len := length t in - if 0 == len then true - else forallb (fun i => f i (t.[i])) 0 (len - 1). - -Definition forallb {A:Type} (f: A->bool) (t:array A) := - let len := length t in - if 0 == len then true - else forallb (fun i => f (t.[i])) 0 (len - 1). - -Definition existsbi {A:Type} (f:int->A->bool) (t:array A) := - let len := length t in - if 0 == len then false - else existsb (fun i => f i (t.[i])) 0 (len - 1). - -Definition existsb {A:Type} (f:A->bool) (t:array A) := - let len := length t in - if 0 == len then false - else existsb (fun i => f (t.[i])) 0 (len - 1). - -(* TODO : We should add init as native and add it *) -Definition mapi {A B:Type} (f:int->A->B) (t:array A) := - let size := length t in - let def := f size (default t) in - let tb := make size def in - if size == 0 then tb - else foldi (fun i tb => tb.[i<- f i (t.[i])]) 0 (size - 1) tb. - -Definition foldi_left {A B:Type} (f:int -> A -> B -> A) a (t:array B) := - let len := length t in - if 0 == len then a - else foldi (fun i a => f i a (t.[i])) 0 (len - 1) a. - -Definition fold_left {A B:Type} (f: A -> B -> A) a (t:array B) := - let len := length t in - if 0 == len then a - else foldi (fun i a => f a (t.[i])) 0 (length t - 1) a. - -Definition foldi_right {A B:Type} (f:int -> A -> B -> B) (t:array A) b := - let len := length t in - if 0 == len then b - else foldi_down (fun i b => f i (t.[i]) b) (len - 1) 0 b. - -Definition fold_right {A B:Type} (f: A -> B -> B) (t:array A) b := - let len := length t in - if 0 == len then b - else foldi_down (fun i b => f (t.[i]) b) (len - 1) 0 b. - -(* Lemmas *) - -Lemma default_copy : forall A (t:array A), default (copy t) = default t. -Proof. - intros A t;assert (length t < length t = false). - apply Bool.not_true_is_false; apply leb_not_gtb; apply leb_refl. - rewrite <- (get_outofbound _ (copy t) (length t)), <- (get_outofbound _ t (length t)), get_copy;trivial. -Qed. - -Lemma reroot_default : forall A (t:array A), default (reroot t) = default t. -Proof. - intros A t;assert (length t < length t = false). - apply Bool.not_true_is_false; apply leb_not_gtb; apply leb_refl. - rewrite <- (get_outofbound _ (reroot t) (length t)), <- (get_outofbound _ t (length t)), get_reroot;trivial. -Qed. - -Lemma get_set_same_default : - forall (A : Type) (t : array A) (i : int) , - (t .[ i <- default t]) .[ i] = default t. -Proof. - intros A t i;case_eq (i < (length t));intros. - rewrite get_set_same;trivial. - rewrite get_outofbound, default_set;trivial. - rewrite length_set;trivial. -Qed. - -Lemma get_not_default_lt : forall A (t:array A) x, - t.[x] <> default t -> x < length t = true. -Proof. - intros A t x Hd. - case_eq (x < length t);intros Heq;[trivial | ]. - elim Hd;rewrite get_outofbound;trivial. -Qed. - -Lemma foldi_left_Ind : - forall A B (P : int -> A -> Prop) (f : int -> A -> B -> A) (t:array B), - (forall a i, i < length t = true -> P i a -> P (i+1) (f i a (t.[i]))) -> - forall a, P 0 a -> - P (length t) (foldi_left f a t). -Proof. - intros;unfold foldi_left. - destruct (reflect_eqb 0 (length t)). - rewrite <- e;trivial. - assert ((length t - 1) + 1 = length t) by ring. - rewrite <- H1 at 1;apply foldi_Ind;auto. - assert (W:= leb_max_int (length t));rewrite leb_spec in W. - rewrite ltb_spec, to_Z_sub_1_diff;auto with zarith. - intros Hlt;elim (ltb_0 _ Hlt). - intros;apply H;trivial. rewrite ltb_leb_sub1;auto. -Qed. - -Lemma fold_left_Ind : - forall A B (P : int -> A -> Prop) (f : A -> B -> A) (t:array B), - (forall a i, i < length t = true -> P i a -> P (i+1) (f a (t.[i]))) -> - forall a, P 0 a -> - P (length t) (fold_left f a t). -Proof. - intros. - apply (foldi_left_Ind A B P (fun i => f));trivial. -Qed. - -Lemma fold_left_ind : - forall A B (P : A -> Prop) (f : A -> B -> A) (t:array B), - (forall a i, i < length t = true -> P a -> P (f a (t.[i]))) -> - forall a, P a -> - P (fold_left f a t). -Proof. - intros;apply (fold_left_Ind A B (fun _ => P));trivial. -Qed. - -Lemma foldi_right_Ind : - forall A B (P : int -> A -> Prop) (f : int -> B -> A -> A) (t:array B), - (forall a i, i < length t = true -> P (i+1) a -> P i (f i (t.[i]) a)) -> - forall a, P (length t) a -> - P 0 (foldi_right f t a). -Proof. - intros;unfold foldi_right. - destruct (reflect_eqb 0 (length t)). - rewrite e;trivial. - set (P' z a := (*-1 <= z < [|length t|] ->*) P (of_Z (z + 1)) a). - assert (P' ([|0|] - 1)%Z (foldi_down (fun (i : int) (b : A) => f i (t .[ i]) b) (length t - 1) 0 a)). - apply foldi_down_ZInd;unfold P'. - intros Hlt;elim (ltb_0 _ Hlt). - rewrite to_Z_sub_1_diff;auto. - ring_simplify ([|length t|] - 1 + 1)%Z;rewrite of_to_Z;trivial. - intros;ring_simplify ([|i|] - 1 + 1)%Z;rewrite of_to_Z;auto. - assert (i < length t = true). - rewrite ltb_leb_sub1;auto. - apply H;trivial. - exact H1. -Qed. - -Lemma fold_right_Ind : - forall A B (P : int -> A -> Prop) (f : B -> A -> A) (t:array B), - (forall a i, i < length t = true -> P (i+1) a -> P i (f (t.[i]) a)) -> - forall a, P (length t) a -> - P 0 (fold_right f t a). -Proof. - intros;apply (foldi_right_Ind A B P (fun i => f));trivial. -Qed. - -Lemma fold_right_ind : - forall A B (P : A -> Prop) (f : B -> A -> A) (t:array B), - (forall a i, i < length t = true -> P a -> P (f (t.[i]) a)) -> - forall a, P a -> - P (fold_right f t a). -Proof. - intros;apply (fold_right_Ind A B (fun i => P));trivial. -Qed. - -Lemma forallbi_spec : forall A (f : int -> A -> bool) t, - forallbi f t = true <-> forall i, i < length t = true -> f i (t.[i]) = true. -Proof. - unfold forallbi;intros A f t. - destruct (reflect_eqb 0 (length t)). - split;[intros | trivial]. - elim (ltb_0 i);rewrite e;trivial. - rewrite forallb_spec;split;intros Hi i;intros;apply Hi. - apply leb_0. rewrite <- ltb_leb_sub1;auto. rewrite ltb_leb_sub1;auto. -Qed. - -Lemma forallb_spec : forall A (f : A -> bool) t, - forallb f t = true <-> forall i, i < length t = true -> f (t.[i]) = true. -Proof. - intros A f;apply (forallbi_spec A (fun i => f)). -Qed. - -Lemma existsbi_spec : forall A (f : int -> A -> bool) t, - existsbi f t = true <-> exists i, i < length t = true /\ f i (t.[i]) = true. -Proof. - unfold existsbi;intros A f t. - destruct (reflect_eqb 0 (length t)). - split;[discriminate | intros [i [Hi _]];rewrite <- e in Hi;elim (ltb_0 _ Hi)]. - rewrite existsb_spec. repeat setoid_rewrite Bool.andb_true_iff. - split;intros [i H];decompose [and] H;clear H;exists i;repeat split;trivial. - rewrite ltb_leb_sub1;auto. apply leb_0. rewrite <- ltb_leb_sub1;auto. -Qed. - -Lemma existsb_spec : forall A (f : A -> bool) t, - existsb f t = true <-> exists i, i < length t = true /\ f (t.[i]) = true. -Proof. - intros A f;apply (existsbi_spec A (fun i => f)). -Qed. - -Local Open Scope list_scope. - -Definition to_list_ntr A (t:array A) := - let len := length t in - if 0 == len then nil - else foldi_ntr _ (fun i l => t.[i] :: l) 0 (len - 1) nil. - -Lemma to_list_to_list_ntr : forall A (t:array A), - to_list t = to_list_ntr _ t. -Proof. - unfold to_list, to_list_ntr; intros A t. - destruct (reflect_eqb 0 (length t));trivial. - rewrite foldi_ntr_foldi_down;trivial. - apply leb_ltb_trans with max_array_length;[ | trivial]. - apply leb_trans with (length t);[ | apply ltb_length]. - rewrite leb_spec, sub_spec. - rewrite to_Z_1, Zmod_small;try omega. - generalize (to_Z_bounded (length t)). - assert (0%Z <> [|length t|]);[ | omega]. - intros Heq;elim n;apply to_Z_inj;trivial. -Qed. - -Lemma fold_left_to_list : forall (A B:Type) (t:array A) (f: B -> A -> B) b, - fold_left f b t = List.fold_left f (to_list t) b. -Proof. - intros A B t f;rewrite to_list_to_list_ntr. - unfold fold_left, to_list_ntr; destruct (reflect_eqb 0 (length t));[trivial | ]. - set (P1 := fun i => forall b, - foldi (fun (i : int) (a : B) => f a (t .[ i])) i (length t - 1) b = - List.fold_left f - (foldi_ntr (list A) (fun (i : int) (l : list A) => t .[ i] :: l) i - (length t - 1) nil) b). - assert (W: P1 0);[ | trivial]. - apply int_ind_bounded with (max := length t - 1);unfold P1. - apply leb_0. - intros b;unfold foldi_ntr;rewrite foldi_eq, foldi_cont_eq;trivial. - intros i _ Hlt Hrec b. - unfold foldi_ntr;rewrite foldi_lt, foldi_cont_lt;trivial;simpl. - apply Hrec. -Qed. - -Require Import Bool. -Local Open Scope bool_scope. - -Definition eqb {A:Type} (Aeqb: A->A->bool) (t1 t2:array A) := - (length t1 == length t2) && - Aeqb (default t1) (default t2) && - forallbi (fun i a1 => Aeqb a1 (t2.[i])) t1. - -(* -Lemma reflect_eqb : forall (A:Type) (Aeqb:A->A->bool), - (forall a1 a2, reflect (a1 = a2) (Aeqb a1 a2)) -> - forall t1 t2, reflect (t1 = t2) (eqb Aeqb t1 t2). -Proof. - intros A Aeqb HA t1 t2. - case_eq (eqb Aeqb t1 t2);unfold eqb;intros H;constructor. - rewrite !andb_true_iff in H;destruct H as [[H1 H2] H3]. - apply get_ext. - rewrite (reflect_iff _ _ (reflect_eqb _ _));trivial. - rewrite forallbi_spec in H3. - intros i Hlt;rewrite (reflect_iff _ _ (HA _ _));auto. - rewrite (reflect_iff _ _ (HA _ _));trivial. - intros Heq;rewrite Heq in H;clear Heq. - revert H; rewrite Int63Axioms.eqb_refl;simpl. - case_eq (Aeqb (default t2) (default t2));simpl;intros H0 H1. - rewrite <- not_true_iff_false, forallbi_spec in H1;apply H1. - intros i _; rewrite <- (reflect_iff _ _ (HA _ _));trivial. - rewrite <- not_true_iff_false, <- (reflect_iff _ _ (HA _ _)) in H0;apply H0;trivial. -Qed. -*) - - -(* - Local Variables: - coq-load-path: ((rec "../../.." "SMTCoq")) - End: -*) diff --git a/src/versions/standard/Int63/Int63Axioms_standard.v b/src/versions/standard/Int63/Int63Axioms_standard.v deleted file mode 100644 index e9c2dfe..0000000 --- a/src/versions/standard/Int63/Int63Axioms_standard.v +++ /dev/null @@ -1,313 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2022 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -Require Import Bvector. -(* Require Export BigNumPrelude. *) -Require Import Int31 Cyclic31. -Require Export Int63Native. -Require Export Int63Op. -Require Import Psatz. - -Local Open Scope Z_scope. - - -(* Taken from BigNumPrelude *) - - Lemma div_le_0 : forall p x, 0 <= x -> 0 <= x / 2 ^ p. - Proof. - intros p x Hle;destruct (Z_le_gt_dec 0 p). - apply Zdiv_le_lower_bound;auto with zarith. - replace (2^p) with 0. - destruct x;compute;intro;discriminate. - destruct p;trivial;discriminate. - Qed. - - Lemma div_lt : forall p x y, 0 <= x < y -> x / 2^p < y. - Proof. - intros p x y H;destruct (Z_le_gt_dec 0 p). - apply Zdiv_lt_upper_bound;auto with zarith. - apply Z.lt_le_trans with y;auto with zarith. - rewrite <- (Z.mul_1_r y);apply Z.mul_le_mono_nonneg;auto with zarith. - assert (0 < 2^p);auto with zarith. - replace (2^p) with 0. - destruct x;change (0<y);auto with zarith. - destruct p;trivial;discriminate. - Qed. - - -(* Int63Axioms *) - -Definition wB := (2^(Z_of_nat size)). - -Notation "[| x |]" := (to_Z x) (at level 0, x at level 99) : int63_scope. - -Notation "[+| c |]" := - (interp_carry 1 wB to_Z c) (at level 0, c at level 99) : int63_scope. - -Notation "[-| c |]" := - (interp_carry (-1) wB to_Z c) (at level 0, c at level 99) : int63_scope. - -Notation "[|| x ||]" := - (zn2z_to_Z wB to_Z x) (at level 0, x at level 99) : int63_scope. - -Local Open Scope int63_scope. -Local Open Scope Z_scope. - -(* Bijection : int63 <-> Bvector size *) - -Theorem to_Z_inj : forall x y, [|x|] = [|y|] -> x = y. -Proof Ring31.Int31_canonic. - -Theorem of_to_Z : forall x, of_Z ([|x|]) = x. -Proof. exact phi_inv_phi. Qed. - -(* Comparisons *) -Theorem eqb_refl x : (x == x)%int = true. -Proof. now rewrite Ring31.eqb31_eq. Qed. - -Theorem ltb_spec x y : (x < y)%int = true <-> [|x|] < [|y|]. -Proof. - unfold ltb. rewrite spec_compare, <- Z.compare_lt_iff. - change (phi x ?= phi y) with ([|x|] ?= [|y|]). - case ([|x|] ?= [|y|]); intuition; discriminate. -Qed. - -Theorem leb_spec x y : (x <= y)%int = true <-> [|x|] <= [|y|]. -Proof. - unfold leb. rewrite spec_compare, <- Z.compare_le_iff. - change (phi x ?= phi y) with ([|x|] ?= [|y|]). - case ([|x|] ?= [|y|]); intuition; discriminate. -Qed. - - -(** Specification of logical operations *) -Lemma lsl_spec_alt p : - forall x, [| addmuldiv31_alt p x 0 |] = ([|x|] * 2^(Z.of_nat p)) mod wB. -Proof. - induction p as [ |p IHp]; simpl; intro x. - - rewrite Z.mul_1_r. symmetry. apply Zmod_small. apply phi_bounded. - - rewrite IHp, phi_twice, Zmult_mod_idemp_l, Z.double_spec, - Z.mul_comm, Z.mul_assoc, Z.mul_comm, - Z.pow_pos_fold, Zpos_P_of_succ_nat, <- Z.add_1_r, Z.pow_add_r. - * reflexivity. - * apply Zle_0_nat. - * exact Z.le_0_1. -Qed. - -Theorem lsl_spec x p : [| x << p |] = ([|x|] * 2^[|p|]) mod wB. -Proof. - unfold lsl. - rewrite addmuldiv31_equiv, lsl_spec_alt, Nat2Z.inj_abs_nat, Z.abs_eq. - - reflexivity. - - now destruct (phi_bounded p). -Qed. - - -Lemma div_greater (p x:int) (H:Z.of_nat Int31.size <= [|p|]) : [|x|] / 2 ^ [|p|] = 0. -Proof. - apply Z.div_small. destruct (phi_bounded x) as [H1 H2]. split; auto. - apply (Z.lt_le_trans _ _ _ H2). apply Z.pow_le_mono_r; auto. - exact Z.lt_0_2. -Qed. - -Theorem lsr_spec x p : [|x >> p|] = [|x|] / 2 ^ [|p|]. -Proof. - unfold lsr. case_eq (p < 31%int31)%int; intro Heq. - - assert (H : [|31%int31 - p|] = 31 - [|p|]). - * rewrite spec_sub. rewrite Zmod_small; auto. - split. - + rewrite ltb_spec in Heq. assert (forall x y, x < y -> 0 <= y - x) by (intros;lia); auto. - + assert (H:forall x y z, 0 <= y /\ x < z -> x - y < z) by (intros;lia). - apply H. destruct (phi_bounded p). destruct (phi_bounded (31%int31)). split; auto. - * rewrite spec_add_mul_div. - + rewrite Z.add_0_l. change (phi (31%int31 - p)) with [|31%int31 - p|]. rewrite H. replace (31 - (31 - [|p|])) with [|p|] by ring. apply Zmod_small. split. - ++ apply div_le_0. now destruct (phi_bounded x). - ++ apply div_lt. apply phi_bounded. - + change (phi (31%int31 - p)) with [|31%int31 - p|]. rewrite H. assert (forall x y, 0 <= y -> x - y <= x) by (intros;lia). apply H0. now destruct (phi_bounded p). - - rewrite div_greater; auto. - destruct (Z.le_gt_cases [|31%int31|] [|p|]); auto. - rewrite <- ltb_spec in H. rewrite H in Heq. discriminate. -Qed. - - -Lemma bit_testbit x i : bit x i = Z.testbit [|x|] [|i|]. -Admitted. -(* Proof. *) -(* case_eq [|i|]. *) -(* - simpl. change 0 with [|0|]. intro Heq. apply Ring31.Int31_canonic in Heq. subst i. *) -(* unfold bit. *) - - -Lemma Z_pos_xO_pow i x (Hi:0 <= i) : Z.pos x < 2 ^ i <-> Z.pos x~0 < 2 ^ (i+1). -Proof. rewrite Pos2Z.inj_xO, Z.pow_add_r; auto using Z.le_0_1; lia. Qed. - -Lemma Z_pos_xI_pow i x (Hi:0 <= i) : Z.pos x < 2 ^ i <-> Z.pos x~1 < 2 ^ (i+1). -Proof. rewrite Pos2Z.inj_xI, Z.pow_add_r; auto using Z.le_0_1; lia. Qed. - -Lemma pow_nonneg i (Hi : 1 <= 2 ^ i) : 0 <= i. -Proof. - destruct (Z.le_gt_cases 0 i); auto. - rewrite (Z.pow_neg_r _ _ H) in Hi. lia. -Qed. - -Lemma pow_pos i (Hi : 1 < 2 ^ i) : 0 < i. -Proof. - destruct (Z.lt_trichotomy 0 i) as [H|[H|H]]; auto. - - subst i. lia. - - rewrite (Z.pow_neg_r _ _ H) in Hi. lia. -Qed. - -Lemma pos_land_bounded : forall x y i, - Z.pos x < 2 ^ i -> Z.pos y < 2 ^ i -> Z.of_N (Pos.land x y) < 2 ^ i. -Proof. - induction x as [x IHx|x IHx| ]; intros [y|y| ] i; auto. - - simpl. intro H. - assert (H4:0 <= i - 1) by (assert (H4:0 < i); try lia; apply pow_pos; apply (Z.le_lt_trans _ (Z.pos x~1)); auto; lia). - generalize H. replace i with ((i-1)+1) at 1 2 by ring. rewrite <- !Z_pos_xI_pow; auto. intros H1 H2. - assert (H3:=IHx _ _ H1 H2). - unfold Pos.Nsucc_double. case_eq (Pos.land x y). - * intros _. eapply Z.le_lt_trans; [ |exact H]. clear. lia. - * intros p Hp. revert H3. rewrite Hp, N2Z.inj_pos, Z_pos_xI_pow; auto. - replace (i - 1 + 1) with i by ring. clear. lia. - - simpl. intro H. - assert (H4:0 <= i - 1) by (assert (H4:0 < i); try lia; apply pow_pos; apply (Z.le_lt_trans _ (Z.pos x~1)); auto; lia). - generalize H. replace i with ((i-1)+1) at 1 2 by ring. rewrite <- Z_pos_xI_pow, <- Z_pos_xO_pow; auto. intros H1 H2. - assert (H3:=IHx _ _ H1 H2). - unfold Pos.Ndouble. case_eq (Pos.land x y). - * intros _. eapply Z.le_lt_trans; [ |exact H]. clear. lia. - * intros p Hp. revert H3. rewrite Hp, N2Z.inj_pos, Z_pos_xO_pow; auto. - replace (i - 1 + 1) with i by ring. clear. lia. - - simpl. intro H. - assert (H4:0 <= i - 1) by (assert (H4:0 < i); try lia; apply pow_pos; apply (Z.le_lt_trans _ (Z.pos x~0)); auto; lia). - generalize H. replace i with ((i-1)+1) at 1 2 by ring. rewrite <- Z_pos_xI_pow, <- Z_pos_xO_pow; auto. intros H1 H2. - assert (H3:=IHx _ _ H1 H2). - unfold Pos.Ndouble. case_eq (Pos.land x y). - * intros _. eapply Z.le_lt_trans; [ |exact H]. clear. lia. - * intros p Hp. revert H3. rewrite Hp, N2Z.inj_pos, Z_pos_xO_pow; auto. - replace (i - 1 + 1) with i by ring. clear. lia. - - simpl. intro H. - assert (H4:0 <= i - 1) by (assert (H4:0 < i); try lia; apply pow_pos; apply (Z.le_lt_trans _ (Z.pos x~0)); auto; lia). - generalize H. replace i with ((i-1)+1) at 1 2 by ring. rewrite <- !Z_pos_xO_pow; auto. intros H1 H2. - assert (H3:=IHx _ _ H1 H2). - unfold Pos.Ndouble. case_eq (Pos.land x y). - * intros _. eapply Z.le_lt_trans; [ |exact H]. clear. lia. - * intros p Hp. revert H3. rewrite Hp, N2Z.inj_pos, Z_pos_xO_pow; auto. - replace (i - 1 + 1) with i by ring. clear. lia. - - simpl. intros H _. apply (Z.le_lt_trans _ (Z.pos x~0)); lia. - - simpl. intros H _. apply (Z.le_lt_trans _ 1); lia. -Qed. - - -Lemma Z_land_bounded i : forall x y, - 0 <= x < 2 ^ i -> 0 <= y < 2 ^ i -> 0 <= Z.land x y < 2 ^ i. -Proof. - intros [ |p|p] [ |q|q]; auto. - - intros [_ H1] [_ H2]. simpl. split. - * apply N2Z.is_nonneg. - * now apply pos_land_bounded. -Admitted. - -Theorem land_spec x y i : bit (x land y) i = bit x i && bit y i. -Proof. - rewrite !bit_testbit. change (x land y) with (land31 x y). unfold land31. - rewrite phi_phi_inv. rewrite Zmod_small. - - apply Z.land_spec. - - split. - * rewrite Z.land_nonneg. left. now destruct (phi_bounded x). - * now destruct (Z_land_bounded _ _ _ (phi_bounded x) (phi_bounded y)). -Qed. - - -Axiom lor_spec: forall x y i, bit (x lor y) i = bit x i || bit y i. - -Axiom lxor_spec: forall x y i, bit (x lxor y) i = xorb (bit x i) (bit y i). - -(** Specification of basic opetations *) - -(* Arithmetic modulo operations *) - -(* Remarque : les axiomes seraient plus simple si on utilise of_Z a la place : - exemple : add_spec : forall x y, of_Z (x + y) = of_Z x + of_Z y. *) - -Axiom add_spec : forall x y, [|x + y|] = ([|x|] + [|y|]) mod wB. - -Axiom sub_spec : forall x y, [|x - y|] = ([|x|] - [|y|]) mod wB. - -Axiom mul_spec : forall x y, [| x * y |] = [|x|] * [|y|] mod wB. - -Axiom mulc_spec : forall x y, [|x|] * [|y|] = [|fst (mulc x y)|] * wB + [|snd (mulc x y)|]. - -Axiom div_spec : forall x y, [|x / y|] = [|x|] / [|y|]. - -Axiom mod_spec : forall x y, [|x \% y|] = [|x|] mod [|y|]. - -(** Iterators *) - -Axiom foldi_cont_gt : forall A B f from to cont, - (to < from)%int = true -> foldi_cont (A:=A) (B:=B) f from to cont = cont. - -Axiom foldi_cont_eq : forall A B f from to cont, - from = to -> foldi_cont (A:=A) (B:=B) f from to cont = f from cont. - -Axiom foldi_cont_lt : forall A B f from to cont, - (from < to)%int = true-> - foldi_cont (A:=A) (B:=B) f from to cont = - f from (fun a' => foldi_cont f (from + 1%int) to cont a'). - -Axiom foldi_down_cont_lt : forall A B f from downto cont, - (from < downto)%int = true -> foldi_down_cont (A:=A) (B:=B) f from downto cont = cont. - -Axiom foldi_down_cont_eq : forall A B f from downto cont, - from = downto -> foldi_down_cont (A:=A) (B:=B) f from downto cont = f from cont. - -Axiom foldi_down_cont_gt : forall A B f from downto cont, - (downto < from)%int = true-> - foldi_down_cont (A:=A) (B:=B) f from downto cont = - f from (fun a' => foldi_down_cont f (from-1) downto cont a'). - -(** Print *) - -Axiom print_int_spec : forall x, x = print_int x. - -(** Axioms on operations which are just short cut *) - -Axiom compare_def_spec : forall x y, compare x y = compare_def x y. - -Axiom head0_spec : forall x, 0 < [|x|] -> - wB/ 2 <= 2 ^ ([|head0 x|]) * [|x|] < wB. - -Axiom tail0_spec : forall x, 0 < [|x|] -> - (exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|tail0 x|]))%Z. - -Axiom addc_def_spec : forall x y, (x +c y)%int = addc_def x y. - -Axiom addcarryc_def_spec : forall x y, addcarryc x y = addcarryc_def x y. - -Axiom subc_def_spec : forall x y, (x -c y)%int = subc_def x y. - -Axiom subcarryc_def_spec : forall x y, subcarryc x y = subcarryc_def x y. - -Axiom diveucl_def_spec : forall x y, diveucl x y = diveucl_def x y. - -Axiom diveucl_21_spec : forall a1 a2 b, - let (q,r) := diveucl_21 a1 a2 b in - ([|q|],[|r|]) = Z.div_eucl ([|a1|] * wB + [|a2|]) [|b|]. - -Axiom addmuldiv_def_spec : forall p x y, - addmuldiv p x y = addmuldiv_def p x y. - - -(* - Local Variables: - coq-load-path: ((rec "../../.." "SMTCoq")) - End: -*) diff --git a/src/versions/standard/Int63/Int63Native_standard.v b/src/versions/standard/Int63/Int63Native_standard.v deleted file mode 100644 index 9fd425b..0000000 --- a/src/versions/standard/Int63/Int63Native_standard.v +++ /dev/null @@ -1,143 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2022 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -Require Export DoubleType. -Require Import Int31 Cyclic31 Ring31. -Require Import ZArith. -Require Import Bool. - - -Definition size := size. - -Notation int := int31. - -Delimit Scope int63_scope with int. -Bind Scope int63_scope with int. - -(* Some constants *) -Notation "0" := 0%int31 : int63_scope. -Notation "1" := 1%int31 : int63_scope. -Notation "2" := 2%int31 : int63_scope. -Notation "3" := 3%int31 : int63_scope. - -(* Comparisons *) -Definition eqb := eqb31. -Notation "m '==' n" := (eqb m n) (at level 70, no associativity) : int63_scope. - -Definition ltb : int -> int -> bool := - fun i j => match compare31 i j with | Lt => true | _ => false end. -Notation "m < n" := (ltb m n) : int63_scope. - -Definition leb : int -> int -> bool := - fun i j => match compare31 i j with | Gt => false | _ => true end. -Notation "m <= n" := (leb m n) : int63_scope. - - -Lemma eqb_correct : forall i j, (i==j)%int = true -> i = j. -Proof. exact eqb31_correct. Qed. - -(* Logical operations *) -Definition lsl : int -> int -> int := - fun i j => addmuldiv31 j i 0. -Infix "<<" := lsl (at level 30, no associativity) : int63_scope. - -Definition lsr : int -> int -> int := - fun i j => if (j < 31%int31)%int then addmuldiv31 (31-j)%int31 0 i else 0%int31. -Infix ">>" := lsr (at level 30, no associativity) : int63_scope. - -Definition land : int -> int -> int := land31. -Global Arguments land i j : simpl never. -Global Opaque land. -Infix "land" := land (at level 40, left associativity) : int63_scope. - -Definition lor : int -> int -> int := lor31. -Global Arguments lor i j : simpl never. -Global Opaque lor. -Infix "lor" := lor (at level 40, left associativity) : int63_scope. - -Definition lxor : int -> int -> int := lxor31. -Global Arguments lxor i j : simpl never. -Global Opaque lxor. -Infix "lxor" := lxor (at level 40, left associativity) : int63_scope. - -(* Arithmetic modulo operations *) -Notation "n + m" := (add31 n m) : int63_scope. -Notation "n - m" := (sub31 n m) : int63_scope. -Notation "n * m" := (mul31 n m) : int63_scope. - -Definition mulc : int -> int -> int * int := - fun i j => match mul31c i j with - | W0 => (0%int, 0%int) - | WW h l => (h, l) - end. - -Definition div : int -> int -> int := - fun i j => let (q,_) := div31 i j in q. -Notation "n / m" := (div n m) : int63_scope. - -Definition modulo : int -> int -> int := - fun i j => let (_,r) := div31 i j in r. -Notation "n '\%' m" := (modulo n m) (at level 40, left associativity) : int63_scope. - - -(* Iterators *) - -Definition firstr i := if ((i land 1) == 0)%int then D0 else D1. -Fixpoint recr_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A) - (i:int31) : A := - match n with - | O => case0 - | S next => - if (i == 0)%int then - case0 - else - let si := (i >> 1)%int in - caserec (firstr i) si (recr_aux next A case0 caserec si) - end. -Definition recr := recr_aux size. -Definition iter_int31 i A f := - recr (A->A) (fun x => x) - (fun b si rec => match b with - | D0 => fun x => rec (rec x) - | D1 => fun x => f (rec (rec x)) - end) - i. - -Definition foldi_cont - {A B : Type} - (f : int -> (A -> B) -> A -> B) - (from to : int) - (cont : A -> B) : A -> B := - if ltb to from then - cont - else - let (_,r) := iter_int31 (to - from) _ (fun (jy: (int * (A -> B))%type) => - let (j,y) := jy in ((j-1)%int, f j y) - ) (to, cont) in - f from r. - -Definition foldi_down_cont - {A B : Type} - (f : int -> (A -> B) -> A -> B) - (from downto : int) - (cont : A -> B) : A -> B := - if ltb from downto then - cont - else - let (_,r) := iter_int31 (from - downto) _ (fun (jy: (int * (A -> B))%type) => - let (j,y) := jy in ((j+1)%int, f j y) - ) (downto, cont) in - f from r. - -(* Fake print *) - -Definition print_int : int -> int := fun i => i. diff --git a/src/versions/standard/Int63/Int63Op_standard.v b/src/versions/standard/Int63/Int63Op_standard.v deleted file mode 100644 index 2998adb..0000000 --- a/src/versions/standard/Int63/Int63Op_standard.v +++ /dev/null @@ -1,334 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2022 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -Require Import Int31 Cyclic31. -Require Export Int63Native. -(* Require Import BigNumPrelude. *) -Require Import Bvector. - - -Local Open Scope int63_scope. - -(** The number of digits as a int *) -Definition digits := 31%int31. - -(** The bigger int *) -Definition max_int := Eval vm_compute in 0 - 1. - -(** Access to the nth digits *) -Definition get_digit x p := (0 < (x land (1 << p))). - -Definition set_digit x p (b:bool) := - if (0 <= p) && (p < digits) then - if b then x lor (1 << p) - else x land (max_int lxor (1 << p)) - else x. - -(** Equality to 0 *) -Definition is_zero (i:int) := i == 0. - -(** Parity *) -Definition is_even (i:int) := is_zero (i land 1). - -(** Bit *) - -Definition bit i n := negb (is_zero ((i >> n) << (digits - 1))). -(* Register bit as PrimInline. *) - -(** Extra modulo operations *) -Definition opp (i:int) := 0 - i. -Notation "- x" := (opp x) : int63_scope. - -Definition oppcarry i := max_int - i. - -Definition succ i := i + 1. - -Definition pred i := i - 1. - -Definition addcarry i j := i + j + 1. - -Definition subcarry i j := i - j - 1. - -(** Exact arithmetic operations *) - -Definition addc_def x y := - let r := x + y in - if r < x then C1 r else C0 r. -(* the same but direct implementation for efficiancy *) -Definition addc : int -> int -> carry int := add31c. -Notation "n '+c' m" := (addc n m) (at level 50, no associativity) : int63_scope. - -Definition addcarryc_def x y := - let r := addcarry x y in - if r <= x then C1 r else C0 r. -(* the same but direct implementation for efficiancy *) -Definition addcarryc : int -> int -> carry int := add31carryc. - -Definition subc_def x y := - if y <= x then C0 (x - y) else C1 (x - y). -(* the same but direct implementation for efficiancy *) -Definition subc : int -> int -> carry int := sub31c. -Notation "n '-c' m" := (subc n m) (at level 50, no associativity) : int63_scope. - -Definition subcarryc_def x y := - if y < x then C0 (x - y - 1) else C1 (x - y - 1). -(* the same but direct implementation for efficiancy *) -Definition subcarryc : int -> int -> carry int := sub31carryc. - -Definition diveucl_def x y := (x/y, x\%y). -(* the same but direct implementation for efficiancy *) -Definition diveucl : int -> int -> int * int := div31. - -Definition diveucl_21 : int -> int -> int -> int * int := div3121. - -Definition addmuldiv_def p x y := - (x << p) lor (y >> (digits - p)). -(* the same but direct implementation for efficiancy *) -Definition addmuldiv : int -> int -> int -> int := addmuldiv31. - -Definition oppc (i:int) := 0 -c i. - -Definition succc i := i +c 1. - -Definition predc i := i -c 1. - -(** Comparison *) -Definition compare_def x y := - if x < y then Lt - else if (x == y) then Eq else Gt. - -Definition compare : int -> int -> comparison := compare31. -Notation "n ?= m" := (compare n m) (at level 70, no associativity) : int63_scope. - -(** Exotic operations *) - -(** I should add the definition (like for compare) *) -Definition head0 : int -> int := head031. -Definition tail0 : int -> int := tail031. - -(** Iterators *) - -Definition foldi {A} (f:int -> A -> A) from to := - foldi_cont (fun i cont a => cont (f i a)) from to (fun a => a). - -Definition fold {A} (f: A -> A) from to := - foldi_cont (fun i cont a => cont (f a)) from to (fun a => a). - -Definition foldi_down {A} (f:int -> A -> A) from downto := - foldi_down_cont (fun i cont a => cont (f i a)) from downto (fun a => a). - -Definition fold_down {A} (f:A -> A) from downto := - foldi_down_cont (fun i cont a => cont (f a)) from downto (fun a => a). - -Definition forallb (f:int -> bool) from to := - foldi_cont (fun i cont _ => if f i then cont tt else false) from to (fun _ => true) tt. - -Definition existsb (f:int -> bool) from to := - foldi_cont (fun i cont _ => if f i then true else cont tt) from to (fun _ => false) tt. - -(** Translation to Z *) - -(* Fixpoint to_Z_rec (n:nat) (i:int) := *) -(* match n with *) -(* | O => 0%Z *) -(* | S n => *) -(* (if is_even i then Zdouble else Zdouble_plus_one) (to_Z_rec n (i >> 1)) *) -(* end. *) - -(* Definition to_Z := to_Z_rec size. *) - -Definition to_Z := phi. -Definition of_Z := phi_inv. - -(* Fixpoint of_pos_rec (n:nat) (p:positive) := *) -(* match n, p with *) -(* | O, _ => 0 *) -(* | S n, xH => 1 *) -(* | S n, xO p => (of_pos_rec n p) << 1 *) -(* | S n, xI p => (of_pos_rec n p) << 1 lor 1 *) -(* end. *) - -(* Definition of_pos := of_pos_rec size. *) - -(* Definition of_Z z := *) -(* match z with *) -(* | Zpos p => of_pos p *) -(* | Z0 => 0 *) -(* | Zneg p => - (of_pos p) *) -(* end. *) - -(** Gcd **) -Fixpoint gcd_rec (guard:nat) (i j:int) {struct guard} := - match guard with - | O => 1 - | S p => if j == 0 then i else gcd_rec p j (i \% j) - end. - -Definition gcd := gcd_rec (2*size). - -(** Square root functions using newton iteration **) - -Definition sqrt_step (rec: int -> int -> int) (i j: int) := - let quo := i/j in - if quo < j then rec i ((j + (i/j)%int) >> 1) - else j. - -Definition iter_sqrt := - Eval lazy beta delta [sqrt_step] in - fix iter_sqrt (n: nat) (rec: int -> int -> int) - (i j: int) {struct n} : int := - sqrt_step - (fun i j => match n with - O => rec i j - | S n => (iter_sqrt n (iter_sqrt n rec)) i j - end) i j. - -Definition sqrt i := - match compare 1 i with - Gt => 0 - | Eq => 1 - | Lt => iter_sqrt size (fun i j => j) i (i >> 1) - end. - -Definition high_bit := 1 << (digits - 1). - -Definition sqrt2_step (rec: int -> int -> int -> int) - (ih il j: int) := - if ih < j then - let (quo,_) := diveucl_21 ih il j in - if quo < j then - match j +c quo with - | C0 m1 => rec ih il (m1 >> 1) - | C1 m1 => rec ih il ((m1 >> 1) + high_bit) - end - else j - else j. - -Definition iter2_sqrt := - Eval lazy beta delta [sqrt2_step] in - fix iter2_sqrt (n: nat) - (rec: int -> int -> int -> int) - (ih il j: int) {struct n} : int := - sqrt2_step - (fun ih il j => - match n with - | O => rec ih il j - | S n => (iter2_sqrt n (iter2_sqrt n rec)) ih il j - end) ih il j. - -Definition sqrt2 ih il := - let s := iter2_sqrt size (fun ih il j => j) ih il max_int in - let (ih1, il1) := mulc s s in - match il -c il1 with - | C0 il2 => - if ih1 < ih then (s, C1 il2) else (s, C0 il2) - | C1 il2 => - if ih1 < (ih - 1) then (s, C1 il2) else (s, C0 il2) - end. - -(* Extra function on equality *) - -Definition cast_digit d1 d2 : - option (forall P : Int31.digits -> Type, P d1 -> P d2) := - match d1, d2 with - | D0, D0 | D1, D1 => Some (fun P h => h) - | _, _ => None - end. - -(* May need to improve this definition, but no reported efficiency problem for the moment *) -Definition cast i j : - option (forall P : int -> Type, P i -> P j) := - match i, j return option (forall P : int -> Type, P i -> P j) with - | I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d20 d21 d22 d23 d24 d25 d26 d27 d28 d29 d30, I31 d'0 d'1 d'2 d'3 d'4 d'5 d'6 d'7 d'8 d'9 d'10 d'11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30 => - match - cast_digit d0 d'0, - cast_digit d1 d'1, - cast_digit d2 d'2, - cast_digit d3 d'3, - cast_digit d4 d'4, - cast_digit d5 d'5, - cast_digit d6 d'6, - cast_digit d7 d'7, - cast_digit d8 d'8, - cast_digit d9 d'9, - cast_digit d10 d'10, - cast_digit d11 d'11, - cast_digit d12 d'12, - cast_digit d13 d'13, - cast_digit d14 d'14, - cast_digit d15 d'15, - cast_digit d16 d'16, - cast_digit d17 d'17, - cast_digit d18 d'18, - cast_digit d19 d'19, - cast_digit d20 d'20, - cast_digit d21 d'21, - cast_digit d22 d'22, - cast_digit d23 d'23, - cast_digit d24 d'24, - cast_digit d25 d'25, - cast_digit d26 d'26, - cast_digit d27 d'27, - cast_digit d28 d'28, - cast_digit d29 d'29, - cast_digit d30 d'30 - with - | Some k0, - Some k1, - Some k2, - Some k3, - Some k4, - Some k5, - Some k6, - Some k7, - Some k8, - Some k9, - Some k10, - Some k11, - Some k12, - Some k13, - Some k14, - Some k15, - Some k16, - Some k17, - Some k18, - Some k19, - Some k20, - Some k21, - Some k22, - Some k23, - Some k24, - Some k25, - Some k26, - Some k27, - Some k28, - Some k29, - Some k30 => - Some (fun P h => - k0 (fun d0 => P (I31 d0 d'1 d'2 d'3 d'4 d'5 d'6 d'7 d'8 d'9 d'10 d'11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k1 (fun d1 => P (I31 d0 d1 d'2 d'3 d'4 d'5 d'6 d'7 d'8 d'9 d'10 d'11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k2 (fun d2 => P (I31 d0 d1 d2 d'3 d'4 d'5 d'6 d'7 d'8 d'9 d'10 d'11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k3 (fun d3 => P (I31 d0 d1 d2 d3 d'4 d'5 d'6 d'7 d'8 d'9 d'10 d'11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k4 (fun d4 => P (I31 d0 d1 d2 d3 d4 d'5 d'6 d'7 d'8 d'9 d'10 d'11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k5 (fun d5 => P (I31 d0 d1 d2 d3 d4 d5 d'6 d'7 d'8 d'9 d'10 d'11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k6 (fun d6 => P (I31 d0 d1 d2 d3 d4 d5 d6 d'7 d'8 d'9 d'10 d'11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k7 (fun d7 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d'8 d'9 d'10 d'11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k8 (fun d8 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d'9 d'10 d'11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k9 (fun d9 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d'10 d'11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k10 (fun d10 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d'11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k11 (fun d11 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k12 (fun d12 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k13 (fun d13 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k14 (fun d14 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k15 (fun d15 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k16 (fun d16 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k17 (fun d17 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k18 (fun d18 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k19 (fun d19 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k20 (fun d20 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k21 (fun d21 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d20 d21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k22 (fun d22 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d20 d21 d22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k23 (fun d23 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d20 d21 d22 d23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k24 (fun d24 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d20 d21 d22 d23 d24 d'25 d'26 d'27 d'28 d'29 d'30)) (k25 (fun d25 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d20 d21 d22 d23 d24 d25 d'26 d'27 d'28 d'29 d'30)) (k26 (fun d26 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d20 d21 d22 d23 d24 d25 d26 d'27 d'28 d'29 d'30)) (k27 (fun d27 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d20 d21 d22 d23 d24 d25 d26 d27 d'28 d'29 d'30)) (k28 (fun d28 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d20 d21 d22 d23 d24 d25 d26 d27 d28 d'29 d'30)) (k29 (fun d29 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d20 d21 d22 d23 d24 d25 d26 d27 d28 d29 d'30)) (k30 (fun d30 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d20 d21 d22 d23 d24 d25 d26 d27 d28 d29 d30)) h))))))))))))))))))))))))))))))) - | _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _ => None - end - end. - - -Definition eqo i j : option (i = j) := - match cast i j with - | Some k => Some (k (fun j => i = j) (refl_equal i)) - | None => None - end. - - -(* - Local Variables: - coq-load-path: ((rec "../../.." "SMTCoq")) - End: -*) diff --git a/src/versions/standard/Int63/Int63Properties_standard.v b/src/versions/standard/Int63/Int63Properties_standard.v deleted file mode 100644 index a55295e..0000000 --- a/src/versions/standard/Int63/Int63Properties_standard.v +++ /dev/null @@ -1,2768 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2022 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -Require Import Zgcd_alt. -Require Import Bvector. -Require Import Int31 Cyclic31. -Require Export Int63Axioms. -Require Import Eqdep_dec. -Require Import Psatz. -Require Import Znumtheory Zpow_facts. - -Local Open Scope int63_scope. -Local Open Scope Z_scope. - - -Notation Zpower_2 := Z.pow_2_r. -Notation Zpower_Zsucc := Z.pow_succ_r. - - -(* Taken from BigNumPrelude *) - -Lemma Zlt0_not_eq : forall n, 0<n -> n<>0. -Proof. - auto with zarith. -Qed. - -Definition Z_div_plus_l a b c H := Zdiv.Z_div_plus_full_l a b c (Zlt0_not_eq _ H). - -Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. - Proof. - intros a b H H1;case (Z_mod_lt a b);auto with zarith;intros H2 H3;split;auto. - case (Z.le_gt_cases b a); intros H4; auto with zarith. - rewrite Zmod_small; auto with zarith. - Qed. - - -(** Trivial lemmas without axiom *) - -Lemma wB_diff_0 : wB <> 0. -Proof. compute;discriminate. Qed. - -Lemma wB_pos : 0 < wB. -Proof. reflexivity. Qed. - -Lemma to_Z_0 : [|0|] = 0. -Proof. reflexivity. Qed. - -Lemma to_Z_1 : [|1|] = 1. -Proof. reflexivity. Qed. - -(** equality *) -Lemma eqb_complete : forall x y, x = y -> (x == y) = true. -Proof. - intros x y H;rewrite H, eqb_refl;trivial. -Qed. - -Lemma eqb_spec : forall x y, (x == y) = true <-> x = y. -Proof. - split;auto using eqb_correct, eqb_complete. -Qed. - -Lemma eqb_false_spec : forall x y, (x == y) = false <-> x <> y. -Proof. - intros;rewrite <- not_true_iff_false, eqb_spec;split;trivial. -Qed. - -Lemma eqb_false_complete : forall x y, x <> y -> (x == y) = false. -Proof. - intros x y;rewrite eqb_false_spec;trivial. -Qed. - -Lemma eqb_false_correct : forall x y, (x == y) = false -> x <> y. -Proof. - intros x y;rewrite eqb_false_spec;trivial. -Qed. - -Definition eqs (i j : int) : {i = j} + { i <> j } := - (if i == j as b return ((b = true -> i = j) -> (b = false -> i <> j) -> {i=j} + {i <> j} ) - then fun (Heq : true = true -> i = j) _ => left _ (Heq (eq_refl true)) - else fun _ (Hdiff : false = false -> i <> j) => right _ (Hdiff (eq_refl false))) - (eqb_correct i j) - (eqb_false_correct i j). - -Lemma eq_dec : forall i j:int, i = j \/ i <> j. -Proof. - intros i j;destruct (eqs i j);auto. -Qed. - -(* TODO: fill these proofs *) -Lemma cast_refl : forall i, cast i i = Some (fun P H => H). -Admitted. -(* Proof. *) -(* unfold cast;intros. *) -(* generalize (eqb_correct i i). *) -(* rewrite eqb_refl;intros. *) -(* rewrite (eq_proofs_unicity eq_dec (e (eq_refl true)) (eq_refl i));trivial. *) -(* Qed. *) - -Lemma cast_diff : forall i j, i == j = false -> cast i j = None. -Admitted. -(* Proof. *) -(* intros;unfold cast;intros; generalize (eqb_correct i j). *) -(* rewrite H;trivial. *) -(* Qed. *) - -Lemma eqo_refl : forall i, eqo i i = Some (eq_refl i). -Admitted. -(* Proof. *) -(* unfold eqo;intros. *) -(* generalize (eqb_correct i i). *) -(* rewrite eqb_refl;intros. *) -(* rewrite (eq_proofs_unicity eq_dec (e (eq_refl true)) (eq_refl i));trivial. *) -(* Qed. *) - -Lemma eqo_diff : forall i j, i == j = false -> eqo i j = None. -Admitted. -(* Proof. *) -(* unfold eqo;intros; generalize (eqb_correct i j). *) -(* rewrite H;trivial. *) -(* Qed. *) - -(** translation with Z *) -Require Import Ndigits. - -Lemma Z_of_N_double : forall n, Z_of_N (N.double n) = Z.double (Z_of_N n). -Proof. - destruct n;simpl;trivial. -Qed. - -Lemma Z_of_N_double_plus_one : forall n, Z_of_N (Ndouble_plus_one n) = Zdouble_plus_one (Z_of_N n). -Proof. - destruct n;simpl;trivial. -Qed. - -Lemma to_Z_bounded : forall x, 0 <= [|x|] < wB. -Proof. apply phi_bounded. Qed. -(* unfold to_Z, wB;induction size;intros. *) -(* simpl;auto with zarith. *) -(* rewrite inj_S;simpl;assert (W:= IHn (x >> 1)%int). *) -(* rewrite Zpower_Zsucc;auto with zarith. *) -(* destruct (is_even x). *) -(* rewrite Z.double_mult;auto with zarith. *) -(* rewrite Zdouble_plus_one_mult;auto with zarith. *) -(* Qed. *) - -(* TODO: move_this *) -(* Lemma orb_true_iff : forall b1 b2, b1 || b2 = true <-> b1 = true \/ b2 = true. *) -(* Proof. *) -(* split;intros;[apply orb_prop | apply orb_true_intro];trivial. *) -(* Qed. *) - -Lemma to_Z_eq : forall x y, [|x|] = [|y|] <-> x = y. -Proof. - split;intros;subst;trivial. - apply to_Z_inj;trivial. -Qed. - -Lemma leb_ltb_eqb : forall x y, ((x <= y) = (x < y) || (x == y))%int. -Proof. - intros. - apply eq_true_iff_eq. - rewrite leb_spec, orb_true_iff, ltb_spec, eqb_spec, <- to_Z_eq;omega. -Qed. - - -(** Comparison *) - -Lemma compare_spec : - forall x y, compare x y = ([|x|] ?= [|y|]). -Proof. - intros;rewrite compare_def_spec;unfold compare_def. - case_eq (x < y)%int;intros Heq. - rewrite ltb_spec in Heq. - red in Heq;rewrite Heq;trivial. - rewrite <- not_true_iff_false, ltb_spec in Heq. - case_eq (x == y)%int;intros Heq1. - rewrite eqb_spec in Heq1;rewrite Heq1, Z.compare_refl;trivial. - rewrite <- not_true_iff_false, eqb_spec in Heq1. - symmetry;change ([|x|] > [|y|]);rewrite <- to_Z_eq in Heq1;omega. -Qed. - -Lemma is_zero_spec : forall x : int, is_zero x = true <-> x = 0%int. -Proof. - unfold is_zero;intros;apply eqb_spec. -Qed. - - -(** Addition *) - -Lemma addc_spec : forall x y, [+|x +c y|] = [|x|] + [|y|]. -Proof. - intros;rewrite addc_def_spec;unfold addc_def. - assert (W1 := to_Z_bounded x); assert (W2 := to_Z_bounded y). - case_eq ((x + y < x)%int). - rewrite ltb_spec;intros. - change (wB + [|x+y|] = [|x|] + [|y|]). - rewrite add_spec in H |- *. - assert ([|x|] + [|y|] >= wB). - destruct (Z_lt_ge_dec ([|x|] + [|y|]) wB);auto with zarith. - elimtype False;rewrite Zmod_small in H;auto with zarith. - assert (([|x|] + [|y|]) mod wB = [|x|] + [|y|] - wB). - symmetry;apply Zmod_unique with 1;auto with zarith. - rewrite H1;ring. - rewrite <- not_true_iff_false, ltb_spec;intros. - change ([|x+y|] = [|x|] + [|y|]). - rewrite add_spec in *. - assert ([|x|] + [|y|] < wB). - destruct (Z_lt_ge_dec ([|x|] + [|y|]) wB);auto with zarith. - assert (([|x|] + [|y|]) mod wB = [|x|] + [|y|] - wB). - symmetry;apply Zmod_unique with 1;auto with zarith. - elim H;omega. - rewrite Zmod_small;auto with zarith. -Qed. - - -Lemma succc_spec : forall x, [+|succc x|] = [|x|] + 1. -Proof. intros; unfold succc; apply addc_spec. Qed. - -Lemma addcarry_spec : forall x y, [|addcarry x y|] = ([|x|] + [|y|] + 1) mod wB. -Proof. - unfold addcarry;intros. - rewrite add_spec,add_spec,Zplus_mod_idemp_l;trivial. -Qed. - -Lemma addcarryc_spec : forall x y, [+|addcarryc x y|] = [|x|] + [|y|] + 1. -Proof. - intros;rewrite addcarryc_def_spec;unfold addcarryc_def. - assert (W1 := to_Z_bounded x); assert (W2 := to_Z_bounded y). - case_eq ((addcarry x y <= x)%int). - rewrite leb_spec;intros. - change (wB + [|(addcarry x y)|] = [|x|] + [|y|] + 1). - rewrite addcarry_spec in H |- *. - assert ([|x|] + [|y|] + 1 >= wB). - destruct (Z_lt_ge_dec ([|x|] + [|y|] + 1) wB);auto with zarith. - elimtype False;rewrite Zmod_small in H;auto with zarith. - assert (([|x|] + [|y|] + 1) mod wB = [|x|] + [|y|] + 1 - wB). - symmetry;apply Zmod_unique with 1;auto with zarith. - rewrite H1;ring. - rewrite <- not_true_iff_false, leb_spec;intros. - change ([|addcarry x y|] = [|x|] + [|y|] + 1). - rewrite addcarry_spec in *. - assert ([|x|] + [|y|] + 1 < wB). - destruct (Z_lt_ge_dec ([|x|] + [|y|] + 1) wB);auto with zarith. - assert (([|x|] + [|y|] + 1) mod wB = [|x|] + [|y|] + 1 - wB). - symmetry;apply Zmod_unique with 1;auto with zarith. - elim H;omega. - rewrite Zmod_small;auto with zarith. -Qed. - -Lemma succ_spec : forall x, [|succ x|] = ([|x|] + 1) mod wB. -Proof. intros; apply add_spec. Qed. - -(** Subtraction *) -Lemma subc_spec : forall x y, [-|x -c y|] = [|x|] - [|y|]. -Proof. - intros;rewrite subc_def_spec;unfold subc_def. - assert (W1 := to_Z_bounded x); assert (W2 := to_Z_bounded y). - case_eq (y <= x)%int. - rewrite leb_spec;intros. - change ([|x - y|] = [|x|] - [|y|]). - rewrite sub_spec. - rewrite Zmod_small;auto with zarith. - rewrite <- not_true_iff_false, leb_spec;intros. - change (-wB + [|x - y|] = [|x|] - [|y|]). - rewrite sub_spec. - assert (([|x|] - [|y|]) mod wB = [|x|] - [|y|] + wB). - symmetry;apply Zmod_unique with (-1);auto with zarith. - rewrite H0;ring. -Qed. - -Lemma subcarry_spec : - forall x y, [|subcarry x y|] = ([|x|] - [|y|] - 1) mod wB. -Proof. - unfold subcarry; intros. - rewrite sub_spec,sub_spec,Zminus_mod_idemp_l;trivial. -Qed. - -Lemma subcarryc_spec : forall x y, [-|subcarryc x y|] = [|x|] - [|y|] - 1. - intros;rewrite subcarryc_def_spec;unfold subcarryc_def. - assert (W1 := to_Z_bounded x); assert (W2 := to_Z_bounded y). - (* fold (subcarry x y). *) - replace ((x - y - 1)%int) with (subcarry x y) by reflexivity. - case_eq (y < x)%int. - rewrite ltb_spec;intros. - change ([|subcarry x y|] = [|x|] - [|y|] - 1). - rewrite subcarry_spec. - rewrite Zmod_small;auto with zarith. - rewrite <- not_true_iff_false, ltb_spec;intros. - change (-wB + [|subcarry x y|] = [|x|] - [|y|] - 1). - rewrite subcarry_spec. - assert (([|x|] - [|y|] - 1) mod wB = [|x|] - [|y|] - 1 + wB). - symmetry;apply Zmod_unique with (-1);auto with zarith. - rewrite H0;ring. -Qed. - -Lemma oppc_spec : forall x : int, [-|oppc x|] = - [|x|]. -Proof. - unfold oppc;intros;rewrite subc_spec, to_Z_0;trivial. -Qed. - -Lemma opp_spec : forall x : int, [|- x|] = - [|x|] mod wB. -Proof. - unfold opp;intros. rewrite sub_spec, to_Z_0;trivial. -Qed. - -Lemma oppcarry_spec : forall x, [|oppcarry x|] = wB - [|x|] - 1. -Proof. - unfold oppcarry;intros. - rewrite sub_spec. - change [|max_int|] with (wB - 1). - rewrite <- Zminus_plus_distr, Zplus_comm, Zminus_plus_distr. - apply Zmod_small. - generalize (to_Z_bounded x);auto with zarith. -Qed. - -Lemma predc_spec : forall x, [-|predc x|] = [|x|] - 1. -Proof. intros; unfold predc; apply subc_spec. Qed. - -Lemma pred_spec : forall x, [|pred x|] = ([|x|] - 1) mod wB. -Proof. intros; unfold pred; apply sub_spec. Qed. - -Lemma diveucl_spec : - forall x y, - let (q,r) := diveucl x y in - ([|q|],[|r|]) = Z.div_eucl [|x|] [|y|]. -Proof. - intros;rewrite diveucl_def_spec. - unfold diveucl_def;rewrite div_spec, mod_spec. - unfold Z.div, Zmod;destruct (Z.div_eucl [|x|] [|y|]);trivial. -Qed. - -(* Sqrt *) - - (* Direct transcription of an old proof - of a fortran program in boyer-moore *) - -Lemma quotient_by_2 a: a - 1 <= (a/2) + (a/2). -Proof. - case (Z_mod_lt a 2); auto with zarith. - intros H1; rewrite Zmod_eq_full; auto with zarith. -Qed. - -Lemma sqrt_main_trick j k: 0 <= j -> 0 <= k -> - (j * k) + j <= ((j + k)/2 + 1) ^ 2. -Proof. - intros Hj; generalize Hj k; pattern j; apply natlike_ind; - auto; clear k j Hj. - intros _ k Hk; repeat rewrite Zplus_0_l. - apply Zmult_le_0_compat; generalize (Z_div_pos k 2); auto with zarith. - intros j Hj Hrec _ k Hk; pattern k; apply natlike_ind; auto; clear k Hk. - rewrite Zmult_0_r, Zplus_0_r, Zplus_0_l. - generalize (sqr_pos (Z.succ j / 2)) (quotient_by_2 (Z.succ j)); - unfold Z.succ. - rewrite Zpower_2, Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r. - auto with zarith. - intros k Hk _. - replace ((Z.succ j + Z.succ k) / 2) with ((j + k)/2 + 1). - generalize (Hrec Hj k Hk) (quotient_by_2 (j + k)). - unfold Z.succ; repeat rewrite Zpower_2; - repeat rewrite Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r. - repeat rewrite Zmult_1_l; repeat rewrite Zmult_1_r. - auto with zarith. - rewrite Zplus_comm, <- Z_div_plus_full_l; auto with zarith. - apply f_equal2 with (f := Z.div); auto with zarith. -Qed. - -Lemma sqrt_main i j: 0 <= i -> 0 < j -> i < ((j + (i/j))/2 + 1) ^ 2. -Proof. - intros Hi Hj. - assert (Hij: 0 <= i/j) by (apply Z_div_pos; auto with zarith). - apply Z.lt_le_trans with (2 := sqrt_main_trick _ _ (Zlt_le_weak _ _ Hj) Hij). - pattern i at 1; rewrite (Z_div_mod_eq i j); case (Z_mod_lt i j); auto with zarith. -Qed. - -Lemma sqrt_init i: 1 < i -> i < (i/2 + 1) ^ 2. -Proof. - intros Hi. - assert (H1: 0 <= i - 2) by auto with zarith. - assert (H2: 1 <= (i / 2) ^ 2); auto with zarith. - replace i with (1* 2 + (i - 2)); auto with zarith. - rewrite Zpower_2, Z_div_plus_full_l; auto with zarith. - generalize (sqr_pos ((i - 2)/ 2)) (Z_div_pos (i - 2) 2). - rewrite Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r. - auto with zarith. - generalize (quotient_by_2 i). - rewrite Zpower_2 in H2 |- *; - repeat (rewrite Zmult_plus_distr_l || - rewrite Zmult_plus_distr_r || - rewrite Zmult_1_l || rewrite Zmult_1_r). - auto with zarith. -Qed. - -Lemma sqrt_test_true i j: 0 <= i -> 0 < j -> i/j >= j -> j ^ 2 <= i. -Proof. - intros Hi Hj Hd; rewrite Zpower_2. - apply Z.le_trans with (j * (i/j)); auto with zarith. - apply Z_mult_div_ge; auto with zarith. -Qed. - -Lemma sqrt_test_false i j: 0 <= i -> 0 < j -> i/j < j -> (j + (i/j))/2 < j. -Proof. - intros Hi Hj H; case (Zle_or_lt j ((j + (i/j))/2)); auto. - intros H1; contradict H; apply Zle_not_lt. - assert (2 * j <= j + (i/j)); auto with zarith. - apply Z.le_trans with (2 * ((j + (i/j))/2)); auto with zarith. - apply Z_mult_div_ge; auto with zarith. -Qed. - - -Lemma sqrt_step_correct rec i j: - 0 < [|i|] -> 0 < [|j|] -> [|i|] < ([|j|] + 1) ^ 2 -> - 2 * [|j|] < wB -> - (forall j1 : int, - 0 < [|j1|] < [|j|] -> [|i|] < ([|j1|] + 1) ^ 2 -> - [|rec i j1|] ^ 2 <= [|i|] < ([|rec i j1|] + 1) ^ 2) -> - [|sqrt_step rec i j|] ^ 2 <= [|i|] < ([|sqrt_step rec i j|] + 1) ^ 2. -Proof. - assert (Hp2: 0 < [|2|]) by exact (refl_equal Lt). - intros Hi Hj Hij H31 Hrec. - unfold sqrt_step. - case_eq ((i / j < j)%int);[ | rewrite <- Bool.not_true_iff_false]; - rewrite ltb_spec, div_spec;intros. - assert ([| j + (i / j)%int|] = [|j|] + [|i|]/[|j|]). - { - rewrite add_spec, Zmod_small;rewrite div_spec; auto with zarith. - split. - - apply Z.add_nonneg_nonneg. - + apply Z.lt_le_incl; apply Z.le_lt_trans with (2 := H). apply Z_div_pos. - * apply Z.lt_gt. abstract omega. - * abstract omega. - + apply Z_div_pos. - * apply Z.lt_gt. assumption. - * abstract omega. - - abstract omega. - } - apply Hrec;rewrite lsr_spec, H0, to_Z_1;change (2^1) with 2. - split; [ | apply sqrt_test_false;auto with zarith]. - replace ([|j|] + [|i|]/[|j|]) with - (1 * 2 + (([|j|] - 2) + [|i|] / [|j|]));[ | ring]. - rewrite Z_div_plus_full_l; auto with zarith. - assert (0 <= [|i|]/ [|j|]) by (apply Z_div_pos; auto with zarith). - assert (0 <= ([|j|] - 2 + [|i|] / [|j|]) / 2) ; auto with zarith. - case (Zle_lt_or_eq 1 [|j|]); auto with zarith. - { - intro. apply Z_div_pos. - - apply Zgt_pos_0. - - apply Z.add_nonneg_nonneg. - + abstract omega. - + assumption. - } - intros Hj1. - rewrite <- Hj1, Zdiv_1_r. - assert (0 <= ([|i|] - 1) /2)%Z;[ |apply Z_div_pos]; auto with zarith. - { - apply Z_div_pos. - - apply Zgt_pos_0. - - abstract omega. - } - apply sqrt_main;auto with zarith. - split;[apply sqrt_test_true | ];auto with zarith. -Qed. - -Lemma iter_sqrt_correct n rec i j: 0 < [|i|] -> 0 < [|j|] -> - [|i|] < ([|j|] + 1) ^ 2 -> 2 * [|j|] < wB -> - (forall j1, 0 < [|j1|] -> 2^(Z_of_nat n) + [|j1|] <= [|j|] -> - [|i|] < ([|j1|] + 1) ^ 2 -> 2 * [|j1|] < wB -> - [|rec i j1|] ^ 2 <= [|i|] < ([|rec i j1|] + 1) ^ 2) -> - [|iter_sqrt n rec i j|] ^ 2 <= [|i|] < ([|iter_sqrt n rec i j|] + 1) ^ 2. -Proof. - revert rec i j; elim n; unfold iter_sqrt; fold iter_sqrt; clear n. - intros rec i j Hi Hj Hij H31 Hrec. replace (and (Z.le (Z.pow (to_Z match ltb (div i j) j return int with | true => rec i (lsr (add31 j (div i j)) In) | false => j end) (Zpos (xO xH))) (to_Z i)) (Z.lt (to_Z i) (Z.pow (Z.add (to_Z match ltb (div i j) j return int with | true => rec i (lsr (add31 j (div i j)) In) | false => j end) (Zpos xH)) (Zpos (xO xH))))) with ([|sqrt_step rec i j|] ^ 2 <= [|i|] < ([|sqrt_step rec i j|] + 1) ^ 2) by reflexivity. apply sqrt_step_correct; auto with zarith. - intros; apply Hrec; auto with zarith. - rewrite Zpower_0_r; auto with zarith. - intros n Hrec rec i j Hi Hj Hij H31 HHrec. - replace (and (Z.le (Z.pow (to_Z match ltb (div i j) j return int with | true => iter_sqrt n (iter_sqrt n rec) i (lsr (add31 j (div i j)) In) | false => j end) (Zpos (xO xH))) (to_Z i)) (Z.lt (to_Z i) (Z.pow (Z.add (to_Z match ltb (div i j) j return int with | true => iter_sqrt n (iter_sqrt n rec) i (lsr (add31 j (div i j)) In) | false => j end) (Zpos xH)) (Zpos (xO xH))))) with ([|sqrt_step (iter_sqrt n (iter_sqrt n rec)) i j|] ^ 2 <= [|i|] < ([|sqrt_step (iter_sqrt n (iter_sqrt n rec)) i j|] + 1) ^ 2) by reflexivity. - apply sqrt_step_correct; auto. - intros j1 Hj1 Hjp1; apply Hrec; auto with zarith. - intros j2 Hj2 H2j2 Hjp2 Hj31; apply Hrec; auto with zarith. - intros j3 Hj3 Hpj3. - apply HHrec; auto. - rewrite inj_S, Zpower_Zsucc. - apply Z.le_trans with (2 ^Z_of_nat n + [|j2|]); auto with zarith. - apply Zle_0_nat. -Qed. - -Lemma sqrt_spec : forall x, - [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2. -Proof. - intros i; unfold sqrt. - rewrite compare_spec. case Z.compare_spec; rewrite to_Z_1; - intros Hi; auto with zarith. - repeat rewrite Zpower_2; auto with zarith. - apply iter_sqrt_correct; auto with zarith; - rewrite lsr_spec, to_Z_1; change (2^1) with 2; auto with zarith. - replace ([|i|]) with (1 * 2 + ([|i|] - 2))%Z; try ring. - assert (0 <= ([|i|] - 2)/2)%Z by (apply Z_div_pos; auto with zarith). - rewrite Z_div_plus_full_l; auto with zarith. - apply sqrt_init; auto. - assert (W:= Z_mult_div_ge [|i|] 2);assert (W':= to_Z_bounded i);auto with zarith. - intros j2 H1 H2; contradict H2; apply Zlt_not_le. - fold wB;assert (W:=to_Z_bounded i). - apply Z.le_lt_trans with ([|i|]); auto with zarith. - assert (0 <= [|i|]/2)%Z by (apply Z_div_pos; auto with zarith). - apply Z.le_trans with (2 * ([|i|]/2)); auto with zarith. - apply Z_mult_div_ge; auto with zarith. - case (to_Z_bounded i); repeat rewrite Zpower_2; auto with zarith. -Qed. - -Lemma sqrt2_step_def rec ih il j: - sqrt2_step rec ih il j = - if (ih < j)%int then - let quo := fst (diveucl_21 ih il j) in - if (quo < j)%int then - let m := - match j +c quo with - | C0 m1 => m1 >> 1 - | C1 m1 => (m1 >> 1 + 1 << (digits -1))%int - end in - rec ih il m - else j - else j. -Proof. - unfold sqrt2_step; case diveucl_21; intros;simpl. - case (j +c i);trivial. -Qed. - -Lemma sqrt2_lower_bound ih il j: - [|| WW ih il||] < ([|j|] + 1) ^ 2 -> [|ih|] <= [|j|]. -Proof. - intros H1. - case (to_Z_bounded j); intros Hbj _. - case (to_Z_bounded il); intros Hbil _. - case (to_Z_bounded ih); intros Hbih Hbih1. - assert (([|ih|] < [|j|] + 1)%Z); auto with zarith. - apply Zlt_square_simpl; auto with zarith. - simpl zn2z_to_Z in H1. - repeat rewrite <-Zpower_2; apply Z.le_lt_trans with (2 := H1). - apply Z.le_trans with ([|ih|] * wB)%Z;try rewrite Zpower_2; auto with zarith. -Qed. - - -Lemma div2_phi ih il j: - [|fst (diveucl_21 ih il j)|] = [|| WW ih il||] /[|j|]. -Proof. - generalize (diveucl_21_spec ih il j). - case diveucl_21; intros q r Heq. - simpl zn2z_to_Z;unfold Z.div;rewrite <- Heq;trivial. -Qed. - -Lemma zn2z_to_Z_pos ih il : 0 <= [||WW ih il||]. -Proof. - simpl zn2z_to_Z;destruct (to_Z_bounded ih);destruct (to_Z_bounded il);auto with zarith. -Qed. - - -Lemma sqrt2_step_correct rec ih il j: - 2 ^ (Z_of_nat (size - 2)) <= [|ih|] -> - 0 < [|j|] -> [|| WW ih il||] < ([|j|] + 1) ^ 2 -> - (forall j1, 0 < [|j1|] < [|j|] -> [|| WW ih il||] < ([|j1|] + 1) ^ 2 -> - [|rec ih il j1|] ^ 2 <= [||WW ih il||] < ([|rec ih il j1|] + 1) ^ 2) -> - [|sqrt2_step rec ih il j|] ^ 2 <= [||WW ih il ||] - < ([|sqrt2_step rec ih il j|] + 1) ^ 2. -Proof. - assert (Hp2: (0 < [|2|])%Z) by exact (refl_equal Lt). - intros Hih Hj Hij Hrec; rewrite sqrt2_step_def. - assert (H1: ([|ih|] <= [|j|])%Z) by (apply sqrt2_lower_bound with il; auto). - case (to_Z_bounded ih); intros Hih1 _. - case (to_Z_bounded il); intros Hil1 _. - case (to_Z_bounded j); intros _ Hj1. - assert (Hp3: (0 < [||WW ih il||])). - simpl zn2z_to_Z;apply Z.lt_le_trans with ([|ih|] * wB)%Z; auto with zarith. - apply Zmult_lt_0_compat; auto with zarith. - apply Z.lt_le_trans with (2:= Hih); auto with zarith. - cbv zeta. - case_eq (ih < j)%int;intros Heq. - rewrite ltb_spec in Heq. - 2: rewrite <-not_true_iff_false, ltb_spec in Heq. - 2: split; auto. - 2: apply sqrt_test_true; auto with zarith. - 2: unfold zn2z_to_Z; replace [|ih|] with [|j|]; auto with zarith. - 2: assert (0 <= [|il|]/[|j|]) by (apply Z_div_pos; auto with zarith). - 2: rewrite Zmult_comm, Z_div_plus_full_l; unfold base; auto with zarith. - case (Zle_or_lt (2^(Z_of_nat size -1)) [|j|]); intros Hjj. - case_eq (fst (diveucl_21 ih il j) < j)%int;intros Heq0. - 2: rewrite <-not_true_iff_false, ltb_spec, div2_phi in Heq0. - 2: split; auto; apply sqrt_test_true; auto with zarith. - rewrite ltb_spec, div2_phi in Heq0. - match goal with |- context[rec _ _ ?X] => - set (u := X) - end. - assert (H: [|u|] = ([|j|] + ([||WW ih il||])/([|j|]))/2). - unfold u; generalize (addc_spec j (fst (diveucl_21 ih il j))); - case addc;unfold interp_carry;rewrite div2_phi;simpl zn2z_to_Z. - intros i H;rewrite lsr_spec, H;trivial. - intros i H;rewrite <- H. - case (to_Z_bounded i); intros H1i H2i. - rewrite add_spec, Zmod_small, lsr_spec. - change (1 * wB) with ([|(1 << (digits -1))|] * 2)%Z. - rewrite Z_div_plus_full_l; auto with zarith. - change wB with (2 * (wB/2))%Z; auto. - replace [|(1 << (digits - 1))|] with (wB/2); auto. - rewrite lsr_spec; auto. - replace (2^[|1|]) with 2%Z; auto. - split. - { - apply Z.add_nonneg_nonneg. - - apply Z_div_pos. - + apply Zgt_pos_0. - + assumption. - - apply Z_div_pos. - + apply Zgt_pos_0. - + abstract omega. - } - assert ([|i|]/2 < wB/2); auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. - apply Hrec; rewrite H; clear u H. - assert (Hf1: 0 <= [||WW ih il||]/ [|j|]) by (apply Z_div_pos; auto with zarith). - case (Zle_lt_or_eq 1 ([|j|])); auto with zarith; intros Hf2. - 2: contradict Heq0; apply Zle_not_lt; rewrite <- Hf2, Zdiv_1_r; assert (H10: forall (x:Z), 0 < x -> 1 <= x) by (intros; omega); auto. - split. - replace ([|j|] + [||WW ih il||]/ [|j|])%Z with - (1 * 2 + (([|j|] - 2) + [||WW ih il||] / [|j|])); try ring. - rewrite Z_div_plus_full_l; auto with zarith. - assert (0 <= ([|j|] - 2 + [||WW ih il||] / [|j|]) / 2) ; auto with zarith. - { - apply Z_div_pos. - - apply Zgt_pos_0. - - apply Z.add_nonneg_nonneg. - + abstract omega. - + assumption. - } - apply sqrt_test_false; auto with zarith. - apply sqrt_main; auto with zarith. - contradict Hij; apply Zle_not_lt. - assert ((1 + [|j|]) <= 2 ^ (Z_of_nat size - 1)); auto with zarith. - apply Z.le_trans with ((2 ^ (Z_of_nat size - 1)) ^2); auto with zarith. - assert (0 <= 1 + [|j|]); auto with zarith. - apply Zmult_le_compat; auto with zarith. - change ((2 ^ (Z_of_nat size - 1))^2) with (2 ^ (Z_of_nat size - 2) * wB). - apply Z.le_trans with ([|ih|] * wB); auto with zarith. - unfold zn2z_to_Z, wB; auto with zarith. -Qed. - - - -Lemma iter2_sqrt_correct n rec ih il j: - 2^(Z_of_nat (size - 2)) <= [|ih|] -> 0 < [|j|] -> [||WW ih il||] < ([|j|] + 1) ^ 2 -> - (forall j1, 0 < [|j1|] -> 2^(Z_of_nat n) + [|j1|] <= [|j|] -> - [||WW ih il||] < ([|j1|] + 1) ^ 2 -> - [|rec ih il j1|] ^ 2 <= [||WW ih il||] < ([|rec ih il j1|] + 1) ^ 2) -> - [|iter2_sqrt n rec ih il j|] ^ 2 <= [||WW ih il||] - < ([|iter2_sqrt n rec ih il j|] + 1) ^ 2. -Proof. - revert rec ih il j; elim n; unfold iter2_sqrt; fold iter2_sqrt; clear n. - intros rec ih il j Hi Hj Hij Hrec; apply sqrt2_step_correct; auto with zarith. - intros; apply Hrec; auto with zarith. - rewrite Zpower_0_r; auto with zarith. - intros n Hrec rec ih il j Hi Hj Hij HHrec. - apply sqrt2_step_correct; auto. - intros j1 Hj1 Hjp1; apply Hrec; auto with zarith. - intros j2 Hj2 H2j2 Hjp2; apply Hrec; auto with zarith. - intros j3 Hj3 Hpj3. - apply HHrec; auto. - rewrite inj_S, Zpower_Zsucc. - apply Z.le_trans with (2 ^Z_of_nat n + [|j2|])%Z; auto with zarith. - apply Zle_0_nat. -Qed. - - -Lemma sqrt2_spec : forall x y, - wB/ 4 <= [|x|] -> - let (s,r) := sqrt2 x y in - [||WW x y||] = [|s|] ^ 2 + [+|r|] /\ - [+|r|] <= 2 * [|s|]. - Proof. - intros ih il Hih; unfold sqrt2. - change [||WW ih il||] with ([||WW ih il||]). - assert (Hbin: forall s, s * s + 2* s + 1 = (s + 1) ^ 2) by - (intros s; ring). - assert (Hb: 0 <= wB) by (red; intros HH; discriminate). - assert (Hi2: [||WW ih il ||] < ([|max_int|] + 1) ^ 2). - apply Z.le_lt_trans with ((wB - 1) * wB + (wB - 1)); auto with zarith. - 2: apply refl_equal. - case (to_Z_bounded ih); case (to_Z_bounded il); intros H1 H2 H3 H4. - unfold zn2z_to_Z; auto with zarith. - case (iter2_sqrt_correct size (fun _ _ j => j) ih il max_int); auto with zarith. - apply refl_equal. - intros j1 _ HH; contradict HH. - apply Zlt_not_le. - case (to_Z_bounded j1); auto with zarith. - change (2 ^ Z_of_nat size) with ([|max_int|]+1)%Z; auto with zarith. - set (s := iter2_sqrt size (fun _ _ j : int=> j) ih il max_int). - intros Hs1 Hs2. - generalize (mulc_spec s s); case mulc. - simpl fst; simpl snd; intros ih1 il1 Hihl1. - generalize (subc_spec il il1). - case subc; intros il2 Hil2. - simpl interp_carry in Hil2. - case_eq (ih1 < ih)%int; [idtac | rewrite <- not_true_iff_false]; - rewrite ltb_spec; intros Heq. - unfold interp_carry; rewrite Zmult_1_l. - rewrite Zpower_2, Hihl1, Hil2. - case (Zle_lt_or_eq ([|ih1|] + 1) ([|ih|])); auto with zarith. - intros H2; contradict Hs2; apply Zle_not_lt. - replace (([|s|] + 1) ^ 2) with ([||WW ih1 il1||] + 2 * [|s|] + 1). - unfold zn2z_to_Z. - case (to_Z_bounded il); intros Hpil _. - assert (Hl1l: [|il1|] <= [|il|]). - case (to_Z_bounded il2); rewrite Hil2; auto with zarith. - assert ([|ih1|] * wB + 2 * [|s|] + 1 <= [|ih|] * wB); auto with zarith. - case (to_Z_bounded s); intros _ Hps. - case (to_Z_bounded ih1); intros Hpih1 _; auto with zarith. - apply Z.le_trans with (([|ih1|] + 2) * wB); auto with zarith. - rewrite Zmult_plus_distr_l. - assert (2 * [|s|] + 1 <= 2 * wB); auto with zarith. - unfold zn2z_to_Z; rewrite <-Hihl1, Hbin; auto. - intros H2; split. - unfold zn2z_to_Z; rewrite <- H2; ring. - replace (wB + ([|il|] - [|il1|])) with ([||WW ih il||] - ([|s|] * [|s|])). - rewrite <-Hbin in Hs2; assert (([||WW ih il||] < [|s|] * [|s|] + 2 * [|s|] + 1) -> ([||WW ih il||] - [|s|] * [|s|] <= 2 * [|s|])) by omega; auto. - rewrite Hihl1; unfold zn2z_to_Z; rewrite <- H2; ring. - unfold interp_carry. - case (Zle_lt_or_eq [|ih|] [|ih1|]); auto with zarith; intros H. - contradict Hs1. - apply Zlt_not_le; rewrite Zpower_2, Hihl1. - unfold zn2z_to_Z. - case (to_Z_bounded il); intros _ H2. - apply Z.lt_le_trans with (([|ih|] + 1) * wB + 0). - rewrite Zmult_plus_distr_l, Zplus_0_r; auto with zarith. - case (to_Z_bounded il1); intros H3 _. - apply Zplus_le_compat; auto with zarith. - split. - rewrite Zpower_2, Hihl1. - unfold zn2z_to_Z; ring[Hil2 H]. - replace [|il2|] with ([||WW ih il||] - [||WW ih1 il1||]). - unfold zn2z_to_Z at 2; rewrite <-Hihl1. - rewrite <-Hbin in Hs2; assert (([||WW ih il||] < [|s|] * [|s|] + 2 * [|s|] + 1) -> ([||WW ih il||] - [|s|] * [|s|] <= 2 * [|s|])) by omega; auto. - unfold zn2z_to_Z; rewrite H, Hil2; ring. - unfold interp_carry in Hil2 |- *. - assert (Hsih: [|ih - 1|] = [|ih|] - 1). - rewrite sub_spec, Zmod_small; auto; replace [|1|] with 1; auto. - case (to_Z_bounded ih); intros H1 H2. - split; auto with zarith. - apply Z.le_trans with (wB/4 - 1); auto with zarith. - case_eq (ih1 < ih - 1)%int; [idtac | rewrite <- not_true_iff_false]; - rewrite ltb_spec, Hsih; intros Heq. - rewrite Zpower_2, Hihl1. - case (Zle_lt_or_eq ([|ih1|] + 2) [|ih|]); auto with zarith. - intros H2; contradict Hs2; apply Zle_not_lt. - replace (([|s|] + 1) ^ 2) with ([||WW ih1 il1||] + 2 * [|s|] + 1). - unfold zn2z_to_Z. - assert ([|ih1|] * wB + 2 * [|s|] + 1 <= [|ih|] * wB + ([|il|] - [|il1|])); - auto with zarith. - rewrite <-Hil2. - case (to_Z_bounded il2); intros Hpil2 _. - apply Z.le_trans with ([|ih|] * wB + - wB); auto with zarith. - case (to_Z_bounded s); intros _ Hps. - assert (2 * [|s|] + 1 <= 2 * wB); auto with zarith. - apply Z.le_trans with ([|ih1|] * wB + 2 * wB); auto with zarith. - assert (Hi: ([|ih1|] + 3) * wB <= [|ih|] * wB); auto with zarith. - rewrite Zmult_plus_distr_l in Hi; auto with zarith. - unfold zn2z_to_Z; rewrite <-Hihl1, Hbin; auto. - intros H2; unfold zn2z_to_Z; rewrite <-H2. - split. - replace [|il|] with (([|il|] - [|il1|]) + [|il1|]); try ring. - rewrite <-Hil2; ring. - replace (1 * wB + [|il2|]) with ([||WW ih il||] - [||WW ih1 il1||]). - unfold zn2z_to_Z at 2; rewrite <-Hihl1. - rewrite <-Hbin in Hs2; assert (([||WW ih il||] < [|s|] * [|s|] + 2 * [|s|] + 1) -> ([||WW ih il||] - [|s|] * [|s|] <= 2 * [|s|])) by omega; auto. - unfold zn2z_to_Z; rewrite <-H2. - replace [|il|] with (([|il|] - [|il1|]) + [|il1|]); try ring. - rewrite <-Hil2; ring. - case (Zle_lt_or_eq ([|ih|] - 1) ([|ih1|])); auto with zarith; intros H1. - assert (He: [|ih|] = [|ih1|]). - apply Zle_antisym; auto with zarith. - case (Zle_or_lt [|ih1|] [|ih|]); auto; intros H2. - contradict Hs1; apply Zlt_not_le; rewrite Zpower_2, Hihl1. - unfold zn2z_to_Z. - case (to_Z_bounded il); intros _ Hpil1. - apply Z.lt_le_trans with (([|ih|] + 1) * wB). - rewrite Zmult_plus_distr_l, Zmult_1_l; auto with zarith. - case (to_Z_bounded il1); intros Hpil2 _. - apply Z.le_trans with (([|ih1|]) * wB); auto with zarith. - contradict Hs1; apply Zlt_not_le; rewrite Zpower_2, Hihl1. - unfold zn2z_to_Z; rewrite He. - assert ([|il|] - [|il1|] < 0); auto with zarith. - rewrite <-Hil2. - case (to_Z_bounded il2); auto with zarith. - split. - rewrite Zpower_2, Hihl1. - unfold zn2z_to_Z; rewrite <-H1. - apply trans_equal with ([|ih|] * wB + [|il1|] + ([|il|] - [|il1|])). - ring. - rewrite <-Hil2; ring. - replace [|il2|] with ([||WW ih il||] - [||WW ih1 il1||]). - unfold zn2z_to_Z at 2; rewrite <- Hihl1. - rewrite <-Hbin in Hs2; assert (([||WW ih il||] < [|s|] * [|s|] + 2 * [|s|] + 1) -> ([||WW ih il||] - [|s|] * [|s|] <= 2 * [|s|])) by omega; auto. - unfold zn2z_to_Z. - rewrite <-H1. - ring_simplify. - apply trans_equal with (wB + ([|il|] - [|il1|])). - ring. - rewrite <-Hil2; ring. -Qed. - -Lemma to_Z_gcd : forall i j, - [|gcd i j|] = Zgcdn (2*size) [|j|] [|i|]. -Proof. - unfold gcd. - induction (2*size)%nat; intros. - reflexivity. - simpl. - generalize (to_Z_bounded j)(to_Z_bounded i); intros. - case_eq (j == 0)%int. - rewrite eqb_spec;intros H1;rewrite H1. - replace [|0|] with 0;trivial;rewrite Z.abs_eq;auto with zarith. - rewrite <- not_true_iff_false, eqb_spec;intros. - case_eq [|j|]; intros. - elim H1;apply to_Z_inj;assumption. - rewrite IHn, <- H2, mod_spec;trivial. - rewrite H2 in H;destruct H as (H, _);elim H;trivial. -Qed. - -Lemma gcd_spec : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|]. -Proof. - intros. - rewrite to_Z_gcd. - apply Zis_gcd_sym. - apply Zgcdn_is_gcd. - unfold Zgcd_bound. - generalize (to_Z_bounded b). - destruct [|b|]. - unfold size; intros _; change Int31.size with 31%nat; omega. - intros (_,H). - cut (Psize p <= size)%nat; [ omega | rewrite <- Zpower2_Psize; auto]. - intros (H,_); compute in H; elim H; auto. -Qed. - -Lemma head00_spec: forall x, [|x|] = 0 -> [|head0 x|] = [|digits|]. -Proof. - change 0 with [|0|];intros x Heq. - apply to_Z_inj in Heq;rewrite Heq;trivial. -Qed. - -Lemma tail00_spec: forall x, [|x|] = 0 -> [|tail0 x|] = [|digits|]. -Proof. - change 0 with [|0|];intros x Heq. - apply to_Z_inj in Heq;rewrite Heq;trivial. -Qed. - -(* lsr lsl *) -Lemma lsl_0_l i: 0 << i = 0%int. -Proof. - apply to_Z_inj. - generalize (lsl_spec 0 i). - rewrite to_Z_0, Zmult_0_l, Zmod_0_l; auto. -Qed. - -Lemma lsl_0_r i: i << 0 = i. -Proof. - apply to_Z_inj. - rewrite lsl_spec, to_Z_0, Zmult_1_r. - apply Zmod_small; apply (to_Z_bounded i). -Qed. - -Lemma lsl_M_r x i (H: (digits <= i = true)%int) : x << i = 0%int. -Proof. - apply to_Z_inj. - rewrite lsl_spec, to_Z_0. - rewrite leb_spec in H. - unfold wB; change (Z_of_nat size) with [|digits|]. - replace ([|i|]) with (([|i|] - [|digits|]) + [|digits|])%Z; try ring. - rewrite Zpower_exp, Zmult_assoc, Z_mod_mult; auto with arith. - apply Z.le_ge; auto with zarith. - case (to_Z_bounded digits); auto with zarith. -Qed. - -Lemma lsr_0_l i: 0 >> i = 0%int. -Proof. - apply to_Z_inj. - generalize (lsr_spec 0 i). - rewrite to_Z_0, Zdiv_0_l; auto. -Qed. - -Lemma lsr_0_r i: i >> 0 = i. -Proof. - apply to_Z_inj. - rewrite lsr_spec, to_Z_0, Zdiv_1_r; auto. -Qed. - -Lemma lsr_M_r x i (H: (digits <= i = true)%int) : x >> i = 0%int. -Proof. - apply to_Z_inj. - rewrite lsr_spec, to_Z_0. - case (to_Z_bounded x); intros H1x H2x. - case (to_Z_bounded digits); intros H1d H2d. - rewrite leb_spec in H. - apply Zdiv_small; split; auto. - apply Z.lt_le_trans with (1 := H2x). - unfold wB; change (Z_of_nat size) with [|digits|]. - apply Zpower_le_monotone; auto with zarith. -Qed. - -Lemma add_le_r m n: - if (n <= m + n)%int then ([|m|] + [|n|] < wB)%Z else (wB <= [|m|] + [|n|])%Z. -Proof. - case (to_Z_bounded m); intros H1m H2m. - case (to_Z_bounded n); intros H1n H2n. - case (Zle_or_lt wB ([|m|] + [|n|])); intros H. - assert (H1: ([| m + n |] = [|m|] + [|n|] - wB)%Z). - rewrite add_spec. - replace (([|m|] + [|n|]) mod wB)%Z with (((([|m|] + [|n|]) - wB) + wB) mod wB)%Z. - rewrite Zplus_mod, Z_mod_same_full, Zplus_0_r, !Zmod_small; auto with zarith. - rewrite !Zmod_small; auto with zarith. - apply f_equal2 with (f := Zmod); auto with zarith. - case_eq (n <= m + n)%int; auto. - rewrite leb_spec, H1; auto with zarith. - assert (H1: ([| m + n |] = [|m|] + [|n|])%Z). - rewrite add_spec, Zmod_small; auto with zarith. - replace (n <= m + n)%int with true; auto. - apply sym_equal; rewrite leb_spec, H1; auto with zarith. -Qed. - -Lemma lsr_add i m n: ((i >> m) >> n = if n <= m + n then i >> (m + n) else 0)%int. -Proof. - case (to_Z_bounded m); intros H1m H2m. - case (to_Z_bounded n); intros H1n H2n. - case (to_Z_bounded i); intros H1i H2i. - generalize (add_le_r m n); case (n <= m + n)%int; intros H. - apply to_Z_inj; rewrite !lsr_spec, Zdiv_Zdiv, <- Zpower_exp; auto with zarith. - rewrite add_spec, Zmod_small; auto with zarith. - apply to_Z_inj; rewrite !lsr_spec, Zdiv_Zdiv, <- Zpower_exp; auto with zarith. - apply Zdiv_small; split; auto with zarith. - apply Z.lt_le_trans with (1 := H2i). - apply Z.le_trans with (1 := H). - apply Zpower2_le_lin; auto with zarith. -Qed. - -Lemma lsl_add i m n: ((i << m) << n = if n <= m + n then i << (m + n) else 0)%int. -Proof. - case (to_Z_bounded m); intros H1m H2m. - case (to_Z_bounded n); intros H1n H2n. - case (to_Z_bounded i); intros H1i H2i. - generalize (add_le_r m n); case (n <= m + n)%int; intros H. - apply to_Z_inj; rewrite !lsl_spec, Zmult_mod, Zmod_mod, <- Zmult_mod. - rewrite <-Zmult_assoc, <- Zpower_exp; auto with zarith. - apply f_equal2 with (f := Zmod); auto. - rewrite add_spec, Zmod_small; auto with zarith. - apply to_Z_inj; rewrite !lsl_spec, Zmult_mod, Zmod_mod, <- Zmult_mod. - rewrite <-Zmult_assoc, <- Zpower_exp; auto with zarith. - unfold wB. - replace ([|m|] + [|n|])%Z with - ((([|m|] + [|n|]) - Z_of_nat size) + Z_of_nat size)%Z. - 2: ring. - rewrite Zpower_exp, Zmult_assoc, Z_mod_mult; auto with zarith. - assert (Z_of_nat size < wB)%Z; auto with zarith. - apply Zpower2_lt_lin; auto with zarith. -Qed. - - -Coercion b2i (b: bool) : int := if b then 1%int else 0%int. - -Lemma bit_0 n : bit 0 n = false. -Proof. unfold bit; rewrite lsr_0_l; auto. Qed. - -Lemma lsr_1 n : 1 >> n = (n == 0). -Proof. - case_eq (n == 0). - rewrite eqb_spec; intros H; rewrite H, lsr_0_r. - apply refl_equal. - intros Hn. - assert (H1n : (1 >> n = 0)%int); auto. - apply to_Z_inj; rewrite lsr_spec. - apply Zdiv_small; rewrite to_Z_1; split; auto with zarith. - change 1%Z with (2^0)%Z. - apply Zpower_lt_monotone; split; auto with zarith. - case (Zle_lt_or_eq 0 [|n|]); auto. - case (to_Z_bounded n); auto. - intros H1. - assert ((n == 0) = true). - rewrite eqb_spec; apply to_Z_inj; rewrite <-H1, to_Z_0; auto. - generalize H; rewrite Hn; discriminate. -Qed. - -Lemma bit_1 n : bit 1 n = (n == 0). -Proof. - unfold bit; rewrite lsr_1. - case (n == 0). - apply refl_equal. - rewrite lsl_0_l; apply refl_equal. -Qed. - -Lemma bit_M i n (H: (digits <= n = true)%int): bit i n = false. -Proof. unfold bit; rewrite lsr_M_r; auto. Qed. - -Lemma bit_half i n (H: (n < digits = true)%int) : bit (i>>1) n = bit i (n+1). -Proof. - unfold bit. - rewrite lsr_add. - case_eq (n <= (1 + n))%int. - replace (1+n)%int with (n+1)%int; [auto|idtac]. - apply to_Z_inj; rewrite !add_spec, Zplus_comm; auto. - intros H1; assert (H2: n = max_int). - 2: generalize H; rewrite H2; discriminate. - case (to_Z_bounded n); intros H1n H2n. - case (Zle_lt_or_eq [|n|] (wB - 1)); auto with zarith; - intros H2; apply to_Z_inj; auto. - generalize (add_le_r 1 n); rewrite H1. - change [|max_int|] with (wB - 1)%Z. - replace [|1|] with 1%Z; auto with zarith. -Qed. - -Lemma bit_0_spec i: [|bit i 0|] = [|i|] mod 2. -Proof. - unfold bit, is_zero; rewrite lsr_0_r. - assert (Hbi: ([|i|] mod 2 < 2)%Z). - apply Z_mod_lt; auto with zarith. - case (to_Z_bounded i); intros H1i H2i. - case (Zmod_le_first [|i|] 2); auto with zarith; intros H3i H4i. - assert (H2b: (0 < 2 ^ [|digits - 1|])%Z). - apply Zpower_gt_0; auto with zarith. - case (to_Z_bounded (digits -1)); auto with zarith. - assert (H: [|i << (digits -1)|] = ([|i|] mod 2 * 2^ [|digits -1|])%Z). - rewrite lsl_spec. - rewrite (Z_div_mod_eq [|i|] 2) at 1; auto with zarith. - rewrite Zmult_plus_distr_l, <-Zplus_mod_idemp_l. - rewrite (Zmult_comm 2), <-Zmult_assoc. - replace (2 * 2 ^ [|digits - 1|])%Z with wB; auto. - rewrite Z_mod_mult, Zplus_0_l; apply Zmod_small. - split; auto with zarith. - replace wB with (2 * 2 ^ [|digits -1|])%Z; auto. - apply Zmult_lt_compat_r; auto with zarith. - case (Zle_lt_or_eq 0 ([|i|] mod 2)); auto with zarith; intros Hi. - 2: generalize H; rewrite <-Hi, Zmult_0_l. - 2: replace 0%Z with [|0|]; auto. - 2: rewrite to_Z_eq, <-eqb_spec; intros H1; rewrite H1; auto. - generalize H; replace ([|i|] mod 2) with 1%Z; auto with zarith. - rewrite Zmult_1_l. - intros H1. - assert (H2: [|i << (digits - 1)|] <> [|0|]). - replace [|0|] with 0%Z; auto with zarith. - generalize (eqb_spec (i << (digits - 1)) 0). - case (i << (digits - 1) == 0); auto. - intros (H3,_); case H2. - rewrite to_Z_eq; auto. -Qed. - -Lemma bit_split i : (i = (i>>1)<<1 + bit i 0)%int. -Proof. - apply to_Z_inj. - rewrite add_spec, lsl_spec, lsr_spec, bit_0_spec, Zplus_mod_idemp_l. - replace (2 ^ [|1|]) with 2%Z; auto with zarith. - rewrite Zmult_comm, <-Z_div_mod_eq; auto with zarith. - rewrite Zmod_small; auto; case (to_Z_bounded i); auto. -Qed. - - -Lemma bit_eq i1 i2: - i1 = i2 <-> forall i, bit i1 i = bit i2 i. -Admitted. (* Too slow *) -(* Proof. *) -(* split; try (intros; subst; auto; fail). *) -(* case (to_Z_bounded i2); case (to_Z_bounded i1). *) -(* unfold wB; generalize i1 i2; elim size; clear i1 i2. *) -(* replace (2^Z_of_nat 0) with 1%Z; auto with zarith. *) -(* intros; apply to_Z_inj; auto with zarith. *) -(* intros n IH i1 i2 H1i1 H2i1 H1i2 H2i2 H. *) -(* rewrite (bit_split i1), (bit_split i2). *) -(* rewrite H. *) -(* apply f_equal2 with (f := add31); auto. *) -(* apply f_equal2 with (f := lsl); auto. *) -(* apply IH; try rewrite lsr_spec; *) -(* replace (2^[|1|]) with 2%Z; auto with zarith. *) -(* apply Zdiv_lt_upper_bound; auto with zarith. *) -(* generalize H2i1; rewrite inj_S. *) -(* unfold Z.succ; rewrite Zpower_exp; auto with zarith. *) -(* apply Zdiv_lt_upper_bound; auto with zarith. *) -(* generalize H2i2; rewrite inj_S. *) -(* unfold Z.succ; rewrite Zpower_exp; auto with zarith. *) -(* intros i. *) -(* case (Zle_or_lt [|digits|] [|i|]); intros Hi. *) -(* rewrite !bit_M; auto; rewrite leb_spec; auto. *) -(* rewrite !bit_half; auto; rewrite ltb_spec; auto with zarith. *) -(* Qed. *) - -Lemma bit_lsr x i j : - (bit (x >> i) j = if j <= i + j then bit x (i + j) else false)%int. -Proof. - unfold bit; rewrite lsr_add; case leb; auto. -Qed. - -Lemma bit_lsl x i j : bit (x << i) j = -(if (j < i) || (digits <= j) then false else bit x (j - i))%int. -Proof. - assert (F1: 1 >= 0) by discriminate. - case_eq (digits <= j)%int; intros H. - rewrite orb_true_r, bit_M; auto. - set (d := [|digits|]). - case (Zle_or_lt d [|j|]); intros H1. - case (leb_spec digits j); rewrite H; auto with zarith. - intros _ HH; generalize (HH H1); discriminate. - clear H. - generalize (ltb_spec j i); case ltb; intros H2; unfold bit; [change (if true || false then false else negb (is_zero ((x >> (j - i)) << (digits - 1)))) with false | change (if false || false then false else negb (is_zero ((x >> (j - i)) << (digits - 1)))) with (negb (is_zero ((x >> (j - i)) << (digits - 1))))]. - assert (F2: ([|j|] < [|i|])%Z) by (case H2; auto); clear H2. - replace (is_zero (((x << i) >> j) << (digits - 1))) with true; auto. - case (to_Z_bounded j); intros H1j H2j. - apply sym_equal; rewrite is_zero_spec; apply to_Z_inj. - rewrite lsl_spec, lsr_spec, lsl_spec. - replace wB with (2^d); auto. - pattern d at 1; replace d with ((d - ([|j|] + 1)) + ([|j|] + 1))%Z. - 2: ring. - rewrite Zpower_exp; auto with zarith. - replace [|i|] with (([|i|] - ([|j|] + 1)) + ([|j|] + 1))%Z. - 2: ring. - rewrite Zpower_exp, Zmult_assoc; auto with zarith. - rewrite Zmult_mod_distr_r. - rewrite Zplus_comm, Zpower_exp, !Zmult_assoc; auto with zarith. - rewrite Z_div_mult_full; auto with zarith. - 2: assert (0 < 2 ^ [|j|])%Z; auto with zarith. - rewrite <-Zmult_assoc, <-Zpower_exp; auto with zarith. - replace (1 + [|digits - 1|])%Z with d; auto with zarith. - rewrite Z_mod_mult; auto. - case H2; intros _ H3; case (Zle_or_lt [|i|] [|j|]); intros F2. - 2: generalize (H3 F2); discriminate. - clear H2 H3. - apply f_equal with (f := negb). - apply f_equal with (f := is_zero). - apply to_Z_inj. - rewrite !lsl_spec, !lsr_spec, !lsl_spec. - pattern wB at 2 3; replace wB with (2^(1+ [|digits - 1|])); auto. - rewrite Zpower_exp, Zpower_1_r; auto with zarith. - rewrite !Zmult_mod_distr_r. - apply f_equal2 with (f := Zmult); auto. - replace wB with (2^ d); auto with zarith. - replace d with ((d - [|i|]) + [|i|])%Z. - 2: ring. - case (to_Z_bounded i); intros H1i H2i. - rewrite Zpower_exp; [ |apply Z.le_ge; lia|apply Z.le_ge; assumption]. - rewrite Zmult_mod_distr_r. - case (to_Z_bounded j); intros H1j H2j. - replace [|j - i|] with ([|j|] - [|i|])%Z. - 2: rewrite sub_spec, Zmod_small; auto with zarith. - set (d1 := (d - [|i|])%Z). - set (d2 := ([|j|] - [|i|])%Z). - pattern [|j|] at 1; - replace [|j|] with (d2 + [|i|])%Z. - 2: unfold d2; ring. - rewrite Zpower_exp; auto with zarith. - rewrite Zdiv_mult_cancel_r. - 2: (apply Zlt0_not_eq; apply Z.pow_pos_nonneg; [apply Pos2Z.is_pos|assumption]). - rewrite (Z_div_mod_eq [|x|] (2^d1)) at 2; auto with zarith. - 2: apply Z.lt_gt; apply Zpower_gt_0; unfold d1; lia. - pattern d1 at 2; - replace d1 with (d2 + (1+ (d - [|j|] - 1)))%Z. - 2: unfold d1, d2; ring. - rewrite Zpower_exp; auto with zarith. - rewrite <-Zmult_assoc, Zmult_comm. - rewrite Z_div_plus_l; auto with zarith. - rewrite Zpower_exp, Zpower_1_r; auto with zarith. - rewrite <-Zplus_mod_idemp_l. - rewrite <-!Zmult_assoc, Zmult_comm, Z_mod_mult, Zplus_0_l; auto. -Qed. - - -Lemma bit_b2i (b: bool) i : bit b i = (i == 0) && b. -Proof. - case b; unfold bit; simpl b2i. - 2: rewrite lsr_0_l, lsl_0_l, andb_false_r; auto. - rewrite lsr_1; case (i == 0); auto. -Qed. - -Lemma bit_or_split i : (i = (i>>1)<<1 lor bit i 0)%int. -Proof. - rewrite bit_eq. - intros n; rewrite lor_spec. - rewrite bit_lsl, bit_lsr, bit_b2i. - case (to_Z_bounded n); intros Hi _. - case (Zle_lt_or_eq _ _ Hi). - 2: replace 0%Z with [|0|]; auto; rewrite to_Z_eq. - 2: intros H; rewrite <-H. - 2: replace (0 < 1)%int with true; auto. - intros H; clear Hi. - case_eq (n == 0). - rewrite eqb_spec; intros H1; generalize H; rewrite H1; discriminate. - intros _; rewrite orb_false_r. - case_eq (n < 1)%int. - rewrite ltb_spec, to_Z_1; intros HH; contradict HH; auto with zarith. - intros _. - generalize (@bit_M i n); case leb. - intros H1; rewrite H1; auto. - intros _. - case (to_Z_bounded n); intros H1n H2n. - assert (F1: [|n - 1|] = ([|n|] - 1)%Z). - rewrite sub_spec, Zmod_small; rewrite to_Z_1; auto with zarith. - generalize (add_le_r 1 (n - 1)); case leb; rewrite F1, to_Z_1; intros HH. - replace (1 + (n -1))%int with n. change (bit i n = bit i n). reflexivity. - apply to_Z_inj; rewrite add_spec, F1, Zmod_small; rewrite to_Z_1; - auto with zarith. - rewrite bit_M; auto; rewrite leb_spec. - replace [|n|] with wB; try discriminate; auto with zarith. -Qed. - -(* is_zero *) -Lemma is_zero_0: is_zero 0 = true. -Proof. apply refl_equal. Qed. - -(* is_even *) -Lemma is_even_bit i : is_even i = negb (bit i 0). -Proof. - unfold is_even. - replace (i land 1) with (b2i (bit i 0)). - case bit; auto. - apply bit_eq; intros n. - rewrite bit_b2i, land_spec, bit_1. - generalize (eqb_spec n 0). - case (n == 0); auto. - intros(H,_); rewrite andb_true_r, H; auto. - rewrite andb_false_r; auto. -Qed. - -Lemma is_even_0: is_even 0 = true. -Proof. apply refl_equal. Qed. - -Lemma is_even_lsl_1 i: is_even (i << 1) = true. -Proof. - rewrite is_even_bit, bit_lsl; auto. -Qed. - -Lemma is_even_spec : forall x, - if is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1. -Proof. -intros x; rewrite is_even_bit. -generalize (bit_0_spec x); case bit; simpl; auto. -Qed. - -(* More land *) - -Lemma land_0_l i: 0 land i = 0%int. -Proof. - apply bit_eq; intros n. - rewrite land_spec, bit_0; auto. -Qed. - -Lemma land_0_r i: i land 0 = 0%int. -Proof. - apply bit_eq; intros n. - rewrite land_spec, bit_0, andb_false_r; auto. -Qed. - -Lemma land_assoc i1 i2 i3 : - i1 land (i2 land i3) = i1 land i2 land i3. -Proof. - apply bit_eq; intros n. - rewrite !land_spec, andb_assoc; auto. -Qed. - - -Lemma land_comm i j : i land j = j land i. -Proof. - apply bit_eq; intros n. - rewrite !land_spec, andb_comm; auto. -Qed. - -Lemma lor_comm i1 i2 : i1 lor i2 = i2 lor i1. -Proof. - apply bit_eq; intros n. - rewrite !lor_spec, orb_comm; auto. -Qed. - -Lemma lor_assoc i1 i2 i3 : - i1 lor (i2 lor i3) = i1 lor i2 lor i3. -Proof. - apply bit_eq; intros n. - rewrite !lor_spec, orb_assoc; auto. -Qed. - -Lemma land_lor_distrib_r i1 i2 i3 : - i1 land (i2 lor i3) = (i1 land i2) lor (i1 land i3). -Proof. - apply bit_eq; intros n. - rewrite !land_spec, !lor_spec, !land_spec, andb_orb_distrib_r; auto. -Qed. - -Lemma land_lor_distrib_l i1 i2 i3 : - (i1 lor i2) land i3 = (i1 land i3) lor (i2 land i3). -Proof. - apply bit_eq; intros n. - rewrite !land_spec, !lor_spec, !land_spec, andb_orb_distrib_l; auto. -Qed. - -Lemma lor_land_distrib_r i1 i2 i3: - i1 lor (i2 land i3) = (i1 lor i2) land (i1 lor i3). -Proof. - apply bit_eq; intros n. - rewrite !land_spec, !lor_spec, !land_spec, orb_andb_distrib_r; auto. -Qed. - -Lemma lor_land_distrib_l i1 i2 i3: - (i1 land i2) lor i3 = (i1 lor i3) land (i2 lor i3). -Proof. - apply bit_eq; intros n. - rewrite !land_spec, !lor_spec, !land_spec, orb_andb_distrib_l; auto. -Qed. - -Lemma absoption_land i1 i2 : i1 land (i1 lor i2) = i1. -Proof. - apply bit_eq; intros n. - rewrite land_spec, lor_spec, absoption_andb; auto. -Qed. - -Lemma absoption_lor i1 i2: i1 lor (i1 land i2) = i1. -Proof. - apply bit_eq; intros n. - rewrite lor_spec, land_spec, absoption_orb; auto. -Qed. - -Lemma land_lsl i1 i2 i: (i1 land i2) << i = (i1 << i) land (i2 << i). -Proof. - apply bit_eq; intros n. - rewrite land_spec, !bit_lsl, land_spec. - case (_ || _); auto. -Qed. - -Lemma lor_lsl i1 i2 i: (i1 lor i2) << i = (i1 << i) lor (i2 << i). -Proof. - apply bit_eq; intros n. - rewrite lor_spec, !bit_lsl, lor_spec. - case (_ || _); auto. -Qed. - -Lemma lxor_lsl i1 i2 i: (i1 lxor i2) << i = (i1 << i) lxor (i2 << i). -Proof. - apply bit_eq; intros n. - rewrite lxor_spec, !bit_lsl, lxor_spec. - case (_ || _); auto. -Qed. - -Lemma land_lsr i1 i2 i: (i1 land i2) >> i = (i1 >> i) land (i2 >> i). -Proof. - apply bit_eq; intros n. - rewrite land_spec, !bit_lsr, land_spec. - case (_ <= _)%int; auto. -Qed. - -Lemma lor_lsr i1 i2 i: (i1 lor i2) >> i = (i1 >> i) lor (i2 >> i). -Proof. - apply bit_eq; intros n. - rewrite lor_spec, !bit_lsr, lor_spec. - case (_ <= _)%int; auto. -Qed. - -Lemma lxor_lsr i1 i2 i: (i1 lxor i2) >> i = (i1 >> i) lxor (i2 >> i). -Proof. - apply bit_eq; intros n. - rewrite lxor_spec, !bit_lsr, lxor_spec. - case (_ <= _)%int; auto. -Qed. - -Lemma is_even_and i j : is_even (i land j) = is_even i || is_even j. -Proof. - rewrite !is_even_bit, land_spec; case bit; auto. -Qed. - -Lemma is_even_or i j : is_even (i lor j) = is_even i && is_even j. -Proof. - rewrite !is_even_bit, lor_spec; case bit; auto. -Qed. - -Lemma is_even_xor i j : is_even (i lxor j) = negb (xorb (is_even i) (is_even j)). -Proof. - rewrite !is_even_bit, lxor_spec; do 2 case bit; auto. -Qed. - -Lemma lsl_add_distr x y n: (x + y) << n = ((x << n) + (y << n))%int. -Proof. - apply to_Z_inj; rewrite !lsl_spec, !add_spec, Zmult_mod_idemp_l. - rewrite !lsl_spec, <-Zplus_mod. - apply f_equal2 with (f := Zmod); auto with zarith. -Qed. - -Lemma add_assoc x y z: (x + (y + z) = (x + y) + z)%int. -Proof. - apply to_Z_inj; rewrite !add_spec. - rewrite Zplus_mod_idemp_l, Zplus_mod_idemp_r, Zplus_assoc; auto. -Qed. - -Lemma add_comm x y: (x + y = y + x)%int. -Proof. - apply to_Z_inj; rewrite !add_spec, Zplus_comm; auto. -Qed. - -Lemma lsr_add_distr x y n: (x + y) << n = ((x << n) + (y << n))%int. -Proof. - apply to_Z_inj. - rewrite add_spec, !lsl_spec, add_spec. - rewrite Zmult_mod_idemp_l, <-Zplus_mod. - apply f_equal2 with (f := Zmod); auto with zarith. -Qed. - -Lemma is_even_add x y : - is_even (x + y) = negb (xorb (negb (is_even x)) (negb (is_even y))). -Proof. - assert (F : [|x + y|] mod 2 = ([|x|] mod 2 + [|y|] mod 2) mod 2). - assert (F1: (2 | wB)) by (apply Zpower_divide; apply refl_equal). - assert (F2: 0 < wB) by (apply refl_equal). - case (to_Z_bounded x); intros H1x H2x. - case (to_Z_bounded y); intros H1y H2y. - rewrite add_spec, <-Zmod_div_mod; auto with zarith. - rewrite (Z_div_mod_eq [|x|] 2) at 1; auto with zarith. - rewrite (Z_div_mod_eq [|y|] 2) at 1; auto with zarith. - rewrite Zplus_mod. - rewrite Zmult_comm, (fun x => Zplus_comm (x * 2)), Z_mod_plus; auto with zarith. - rewrite Zmult_comm, (fun x => Zplus_comm (x * 2)), Z_mod_plus; auto with zarith. - rewrite !Zmod_mod, <-Zplus_mod; auto. - generalize (is_even_spec (x + y)) (is_even_spec x) (is_even_spec y). - do 3 case is_even; auto; rewrite F; intros H1 H2 H3; - generalize H1; rewrite H2, H3; try discriminate. -Qed. - -Lemma bit_add_0 x y: bit (x + y) 0 = xorb (bit x 0) (bit y 0). -Proof. - rewrite <-(fun x => (negb_involutive (bit x 0))). - rewrite <-is_even_bit, is_even_add, !is_even_bit. - do 2 case bit; auto. -Qed. - -Lemma add_cancel_l x y z : (x + y = x + z)%int -> y = z. -Proof. - intros H; case (to_Z_bounded x); case (to_Z_bounded y); case (to_Z_bounded z); - intros H1z H2z H1y H2y H1x H2x. - generalize (add_le_r y x) (add_le_r z x); rewrite (add_comm y x), H, (add_comm z x). - case_eq (x <= x + z)%int; intros H1 H2 H3. - apply to_Z_inj; generalize H; rewrite <-to_Z_eq, !add_spec, !Zmod_small; auto with zarith. - apply to_Z_inj; assert ([|x|] + [|y|] = [|x|] + [|z|]); auto with zarith. - assert (F1: wB > 0) by apply refl_equal. - rewrite (Z_div_mod_eq ([|x|] + [|y|]) wB), (Z_div_mod_eq ([|x|] + [|z|]) wB); auto. - rewrite <-to_Z_eq, !add_spec in H; rewrite H. - replace (([|x|] + [|y|])/wB) with 1. - replace (([|x|] + [|z|])/wB) with 1; auto with zarith. - apply Zle_antisym. - apply Zdiv_le_lower_bound; auto with zarith. - assert (F2: [|x|] + [|z|] < 2 * wB); auto with zarith. - generalize (Zdiv_lt_upper_bound _ _ _ (Z.gt_lt _ _ F1) F2); auto with zarith. - apply Zle_antisym. - apply Zdiv_le_lower_bound; auto with zarith. - assert (F2: [|x|] + [|y|] < 2 * wB); auto with zarith. - generalize (Zdiv_lt_upper_bound _ _ _ (Z.gt_lt _ _ F1) F2); auto with zarith. -Qed. - -Lemma add_cancel_r x y z : (y + x = z + x)%int -> y = z. -Proof. - rewrite !(fun t => add_comm t x); intros Hl; apply (add_cancel_l x); auto. -Qed. - -Lemma to_Z_split x : [|x|] = [|(x >> 1)|] * 2 + [|bit x 0|]. -Proof. - case (to_Z_bounded x); intros H1x H2x. - case (to_Z_bounded (bit x 0)); intros H1b H2b. - assert (F1: 0 <= [|x >> 1|] < wB/2). - rewrite lsr_spec, to_Z_1, Zpower_1_r; split. - { - apply Z_div_pos. - - apply Zgt_pos_0. - - assumption. - } - apply Zdiv_lt_upper_bound; auto with zarith. - rewrite (bit_split x) at 1. - rewrite add_spec, Zmod_small, lsl_spec, to_Z_1, Zpower_1_r, Zmod_small; - split; auto with zarith. - change wB with ((wB/2)*2); auto with zarith. - rewrite lsl_spec, to_Z_1, Zpower_1_r, Zmod_small; auto with zarith. - change wB with ((wB/2)*2); auto with zarith. - rewrite lsl_spec, to_Z_1, Zpower_1_r, Zmod_small; auto with zarith. - 2: change wB with ((wB/2)*2); auto with zarith. - change wB with (((wB/2 - 1) * 2 + 1) + 1). - assert ([|bit x 0|] <= 1); auto with zarith. - case bit; discriminate. -Qed. - -Lemma lor_le x y : (y <= x lor y)%int = true. -Proof. - generalize x y (to_Z_bounded x) (to_Z_bounded y); clear x y. - unfold wB; elim size. - replace (2^Z_of_nat 0) with 1%Z; auto with zarith. - intros x y Hx Hy; replace x with 0%int. - replace y with 0%int; auto. - apply to_Z_inj; rewrite to_Z_0; auto with zarith. - apply to_Z_inj; rewrite to_Z_0; auto with zarith. - intros n IH x y; rewrite inj_S. - unfold Z.succ; rewrite Zpower_exp, Zpower_1_r; auto with zarith. - intros Hx Hy. - rewrite leb_spec. - rewrite (to_Z_split y) at 1; rewrite (to_Z_split (x lor y)). - assert ([|y>>1|] <= [|(x lor y) >> 1|]). - rewrite lor_lsr, <-leb_spec; apply IH. - rewrite lsr_spec, to_Z_1, Zpower_1_r; split. - { - apply Z_div_pos. - - apply Zgt_pos_0. - - abstract omega. - } - apply Zdiv_lt_upper_bound; auto with zarith. - rewrite lsr_spec, to_Z_1, Zpower_1_r; split. - { - apply Z_div_pos. - - apply Zgt_pos_0. - - abstract omega. - } - apply Zdiv_lt_upper_bound; auto with zarith. - assert ([|bit y 0|] <= [|bit (x lor y) 0|]); auto with zarith. - rewrite lor_spec; do 2 case bit; try discriminate. -Qed. - - -Lemma bit_add_or x y: - (forall n, bit x n = true -> bit y n = true -> False) <-> (x + y)%int= x lor y. -Proof. - generalize x y (to_Z_bounded x) (to_Z_bounded y); clear x y. - unfold wB; elim size. - replace (2^Z_of_nat 0) with 1%Z; auto with zarith. - intros x y Hx Hy; replace x with 0%int. - replace y with 0%int. - split; auto; intros _ n; rewrite !bit_0; discriminate. - apply to_Z_inj; rewrite to_Z_0; auto with zarith. - apply to_Z_inj; rewrite to_Z_0; auto with zarith. - intros n IH x y; rewrite inj_S. - unfold Z.succ; rewrite Zpower_exp, Zpower_1_r; auto with zarith. - intros Hx Hy. - split. - intros Hn. - assert (F1: ((x >> 1) + (y >> 1))%int = (x >> 1) lor (y >> 1)). - apply IH. - rewrite lsr_spec, Zpower_1_r; split. - { - apply Z_div_pos. - - apply Zgt_pos_0. - - abstract omega. - } - apply Zdiv_lt_upper_bound; auto with zarith. - rewrite lsr_spec, Zpower_1_r; split. - { - apply Z_div_pos. - - apply Zgt_pos_0. - - abstract omega. - } - apply Zdiv_lt_upper_bound; auto with zarith. - intros m H1 H2. - case_eq (digits <= m)%int; [idtac | rewrite <- not_true_iff_false]; - intros Heq. - rewrite bit_M in H1; auto; discriminate. - rewrite leb_spec in Heq. - apply (Hn (m + 1)%int); - rewrite <-bit_half; auto; rewrite ltb_spec; auto with zarith. - rewrite (bit_split (x lor y)), lor_lsr, <- F1, lor_spec. - replace (b2i (bit x 0 || bit y 0)) with (bit x 0 + bit y 0)%int. - 2: generalize (Hn 0%int); do 2 case bit; auto; intros [ ]; auto. - rewrite lsl_add_distr. - rewrite (bit_split x) at 1; rewrite (bit_split y) at 1. - rewrite <-!add_assoc; apply f_equal2 with (f := add31); auto. - rewrite add_comm, <-!add_assoc; apply f_equal2 with (f := add31); auto. - rewrite add_comm; auto. - intros Heq. - generalize (add_le_r x y); rewrite Heq, lor_le; intro Hb. - generalize Heq; rewrite (bit_split x) at 1; rewrite (bit_split y )at 1; clear Heq. - rewrite (fun y => add_comm y (bit x 0)), <-!add_assoc, add_comm, - <-!add_assoc, (add_comm (bit y 0)), add_assoc, <-lsr_add_distr. - rewrite (bit_split (x lor y)), lor_spec. - intros Heq. - assert (F: (bit x 0 + bit y 0)%int = (bit x 0 || bit y 0)). - assert (F1: (2 | wB)) by (apply Zpower_divide; apply refl_equal). - assert (F2: 0 < wB) by (apply refl_equal). - assert (F3: [|bit x 0 + bit y 0|] mod 2 = [|bit x 0 || bit y 0|] mod 2). - apply trans_equal with (([|(x>>1 + y>>1) << 1|] + [|bit x 0 + bit y 0|]) mod 2). - rewrite lsl_spec, Zplus_mod, <-Zmod_div_mod; auto with zarith. - rewrite Zpower_1_r, Z_mod_mult, Zplus_0_l, Zmod_mod; auto with zarith. - rewrite (Zmod_div_mod 2 wB), <-add_spec, Heq; auto with zarith. - rewrite add_spec, <-Zmod_div_mod; auto with zarith. - rewrite lsl_spec, Zplus_mod, <-Zmod_div_mod; auto with zarith. - rewrite Zpower_1_r, Z_mod_mult, Zplus_0_l, Zmod_mod; auto with zarith. - generalize F3; do 2 case bit; try discriminate; auto. - case (IH (x >> 1) (y >> 1)). - rewrite lsr_spec, to_Z_1, Zpower_1_r; split. - { - apply Z_div_pos. - - apply Zgt_pos_0. - - abstract omega. - } - apply Zdiv_lt_upper_bound; auto with zarith. - rewrite lsr_spec, to_Z_1, Zpower_1_r; split. - { - apply Z_div_pos. - - apply Zgt_pos_0. - - abstract omega. - } - apply Zdiv_lt_upper_bound; auto with zarith. - intros _ HH m; case (to_Z_bounded m); intros H1m H2m. - case_eq (digits <= m)%int. - intros Hlm; rewrite bit_M; auto; discriminate. - rewrite <- not_true_iff_false, leb_spec; intros Hlm. - case (Zle_lt_or_eq 0 [|m|]); auto; intros Hm. - replace m with ((m -1) + 1)%int. - rewrite <-(bit_half x), <-(bit_half y); auto with zarith. - apply HH. - rewrite <-lor_lsr. - assert (0 <= [|bit (x lor y) 0|] <= 1) by (case bit; split; discriminate). - rewrite F in Heq; generalize (add_cancel_r _ _ _ Heq). - intros Heq1; apply to_Z_inj. - generalize Heq1; rewrite <-to_Z_eq, lsl_spec, to_Z_1, Zpower_1_r, Zmod_small. - rewrite lsl_spec, to_Z_1, Zpower_1_r, Zmod_small; auto with zarith. - case (to_Z_bounded (x lor y)); intros H1xy H2xy. - rewrite lsr_spec, to_Z_1, Zpower_1_r; auto with zarith. - change wB with ((wB/2)*2); split. - { - apply Z.mul_nonneg_nonneg. - - apply Z_div_pos. - + apply Zgt_pos_0. - + assumption. - - apply Pos2Z.is_nonneg. - } - assert ([|x lor y|] / 2 < wB / 2); auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. - split. - case (to_Z_bounded (x >> 1 + y >> 1)); auto with zarith. - rewrite add_spec. - apply Z.le_lt_trans with (([|x >> 1|] + [|y >> 1|]) * 2); auto with zarith. - case (Zmod_le_first ([|x >> 1|] + [|y >> 1|]) wB); auto with zarith. - case (to_Z_bounded (x >> 1)); case (to_Z_bounded (y >> 1)); auto with zarith. - generalize Hb; rewrite (to_Z_split x) at 1; rewrite (to_Z_split y) at 1. - case (to_Z_bounded (bit x 0)); case (to_Z_bounded (bit y 0)); auto with zarith. - rewrite ltb_spec, sub_spec, to_Z_1, Zmod_small; auto with zarith. - rewrite ltb_spec, sub_spec, to_Z_1, Zmod_small; auto with zarith. - apply to_Z_inj. - rewrite add_spec, sub_spec, Zplus_mod_idemp_l, to_Z_1, Zmod_small; auto with zarith. - replace m with 0%int. - intros Hbx Hby; generalize F; rewrite <-to_Z_eq, Hbx, Hby; discriminate. - apply to_Z_inj; auto. -Qed. - -Lemma addmuldiv_spec : forall x y p, [|p|] <= [|digits|] -> - [| addmuldiv p x y |] = - ([|x|] * (2 ^ [|p|]) + [|y|] / (2 ^ ([|digits|] - [|p|]))) mod wB. -Proof. - intros x y p H. - assert (Fp := to_Z_bounded p); assert (Fd := to_Z_bounded digits). - rewrite addmuldiv_def_spec; unfold addmuldiv_def. - case (bit_add_or (x << p) (y >> (digits - p))); intros HH _. - rewrite <-HH, add_spec, lsl_spec, lsr_spec, Zplus_mod_idemp_l, sub_spec. - rewrite (fun x y => Zmod_small (x - y)); auto with zarith. - intros n; rewrite bit_lsl, bit_lsr. - generalize (add_le_r (digits - p) n). - case leb; try discriminate. - rewrite sub_spec, Zmod_small; auto with zarith; intros H1. - case_eq (n < p)%int; try discriminate. - rewrite <- not_true_iff_false, ltb_spec; intros H2. - case leb; try discriminate. - intros _; rewrite bit_M; try discriminate. - rewrite leb_spec, add_spec, Zmod_small, sub_spec, Zmod_small; auto with zarith. - rewrite sub_spec, Zmod_small; auto with zarith. -Qed. - -Lemma lxor_comm: forall i1 i2 : int, i1 lxor i2 = i2 lxor i1. -Proof. - intros;apply bit_eq;intros. - rewrite !lxor_spec;apply xorb_comm. -Qed. - -Lemma lxor_assoc: forall i1 i2 i3 : int, i1 lxor (i2 lxor i3) = i1 lxor i2 lxor i3. -Proof. - intros;apply bit_eq;intros. - rewrite !lxor_spec, xorb_assoc;trivial. -Qed. - -Lemma lxor_0_l : forall i, 0 lxor i = i. -Proof. - intros;apply bit_eq;intros. - rewrite lxor_spec, bit_0, xorb_false_l;trivial. -Qed. - -Lemma lxor_0_r : forall i, i lxor 0 = i. -Proof. - intros;rewrite lxor_comm;apply lxor_0_l. -Qed. - -Lemma lxor_nilpotent: forall i, i lxor i = 0%int. -Proof. - intros;apply bit_eq;intros. - rewrite lxor_spec, xorb_nilpotent, bit_0;trivial. -Qed. - -Lemma lor_0_l : forall i, 0 lor i = i. -Proof. - intros;apply bit_eq;intros. - rewrite lor_spec, bit_0, orb_false_l;trivial. -Qed. - -Lemma lor_0_r : forall i, i lor 0 = i. -Proof. - intros;rewrite lor_comm;apply lor_0_l. -Qed. - -Lemma reflect_leb : forall i j, reflect ([|i|] <= [|j|])%Z (i <= j)%int. -Proof. - intros; apply iff_reflect. - symmetry;apply leb_spec. -Qed. - -Lemma reflect_eqb : forall i j, reflect (i = j)%Z (i == j). -Proof. - intros; apply iff_reflect. - symmetry;apply eqb_spec. -Qed. - -Lemma reflect_ltb : forall i j, reflect ([|i|] < [|j|])%Z (i < j)%int. -Proof. - intros; apply iff_reflect. - symmetry;apply ltb_spec. -Qed. - -Lemma lsr_is_even_eq : forall i j, - i >> 1 = j >> 1 -> - is_even i = is_even j -> - i = j. -Proof. - intros;apply bit_eq. - intros n;destruct (reflect_eqb n 0). - rewrite <- (negb_involutive (bit i n)), <- (negb_involutive (bit j n)). - rewrite e, <- !is_even_bit, H0;trivial. - assert (W1 : [|n|] <> 0) by (intros Heq;apply n0;apply to_Z_inj;trivial). - assert (W2 := to_Z_bounded n);clear n0. - assert (W3 : [|n-1|] = [|n|] - 1). - rewrite sub_spec, to_Z_1, Zmod_small;trivial;omega. - assert (H1 : n = ((n-1)+1)%int). - apply to_Z_inj;rewrite add_spec, W3. - rewrite Zmod_small;rewrite to_Z_1; omega. - destruct (reflect_ltb (n-1) digits). - rewrite <- ltb_spec in l. - rewrite H1, <- !bit_half, H;trivial. - assert ((digits <= n)%int = true). - rewrite leb_spec;omega. - rewrite !bit_M;trivial. -Qed. - -Lemma lsr1_bit : forall i k, (bit i k >> 1 = 0)%int. -Proof. - intros;destruct (bit i k);trivial. -Qed. - -Lemma bit_xor_split: forall i : int, i = (i >> 1) << 1 lxor bit i 0. -Proof. - intros. - rewrite bit_or_split at 1. - apply lsr_is_even_eq. - rewrite lxor_lsr, lor_lsr, lsr1_bit, lxor_0_r, lor_0_r;trivial. - rewrite is_even_or, is_even_xor. - rewrite is_even_lsl_1;trivial. - rewrite (xorb_true_l (is_even (bit i 0))), negb_involutive;trivial. -Qed. - -(** Order *) -Local Open Scope int63_scope. - -Lemma succ_max_int : forall x, - (x < max_int)%int = true -> (0 < x + 1)%int = true. -Proof. - intros x;rewrite ltb_spec, ltb_spec, add_spec. - intros; assert (W:= to_Z_bounded x); assert (W1:= to_Z_bounded max_int). - change [|0|] with 0%Z;change [|1|] with 1%Z. - rewrite Zmod_small;omega. -Qed. - -Lemma leb_max_int : forall x, (x <= max_int)%int = true. -Proof. - intros x;rewrite leb_spec;assert (W:= to_Z_bounded x). - change [|max_int|] with (wB - 1)%Z;omega. -Qed. - -Lemma leb_0 : forall x, 0 <= x = true. -Proof. - intros x;rewrite leb_spec;destruct (to_Z_bounded x);trivial. -Qed. - -Lemma ltb_0 : forall x, ~ (x < 0 = true). -Proof. - intros x;rewrite ltb_spec, to_Z_0;destruct (to_Z_bounded x);omega. -Qed. - -Lemma leb_trans : forall x y z, x <= y = true -> y <= z = true -> x <= z = true. -Proof. - intros x y z;rewrite !leb_spec;apply Z.le_trans. -Qed. - -Lemma ltb_trans : forall x y z, x < y = true -> y < z = true -> x < z = true. -Proof. - intros x y z;rewrite !ltb_spec;apply Z.lt_trans. -Qed. - -Lemma ltb_leb_trans : forall x y z, x < y = true -> y <= z = true -> x < z = true. -Proof. - intros x y z;rewrite leb_spec, !ltb_spec;apply Z.lt_le_trans. -Qed. - -Lemma leb_ltb_trans : forall x y z, x <= y = true -> y < z = true -> x < z = true. -Proof. - intros x y z;rewrite leb_spec, !ltb_spec;apply Z.le_lt_trans. -Qed. - -Lemma gtb_not_leb : forall n m, m < n = true -> ~(n <= m = true). -Proof. - intros n m; rewrite ltb_spec, leb_spec;omega. -Qed. - -Lemma leb_not_gtb : forall n m, m <= n = true -> ~(n < m = true). -Proof. - intros n m; rewrite ltb_spec, leb_spec;omega. -Qed. - -Lemma leb_refl : forall n, n <= n = true. -Proof. - intros n;rewrite leb_spec;apply Z.le_refl. -Qed. - -Lemma leb_negb_gtb : forall x y, x <= y = negb (y < x). -Proof. - intros x y;apply Bool.eq_true_iff_eq;split;intros. - apply Bool.eq_true_not_negb;apply leb_not_gtb;trivial. - rewrite Bool.negb_true_iff, <- Bool.not_true_iff_false in H. - rewrite leb_spec; rewrite ltb_spec in H;omega. -Qed. - -Lemma ltb_negb_geb : forall x y, x < y = negb (y <= x). -Proof. - intros;rewrite leb_negb_gtb, Bool.negb_involutive;trivial. -Qed. - -Lemma to_Z_sub_gt : forall x y, y <= x = true -> [|x - y|] = ([|x|] - [|y|])%Z. -Proof. - intros x y;assert (W:= to_Z_bounded x);assert (W0:= to_Z_bounded y); - rewrite leb_spec;intros;rewrite sub_spec, Zmod_small;omega. -Qed. - -Lemma not_0_ltb : forall x, x <> 0 <-> 0 < x = true. -Proof. - intros x;rewrite ltb_spec, to_Z_0;assert (W:=to_Z_bounded x);split. - intros Hd;assert ([|x|] <> 0)%Z;[ | omega]. - intros Heq;elim Hd;apply to_Z_inj;trivial. - intros Hlt Heq;elimtype False. - assert ([|x|] = 0)%Z;[ rewrite Heq, to_Z_0;trivial | omega]. -Qed. - -Lemma not_ltb_refl : forall i, ~(i < i = true). -Proof. - intros;rewrite ltb_spec;omega. -Qed. - -Lemma to_Z_sub_1 : forall x y, y < x = true -> ([| x - 1|] = [|x|] - 1)%Z. -Proof. - intros;apply to_Z_sub_gt. - generalize (leb_ltb_trans _ _ _ (leb_0 y) H). - rewrite ltb_spec, leb_spec, to_Z_0, to_Z_1;auto with zarith. -Qed. - -Lemma to_Z_sub_1_diff : forall x, x <> 0 -> ([| x - 1|] = [|x|] - 1)%Z. -Proof. - intros x;rewrite not_0_ltb;apply to_Z_sub_1. -Qed. - -Lemma to_Z_add_1 : forall x y, x < y = true -> [|x+1|] = ([|x|] + 1)%Z. -Proof. - intros x y;assert (W:= to_Z_bounded x);assert (W0:= to_Z_bounded y); - rewrite ltb_spec;intros;rewrite add_spec, to_Z_1, Zmod_small;omega. -Qed. - -Lemma ltb_leb_sub1 : forall x i, x <> 0 -> (i < x = true <-> i <= x - 1 = true). -Proof. - intros x i Hdiff. - rewrite ltb_spec, leb_spec, to_Z_sub_1_diff;trivial. - split;auto with zarith. -Qed. - -Lemma ltb_leb_add1 : forall x y i, i < y = true -> (i < x = true <-> i + 1 <= x = true). -Proof. - intros x y i Hlt. - rewrite ltb_spec, leb_spec. - rewrite (to_Z_add_1 i y);trivial. - split;auto with zarith. -Qed. - -(** Iterators *) - -Lemma foldi_gt : forall A f from to (a:A), - (to < from)%int = true -> foldi f from to a = a. -Proof. - intros;unfold foldi;rewrite foldi_cont_gt;trivial. -Qed. - -Lemma foldi_eq : forall A f from to (a:A), - from = to -> foldi f from to a = f from a. -Proof. - intros;unfold foldi;rewrite foldi_cont_eq;trivial. -Qed. - -Lemma foldi_lt : forall A f from to (a:A), - (from < to)%int = true -> foldi f from to a = foldi f (from + 1) to (f from a). -Proof. - intros;unfold foldi;rewrite foldi_cont_lt;trivial. -Qed. - -Lemma fold_gt : forall A f from to (a:A), - (to < from)%int = true -> fold f from to a = a. -Proof. - intros;apply foldi_gt;trivial. -Qed. - -Lemma fold_eq : forall A f from to (a:A), - from = to -> fold f from to a = f a. -Proof. - intros;apply foldi_eq;trivial. -Qed. - -Lemma fold_lt : forall A f from to (a:A), - (from < to)%int = true -> fold f from to a = fold f (from + 1) to (f a). -Proof. - intros;apply foldi_lt;trivial. -Qed. - -Lemma foldi_down_lt : forall A f from downto (a:A), - (from < downto)%int = true -> foldi_down f from downto a = a. -Proof. - intros;unfold foldi_down;rewrite foldi_down_cont_lt;trivial. -Qed. - -Lemma foldi_down_eq : forall A f from downto (a:A), - from = downto -> foldi_down f from downto a = f from a. -Proof. - intros;unfold foldi_down;rewrite foldi_down_cont_eq;trivial. -Qed. - -Lemma foldi_down_gt : forall A f from downto (a:A), - (downto < from)%int = true-> - foldi_down f from downto a = - foldi_down f (from-1) downto (f from a). -Proof. - intros;unfold foldi_down;rewrite foldi_down_cont_gt;trivial. -Qed. - -Lemma fold_down_lt : forall A f from downto (a:A), - (from < downto)%int = true -> fold_down f from downto a = a. -Proof. - intros;apply foldi_down_lt;trivial. -Qed. - -Lemma fold_down_eq : forall A f from downto (a:A), - from = downto -> fold_down f from downto a = f a. -Proof. - intros;apply foldi_down_eq;trivial. -Qed. - -Lemma fold_down_gt : forall A f from downto (a:A), - (downto < from)%int = true-> - fold_down f from downto a = - fold_down f (from-1) downto (f a). -Proof. - intros;apply foldi_down_gt;trivial. -Qed. - -Require Import Wf_Z. - -Lemma int_ind : forall (P:int -> Type), - P 0%int -> - (forall i, (i < max_int)%int = true -> P i -> P (i + 1)%int) -> - forall i, P i. -Proof. - intros P HP0 Hrec. - assert (forall z, (0 <= z)%Z -> forall i, z = [|i|] -> P i). - intros z H;pattern z;apply natlike_rec2;intros;trivial. - rewrite <- (of_to_Z i), <- H0;exact HP0. - assert (W:= to_Z_bounded i). - assert ([|i - 1|] = [|i|] - 1)%Z. - rewrite sub_spec, Zmod_small;rewrite to_Z_1;auto with zarith. - assert (i = i - 1 + 1)%int. - apply to_Z_inj. - rewrite add_spec, H2. - rewrite Zmod_small;rewrite to_Z_1;auto with zarith. - rewrite H3;apply Hrec. - rewrite ltb_spec, H2;change [|max_int|] with (wB - 1)%Z;auto with zarith. - apply X;auto with zarith. - intros;apply (X [|i|]);trivial. - destruct (to_Z_bounded i);trivial. -Qed. - -Lemma int_ind_bounded : forall (P:int-> Type) min max, - min <= max =true -> - P max -> - (forall i, min <= i + 1 = true-> i < max =true-> P (i + 1) -> P i) -> - P min. -Proof. - intros P min max Hle. - intros Hmax Hrec. - assert (W1:= to_Z_bounded max);assert (W2:= to_Z_bounded min). - assert (forall z, (0 <= z)%Z -> (z <= [|max|] - [|min|])%Z -> forall i, z = [|i|] -> P (max - i)%int). - intros z H1;pattern z;apply natlike_rec2;intros;trivial. - assert (max - i = max)%int. - apply to_Z_inj;rewrite sub_spec, <- H0, Zminus_0_r, Zmod_small;auto using to_Z_bounded. - rewrite H2;trivial. - assert (W3:= to_Z_bounded i);apply Hrec. - rewrite leb_spec,add_spec, sub_spec, to_Z_1, (Zmod_small ([|max|] - [|i|])), Zmod_small;auto with zarith. - rewrite ltb_spec, sub_spec, Zmod_small;auto with zarith. - assert (max - i + 1 = max - (i - 1))%int. - apply to_Z_inj;rewrite add_spec, !sub_spec, to_Z_1. - rewrite (Zmod_small ([|max|] - [|i|]));auto with zarith. - rewrite (Zmod_small ([|i|] - 1));auto with zarith. - apply f_equal2;auto with zarith. - rewrite H3;apply X;auto with zarith. - rewrite sub_spec, to_Z_1, <- H2, Zmod_small;auto with zarith. - rewrite leb_spec in Hle;assert (min = max - (max - min))%int. - apply to_Z_inj. - rewrite !sub_spec, !Zmod_small;auto with zarith. - rewrite Zmod_small;auto with zarith. - rewrite H;apply (X [| max - min |]);trivial;rewrite sub_spec, Zmod_small;auto with zarith. -Qed. - -Lemma foldi_cont_ZInd : forall A B (P: Z -> (A -> B) -> Prop) (f:int -> (A -> B) -> (A -> B)) min max cont, - (forall z, ([|max|] < z)%Z -> P z cont) -> - (forall i cont, min <= i = true -> i <= max = true -> P ([|i|] + 1)%Z cont -> P [|i|] (f i cont)) -> - P [|min|] (foldi_cont f min max cont). -Proof. - intros A B P f min max cont Ha Hf. - assert (Bmax:= to_Z_bounded max);assert (Bmin:= to_Z_bounded min). - case_eq (min <= max);intros Heq. - generalize (leb_refl min). - assert (P ([|max|] + 1)%Z cont) by (apply Ha;auto with zarith). - clear Ha;revert cont H. - pattern min at 2 3 4;apply int_ind_bounded with max;trivial. - intros;rewrite foldi_cont_eq;auto using leb_refl. - intros i Hle Hlt Hr cont Hcont Hle'. - rewrite foldi_cont_lt;[ | trivial]. - apply Hf;trivial. rewrite leb_spec;rewrite ltb_spec in Hlt;auto with zarith. - assert ([|i|] + 1 = [|i + 1|])%Z. - rewrite ltb_spec in Hlt;assert (W:= to_Z_bounded i);rewrite add_spec, to_Z_1, Zmod_small;omega. - rewrite H;apply Hr;trivial. - assert (max < min = true) by (rewrite ltb_negb_geb,Heq;trivial). - rewrite foldi_cont_gt;trivial;apply Ha;rewrite <- ltb_spec;trivial. -Qed. - - -(* Lemma of_pos_spec : forall p, [|of_pos p|] = Zpos p mod wB. *) -(* Proof. *) -(* unfold of_pos. *) -(* unfold wB. *) -(* assert (forall k, (k <= size)%nat -> *) -(* forall p : positive, [|of_pos_rec k p|] = Zpos p mod 2 ^ Z_of_nat k). *) -(* induction k. *) -(* simpl;intros;rewrite to_Z_0,Zmod_1_r;trivial. *) -(* Opaque Z_of_nat. *) -(* destruct p;simpl. *) -(* destruct (bit_add_or (of_pos_rec k p << 1) 1) as (H1, _). *) -(* rewrite <- H1;clear H1. *) -(* change (Zpos p~1) with (2*(Zpos p) + 1)%Z. *) -(* rewrite add_spec,lsl_spec, IHk, to_Z_1. *) -(* rewrite Zmult_comm, Zplus_mod_idemp_l, Zmod_small. *) -(* change 2%Z with (2^1)%Z. *) -(* rewrite Zmod_distr. *) -(* rewrite inj_S, Zpower_Zsucc;[ | apply Zle_0_nat]. *) -(* repeat change (2^1)%Z with 2%Z. *) -(* rewrite Zmult_mod_distr_l;trivial. *) -(* Transparent Z_of_nat. *) -(* rewrite inj_S;omega. *) -(* discriminate. *) -(* split;[discriminate | trivial]. *) -(* compute;trivial. *) -(* assert (W:0 <= Zpos p mod 2 ^ Z_of_nat k < 2 ^ Z_of_nat k). *) -(* apply Z.mod_pos_bound;auto with zarith. *) -(* change (2^1)%Z with 2%Z;split;try omega. *) -(* apply Z.lt_le_trans with (2 ^ Z_of_nat (S k)). *) -(* rewrite inj_S, Zpower_Zsucc;omega. *) -(* unfold wB;apply Zpower_le_monotone;auto with zarith. *) -(* split;auto using inj_le with zarith. *) -(* auto with zarith. *) -(* intros n H1 H2. *) -(* rewrite bit_1, eqb_spec in H2;subst. *) -(* rewrite bit_lsl in H1;discriminate H1. *) - -(* change (Zpos p~0) with (2*(Zpos p))%Z. *) -(* rewrite lsl_spec, IHk, to_Z_1. *) -(* rewrite Zmult_comm, Zmod_small. *) -(* rewrite inj_S, Zpower_Zsucc;[ | apply Zle_0_nat]. *) -(* rewrite Zmult_mod_distr_l;trivial. *) -(* assert (W:0 <= Zpos p mod 2 ^ Z_of_nat k < 2 ^ Z_of_nat k). *) -(* apply Z.mod_pos_bound;auto with zarith. *) -(* change (2^1)%Z with 2%Z;split;try omega. *) -(* apply Z.lt_le_trans with (2 ^ Z_of_nat (S k)). *) -(* rewrite inj_S, Zpower_Zsucc;omega. *) -(* unfold wB;apply Zpower_le_monotone;auto with zarith. *) -(* split;auto using inj_le with zarith. *) -(* auto with zarith. *) - -(* rewrite to_Z_1, Zmod_small;trivial. *) -(* split;auto with zarith. *) -(* apply Zpower_gt_1;auto with zarith. *) -(* rewrite inj_S;auto with zarith. *) - -(* apply H;auto with zarith. *) -(* Qed. *) - -Lemma of_Z_spec : forall z, [|of_Z z|] = z mod wB. -Admitted. (* no more of_pos *) -(* Proof. *) -(* unfold of_Z;destruct z. *) -(* assert (W:= to_Z_bounded 0);rewrite Zmod_small;trivial. *) -(* apply of_pos_spec. *) -(* rewrite opp_spec, of_pos_spec. *) -(* rewrite <- Zmod_opp_opp. *) -(* change (- Zpos p)%Z with (Zneg p). *) -(* destruct (Z_eq_dec (Zneg p mod wB) 0). *) -(* rewrite e, Z_mod_zero_opp_r;trivial. *) -(* rewrite Z_mod_nz_opp_r, Zminus_mod, Z_mod_same_full, Zmod_mod, Zminus_0_r, Zmod_mod;trivial. *) -(* Qed. *) - -Lemma foldi_cont_Ind : forall A B (P: int -> (A -> B) -> Prop) (f:int -> (A -> B) -> (A -> B)) min max cont, - max < max_int = true -> - (forall z, max < z = true -> P z cont) -> - (forall i cont, min <= i = true -> i <= max = true -> P (i + 1) cont -> P i (f i cont)) -> - P min (foldi_cont f min max cont). -Proof. - intros. - set (P' z cont := (0 <= z < wB)%Z -> P (of_Z z) cont). - assert (P' [|min|] (foldi_cont f min max cont)). - apply foldi_cont_ZInd;unfold P';intros. - assert ([|(of_Z z)|] = z). - rewrite of_Z_spec, Zmod_small;trivial. - apply H0;rewrite ltb_spec, H4;trivial. - rewrite of_to_Z;apply H1;trivial. - assert (i < max_int = true). - apply leb_ltb_trans with max;trivial. - rewrite <- (to_Z_add_1 _ _ H6), of_to_Z in H4;apply H4. - apply to_Z_bounded. - unfold P' in H2;rewrite of_to_Z in H2;apply H2;apply to_Z_bounded. -Qed. - -Lemma foldi_cont_ind : forall A B (P: (A -> B) -> Prop) (f:int -> (A -> B) -> (A -> B)) min max cont, - P cont -> - (forall i cont, min <= i = true -> i <= max = true -> P cont -> P (f i cont)) -> - P (foldi_cont f min max cont). -Proof. - intros A B P f min max cont Ha Hf. - set (P2 := fun (z:Z) b => P b);change (P2 [|min|] (foldi_cont f min max cont)). - apply foldi_cont_ZInd;trivial. -Qed. - -Lemma foldi_ZInd : forall A (P : Z -> A -> Prop) f min max a, - (max < min = true -> P ([|max|] + 1)%Z a) -> - P [|min|] a -> - (forall i a, min <= i = true -> i <= max = true -> - P [|i|] a -> P ([|i|] + 1)%Z (f i a)) -> - P ([|max|]+1)%Z (foldi f min max a). -Proof. - unfold foldi;intros A P f min max a Hlt;intros. - set (P' z cont := - if Zlt_bool [|max|] z then cont = (fun a0 : A => a0) - else forall a, P z a -> P ([|max|]+1)%Z (cont a)). - assert (P' [|min|] (foldi_cont (fun (i : int) (cont : A -> A) (a0 : A) => cont (f i a0)) min - max (fun a0 : A => a0))). - apply foldi_cont_ZInd;intros;red. - rewrite Zlt_is_lt_bool in H1;rewrite H1;trivial. - case_eq (Zlt_bool [|max|] [|i|]);intros. - rewrite <- Zlt_is_lt_bool in H4;rewrite leb_spec in H2;elimtype False;omega. - clear H4; revert H3;unfold P'. - case_eq (Zlt_bool [|max|] ([|i|] + 1));intros;auto. - rewrite <- Zlt_is_lt_bool in H3; assert ([|i|] = [|max|]) by (rewrite leb_spec in H2;omega). - rewrite H4, <- H6;apply H0;trivial. - revert H1;unfold P'. - case_eq (Zlt_bool [|max|] [|min|]);auto. - rewrite <- Zlt_is_lt_bool, <- ltb_spec;intros;rewrite foldi_cont_gt;auto. -Qed. - -Lemma foldi_Ind : forall A (P : int -> A -> Prop) f min max a, - (max < max_int = true) -> - (max < min = true -> P (max + 1) a) -> - P min a -> - (forall i a, min <= i = true -> i <= max = true -> - P i a -> P (i + 1) (f i a)) -> - P (max+1) (foldi f min max a). -Proof. - intros. - set (P' z a := (0 <= z < wB)%Z -> P (of_Z z) a). - assert (W:= to_Z_add_1 _ _ H). - assert (P' ([|max|]+1)%Z (foldi f min max a)). - apply foldi_ZInd;unfold P';intros. - rewrite <- W, of_to_Z;auto. - rewrite of_to_Z;trivial. - assert (i < max_int = true). - apply leb_ltb_trans with max;trivial. - rewrite <- (to_Z_add_1 _ _ H7), of_to_Z;apply H2;trivial. - rewrite of_to_Z in H5;apply H5;apply to_Z_bounded. - unfold P' in H3;rewrite <- W, of_to_Z in H3;apply H3;apply to_Z_bounded. -Qed. - -Lemma foldi_ind : forall A (P: A -> Prop) (f:int -> A -> A) min max a, - P a -> - (forall i a, min <= i = true -> i <= max = true -> P a -> P (f i a)) -> - P (foldi f min max a). -Proof. - unfold foldi;intros A P f min max a Ha Hr;revert a Ha. - apply foldi_cont_ind;auto. -Qed. - -Lemma fold_ind : forall A (P: A -> Prop) (f: A -> A) min max a, - P a -> (forall a, P a -> P (f a)) -> P (fold f min max a). -Proof. - unfold fold;intros A P f min max a Ha Hr;revert a Ha. - apply foldi_cont_ind;auto. -Qed. - -Lemma foldi_down_cont_ZInd : - forall A B (P: Z -> (A -> B) -> Prop) (f:int -> (A -> B) -> (A -> B)) max min cont, - (forall z, (z < [|min|])%Z -> P z cont) -> - (forall i cont, min <= i = true -> i <= max = true -> P ([|i|] - 1)%Z cont -> P [|i|] (f i cont)) -> - P [|max|] (foldi_down_cont f max min cont). -Proof. - intros A B P f max min cont Ha Hf. - assert (Bmax:= to_Z_bounded max);assert (Bmin:= to_Z_bounded min). - case_eq (min <= max);intros Heq. - generalize (leb_refl max). - assert (P ([|min|] -1)%Z cont) by (apply Ha;auto with zarith). - clear Ha;revert cont H Heq. - pattern max at 1 2 4 5;apply int_ind;trivial. - intros; assert (0 = min). - apply to_Z_inj;revert Heq;rewrite leb_spec, to_Z_0;omega. - rewrite foldi_down_cont_eq;subst;auto. - intros i Hmaxi Hr cont Hcont Hmin Hmax. - generalize Hmin;rewrite leb_ltb_eqb;case_eq (min < i+1);simpl;intros Hlt Hmin'. - rewrite foldi_down_cont_gt;[ | trivial]. - apply Hf;trivial. - assert ([|i|] + 1 = [|i + 1|])%Z. - assert (W:= to_Z_bounded i);rewrite ltb_spec in Hmaxi; - assert (W2 := to_Z_bounded max_int);rewrite add_spec, to_Z_1, Zmod_small;auto with zarith. - assert (i + 1 - 1 = i). - rewrite leb_spec in *;rewrite ltb_spec in *. - assert (W1:= to_Z_bounded i); apply to_Z_inj;rewrite sub_spec,to_Z_1, Zmod_small;try omega. - assert ([|i|] = [|i+1|]-1)%Z. - rewrite <- H;ring. - rewrite <- H1, H0;apply Hr;trivial. - rewrite ltb_spec in Hlt;rewrite leb_spec;omega. - rewrite leb_spec in Hmax |- *;omega. - rewrite eqb_spec in Hmin';subst;rewrite foldi_down_cont_eq;auto. - assert (max < min = true) by (rewrite ltb_negb_geb,Heq;trivial). - rewrite foldi_down_cont_lt;trivial. - apply Ha;rewrite <- ltb_spec;trivial. -Qed. - -Lemma foldi_down_cont_ind : forall A B (P: (A -> B) -> Prop) (f:int -> (A -> B) -> (A -> B)) max min cont, - P cont -> - (forall i cont, min <= i = true -> i <= max = true -> P cont -> P (f i cont)) -> - P (foldi_down_cont f max min cont). -Proof. - intros A B P f max min cont Ha Hf. - set (P2 := fun (z:Z) b => P b);change (P2 [|max|] (foldi_down_cont f max min cont)). - apply foldi_down_cont_ZInd;trivial. -Qed. - -Lemma foldi_down_ZInd : - forall A (P: Z -> A -> Prop) (f:int -> A -> A) max min a, - (max < min = true -> P ([|min|] - 1)%Z a) -> - (P [|max|] a) -> - (forall i a, min <= i = true -> i <= max = true -> P [|i|]%Z a -> P ([|i|]-1)%Z (f i a)) -> - P ([|min|] - 1)%Z (foldi_down f max min a). -Proof. - unfold foldi_down;intros A P f max min a Hlt;intros. - set (P' z cont := - if Zlt_bool z [|min|] then cont = (fun a0 : A => a0) - else forall a, P z a -> P ([|min|] - 1)%Z (cont a)). - assert (P' [|max|] (foldi_down_cont (fun (i : int) (cont : A -> A) (a0 : A) => cont (f i a0)) max - min (fun a0 : A => a0))). - apply foldi_down_cont_ZInd;intros;red. - rewrite Zlt_is_lt_bool in H1;rewrite H1;trivial. - case_eq (Zlt_bool [|i|] [|min|]);intros. - rewrite <- Zlt_is_lt_bool in H4;rewrite leb_spec in H1;elimtype False;omega. - clear H4;revert H3;unfold P'. - case_eq (Zlt_bool ([|i|] - 1) [|min|]);intros;auto. - rewrite <- Zlt_is_lt_bool in H3; assert ([|i|] = [|min|]) by (rewrite leb_spec in H1;omega). - rewrite H4, <- H6. apply H0;trivial. - revert H1;unfold P'. - case_eq (Zlt_bool [|max|] [|min|]);auto. - rewrite <- Zlt_is_lt_bool, <- ltb_spec;intros;rewrite foldi_down_cont_lt;auto. -Qed. - -Lemma foldi_down_ind : forall A (P: A -> Prop) (f:int -> A -> A) max min a, - P a -> - (forall i a, min <= i = true -> i <= max = true -> P a -> P (f i a)) -> - P (foldi_down f max min a). -Proof. - unfold foldi_down;intros A P f max min a Ha Hr;revert a Ha. - apply foldi_down_cont_ind;auto. -Qed. - -Lemma fold_down_ind : forall A (P: A -> Prop) (f: A -> A) max min a, - P a -> (forall a, P a -> P (f a)) -> P (fold_down f max min a). -Proof. - unfold fold_down;intros A P f max min a Ha Hr;revert a Ha. - apply foldi_down_cont_ind;auto. -Qed. - -Lemma foldi_down_Ind : - forall A (P: int -> A -> Prop) (f:int -> A -> A) max min a, - 0 < min = true -> - (max < min = true -> P (min - 1) a) -> - (P max a) -> - (forall i a, min <= i = true -> i <= max = true -> P i a -> P (i - 1) (f i a)) -> - P (min - 1) (foldi_down f max min a). -Proof. - intros. - set (P' z a := (0 <= z < wB)%Z -> P (of_Z z) a). - assert (W:= to_Z_sub_1 _ _ H). - assert (P' ([|min|]-1)%Z (foldi_down f max min a)). - apply foldi_down_ZInd;unfold P';intros. - rewrite <- W, of_to_Z;auto. - rewrite of_to_Z;trivial. - assert (0 < i = true). - apply ltb_leb_trans with min;trivial. - rewrite <- (to_Z_sub_1 _ _ H7), of_to_Z;apply H2;trivial. - rewrite of_to_Z in H5;apply H5;apply to_Z_bounded. - unfold P' in H3;rewrite <- W, of_to_Z in H3;apply H3;apply to_Z_bounded. -Qed. - -Lemma foldi_down_min : - forall A f min max (a:A), - min < max_int = true-> - (min <= max) = true -> - foldi_down f max min a = f min (foldi_down f max (min + 1) a). -Proof. - intros. - set (P:= fun i => i <= max - min = true -> - forall a, foldi_down f (min + i) min a = f min (foldi_down f (min + i) (min + 1) a)). - assert (min < min + 1 = true). - rewrite ltb_leb_add1 with (y:=max_int), leb_refl;trivial. - assert (P (max - min)). - apply int_ind;unfold P. - replace (min + 0) with min. - intros _ a'; rewrite foldi_down_eq, foldi_down_lt;trivial. - apply to_Z_inj;rewrite add_spec, to_Z_0, Zplus_0_r, Zmod_small;auto using to_Z_bounded. - intros i Hi Hrec Hi1 a'. - rewrite add_assoc. - assert (Wi:= to_Z_add_1 _ _ Hi). - assert (Wmin:= to_Z_add_1 _ _ H). - assert ((min + 1) <= (min + i + 1) = true). - assert (W1 := to_Z_bounded min); assert (W2:= to_Z_bounded max); assert (W3:= to_Z_bounded i). - replace (min + i + 1) with (min + 1 + i). - rewrite leb_spec, (add_spec (min+1)). - unfold is_true in Hi1;rewrite leb_spec in *; rewrite ltb_spec in *. - rewrite sub_spec in Hi1;rewrite Zmod_small in Hi1;[ | omega]. - rewrite Zmod_small;omega. - rewrite <- !add_assoc, (add_comm 1 i);trivial. - rewrite leb_ltb_eqb in H2;revert H2. - case_eq (min + 1 < min + i + 1). - intros Hlt _;rewrite foldi_down_gt. - rewrite foldi_down_gt with (from := min + i + 1);trivial. - replace (min + i + 1 - 1) with (min + i). - apply Hrec. - apply leb_trans with (i+1);[rewrite leb_spec;omega | trivial]. - apply to_Z_inj;rewrite sub_spec, (add_spec (min + i)), to_Z_1, Zminus_mod_idemp_l. - assert (H100: forall (x:Z), (x + 1 - 1)%Z = x) by (intros; ring). rewrite H100. - rewrite Zmod_small;auto using to_Z_bounded. - apply leb_ltb_trans with (2:= Hlt). - rewrite leb_spec;omega. - simpl;rewrite eqb_spec;intros _ Heq. - rewrite <- Heq. - rewrite foldi_down_gt. - replace (min + 1 - 1) with min. - rewrite !foldi_down_eq;trivial. - apply to_Z_inj;rewrite sub_spec, add_spec, to_Z_1, Zminus_mod_idemp_l. - replace ([|min|] + 1 - 1)%Z with [|min|] by ring. - rewrite Zmod_small;auto using to_Z_bounded. - rewrite ltb_spec;omega. - generalize (H2 (leb_refl _) a). - replace (min + (max - min)) with max;trivial. - apply to_Z_inj;rewrite add_spec, sub_spec, Zplus_mod_idemp_r. - ring_simplify ([|min|] + ([|max|] - [|min|]))%Z. - rewrite Zmod_small;auto using to_Z_bounded. -Qed. - -Definition foldi_ntr A f min max (a:A) := - foldi_cont (fun i cont _ => f i (cont tt)) min max (fun _ => a) tt. - -Lemma foldi_ntr_foldi_down : forall A f min max (a:A), - max < max_int = true -> - foldi_down f max min a = foldi_ntr _ f min max a. -Proof. - intros;unfold foldi_ntr. - apply foldi_cont_Ind;trivial. - intros;apply foldi_down_lt;trivial. - intros i cont Hmin Hmax Heq;rewrite <- Heq;clear Heq. - apply foldi_down_min;trivial. - apply leb_ltb_trans with (1:= Hmax);trivial. -Qed. - - -(** Two iterators *) - -Lemma foldi_cont_ZInd2 : forall A B C D (P: Z -> (A -> B) -> (C -> D) -> Prop) (f1 : int -> (A -> B) -> (A -> B)) (f2 : int -> (C -> D) -> (C -> D)) min max cont1 cont2, - (forall z, ([|max|] < z)%Z -> P z cont1 cont2) -> - (forall i cont1 cont2, min <= i = true -> i <= max = true -> P ([|i|] + 1)%Z cont1 cont2 -> - P [|i|] (f1 i cont1) (f2 i cont2)) -> - P [|min|] (foldi_cont f1 min max cont1) (foldi_cont f2 min max cont2). -Proof. - intros. - set (P' z cont := - if Zlt_bool [|max|] z then cont = cont1 - else P z cont (foldi_cont f2 (of_Z z) max cont2)). - assert (P' [|min|] (foldi_cont f1 min max cont1)). - apply foldi_cont_ZInd;unfold P';intros. - rewrite Zlt_is_lt_bool in H1;rewrite H1;trivial. - case_eq (Zlt_bool [|max|] [|i|]);intros. - rewrite <- Zlt_is_lt_bool, <- ltb_spec in H4. - elim (not_ltb_refl max);apply ltb_leb_trans with i;trivial. - rewrite of_to_Z;generalize H2;rewrite leb_ltb_eqb, orb_true_iff;intros [Hlt | Heq]. - rewrite foldi_cont_lt;[apply H0 | ];trivial. - revert H3;case_eq (Zlt_bool [|max|] ([|i|] + 1)). - rewrite <- Zlt_is_lt_bool;rewrite ltb_spec in Hlt;intros;elimtype False;omega. - rewrite <- (to_Z_add_1 _ _ Hlt), of_to_Z; intros _ W;exact W. - rewrite eqb_spec in Heq;subst. - rewrite foldi_cont_eq;[apply H0 | ];trivial. - assert ([|max|] < [|max|] + 1)%Z by auto with zarith. - rewrite Zlt_is_lt_bool in H5;rewrite H5 in H3;rewrite H3. - apply H;rewrite Zlt_is_lt_bool;trivial. - revert H1;unfold P';case_eq (Zlt_bool [|max|] [|min|]). - rewrite <- Zlt_is_lt_bool;intros. - rewrite H2;rewrite foldi_cont_gt;[ | rewrite ltb_spec];auto. - rewrite of_to_Z;auto. -Qed. - - -Lemma foldi_cont_ind2 : forall A B C D (P: (A -> B) -> (C -> D) -> Prop) (f:int -> (A -> B) -> (A -> B)) (g:int -> (C -> D) -> (C -> D)) min max cont1 cont2, - P cont1 cont2 -> - (forall i cont1 cont2, min <= i = true -> i <= max = true -> P cont1 cont2 -> P (f i cont1) (g i cont2)) -> - P (foldi_cont f min max cont1) (foldi_cont g min max cont2). -Proof. - intros A B C D P f g min max cont1 cont2 Ha Hf. - set (P2 := fun (z:Z) b c => P b c);change (P2 [|min|] (foldi_cont f min max cont1) (foldi_cont g min max cont2)). - apply foldi_cont_ZInd2;trivial. -Qed. - - -Lemma foldi_ZInd2 : forall A B (P : Z -> A -> B -> Prop) f g min max a b, - (max < min = true -> P ([|max|] + 1)%Z a b) -> - P [|min|] a b -> - (forall i a b, min <= i = true -> i <= max = true -> - P [|i|] a b -> P ([|i|] + 1)%Z (f i a) (g i b)) -> - P ([|max|]+1)%Z (foldi f min max a) (foldi g min max b). -Proof. - unfold foldi;intros A B P f g min max a b Hlt;intros. - set (P' z cont1 cont2 := - if Zlt_bool [|max|] z then cont1 = (fun a : A => a) /\ cont2 = (fun b : B => b) - else forall a b, P z a b -> P ([|max|]+1)%Z (cont1 a) (cont2 b)). - assert (P' [|min|] (foldi_cont (fun (i : int) (cont : A -> A) (a : A) => cont (f i a)) min - max (fun a : A => a)) - (foldi_cont (fun (i : int) (cont : B -> B) (b : B) => cont (g i b)) min - max (fun b : B => b))). - apply foldi_cont_ZInd2;intros;red. - rewrite Zlt_is_lt_bool in H1;rewrite H1;auto. - case_eq (Zlt_bool [|max|] [|i|]);intros. - rewrite <- Zlt_is_lt_bool in H4;rewrite leb_spec in H2;elimtype False;omega. - clear H4; revert H3;unfold P'. - case_eq (Zlt_bool [|max|] ([|i|] + 1));intros;auto. - rewrite <- Zlt_is_lt_bool in H3; assert ([|i|] = [|max|]) by (rewrite leb_spec in H2;omega). - destruct H4;subst;rewrite <- H6;apply H0;trivial. - revert H1;unfold P'. - case_eq (Zlt_bool [|max|] [|min|]);auto. - rewrite <- Zlt_is_lt_bool, <- ltb_spec;intros;rewrite !foldi_cont_gt;auto. -Qed. - - -Lemma foldi_Ind2 : forall A B (P : int -> A -> B -> Prop) f g min max a b, - (max < max_int = true) -> - (max < min = true -> P (max + 1) a b) -> - P min a b -> - (forall i a b, min <= i = true -> i <= max = true -> - P i a b -> P (i + 1) (f i a) (g i b)) -> - P (max+1) (foldi f min max a) (foldi g min max b). -Proof. - intros. - set (P' z a b := (0 <= z < wB)%Z -> P (of_Z z) a b). - assert (W:= to_Z_add_1 _ _ H). - assert (P' ([|max|]+1)%Z (foldi f min max a) (foldi g min max b)). - apply foldi_ZInd2;unfold P';intros. - rewrite <- W, of_to_Z;auto. - rewrite of_to_Z;trivial. - assert (i < max_int = true). - apply leb_ltb_trans with max;trivial. - rewrite <- (to_Z_add_1 _ _ H7), of_to_Z;apply H2;trivial. - rewrite of_to_Z in H5;apply H5;apply to_Z_bounded. - unfold P' in H3;rewrite <- W, of_to_Z in H3;apply H3;apply to_Z_bounded. -Qed. - - -Lemma foldi_ind2 : forall A B (P: A -> B -> Prop) (f:int -> A -> A) (g:int -> B -> B) min max a b, - P a b -> - (forall i a b, min <= i = true -> i <= max = true -> P a b -> P (f i a) (g i b)) -> - P (foldi f min max a) (foldi g min max b). -Proof. - unfold foldi;intros A B P f g min max a b Ha Hr; revert a b Ha. - apply (foldi_cont_ind2 _ _ _ _ (fun cont1 cont2 => forall a b, P a b -> P (cont1 a) (cont2 b))); auto. -Qed. - - -Lemma fold_ind2 : forall A B (P: A -> B -> Prop) (f: A -> A) (g: B -> B) min max a b, - P a b -> (forall a b, P a b -> P (f a) (g b)) -> P (fold f min max a) (fold g min max b). -Proof. - unfold fold;intros A B P f g min max a b Ha Hr;revert a b Ha. - apply (foldi_cont_ind2 _ _ _ _ (fun cont1 cont2 => forall a b, P a b -> P (cont1 a) (cont2 b)));auto. -Qed. - -Lemma foldi_eq_compat : forall A (f1 f2:int -> A -> A) min max a, - (forall i a, min <= i = true -> i <= max = true -> f1 i a = f2 i a) -> - foldi f1 min max a = foldi f2 min max a. -Proof. - intros; set (P' (z:Z) (a1 a2:A) := a1 = a2). - assert (P' ([|max|] + 1)%Z (foldi f1 min max a) (foldi f2 min max a)). - apply foldi_ZInd2;unfold P';intros;subst;auto. - apply H0. -Qed. - -Lemma foldi_down_cont_ZInd2 : - forall A B C D (P: Z -> (A -> B) -> (C -> D) -> Prop) (f1:int -> (A -> B) -> (A -> B)) (f2:int -> (C -> D) -> (C -> D)) max min cont1 cont2, - (forall z, (z < [|min|])%Z -> P z cont1 cont2) -> - (forall i cont1 cont2, min <= i = true -> i <= max = true -> P ([|i|] - 1)%Z cont1 cont2 -> - P [|i|] (f1 i cont1) (f2 i cont2)) -> - P [|max|] (foldi_down_cont f1 max min cont1) (foldi_down_cont f2 max min cont2). -Proof. - intros. - set (P' z cont := - if Zlt_bool z [|min|] then cont = cont1 - else P z cont (foldi_down_cont f2 (of_Z z) min cont2)). - assert (P' [|max|] (foldi_down_cont f1 max min cont1)). - apply foldi_down_cont_ZInd;unfold P';intros. - rewrite Zlt_is_lt_bool in H1;rewrite H1;trivial. - case_eq (Zlt_bool [|i|] [|min|]);intros. - rewrite <- Zlt_is_lt_bool, <- ltb_spec in H4. - elim (not_ltb_refl min);apply leb_ltb_trans with i;trivial. - rewrite of_to_Z;generalize H1;rewrite leb_ltb_eqb, orb_true_iff;intros [Hlt | Heq]. - rewrite foldi_down_cont_gt;[apply H0 | ];trivial. - revert H3;case_eq (Zlt_bool ([|i|] - 1) [|min|]). - rewrite <- Zlt_is_lt_bool;rewrite ltb_spec in Hlt;intros;elimtype False;omega. - rewrite <- (to_Z_sub_1 _ _ Hlt), of_to_Z; intros _ W;exact W. - rewrite eqb_spec in Heq;subst. - rewrite foldi_down_cont_eq;[apply H0 | ];trivial. - assert ([|i|] - 1 < [|i|])%Z by auto with zarith. - rewrite Zlt_is_lt_bool in H5;rewrite H5 in H3;rewrite H3. - apply H;rewrite Zlt_is_lt_bool;trivial. - revert H1;unfold P';case_eq (Zlt_bool [|max|] [|min|]). - rewrite <- Zlt_is_lt_bool;intros. - rewrite H2;rewrite foldi_down_cont_lt;[ | rewrite ltb_spec];auto. - rewrite of_to_Z;auto. -Qed. - - -Lemma foldi_down_cont_ind2 : forall A B C D (P: (A -> B) -> (C -> D) -> Prop) (f:int -> (A -> B) -> (A -> B)) (g:int -> (C -> D) -> (C -> D)) max min cont1 cont2, - P cont1 cont2 -> - (forall i cont1 cont2, min <= i = true -> i <= max = true -> P cont1 cont2 -> P (f i cont1) (g i cont2)) -> - P (foldi_down_cont f max min cont1) (foldi_down_cont g max min cont2). -Proof. - intros A B C D P f g max min cont1 cont2 Ha Hf. - set (P2 := fun (z:Z) b c => P b c);change (P2 [|max|] (foldi_down_cont f max min cont1) (foldi_down_cont g max min cont2)). - apply foldi_down_cont_ZInd2;trivial. -Qed. - - -Lemma foldi_down_ZInd2 : - forall A B (P: Z -> A -> B -> Prop) (f1:int -> A -> A) (f2:int -> B -> B) max min a1 a2, - (max < min = true -> P ([|min|] - 1)%Z a1 a2) -> - (P [|max|] a1 a2) -> - (forall z, (z < [|min|])%Z -> P z a1 a2) -> - (forall i a1 a2, min <= i = true -> i <= max = true -> P [|i|] a1 a2 -> - P ([|i|] - 1)%Z (f1 i a1) (f2 i a2)) -> - P ([|min|] - 1)%Z (foldi_down f1 max min a1) (foldi_down f2 max min a2). -Proof. - unfold foldi_down;intros A B P f1 f2 max min a1 a2 Hlt;intros. - set (P' z cont1 cont2 := - if Zlt_bool z [|min|] then cont1 = (fun a0 : A => a0) /\ cont2 = (fun a0 : B => a0) - else forall a1 a2, P z a1 a2 -> P ([|min|] - 1)%Z (cont1 a1) (cont2 a2)). - assert (P' [|max|] (foldi_down_cont (fun (i : int) (cont : A -> A) (a0 : A) => cont (f1 i a0)) max - min (fun a0 : A => a0)) - (foldi_down_cont (fun (i : int) (cont : B -> B) (a0 : B) => cont (f2 i a0)) max - min (fun a0 : B => a0))). - apply foldi_down_cont_ZInd2;intros;red. - rewrite Zlt_is_lt_bool in H2;rewrite H2;auto. - case_eq (Zlt_bool [|i|] [|min|]);intros. - rewrite <- Zlt_is_lt_bool in H5;rewrite leb_spec in H2;elimtype False;omega. - clear H5;revert H4;unfold P'. - case_eq (Zlt_bool ([|i|] - 1) [|min|]);intros;auto. - rewrite <- Zlt_is_lt_bool in H4; assert ([|i|] = [|min|]) by (rewrite leb_spec in H2;omega). - destruct H5;subst;rewrite <- H7;apply H1;trivial. - revert H2;unfold P'. - case_eq (Zlt_bool [|max|] [|min|]);auto. - rewrite <- Zlt_is_lt_bool, <- ltb_spec;intros;rewrite foldi_down_cont_lt;auto. - destruct H3. rewrite H4;auto. -Qed. - - -Lemma foldi_down_ind2 : forall A B (P: A -> B -> Prop) (f:int -> A -> A) (g:int -> B -> B) max min a b, - P a b -> - (forall i a b, min <= i = true -> i <= max = true -> P a b -> P (f i a) (g i b)) -> - P (foldi_down f max min a) (foldi_down g max min b). -Proof. - unfold foldi_down;intros A B P f g max min a b Ha Hr;revert a b Ha. - apply (foldi_down_cont_ind2 _ _ _ _ (fun cont1 cont2 => forall a b, P a b -> P (cont1 a) (cont2 b)));auto. -Qed. - - -Lemma fold_down_ind2 : forall A B (P: A -> B -> Prop) (f: A -> A) (g: B -> B) max min a b, - P a b -> (forall a b, P a b -> P (f a) (g b)) -> P (fold_down f max min a) (fold_down g max min b). -Proof. - unfold fold_down;intros A B P f g max min a b Ha Hr;revert a b Ha. - apply (foldi_down_cont_ind2 _ _ _ _ (fun cont1 cont2 => forall a b, P a b -> P (cont1 a) (cont2 b)));auto. -Qed. - -Lemma foldi_down_eq_compat : forall A (f1 f2:int -> A -> A) max min a, - (forall i a, min <= i = true -> i <= max = true -> f1 i a = f2 i a) -> - foldi_down f1 max min a = foldi_down f2 max min a. -Proof. - intros; set (P' (z:Z) (a1 a2:A) := a1 = a2). - assert (P' ([|min|] - 1)%Z (foldi_down f1 max min a) (foldi_down f2 max min a)). - apply foldi_down_ZInd2;unfold P';intros;subst;auto. - apply H0. -Qed. - - -Lemma forallb_spec : forall f from to, - forallb f from to = true <-> - forall i, from <= i = true -> i <= to = true -> f i = true. -Proof. - unfold forallb;intros f from to. - setoid_rewrite leb_spec. - apply foldi_cont_ZInd. - intros;split;[intros;elimtype False;omega | trivial]. - intros i cont Hfr Hto Hcont. - case_eq (f i);intros Heq. - rewrite Hcont;clear Hcont;split;auto with zarith;intros. - assert (H2 : ([|i0|] = [|i|] \/ [|i|] + 1 <= [|i0|])%Z) by omega; destruct H2;auto with zarith. - apply to_Z_inj in H2;rewrite H2;trivial. - split;[discriminate | intros]. - rewrite leb_spec in Hto;rewrite <- Heq;auto with zarith. -Qed. - -Lemma forallb_eq_compat : forall f1 f2 from to, - (forall i, from <= i = true -> i <= to = true -> f1 i = f2 i) -> - forallb f1 from to = forallb f2 from to. -Proof. - unfold forallb;intros. - set (P' (z:Z) (cont1 cont2:unit -> bool) := cont1 tt = cont2 tt). - refine (foldi_cont_ZInd2 _ _ _ _ P' _ _ from to _ _ _ _);unfold P';intros;trivial. - rewrite H2, H;trivial. -Qed. - -Lemma existsb_spec : forall f from to, - existsb f from to = true <-> - exists i, ((from <= i) && (i <= to) && (f i)) = true . -Proof. - unfold existsb;intros. - repeat setoid_rewrite andb_true_iff;setoid_rewrite leb_spec. - apply foldi_cont_ZInd. - intros;split;[discriminate | intros [i [W1 W2]];elimtype False;omega]. - intros i cont Hfr Hto Hcont. - case_eq (f i);intros Heq. - split;trivial. - exists i;rewrite leb_spec in Hto;auto with zarith. - rewrite Hcont;clear Hcont;split;intros [i0 [W1 W2]]; - exists i0;split;auto with zarith. - assert (~ [|i|] = [|i0|]);[ | auto with zarith]. - intros W;apply to_Z_inj in W;rewrite W in Heq;rewrite Heq in W2;discriminate. -Qed. - -Lemma existsb_eq_compat : forall f1 f2 from to, - (forall i, from <= i = true -> i <= to = true -> f1 i = f2 i) -> - existsb f1 from to = existsb f2 from to. -Proof. - unfold existsb;intros. - set (P' (z:Z) (cont1 cont2:unit -> bool) := cont1 tt = cont2 tt). - refine (foldi_cont_ZInd2 _ _ _ _ P' _ _ from to _ _ _ _);unfold P';intros;trivial. - rewrite H2, H;trivial. -Qed. - - -Lemma bit_max_int : forall i, (i < digits)%int = true -> bit max_int i = true. -Proof. - intros;apply (forallb_spec (bit max_int) 0 (digits - 1)). - vm_compute;trivial. - apply leb_0. - rewrite ltb_spec in H. - destruct (to_Z_bounded i);rewrite leb_spec. - change [|digits - 1 |] with ([|digits|] - 1)%Z;omega. -Qed. - -Lemma land_max_int_l : forall i, max_int land i = i. -Proof. - intros;apply bit_eq;intros. - rewrite land_spec. - destruct (reflect_leb digits i0). - rewrite <- leb_spec in l. - rewrite !bit_M;trivial. - rewrite bit_max_int;trivial. - rewrite ltb_spec;omega. -Qed. - -Lemma land_max_int_r : forall i, i land max_int = i. -Proof. - intros;rewrite land_comm;apply land_max_int_l. -Qed. - - -(* int is an OrderedType *) - -Require Import OrderedType. - -Module IntOrderedType <: OrderedType. - - Definition t := int. - - Definition eq x y := (x == y) = true. - - Definition lt x y := (x < y) = true. - - Lemma eq_refl x : eq x x. - Proof. unfold eq. rewrite eqb_spec. reflexivity. Qed. - - Lemma eq_sym x y : eq x y -> eq y x. - Proof. unfold eq. rewrite !eqb_spec. intros ->. reflexivity. Qed. - - Lemma eq_trans x y z : eq x y -> eq y z -> eq x z. - Proof. unfold eq. rewrite !eqb_spec. intros -> ->. reflexivity. Qed. - - Lemma lt_trans x y z : lt x y -> lt y z -> lt x z. - Proof. apply ltb_trans. Qed. - - Lemma lt_not_eq x y : lt x y -> ~ eq x y. - Proof. unfold lt, eq. rewrite ltb_negb_geb, eqb_spec. intros H1 H2. rewrite H2, leb_refl in H1. discriminate. Qed. - - Definition compare x y : Compare lt eq x y. - Proof. - case_eq (x < y); intro e. - exact (LT e). - case_eq (x == y); intro e2. - exact (EQ e2). apply GT. unfold lt. rewrite ltb_negb_geb, leb_ltb_eqb, e, e2. reflexivity. - Defined. - - Definition eq_dec x y : { eq x y } + { ~ eq x y }. - Proof. - case_eq (x == y); intro e. - left; exact e. - right. intro H. rewrite H in e. discriminate. - Defined. - -End IntOrderedType. - - -(* - Local Variables: - coq-load-path: ((rec "../../.." "SMTCoq")) - End: -*) diff --git a/src/versions/standard/Int63/Int63_standard.v b/src/versions/standard/Int63/Int63_standard.v deleted file mode 100644 index 42ede79..0000000 --- a/src/versions/standard/Int63/Int63_standard.v +++ /dev/null @@ -1,23 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2022 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -(** Glue with the Int31 library of standard coq, which is linked to - native integers during VM computations. - - CAUTION: The name "Int63" is given for compatibility reasons, but - int31 is used. **) - -Require Export Ring31. -Require Export Int63Native. -Require Export Int63Op. -Require Export Int63Axioms. -Require Export Int63Properties. diff --git a/src/versions/standard/Structures_standard.v b/src/versions/standard/Structures_standard.v deleted file mode 100644 index 1155874..0000000 --- a/src/versions/standard/Structures_standard.v +++ /dev/null @@ -1,64 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2022 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -Require Import Int63. - -Require Import List. - - -Section Trace. - - Definition trace (step:Type) := ((list step) * step)%type. - - Definition trace_to_list {step:Type} (t:trace step) : list step := - let (t, _) := t in t. - - Definition trace_length {step:Type} (t:trace step) : int := - let (t,_) := t in - List.fold_left (fun i _ => (i+1)%int) t 0%int. - - Fixpoint trace_get_aux {step:Type} (t:list step) (def:step) (i:int) : step := - match t with - | nil => def - | s::ss => - if (i == 0)%int then - s - else - trace_get_aux ss def (i-1) - end. - Definition trace_get {step:Type} (t:trace step) : int -> step := - let (t,def) := t in trace_get_aux t def. - - Definition trace_fold {state step:Type} (transition: state -> step -> state) (s0:state) (t:trace step) := - let (t,_) := t in - List.fold_left transition t s0. - - Lemma trace_fold_ind (state step : Type) (P : state -> Prop) (transition : state -> step -> state) (t : trace step) - (IH: forall (s0 : state) (i : int), (i < trace_length t)%int = true -> P s0 -> P (transition s0 (trace_get t i))) : - forall s0 : state, P s0 -> P (trace_fold transition s0 t). - Admitted. - -End Trace. - - -Require Import PeanoNat. - -Definition nat_eqb := Nat.eqb. -Definition nat_eqb_eq := Nat.eqb_eq. -Definition nat_eqb_refl := Nat.eqb_refl. - - -(* - Local Variables: - coq-load-path: ((rec "../.." "SMTCoq")) - End: -*) diff --git a/src/versions/standard/coq_micromega_full.ml b/src/versions/standard/coq_micromega_full.ml deleted file mode 100644 index d957110..0000000 --- a/src/versions/standard/coq_micromega_full.ml +++ /dev/null @@ -1,2215 +0,0 @@ -(*** This file is taken from Coq-8.9.0 to expose more functions than - coq_micromega.mli does. - See https://github.com/coq/coq/issues/9749 . ***) - - -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* ** Toplevel definition of tactics ** *) -(* *) -(* - Modules ISet, M, Mc, Env, Cache, CacheZ *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-20011 *) -(* *) -(************************************************************************) - -open Pp -open Names -open Goptions -open Mutils_full -open Constr -open Tactypes - -module Micromega = Micromega_plugin.Micromega -module Certificate = Micromega_plugin.Certificate -module Sos_types = Micromega_plugin.Sos_types -module Mfourier = Micromega_plugin.Mfourier - -(** - * Debug flag - *) - -let debug = false - -(* Limit the proof search *) - -let max_depth = max_int - -(* Search limit for provers over Q R *) -let lra_proof_depth = ref max_depth - - -(* Search limit for provers over Z *) -let lia_enum = ref true -let lia_proof_depth = ref max_depth - -let get_lia_option () = - (!lia_enum,!lia_proof_depth) - -let get_lra_option () = - !lra_proof_depth - - - -let _ = - - let int_opt l vref = - { - optdepr = false; - optname = List.fold_right (^) l ""; - optkey = l ; - optread = (fun () -> Some !vref); - optwrite = (fun x -> vref := (match x with None -> max_depth | Some v -> v)) - } in - - let lia_enum_opt = - { - optdepr = false; - optname = "Lia Enum"; - optkey = ["Lia2";"Enum"]; - optread = (fun () -> !lia_enum); - optwrite = (fun x -> lia_enum := x) - } in - let _ = declare_int_option (int_opt ["Lra2"; "Depth"] lra_proof_depth) in - let _ = declare_int_option (int_opt ["Lia2"; "Depth"] lia_proof_depth) in - let _ = declare_bool_option lia_enum_opt in - () - -(** - * Initialize a tag type to the Tag module declaration (see Mutils). - *) - -type tag = Tag.t - -(** - * An atom is of the form: - * pExpr1 \{<,>,=,<>,<=,>=\} pExpr2 - * where pExpr1, pExpr2 are polynomial expressions (see Micromega). pExprs are - * parametrized by 'cst, which is used as the type of constants. - *) - -type 'cst atom = 'cst Micromega.formula - -(** - * Micromega's encoding of formulas. - * By order of appearance: boolean constants, variables, atoms, conjunctions, - * disjunctions, negation, implication. -*) - -type 'cst formula = - | TT - | FF - | X of EConstr.constr - | A of 'cst atom * tag * EConstr.constr - | C of 'cst formula * 'cst formula - | D of 'cst formula * 'cst formula - | N of 'cst formula - | I of 'cst formula * Names.Id.t option * 'cst formula - -(** - * Formula pretty-printer. - *) - -let rec pp_formula o f = - match f with - | TT -> output_string o "tt" - | FF -> output_string o "ff" - | X c -> output_string o "X " - | A(_,t,_) -> Printf.fprintf o "A(%a)" Tag.pp t - | C(f1,f2) -> Printf.fprintf o "C(%a,%a)" pp_formula f1 pp_formula f2 - | D(f1,f2) -> Printf.fprintf o "D(%a,%a)" pp_formula f1 pp_formula f2 - | I(f1,n,f2) -> Printf.fprintf o "I(%a%s,%a)" - pp_formula f1 - (match n with - | Some id -> Names.Id.to_string id - | None -> "") pp_formula f2 - | N(f) -> Printf.fprintf o "N(%a)" pp_formula f - - -let rec map_atoms fct f = - match f with - | TT -> TT - | FF -> FF - | X x -> X x - | A (at,tg,cstr) -> A(fct at,tg,cstr) - | C (f1,f2) -> C(map_atoms fct f1, map_atoms fct f2) - | D (f1,f2) -> D(map_atoms fct f1, map_atoms fct f2) - | N f -> N(map_atoms fct f) - | I(f1,o,f2) -> I(map_atoms fct f1, o , map_atoms fct f2) - -let rec map_prop fct f = - match f with - | TT -> TT - | FF -> FF - | X x -> X (fct x) - | A (at,tg,cstr) -> A(at,tg,cstr) - | C (f1,f2) -> C(map_prop fct f1, map_prop fct f2) - | D (f1,f2) -> D(map_prop fct f1, map_prop fct f2) - | N f -> N(map_prop fct f) - | I(f1,o,f2) -> I(map_prop fct f1, o , map_prop fct f2) - -(** - * Collect the identifiers of a (string of) implications. Implication labels - * are inherited from Coq/CoC's higher order dependent type constructor (Pi). - *) - -let rec ids_of_formula f = - match f with - | I(f1,Some id,f2) -> id::(ids_of_formula f2) - | _ -> [] - -(** - * A clause is a list of (tagged) nFormulas. - * nFormulas are normalized formulas, i.e., of the form: - * cPol \{=,<>,>,>=\} 0 - * with cPol compact polynomials (see the Pol inductive type in EnvRing.v). - *) - -type 'cst clause = ('cst Micromega.nFormula * tag) list - -(** - * A CNF is a list of clauses. - *) - -type 'cst cnf = ('cst clause) list - -(** - * True and False are empty cnfs and clauses. - *) - -let tt : 'cst cnf = [] - -let ff : 'cst cnf = [ [] ] - -(** - * A refinement of cnf with tags left out. This is an intermediary form - * between the cnf tagged list representation ('cst cnf) used to solve psatz, - * and the freeform formulas ('cst formula) that is retrieved from Coq. - *) - -module Mc = Micromega - -type 'cst mc_cnf = ('cst Mc.nFormula) list list - -(** - * From a freeform formula, build a cnf. - * The parametric functions negate and normalize are theory-dependent, and - * originate in micromega.ml (extracted, e.g. for rnegate, from RMicromega.v - * and RingMicromega.v). - *) - -type 'a tagged_option = T of tag list | S of 'a - -let cnf - (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) - (unsat : 'cst Mc.nFormula -> bool) (deduce : 'cst Mc.nFormula -> 'cst Mc.nFormula -> 'cst Mc.nFormula option) (f:'cst formula) = - - let negate a t = - List.map (fun cl -> List.map (fun x -> (x,t)) cl) (negate a) in - - let normalise a t = - List.map (fun cl -> List.map (fun x -> (x,t)) cl) (normalise a) in - - let and_cnf x y = x @ y in - -let rec add_term t0 = function - | [] -> - (match deduce (fst t0) (fst t0) with - | Some u -> if unsat u then T [snd t0] else S (t0::[]) - | None -> S (t0::[])) - | t'::cl0 -> - (match deduce (fst t0) (fst t') with - | Some u -> - if unsat u - then T [snd t0 ; snd t'] - else (match add_term t0 cl0 with - | S cl' -> S (t'::cl') - | T l -> T l) - | None -> - (match add_term t0 cl0 with - | S cl' -> S (t'::cl') - | T l -> T l)) in - - - let rec or_clause cl1 cl2 = - match cl1 with - | [] -> S cl2 - | t0::cl -> - (match add_term t0 cl2 with - | S cl' -> or_clause cl cl' - | T l -> T l) in - - - - let or_clause_cnf t f = - List.fold_right (fun e (acc,tg) -> - match or_clause t e with - | S cl -> (cl :: acc,tg) - | T l -> (acc,tg@l)) f ([],[]) in - - - let rec or_cnf f f' = - match f with - | [] -> tt,[] - | e :: rst -> - let (rst_f',t) = or_cnf rst f' in - let (e_f', t') = or_clause_cnf e f' in - (rst_f' @ e_f', t @ t') in - - - let rec xcnf (polarity : bool) f = - match f with - | TT -> if polarity then (tt,[]) else (ff,[]) - | FF -> if polarity then (ff,[]) else (tt,[]) - | X p -> if polarity then (ff,[]) else (ff,[]) - | A(x,t,_) -> ((if polarity then normalise x t else negate x t),[]) - | N(e) -> xcnf (not polarity) e - | C(e1,e2) -> - let e1,t1 = xcnf polarity e1 in - let e2,t2 = xcnf polarity e2 in - if polarity - then and_cnf e1 e2, t1 @ t2 - else let f',t' = or_cnf e1 e2 in - (f', t1 @ t2 @ t') - | D(e1,e2) -> - let e1,t1 = xcnf polarity e1 in - let e2,t2 = xcnf polarity e2 in - if polarity - then let f',t' = or_cnf e1 e2 in - (f', t1 @ t2 @ t') - else and_cnf e1 e2, t1 @ t2 - | I(e1,_,e2) -> - let e1 , t1 = (xcnf (not polarity) e1) in - let e2 , t2 = (xcnf polarity e2) in - if polarity - then let f',t' = or_cnf e1 e2 in - (f', t1 @ t2 @ t') - else and_cnf e1 e2, t1 @ t2 in - - xcnf true f - -(** - * MODULE: Ordered set of integers. - *) - -module ISet = Set.Make(Int) - -(** - * Given a set of integers s=\{i0,...,iN\} and a list m, return the list of - * elements of m that are at position i0,...,iN. - *) - -let selecti s m = - let rec xselecti i m = - match m with - | [] -> [] - | e::m -> if ISet.mem i s then e::(xselecti (i+1) m) else xselecti (i+1) m in - xselecti 0 m - -(** - * MODULE: Mapping of the Coq data-strustures into Caml and Caml extracted - * code. This includes initializing Caml variables based on Coq terms, parsing - * various Coq expressions into Caml, and dumping Caml expressions into Coq. - * - * Opened here and in csdpcert.ml. - *) - -module M = -struct - - (** - * Location of the Coq libraries. - *) - - let logic_dir = ["Coq";"Logic";"Decidable"] - - let mic_modules = - [ - ["Coq";"Lists";"List"]; - ["ZMicromega"]; - ["Tauto"]; - ["RingMicromega"]; - ["EnvRing"]; - ["Coq"; "micromega"; "ZMicromega"]; - ["Coq"; "micromega"; "RMicromega"]; - ["Coq" ; "micromega" ; "Tauto"]; - ["Coq" ; "micromega" ; "RingMicromega"]; - ["Coq" ; "micromega" ; "EnvRing"]; - ["Coq";"QArith"; "QArith_base"]; - ["Coq";"Reals" ; "Rdefinitions"]; - ["Coq";"Reals" ; "Rpow_def"]; - ["LRing_normalise"]] - - let coq_modules = - Coqlib.(init_modules @ - [logic_dir] @ arith_modules @ zarith_base_modules @ mic_modules) - - let bin_module = [["Coq";"Numbers";"BinNums"]] - - let r_modules = - [["Coq";"Reals" ; "Rdefinitions"]; - ["Coq";"Reals" ; "Rpow_def"] ; - ["Coq";"Reals" ; "Raxioms"] ; - ["Coq";"QArith"; "Qreals"] ; - ] - - let z_modules = [["Coq";"ZArith";"BinInt"]] - - (** - * Initialization : a large amount of Caml symbols are derived from - * ZMicromega.v - *) - - let gen_constant_in_modules s m n = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules s m n) - let init_constant = gen_constant_in_modules "ZMicromega" Coqlib.init_modules - let constant = gen_constant_in_modules "ZMicromega" coq_modules - let bin_constant = gen_constant_in_modules "ZMicromega" bin_module - let r_constant = gen_constant_in_modules "ZMicromega" r_modules - let z_constant = gen_constant_in_modules "ZMicromega" z_modules - let m_constant = gen_constant_in_modules "ZMicromega" mic_modules - - let coq_and = lazy (init_constant "and") - let coq_or = lazy (init_constant "or") - let coq_not = lazy (init_constant "not") - - let coq_iff = lazy (init_constant "iff") - let coq_True = lazy (init_constant "True") - let coq_False = lazy (init_constant "False") - - let coq_cons = lazy (constant "cons") - let coq_nil = lazy (constant "nil") - let coq_list = lazy (constant "list") - - let coq_O = lazy (init_constant "O") - let coq_S = lazy (init_constant "S") - - let coq_N0 = lazy (bin_constant "N0") - let coq_Npos = lazy (bin_constant "Npos") - - let coq_xH = lazy (bin_constant "xH") - let coq_xO = lazy (bin_constant "xO") - let coq_xI = lazy (bin_constant "xI") - - let coq_Z = lazy (bin_constant "Z") - let coq_ZERO = lazy (bin_constant "Z0") - let coq_POS = lazy (bin_constant "Zpos") - let coq_NEG = lazy (bin_constant "Zneg") - - let coq_Q = lazy (constant "Q") - let coq_R = lazy (constant "R") - - let coq_Qmake = lazy (constant "Qmake") - - let coq_Rcst = lazy (constant "Rcst") - - let coq_C0 = lazy (m_constant "C0") - let coq_C1 = lazy (m_constant "C1") - let coq_CQ = lazy (m_constant "CQ") - let coq_CZ = lazy (m_constant "CZ") - let coq_CPlus = lazy (m_constant "CPlus") - let coq_CMinus = lazy (m_constant "CMinus") - let coq_CMult = lazy (m_constant "CMult") - let coq_CInv = lazy (m_constant "CInv") - let coq_COpp = lazy (m_constant "COpp") - - - let coq_R0 = lazy (constant "R0") - let coq_R1 = lazy (constant "R1") - - let coq_proofTerm = lazy (constant "ZArithProof") - let coq_doneProof = lazy (constant "DoneProof") - let coq_ratProof = lazy (constant "RatProof") - let coq_cutProof = lazy (constant "CutProof") - let coq_enumProof = lazy (constant "EnumProof") - - let coq_Zgt = lazy (z_constant "Z.gt") - let coq_Zge = lazy (z_constant "Z.ge") - let coq_Zle = lazy (z_constant "Z.le") - let coq_Zlt = lazy (z_constant "Z.lt") - let coq_Eq = lazy (init_constant "eq") - - let coq_Zplus = lazy (z_constant "Z.add") - let coq_Zminus = lazy (z_constant "Z.sub") - let coq_Zopp = lazy (z_constant "Z.opp") - let coq_Zmult = lazy (z_constant "Z.mul") - let coq_Zpower = lazy (z_constant "Z.pow") - - let coq_Qle = lazy (constant "Qle") - let coq_Qlt = lazy (constant "Qlt") - let coq_Qeq = lazy (constant "Qeq") - - let coq_Qplus = lazy (constant "Qplus") - let coq_Qminus = lazy (constant "Qminus") - let coq_Qopp = lazy (constant "Qopp") - let coq_Qmult = lazy (constant "Qmult") - let coq_Qpower = lazy (constant "Qpower") - - let coq_Rgt = lazy (r_constant "Rgt") - let coq_Rge = lazy (r_constant "Rge") - let coq_Rle = lazy (r_constant "Rle") - let coq_Rlt = lazy (r_constant "Rlt") - - let coq_Rplus = lazy (r_constant "Rplus") - let coq_Rminus = lazy (r_constant "Rminus") - let coq_Ropp = lazy (r_constant "Ropp") - let coq_Rmult = lazy (r_constant "Rmult") - let coq_Rinv = lazy (r_constant "Rinv") - let coq_Rpower = lazy (r_constant "pow") - let coq_IZR = lazy (r_constant "IZR") - let coq_IQR = lazy (r_constant "Q2R") - - - let coq_PEX = lazy (constant "PEX" ) - let coq_PEc = lazy (constant"PEc") - let coq_PEadd = lazy (constant "PEadd") - let coq_PEopp = lazy (constant "PEopp") - let coq_PEmul = lazy (constant "PEmul") - let coq_PEsub = lazy (constant "PEsub") - let coq_PEpow = lazy (constant "PEpow") - - let coq_PX = lazy (constant "PX" ) - let coq_Pc = lazy (constant"Pc") - let coq_Pinj = lazy (constant "Pinj") - - let coq_OpEq = lazy (constant "OpEq") - let coq_OpNEq = lazy (constant "OpNEq") - let coq_OpLe = lazy (constant "OpLe") - let coq_OpLt = lazy (constant "OpLt") - let coq_OpGe = lazy (constant "OpGe") - let coq_OpGt = lazy (constant "OpGt") - - let coq_PsatzIn = lazy (constant "PsatzIn") - let coq_PsatzSquare = lazy (constant "PsatzSquare") - let coq_PsatzMulE = lazy (constant "PsatzMulE") - let coq_PsatzMultC = lazy (constant "PsatzMulC") - let coq_PsatzAdd = lazy (constant "PsatzAdd") - let coq_PsatzC = lazy (constant "PsatzC") - let coq_PsatzZ = lazy (constant "PsatzZ") - - let coq_TT = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "TT") - let coq_FF = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "FF") - let coq_And = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "Cj") - let coq_Or = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "D") - let coq_Neg = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "N") - let coq_Atom = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "A") - let coq_X = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "X") - let coq_Impl = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "I") - let coq_Formula = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "BFormula") - - (** - * Initialization : a few Caml symbols are derived from other libraries; - * QMicromega, ZArithRing, RingMicromega. - *) - - let coq_QWitness = lazy - (gen_constant_in_modules "QMicromega" - [["Coq"; "micromega"; "QMicromega"]] "QWitness") - - let coq_Build = lazy - (gen_constant_in_modules "RingMicromega" - [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] - "Build_Formula") - let coq_Cstr = lazy - (gen_constant_in_modules "RingMicromega" - [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] "Formula") - - (** - * Parsing and dumping : transformation functions between Caml and Coq - * data-structures. - * - * dump_* functions go from Micromega to Coq terms - * parse_* functions go from Coq to Micromega terms - * pp_* functions pretty-print Coq terms. - *) - - exception ParseError - - (* A simple but useful getter function *) - - let get_left_construct sigma term = - match EConstr.kind sigma term with - | Construct((_,i),_) -> (i,[| |]) - | App(l,rst) -> - (match EConstr.kind sigma l with - | Construct((_,i),_) -> (i,rst) - | _ -> raise ParseError - ) - | _ -> raise ParseError - - (* Access the Micromega module *) - - (* parse/dump/print from numbers up to expressions and formulas *) - - let rec parse_nat sigma term = - let (i,c) = get_left_construct sigma term in - match i with - | 1 -> Mc.O - | 2 -> Mc.S (parse_nat sigma (c.(0))) - | i -> raise ParseError - - let pp_nat o n = Printf.fprintf o "%i" (CoqToCaml.nat n) - - let rec dump_nat x = - match x with - | Mc.O -> Lazy.force coq_O - | Mc.S p -> EConstr.mkApp(Lazy.force coq_S,[| dump_nat p |]) - - let rec parse_positive sigma term = - let (i,c) = get_left_construct sigma term in - match i with - | 1 -> Mc.XI (parse_positive sigma c.(0)) - | 2 -> Mc.XO (parse_positive sigma c.(0)) - | 3 -> Mc.XH - | i -> raise ParseError - - let rec dump_positive x = - match x with - | Mc.XH -> Lazy.force coq_xH - | Mc.XO p -> EConstr.mkApp(Lazy.force coq_xO,[| dump_positive p |]) - | Mc.XI p -> EConstr.mkApp(Lazy.force coq_xI,[| dump_positive p |]) - - let pp_positive o x = Printf.fprintf o "%i" (CoqToCaml.positive x) - - let dump_n x = - match x with - | Mc.N0 -> Lazy.force coq_N0 - | Mc.Npos p -> EConstr.mkApp(Lazy.force coq_Npos,[| dump_positive p|]) - - let parse_z sigma term = - let (i,c) = get_left_construct sigma term in - match i with - | 1 -> Mc.Z0 - | 2 -> Mc.Zpos (parse_positive sigma c.(0)) - | 3 -> Mc.Zneg (parse_positive sigma c.(0)) - | i -> raise ParseError - - let dump_z x = - match x with - | Mc.Z0 ->Lazy.force coq_ZERO - | Mc.Zpos p -> EConstr.mkApp(Lazy.force coq_POS,[| dump_positive p|]) - | Mc.Zneg p -> EConstr.mkApp(Lazy.force coq_NEG,[| dump_positive p|]) - - let pp_z o x = Printf.fprintf o "%s" (Big_int.string_of_big_int (CoqToCaml.z_big_int x)) - - let dump_q q = - EConstr.mkApp(Lazy.force coq_Qmake, - [| dump_z q.Micromega.qnum ; dump_positive q.Micromega.qden|]) - - let parse_q sigma term = - match EConstr.kind sigma term with - | App(c, args) -> if EConstr.eq_constr sigma c (Lazy.force coq_Qmake) then - {Mc.qnum = parse_z sigma args.(0) ; Mc.qden = parse_positive sigma args.(1) } - else raise ParseError - | _ -> raise ParseError - - - let rec pp_Rcst o cst = - match cst with - | Mc.C0 -> output_string o "C0" - | Mc.C1 -> output_string o "C1" - | Mc.CQ q -> output_string o "CQ _" - | Mc.CZ z -> pp_z o z - | Mc.CPlus(x,y) -> Printf.fprintf o "(%a + %a)" pp_Rcst x pp_Rcst y - | Mc.CMinus(x,y) -> Printf.fprintf o "(%a - %a)" pp_Rcst x pp_Rcst y - | Mc.CMult(x,y) -> Printf.fprintf o "(%a * %a)" pp_Rcst x pp_Rcst y - | Mc.CInv t -> Printf.fprintf o "(/ %a)" pp_Rcst t - | Mc.COpp t -> Printf.fprintf o "(- %a)" pp_Rcst t - - - let rec dump_Rcst cst = - match cst with - | Mc.C0 -> Lazy.force coq_C0 - | Mc.C1 -> Lazy.force coq_C1 - | Mc.CQ q -> EConstr.mkApp(Lazy.force coq_CQ, [| dump_q q |]) - | Mc.CZ z -> EConstr.mkApp(Lazy.force coq_CZ, [| dump_z z |]) - | Mc.CPlus(x,y) -> EConstr.mkApp(Lazy.force coq_CPlus, [| dump_Rcst x ; dump_Rcst y |]) - | Mc.CMinus(x,y) -> EConstr.mkApp(Lazy.force coq_CMinus, [| dump_Rcst x ; dump_Rcst y |]) - | Mc.CMult(x,y) -> EConstr.mkApp(Lazy.force coq_CMult, [| dump_Rcst x ; dump_Rcst y |]) - | Mc.CInv t -> EConstr.mkApp(Lazy.force coq_CInv, [| dump_Rcst t |]) - | Mc.COpp t -> EConstr.mkApp(Lazy.force coq_COpp, [| dump_Rcst t |]) - - let rec dump_list typ dump_elt l = - match l with - | [] -> EConstr.mkApp(Lazy.force coq_nil,[| typ |]) - | e :: l -> EConstr.mkApp(Lazy.force coq_cons, - [| typ; dump_elt e;dump_list typ dump_elt l|]) - - let pp_list op cl elt o l = - let rec _pp o l = - match l with - | [] -> () - | [e] -> Printf.fprintf o "%a" elt e - | e::l -> Printf.fprintf o "%a ,%a" elt e _pp l in - Printf.fprintf o "%s%a%s" op _pp l cl - - let dump_var = dump_positive - - let dump_expr typ dump_z e = - let rec dump_expr e = - match e with - | Mc.PEX n -> EConstr.mkApp(Lazy.force coq_PEX,[| typ; dump_var n |]) - | Mc.PEc z -> EConstr.mkApp(Lazy.force coq_PEc,[| typ ; dump_z z |]) - | Mc.PEadd(e1,e2) -> EConstr.mkApp(Lazy.force coq_PEadd, - [| typ; dump_expr e1;dump_expr e2|]) - | Mc.PEsub(e1,e2) -> EConstr.mkApp(Lazy.force coq_PEsub, - [| typ; dump_expr e1;dump_expr e2|]) - | Mc.PEopp e -> EConstr.mkApp(Lazy.force coq_PEopp, - [| typ; dump_expr e|]) - | Mc.PEmul(e1,e2) -> EConstr.mkApp(Lazy.force coq_PEmul, - [| typ; dump_expr e1;dump_expr e2|]) - | Mc.PEpow(e,n) -> EConstr.mkApp(Lazy.force coq_PEpow, - [| typ; dump_expr e; dump_n n|]) - in - dump_expr e - - let dump_pol typ dump_c e = - let rec dump_pol e = - match e with - | Mc.Pc n -> EConstr.mkApp(Lazy.force coq_Pc, [|typ ; dump_c n|]) - | Mc.Pinj(p,pol) -> EConstr.mkApp(Lazy.force coq_Pinj , [| typ ; dump_positive p ; dump_pol pol|]) - | Mc.PX(pol1,p,pol2) -> EConstr.mkApp(Lazy.force coq_PX, [| typ ; dump_pol pol1 ; dump_positive p ; dump_pol pol2|]) in - dump_pol e - - let pp_pol pp_c o e = - let rec pp_pol o e = - match e with - | Mc.Pc n -> Printf.fprintf o "Pc %a" pp_c n - | Mc.Pinj(p,pol) -> Printf.fprintf o "Pinj(%a,%a)" pp_positive p pp_pol pol - | Mc.PX(pol1,p,pol2) -> Printf.fprintf o "PX(%a,%a,%a)" pp_pol pol1 pp_positive p pp_pol pol2 in - pp_pol o e - - let pp_cnf pp_c o f = - let pp_clause o l = List.iter (fun ((p,_),t) -> Printf.fprintf o "(%a @%a)" (pp_pol pp_c) p Tag.pp t) l in - List.iter (fun l -> Printf.fprintf o "[%a]" pp_clause l) f - - let dump_psatz typ dump_z e = - let z = Lazy.force typ in - let rec dump_cone e = - match e with - | Mc.PsatzIn n -> EConstr.mkApp(Lazy.force coq_PsatzIn,[| z; dump_nat n |]) - | Mc.PsatzMulC(e,c) -> EConstr.mkApp(Lazy.force coq_PsatzMultC, - [| z; dump_pol z dump_z e ; dump_cone c |]) - | Mc.PsatzSquare e -> EConstr.mkApp(Lazy.force coq_PsatzSquare, - [| z;dump_pol z dump_z e|]) - | Mc.PsatzAdd(e1,e2) -> EConstr.mkApp(Lazy.force coq_PsatzAdd, - [| z; dump_cone e1; dump_cone e2|]) - | Mc.PsatzMulE(e1,e2) -> EConstr.mkApp(Lazy.force coq_PsatzMulE, - [| z; dump_cone e1; dump_cone e2|]) - | Mc.PsatzC p -> EConstr.mkApp(Lazy.force coq_PsatzC,[| z; dump_z p|]) - | Mc.PsatzZ -> EConstr.mkApp(Lazy.force coq_PsatzZ,[| z|]) in - dump_cone e - - let pp_psatz pp_z o e = - let rec pp_cone o e = - match e with - | Mc.PsatzIn n -> - Printf.fprintf o "(In %a)%%nat" pp_nat n - | Mc.PsatzMulC(e,c) -> - Printf.fprintf o "( %a [*] %a)" (pp_pol pp_z) e pp_cone c - | Mc.PsatzSquare e -> - Printf.fprintf o "(%a^2)" (pp_pol pp_z) e - | Mc.PsatzAdd(e1,e2) -> - Printf.fprintf o "(%a [+] %a)" pp_cone e1 pp_cone e2 - | Mc.PsatzMulE(e1,e2) -> - Printf.fprintf o "(%a [*] %a)" pp_cone e1 pp_cone e2 - | Mc.PsatzC p -> - Printf.fprintf o "(%a)%%positive" pp_z p - | Mc.PsatzZ -> - Printf.fprintf o "0" in - pp_cone o e - - let dump_op = function - | Mc.OpEq-> Lazy.force coq_OpEq - | Mc.OpNEq-> Lazy.force coq_OpNEq - | Mc.OpLe -> Lazy.force coq_OpLe - | Mc.OpGe -> Lazy.force coq_OpGe - | Mc.OpGt-> Lazy.force coq_OpGt - | Mc.OpLt-> Lazy.force coq_OpLt - - let dump_cstr typ dump_constant {Mc.flhs = e1 ; Mc.fop = o ; Mc.frhs = e2} = - EConstr.mkApp(Lazy.force coq_Build, - [| typ; dump_expr typ dump_constant e1 ; - dump_op o ; - dump_expr typ dump_constant e2|]) - - let assoc_const sigma x l = - try - snd (List.find (fun (x',y) -> EConstr.eq_constr sigma x (Lazy.force x')) l) - with - Not_found -> raise ParseError - - let zop_table = [ - coq_Zgt, Mc.OpGt ; - coq_Zge, Mc.OpGe ; - coq_Zlt, Mc.OpLt ; - coq_Zle, Mc.OpLe ] - - let rop_table = [ - coq_Rgt, Mc.OpGt ; - coq_Rge, Mc.OpGe ; - coq_Rlt, Mc.OpLt ; - coq_Rle, Mc.OpLe ] - - let qop_table = [ - coq_Qlt, Mc.OpLt ; - coq_Qle, Mc.OpLe ; - coq_Qeq, Mc.OpEq - ] - - type gl = { env : Environ.env; sigma : Evd.evar_map } - - let is_convertible gl t1 t2 = - Reductionops.is_conv gl.env gl.sigma t1 t2 - - let parse_zop gl (op,args) = - let sigma = gl.sigma in - match EConstr.kind sigma op with - | Const (x,_) -> (assoc_const sigma op zop_table, args.(0) , args.(1)) - | Ind((n,0),_) -> - if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_Z) - then (Mc.OpEq, args.(1), args.(2)) - else raise ParseError - | _ -> failwith "parse_zop" - - let parse_rop gl (op,args) = - let sigma = gl.sigma in - match EConstr.kind sigma op with - | Const (x,_) -> (assoc_const sigma op rop_table, args.(0) , args.(1)) - | Ind((n,0),_) -> - if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_R) - then (Mc.OpEq, args.(1), args.(2)) - else raise ParseError - | _ -> failwith "parse_zop" - - let parse_qop gl (op,args) = - (assoc_const gl.sigma op qop_table, args.(0) , args.(1)) - - type 'a op = - | Binop of ('a Mc.pExpr -> 'a Mc.pExpr -> 'a Mc.pExpr) - | Opp - | Power - | Ukn of string - - let assoc_ops sigma x l = - try - snd (List.find (fun (x',y) -> EConstr.eq_constr sigma x (Lazy.force x')) l) - with - Not_found -> Ukn "Oups" - - (** - * MODULE: Env is for environment. - *) - - module Env = - struct - let compute_rank_add env sigma v = - let rec _add env n v = - match env with - | [] -> ([v],n) - | e::l -> - if EConstr.eq_constr sigma e v - then (env,n) - else - let (env,n) = _add l ( n+1) v in - (e::env,n) in - let (env, n) = _add env 1 v in - (env, CamlToCoq.positive n) - - let get_rank env sigma v = - - let rec _get_rank env n = - match env with - | [] -> raise (Invalid_argument "get_rank") - | e::l -> - if EConstr.eq_constr sigma e v - then n - else _get_rank l (n+1) in - _get_rank env 1 - - - let empty = [] - - let elements env = env - - end (* MODULE END: Env *) - - (** - * This is the big generic function for expression parsers. - *) - - let parse_expr sigma parse_constant parse_exp ops_spec env term = - if debug - then ( - let _, env = Pfedit.get_current_context () in - Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.pr_leconstr_env env sigma term)); - -(* - let constant_or_variable env term = - try - ( Mc.PEc (parse_constant term) , env) - with ParseError -> - let (env,n) = Env.compute_rank_add env term in - (Mc.PEX n , env) in -*) - let parse_variable env term = - let (env,n) = Env.compute_rank_add env sigma term in - (Mc.PEX n , env) in - - let rec parse_expr env term = - let combine env op (t1,t2) = - let (expr1,env) = parse_expr env t1 in - let (expr2,env) = parse_expr env t2 in - (op expr1 expr2,env) in - - try (Mc.PEc (parse_constant term) , env) - with ParseError -> - match EConstr.kind sigma term with - | App(t,args) -> - ( - match EConstr.kind sigma t with - | Const c -> - ( match assoc_ops sigma t ops_spec with - | Binop f -> combine env f (args.(0),args.(1)) - | Opp -> let (expr,env) = parse_expr env args.(0) in - (Mc.PEopp expr, env) - | Power -> - begin - try - let (expr,env) = parse_expr env args.(0) in - let power = (parse_exp expr args.(1)) in - (power , env) - with e when CErrors.noncritical e -> - (* if the exponent is a variable *) - let (env,n) = Env.compute_rank_add env sigma term in (Mc.PEX n, env) - end - | Ukn s -> - if debug - then (Printf.printf "unknown op: %s\n" s; flush stdout;); - let (env,n) = Env.compute_rank_add env sigma term in (Mc.PEX n, env) - ) - | _ -> parse_variable env term - ) - | _ -> parse_variable env term in - parse_expr env term - - let zop_spec = - [ - coq_Zplus , Binop (fun x y -> Mc.PEadd(x,y)) ; - coq_Zminus , Binop (fun x y -> Mc.PEsub(x,y)) ; - coq_Zmult , Binop (fun x y -> Mc.PEmul (x,y)) ; - coq_Zopp , Opp ; - coq_Zpower , Power] - - let qop_spec = - [ - coq_Qplus , Binop (fun x y -> Mc.PEadd(x,y)) ; - coq_Qminus , Binop (fun x y -> Mc.PEsub(x,y)) ; - coq_Qmult , Binop (fun x y -> Mc.PEmul (x,y)) ; - coq_Qopp , Opp ; - coq_Qpower , Power] - - let rop_spec = - [ - coq_Rplus , Binop (fun x y -> Mc.PEadd(x,y)) ; - coq_Rminus , Binop (fun x y -> Mc.PEsub(x,y)) ; - coq_Rmult , Binop (fun x y -> Mc.PEmul (x,y)) ; - coq_Ropp , Opp ; - coq_Rpower , Power] - - let zconstant = parse_z - let qconstant = parse_q - - - let rconst_assoc = - [ - coq_Rplus , (fun x y -> Mc.CPlus(x,y)) ; - coq_Rminus , (fun x y -> Mc.CMinus(x,y)) ; - coq_Rmult , (fun x y -> Mc.CMult(x,y)) ; - (* coq_Rdiv , (fun x y -> Mc.CMult(x,Mc.CInv y)) ;*) - ] - - let rec rconstant sigma term = - match EConstr.kind sigma term with - | Const x -> - if EConstr.eq_constr sigma term (Lazy.force coq_R0) - then Mc.C0 - else if EConstr.eq_constr sigma term (Lazy.force coq_R1) - then Mc.C1 - else raise ParseError - | App(op,args) -> - begin - try - (* the evaluation order is important in the following *) - let f = assoc_const sigma op rconst_assoc in - let a = rconstant sigma args.(0) in - let b = rconstant sigma args.(1) in - f a b - with - ParseError -> - match op with - | op when EConstr.eq_constr sigma op (Lazy.force coq_Rinv) -> - let arg = rconstant sigma args.(0) in - if Mc.qeq_bool (Mc.q_of_Rcst arg) {Mc.qnum = Mc.Z0 ; Mc.qden = Mc.XH} - then raise ParseError (* This is a division by zero -- no semantics *) - else Mc.CInv(arg) - | op when EConstr.eq_constr sigma op (Lazy.force coq_IQR) -> Mc.CQ (parse_q sigma args.(0)) - | op when EConstr.eq_constr sigma op (Lazy.force coq_IZR) -> Mc.CZ (parse_z sigma args.(0)) - | _ -> raise ParseError - end - - | _ -> raise ParseError - - - let rconstant sigma term = - let _, env = Pfedit.get_current_context () in - if debug - then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.pr_leconstr_env env sigma term ++ fnl ()); - let res = rconstant sigma term in - if debug then - (Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ; - res - - - let parse_zexpr sigma = parse_expr sigma - (zconstant sigma) - (fun expr x -> - let exp = (parse_z sigma x) in - match exp with - | Mc.Zneg _ -> Mc.PEc Mc.Z0 - | _ -> Mc.PEpow(expr, Mc.Z.to_N exp)) - zop_spec - - let parse_qexpr sigma = parse_expr sigma - (qconstant sigma) - (fun expr x -> - let exp = parse_z sigma x in - match exp with - | Mc.Zneg _ -> - begin - match expr with - | Mc.PEc q -> Mc.PEc (Mc.qpower q exp) - | _ -> print_string "parse_qexpr parse error" ; flush stdout ; raise ParseError - end - | _ -> let exp = Mc.Z.to_N exp in - Mc.PEpow(expr,exp)) - qop_spec - - let parse_rexpr sigma = parse_expr sigma - (rconstant sigma) - (fun expr x -> - let exp = Mc.N.of_nat (parse_nat sigma x) in - Mc.PEpow(expr,exp)) - rop_spec - - let parse_arith parse_op parse_expr env cstr gl = - let sigma = gl.sigma in - if debug - then Feedback.msg_debug (Pp.str "parse_arith: " ++ Printer.pr_leconstr_env gl.env sigma cstr ++ fnl ()); - match EConstr.kind sigma cstr with - | App(op,args) -> - let (op,lhs,rhs) = parse_op gl (op,args) in - let (e1,env) = parse_expr sigma env lhs in - let (e2,env) = parse_expr sigma env rhs in - ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env) - | _ -> failwith "error : parse_arith(2)" - - let parse_zarith = parse_arith parse_zop parse_zexpr - - let parse_qarith = parse_arith parse_qop parse_qexpr - - let parse_rarith = parse_arith parse_rop parse_rexpr - - (* generic parsing of arithmetic expressions *) - - let mkC f1 f2 = C(f1,f2) - let mkD f1 f2 = D(f1,f2) - let mkIff f1 f2 = C(I(f1,None,f2),I(f2,None,f1)) - let mkI f1 f2 = I(f1,None,f2) - - let mkformula_binary g term f1 f2 = - match f1 , f2 with - | X _ , X _ -> X(term) - | _ -> g f1 f2 - - (** - * This is the big generic function for formula parsers. - *) - - let parse_formula gl parse_atom env tg term = - let sigma = gl.sigma in - - let parse_atom env tg t = - try - let (at,env) = parse_atom env t gl in - (A(at,tg,t), env,Tag.next tg) - with e when CErrors.noncritical e -> (X(t),env,tg) in - - let is_prop term = - let sort = Retyping.get_sort_of gl.env gl.sigma term in - Sorts.is_prop sort in - - let rec xparse_formula env tg term = - match EConstr.kind sigma term with - | App(l,rst) -> - (match rst with - | [|a;b|] when EConstr.eq_constr sigma l (Lazy.force coq_and) -> - let f,env,tg = xparse_formula env tg a in - let g,env, tg = xparse_formula env tg b in - mkformula_binary mkC term f g,env,tg - | [|a;b|] when EConstr.eq_constr sigma l (Lazy.force coq_or) -> - let f,env,tg = xparse_formula env tg a in - let g,env,tg = xparse_formula env tg b in - mkformula_binary mkD term f g,env,tg - | [|a|] when EConstr.eq_constr sigma l (Lazy.force coq_not) -> - let (f,env,tg) = xparse_formula env tg a in (N(f), env,tg) - | [|a;b|] when EConstr.eq_constr sigma l (Lazy.force coq_iff) -> - let f,env,tg = xparse_formula env tg a in - let g,env,tg = xparse_formula env tg b in - mkformula_binary mkIff term f g,env,tg - | _ -> parse_atom env tg term) - | Prod(typ,a,b) when EConstr.Vars.noccurn sigma 1 b -> - let f,env,tg = xparse_formula env tg a in - let g,env,tg = xparse_formula env tg b in - mkformula_binary mkI term f g,env,tg - | _ when EConstr.eq_constr sigma term (Lazy.force coq_True) -> (TT,env,tg) - | _ when EConstr.eq_constr sigma term (Lazy.force coq_False) -> (FF,env,tg) - | _ when is_prop term -> X(term),env,tg - | _ -> raise ParseError - in - xparse_formula env tg ((*Reductionops.whd_zeta*) term) - - let dump_formula typ dump_atom f = - let rec xdump f = - match f with - | TT -> EConstr.mkApp(Lazy.force coq_TT,[|typ|]) - | FF -> EConstr.mkApp(Lazy.force coq_FF,[|typ|]) - | C(x,y) -> EConstr.mkApp(Lazy.force coq_And,[|typ ; xdump x ; xdump y|]) - | D(x,y) -> EConstr.mkApp(Lazy.force coq_Or,[|typ ; xdump x ; xdump y|]) - | I(x,_,y) -> EConstr.mkApp(Lazy.force coq_Impl,[|typ ; xdump x ; xdump y|]) - | N(x) -> EConstr.mkApp(Lazy.force coq_Neg,[|typ ; xdump x|]) - | A(x,_,_) -> EConstr.mkApp(Lazy.force coq_Atom,[|typ ; dump_atom x|]) - | X(t) -> EConstr.mkApp(Lazy.force coq_X,[|typ ; t|]) in - xdump f - - - let prop_env_of_formula sigma form = - let rec doit env = function - | TT | FF | A(_,_,_) -> env - | X t -> fst (Env.compute_rank_add env sigma t) - | C(f1,f2) | D(f1,f2) | I(f1,_,f2) -> - doit (doit env f1) f2 - | N f -> doit env f in - - doit [] form - - let var_env_of_formula form = - - let rec vars_of_expr = function - | Mc.PEX n -> ISet.singleton (CoqToCaml.positive n) - | Mc.PEc z -> ISet.empty - | Mc.PEadd(e1,e2) | Mc.PEmul(e1,e2) | Mc.PEsub(e1,e2) -> - ISet.union (vars_of_expr e1) (vars_of_expr e2) - | Mc.PEopp e | Mc.PEpow(e,_)-> vars_of_expr e - in - - let vars_of_atom {Mc.flhs ; Mc.fop; Mc.frhs} = - ISet.union (vars_of_expr flhs) (vars_of_expr frhs) in - - let rec doit = function - | TT | FF | X _ -> ISet.empty - | A (a,t,c) -> vars_of_atom a - | C(f1,f2) | D(f1,f2) |I (f1,_,f2) -> ISet.union (doit f1) (doit f2) - | N f -> doit f in - - doit form - - - - - type 'cst dump_expr = (* 'cst is the type of the syntactic constants *) - { - interp_typ : EConstr.constr; - dump_cst : 'cst -> EConstr.constr; - dump_add : EConstr.constr; - dump_sub : EConstr.constr; - dump_opp : EConstr.constr; - dump_mul : EConstr.constr; - dump_pow : EConstr.constr; - dump_pow_arg : Mc.n -> EConstr.constr; - dump_op : (Mc.op2 * EConstr.constr) list - } - -let dump_zexpr = lazy - { - interp_typ = Lazy.force coq_Z; - dump_cst = dump_z; - dump_add = Lazy.force coq_Zplus; - dump_sub = Lazy.force coq_Zminus; - dump_opp = Lazy.force coq_Zopp; - dump_mul = Lazy.force coq_Zmult; - dump_pow = Lazy.force coq_Zpower; - dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n))); - dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) zop_table - } - -let dump_qexpr = lazy - { - interp_typ = Lazy.force coq_Q; - dump_cst = dump_q; - dump_add = Lazy.force coq_Qplus; - dump_sub = Lazy.force coq_Qminus; - dump_opp = Lazy.force coq_Qopp; - dump_mul = Lazy.force coq_Qmult; - dump_pow = Lazy.force coq_Qpower; - dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n))); - dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) qop_table - } - -let rec dump_Rcst_as_R cst = - match cst with - | Mc.C0 -> Lazy.force coq_R0 - | Mc.C1 -> Lazy.force coq_R1 - | Mc.CQ q -> EConstr.mkApp(Lazy.force coq_IQR, [| dump_q q |]) - | Mc.CZ z -> EConstr.mkApp(Lazy.force coq_IZR, [| dump_z z |]) - | Mc.CPlus(x,y) -> EConstr.mkApp(Lazy.force coq_Rplus, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) - | Mc.CMinus(x,y) -> EConstr.mkApp(Lazy.force coq_Rminus, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) - | Mc.CMult(x,y) -> EConstr.mkApp(Lazy.force coq_Rmult, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) - | Mc.CInv t -> EConstr.mkApp(Lazy.force coq_Rinv, [| dump_Rcst_as_R t |]) - | Mc.COpp t -> EConstr.mkApp(Lazy.force coq_Ropp, [| dump_Rcst_as_R t |]) - - -let dump_rexpr = lazy - { - interp_typ = Lazy.force coq_R; - dump_cst = dump_Rcst_as_R; - dump_add = Lazy.force coq_Rplus; - dump_sub = Lazy.force coq_Rminus; - dump_opp = Lazy.force coq_Ropp; - dump_mul = Lazy.force coq_Rmult; - dump_pow = Lazy.force coq_Rpower; - dump_pow_arg = (fun n -> dump_nat (CamlToCoq.nat (CoqToCaml.n n))); - dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) rop_table - } - - - - -(** [make_goal_of_formula depxr vars props form] where - - vars is an environment for the arithmetic variables occuring in form - - props is an environment for the propositions occuring in form - @return a goal where all the variables and propositions of the formula are quantified - -*) - -let prodn n env b = - let rec prodrec = function - | (0, env, b) -> b - | (n, ((v,t)::l), b) -> prodrec (n-1, l, EConstr.mkProd (v,t,b)) - | _ -> assert false - in - prodrec (n,env,b) - -let make_goal_of_formula sigma dexpr form = - - let vars_idx = - List.mapi (fun i v -> (v, i+1)) (ISet.elements (var_env_of_formula form)) in - - (* List.iter (fun (v,i) -> Printf.fprintf stdout "var %i has index %i\n" v i) vars_idx ;*) - - let props = prop_env_of_formula sigma form in - - let vars_n = List.map (fun (_,i) -> (Names.Id.of_string (Printf.sprintf "__x%i" i)) , dexpr.interp_typ) vars_idx in - let props_n = List.mapi (fun i _ -> (Names.Id.of_string (Printf.sprintf "__p%i" (i+1))) , EConstr.mkProp) props in - - let var_name_pos = List.map2 (fun (idx,_) (id,_) -> id,idx) vars_idx vars_n in - - let dump_expr i e = - let rec dump_expr = function - | Mc.PEX n -> EConstr.mkRel (i+(List.assoc (CoqToCaml.positive n) vars_idx)) - | Mc.PEc z -> dexpr.dump_cst z - | Mc.PEadd(e1,e2) -> EConstr.mkApp(dexpr.dump_add, - [| dump_expr e1;dump_expr e2|]) - | Mc.PEsub(e1,e2) -> EConstr.mkApp(dexpr.dump_sub, - [| dump_expr e1;dump_expr e2|]) - | Mc.PEopp e -> EConstr.mkApp(dexpr.dump_opp, - [| dump_expr e|]) - | Mc.PEmul(e1,e2) -> EConstr.mkApp(dexpr.dump_mul, - [| dump_expr e1;dump_expr e2|]) - | Mc.PEpow(e,n) -> EConstr.mkApp(dexpr.dump_pow, - [| dump_expr e; dexpr.dump_pow_arg n|]) - in dump_expr e in - - let mkop op e1 e2 = - try - EConstr.mkApp(List.assoc op dexpr.dump_op, [| e1; e2|]) - with Not_found -> - EConstr.mkApp(Lazy.force coq_Eq,[|dexpr.interp_typ ; e1 ;e2|]) in - - let dump_cstr i { Mc.flhs ; Mc.fop ; Mc.frhs } = - mkop fop (dump_expr i flhs) (dump_expr i frhs) in - - let rec xdump pi xi f = - match f with - | TT -> Lazy.force coq_True - | FF -> Lazy.force coq_False - | C(x,y) -> EConstr.mkApp(Lazy.force coq_and,[|xdump pi xi x ; xdump pi xi y|]) - | D(x,y) -> EConstr.mkApp(Lazy.force coq_or,[| xdump pi xi x ; xdump pi xi y|]) - | I(x,_,y) -> EConstr.mkArrow (xdump pi xi x) (xdump (pi+1) (xi+1) y) - | N(x) -> EConstr.mkArrow (xdump pi xi x) (Lazy.force coq_False) - | A(x,_,_) -> dump_cstr xi x - | X(t) -> let idx = Env.get_rank props sigma t in - EConstr.mkRel (pi+idx) in - - let nb_vars = List.length vars_n in - let nb_props = List.length props_n in - - (* Printf.fprintf stdout "NBProps : %i\n" nb_props ;*) - - let subst_prop p = - let idx = Env.get_rank props sigma p in - EConstr.mkVar (Names.Id.of_string (Printf.sprintf "__p%i" idx)) in - - let form' = map_prop subst_prop form in - - (prodn nb_props (List.map (fun (x,y) -> Name.Name x,y) props_n) - (prodn nb_vars (List.map (fun (x,y) -> Name.Name x,y) vars_n) - (xdump (List.length vars_n) 0 form)), - List.rev props_n, List.rev var_name_pos,form') - - (** - * Given a conclusion and a list of affectations, rebuild a term prefixed by - * the appropriate letins. - * TODO: reverse the list of bindings! - *) - - let set l concl = - let rec xset acc = function - | [] -> acc - | (e::l) -> - let (name,expr,typ) = e in - xset (EConstr.mkNamedLetIn - (Names.Id.of_string name) - expr typ acc) l in - xset concl l - -end (** - * MODULE END: M - *) - -open M - -let coq_Node = - lazy (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node") -let coq_Leaf = - lazy (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Leaf") -let coq_Empty = - lazy (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty") - -let coq_VarMap = - lazy (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t") - - -let rec dump_varmap typ m = - match m with - | Mc.Empty -> EConstr.mkApp(Lazy.force coq_Empty,[| typ |]) - | Mc.Leaf v -> EConstr.mkApp(Lazy.force coq_Leaf,[| typ; v|]) - | Mc.Node(l,o,r) -> - EConstr.mkApp (Lazy.force coq_Node, [| typ; dump_varmap typ l; o ; dump_varmap typ r |]) - - -let vm_of_list env = - match env with - | [] -> Mc.Empty - | (d,_)::_ -> - List.fold_left (fun vm (c,i) -> - Mc.vm_add d (CamlToCoq.positive i) c vm) Mc.Empty env - -let rec dump_proof_term = function - | Micromega.DoneProof -> Lazy.force coq_doneProof - | Micromega.RatProof(cone,rst) -> - EConstr.mkApp(Lazy.force coq_ratProof, [| dump_psatz coq_Z dump_z cone; dump_proof_term rst|]) - | Micromega.CutProof(cone,prf) -> - EConstr.mkApp(Lazy.force coq_cutProof, - [| dump_psatz coq_Z dump_z cone ; - dump_proof_term prf|]) - | Micromega.EnumProof(c1,c2,prfs) -> - EConstr.mkApp (Lazy.force coq_enumProof, - [| dump_psatz coq_Z dump_z c1 ; dump_psatz coq_Z dump_z c2 ; - dump_list (Lazy.force coq_proofTerm) dump_proof_term prfs |]) - - -let rec size_of_psatz = function - | Micromega.PsatzIn _ -> 1 - | Micromega.PsatzSquare _ -> 1 - | Micromega.PsatzMulC(_,p) -> 1 + (size_of_psatz p) - | Micromega.PsatzMulE(p1,p2) | Micromega.PsatzAdd(p1,p2) -> size_of_psatz p1 + size_of_psatz p2 - | Micromega.PsatzC _ -> 1 - | Micromega.PsatzZ -> 1 - -let rec size_of_pf = function - | Micromega.DoneProof -> 1 - | Micromega.RatProof(p,a) -> (size_of_pf a) + (size_of_psatz p) - | Micromega.CutProof(p,a) -> (size_of_pf a) + (size_of_psatz p) - | Micromega.EnumProof(p1,p2,l) -> (size_of_psatz p1) + (size_of_psatz p2) + (List.fold_left (fun acc p -> size_of_pf p + acc) 0 l) - -let dump_proof_term t = - if debug then Printf.printf "dump_proof_term %i\n" (size_of_pf t) ; - dump_proof_term t - - - -let pp_q o q = Printf.fprintf o "%a/%a" pp_z q.Micromega.qnum pp_positive q.Micromega.qden - - -let rec pp_proof_term o = function - | Micromega.DoneProof -> Printf.fprintf o "D" - | Micromega.RatProof(cone,rst) -> Printf.fprintf o "R[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst - | Micromega.CutProof(cone,rst) -> Printf.fprintf o "C[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst - | Micromega.EnumProof(c1,c2,rst) -> - Printf.fprintf o "EP[%a,%a,%a]" - (pp_psatz pp_z) c1 (pp_psatz pp_z) c2 - (pp_list "[" "]" pp_proof_term) rst - -let rec parse_hyps gl parse_arith env tg hyps = - match hyps with - | [] -> ([],env,tg) - | (i,t)::l -> - let (lhyps,env,tg) = parse_hyps gl parse_arith env tg l in - try - let (c,env,tg) = parse_formula gl parse_arith env tg t in - ((i,c)::lhyps, env,tg) - with e when CErrors.noncritical e -> (lhyps,env,tg) - (*(if debug then Printf.printf "parse_arith : %s\n" x);*) - - -(*exception ParseError*) - -let parse_goal gl parse_arith env hyps term = - (* try*) - let (f,env,tg) = parse_formula gl parse_arith env (Tag.from 0) term in - let (lhyps,env,tg) = parse_hyps gl parse_arith env tg hyps in - (lhyps,f,env) - (* with Failure x -> raise ParseError*) - -(** - * The datastructures that aggregate theory-dependent proof values. - *) -type ('synt_c, 'prf) domain_spec = { - typ : EConstr.constr; (* is the type of the interpretation domain - Z, Q, R*) - coeff : EConstr.constr ; (* is the type of the syntactic coeffs - Z , Q , Rcst *) - dump_coeff : 'synt_c -> EConstr.constr ; - proof_typ : EConstr.constr ; - dump_proof : 'prf -> EConstr.constr -} - -let zz_domain_spec = lazy { - typ = Lazy.force coq_Z; - coeff = Lazy.force coq_Z; - dump_coeff = dump_z ; - proof_typ = Lazy.force coq_proofTerm ; - dump_proof = dump_proof_term -} - -let qq_domain_spec = lazy { - typ = Lazy.force coq_Q; - coeff = Lazy.force coq_Q; - dump_coeff = dump_q ; - proof_typ = Lazy.force coq_QWitness ; - dump_proof = dump_psatz coq_Q dump_q -} - -(** Naive topological sort of constr according to the subterm-ordering *) - -(* An element is minimal x is minimal w.r.t y if - x <= y or (x and y are incomparable) *) - -(** - * Instanciate the current Coq goal with a Micromega formula, a varmap, and a - * witness. - *) - -let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic*) = - (* let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *) - let formula_typ = (EConstr.mkApp (Lazy.force coq_Cstr,[|spec.coeff|])) in - let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in - let vm = dump_varmap (spec.typ) (vm_of_list env) in - (* todo : directly generate the proof term - or generalize before conversion? *) - Proofview.Goal.nf_enter begin fun gl -> - Tacticals.New.tclTHENLIST - [ - Tactics.change_concl - (set - [ - ("__ff", ff, EConstr.mkApp(Lazy.force coq_Formula, [|formula_typ |])); - ("__varmap", vm, EConstr.mkApp(Lazy.force coq_VarMap, [|spec.typ|])); - ("__wit", cert, cert_typ) - ] - (Tacmach.New.pf_concl gl)) - ] - end - - -(** - * The datastructures that aggregate prover attributes. - *) - -type ('option,'a,'prf) prover = { - name : string ; (* name of the prover *) - get_option : unit ->'option ; (* find the options of the prover *) - prover : 'option * 'a list -> 'prf option ; (* the prover itself *) - hyps : 'prf -> ISet.t ; (* extract the indexes of the hypotheses really used in the proof *) - compact : 'prf -> (int -> int) -> 'prf ; (* remap the hyp indexes according to function *) - pp_prf : out_channel -> 'prf -> unit ;(* pretting printing of proof *) - pp_f : out_channel -> 'a -> unit (* pretty printing of the formulas (polynomials)*) -} - - - -(** - * Given a list of provers and a disjunction of atoms, find a proof of any of - * the atoms. Returns an (optional) pair of a proof and a prover - * datastructure. - *) - -let find_witness provers polys1 = - let provers = List.map (fun p -> - (fun l -> - match p.prover (p.get_option (),l) with - | None -> None - | Some prf -> Some(prf,p)) , p.name) provers in - try_any provers (List.map fst polys1) - -(** - * Given a list of provers and a CNF, find a proof for each of the clauses. - * Return the proofs as a list. - *) - -let witness_list prover l = - let rec xwitness_list l = - match l with - | [] -> Some [] - | e :: l -> - match find_witness prover e with - | None -> None - | Some w -> - (match xwitness_list l with - | None -> None - | Some l -> Some (w :: l) - ) in - xwitness_list l - -let witness_list_tags = witness_list - -(** - * Prune the proof object, according to the 'diff' between two cnf formulas. - *) - -let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = - - let compact_proof (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = - let new_cl = List.mapi (fun i (f,_) -> (f,i)) new_cl in - let remap i = - let formula = try fst (List.nth old_cl i) with Failure _ -> failwith "bad old index" in - List.assoc formula new_cl in -(* if debug then - begin - Printf.printf "\ncompact_proof : %a %a %a" - (pp_ml_list prover.pp_f) (List.map fst old_cl) - prover.pp_prf prf - (pp_ml_list prover.pp_f) (List.map fst new_cl) ; - flush stdout - end ; *) - let res = try prover.compact prf remap with x when CErrors.noncritical x -> - if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ; - (* This should not happen -- this is the recovery plan... *) - match prover.prover (prover.get_option () ,List.map fst new_cl) with - | None -> failwith "proof compaction error" - | Some p -> p - in - if debug then - begin - Printf.printf " -> %a\n" - prover.pp_prf res ; - flush stdout - end ; - res in - - let is_proof_compatible (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = - let hyps_idx = prover.hyps prf in - let hyps = selecti hyps_idx old_cl in - is_sublist Pervasives.(=) hyps new_cl in - - let cnf_res = List.combine cnf_ff res in (* we get pairs clause * proof *) - - List.map (fun x -> - let (o,p) = List.find (fun (l,p) -> is_proof_compatible l p x) cnf_res - in compact_proof o p x) cnf_ff' - - -(** - * "Hide out" tagged atoms of a formula by transforming them into generic - * variables. See the Tag module in mutils.ml for more. - *) - -let abstract_formula hyps f = - let rec xabs f = - match f with - | X c -> X c - | A(a,t,term) -> if TagSet.mem t hyps then A(a,t,term) else X(term) - | C(f1,f2) -> - (match xabs f1 , xabs f2 with - | X a1 , X a2 -> X (EConstr.mkApp(Lazy.force coq_and, [|a1;a2|])) - | f1 , f2 -> C(f1,f2) ) - | D(f1,f2) -> - (match xabs f1 , xabs f2 with - | X a1 , X a2 -> X (EConstr.mkApp(Lazy.force coq_or, [|a1;a2|])) - | f1 , f2 -> D(f1,f2) ) - | N(f) -> - (match xabs f with - | X a -> X (EConstr.mkApp(Lazy.force coq_not, [|a|])) - | f -> N f) - | I(f1,hyp,f2) -> - (match xabs f1 , hyp, xabs f2 with - | X a1 , Some _ , af2 -> af2 - | X a1 , None , X a2 -> X (EConstr.mkArrow a1 a2) - | af1 , _ , af2 -> I(af1,hyp,af2) - ) - | FF -> FF - | TT -> TT - in xabs f - - -(* [abstract_wrt_formula] is used in contexts whre f1 is already an abstraction of f2 *) -let rec abstract_wrt_formula f1 f2 = - match f1 , f2 with - | X c , _ -> X c - | A _ , A _ -> f2 - | C(a,b) , C(a',b') -> C(abstract_wrt_formula a a', abstract_wrt_formula b b') - | D(a,b) , D(a',b') -> D(abstract_wrt_formula a a', abstract_wrt_formula b b') - | I(a,_,b) , I(a',x,b') -> I(abstract_wrt_formula a a',x, abstract_wrt_formula b b') - | FF , FF -> FF - | TT , TT -> TT - | N x , N y -> N(abstract_wrt_formula x y) - | _ -> failwith "abstract_wrt_formula" - -(** - * This exception is raised by really_call_csdpcert if Coq's configure didn't - * find a CSDP executable. - *) - -exception CsdpNotFound - - -(** - * This is the core of Micromega: apply the prover, analyze the result and - * prune unused fomulas, and finally modify the proof state. - *) - -let formula_hyps_concl hyps concl = - List.fold_right - (fun (id,f) (cc,ids) -> - match f with - X _ -> (cc,ids) - | _ -> (I(f,Some id,cc), id::ids)) - hyps (concl,[]) - - -let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 gl = - - (* Express the goal as one big implication *) - let (ff,ids) = formula_hyps_concl polys1 polys2 in - - (* Convert the aplpication into a (mc_)cnf (a list of lists of formulas) *) - let cnf_ff,cnf_ff_tags = cnf negate normalise unsat deduce ff in - - if debug then - begin - Feedback.msg_notice (Pp.str "Formula....\n") ; - let formula_typ = (EConstr.mkApp(Lazy.force coq_Cstr, [|spec.coeff|])) in - let ff = dump_formula formula_typ - (dump_cstr spec.typ spec.dump_coeff) ff in - Feedback.msg_notice (Printer.pr_leconstr_env gl.env gl.sigma ff); - Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff - end; - - match witness_list_tags prover cnf_ff with - | None -> None - | Some res -> (*Printf.printf "\nList %i" (List.length `res); *) - let hyps = List.fold_left (fun s (cl,(prf,p)) -> - let tags = ISet.fold (fun i s -> let t = snd (List.nth cl i) in - if debug then (Printf.fprintf stdout "T : %i -> %a" i Tag.pp t) ; - (*try*) TagSet.add t s (* with Invalid_argument _ -> s*)) (p.hyps prf) TagSet.empty in - TagSet.union s tags) (List.fold_left (fun s i -> TagSet.add i s) TagSet.empty cnf_ff_tags) (List.combine cnf_ff res) in - - if debug then (Printf.printf "TForm : %a\n" pp_formula ff ; flush stdout; - Printf.printf "Hyps : %a\n" (fun o s -> TagSet.fold (fun i _ -> Printf.fprintf o "%a " Tag.pp i) s ()) hyps) ; - - let ff' = abstract_formula hyps ff in - let cnf_ff',_ = cnf negate normalise unsat deduce ff' in - - if debug then - begin - Feedback.msg_notice (Pp.str "\nAFormula\n") ; - let formula_typ = (EConstr.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in - let ff' = dump_formula formula_typ - (dump_cstr spec.typ spec.dump_coeff) ff' in - Feedback.msg_notice (Printer.pr_leconstr_env gl.env gl.sigma ff'); - Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff' - end; - - (* Even if it does not work, this does not mean it is not provable - -- the prover is REALLY incomplete *) - (* if debug then - begin - (* recompute the proofs *) - match witness_list_tags prover cnf_ff' with - | None -> failwith "abstraction is wrong" - | Some res -> () - end ; *) - let res' = compact_proofs cnf_ff res cnf_ff' in - - let (ff',res',ids) = (ff',res', ids_of_formula ff') in - - let res' = dump_list (spec.proof_typ) spec.dump_proof res' in - Some (ids,ff',res') - - -(** - * Parse the proof environment, and call micromega_tauto - *) - -let fresh_id avoid id gl = - Tactics.fresh_id_in_env avoid id (Proofview.Goal.env gl) - -let micromega_gen - parse_arith - (negate:'cst atom -> 'cst mc_cnf) - (normalise:'cst atom -> 'cst mc_cnf) - unsat deduce - spec dumpexpr prover tac = - Proofview.Goal.nf_enter begin fun gl -> - let sigma = Tacmach.New.project gl in - let concl = Tacmach.New.pf_concl gl in - let hyps = Tacmach.New.pf_hyps_types gl in - try - let gl0 = { env = Tacmach.New.pf_env gl; sigma } in - let (hyps,concl,env) = parse_goal gl0 parse_arith Env.empty hyps concl in - let env = Env.elements env in - let spec = Lazy.force spec in - let dumpexpr = Lazy.force dumpexpr in - - match micromega_tauto negate normalise unsat deduce spec prover env hyps concl gl0 with - | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") - | Some (ids,ff',res') -> - let (arith_goal,props,vars,ff_arith) = make_goal_of_formula sigma dumpexpr ff' in - let intro (id,_) = Tactics.introduction id in - - let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in - let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in - let ipat_of_name id = Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) in - let goal_name = fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl in - let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in - - let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; - micromega_order_change spec res' - (EConstr.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env' ff_arith ] in - - let goal_props = List.rev (prop_env_of_formula sigma ff') in - - let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in - - let arith_args = goal_props @ goal_vars in - - let kill_arith = - Tacticals.New.tclTHEN - (Tactics.keep []) - ((*Tactics.tclABSTRACT None*) - (Tacticals.New.tclTHEN tac_arith tac)) in - - Tacticals.New.tclTHENS - (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal) - [ - kill_arith; - (Tacticals.New.tclTHENLIST - [(Tactics.generalize (List.map EConstr.mkVar ids)); - Tactics.exact_check (EConstr.applist (EConstr.mkVar goal_name, arith_args)) - ] ) - ] - with - | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment") - | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout") - | CsdpNotFound -> flush stdout ; - Tacticals.New.tclFAIL 0 (Pp.str - (" Skipping what remains of this tactic: the complexity of the goal requires " - ^ "the use of a specialized external tool called csdp. \n\n" - ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" - ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) - end - -let micromega_gen parse_arith - (negate:'cst atom -> 'cst mc_cnf) - (normalise:'cst atom -> 'cst mc_cnf) - unsat deduce - spec prover = - (micromega_gen parse_arith negate normalise unsat deduce spec prover) - - - -let micromega_order_changer cert env ff = - (*let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *) - let coeff = Lazy.force coq_Rcst in - let dump_coeff = dump_Rcst in - let typ = Lazy.force coq_R in - let cert_typ = (EConstr.mkApp(Lazy.force coq_list, [|Lazy.force coq_QWitness |])) in - - let formula_typ = (EConstr.mkApp (Lazy.force coq_Cstr,[| coeff|])) in - let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in - let vm = dump_varmap (typ) (vm_of_list env) in - Proofview.Goal.nf_enter begin fun gl -> - Tacticals.New.tclTHENLIST - [ - (Tactics.change_concl - (set - [ - ("__ff", ff, EConstr.mkApp(Lazy.force coq_Formula, [|formula_typ |])); - ("__varmap", vm, EConstr.mkApp - (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|typ|])); - ("__wit", cert, cert_typ) - ] - (Tacmach.New.pf_concl gl))); - (* Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids)*) - ] - end - -let micromega_genr prover tac = - let parse_arith = parse_rarith in - let negate = Mc.rnegate in - let normalise = Mc.rnormalise in - let unsat = Mc.runsat in - let deduce = Mc.rdeduce in - let spec = lazy { - typ = Lazy.force coq_R; - coeff = Lazy.force coq_Rcst; - dump_coeff = dump_q; - proof_typ = Lazy.force coq_QWitness ; - dump_proof = dump_psatz coq_Q dump_q - } in - Proofview.Goal.nf_enter begin fun gl -> - let sigma = Tacmach.New.project gl in - let concl = Tacmach.New.pf_concl gl in - let hyps = Tacmach.New.pf_hyps_types gl in - - try - let gl0 = { env = Tacmach.New.pf_env gl; sigma } in - let (hyps,concl,env) = parse_goal gl0 parse_arith Env.empty hyps concl in - let env = Env.elements env in - let spec = Lazy.force spec in - - let hyps' = List.map (fun (n,f) -> (n, map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in - let concl' = map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) concl in - - match micromega_tauto negate normalise unsat deduce spec prover env hyps' concl' gl0 with - | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") - | Some (ids,ff',res') -> - let (ff,ids) = formula_hyps_concl - (List.filter (fun (n,_) -> List.mem n ids) hyps) concl in - let ff' = abstract_wrt_formula ff' ff in - - let (arith_goal,props,vars,ff_arith) = make_goal_of_formula sigma (Lazy.force dump_rexpr) ff' in - let intro (id,_) = Tactics.introduction id in - - let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in - let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in - let ipat_of_name id = Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) in - let goal_name = fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl in - let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in - - let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; - micromega_order_changer res' env' ff_arith ] in - - let goal_props = List.rev (prop_env_of_formula sigma ff') in - - let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in - - let arith_args = goal_props @ goal_vars in - - let kill_arith = - Tacticals.New.tclTHEN - (Tactics.keep []) - ((*Tactics.tclABSTRACT None*) - (Tacticals.New.tclTHEN tac_arith tac)) in - - Tacticals.New.tclTHENS - (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal) - [ - kill_arith; - (Tacticals.New.tclTHENLIST - [(Tactics.generalize (List.map EConstr.mkVar ids)); - Tactics.exact_check (EConstr.applist (EConstr.mkVar goal_name, arith_args)) - ] ) - ] - - with - | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment") - | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout") - | CsdpNotFound -> flush stdout ; - Tacticals.New.tclFAIL 0 (Pp.str - (" Skipping what remains of this tactic: the complexity of the goal requires " - ^ "the use of a specialized external tool called csdp. \n\n" - ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" - ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) - end - - - - -let micromega_genr prover = (micromega_genr prover) - - -let lift_ratproof prover l = - match prover l with - | None -> None - | Some c -> Some (Mc.RatProof( c,Mc.DoneProof)) - -type micromega_polys = (Micromega.q Mc.pol * Mc.op1) list - -[@@@ocaml.warning "-37"] -type csdp_certificate = S of Sos_types.positivstellensatz option | F of string -(* Used to read the result of the execution of csdpcert *) - -type provername = string * int option - -(** - * The caching mechanism. - *) - -open Micromega_plugin.Persistent_cache - -module Cache = PHashtable(struct - type t = (provername * micromega_polys) - let equal = Pervasives.(=) - let hash = Hashtbl.hash -end) - -let csdp_cache = ".csdp.cache" - -(** - * Build the command to call csdpcert, and launch it. This in turn will call - * the sos driver to the csdp executable. - * Throw CsdpNotFound if Coq isn't aware of any csdp executable. - *) - -let require_csdp = - if System.is_in_system_path "csdp" - then lazy () - else lazy (raise CsdpNotFound) - -let really_call_csdpcert : provername -> micromega_polys -> Sos_types.positivstellensatz option = - fun provername poly -> - - Lazy.force require_csdp; - - let cmdname = - List.fold_left Filename.concat (Envars.coqlib ()) - ["plugins"; "micromega"; "csdpcert" ^ Coq_config.exec_extension] in - - match ((command cmdname [|cmdname|] (provername,poly)) : csdp_certificate) with - | F str -> failwith str - | S res -> res - -(** - * Check the cache before calling the prover. - *) - -let xcall_csdpcert = - Cache.memo csdp_cache (fun (prover,pb) -> really_call_csdpcert prover pb) - -(** - * Prover callback functions. - *) - -let call_csdpcert prover pb = xcall_csdpcert (prover,pb) - -let rec z_to_q_pol e = - match e with - | Mc.Pc z -> Mc.Pc {Mc.qnum = z ; Mc.qden = Mc.XH} - | Mc.Pinj(p,pol) -> Mc.Pinj(p,z_to_q_pol pol) - | Mc.PX(pol1,p,pol2) -> Mc.PX(z_to_q_pol pol1, p, z_to_q_pol pol2) - -let call_csdpcert_q provername poly = - match call_csdpcert provername poly with - | None -> None - | Some cert -> - let cert = Certificate.q_cert_of_pos cert in - if Mc.qWeakChecker poly cert - then Some cert - else ((print_string "buggy certificate") ;None) - -let call_csdpcert_z provername poly = - let l = List.map (fun (e,o) -> (z_to_q_pol e,o)) poly in - match call_csdpcert provername l with - | None -> None - | Some cert -> - let cert = Certificate.z_cert_of_pos cert in - if Mc.zWeakChecker poly cert - then Some cert - else ((print_string "buggy certificate" ; flush stdout) ;None) - -let xhyps_of_cone base acc prf = - let rec xtract e acc = - match e with - | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> acc - | Mc.PsatzIn n -> let n = (CoqToCaml.nat n) in - if n >= base - then ISet.add (n-base) acc - else acc - | Mc.PsatzMulC(_,c) -> xtract c acc - | Mc.PsatzAdd(e1,e2) | Mc.PsatzMulE(e1,e2) -> xtract e1 (xtract e2 acc) in - - xtract prf acc - -let hyps_of_cone prf = xhyps_of_cone 0 ISet.empty prf - -let compact_cone prf f = - let np n = CamlToCoq.nat (f (CoqToCaml.nat n)) in - - let rec xinterp prf = - match prf with - | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> prf - | Mc.PsatzIn n -> Mc.PsatzIn (np n) - | Mc.PsatzMulC(e,c) -> Mc.PsatzMulC(e,xinterp c) - | Mc.PsatzAdd(e1,e2) -> Mc.PsatzAdd(xinterp e1,xinterp e2) - | Mc.PsatzMulE(e1,e2) -> Mc.PsatzMulE(xinterp e1,xinterp e2) in - - xinterp prf - -let hyps_of_pt pt = - - let rec xhyps base pt acc = - match pt with - | Mc.DoneProof -> acc - | Mc.RatProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c) - | Mc.CutProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c) - | Mc.EnumProof(c1,c2,l) -> - let s = xhyps_of_cone base (xhyps_of_cone base acc c2) c1 in - List.fold_left (fun s x -> xhyps (base + 1) x s) s l in - - xhyps 0 pt ISet.empty - -let hyps_of_pt pt = - let res = hyps_of_pt pt in - if debug - then (Printf.fprintf stdout "\nhyps_of_pt : %a -> " pp_proof_term pt ; ISet.iter (fun i -> Printf.printf "%i " i) res); - res - -let compact_pt pt f = - let translate ofset x = - if x < ofset then x - else (f (x-ofset) + ofset) in - - let rec compact_pt ofset pt = - match pt with - | Mc.DoneProof -> Mc.DoneProof - | Mc.RatProof(c,pt) -> Mc.RatProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt ) - | Mc.CutProof(c,pt) -> Mc.CutProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt ) - | Mc.EnumProof(c1,c2,l) -> Mc.EnumProof(compact_cone c1 (translate (ofset)), compact_cone c2 (translate (ofset)), - Mc.map (fun x -> compact_pt (ofset+1) x) l) in - compact_pt 0 pt - -(** - * Definition of provers. - * Instantiates the type ('a,'prf) prover defined above. - *) - -let lift_pexpr_prover p l = p (List.map (fun (e,o) -> Mc.denorm e , o) l) - -module CacheZ = PHashtable(struct - type prover_option = bool * int - - type t = prover_option * ((Mc.z Mc.pol * Mc.op1) list) - let equal = (=) - let hash = Hashtbl.hash -end) - -module CacheQ = PHashtable(struct - type t = int * ((Mc.q Mc.pol * Mc.op1) list) - let equal = (=) - let hash = Hashtbl.hash -end) - -let memo_zlinear_prover = CacheZ.memo ".lia.cache" (fun ((ce,b),s) -> lift_pexpr_prover (Certificate.lia ce b) s) -let memo_nlia = CacheZ.memo ".nia.cache" (fun ((ce,b),s) -> lift_pexpr_prover (Certificate.nlia ce b) s) -let memo_nra = CacheQ.memo ".nra.cache" (fun (o,s) -> lift_pexpr_prover (Certificate.nlinear_prover o) s) - - - -let linear_prover_Q = { - name = "linear prover"; - get_option = get_lra_option ; - prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o Certificate.q_spec) l) ; - hyps = hyps_of_cone ; - compact = compact_cone ; - pp_prf = pp_psatz pp_q ; - pp_f = fun o x -> pp_pol pp_q o (fst x) -} - - -let linear_prover_R = { - name = "linear prover"; - get_option = get_lra_option ; - prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o Certificate.q_spec) l) ; - hyps = hyps_of_cone ; - compact = compact_cone ; - pp_prf = pp_psatz pp_q ; - pp_f = fun o x -> pp_pol pp_q o (fst x) -} - -let nlinear_prover_R = { - name = "nra"; - get_option = get_lra_option; - prover = memo_nra ; - hyps = hyps_of_cone ; - compact = compact_cone ; - pp_prf = pp_psatz pp_q ; - pp_f = fun o x -> pp_pol pp_q o (fst x) -} - -let non_linear_prover_Q str o = { - name = "real nonlinear prover"; - get_option = (fun () -> (str,o)); - prover = (fun (o,l) -> call_csdpcert_q o l); - hyps = hyps_of_cone; - compact = compact_cone ; - pp_prf = pp_psatz pp_q ; - pp_f = fun o x -> pp_pol pp_q o (fst x) -} - -let non_linear_prover_R str o = { - name = "real nonlinear prover"; - get_option = (fun () -> (str,o)); - prover = (fun (o,l) -> call_csdpcert_q o l); - hyps = hyps_of_cone; - compact = compact_cone; - pp_prf = pp_psatz pp_q; - pp_f = fun o x -> pp_pol pp_q o (fst x) -} - -let non_linear_prover_Z str o = { - name = "real nonlinear prover"; - get_option = (fun () -> (str,o)); - prover = (fun (o,l) -> lift_ratproof (call_csdpcert_z o) l); - hyps = hyps_of_pt; - compact = compact_pt; - pp_prf = pp_proof_term; - pp_f = fun o x -> pp_pol pp_z o (fst x) -} - -let linear_Z = { - name = "lia"; - get_option = get_lia_option; - prover = memo_zlinear_prover ; - hyps = hyps_of_pt; - compact = compact_pt; - pp_prf = pp_proof_term; - pp_f = fun o x -> pp_pol pp_z o (fst x) -} - -let nlinear_Z = { - name = "nlia"; - get_option = get_lia_option; - prover = memo_nlia ; - hyps = hyps_of_pt; - compact = compact_pt; - pp_prf = pp_proof_term; - pp_f = fun o x -> pp_pol pp_z o (fst x) -} - -(** - * Functions instantiating micromega_gen with the appropriate theories and - * solvers - *) - -let lra_Q = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr - [ linear_prover_Q ] - -let psatz_Q i = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr - [ non_linear_prover_Q "real_nonlinear_prover" (Some i) ] - -let lra_R = - micromega_genr [ linear_prover_R ] - -let psatz_R i = - micromega_genr [ non_linear_prover_R "real_nonlinear_prover" (Some i) ] - - -let psatz_Z i = - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr - [ non_linear_prover_Z "real_nonlinear_prover" (Some i) ] - -let sos_Z = - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr - [ non_linear_prover_Z "pure_sos" None ] - -let sos_Q = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr - [ non_linear_prover_Q "pure_sos" None ] - - -let sos_R = - micromega_genr [ non_linear_prover_R "pure_sos" None ] - - -let xlia = micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr - [ linear_Z ] - -let xnlia = - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr - [ nlinear_Z ] - -let nra = - micromega_genr [ nlinear_prover_R ] - -let nqa = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr - [ nlinear_prover_R ] - - - -(* Local Variables: *) -(* coding: utf-8 *) -(* End: *) diff --git a/src/versions/standard/mutils_full.ml b/src/versions/standard/mutils_full.ml deleted file mode 100644 index efa2e4d..0000000 --- a/src/versions/standard/mutils_full.ml +++ /dev/null @@ -1,358 +0,0 @@ -(*** This file is taken from Coq-8.9.0 to solve a compilation issue due - to a wrong order in dependencies. - See https://github.com/coq/coq/issues/9768 . ***) - - -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* ** Utility functions ** *) -(* *) -(* - Modules CoqToCaml, CamlToCoq *) -(* - Modules Cmp, Tag, TagSet *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -module Micromega = Micromega_plugin.Micromega - -let rec pp_list f o l = - match l with - | [] -> () - | e::l -> f o e ; output_string o ";" ; pp_list f o l - - -let finally f rst = - try - let res = f () in - rst () ; res - with reraise -> - (try rst () - with any -> raise reraise - ); raise reraise - -let rec try_any l x = - match l with - | [] -> None - | (f,s)::l -> match f x with - | None -> try_any l x - | x -> x - -let all_sym_pairs f l = - let pair_with acc e l = List.fold_left (fun acc x -> (f e x) ::acc) acc l in - - let rec xpairs acc l = - match l with - | [] -> acc - | e::l -> xpairs (pair_with acc e l) l in - xpairs [] l - -let all_pairs f l = - let pair_with acc e l = List.fold_left (fun acc x -> (f e x) ::acc) acc l in - - let rec xpairs acc l = - match l with - | [] -> acc - | e::lx -> xpairs (pair_with acc e l) lx in - xpairs [] l - -let rec is_sublist f l1 l2 = - match l1 ,l2 with - | [] ,_ -> true - | e::l1', [] -> false - | e::l1' , e'::l2' -> - if f e e' then is_sublist f l1' l2' - else is_sublist f l1 l2' - -let extract pred l = - List.fold_left (fun (fd,sys) e -> - match fd with - | None -> - begin - match pred e with - | None -> fd, e::sys - | Some v -> Some(v,e) , sys - end - | _ -> (fd, e::sys) - ) (None,[]) l - -open Num -open Big_int - -let ppcm x y = - let g = gcd_big_int x y in - let x' = div_big_int x g in - let y' = div_big_int y g in - mult_big_int g (mult_big_int x' y') - -let denominator = function - | Int _ | Big_int _ -> unit_big_int - | Ratio r -> Ratio.denominator_ratio r - -let numerator = function - | Ratio r -> Ratio.numerator_ratio r - | Int i -> Big_int.big_int_of_int i - | Big_int i -> i - -let rec ppcm_list c l = - match l with - | [] -> c - | e::l -> ppcm_list (ppcm c (denominator e)) l - -let rec rec_gcd_list c l = - match l with - | [] -> c - | e::l -> rec_gcd_list (gcd_big_int c (numerator e)) l - -let gcd_list l = - let res = rec_gcd_list zero_big_int l in - if Int.equal (compare_big_int res zero_big_int) 0 - then unit_big_int else res - -let rats_to_ints l = - let c = ppcm_list unit_big_int l in - List.map (fun x -> (div_big_int (mult_big_int (numerator x) c) - (denominator x))) l - -(* assoc_pos j [a0...an] = [j,a0....an,j+n],j+n+1 *) -(** - * MODULE: Coq to Caml data-structure mappings - *) - -module CoqToCaml = -struct - open Micromega - - let rec nat = function - | O -> 0 - | S n -> (nat n) + 1 - - - let rec positive p = - match p with - | XH -> 1 - | XI p -> 1+ 2*(positive p) - | XO p -> 2*(positive p) - - let n nt = - match nt with - | N0 -> 0 - | Npos p -> positive p - - let rec index i = (* Swap left-right ? *) - match i with - | XH -> 1 - | XI i -> 1+(2*(index i)) - | XO i -> 2*(index i) - - open Big_int - - let rec positive_big_int p = - match p with - | XH -> unit_big_int - | XI p -> add_int_big_int 1 (mult_int_big_int 2 (positive_big_int p)) - | XO p -> (mult_int_big_int 2 (positive_big_int p)) - - let z_big_int x = - match x with - | Z0 -> zero_big_int - | Zpos p -> (positive_big_int p) - | Zneg p -> minus_big_int (positive_big_int p) - - let q_to_num {qnum = x ; qden = y} = - Big_int (z_big_int x) // (Big_int (z_big_int (Zpos y))) - -end - - -(** - * MODULE: Caml to Coq data-structure mappings - *) - -module CamlToCoq = -struct - open Micromega - - let rec nat = function - | 0 -> O - | n -> S (nat (n-1)) - - - let rec positive n = - if Int.equal n 1 then XH - else if Int.equal (n land 1) 1 then XI (positive (n lsr 1)) - else XO (positive (n lsr 1)) - - let n nt = - if nt < 0 - then assert false - else if Int.equal nt 0 then N0 - else Npos (positive nt) - - let rec index n = - if Int.equal n 1 then XH - else if Int.equal (n land 1) 1 then XI (index (n lsr 1)) - else XO (index (n lsr 1)) - - - let z x = - match compare x 0 with - | 0 -> Z0 - | 1 -> Zpos (positive x) - | _ -> (* this should be -1 *) - Zneg (positive (-x)) - - open Big_int - - let positive_big_int n = - let two = big_int_of_int 2 in - let rec _pos n = - if eq_big_int n unit_big_int then XH - else - let (q,m) = quomod_big_int n two in - if eq_big_int unit_big_int m - then XI (_pos q) - else XO (_pos q) in - _pos n - - let bigint x = - match sign_big_int x with - | 0 -> Z0 - | 1 -> Zpos (positive_big_int x) - | _ -> Zneg (positive_big_int (minus_big_int x)) - - let q n = - {Micromega.qnum = bigint (numerator n) ; - Micromega.qden = positive_big_int (denominator n)} - -end - -(** - * MODULE: Comparisons on lists: by evaluating the elements in a single list, - * between two lists given an ordering, and using a hash computation - *) - -module Cmp = -struct - - let rec compare_lexical l = - match l with - | [] -> 0 (* Equal *) - | f::l -> - let cmp = f () in - if Int.equal cmp 0 then compare_lexical l else cmp - - let rec compare_list cmp l1 l2 = - match l1 , l2 with - | [] , [] -> 0 - | [] , _ -> -1 - | _ , [] -> 1 - | e1::l1 , e2::l2 -> - let c = cmp e1 e2 in - if Int.equal c 0 then compare_list cmp l1 l2 else c - -end - -(** - * MODULE: Labels for atoms in propositional formulas. - * Tags are used to identify unused atoms in CNFs, and propagate them back to - * the original formula. The translation back to Coq then ignores these - * superfluous items, which speeds the translation up a bit. - *) - -module type Tag = -sig - - type t - - val from : int -> t - val next : t -> t - val pp : out_channel -> t -> unit - val compare : t -> t -> int - -end - -module Tag : Tag = -struct - - type t = int - - let from i = i - let next i = i + 1 - let pp o i = output_string o (string_of_int i) - let compare : int -> int -> int = Int.compare - -end - -(** - * MODULE: Ordered sets of tags. - *) - -module TagSet = Set.Make(Tag) - -(** As for Unix.close_process, our Unix.waipid will ignore all EINTR *) - -let rec waitpid_non_intr pid = - try snd (Unix.waitpid [] pid) - with Unix.Unix_error (Unix.EINTR, _, _) -> waitpid_non_intr pid - -(** - * Forking routine, plumbing the appropriate pipes where needed. - *) - -let command exe_path args vl = - (* creating pipes for stdin, stdout, stderr *) - let (stdin_read,stdin_write) = Unix.pipe () - and (stdout_read,stdout_write) = Unix.pipe () - and (stderr_read,stderr_write) = Unix.pipe () in - - (* Create the process *) - let pid = Unix.create_process exe_path args stdin_read stdout_write stderr_write in - - (* Write the data on the stdin of the created process *) - let outch = Unix.out_channel_of_descr stdin_write in - output_value outch vl ; - flush outch ; - - (* Wait for its completion *) - let status = waitpid_non_intr pid in - - finally - (* Recover the result *) - (fun () -> - match status with - | Unix.WEXITED 0 -> - let inch = Unix.in_channel_of_descr stdout_read in - begin - try Marshal.from_channel inch - with any -> - failwith - (Printf.sprintf "command \"%s\" exited %s" exe_path - (Printexc.to_string any)) - end - | Unix.WEXITED i -> - failwith (Printf.sprintf "command \"%s\" exited %i" exe_path i) - | Unix.WSIGNALED i -> - failwith (Printf.sprintf "command \"%s\" killed %i" exe_path i) - | Unix.WSTOPPED i -> - failwith (Printf.sprintf "command \"%s\" stopped %i" exe_path i)) - (* Cleanup *) - (fun () -> - List.iter (fun x -> try Unix.close x with any -> ()) - [stdin_read; stdin_write; - stdout_read; stdout_write; - stderr_read; stderr_write]) - -(* Local Variables: *) -(* coding: utf-8 *) -(* End: *) diff --git a/src/versions/standard/mutils_full.mli b/src/versions/standard/mutils_full.mli deleted file mode 100644 index d506485..0000000 --- a/src/versions/standard/mutils_full.mli +++ /dev/null @@ -1,77 +0,0 @@ -(*** This file is taken from Coq-8.9.0 to solve a compilation issue due - to a wrong order in dependencies. - See https://github.com/coq/coq/issues/9768 . ***) - - -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -module Micromega = Micromega_plugin.Micromega - -val numerator : Num.num -> Big_int.big_int -val denominator : Num.num -> Big_int.big_int - -module Cmp : sig - - val compare_list : ('a -> 'b -> int) -> 'a list -> 'b list -> int - val compare_lexical : (unit -> int) list -> int - -end - -module Tag : sig - - type t - - val pp : out_channel -> t -> unit - val next : t -> t - val from : int -> t - -end - -module TagSet : CSig.SetS with type elt = Tag.t - -val pp_list : (out_channel -> 'a -> unit) -> out_channel -> 'a list -> unit - -module CamlToCoq : sig - - val positive : int -> Micromega.positive - val bigint : Big_int.big_int -> Micromega.z - val n : int -> Micromega.n - val nat : int -> Micromega.nat - val q : Num.num -> Micromega.q - val index : int -> Micromega.positive - val z : int -> Micromega.z - val positive_big_int : Big_int.big_int -> Micromega.positive - -end - -module CoqToCaml : sig - - val z_big_int : Micromega.z -> Big_int.big_int - val q_to_num : Micromega.q -> Num.num - val positive : Micromega.positive -> int - val n : Micromega.n -> int - val nat : Micromega.nat -> int - val index : Micromega.positive -> int - -end - -val rats_to_ints : Num.num list -> Big_int.big_int list - -val all_pairs : ('a -> 'a -> 'b) -> 'a list -> 'b list -val all_sym_pairs : ('a -> 'a -> 'b) -> 'a list -> 'b list -val try_any : (('a -> 'b option) * 'c) list -> 'a -> 'b option -val is_sublist : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool - -val gcd_list : Num.num list -> Big_int.big_int - -val extract : ('a -> 'b option) -> 'a list -> ('b * 'a) option * 'a list - -val command : string -> string array -> 'a -> 'b diff --git a/src/zchaff/zchaff.ml b/src/zchaff/zchaff.ml index c3aaa64..15a26f2 100644 --- a/src/zchaff/zchaff.ml +++ b/src/zchaff/zchaff.ml @@ -133,7 +133,7 @@ let import_cnf_trace reloc filename first last = let make_roots first last = let cint = Lazy.force cint in - let roots = Array.make (last.id + 2) (Structures.mkArray (cint, Array.make 1 (mkInt 0))) in + let roots = Array.make (last.id + 2) (CoqTerms.mkArray (cint, Array.make 1 (mkInt 0))) in let mk_elem l = let x = match Form.pform l with | Fatom x -> x + 2 @@ -144,15 +144,15 @@ let make_roots first last = let root = Array.of_list (get_val !r) in let croot = Array.make (Array.length root + 1) (mkInt 0) in Array.iteri (fun i l -> croot.(i) <- mk_elem l) root; - roots.(!r.id) <- Structures.mkArray (cint, croot); + roots.(!r.id) <- CoqTerms.mkArray (cint, croot); r := next !r done; let root = Array.of_list (get_val !r) in let croot = Array.make (Array.length root + 1) (mkInt 0) in Array.iteri (fun i l -> croot.(i) <- mk_elem l) root; - roots.(!r.id) <- Structures.mkArray (cint, croot); + roots.(!r.id) <- CoqTerms.mkArray (cint, croot); - Structures.mkArray (mklApp carray [|cint|], roots) + CoqTerms.mkArray (mklApp carray [|cint|], roots) let interp_roots first last = let tbl = Hashtbl.create 17 in @@ -164,7 +164,7 @@ let interp_roots first last = let h = if Form.is_pos l then ph else ph lxor 1 in try Hashtbl.find tbl h with Not_found -> - let p = Structures.mkApp (Structures.mkRel 1, [|mkInt (x+1)|]) in + let p = CoqInterface.mkApp (CoqInterface.mkRel 1, [|mkInt (x+1)|]) in let np = mklApp cnegb [|p|] in Hashtbl.add tbl ph p; Hashtbl.add tbl (ph lxor 1) np; @@ -185,30 +185,28 @@ let interp_roots first last = end; !res -let sat_checker_modules = [ ["SMTCoq";"Trace";"Sat_Checker"] ] - -let certif_ops = CoqTerms.make_certif_ops sat_checker_modules None -let cCertif = gen_constant sat_checker_modules "Certif" +let certif_ops = CoqTerms.csat_checker_certif_ops +let cCertif = CoqTerms.csat_checker_Certif let parse_certif dimacs trace fdimacs ftrace = SmtTrace.clear (); let _,first,last,reloc = import_cnf fdimacs in let d = make_roots first last in - let ce1 = Structures.mkUConst d in - let _ = Structures.declare_constant dimacs ce1 in + let ce1 = CoqInterface.mkUConst d in + let _ = CoqInterface.declare_constant dimacs ce1 in let max_id, confl = import_cnf_trace reloc ftrace first last in let (tres,_,_) = SmtTrace.to_coq (fun _ -> assert false) (fun _ -> assert false) certif_ops confl None in let certif = mklApp cCertif [|mkInt (max_id + 1); tres;mkInt (get_pos confl)|] in - let ce2 = Structures.mkUConst certif in - let _ = Structures.declare_constant trace ce2 in + let ce2 = CoqInterface.mkUConst certif in + let _ = CoqInterface.declare_constant trace ce2 in () -let cdimacs = gen_constant sat_checker_modules "dimacs" -let ccertif = gen_constant sat_checker_modules "certif" -let ctheorem_checker = gen_constant sat_checker_modules "theorem_checker" -let cchecker = gen_constant sat_checker_modules "checker" +let cdimacs = CoqTerms.csat_checker_dimacs +let ccertif = CoqTerms.csat_checker_certif +let ctheorem_checker = CoqTerms.csat_checker_theorem_checker +let cchecker = CoqTerms.csat_checker_checker let theorems interp name fdimacs ftrace = SmtTrace.clear (); @@ -222,36 +220,36 @@ let theorems interp name fdimacs ftrace = mklApp cCertif [|mkInt (max_id + 1);tres;mkInt (get_pos confl)|] in let theorem_concl = mklApp cnot [|mklApp cis_true [|interp d first last|] |] in - let vtype = Term.mkArrow (Lazy.force cint) (Lazy.force cbool) in + let vtype = CoqInterface.mkArrow (Lazy.force cint) (Lazy.force cbool) in let theorem_type = - Structures.mkProd (Structures.mkName "v", vtype, theorem_concl) in + CoqInterface.mkProd (CoqInterface.mkName "v", vtype, theorem_concl) in let theorem_proof_cast = - Structures.mkCast ( - Structures.mkLetIn (Structures.mkName "d", d, Lazy.force cdimacs, - Structures.mkLetIn (Structures.mkName "c", certif, Lazy.force ccertif, - Structures.mkLambda (Structures.mkName "v", vtype, + CoqInterface.mkCast ( + CoqInterface.mkLetIn (CoqInterface.mkName "d", d, Lazy.force cdimacs, + CoqInterface.mkLetIn (CoqInterface.mkName "c", certif, Lazy.force ccertif, + CoqInterface.mkLambda (CoqInterface.mkName "v", vtype, mklApp ctheorem_checker - [| Structures.mkRel 3(*d*); Structures.mkRel 2(*c*); + [| CoqInterface.mkRel 3(*d*); CoqInterface.mkRel 2(*c*); vm_cast_true_no_check - (mklApp cchecker [|Structures.mkRel 3(*d*); Structures.mkRel 2(*c*)|]); - Structures.mkRel 1(*v*)|]))), - Structures.vmcast, + (mklApp cchecker [|CoqInterface.mkRel 3(*d*); CoqInterface.mkRel 2(*c*)|]); + CoqInterface.mkRel 1(*v*)|]))), + CoqInterface.vmcast, theorem_type) in let theorem_proof_nocast = - Structures.mkLetIn (Structures.mkName "d", d, Lazy.force cdimacs, - Structures.mkLetIn (Structures.mkName "c", certif, Lazy.force ccertif, - Structures.mkLambda (Structures.mkName "v", vtype, + CoqInterface.mkLetIn (CoqInterface.mkName "d", d, Lazy.force cdimacs, + CoqInterface.mkLetIn (CoqInterface.mkName "c", certif, Lazy.force ccertif, + CoqInterface.mkLambda (CoqInterface.mkName "v", vtype, mklApp ctheorem_checker - [| Structures.mkRel 3(*d*); Structures.mkRel 2(*c*)|]))) + [| CoqInterface.mkRel 3(*d*); CoqInterface.mkRel 2(*c*)|]))) in - let ce = Structures.mkTConst theorem_proof_cast theorem_proof_nocast theorem_type in - let _ = Structures.declare_constant name ce in + let ce = CoqInterface.mkTConst theorem_proof_cast theorem_proof_nocast theorem_type in + let _ = CoqInterface.declare_constant name ce in () let theorem = theorems (fun _ -> interp_roots) let theorem_abs = - theorems (fun d _ _ -> mklApp cvalid_sat_checker [|mklApp cinterp_var_sat_checker [|Structures.mkRel 1(*v*)|]; d|]) + theorems (fun d _ _ -> mklApp csat_checker_valid [|mklApp csat_checker_interp_var [|CoqInterface.mkRel 1(*v*)|]; d|]) let checker fdimacs ftrace = @@ -267,9 +265,9 @@ let checker fdimacs ftrace = let tm = mklApp cchecker [|d; certif|] in - let res = Structures.cbv_vm (Global.env ()) tm (Lazy.force CoqTerms.cbool) in + let res = CoqInterface.cbv_vm (Global.env ()) tm (Lazy.force CoqTerms.cbool) in Format.eprintf " = %s\n : bool@." - (if Structures.eq_constr res (Lazy.force CoqTerms.ctrue) then + (if CoqInterface.eq_constr res (Lazy.force CoqTerms.ctrue) then "true" else "false") @@ -345,35 +343,31 @@ let call_zchaff nvars root = (* Build the problem that it may be understoof by zchaff *) -let cnf_checker_modules = [ ["SMTCoq";"Trace";"Cnf_Checker"] ] - -let certif_ops = CoqTerms.make_certif_ops cnf_checker_modules None -let ccertif = gen_constant cnf_checker_modules "certif" -let cCertif = gen_constant cnf_checker_modules "Certif" -let cchecker_b_correct = - gen_constant cnf_checker_modules "checker_b_correct" -let cchecker_b = gen_constant cnf_checker_modules "checker_b" -let cchecker_eq_correct = - gen_constant cnf_checker_modules "checker_eq_correct" -let cchecker_eq = gen_constant cnf_checker_modules "checker_eq" +let certif_ops = CoqTerms.ccnf_checker_certif_ops +let ccertif = CoqTerms.ccnf_checker_certif +let cCertif = CoqTerms.ccnf_checker_Certif +let cchecker_b_correct = CoqTerms.ccnf_checker_checker_b_correct +let cchecker_b = CoqTerms.ccnf_checker_checker_b +let cchecker_eq_correct = CoqTerms.ccnf_checker_checker_eq_correct +let cchecker_eq = CoqTerms.ccnf_checker_checker_eq let build_body reify_atom reify_form l b (max_id, confl) vm_cast = - let ntvar = Structures.mkName "t_var" in - let ntform = Structures.mkName "t_form" in - let nc = Structures.mkName "c" in + let ntvar = CoqInterface.mkName "t_var" in + let ntform = CoqInterface.mkName "t_form" in + let nc = CoqInterface.mkName "c" in let tvar = Atom.interp_tbl reify_atom in let _, tform = Form.interp_tbl reify_form in let (tres,_,_) = SmtTrace.to_coq Form.to_coq (fun _ -> assert false) certif_ops confl None in let certif = mklApp cCertif [|mkInt (max_id + 1);tres;mkInt (get_pos confl)|] in - let vtvar = Structures.mkRel 3 in - let vtform = Structures.mkRel 2 in - let vc = Structures.mkRel 1 in + let vtvar = CoqInterface.mkRel 3 in + let vtform = CoqInterface.mkRel 2 in + let vc = CoqInterface.mkRel 1 in let add_lets t = - Structures.mkLetIn (ntvar, tvar, mklApp carray [|Lazy.force cbool|], - Structures.mkLetIn (ntform, tform, mklApp carray [|Lazy.force cform|], - Structures.mkLetIn (nc, certif, Lazy.force ccertif, + CoqInterface.mkLetIn (ntvar, tvar, mklApp carray [|Lazy.force cbool|], + CoqInterface.mkLetIn (ntform, tform, mklApp carray [|Lazy.force cform|], + CoqInterface.mkLetIn (nc, certif, Lazy.force ccertif, t))) in let cbc = @@ -391,22 +385,22 @@ let build_body reify_atom reify_form l b (max_id, confl) vm_cast = let build_body_eq reify_atom reify_form l1 l2 l (max_id, confl) vm_cast = - let ntvar = Structures.mkName "t_var" in - let ntform = Structures.mkName "t_form" in - let nc = Structures.mkName "c" in + let ntvar = CoqInterface.mkName "t_var" in + let ntform = CoqInterface.mkName "t_form" in + let nc = CoqInterface.mkName "c" in let tvar = Atom.interp_tbl reify_atom in let _, tform = Form.interp_tbl reify_form in let (tres,_,_) = SmtTrace.to_coq Form.to_coq (fun _ -> assert false) certif_ops confl None in let certif = mklApp cCertif [|mkInt (max_id + 1);tres;mkInt (get_pos confl)|] in - let vtvar = Structures.mkRel 3 in - let vtform = Structures.mkRel 2 in - let vc = Structures.mkRel 1 in + let vtvar = CoqInterface.mkRel 3 in + let vtform = CoqInterface.mkRel 2 in + let vc = CoqInterface.mkRel 1 in let add_lets t = - Structures.mkLetIn (ntvar, tvar, mklApp carray [|Lazy.force cbool|], - Structures.mkLetIn (ntform, tform, mklApp carray [|Lazy.force cform|], - Structures.mkLetIn (nc, certif, Lazy.force ccertif, + CoqInterface.mkLetIn (ntvar, tvar, mklApp carray [|Lazy.force cbool|], + CoqInterface.mkLetIn (ntform, tform, mklApp carray [|Lazy.force cform|], + CoqInterface.mkLetIn (nc, certif, Lazy.force ccertif, t))) in let ceqc = add_lets (mklApp cchecker_eq [|vtform;l1;l2;l;vc|]) @@ -421,10 +415,10 @@ let build_body_eq reify_atom reify_form l1 l2 l (max_id, confl) vm_cast = (proof_cast, proof_nocast) let get_arguments concl = - let f, args = Structures.decompose_app concl in + let f, args = CoqInterface.decompose_app concl in match args with - | [ty;a;b] when (Structures.eq_constr f (Lazy.force ceq)) && (Structures.eq_constr ty (Lazy.force cbool)) -> a, b - | [a] when (Structures.eq_constr f (Lazy.force cis_true)) -> a, Lazy.force ctrue + | [ty;a;b] when (CoqInterface.eq_constr f (Lazy.force ceq)) && (CoqInterface.eq_constr ty (Lazy.force cbool)) -> a, b + | [a] when (CoqInterface.eq_constr f (Lazy.force cis_true)) -> a, Lazy.force ctrue | _ -> failwith ("Zchaff.get_arguments :can only deal with equality over bool") @@ -499,7 +493,7 @@ let make_proof pform_tbl atom_tbl env reify_form l = let (reloc, resfilename, logfilename, last) = call_zchaff (Form.nvars reify_form) root in (try check_unsat resfilename with - | Sat model -> Structures.error (List.fold_left (fun acc i -> + | Sat model -> CoqInterface.error (List.fold_left (fun acc i -> let index = if i > 0 then i-1 else -i-1 in let ispos = i > 0 in try ( @@ -508,7 +502,7 @@ let make_proof pform_tbl atom_tbl env reify_form l = | Fatom a -> let t = atom_tbl.(a) in let value = if ispos then " = true" else " = false" in - acc^" "^(Pp.string_of_ppcmds (Structures.pr_constr_env env t))^value + acc^" "^(Pp.string_of_ppcmds (CoqInterface.pr_constr_env env t))^value | Fapp _ -> acc (* Nothing to do with ZChaff *) | FbbT _ -> assert false @@ -528,9 +522,9 @@ let core_tactic vm_cast env sigma concl = let reify_atom = Atom.create () in let reify_form = Form.create () in let (body_cast, body_nocast) = - if ((Structures.eq_constr b (Lazy.force ctrue)) || (Structures.eq_constr b (Lazy.force cfalse))) then + if ((CoqInterface.eq_constr b (Lazy.force ctrue)) || (CoqInterface.eq_constr b (Lazy.force cfalse))) then let l = Form.of_coq (Atom.get reify_atom) reify_form a in - let l' = if (Structures.eq_constr b (Lazy.force ctrue)) then Form.neg l else l in + let l' = if (CoqInterface.eq_constr b (Lazy.force ctrue)) then Form.neg l else l in let atom_tbl = Atom.atom_tbl reify_atom in let pform_tbl = Form.pform_tbl reify_form in let max_id_confl = make_proof pform_tbl atom_tbl (Environ.push_rel_context forall_let env) reify_form l' in @@ -551,10 +545,10 @@ let core_tactic vm_cast env sigma concl = let res_cast = compose_lam_assum forall_let body_cast in let res_nocast = compose_lam_assum forall_let body_nocast in - (Structures.tclTHEN - (Structures.set_evars_tac res_nocast) - (Structures.vm_cast_no_check res_cast)) + (CoqInterface.tclTHEN + (CoqInterface.set_evars_tac res_nocast) + (CoqInterface.vm_cast_no_check res_cast)) -let tactic () = Structures.tclTHEN Tactics.intros (Structures.mk_tactic (core_tactic vm_cast_true)) -let tactic_no_check () = Structures.tclTHEN Tactics.intros (Structures.mk_tactic (core_tactic (fun _ -> vm_cast_true_no_check))) +let tactic () = CoqInterface.tclTHEN Tactics.intros (CoqInterface.mk_tactic (core_tactic vm_cast_true)) +let tactic_no_check () = CoqInterface.tclTHEN Tactics.intros (CoqInterface.mk_tactic (core_tactic (fun _ -> vm_cast_true_no_check))) diff --git a/src/zchaff/zchaff.mli b/src/zchaff/zchaff.mli index 612c063..5e67177 100644 --- a/src/zchaff/zchaff.mli +++ b/src/zchaff/zchaff.mli @@ -11,9 +11,9 @@ val pp_trace : Format.formatter -> SatAtom.Form.t SmtCertif.clause -> unit -val parse_certif : Structures.id -> Structures.id -> string -> string -> unit +val parse_certif : CoqInterface.id -> CoqInterface.id -> string -> string -> unit val checker : string -> string -> unit -val theorem : Structures.id -> string -> string -> unit -val theorem_abs : Structures.id -> string -> string -> unit -val tactic : unit -> Structures.tactic -val tactic_no_check : unit -> Structures.tactic +val theorem : CoqInterface.id -> string -> string -> unit +val theorem_abs : CoqInterface.id -> string -> string -> unit +val tactic : unit -> CoqInterface.tactic +val tactic_no_check : unit -> CoqInterface.tactic diff --git a/unit-tests/Makefile b/unit-tests/Makefile index 7739224..b042078 100644 --- a/unit-tests/Makefile +++ b/unit-tests/Makefile @@ -45,7 +45,7 @@ logs: $(OBJ) parallel: Tests_zchaff_tactics.vio Tests_verit_tactics.vio Tests_lfsc_tactics.vio - coqtop -schedule-vio-checking 3 Tests_zchaff_tactics Tests_verit_tactics Tests_lfsc_tactics + coqc -schedule-vio-checking 3 Tests_zchaff_tactics Tests_verit_tactics Tests_lfsc_tactics clean: cleanvo |