Commit upstream/8.11.0 - coq

New upstream version 8.11.0 Ralf Treinen 4 years ago

179 changed file(s) with 9390 addition(s) and 8687 deletion(s). Raw diff Collapse all Expand all

+18

-7

.gitlab-ci.yml less more

17	17	variables:
18	18	# Format: $IMAGE-V$DATE [Cache is not used as of today but kept here
19	19	# for reference]
20		CACHEKEY: "bionic_coq-v8.11-V2019-11-08-V01"
	20	CACHEKEY: "bionic_coq-v8.11-V2019-12-08-V01"
21	21	IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY"
22	22	# By default, jobs run in the base switch; override to select another switch
23	23	OPAM_SWITCH: "base"

102	102	- set -e
103	103	- make -f Makefile.dune world
104	104	- set +e
	105	- tar cfj _build.tar.bz2 _build
105	106	variables:
106	107	OPAM_SWITCH: edge
107	108	OPAM_VARIANT: "+flambda"
108	109	artifacts:
109	110	name: "$CI_JOB_NAME"
110		paths:
111		- _build/
	111	when: always
	112	paths:
	113	- _build/log
	114	- _build.tar.bz2
112	115	expire_in: 1 week
113	116
114	117	.dune-ci-template:

118	121	dependencies:
119	122	- build:edge+flambda:dune:dev
120	123	script:
	124	- tar xfj _build.tar.bz2
121	125	- set -e
122	126	- echo 'start:coq.test'
123	127	- make -f Makefile.dune "$DUNE_TARGET"

127	131	OPAM_SWITCH: edge
128	132	OPAM_VARIANT: "+flambda"
129	133	artifacts:
	134	when: always
130	135	name: "$CI_JOB_NAME"
131	136	expire_in: 2 months
132	137

220	225	expire_in: 1 week
221	226	dependencies: []
222	227	tags:
223		- windows
	228	- windows-inria
224	229	before_script: []
225	230	script:
226	231	- call dev/ci/gitlab.bat

405	410	DUNE_TARGET: refman-html
406	411	artifacts:
407	412	paths:
	413	- _build/log
408	414	- _build/default/doc/sphinx_build/html
409	415
410	416	doc:stdlib:dune:

413	419	DUNE_TARGET: stdlib-html
414	420	artifacts:
415	421	paths:
	422	- _build/log
416	423	- _build/default/doc/stdlib/html
417	424
418	425	doc:refman:deploy:

452	459	DUNE_TARGET: apidoc
453	460	artifacts:
454	461	paths:
	462	- _build/log
455	463	- _build/default/_doc/
456	464
457	465	test-suite:base:

482	490	OPAM_VARIANT: "+flambda"
483	491	only: *full-ci
484	492
485		test-suite:egde:dune:dev:
	493	test-suite:edge:dune:dev:
486	494	stage: stage-2
487	495	dependencies:
488	496	- build:edge+flambda:dune:dev
489	497	needs:
490	498	- build:edge+flambda:dune:dev
491		script: make -f Makefile.dune test-suite
	499	script:
	500	- tar xfj _build.tar.bz2
	501	- make -f Makefile.dune test-suite
492	502	variables:
493	503	OPAM_SWITCH: edge
494	504	OPAM_VARIANT: "+flambda"

560	570
561	571	library:ci-bedrock2:
562	572	extends: .ci-template
	573	variables:
	574	NJOBS: "1"
563	575
564	576	library:ci-color:
565	577	extends: .ci-template-flambda

631	643
632	644	library:ci-sf:
633	645	extends: .ci-template
634		allow_failure: true # Waiting for integration of the fix for #10476
635	646
636	647	library:ci-stdlib2:
637	648	extends: .ci-template-flambda

-0

INSTALL less more

150	150	with flambda unless you use OCaml >= 4.07.0.
151	151
152	152	c.f. https://caml.inria.fr/mantis/view.php?id=7630
	153
	154	If you want your build to be reproducible, ensure that the
	155	SOURCE_DATE_EPOCH environment variable is set as documented in
	156	https://reproducible-builds.org/specs/source-date-epoch/
153	157
154	158	4- Still in the root directory, do
155	159

+16

-1

META.coq.in less more

549	549	plugin(byte) = "ssreflect_plugin.cmo"
550	550	plugin(native) = "ssreflect_plugin.cmxs"
551	551	)
552		)
	552
	553	package "ltac2" (
	554
	555	description = "Coq Ltac2 Plugin"
	556	version = "8.11"
	557
	558	requires = "coq.plugins.ltac"
	559	directory = "../user-contrib/Ltac2"
	560
	561	archive(byte) = "ltac2_plugin.cmo"
	562	archive(native) = "ltac2_plugin.cmx"
	563
	564	plugin(byte) = "ltac2_plugin.cmo"
	565	plugin(native) = "ltac2_plugin.cmxs"
	566	)
	567	)

-7

Makefile less more

45	45
46	46	# !! Before using FIND_SKIP_DIRS, please read how you should in the !!
47	47	# !! FIND_SKIP_DIRS section of dev/doc/build-system.dev.txt !!
48		FIND_SKIP_DIRS:='(' \
	48	# "-not -name ." to avoid skipping everything since we "find ."
	49	# "-type d" to be able to find .merlin.in files
	50	FIND_SKIP_DIRS:=-not -name . '(' \
49	51	-name '{arch}' -o \
50		-name '.svn' -o \
	52	-name '.*' -type d -o \
51	53	-name '_darcs' -o \
52		-name '.git' -o \
53		-name '.bzr' -o \
54	54	-name 'debian' -o \
55	55	-name "$${GIT_DIR}" -o \
56	56	-name '_build' -o \

59	59	-name 'gramlib' -o \
60	60	-name 'user-contrib' -o \
61	61	-name 'test-suite' -o \
62		-name '.opamcache' -o \
63		-name '.coq-native' -o \
64	62	-name 'plugin_tutorial' \
65	63	')' -prune -o
66	64

283	281	distclean: clean cleanconfig cacheclean timingclean
284	282
285	283	voclean:
286		find theories plugins test-suite \( -name '.vo' -o -name '.vio' -o -name '.glob' -o -name ".cmxs" \
	284	find theories plugins test-suite \( -name '.vo' -o -name '.vio' -o -name '.vos' -o -name '.vok' -o -name '.glob' -o -name ".cmxs" \
287	285	-o -name ".native" -o -name ".cmx" -o -name ".cmi" -o -name ".o" \) -exec rm -f {} +
288	286	find theories plugins test-suite -name .coq-native -empty -exec rm -rf {} +
289	287

-3

Makefile.build less more

869	869
870	870	theories/Init/%.vio: theories/Init/%.v $(VO_TOOLS_DEP)
871	871	$(SHOW)'COQC -quick -noinit $<'
872		$(HIDE)$(BOOTCOQC) $< -noinit -R theories Coq -quick -noglob
	872	$(HIDE)$(BOOTCOQC) $< -noinit -R theories Coq -vio -noglob
873	873
874	874	# The general rule for building .vo files :
875	875

884	884	endif
885	885
886	886	%.vio: %.v theories/Init/Prelude.vio $(VO_TOOLS_DEP)
887		$(SHOW)'COQC -quick $<'
888		$(HIDE)$(BOOTCOQC) $< -quick -noglob
	887	$(SHOW)'COQC -vio $<'
	888	$(HIDE)$(BOOTCOQC) $< -vio -noglob
889	889
890	890	%.v.timing.diff: %.v.before-timing %.v.after-timing
891	891	$(SHOW)PYTHON TIMING-DIFF $<

-3

Makefile.doc less more

70	70	$(HIDE)$(SPHINXENV) $(SPHINXBUILD) -b $* \
71	71	$(ALLSPHINXOPTS) doc/sphinx $(SPHINXBUILDDIR)/$*
72	72
	73	COQREFMAN_FILES := $(wildcard $(SPHINXBUILDDIR)/latex/CoqRefMan*)
	74	LATEX_REMOVE_FILES := $(filter-out $(SPHINXBUILDDIR)/latex/CoqRefMan.tex, $(COQREFMAN_FILES))
73	75	refman-pdf: refman-latex
	76	rm -f $(LATEX_REMOVE_FILES)
74	77	+$(MAKE) -C $(SPHINXBUILDDIR)/latex
75	78
76	79	refman: $(SPHINX_DEPS)

125	128	# Standard library
126	129	######################################################################
127	130
	131	DOCLIBS=-R theories Coq -R plugins Coq -Q user-contrib/Ltac2 Ltac2
	132
128	133	### Standard library (browsable html format)
129	134
130	135	ifdef QUICK

135	140	- rm -rf doc/stdlib/html
136	141	$(MKDIR) doc/stdlib/html
137	142	$(COQDOC) -q -d doc/stdlib/html --with-header doc/common/styles/html/$(HTMLSTYLE)/header.html --with-footer doc/common/styles/html/$(HTMLSTYLE)/footer.html --multi-index --html -g \
138		-R theories Coq -R plugins Coq $(VFILES)
	143	$(DOCLIBS) $(VFILES)
139	144	mv doc/stdlib/html/index.html doc/stdlib/html/genindex.html
140	145
141	146	doc/stdlib/index-list.html: doc/stdlib/index-list.html.template doc/stdlib/make-library-index

174	179	ifdef QUICK
175	180	doc/stdlib/FullLibrary.coqdoc.tex:
176	181	$(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \
177		-R theories Coq -R plugins Coq $(VFILES) > $@
	182	$(DOCLIBS) $(VFILES) > $@
178	183	sed -i.tmp -e 's///g' $@ && rm $@.tmp
179	184	else
180	185	doc/stdlib/FullLibrary.coqdoc.tex: $(COQDOC) $(ALLVO)
181	186	$(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \
182		-R theories Coq -R plugins Coq $(VFILES) > $@
	187	$(DOCLIBS) $(VFILES) > $@
183	188	sed -i.tmp -e 's///g' $@ && rm $@.tmp
184	189	endif
185	190

-5

Makefile.dune less more

10	10	# use DUNEOPT=--display=short for a more verbose build
11	11	# DUNEOPT=--display=short
12	12
13		BUILD_CONTEXT=_build/default
	13	BOOT_DIR=_build_boot
	14	BOOT_CONTEXT=$(BOOT_DIR)/default
14	15
15	16	help:
16	17	@echo "Welcome to Coq's Dune-based build system. Targets are:"

44	45	@echo "(library (name ltac_plugin) (public_name coq.plugins.ltac) (modules_without_implementation extraargs extratactics))" > plugins/ltac/dune
45	46
46	47	voboot: plugins/ltac/dune
47		dune build $(DUNEOPT) @vodeps
48		dune exec ./tools/coq_dune.exe $(BUILD_CONTEXT)/.vfiles.d
	48	dune build --build-dir=$(BOOT_DIR) $(DUNEOPT) @vodeps
	49	dune exec --build-dir=$(BOOT_DIR) -- ./tools/coq_dune.exe $(BOOT_CONTEXT)/.vfiles.d
49	50
50	51	states: voboot
51	52	dune build --display=short $(DUNEOPT) dev/shim/coqtop-prelude

103	104
104	105	ireport:
105	106	dune clean
106		dune build $(DUNEOPT) @vodeps --profile=ireport
107		dune exec coq_dune $(BUILD_CONTEXT)/.vfiles.d --profile=ireport
	107	dune build --build-dir=$(BOOT_DIR) $(DUNEOPT) @vodeps
	108	dune exec --build-dir=$(BOOT_DIR) -- ./tools/coq_dune.exe $(BOOT_CONTEXT)/.vfiles.d
108	109	dune build $(DUNEOPT) @install --profile=ireport
109	110
110	111	clean:

-3

Makefile.ide less more

105	105	$(COQIDE): $(LINKIDEOPT)
106	106	$(SHOW)'OCAMLOPT -o $@'
107	107	$(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ \
108		-linkpkg -package str,unix,dynlink,threads,lablgtk3-sourceview3 -linkall $(IDEFLAGS:.cma=.cmxa) $^
	108	-linkpkg -package str,unix,threads,lablgtk3-sourceview3 $(IDEFLAGS:.cma=.cmxa) $^
109	109	$(STRIP_HIDE) $@
110	110	else
111	111	$(COQIDE): $(COQIDEBYTE)

115	115	$(COQIDEBYTE): $(LINKIDE)
116	116	$(SHOW)'OCAMLC -o $@'
117	117	$(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -o $@ \
118		-linkpkg -package str,unix,dynlink,threads,lablgtk3-sourceview3 $(IDEFLAGS) $(IDECDEPSFLAGS) $^
	118	-linkpkg -package str,unix,threads,lablgtk3-sourceview3 $(IDEFLAGS) $(IDECDEPSFLAGS) $^
119	119
120	120	ide/coqide_os_specific.ml: ide/coqide_$(IDEINT).ml.in config/Makefile
121	121	rm -f $@ && cp $< $@ && chmod a-w $@

240	240	$(COQIDEINAPP): ide/macos_prehook.cmx $(LINKIDEOPT) \| $(COQIDEAPP)/Contents
241	241	$(SHOW)'OCAMLOPT -o $@'
242	242	$(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ \
243		-linkpkg -package str,unix,dynlink,threads,lablgtk3-sourceview3 $(IDEFLAGS:.cma=.cmxa) $^
	243	-linkpkg -package str,unix,threads,lablgtk3-sourceview3 $(IDEFLAGS:.cma=.cmxa) $^
244	244	$(STRIP_HIDE) $@
245	245
246	246	$(COQIDEAPP)/Contents/Resources/share: $(COQIDEAPP)/Contents

+10

-1

Makefile.install less more

114	114	install-merlin:
115	115	$(INSTALLSH) $(FULLCOQLIB) $(wildcard $(INSTALLCMX:.cmx=.cmt) $(INSTALLCMI:.cmi=.cmti) $(MLIFILES) $(MLFILES) $(MERLINFILES))
116	116
	117	#NB: some files don't produce native files (eg Ltac2 files) as they
	118	#don't have any Coq definitions. Makefile can't predict that so we use \|\| true
	119	#vos build is bugged in -quick mode, see #11195
117	120	install-library:
118	121	$(MKDIR) $(FULLCOQLIB)
119		$(INSTALLSH) $(FULLCOQLIB) $(LIBFILES)
	122	$(INSTALLSH) $(FULLCOQLIB) $(ALLVO:.$(VO)=.vo)
	123	$(INSTALLSH) $(FULLCOQLIB) $(ALLVO:.$(VO)=.vos) \|\| true
	124	ifneq ($(NATIVECOMPUTE),)
	125	$(INSTALLSH) $(FULLCOQLIB) $(NATIVEFILES) \|\| true
	126	endif
	127	$(INSTALLSH) $(FULLCOQLIB) $(VFILES)
	128	$(INSTALLSH) $(FULLCOQLIB) $(GLOBFILES)
120	129	$(MKDIR) $(FULLCOQLIB)/user-contrib
121	130	$(MKDIR) $(FULLCOQLIB)/kernel/byterun
122	131	ifndef CUSTOM

-1

Makefile.vofiles less more

48	48	else
49	49	NATIVEFILES :=
50	50	endif
51		LIBFILES:=$(ALLVO:.$(VO)=.vo) $(ALLVO:.$(VO)=.vos) $(NATIVEFILES) $(VFILES) $(GLOBFILES)
52	51
53	52	# For emacs:
54	53	# Local Variables:

+11

-11

checker/analyze.ml less more

105	105
106	106	type repr =
107	107	\| RInt of int
108		\| RInt63 of Uint63.t
109		\| RFloat64 of Float64.t
	108	\| Rint64 of Int64.t
	109	\| RFloat64 of float
110	110	\| RBlock of (int * int) (* tag × len *)
111	111	\| RString of string
112	112	\| RPointer of int

120	120
121	121	type obj =
122	122	\| Struct of int * data array (* tag × data *)
123		\| Int63 of Uint63.t (* Primitive integer *)
124		\| Float64 of Float64.t (* Primitive float *)
	123	\| Int64 of Int64.t (* Primitive integer *)
	124	\| Float64 of float (* Primitive float *)
125	125	\| String of string
126	126
127	127	module type Input =

343	343	RCode addr
344	344	\| CODE_CUSTOM ->
345	345	begin match input_cstring chan with
346		\| "_j" -> RInt63 (Uint63.of_int64 (input_intL chan))
	346	\| "_j" -> Rint64 (input_intL chan)
347	347	\| s -> Printf.eprintf "Unhandled custom code: %s" s; assert false
348	348	end
349	349	\| CODE_DOUBLE_BIG ->
350		RFloat64 (Float64.of_float (input_double_big chan))
	350	RFloat64 (input_double_big chan)
351	351	\| CODE_DOUBLE_LITTLE ->
352		RFloat64 (Float64.of_float (input_double_little chan))
	352	RFloat64 (input_double_little chan)
353	353	\| CODE_DOUBLE_ARRAY32_LITTLE
354	354	\| CODE_DOUBLE_ARRAY8_BIG
355	355	\| CODE_DOUBLE_ARRAY8_LITTLE

387	387	\| RCode addr ->
388	388	let data = Fun addr in
389	389	data, None
390		\| RInt63 i ->
	390	\| Rint64 i ->
391	391	let data = Ptr !current_object in
392		let () = LargeArray.set memory !current_object (Int63 i) in
	392	let () = LargeArray.set memory !current_object (Int64 i) in
393	393	let () = incr current_object in
394	394	data, None
395	395	\| RFloat64 f ->

460	460	for i = 0 to len - 1 do
461	461	let obj = match LargeArray.get mem i with
462	462	\| Struct (tag, blk) -> Obj.new_block tag (Array.length blk)
463		\| Int63 i -> Obj.repr i
	463	\| Int64 i -> Obj.repr i
464	464	\| Float64 f -> Obj.repr f
465	465	\| String str -> Obj.repr str
466	466	in

480	480	for k = 0 to Array.length blk - 1 do
481	481	Obj.set_field obj k (get_data blk.(k))
482	482	done
483		\| Int63 _
	483	\| Int64 _
484	484	\| Float64 _
485	485	\| String _ -> ()
486	486	done;

-2

checker/analyze.mli less more

6	6
7	7	type obj =
8	8	\| Struct of int * data array (* tag × data *)
9		\| Int63 of Uint63.t (* Primitive integer *)
10		\| Float64 of Float64.t (* Primitive float *)
	9	\| Int64 of Int64.t (* Primitive integer *)
	10	\| Float64 of float (* Primitive float *)
11	11	\| String of string
12	12
13	13	module LargeArray :

-2

checker/votour.ml less more

99	99	init_size seen (fun n -> fold (succ i) (accu + 1 + n) k) os.(i)
100	100	in
101	101	fold 0 1 (fun size -> let () = LargeArray.set !sizes p size in k size)
102		\| Int63 _ -> k 0
	102	\| Int64 _ -> k 0
103	103	\| Float64 _ -> k 0
104	104	\| String s ->
105	105	let size = 2 + (String.length s / ws) in

117	117	\| Ptr p ->
118	118	match LargeArray.get !memory p with
119	119	\| Struct (tag, os) -> BLOCK (tag, os)
120		\| Int63 _ -> OTHER (* TODO: pretty-print int63 values *)
	120	\| Int64 _ -> OTHER (* TODO: pretty-print int63 values *)
121	121	\| Float64 _ -> OTHER (* TODO: pretty-print float64 values *)
122	122	\| String s -> STRING s
123	123

+17

-0

clib/cUnix.ml less more

139	139	Unix.Unix_error _ -> false)
140	140	with
141	141	Unix.Unix_error _ -> (fun _ -> false)
	142
	143	(* Copied from ocaml filename.ml *)
	144	let prng = lazy(Random.State.make_self_init ())
	145
	146	let temp_file_name temp_dir prefix suffix =
	147	let rnd = (Random.State.bits (Lazy.force prng)) land 0xFFFFFF in
	148	Filename.concat temp_dir (Printf.sprintf "%s%06x%s" prefix rnd suffix)
	149
	150	let mktemp_dir ?(temp_dir=Filename.get_temp_dir_name()) prefix suffix =
	151	let rec try_name counter =
	152	let name = temp_file_name temp_dir prefix suffix in
	153	match Unix.mkdir name 0o700 with
	154	\| () -> name
	155	\| exception (Sys_error _ as e) ->
	156	if counter >= 1000 then raise e else try_name (counter + 1)
	157	in
	158	try_name 0

-0

clib/cUnix.mli less more

64	64	(** Check if two file names refer to the same (existing) file *)
65	65	val same_file : string -> string -> bool
66	66
	67	(** Like [Stdlib.Filename.temp_file] but producing a directory. *)
	68	val mktemp_dir : ?temp_dir:string -> string -> string -> string

-1

config/dune less more

8	8	(rule
9	9	(targets coq_config.ml coq_config.py Makefile dune.c_flags)
10	10	(mode fallback)
11		(deps %{project_root}/configure.ml %{project_root}/dev/ocamldebug-coq.run (env_var COQ_CONFIGURE_PREFIX))
	11	(deps
	12	%{project_root}/configure.ml
	13	%{project_root}/dev/ocamldebug-coq.run
	14	%{project_root}/dev/header.c
	15	(env_var COQ_CONFIGURE_PREFIX))
12	16	(action (chdir %{project_root} (run %{ocaml} configure.ml -no-ask -native-compiler no))))

+11

-5

configure.ml less more

11	11	#load "str.cma"
12	12	open Printf
13	13
14		let coq_version = "8.11+beta1"
15		let coq_macos_version = "8.10.91" (** "[...] should be a string comprised of
	14	let coq_version = "8.11.0"
	15	let coq_macos_version = "8.11.0" (** "[...] should be a string comprised of
16	16	three non-negative, period-separated integers [...]" *)
17		let vo_magic = 81091
18		let state_magic = 581091
	17	let vo_magic = 81100
	18	let state_magic = 581100
19	19	let is_a_released_version = true
20	20	let distributed_exec =
21	21	["coqtop.opt"; "coqidetop.opt"; "coqqueryworker.opt"; "coqproofworker.opt"; "coqtacticworker.opt";

193	193	let program_in_path prog =
194	194	try let _ = which prog in true with Not_found -> false
195	195
	196	let build_date =
	197	try
	198	float_of_string (Sys.getenv "SOURCE_DATE_EPOCH")
	199	with
	200	Not_found -> Unix.time ()
	201
196	202	(** * Date *)
197	203
198	204	(** The short one is displayed when starting coqtop,

203	209	"July";"August";"September";"October";"November";"December" \|]
204	210
205	211	let get_date () =
206		let now = Unix.localtime (Unix.time ()) in
	212	let now = Unix.gmtime build_date in
207	213	let year = 1900+now.Unix.tm_year in
208	214	let month = months.(now.Unix.tm_mon) in
209	215	sprintf "%s %d" month year,

-0

dev/build/windows/MakeCoq_MinGW.bat less more

419	419	ECHO ========== BUILD COQ ==========
420	420
421	421	MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build"
	422	RMDIR /S /Q "%CYGWIN_INSTALLDIR_WFMT%\build\patches"
422	423	MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build\patches"
423	424
424	425	COPY "%BATCHDIR%\makecoq_mingw.sh" "%CYGWIN_INSTALLDIR_WFMT%\build" \|\| GOTO ErrorExit

-3

dev/build/windows/makecoq_mingw.sh less more

1146	1146	make_ocaml
1147	1147	make_findlib
1148	1148	make_ocamlbuild
1149		# This is the version required by latest CompCert
1150		if build_prep https://gitlab.inria.fr/fpottier/menhir/-/archive/20190626 menhir-20190626 tar.gz 1 ; then
	1149	# This is the latest version as of Jan 13 2020 and compatible with CompCert
	1150	if build_prep https://gitlab.inria.fr/fpottier/menhir/-/archive/20190626 menhir-20190924 tar.gz 1 ; then
1151	1151	# Note: menhir doesn't support -j 8, so don't pass MAKE_OPT
1152	1152	log2 make all PREFIX="$PREFIXOCAML"
1153	1153	log2 make install PREFIX="$PREFIXOCAML"

1648	1648	logn coq_makefile ${COQBIN}coq_makefile -f _CoqProject -o Makefile
1649	1649	log1 make $MAKE_OPT
1650	1650	log2 make install
	1651	# Hack: cmxs file not installed
	1652	# Since the makefiles switch to dune in master there is no point in fixing it
	1653	logn cp_cmxs cp src/equations_plugin.cmxs ${COQLIB}/user-contrib/Equations/
	1654	logn cp_cmxa cp src/equations_plugin.cmxa ${COQLIB}/user-contrib/Equations/
1651	1655	build_post
1652	1656	fi
1653	1657	}

1760	1764	function make_addon_compcert {
1761	1765	installer_addon_dependency_beg compcert
1762	1766	make_menhir
1763		make_addon_menhirlib
1764	1767	installer_addon_dependency_end
	1768	# Temporary hack for 8.11. See ci-basic-overlays.h
	1769	compcert_CI_REF=v3.6
1765	1770	if build_prep_overlay compcert; then
1766	1771	installer_addon_section compcert "CompCert" "ATTENTION: THIS IS NOT OPEN SOURCE! CompCert verified C compiler and Clightgen (required for using VST for your own code)" "off"
1767	1772	logn configure ./configure -ignore-coq-version -clightgen -prefix "$PREFIXCOQ" -coqdevdir "$PREFIXCOQ/lib/coq/user-contrib/compcert" x86_32-cygwin

1919	1924	logn autogen ./autogen.sh
1920	1925	logn configure ./configure
1921	1926	logn remake ./remake --jobs=$MAKE_THREADS
	1927	logn remake_check ./remake --jobs=$MAKE_THREADS check
1922	1928	logn install ./remake install
1923	1929	build_post
1924	1930	fi

+148

-0

dev/build/windows/patches_coq/compcert-v3.6.patch less more

	0	diff --git a/backend/Inliningproof.v b/backend/Inliningproof.v
	1	index 181f40bf..cc84b1cc 100644
	2	--- a/backend/Inliningproof.v
	3	+++ b/backend/Inliningproof.v
	4	@@ -744,7 +744,7 @@ Lemma match_stacks_free_right:
	5	match_stacks F m m1' stk stk' sp.
	6	Proof.
	7	intros. eapply match_stacks_invariant; eauto.
	8	- intros. eapply Mem.perm_free_1; eauto.
	9	+ intros. eapply Mem.perm_free_1; eauto with ordered_type.
	10	intros. eapply Mem.perm_free_3; eauto.
	11	Qed.
	12
	13	@@ -1043,7 +1043,7 @@ Proof.
	14	eapply match_stacks_bound with (bound := sp').
	15	eapply match_stacks_invariant; eauto.
	16	intros. eapply Mem.perm_free_3; eauto.
	17	- intros. eapply Mem.perm_free_1; eauto.
	18	+ intros. eapply Mem.perm_free_1; eauto with ordered_type.
	19	intros. eapply Mem.perm_free_3; eauto.
	20	erewrite Mem.nextblock_free; eauto. red in VB; xomega.
	21	eapply agree_val_regs; eauto.
	22	@@ -1135,7 +1135,7 @@ Proof.
	23	eapply match_stacks_bound with (bound := sp').
	24	eapply match_stacks_invariant; eauto.
	25	intros. eapply Mem.perm_free_3; eauto.
	26	- intros. eapply Mem.perm_free_1; eauto.
	27	+ intros. eapply Mem.perm_free_1; eauto with ordered_type.
	28	intros. eapply Mem.perm_free_3; eauto.
	29	erewrite Mem.nextblock_free; eauto. red in VB; xomega.
	30	destruct or; simpl. apply agree_val_reg; auto. auto.
	31	@@ -1182,7 +1182,7 @@ Proof.
	32	subst b1. rewrite D in H8; inv H8. eelim Plt_strict; eauto.
	33	intros. eapply Mem.perm_alloc_1; eauto.
	34	intros. exploit Mem.perm_alloc_inv. eexact A. eauto.
	35	- rewrite dec_eq_false; auto.
	36	+ rewrite dec_eq_false; auto with ordered_type.
	37	auto. auto. auto. eauto. auto.
	38	rewrite H5. apply agree_regs_init_regs. eauto. auto. inv H1; auto. congruence. auto.
	39	eapply Mem.valid_new_block; eauto.
	40	diff --git a/backend/ValueAnalysis.v b/backend/ValueAnalysis.v
	41	index 8dbb67a7..2b233900 100644
	42	--- a/backend/ValueAnalysis.v
	43	+++ b/backend/ValueAnalysis.v
	44	@@ -1148,10 +1148,10 @@ Proof.
	45	- constructor.
	46	- assert (Plt sp bound') by eauto with va.
	47	eapply sound_stack_public_call; eauto. apply IHsound_stack; intros.
	48	- apply INV. xomega. rewrite SAME; auto. xomega. auto. auto.
	49	+ apply INV. xomega. rewrite SAME; auto with ordered_type. xomega. auto. auto.
	50	- assert (Plt sp bound') by eauto with va.
	51	eapply sound_stack_private_call; eauto. apply IHsound_stack; intros.
	52	- apply INV. xomega. rewrite SAME; auto. xomega. auto. auto.
	53	+ apply INV. xomega. rewrite SAME; auto with ordered_type. xomega. auto. auto.
	54	apply bmatch_ext with m; auto. intros. apply INV. xomega. auto. auto. auto.
	55	Qed.
	56
	57	@@ -1362,7 +1362,7 @@ Proof.
	58	apply sound_stack_exten with bc.
	59	apply sound_stack_inv with m. auto.
	60	intros. apply Q. red. eapply Plt_trans; eauto.
	61	- rewrite C; auto.
	62	+ rewrite C; auto with ordered_type.
	63	exact AA.
	64	* (* public builtin call *)
	65	exploit anonymize_stack; eauto.
	66	@@ -1381,7 +1381,7 @@ Proof.
	67	apply sound_stack_exten with bc.
	68	apply sound_stack_inv with m. auto.
	69	intros. apply Q. red. eapply Plt_trans; eauto.
	70	- rewrite C; auto.
	71	+ rewrite C; auto with ordered_type.
	72	exact AA.
	73	}
	74	unfold transfer_builtin in TR.
	75	diff --git a/lib/Heaps.v b/lib/Heaps.v
	76	index 9fa07a1d..85343998 100644
	77	--- a/lib/Heaps.v
	78	+++ b/lib/Heaps.v
	79	@@ -256,14 +256,14 @@ Proof.
	80	eapply gt_heap_trans with y; eauto. red; auto.
	81	- intuition.
	82	eapply lt_heap_trans; eauto. red; auto.
	83	- eapply gt_heap_trans; eauto. red; auto.
	84	+ eapply gt_heap_trans; eauto. red; auto with ordered_type.
	85	- intuition. eapply gt_heap_trans; eauto. red; auto.
	86	- rewrite e3 in ; simpl in . intuition.
	87	eapply lt_heap_trans with y; eauto. red; auto.
	88	eapply gt_heap_trans; eauto. red; auto.
	89	- intuition.
	90	eapply lt_heap_trans with y; eauto. red; auto.
	91	- eapply gt_heap_trans; eauto. red; auto.
	92	+ eapply gt_heap_trans; eauto. red; auto with ordered_type.
	93	eapply gt_heap_trans with x; eauto. red; auto.
	94	- rewrite e3 in ; simpl in ; intuition.
	95	eapply gt_heap_trans; eauto. red; auto.
	96	@@ -308,7 +308,7 @@ Proof.
	97	intros. unfold insert.
	98	case_eq (partition x h). intros a b EQ; simpl.
	99	assert (E.eq y x \/ ~E.eq y x).
	100	- destruct (E.compare y x); auto.
	101	+ destruct (E.compare y x); auto with ordered_type.
	102	right; red; intros. elim (E.lt_not_eq l). apply E.eq_sym; auto.
	103	destruct H0.
	104	tauto.
	105	diff --git a/lib/Ordered.v b/lib/Ordered.v
	106	index bcf24cbd..1adbd330 100644
	107	--- a/lib/Ordered.v
	108	+++ b/lib/Ordered.v
	109	@@ -21,6 +21,8 @@ Require Import Coqlib.
	110	Require Import Maps.
	111	Require Import Integers.
	112
	113	+Create HintDb ordered_type.
	114	+
	115	(** The ordered type of positive numbers *)
	116
	117	Module OrderedPositive <: OrderedType.
	118	@@ -173,17 +175,17 @@ Definition eq (x y: t) :=
	119
	120	Lemma eq_refl : forall x : t, eq x x.
	121	Proof.
	122	- intros; split; auto.
	123	+ intros; split; auto with ordered_type.
	124	Qed.
	125
	126	Lemma eq_sym : forall x y : t, eq x y -> eq y x.
	127	Proof.
	128	- unfold eq; intros. intuition auto.
	129	+ unfold eq; intros. intuition auto with ordered_type.
	130	Qed.
	131
	132	Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
	133	Proof.
	134	- unfold eq; intros. intuition eauto.
	135	+ unfold eq; intros. intuition eauto with ordered_type.
	136	Qed.
	137
	138	Definition lt (x y: t) :=
	139	@@ -201,7 +203,7 @@ Proof.
	140	case (A.compare (fst x) (fst z)); intro.
	141	assumption.
	142	generalize (A.lt_not_eq H2); intro. elim H5.
	143	- apply A.eq_trans with (fst z). auto. auto.
	144	+ apply A.eq_trans with (fst z). auto. auto with ordered_type.
	145	generalize (@A.lt_not_eq (fst z) (fst y)); intro.
	146	elim H5. apply A.lt_trans with (fst x); auto.
	147	apply A.eq_sym; auto.

-18

~~dev/build/windows/patches_coq/gappa_plugin.patch~~ less more

0		diff/patch file created on Wed, Dec 4, 2019 11:47:42 AM with:
1		difftar-folder.sh tarballs/gappa_plugin-07b2a6e39256b33f6b0b9f89c1e880dae51f740a.tar.gz gappa_plugin-07b2a6e39256b33f6b0b9f89c1e880dae51f740a 1
2		TARFILE= tarballs/gappa_plugin-07b2a6e39256b33f6b0b9f89c1e880dae51f740a.tar.gz
3		FOLDER= gappa_plugin-07b2a6e39256b33f6b0b9f89c1e880dae51f740a
4		TARSTRIP= 1
5		TARPREFIX= coq-07b2a6e39256b33f6b0b9f89c1e880dae51f740a/
6		ORIGFOLDER= gappa_plugin-07b2a6e39256b33f6b0b9f89c1e880dae51f740a.orig
7		--- gappa_plugin-07b2a6e39256b33f6b0b9f89c1e880dae51f740a.orig/src/Gappa_tactic.v 2019-07-17 13:48:30.000000000 +0200
8		+++ gappa_plugin-07b2a6e39256b33f6b0b9f89c1e880dae51f740a/src/Gappa_tactic.v 2019-12-04 11:46:40.621036000 +0100
9		@@ -1136,7 +1136,7 @@
10		trLeaf change_format_func change_format_prop ::
11		trLeaf remove_unknown_func remove_unknown_prop ::
12		trTree simplify_tree simplify_tree_correct ::
13		- nil.
14		+ List.nil.
15
16		Theorem prepare_goal :
17		forall uv t,

-52

dev/build/windows/patches_coq/interval.patch less more

0		diff/patch file created on Tue, Dec 3, 2019 8:33:46 PM with:
	0	diff/patch file created on Fri, Dec 20, 2019 6:11:49 PM with:
1	1	difftar-folder.sh tarballs/interval-839a03e1bddbafab868fbceee59abe678e32a0f3.tar.gz interval-839a03e1bddbafab868fbceee59abe678e32a0f3 1
2	2	TARFILE= tarballs/interval-839a03e1bddbafab868fbceee59abe678e32a0f3.tar.gz
3	3	FOLDER= interval-839a03e1bddbafab868fbceee59abe678e32a0f3

5	5	TARPREFIX= interval-839a03e1bddbafab868fbceee59abe678e32a0f3/
6	6	ORIGFOLDER= interval-839a03e1bddbafab868fbceee59abe678e32a0f3.orig
7	7	--- interval-839a03e1bddbafab868fbceee59abe678e32a0f3.orig/src/Integral/Bertrand.v 2019-07-20 09:48:54.000000000 +0200
8		+++ interval-839a03e1bddbafab868fbceee59abe678e32a0f3/src/Integral/Bertrand.v 2019-12-03 15:47:02.749603700 +0100
	8	+++ interval-839a03e1bddbafab868fbceee59abe678e32a0f3/src/Integral/Bertrand.v 2019-12-20 15:10:07.777216000 +0100
9	9	@@ -1,6 +1,6 @@
10	10	From Coq Require Import Reals ZArith Psatz Fourier_util.
11	11	From Coquelicot Require Import Coquelicot AutoDerive.

33	33	- apply: (is_RInt_ext (fun t : R => plus (scal (f' t) (g t)) (scal (f t) (g' t)))) =>[x Hx\|].
34	34	by [].
35	35	--- interval-839a03e1bddbafab868fbceee59abe678e32a0f3.orig/src/Integral/Integral.v 2019-07-20 09:48:54.000000000 +0200
36		+++ interval-839a03e1bddbafab868fbceee59abe678e32a0f3/src/Integral/Integral.v 2019-12-03 15:53:17.343170000 +0100
	36	+++ interval-839a03e1bddbafab868fbceee59abe678e32a0f3/src/Integral/Integral.v 2019-12-20 15:10:07.780217100 +0100
37	37	@@ -242,7 +242,7 @@
38	38	exact: Rlt_le.
39	39	apply: Rplus_le_compat_r.

52	52	move: (H _ _ Qbu2 Qbv2) => /= .
53	53	move => /(_ _ HC) Hle.
54	54	apply: Rle_lt_trans Hle _.
55		--- interval-839a03e1bddbafab868fbceee59abe678e32a0f3.orig/src/Interval/Eval.v 2019-07-20 09:48:54.000000000 +0200
56		+++ interval-839a03e1bddbafab868fbceee59abe678e32a0f3/src/Interval/Eval.v 2019-12-03 15:55:33.037225800 +0100
57		@@ -62,8 +62,10 @@
58		now rewrite !IH; case no_floor_term; simpl; case no_floor_term; simpl.
59		Qed.
60
61		+Locate nil.
62		+
63		Lemma no_floor_prog_rcons t prog :
64		- no_floor_prog (prog ++ (t :: nil)) = no_floor_term t && no_floor_prog prog.
65		+ no_floor_prog (prog ++ (t :: List.nil)) = no_floor_term t && no_floor_prog prog.
66		Proof.
67		unfold no_floor_prog.
68		generalize true.
69	55	--- interval-839a03e1bddbafab868fbceee59abe678e32a0f3.orig/src/Missing/Coquelicot.v 2019-07-20 09:48:54.000000000 +0200
70		+++ interval-839a03e1bddbafab868fbceee59abe678e32a0f3/src/Missing/Coquelicot.v 2019-12-03 14:55:15.821078400 +0100
	56	+++ interval-839a03e1bddbafab868fbceee59abe678e32a0f3/src/Missing/Coquelicot.v 2019-12-20 15:10:07.787214200 +0100
71	57	@@ -1,10 +1,13 @@
72	58	From Coq Require Import Reals Psatz.
73	59	From Coquelicot Require Import Coquelicot.

93	79	rewrite /minus.
94	80	apply: (filterlim_comp _ _ _ (fun x => opp (exp (-(lam * x)) / lam)) (fun x => plus (exp (- (lam * a)) / lam) x) (Rbar_locally p_infty) (locally (0)) (locally (exp (- (lam * a)) / lam))); last first.
95	81	--- interval-839a03e1bddbafab868fbceee59abe678e32a0f3.orig/src/Poly/Datatypes.v 2019-07-20 09:48:54.000000000 +0200
96		+++ interval-839a03e1bddbafab868fbceee59abe678e32a0f3/src/Poly/Datatypes.v 2019-12-03 15:42:40.401690500 +0100
	82	+++ interval-839a03e1bddbafab868fbceee59abe678e32a0f3/src/Poly/Datatypes.v 2019-12-20 15:10:07.791212700 +0100
97	83	@@ -22,7 +22,7 @@
98	84
99	85	From Coq Require Import ZArith Reals.

133	119	nth (deriv tt p) i = (nth p i.+1 * INR i.+1)%R.
134	120	Proof.
135	121	--- interval-839a03e1bddbafab868fbceee59abe678e32a0f3.orig/src/Poly/Taylor_model_sharp.v 2019-07-20 09:48:54.000000000 +0200
136		+++ interval-839a03e1bddbafab868fbceee59abe678e32a0f3/src/Poly/Taylor_model_sharp.v 2019-12-03 15:49:16.232514700 +0100
	122	+++ interval-839a03e1bddbafab868fbceee59abe678e32a0f3/src/Poly/Taylor_model_sharp.v 2019-12-20 15:10:07.794210100 +0100
137	123	@@ -23,7 +23,7 @@
138	124	From Coq Require Import ZArith Psatz Reals.
139	125	From Flocq Require Import Raux.

152	138	(********************************************************************)
153	139	(** This theory implements Taylor models with interval polynomials for
154	140	univariate real-valued functions. The implemented algorithms rely
155		--- interval-839a03e1bddbafab868fbceee59abe678e32a0f3.orig/src/Tactic.v 2019-07-20 09:48:54.000000000 +0200
156		+++ interval-839a03e1bddbafab868fbceee59abe678e32a0f3/src/Tactic.v 2019-12-03 20:07:43.622177800 +0100
157		@@ -1992,9 +1992,9 @@
158		Qed.
159
160		Lemma interval_helper_bisection :
161		- forall bounds check formula prec depth n,
162		+ forall (bounds:list A.bound_proof) check formula prec depth n,
163		match bounds with
164		- \| cons (A.Bproof _ (Float.Ibnd l u) _) tail =>
165		+ \| List.cons (A.Bproof _ (Float.Ibnd l u) _) tail =>
166		let fi := fun b => nth n (A.BndValuator.eval prec formula (b :: map A.interval_from_bp tail)) I.nai in
167		A.bisect_1d l u (fun b => A.check_f check (fi b)) depth = true
168		\| _ => False
169		@@ -2016,7 +2016,7 @@
170		Lemma interval_helper_bisection_diff :
171		forall bounds check formula prec depth n,
172		match bounds with
173		- \| cons (A.Bproof _ (Float.Ibnd l u) _) tail =>
174		+ \| List.cons (A.Bproof _ (Float.Ibnd l u) _) tail =>
175		let fi := fun b => A.DiffValuator.eval prec formula (map A.interval_from_bp tail) n b in
176		A.bisect_1d l u (fun b => A.check_f check (fi b)) depth = true
177		\| _ => False
178		@@ -2038,7 +2038,7 @@
179		Lemma interval_helper_bisection_taylor :
180		forall bounds check formula prec deg depth n,
181		match bounds with
182		- \| cons (A.Bproof _ (Float.Ibnd l u) _) tail =>
183		+ \| List.cons (A.Bproof _ (Float.Ibnd l u) _) tail =>
184		let fi := fun b => A.TaylorValuator.TM.eval (prec, deg)
185		(nth n (A.TaylorValuator.eval prec deg b formula (A.TaylorValuator.TM.var ::
186		map (fun b => A.TaylorValuator.TM.const (A.interval_from_bp b)) tail)) A.TaylorValuator.TM.dummy) b b in

+301

-22

dev/ci/ci-basic-overlay.sh less more

8	8	########################################################################
9	9	# MathComp
10	10	########################################################################
11		: "${mathcomp_CI_REF:=8187ed3b12da2c164f1fc90c634b4330b796ab44}"
	11
	12	# Picking:
	13	#
	14	# Before picking this was on 8187ed3b12da2c164f1fc90c634b4330b796ab44
	15	# = Nov 29 2019 master
	16	# "Return of PR #226: adds relevant theorems when fcycle f (orbit f x) a…"
	17	# - The tag mathcomp-1.10.0 contains only one further editorial commit
	18	#
	19	# There are no Coq version specific tags or branches
	20	#
	21	# The latest tag is mathcomp-1.10.0 from Nov 29 2019
	22	# - This tag works with Coq 8.11 and it is not older than 6 months.
	23	#
	24	# => Use tag mathcomp-1.10.0
	25
	26	: "${mathcomp_CI_REF:=mathcomp-1.10.0}"
12	27	: "${mathcomp_CI_GITURL:=https://github.com/math-comp/math-comp}"
13	28	: "${mathcomp_CI_ARCHIVEURL:=${mathcomp_CI_GITURL}/archive}"
14	29

30	45	########################################################################
31	46	# Unicoq + Mtac2
32	47	########################################################################
	48
	49	# Picking:
	50	#
	51	# Before picking this was on c33e66c8f2924449c7b98aab108d97b5ee105bab
	52	# = Nov 4 2019 master
	53	# "Merge pull request #28 from validsdp/primitive-floats"
	54	# - This commit seems to be required for 8.11 since primitive floats are included in 8.11
	55	#
	56	# There are no 8.11 specific tags or branches
	57	# - there are 8.10 tags and branches => request tag
	58	#
	59	# The latest 8.10 tag v1.3.2-8.10
	60	# - has just 5 commit from Jan 2 2020 since Mar 15 2019
	61	# - does not include a port of the commit used before picking
	62	# => looks old
	63	#
	64	# The commits on master beyond c33e66c look like adoptions to changes not in 8.11
	65	#
	66	# => Continue to use c33e66c8f2924449c7b98aab108d97b5ee105bab from Nov 4 2019
	67	# => Ask upstream to tag this as 8.11.0
	68
33	69	: "${unicoq_CI_REF:=c33e66c8f2924449c7b98aab108d97b5ee105bab}"
34	70	: "${unicoq_CI_GITURL:=https://github.com/unicoq/unicoq}"
35	71	: "${unicoq_CI_ARCHIVEURL:=${unicoq_CI_GITURL}/archive}"
36	72
37		: "${mtac2_CI_REF:=master-8.11}"
	73	# Picking:
	74	#
	75	# Before picking this was on master-8.11
	76	# = (as of Jan 13 2020)
	77	# Nov 4 2019 006dc6966348c54da212d015a61773c2b2a5e921
	78	# "Force Coq#8.11 branch in CI."
	79	# - This is the latest commit on master-8.11 as of Jan 13 2020
	80	#
	81	# => Choose latest commit on master-8.11
	82	# => Ask upstream to tag this as 8.11.0
	83
	84	: "${mtac2_CI_REF:=006dc6966348c54da212d015a61773c2b2a5e921}"
38	85	: "${mtac2_CI_GITURL:=https://github.com/Mtac2/Mtac2}"
39	86	: "${mtac2_CI_ARCHIVEURL:=${mtac2_CI_GITURL}/archive}"
40	87

89	136	########################################################################
90	137	# Flocq
91	138	########################################################################
92		: "${Flocq_CI_REF:=7076cd30f4409b72b7bf852bf6a935eb60ca29b4}"
93		: "${Flocq_CI_GITURL:=https://gitlab.inria.fr/flocq/flocq}"
94		: "${Flocq_CI_ARCHIVEURL:=${Flocq_CI_GITURL}/-/archive}"
	139
	140	# Picking
	141	#
	142	# Before picking this was on 7076cd30f4409b72b7bf852bf6a935eb60ca29b4
	143	# = Nov 19 2019 master
	144	# "Use standard macros for checking versions."
	145	#
	146	# There are no Coq version specific tags or branches
	147	#
	148	# The latest tag is flocq-3.2.0 from July 17 2019
	149	# - This tag works with Coq 8.11 and it is not older than 6 months.
	150	#
	151	# => Use tag flocq-3.2.0
	152	#
	153	# The linked commit is 3.2.0 plus a patch for Gappa
	154
	155	: "${Flocq_CI_REF:=66482a0775e39770dde8bebc4c896d8d47980e1a}"
	156	: "${Flocq_CI_GITURL:=https://github.com/MSoegtropIMC/flocq}"
	157	: "${Flocq_CI_ARCHIVEURL:=${Flocq_CI_GITURL}/archive}"
	158
	159	# Original source is
	160	# : "${Flocq_CI_GITURL:=https://gitlab.inria.fr/flocq/flocq}"
	161	# : "${Flocq_CI_ARCHIVEURL:=${Flocq_CI_GITURL}/-/archive}"
95	162
96	163	########################################################################
97	164	# Coquelicot
98	165	########################################################################
99		: "${coquelicot_CI_REF:=155e88c47e3793f1f2c4118bc1d4520abe780d74}"
100		: "${coquelicot_CI_GITURL:=https://gitlab.inria.fr/coquelicot/coquelicot}"
101		: "${coquelicot_CI_ARCHIVEURL:=${coquelicot_CI_GITURL}/-/archive}"
	166
	167	# Picking
	168	#
	169	# Before picking this was on 155e88c47e3793f1f2c4118bc1d4520abe780d74
	170	# = Aug 19 2019 master
	171	# "Update URL."
	172	#
	173	# There are no Coq version specific tags or branches
	174	#
	175	# The latest tag is coquelicot-3.0.3 from Aug 19 2019
	176	# - This tag works with Coq 8.11 and it is not older than 6 months.
	177	#
	178	# The only change on master after 3.0.3 is the pre-pick commit
	179	# - This commit is purely editorial and helps to follow the examples
	180	# (the URL for the exercises solved in the sample was inaccessible)
	181	#
	182	# The next commit after this on master is about coq-native libraries
	183	# - This is currently not supportes on WIndows the main target of the picking
	184	#
	185	# A change was require to adjust to PR #11398 Rlist hides standard list constructors cons and nil
	186	#
	187	# => Use coquelicot-3.0.3 + URL fix + fix for RList
	188	# => Ask upstream about opinion for a new tag
	189
	190	: "${coquelicot_CI_REF:=1ec80657ce992fc5aa660dca86d423671f02e33c}"
	191	: "${coquelicot_CI_GITURL:=https://github.com/MSoegtropIMC/coquelicot}"
	192	: "${coquelicot_CI_ARCHIVEURL:=${coquelicot_CI_GITURL}/archive}"
	193
	194	# Original source is
	195	# : "${coquelicot_CI_GITURL:=https://gitlab.inria.fr/coquelicot/coquelicot}"
	196	# : "${coquelicot_CI_ARCHIVEURL:=${coquelicot_CI_GITURL}/-/archive}"
102	197
103	198	########################################################################
104	199	# Coq-interval
105	200	########################################################################
	201
	202	# Picking
	203	#
	204	# Before picking this was on 839a03e1bddbafab868fbceee59abe678e32a0f3
	205	# = Jul 20 2019 master
	206	# "Avoid uncontrolled characters (e.g., 'C:/') as arguments to $(addprefix)."
	207	#
	208	# There are no Coq version specific tags or branches
	209	#
	210	# The latest tag is interval-3.4.1 from "5 months ago"
	211	# - This tag does not compile with Coq 8.11 mostly cause of library incompatibilities
	212	#
	213	# The hash 839a03e1bddbafab868fbceee59abe678e32a0f3 has been patched to work with 8.11
	214	# - This combination has been tested quite a bit during tests for #11321
	215	# - The same patch does not work for the latest commit on
	216	# master ec99901a45b1acba137a3e0e4230289b4fe9553f
	217	#
	218	# => Use commit 839a03e1bddbafab868fbceee59abe678e32a0f3
	219
106	220	: "${interval_CI_REF:=839a03e1bddbafab868fbceee59abe678e32a0f3}"
107	221	: "${interval_CI_GITURL:=https://gitlab.inria.fr/coqinterval/interval}"
108	222	: "${interval_CI_ARCHIVEURL:=${interval_CI_GITURL}/-/archive}"

110	224	########################################################################
111	225	# Gappa stand alone tool
112	226	########################################################################
	227
	228	# Picking
	229	#
	230	# Before picking this was on f53e105cd73484fc76eb58ba24ead73be502c608
	231	# = Jun 17 2019 master
	232	# "Fix outdated documentation."
	233	# - This is the latest commit on master
	234	#
	235	# There are no Coq version specific tags or branches
	236	#
	237	# The latest tag is gappa-1.3.5 from May 24 2019 which is more than 6 months old
	238	#
	239	# 8.11 beta has been done with f53e105 (latest on master as of Jan 13 2020)
	240	#
	241	# => use f53e105cd73484fc76eb58ba24ead73be502c608
	242
113	243	: "${gappa_tool_CI_REF:=f53e105cd73484fc76eb58ba24ead73be502c608}"
114	244	: "${gappa_tool_CI_GITURL:=https://gitlab.inria.fr/gappa/gappa}"
115	245	: "${gappa_tool_CI_ARCHIVEURL:=${gappa_tool_CI_GITURL}/-/archive}"

117	247	########################################################################
118	248	# Gappa plugin
119	249	########################################################################
120		: "${gappa_plugin_CI_REF:=07b2a6e39256b33f6b0b9f89c1e880dae51f740a}"
121		: "${gappa_plugin_CI_GITURL:=https://gitlab.inria.fr/gappa/coq}"
122		: "${gappa_plugin_CI_ARCHIVEURL:=${gappa_plugin_CI_GITURL}/-/archive}"
	250
	251	# Picking
	252	#
	253	# Before picking this was on 07b2a6e39256b33f6b0b9f89c1e880dae51f740a
	254	# = Jun 17 2019 master
	255	# "New release."
	256	# - This is the latest commit on master
	257	#
	258	# There are no Coq version specific tags or branches
	259	#
	260	# The latest tag is gappalib-coq-1.4.2
	261	# - this is the same thing as 07b2a6e and the latest commit on master
	262	# - It does not work with Coq 8.11 (compiles but does not run)
	263	#
	264	# => Use tag gappalib-coq-1.4.2 + patch for Coq 8.11
	265
	266	: "${gappa_plugin_CI_REF:=d6f5177181c35f07ff50bd5c173ee13528e06576}"
	267	: "${gappa_plugin_CI_GITURL:=https://github.com/MSoegtropIMC/gappa-coq}"
	268	: "${gappa_plugin_CI_ARCHIVEURL:=${gappa_plugin_CI_GITURL}/archive}"
	269
	270	# Original source is
	271	# : "${gappa_plugin_CI_GITURL:=https://gitlab.inria.fr/gappa/coq}"
	272	# : "${gappa_plugin_CI_ARCHIVEURL:=${gappa_plugin_CI_GITURL}/-/archive}"
123	273
124	274	########################################################################
125	275	# CompCert
126	276	########################################################################
	277
	278	# Picking:
	279	#
	280	# Before picking this was on a99406bbd9c01dc04e79b14681a254fe22c9d424
	281	# = Nov 28 2019 master
	282	# "Fix for AArch64 alignment problem"
	283	#
	284	# There are no Coq version specific tags or branches
	285	#
	286	# The latest tag is v3.6 from Sep 17 2019
	287	# - This tag does not work with 8.11
	288	# - There is a specific compatibility commit b7374d2 from Oct 2 2019
	289	#
	290	# => Use tag v3.6 with a patch which cherry picks b7374d2
	291	# The cherry picking is done via patch dev/build/windows/patches_coq/compcert-v3.6.patch
	292	# Since CI does not support patches or cherry picking, CI is set to what it was and
	293	# compcert_CI_REF is overriden in the windows build script
	294
127	295	: "${compcert_CI_REF:=a99406bbd9c01dc04e79b14681a254fe22c9d424}"
128	296	: "${compcert_CI_GITURL:=https://github.com/AbsInt/CompCert}"
129	297	: "${compcert_CI_ARCHIVEURL:=${compcert_CI_GITURL}/archive}"

131	299	########################################################################
132	300	# VST
133	301	########################################################################
134		: "${vst_CI_REF:=a04b451b3ef9fd99007115f7745713f6fc84d1dc}"
	302
	303	# Picking:
	304	#
	305	# Before picking this was on a04b451b3ef9fd99007115f7745713f6fc84d1dc
	306	# = Nov 26 2019 master
	307	# "Update submodules"
	308	#
	309	# There are no Coq version specific tags or branches
	310	#
	311	# The latest tag is v2.5 from Jan 13 2020
	312	#
	313	# => Use tag v2.5
	314
	315	: "${vst_CI_REF:=v2.5}"
135	316	: "${vst_CI_GITURL:=https://github.com/PrincetonUniversity/VST}"
136	317	: "${vst_CI_ARCHIVEURL:=${vst_CI_GITURL}/archive}"
137	318

178	359	: "${color_CI_ARCHIVEURL:=${color_CI_GITURL}/archive}"
179	360
180	361	########################################################################
181		# SF
182		########################################################################
183		: "${sf_lf_CI_TARURL:=https://softwarefoundations.cis.upenn.edu/lf-current/lf.tgz}"
184		: "${sf_plf_CI_TARURL:=https://softwarefoundations.cis.upenn.edu/plf-current/plf.tgz}"
185		: "${sf_vfa_CI_TARURL:=https://softwarefoundations.cis.upenn.edu/vfa-current/vfa.tgz}"
186
187		########################################################################
188	362	# TLC
189	363	########################################################################
190	364	: "${tlc_CI_REF:=3a77d66bde6fe9365c7452f082d6fb34d044c771}"

194	368	########################################################################
195	369	# Bignums
196	370	########################################################################
197		: "${bignums_CI_REF:=v8.11}"
	371
	372	# Picking:
	373	#
	374	# Before picking this was on v8.11
	375	# = (as of Jan 13 2020)
	376	# Nov 21 2019 c23738415e814257bd14b009c27a27e7579917bc
	377	# "Merge pull request #30 from ejgallego/v8.11+back_to_dune"
	378	# - This is the latest commit on v8.11 as of Jan 13 2020
	379	#
	380	# => Choose latest commit on master-8.11
	381	# => Ask upstream to tag this as 8.11.0
	382
	383	: "${bignums_CI_REF:=c23738415e814257bd14b009c27a27e7579917bc}"
198	384	: "${bignums_CI_GITURL:=https://github.com/coq/bignums}"
199	385	: "${bignums_CI_ARCHIVEURL:=${bignums_CI_GITURL}/archive}"
200	386

208	394	########################################################################
209	395	# Equations
210	396	########################################################################
	397
	398	# Picking:
	399	#
	400	# Before picking this was on b593e3734f01c6f9c05987e4af593d2712025ae3
	401	# = Nov 5 2019 master
	402	# "Fix Make dependencies of test-suite and examples" on master
	403	#
	404	# There are no 8.11 specific tags or branches
	405	# - there are Coq version specific tags and branches => request tag
	406	#
	407	# The latest tag is v1.2.1-8.10-2
	408	# - it includes a backport of b593e37 (25bed60) and a few more changes.
	409	# - it does NOT compile with Coq 8.11
	410	#
	411	# Choosing b593e37 seems to be arbitrary (latest on master on that day)
	412	# - still 8.11 beta was done with this pick, so keep it.
	413	# - it compiles bot does not work with 8.11 (issues with installation)
	414	#
	415	# Latest master as of Jan 17 2020 is a13f2993f93d41d0cbd3a94e0bb18f927e5913ae
	416	# - does not build with Coq 8.11
	417	#
	418	# => Choose b593e3734f01c6f9c05987e4af593d2712025ae3
	419	# => Hack make_addon_equations in makecoq_mingw.sh to work around the installation issues
	420	# => TODO: remove this hack if a proper picking is found
	421	# => Ask upstream to tag this as 8.11.0
	422
211	423	: "${equations_CI_REF:=b593e3734f01c6f9c05987e4af593d2712025ae3}"
212	424	: "${equations_CI_GITURL:=https://github.com/mattam82/Coq-Equations}"
213	425	: "${equations_CI_ARCHIVEURL:=${equations_CI_GITURL}/archive}"

229	441	########################################################################
230	442	# ext-lib
231	443	########################################################################
232		: "${ext_lib_CI_REF:=341323ab3ba1a4941d0944c99fc951b54294f9a7}"
	444
	445	# Picking:
	446	#
	447	# Before picking this was on 341323ab3ba1a4941d0944c99fc951b54294f9a7
	448	# = Nov 22 2019 master
	449	# "[ci skip] update template"
	450	# This is NOT the latest commit on master
	451	#
	452	# There are no 8.11 specific tags or branches
	453	# - there are Coq version branches up to 8.9 but no tags
	454	#
	455	# The latest tag is v0.10.3 from Oct 17 2029
	456	# - this tag works with 8.11 and is not older than 6 months
	457	#
	458	# => Use latest tag
	459
	460	: "${ext_lib_CI_REF:=v0.10.3}"
233	461	: "${ext_lib_CI_GITURL:=https://github.com/coq-ext-lib/coq-ext-lib}"
234	462	: "${ext_lib_CI_ARCHIVEURL:=${ext_lib_CI_GITURL}/archive}"
235	463

243	471	########################################################################
244	472	# quickchick
245	473	########################################################################
	474
	475	# Picking:
	476	#
	477	# Before picking this was on 581d839e7ae989dae311e2669aa2527e6601253f
	478	# = Aug 23 2019 master
	479	# "Merge pull request #178 from ejgallego/api+varkind"
	480	# This is NOT the latest commit on master
	481	# This is behind the latest commit on the 8.10 branch
	482	#
	483	# There are no 8.11 specific tags or branches
	484	# - there are Coq version branches up to 8.10 but tags only up to 8.7
	485	#
	486	# The latest tag is v1.1.0 from Apr 12 2020
	487	# - this tag is older than 6 months and far behind the 8.10 branch
	488	#
	489	# The latest commit on 8.10 branch is
	490	# = Dec 8 2019 1d00ecf673b370cc1fde4bb9c23ba13d4404b0bd
	491	# "fix STLC example"
	492	# - This does not work with Coq 8.11
	493	#
	494	# Use 581d839e7ae989dae311e2669aa2527e6601253f because
	495	# - it seems to be a Coq specific fix (comes from Coq team)
	496	# - it was used during 8.11 beta
	497	#
	498	# => Use 581d839e7ae989dae311e2669aa2527e6601253f
	499	# => Ask upstream to create a tag (either on this or something newer)
	500
246	501	: "${quickchick_CI_REF:=581d839e7ae989dae311e2669aa2527e6601253f}"
247	502	: "${quickchick_CI_GITURL:=https://github.com/QuickChick/QuickChick}"
248	503	: "${quickchick_CI_ARCHIVEURL:=${quickchick_CI_GITURL}/archive}"

250	505	########################################################################
251	506	# menhirlib
252	507	########################################################################
	508
	509	# Picking:
	510	#
	511	# Before picking this was on ca0655b2f96057a271fb5c9a254a38d195b4a7f9
	512	# = Feb 14 2019 master
	513	# "Axiom-free development, the interpreter should evaluate inside Coq with reasonnable performance.
	514	# This is the latest commit on master
	515	#
	516	# There are no Coq version specific tags or branches
	517	#
	518	# => Choose this commit (we also had it in 8.10)
	519	# => Ask upstream to create library tags since we used this untagged commit since a while
	520
253	521	: "${menhirlib_CI_REF:=ca0655b2f96057a271fb5c9a254a38d195b4a7f9}"
254	522	: "${menhirlib_CI_GITURL:=https://gitlab.inria.fr/fpottier/coq-menhirlib}"
255	523	: "${menhirlib_CI_ARCHIVEURL:=${menhirlib_CI_GITURL}/-/archive}"

257	525	########################################################################
258	526	# aac_tactics
259	527	########################################################################
260		: "${aac_tactics_CI_REF:=c57960afb0c9702a8c3c12aec26534e3495bbde9}"
	528
	529	# Picking:
	530	#
	531	# Before picking this was on c57960afb0c9702a8c3c12aec26534e3495bbde9
	532	# = Nov 6 2019 v8.11
	533	# Merge pull request #51 from vbgl/noomega "
	534	# - This is the latest commit on v8.11 as of Jan 13 2020
	535	#
	536	# => Choose latest commit on v8.11
	537	# => Ask upstream to tag this as 8.11.0
	538
	539	: "${aac_tactics_CI_REF:=c10b948e296e2550ecacf09770da6896549299d4}"
261	540	: "${aac_tactics_CI_GITURL:=https://github.com/coq-community/aac-tactics}"
262	541	: "${aac_tactics_CI_ARCHIVEURL:=${aac_tactics_CI_GITURL}/archive}"
263	542

+15

-4

dev/ci/ci-sf.sh less more

2	2	ci_dir="$(dirname "$0")"
3	3	. "${ci_dir}/ci-common.sh"
4	4
5		mkdir -p "${CI_BUILD_DIR}" && cd "${CI_BUILD_DIR}" \|\| exit 1
6		wget -qO- "${sf_lf_CI_TARURL}" \| tar xvz
7		wget -qO- "${sf_plf_CI_TARURL}" \| tar xvz
8		wget -qO- "${sf_vfa_CI_TARURL}" \| tar xvz
	5	CIRCLE_SF_TOKEN=00127070c10f5f09574b050e4f08e924764680d2
	6
	7	# "latest" is disabled due to lack of build credits upstream, thus artifacts fail
	8	# data=$(wget https://circleci.com/api/v1.1/project/gh/DeepSpec/sfdev/latest/artifacts?circle-token=${CIRCLE_SF_TOKEN} -O -)
	9	data=$(wget https://circleci.com/api/v1.1/project/gh/DeepSpec/sfdev/1411/artifacts?circle-token=${CIRCLE_SF_TOKEN} -O -)
	10
	11	mkdir -p "${CI_BUILD_DIR}" && cd "${CI_BUILD_DIR}"
	12
	13	sf_lf_CI_TARURL=$(echo "$data" \| jq -rc '.[] \| select (.path == "lf.tgz") \| .url')
	14	sf_plf_CI_TARURL=$(echo "$data" \| jq -rc '.[] \| select (.path == "plf.tgz") \| .url')
	15	sf_vfa_CI_TARURL=$(echo "$data" \| jq -rc '.[] \| select (.path == "vfa.tgz") \| .url')
	16
	17	wget -O - "${sf_lf_CI_TARURL}?circle-token=${CIRCLE_SF_TOKEN}" \| tar xvz
	18	wget -O - "${sf_plf_CI_TARURL}?circle-token=${CIRCLE_SF_TOKEN}" \| tar xvz
	19	wget -O - "${sf_vfa_CI_TARURL}?circle-token=${CIRCLE_SF_TOKEN}" \| tar xvz
9	20
10	21	( cd lf && make clean && make )
11	22	( cd plf && make clean && make )

-2

dev/ci/docker/bionic_coq/Dockerfile less more

0		# CACHEKEY: "bionic_coq-v8.11-V2019-11-08-V01"
	0	# CACHEKEY: "bionic_coq-v8.11-V2019-12-08-V01"
1	1	# ^^ Update when modifying this file.
2	2
3	3	FROM ubuntu:bionic

7	7
8	8	RUN apt-get update -qq && apt-get install --no-install-recommends -y -qq \
9	9	# Dependencies of the image, the test-suite and external projects
10		m4 automake autoconf time wget rsync git gcc-multilib build-essential unzip \
	10	m4 automake autoconf time wget rsync git gcc-multilib build-essential unzip jq \
11	11	# Dependencies of lablgtk (for CoqIDE)
12	12	libgtksourceview-3.0-dev \
13	13	# Dependencies of stdlib and sphinx doc

-1

dev/ci/gitlab.bat less more

46	46	-addon=mtac2 ^
47	47	-addon=mathcomp ^
48	48	-addon=menhir ^
49		-addon=menhirlib ^
50	49	-addon=compcert ^
51	50	-addon=extlib ^
52	51	-addon=quickchick ^

+26

-1

dev/doc/critical-bugs less more

157	157	component: universe polymorphism, asynchronous proofs
158	158	summary: universe constraints erroneously discarded when forcing an asynchronous proof containing delayed monomorphic constraints inside a universe polymorphic section
159	159	introduced: between 8.4 and 8.5 by merging the asynchronous proofs feature branch and universe polymorphism one
160		impacted released: V8.5-V8.10
	160	impacted released versions: V8.5-V8.10
161	161	impacted development branches: none
162	162	impacted coqchk versions: immune
163	163	fixed in: PR#10664

165	165	exploit: no test
166	166	GH issue number: none
167	167	risk: unlikely to be triggered in interactive mode, not present in batch mode (i.e. coqc)
	168
	169	component: algebraic universes
	170	summary: Set+2 was incorrectly simplified to Set+1
	171	introduced: V8.10 (with the SProp commit 75508769762372043387c67a9abe94e8f940e80a)
	172	impacted released versions: V8.10.0 V8.10.1 V8.10.2
	173	impacted coqchk versions: same
	174	fixed in: PR#11422
	175	found by: Gilbert
	176	exploit: see PR (custom application of Hurkens to get around the refreshing at elaboration)
	177	GH issue number: see PR
	178	risk: unlikely to be triggered through the vernacular (the system "refreshes" algebraic
	179	universes such that +2 increments do not appear), mild risk from plugins which manipulate
	180	algebraic universes.
168	181
169	182	Primitive projections
170	183

253	266	exploit:
254	267	GH issue number: #9925
255	268	risk:
	269
	270	component: "virtual machine" (compilation to bytecode ran by a C-interpreter)
	271	summary: broken long multiplication primitive integer emulation layer on 32 bits
	272	introduced: e43b176
	273	impacted released versions: 8.10.0, 8.10.1, 8.10.2
	274	impacted development branches: 8.11
	275	impacted coqchk versions: none (no virtual machine in coqchk)
	276	fixed in: 4e176a7
	277	found by: Soegtrop, Melquiond
	278	exploit: test-suite/bugs/closed/bug_11321.v
	279	GH issue number: #11321
	280	risk: critical, as any BigN computation on 32-bit architectures is wrong
256	281
257	282	component: "native" conversion machine (translation to OCaml which compiles to native code)
258	283	summary: translation of identifier from Coq to OCaml was not bijective, leading to identify True and False

-2

doc/stdlib/dune less more

4	4	(deps
5	5	make-library-index index-list.html.template hidden-files
6	6	(source_tree %{project_root}/theories)
7		(source_tree %{project_root}/plugins))
	7	(source_tree %{project_root}/plugins)
	8	(source_tree %{project_root}/user-contrib))
8	9	(action
9	10	(chdir %{project_root}
10	11	; On windows run will fail

16	17	; This will be replaced soon by `theories/*/.v` soon, thanks to rgrinberg
17	18	(source_tree %{project_root}/theories)
18	19	(source_tree %{project_root}/plugins)
	20	(source_tree %{project_root}/user-contrib)
19	21	(:header %{project_root}/doc/common/styles/html/coqremote/header.html)
20	22	(:footer %{project_root}/doc/common/styles/html/coqremote/footer.html)
21	23	; For .glob files, should be gone when Coq Dune is smarter.

23	25	(action
24	26	(progn
25	27	(run mkdir -p html)
26		(bash "%{bin:coqdoc} -q -d html --with-header %{header} --with-footer %{footer} --multi-index --html -g -R %{project_root}/theories Coq -R %{project_root}/plugins Coq $(find %{project_root}/theories %{project_root}/plugins -name *.v)")
	28	(bash "%{bin:coqdoc} -q -d html --with-header %{header} --with-footer %{footer} --multi-index --html -g -R %{project_root}/theories Coq -R %{project_root}/plugins Coq -Q %{project_root}/user-contrib/Ltac2 Ltac2 $(find %{project_root}/theories %{project_root}/plugins %{project_root}/user-contrib -name *.v)")
27	29	(run mv html/index.html html/genindex.html)
28	30	(with-stdout-to
29	31	_index.html

-0

doc/stdlib/hidden-files less more

23	23	plugins/funind/FunInd.v
24	24	plugins/funind/Recdef.v
25	25	plugins/ltac/Ltac.v
	26	plugins/micromega/Ztac.v
26	27	plugins/micromega/DeclConstant.v
27	28	plugins/micromega/Env.v
28	29	plugins/micromega/EnvRing.v

43	44	plugins/micromega/ZCoeff.v
44	45	plugins/micromega/ZMicromega.v
45	46	plugins/micromega/ZifyInst.v
	47	plugins/micromega/ZifyPow.v
46	48	plugins/micromega/ZifyBool.v
47	49	plugins/micromega/ZifyComparison.v
48	50	plugins/micromega/ZifyClasses.v

+26

-0

doc/stdlib/index-list.html.template less more

594	594	theories/Reals/SeqSeries.v
595	595	theories/Reals/Sqrt_reg.v
596	596	theories/Reals/Rlogic.v
	597	theories/Reals/Rregisternames.v
597	598	(theories/Reals/Reals.v)
598	599	theories/Reals/Runcountable.v
599	600	</dd>

625	626	plugins/ssr/ssrfun.v
626	627	</dd>
627	628
	629	<dt> <b>Ltac2</b>:
	630	The Ltac2 tactic programming language
	631	</dt>
	632	<dd>
	633	user-contrib/Ltac2/Ltac2.v
	634	user-contrib/Ltac2/Array.v
	635	user-contrib/Ltac2/Bool.v
	636	user-contrib/Ltac2/Char.v
	637	user-contrib/Ltac2/Constr.v
	638	user-contrib/Ltac2/Control.v
	639	user-contrib/Ltac2/Env.v
	640	user-contrib/Ltac2/Fresh.v
	641	user-contrib/Ltac2/Ident.v
	642	user-contrib/Ltac2/Init.v
	643	user-contrib/Ltac2/Int.v
	644	user-contrib/Ltac2/List.v
	645	user-contrib/Ltac2/Ltac1.v
	646	user-contrib/Ltac2/Message.v
	647	user-contrib/Ltac2/Notations.v
	648	user-contrib/Ltac2/Option.v
	649	user-contrib/Ltac2/Pattern.v
	650	user-contrib/Ltac2/Std.v
	651	user-contrib/Ltac2/String.v
	652	</dd>
	653
628	654	<dt> <b>Unicode</b>:
629	655	Unicode-based notations
630	656	</dt>

-3

doc/stdlib/make-library-index less more

0		#!/bin/sh
	0	#!/usr/bin/env bash
1	1
2	2	# Instantiate links to library files in index template
3	3

7	7	cp -f $FILE.template tmp
8	8	echo -n "Building file index-list.prehtml... "
9	9
10		LIBDIRS=`find theories/* plugins/* -type d ! -name .coq-native`
	10	LIBDIRS=`find theories/* plugins/* user-contrib/* -type d ! -name .coq-native`
11	11
12	12	for k in $LIBDIRS; do
	13	if [[ $k =~ "user-contrib" ]]; then
	14	BASE_PREFIX=""
	15	else
	16	BASE_PREFIX="Coq."
	17	fi
13	18	d=`basename $k`
14	19	ls $k \| grep -q \.v'$'
15	20	if [ $? = 0 ]; then

25	30	echo Error: $FILE and $HIDDEN both mention $k/$b.v; exit 1
26	31	else
27	32	p=`echo $k \| sed 's:^[^/]*/::' \| sed 's:/:.:g'`
28		sed -e "s:$k/$b.v:<a href=\"Coq.$p.$b.html\">$b</a>:g" tmp > tmp2
	33	sed -e "s:$k/$b.v:<a href=\"$BASE_PREFIX$p.$b.html\">$b</a>:g" tmp > tmp2
29	34	mv -f tmp2 tmp
30	35	fi
31	36	else

-7

engine/evd.ml less more

1371	1371	let unsafe_eq = Refl
1372	1372
1373	1373	let to_constr ?(abort_on_undefined_evars=true) sigma c =
1374		let evar_value =
1375		if not abort_on_undefined_evars then fun ev -> safe_evar_value sigma ev
1376		else fun ev ->
1377		match safe_evar_value sigma ev with
1378		\| Some _ as v -> v
1379		\| None -> anomaly ~label:"econstr" Pp.(str "grounding a non evar-free term")
1380		in
	1374	let evar_value ev = safe_evar_value sigma ev in
1381	1375	UnivSubst.nf_evars_and_universes_opt_subst evar_value (universe_subst sigma) c
1382	1376
1383	1377	let to_constr_opt sigma c =

-2

engine/proofview.ml less more

1024	1024
1025	1025	let undefined = undefined
1026	1026
1027		let mark_as_unresolvable p gl =
1028		{ p with solution = mark_in_evm ~goal:false p.solution [gl] }
	1027	let mark_unresolvables evm evs =
	1028	mark_in_evm ~goal:false evm evs
	1029
	1030	let mark_as_unresolvables p evs =
	1031	{ p with solution = mark_in_evm ~goal:false p.solution evs }
1029	1032
1030	1033	end
1031	1034

-2

engine/proofview.mli less more

480	480	and makes them unresolvable for type classes. *)
481	481	val mark_as_goals : Evd.evar_map -> Evar.t list -> Evd.evar_map
482	482
483		(** Make an evar unresolvable for type classes. *)
484		val mark_as_unresolvable : proofview -> Evar.t -> proofview
	483	(** Make some evars unresolvable for type classes.
	484	We need two functions as some functions use the proofview and others
	485	directly manipulate the undelying evar_map.
	486	*)
	487	val mark_unresolvables : Evd.evar_map -> Evar.t list -> Evd.evar_map
	488
	489	val mark_as_unresolvables : proofview -> Evar.t list -> proofview
485	490
486	491	(** [advance sigma g] returns [Some g'] if [g'] is undefined and is
487	492	the current avatar of [g] (for instance [g] was changed by [clear]

-1

engine/univMinim.ml less more

275	275	Constraint.partition (fun (l,d,r) -> d == Le && (Level.equal l lbound \|\| Level.is_sprop l)) csts
276	276	in
277	277	let smallles = if get_set_minimization ()
278		then Constraint.filter (fun (l,d,r) -> LSet.mem r ctx && not (Level.is_sprop l)) smallles
	278	then Constraint.filter (fun (l,d,r) -> LMap.mem r us && not (Level.is_sprop l)) smallles
279	279	else Constraint.empty
280	280	in
281	281	let csts, partition =

-1

ide/coqide.ml less more

617	617
618	618	let get_current_word term =
619	619	(* First look to find if autocompleting *)
620		match term.script#complete_popup#proposal with
	620	match term.script#proposal with
621	621	\| Some p -> p
622	622	\| None ->
623	623	(* Then look at the current selected word *)

+19

-0

ide/preferences.ml less more

386	386
387	387	let auto_complete =
388	388	new preference ~name:["auto_complete"] ~init:false ~repr:Repr.(bool)
	389
	390	let auto_complete_delay =
	391	new preference ~name:["auto_complete_delay"] ~init:250 ~repr:Repr.(int)
389	392
390	393	let stop_before =
391	394	new preference ~name:["stop_before"] ~init:true ~repr:Repr.(bool)

830	833	let but = GButton.check_button ~label:text ~active ~packing:box#pack () in
831	834	ignore (but#connect#toggled ~callback:(fun () -> pref#set but#active))
832	835	in
	836	let spin text ~min ~max (pref : int preference) =
	837	let box = GPack.hbox ~packing:box#pack () in
	838	let but = GEdit.spin_button
	839	~numeric:true ~update_policy:`IF_VALID ~digits:0
	840	~packing:box#pack ()
	841	in
	842	let _ = GMisc.label ~text:"Delay (ms)" ~packing:box#pack () in
	843	let () = but#adjustment#set_bounds
	844	~lower:(float_of_int min) ~upper:(float_of_int max)
	845	~step_incr:1.
	846	()
	847	in
	848	let () = but#set_value (float_of_int pref#get) in
	849	ignore (but#connect#value_changed ~callback:(fun () -> pref#set but#value_as_int))
	850	in
833	851	let () = button "Dynamic word wrap" dynamic_word_wrap in
834	852	let () = button "Show line number" show_line_number in
835	853	let () = button "Auto indentation" auto_indent in
836	854	let () = button "Auto completion" auto_complete in
	855	let () = spin "Auto completion delay" ~min:0 ~max:5000 auto_complete_delay in
837	856	let () = button "Show spaces" show_spaces in
838	857	let () = button "Show right margin" show_right_margin in
839	858	let () = button "Show progress bar" show_progress_bar in

-0

ide/preferences.mli less more

81	81	val window_width : int preference
82	82	val window_height : int preference
83	83	val auto_complete : bool preference
	84	val auto_complete_delay : int preference
84	85	val stop_before : bool preference
85	86	val reset_on_tab_switch : bool preference
86	87	val line_ending : line_ending preference

+71

-357

ide/wg_Completion.ml less more

68	68	if !break then len2 - len1
69	69	else -1
70	70
71		class type complete_model_signals =
72		object ('a)
73		method after : 'a
74		method disconnect : GtkSignal.id -> unit
75		method start_completion : callback:(int -> unit) -> GtkSignal.id
76		method update_completion : callback:(int * string * Proposals.t -> unit) -> GtkSignal.id
77		method end_completion : callback:(unit -> unit) -> GtkSignal.id
78		end
	71	class completion_provider coqtop =
	72	let self_provider = ref None in
	73	let active = ref true in
	74	let provider = object (self)
79	75
80		let complete_model_signals
81		(start_s : int GUtil.signal)
82		(update_s : (int * string * Proposals.t) GUtil.signal)
83		(end_s : unit GUtil.signal) : complete_model_signals =
84		let signals = [
85		start_s#disconnect;
86		update_s#disconnect;
87		end_s#disconnect;
88		] in
89		object (self : 'a)
90		inherit GUtil.ml_signals signals
91		method start_completion = start_s#connect ~after
92		method update_completion = update_s#connect ~after
93		method end_completion = end_s#connect ~after
94		end
	76	val mutable auto_complete_length = 3
	77	val mutable cache = (-1, "", Proposals.empty)
	78	val mutable insert_offset = -1
95	79
96		class complete_model coqtop (buffer : GText.buffer) =
97		let cols = new GTree.column_list in
98		let column = cols#add Gobject.Data.string in
99		let store = GTree.list_store cols in
100		let filtered_store = GTree.model_filter store in
101		let start_completion_signal = new GUtil.signal () in
102		let update_completion_signal = new GUtil.signal () in
103		let end_completion_signal = new GUtil.signal () in
104		object (self)
	80	method name = ""
105	81
106		val signals = complete_model_signals
107		start_completion_signal update_completion_signal end_completion_signal
108		val mutable active = false
109		val mutable auto_complete_length = 3
110		(* this variable prevents CoqIDE from autocompleting when we have deleted something *)
111		val mutable is_auto_completing = false
112		(* this mutex ensure that CoqIDE will not try to autocomplete twice *)
113		val mutable cache = (-1, "", Proposals.empty)
114		val mutable insert_offset = -1
115		val mutable current_completion = ("", Proposals.empty)
116		val mutable lock_auto_completing = true
	82	method icon = None
117	83
118		method connect = signals
	84	method private update_proposals pref =
	85	let (_, _, props) = cache in
	86	let filter prop = 0 <= is_substring pref prop in
	87	let props = Proposals.filter filter props in
	88	props
119	89
120		method active = active
	90	method private add_proposals ctx props =
	91	let mk text =
	92	let item = GSourceView3.source_completion_item ~text ~label:text () in
	93	(item :> GSourceView3.source_completion_proposal)
	94	in
	95	let props = List.map mk (Proposals.elements props) in
	96	ctx#add_proposals (Option.get !self_provider) props true
121	97
122		method set_active b = active <- b
123
124		method private handle_insert iter s =
125		(* we're inserting, so we may autocomplete *)
126		is_auto_completing <- true
127
128		method private handle_delete ~start ~stop =
129		(* disable autocomplete *)
130		is_auto_completing <- false
131
132		method store = filtered_store
133
134		method column = column
135
136		method handle_proposal path =
137		let row = filtered_store#get_iter path in
138		let proposal = filtered_store#get ~row ~column in
139		let (start_offset, _, _) = cache in
140		(* [iter] might be invalid now, get a new one to please gtk *)
141		let iter = buffer#get_iter `INSERT in
142		(* We cancel completion when the buffer has changed recently *)
143		if iter#offset = insert_offset then begin
144		let suffix =
145		let len1 = String.length proposal in
146		let len2 = insert_offset - start_offset in
147		String.sub proposal len2 (len1 - len2)
148		in
149		buffer#begin_user_action ();
150		ignore (buffer#insert_interactive ~iter suffix);
151		buffer#end_user_action ();
152		end
153
154		method private init_proposals pref props =
155		let () = store#clear () in
156		let iter prop =
157		let iter = store#append () in
158		store#set ~row:iter ~column prop
159		in
160		let () = current_completion <- (pref, props) in
161		Proposals.iter iter props
162
163		method private update_proposals pref =
164		let (_, _, props) = cache in
165		let filter prop = 0 <= is_substring pref prop in
166		let props = Proposals.filter filter props in
167		let () = current_completion <- (pref, props) in
168		let () = filtered_store#refilter () in
169		props
170
171		method private do_auto_complete k =
172		let iter = buffer#get_iter `INSERT in
173		let () = insert_offset <- iter#offset in
174		let log = Printf.sprintf "Completion at offset: %i" insert_offset in
175		let () = Minilib.log log in
176		let prefix =
177		if Gtk_parsing.ends_word iter then
178		let start = Gtk_parsing.find_word_start iter in
179		let w = buffer#get_text ~start ~stop:iter () in
180		if String.length w >= auto_complete_length then Some (w, start)
181		else None
182		else None
183		in
184		match prefix with
185		\| Some (w, start) ->
	98	method populate ctx =
	99	let iter = ctx#iter in
	100	let buffer = new GText.buffer iter#buffer in
	101	let start = Gtk_parsing.find_word_start iter in
	102	let w = start#get_text ~stop:iter in
186	103	let () = Minilib.log ("Completion of prefix: '" ^ w ^ "'") in
187	104	let (off, prefix, props) = cache in
188	105	let start_offset = start#offset in
189	106	(* check whether we have the last request in cache *)
190	107	if (start_offset = off) && (0 <= is_substring prefix w) then
191	108	let props = self#update_proposals w in
192		let () = update_completion_signal#call (start_offset, w, props) in
193		k ()
	109	self#add_proposals ctx props
194	110	else
195		let () = start_completion_signal#call start_offset in
	111	let cancel = ref false in
	112	let _ = ctx#connect#cancelled ~callback:(fun () -> cancel := true) in
196	113	let update props =
197	114	let () = cache <- (start_offset, w, props) in
198		let () = self#init_proposals w props in
199		update_completion_signal#call (start_offset, w, props)
	115	if not !cancel then self#add_proposals ctx props
200	116	in
201	117	(* If not in the cache, we recompute it: first syntactic *)
202	118	let synt = get_syntactic_completion buffer w Proposals.empty in
203	119	(* Then semantic *)
204		let next prop =
205		let () = update prop in
206		Coq.lift k
	120	let next props =
	121	update props;
	122	Coq.return ()
207	123	in
208	124	let query = Coq.bind (get_semantic_completion w synt) next in
209	125	(* If coqtop is computing, do the syntactic completion altogether *)
210		let occupied () =
211		let () = update synt in
212		k ()
213		in
	126	let occupied () = update synt in
214	127	Coq.try_grab coqtop query occupied
215		\| None -> end_completion_signal#call (); k ()
216	128
217		method private may_auto_complete () =
218		if active && is_auto_completing && lock_auto_completing then begin
219		let () = lock_auto_completing <- false in
220		let unlock () = lock_auto_completing <- true in
221		self#do_auto_complete unlock
222		end
223
224		initializer
225		let filter_prop model row =
226		let (_, props) = current_completion in
227		let prop = store#get ~row ~column in
228		Proposals.mem prop props
229		in
230		let () = filtered_store#set_visible_func filter_prop in
231		(* Install auto-completion *)
232		ignore (buffer#connect#insert_text ~callback:self#handle_insert);
233		ignore (buffer#connect#delete_range ~callback:self#handle_delete);
234		ignore (buffer#connect#after#end_user_action ~callback:self#may_auto_complete);
235
236		end
237
238		class complete_popup (model : complete_model) (view : GText.view) =
239		let obj = GWindow.window ~kind:`POPUP ~show:false () in
240		let frame = GBin.scrolled_window
241		~hpolicy:`NEVER ~vpolicy:`NEVER
242		~shadow_type:`OUT ~packing:obj#add ()
243		in
244		(* let frame = GBin.frame ~shadow_type:`OUT ~packing:obj#add () in *)
245		let data = GTree.view
246		~vadjustment:frame#vadjustment ~hadjustment:frame#hadjustment
247		~rules_hint:true ~headers_visible:false
248		~model:model#store ~packing:frame#add ()
249		in
250		let renderer = GTree.cell_renderer_text [], ["text", model#column] in
251		let col = GTree.view_column ~renderer () in
252		let _ = data#append_column col in
253		let () = col#set_sizing `AUTOSIZE in
254		let page_size = 16 in
255
256		object (self)
257
258		method coerce = view#coerce
259
260		method private refresh_style () =
261		let (renderer, _) = renderer in
262		let font = Pango.Font.from_string Preferences.text_font#get in
263		renderer#set_properties [`FONT_DESC font; `XPAD 10]
264
265		method private coordinates pos =
266		(* Toplevel position w.r.t. screen *)
267		let (x, y) = Gdk.Window.get_position view#misc#toplevel#misc#window in
268		(* Position of view w.r.t. window *)
269		let (ux, uy) = Gdk.Window.get_position view#misc#window in
270		(* Relative buffer position to view *)
271		let (dx, dy) = view#window_to_buffer_coords ~tag:`WIDGET ~x:0 ~y:0 in
272		(* Iter position *)
273		let iter = view#buffer#get_iter pos in
274		let coords = view#get_iter_location iter in
275		let lx = Gdk.Rectangle.x coords in
276		let ly = Gdk.Rectangle.y coords in
277		let w = Gdk.Rectangle.width coords in
278		let h = Gdk.Rectangle.height coords in
279		(* Absolute position *)
280		(x + lx + ux - dx, y + ly + uy - dy, w, h)
281
282		method private select_any f =
283		let sel = data#selection#get_selected_rows in
284		let path = match sel with
285		\| [] ->
286		begin match model#store#get_iter_first with
287		\| None -> None
288		\| Some iter -> Some (model#store#get_path iter)
289		end
290		\| path :: _ -> Some path
291		in
292		match path with
293		\| None -> ()
294		\| Some path ->
295		let path = f path in
296		let _ = data#selection#select_path path in
297		data#scroll_to_cell ~align:(0.,0.) path col
298
299		method private select_previous () =
300		let prev path =
301		let copy = GTree.Path.copy path in
302		if GTree.Path.prev path then path
303		else copy
304		in
305		self#select_any prev
306
307		method private select_next () =
308		let next path =
309		let () = GTree.Path.next path in
310		path
311		in
312		self#select_any next
313
314		method private select_previous_page () =
315		let rec up i path =
316		if i = 0 then path
317		else
318		let copy = GTree.Path.copy path in
319		let has_prev = GTree.Path.prev path in
320		if has_prev then up (pred i) path
321		else copy
322		in
323		self#select_any (up page_size)
324
325		method private select_next_page () =
326		let rec down i path =
327		if i = 0 then path
328		else
329		let copy = GTree.Path.copy path in
330		let iter = model#store#get_iter path in
331		let has_next = model#store#iter_next iter in
332		if has_next then down (pred i) (model#store#get_path iter)
333		else copy
334		in
335		self#select_any (down page_size)
336
337		method private select_first () =
338		let rec up path =
339		let copy = GTree.Path.copy path in
340		let has_prev = GTree.Path.prev path in
341		if has_prev then up path
342		else copy
343		in
344		self#select_any up
345
346		method private select_last () =
347		let rec down path =
348		let copy = GTree.Path.copy path in
349		let iter = model#store#get_iter path in
350		let has_next = model#store#iter_next iter in
351		if has_next then down (model#store#get_path iter)
352		else copy
353		in
354		self#select_any down
355
356		method private select_enter () =
357		let sel = data#selection#get_selected_rows in
358		match sel with
359		\| [] -> ()
360		\| path :: _ ->
361		let () = model#handle_proposal path in
362		self#hide ()
363
364		method proposal =
365		let sel = data#selection#get_selected_rows in
366		if obj#misc#visible then match sel with
367		\| [] -> None
368		\| path :: _ ->
369		let row = model#store#get_iter path in
370		let column = model#column in
371		let proposal = model#store#get ~row ~column in
372		Some proposal
373		else None
374
375		method private manage_scrollbar () =
376		(* HACK: we don't have access to the treeview size because of the lack of
377		LablGTK binding for certain functions, so we bypass it by approximating
378		it through the size of the proposals *)
379		let height = match model#store#get_iter_first with
380		\| None -> -1
381		\| Some iter ->
382		let path = model#store#get_path iter in
383		let area = data#get_cell_area ~path ~col () in
384		let height = Gdk.Rectangle.height area in
385		let height = page_size * height in
386		height
387		in
388		let len = ref 0 in
389		let () = model#store#foreach (fun _ _ -> incr len; false) in
390		if !len > page_size then
391		let () = frame#set_vpolicy `ALWAYS in
392		data#misc#set_size_request ~height ()
393		else
394		data#misc#set_size_request ~height:(-1) ()
395
396		method private refresh () =
397		let () = frame#set_vpolicy `NEVER in
398		let () = self#select_first () in
399		let () = obj#misc#show () in
400		let () = self#manage_scrollbar () in
401		obj#resize ~width:1 ~height:1
402
403		method private start_callback off =
404		let (x, y, w, h) = self#coordinates (`OFFSET off) in
405		let () = obj#move ~x ~y:(y + 3 * h / 2) in
406		()
407
408		method private update_callback (off, word, props) =
409		if Proposals.is_empty props then self#hide ()
410		else if Proposals.mem word props then self#hide ()
411		else self#refresh ()
412
413		method private end_callback () =
414		obj#misc#hide ()
415
416		method private hide () = self#end_callback ()
417
418		initializer
419		let move_cb _ _ ~extend = self#hide () in
420		let key_cb ev =
421		let eval cb = cb (); true in
422		let ev_key = GdkEvent.Key.keyval ev in
423		if obj#misc#visible then
424		if ev_key = GdkKeysyms._Up then eval self#select_previous
425		else if ev_key = GdkKeysyms._Down then eval self#select_next
426		else if ev_key = GdkKeysyms._Tab then eval self#select_enter
427		else if ev_key = GdkKeysyms._Return then eval self#select_enter
428		else if ev_key = GdkKeysyms._Escape then eval self#hide
429		else if ev_key = GdkKeysyms._Page_Down then eval self#select_next_page
430		else if ev_key = GdkKeysyms._Page_Up then eval self#select_previous_page
431		else if ev_key = GdkKeysyms._Home then eval self#select_first
432		else if ev_key = GdkKeysyms._End then eval self#select_last
	129	method matched ctx =
	130	if !active then
	131	let iter = ctx#iter in
	132	let () = insert_offset <- iter#offset in
	133	let log = Printf.sprintf "Completion at offset: %i" insert_offset in
	134	let () = Minilib.log log in
	135	if Gtk_parsing.ends_word iter#backward_char then
	136	let start = Gtk_parsing.find_word_start iter in
	137	iter#offset - start#offset >= auto_complete_length
433	138	else false
434	139	else false
435		in
436		(* Style handling *)
437		let _ = view#misc#connect#style_set ~callback:self#refresh_style in
438		let _ = self#refresh_style () in
439		let _ = data#set_resize_mode `PARENT in
440		let _ = frame#set_resize_mode `PARENT in
441		(* Callback to model *)
442		let _ = model#connect#start_completion ~callback:self#start_callback in
443		let _ = model#connect#update_completion ~callback:self#update_callback in
444		let _ = model#connect#end_completion ~callback:self#end_callback in
445		(* Popup interaction *)
446		let _ = view#event#connect#key_press ~callback:key_cb in
447		(* Hiding the popup when necessary*)
448		let _ = view#misc#connect#hide ~callback:obj#misc#hide in
449		let _ = view#event#connect#button_press ~callback:(fun _ -> self#hide (); false) in
450		let _ = view#connect#move_cursor ~callback:move_cb in
451		let _ = view#event#connect#focus_out ~callback:(fun _ -> self#hide (); false) in
452		()
453	140
454		end
	141	method activation = [`INTERACTIVE; `USER_REQUESTED]
	142
	143	method info_widget proposal = None
	144
	145	method update_info proposal info = ()
	146
	147	method start_iter ctx proposal iter = false
	148
	149	method activate_proposal proposal iter = false
	150
	151	method interactive_delay = (-1)
	152
	153	method priority = 0
	154
	155	end in
	156	let provider = GSourceView3.source_completion_provider provider in
	157	object (self)
	158
	159	inherit GSourceView3.source_completion_provider provider#as_source_completion_provider
	160
	161	method active = !active
	162
	163	method set_active b = active := b
	164
	165	initializer
	166	self_provider := Some (self :> GSourceView3.source_completion_provider)
	167
	168	end

-20

ide/wg_Completion.mli less more

9	9
10	10	module Proposals : sig type t end
11	11
12		class type complete_model_signals =
13		object ('a)
14		method after : 'a
15		method disconnect : GtkSignal.id -> unit
16		method start_completion : callback:(int -> unit) -> GtkSignal.id
17		method update_completion : callback:(int * string * Proposals.t -> unit) -> GtkSignal.id
18		method end_completion : callback:(unit -> unit) -> GtkSignal.id
19		end
20
21		class complete_model : Coq.coqtop -> GText.buffer ->
	12	class completion_provider : Coq.coqtop ->
22	13	object
	14	inherit GSourceView3.source_completion_provider
23	15	method active : bool
24		method connect : complete_model_signals
25	16	method set_active : bool -> unit
26		method store : GTree.model_filter
27		method column : string GTree.column
28		method handle_proposal : Gtk.tree_path -> unit
29	17	end
30
31		class complete_popup : complete_model -> GText.view ->
32		object
33		method coerce : GObj.widget
34		method proposal : string option
35		end

-5

ide/wg_ScriptView.ml less more

286	286	class script_view (tv : source_view) (ct : Coq.coqtop) =
287	287
288	288	let view = new GSourceView3.source_view (Gobject.unsafe_cast tv) in
289		let completion = new Wg_Completion.complete_model ct view#buffer in
290		let popup = new Wg_Completion.complete_popup completion (view :> GText.view) in
	289	let provider = new Wg_Completion.completion_provider ct in
291	290
292	291	object (self)
293	292	inherit GSourceView3.source_view (Gobject.unsafe_cast tv)
294	293
295	294	val undo_manager = new undo_manager view#buffer
296	295
297		method auto_complete = completion#active
	296	method auto_complete = provider#active
298	297
299	298	method set_auto_complete flag =
300		completion#set_active flag
	299	provider#set_active flag
301	300
302	301	method recenter_insert =
303	302	self#scroll_to_mark

447	446	self#buffer#delete_mark (`MARK insert_mark)
448	447
449	448
450		method complete_popup = popup
	449	method proposal : string option = None (* FIXME *)
451	450
452	451	method undo = undo_manager#undo
453	452	method redo = undo_manager#redo

526	525	stick spaces_instead_of_tabs self self#set_insert_spaces_instead_of_tabs;
527	526	stick tab_length self self#set_tab_width;
528	527	stick auto_complete self self#set_auto_complete;
	528	stick auto_complete_delay self (fun d -> self#completion#set_auto_complete_delay d);
529	529
530	530	let cb ft = self#misc#modify_font (GPango.font_description_from_string ft) in
531	531	stick text_font self cb;
	532
	533	let () = self#completion#set_accelerators 0 in
	534	let () = self#completion#set_show_headers false in
	535	let _ = self#completion#add_provider (provider :> GSourceView3.source_completion_provider) in
532	536
533	537	()
534	538

-1

ide/wg_ScriptView.mli less more

27	27	method uncomment : unit -> unit
28	28	method apply_unicode_binding : unit -> unit
29	29	method recenter_insert : unit
30		method complete_popup : Wg_Completion.complete_popup
	30	method proposal : string option
31	31	end
32	32
33	33	val script_view : Coq.coqtop ->

-1

interp/notation.ml less more

1871	1871	\| SingleNotation ntn ->
1872	1872	if List.mem_f notation_eq ntn knownntn then (all,knownntn)
1873	1873	else
	1874	try
1874	1875	let { not_interp = (_, r); not_location = (_, df) } =
1875	1876	NotationMap.find ntn (find_scope default_scope).notations in
1876	1877	let all' = match all with

1878	1879	(s,(df,r)::lonelyntn)::rest
1879	1880	\| _ ->
1880	1881	(default_scope,[df,r])::all in
1881		(all',ntn::knownntn))
	1882	(all',ntn::knownntn)
	1883	with Not_found -> (* e.g. if only printing *) (all,knownntn))
1882	1884	([],[]) stack)
1883	1885
1884	1886	let pr_visible_in_scope prglob (scope,ntns) =

+27

-7

kernel/byterun/coq_interp.c less more

16	16	#include <signal.h>
17	17	#include <stdint.h>
18	18	#include <caml/memory.h>
	19	#include <caml/signals.h>
	20	#include <caml/version.h>
19	21	#include <math.h>
20	22	#include "coq_gc.h"
21	23	#include "coq_instruct.h"

202	204	*sp = swap_accu_sp_tmp__; \
203	205	}while(0)
204	206
	207	#if OCAML_VERSION < 41000
205	208	/* For signal handling, we hijack some code from the caml runtime */
206	209
207		extern intnat caml_signals_are_pending;
208		extern intnat caml_pending_signals[];
	210	extern intnat volatile caml_signals_are_pending;
	211	extern intnat volatile caml_pending_signals[];
209	212	extern void caml_process_pending_signals(void);
	213	#endif
210	214
211	215	/* The interpreter itself */
212	216

505	509	print_instr("check_stack");
506	510	CHECK_STACK(0);
507	511	/* We also check for signals */
	512	#if OCAML_VERSION >= 41000
	513	{
	514	value res = caml_process_pending_actions_exn();
	515	if (Is_exception_result(res)) {
	516	/* If there is an asynchronous exception, we reset the vm */
	517	coq_sp = coq_stack_high;
	518	caml_raise(Extract_exception(res));
	519	}
	520	}
	521	#else
508	522	if (caml_signals_are_pending) {
509		/* If there's a Ctrl-C, we reset the vm */
510		if (caml_pending_signals[SIGINT]) { coq_sp = coq_stack_high; }
511		caml_process_pending_signals();
512		}
	523	/* If there's a Ctrl-C, we reset the vm */
	524	intnat sigint = caml_pending_signals[SIGINT];
	525	if (sigint) { coq_sp = coq_stack_high; }
	526	caml_process_pending_signals();
	527	if (sigint) {
	528	caml_failwith("Coq VM: Fatal error: SIGINT signal detected "
	529	"but no exception was raised");
	530	}
	531	}
	532	#endif
513	533	Next;
514	534
515	535	Instruct(ENSURESTACKCAPACITY) {

1742	1762	#ifndef THREADED_CODE
1743	1763	default:
1744	1764	/fprintf(stderr, "%d\n", pc);*/
1745		failwith("Coq VM: Fatal error: bad opcode");
	1765	caml_failwith("Coq VM: Fatal error: bad opcode");
1746	1766	}
1747	1767	}
1748	1768	#endif

-2

kernel/byterun/coq_values.c less more

38	38	if (Is_instruction(c,RESTART)) {
39	39	c++;
40	40	if (Is_instruction(c,GRAB)) return Val_int(3 + c[1] - Wosize_val(clos));
41		else {
42		if (Wosize_val(clos) != 2) failwith("Coq Values : coq_closure_arity");
	41	else {
	42	if (Wosize_val(clos) != 2) caml_failwith("Coq Values : coq_closure_arity");
43	43	return Val_int(1);
44	44	}
45	45	}

+18

-10

kernel/indtypes.ml less more

378	378	(************************************************************************)
379	379	(* Build the inductive packet *)
380	380
381		let repair_arity indices = function
382		\| RegularArity ar -> ar.mind_user_arity
383		\| TemplateArity ar -> mkArity (indices,Sorts.sort_of_univ ar.template_level)
384
385		let fold_inductive_blocks f =
	381	let fold_arity f acc params arity indices = match arity with
	382	\| RegularArity ar -> f acc ar.mind_user_arity
	383	\| TemplateArity _ ->
	384	let fold_ctx acc ctx =
	385	List.fold_left (fun acc d ->
	386	Context.Rel.Declaration.fold_constr (fun c acc -> f acc c) d acc)
	387	acc
	388	ctx
	389	in
	390	fold_ctx (fold_ctx acc params) indices
	391
	392	let fold_inductive_blocks f acc params inds =
386	393	Array.fold_left (fun acc ((arity,lc),(indices,_),_) ->
387		f (Array.fold_left f acc lc) (repair_arity indices arity))
388
389		let used_section_variables env inds =
	394	fold_arity f (Array.fold_left f acc lc) params arity indices)
	395	acc inds
	396
	397	let used_section_variables env params inds =
390	398	let fold l c = Id.Set.union (Environ.global_vars_set env c) l in
391		let ids = fold_inductive_blocks fold Id.Set.empty inds in
	399	let ids = fold_inductive_blocks fold Id.Set.empty params inds in
392	400	keep_hyps env ids
393	401
394	402	let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i))

460	468	let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite inds nmr recargs =
461	469	let ntypes = Array.length inds in
462	470	(* Compute the set of used section variables *)
463		let hyps = used_section_variables env inds in
	471	let hyps = used_section_variables env paramsctxt inds in
464	472	let nparamargs = Context.Rel.nhyps paramsctxt in
465	473	(* Check one inductive *)
466	474	let build_one_packet (id,cnames) ((arity,lc),(indices,splayed_lc),kelim) recarg =

+26

-5

kernel/nativelib.ml less more

26	26	(* Directory where compiled files are stored *)
27	27	let output_dir = ".coq-native"
28	28
29		(* Extension of genereted ml files, stored for debugging purposes *)
	29	(* Extension of generated ml files, stored for debugging purposes *)
30	30	let source_ext = ".native"
31	31
32	32	let ( / ) = Filename.concat
33	33
34		(* We have to delay evaluation of include_dirs because coqlib cannot be guessed
35		until flags have been properly initialized *)
	34	(* Directory for temporary files for the conversion and normalisation
	35	(as opposed to compiling the library itself, which uses [output_dir]). *)
	36	let my_temp_dir = lazy (CUnix.mktemp_dir "Coq_native" "")
	37
	38	let () = at_exit (fun () ->
	39	if Lazy.is_val my_temp_dir then
	40	try
	41	let d = Lazy.force my_temp_dir in
	42	Array.iter (fun f -> Sys.remove (Filename.concat d f)) (Sys.readdir d);
	43	Unix.rmdir d
	44	with e ->
	45	Feedback.msg_warning
	46	Pp.(str "Native compile: failed to cleanup: " ++
	47	str(Printexc.to_string e) ++ fnl()))
	48
	49	(* We have to delay evaluation of include_dirs because coqlib cannot
	50	be guessed until flags have been properly initialized. It also lets
	51	us avoid forcing [my_temp_dir] if we don't need it (eg stdlib file
	52	without native compute or native conv uses). *)
36	53	let include_dirs () =
37		[Filename.get_temp_dir_name (); Envars.coqlib () / "kernel"; Envars.coqlib () / "library"]
	54	let base = [Envars.coqlib () / "kernel"; Envars.coqlib () / "library"] in
	55	if Lazy.is_val my_temp_dir
	56	then (Lazy.force my_temp_dir) :: base
	57	else base
38	58
39	59	(* Pointer to the function linking an ML object into coq's toplevel *)
40	60	let load_obj = ref (fun _x -> () : string -> unit)

43	63	let rt2 = ref (dummy_value ())
44	64
45	65	let get_ml_filename () =
46		let filename = Filename.temp_file "Coq_native" source_ext in
	66	let temp_dir = Lazy.force my_temp_dir in
	67	let filename = Filename.temp_file ~temp_dir "Coq_native" source_ext in
47	68	let prefix = Filename.chop_extension (Filename.basename filename) ^ "." in
48	69	filename, prefix
49	70

+23

-20

kernel/uint63_31.ml less more

14	14
15	15	let uint_size = 63
16	16
17		let maxuint63 = Int64.of_string "0x7FFFFFFFFFFFFFFF"
18		let maxuint31 = Int64.of_string "0x7FFFFFFF"
	17	let maxuint63 = 0x7FFF_FFFF_FFFF_FFFFL
	18	let maxuint31 = 0x7FFF_FFFFL
19	19
20	20	let zero = Int64.zero
21	21	let one = Int64.one

117	117	let div21 xh xl y =
118	118	if Int64.compare y xh <= 0 then zero, zero else div21 xh xl y
119	119
120		(* exact multiplication *)
	120	(* exact multiplication *)
121	121	let mulc x y =
122		let lx = ref (Int64.logand x maxuint31) in
123		let ly = ref (Int64.logand y maxuint31) in
	122	let lx = Int64.logand x maxuint31 in
	123	let ly = Int64.logand y maxuint31 in
124	124	let hx = Int64.shift_right x 31 in
125	125	let hy = Int64.shift_right y 31 in
126		let hr = ref (Int64.mul hx hy) in
127		let lr = ref (Int64.logor (Int64.mul !lx !ly) (Int64.shift_left !hr 62)) in
128		hr := (Int64.shift_right_logical !hr 1);
129		lx := Int64.mul !lx hy;
130		ly := Int64.mul hx !ly;
131		hr := Int64.logor !hr (Int64.add (Int64.shift_right !lx 32) (Int64.shift_right !ly 32));
132		lr := Int64.add !lr (Int64.shift_left !lx 31);
133		hr := Int64.add !hr (Int64.shift_right_logical !lr 63);
134		lr := Int64.add (Int64.shift_left !ly 31) (mask63 !lr);
135		hr := Int64.add !hr (Int64.shift_right_logical !lr 63);
136		if Int64.logand !lr Int64.min_int <> 0L
137		then Int64.(sub !hr one, mask63 !lr)
138		else (!hr, !lr)
139
140		let equal x y = mask63 x = mask63 y
	126	(* compute the median products *)
	127	let s = Int64.add (Int64.mul lx hy) (Int64.mul hx ly) in
	128	(* s fits on 64 bits, split it into a 33-bit high part and a 31-bit low part *)
	129	let lr = Int64.shift_left (Int64.logand s maxuint31) 31 in
	130	let hr = Int64.shift_right_logical s 31 in
	131	(* add the outer products *)
	132	let lr = Int64.add (Int64.mul lx ly) lr in
	133	let hr = Int64.add (Int64.mul hx hy) hr in
	134	(* hr fits on 64 bits, since the final result fits on 126 bits *)
	135	(* now x * y = hr * 2^62 + lr and lr < 2^63 *)
	136	let lr = Int64.add lr (Int64.shift_left (Int64.logand hr 1L) 62) in
	137	let hr = Int64.shift_right_logical hr 1 in
	138	(* now x * y = hr * 2^63 + lr, but lr might be too large *)
	139	if Int64.logand lr Int64.min_int <> 0L
	140	then Int64.add hr 1L, mask63 lr
	141	else hr, lr
	142
	143	let equal (x : t) y = x = y
141	144
142	145	let compare x y = Int64.compare x y
143	146

-2

kernel/univ.ml less more

344	344	(Level.is_prop u && not (Level.is_sprop v))
345	345	else false
346	346
347		let successor (u,n) =
348		if Level.is_small u then type1
	347	let successor (u,n as e) =
	348	if is_small e then type1
349	349	else (u, n + 1)
350	350
351	351	let addn k (u,n as x) =

-1

kernel/univ.mli less more

319	319	val eq_puniverses : ('a -> 'a -> bool) -> 'a puniverses -> 'a puniverses -> bool
320	320
321	321	(** A vector of universe levels with universe Constraint.t,
322		representiong local universe variables and associated Constraint.t *)
	322	representing local universe variables and associated Constraint.t *)
323	323
324	324	module UContext :
325	325	sig

-2

lib/future.ml less more

11	11	Pp.strbrk("The value you are asking for ("^name^") is not ready yet. "^
12	12	"Please wait or pass "^
13	13	"the \"-async-proofs off\" option to CoqIDE to disable "^
14		"asynchronous script processing and don't pass \"-quick\" to "^
	14	"asynchronous script processing and don't pass \"-vio\" to "^
15	15	"coqc."))
16	16	let not_here_msg = ref (fun name ->
17	17	Pp.strbrk("The value you are asking for ("^name^") is not available "^
18	18	"in this process. If you really need this, pass "^
19	19	"the \"-async-proofs off\" option to CoqIDE to disable "^
20		"asynchronous script processing and don't pass \"-quick\" to "^
	20	"asynchronous script processing and don't pass \"-vio\" to "^
21	21	"coqc."))
22	22
23	23	let customize_not_ready_msg f = not_ready_msg := f

-1

parsing/extend.ml less more

53	53	\| ETProdBigint (* Parsed as an (unbounded) integer *)
54	54	\| ETProdConstr of Constrexpr.notation_entry * (production_level * production_position) (* Parsed as constr or pattern, or a subentry of those *)
55	55	\| ETProdPattern of int (* Parsed as pattern as a binder (as subpart of a constr) *)
56		\| ETProdConstrList of (production_level * production_position) * string Tok.p list (* Parsed as non-empty list of constr *)
	56	\| ETProdConstrList of Constrexpr.notation_entry * (production_level * production_position) * string Tok.p list (* Parsed as non-empty list of constr, or subentries of those *)
57	57	\| ETProdBinderList of binder_entry_kind (* Parsed as non-empty list of local binders *)
58	58
59	59	(** {5 AST for user-provided entries} *)

-0

parsing/pcoq.ml less more

531	531	try EntryDataMap.find tag !camlp5_entries
532	532	with Not_found -> EntryData.Ex String.Map.empty
533	533	in
	534	let () = assert (not @@ String.Map.mem name old) in
534	535	let entries = String.Map.add name e old in
535	536	camlp5_entries := EntryDataMap.add tag (EntryData.Ex entries) !camlp5_entries
536	537	in

-1

plugins/ltac/g_tactic.mlg less more

134	134	~hdr:"Constr:mk_cofix_tac"
135	135	(Pp.str"Annotation forbidden in cofix expression.")) ann in
136	136	let bl = List.map (fun (nal,bk,t) -> CLocalAssum (nal,bk,t)) bl in
137		(id,CAst.make ~loc @@ CProdN(bl,ty))
	137	(id,if bl = [] then ty else CAst.make ~loc @@ CProdN(bl,ty))
138	138
139	139	(* Functions overloaded by quotifier *)
140	140	let destruction_arg_of_constr (c,lbind as clbind) = match lbind with

-1

plugins/ltac/pptactic.ml less more

970	970	\| TacTime (s,t) ->
971	971	hov 1 (
972	972	keyword "time"
973		++ pr_opt str s ++ spc ()
	973	++ pr_opt qstring s ++ spc ()
974	974	++ pr_tac (ltactical,E) t),
975	975	ltactical
976	976	\| TacRepeat t ->

-19

plugins/micromega/Lia.v less more

22	22	Declare ML Module "micromega_plugin".
23	23
24	24
25		Ltac zchange checker :=
	25	Ltac zchecker :=
26	26	intros __wit __varmap __ff ;
27		change (@Tauto.eval_bf _ (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
28		apply (checker __ff __wit).
29
30		Ltac zchecker_no_abstract checker :=
31		zchange checker ; vm_compute ; reflexivity.
32
33		Ltac zchecker_abstract checker :=
34		abstract (zchange checker ; vm_cast_no_check (eq_refl true)).
35
36		Ltac zchecker := zchecker_no_abstract ZTautoChecker_sound.
37
38		(Ltac zchecker_ext := zchecker_no_abstract ZTautoCheckerExt_sound.)
39
40		Ltac zchecker_ext :=
41		intros __wit __varmap __ff ;
42		exact (ZTautoCheckerExt_sound __ff __wit
43		(@eq_refl bool true <: @eq bool (ZTautoCheckerExt __ff __wit) true)
	27	exact (ZTautoChecker_sound __ff __wit
	28	(@eq_refl bool true <: @eq bool (ZTautoChecker __ff __wit) true)
44	29	(@find Z Z0 __varmap)).
45	30
46		Ltac lia := PreOmega.zify; xlia zchecker_ext.
	31	Ltac lia := PreOmega.zify; xlia zchecker.
47	32
48	33	Ltac nia := PreOmega.zify; xnlia zchecker.
49	34

-1

plugins/micromega/MExtraction.v less more

55	55	(*Extraction "micromega.ml"
56	56	Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula
57	57	Tauto.abst_form
58		ZMicromega.cnfZ ZMicromega.bound_problem_fr ZMicromega.Zeval_const QMicromega.cnfQ
	58	ZMicromega.cnfZ ZMicromega.Zeval_const QMicromega.cnfQ
59	59	List.map simpl_cone (map_cone indexes)
60	60	denorm Qpower vm_add
61	61	normZ normQ normQ n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find.

-4

plugins/micromega/RMicromega.v less more

16	16	Require Import OrderedRing.
17	17	Require Import RingMicromega.
18	18	Require Import Refl.
19		Require Import Raxioms Rfunctions RIneq Rpow_def DiscrR.
	19	Require Import Raxioms Rfunctions RIneq Rpow_def.
20	20	Require Import QArith.
21	21	Require Import Qfield.
22	22	Require Import Qreals.
23	23	Require Import DeclConstant.
24		Require Import Lia.
	24	Require Import Ztac.
25	25
26	26	Require Setoid.
27	27	(Declare ML Module "micromega_plugin".)

333	333	apply Qeq_bool_eq in C2.
334	334	rewrite C2.
335	335	simpl.
336		rewrite Qpower0 by lia.
	336	rewrite Qpower0.
337	337	apply Q2R_0.
	338	intro ; subst ; slia C1 C1.
338	339	+ rewrite Q2RpowerRZ.
339	340	rewrite IHc.
340	341	reflexivity.
341	342	rewrite andb_false_iff in C.
342	343	destruct C.
343	344	simpl. apply Z.ltb_ge in H.
344		lia.
	345	right ; normZ. slia H H0.
345	346	left ; apply Qeq_bool_neq; auto.
346	347	+ simpl.
347	348	rewrite <- IHc.

-3

plugins/micromega/RingMicromega.v less more

855	855	simpl.
856	856	tauto.
857	857	+
858		rewrite <- eval_cnf_cons_iff with (1:= fun env (term:Formula Z) => True) .
	858	rewrite <- eval_cnf_cons_iff.
859	859	simpl.
860	860	unfold eval_tt. simpl.
861	861	rewrite IHl.

939	939	destruct (check_inconsistent f) eqn:U.
940	940	- destruct f as [e op].
941	941	assert (US := check_inconsistent_sound _ _ U env).
942		rewrite eval_cnf_ff with (1:= eval_nformula).
	942	rewrite eval_cnf_ff.
943	943	tauto.
944	944	- intros. rewrite cnf_of_list_correct.
945	945	now apply xnormalise_correct.

955	955	-
956	956	destruct f as [e o].
957	957	assert (US := check_inconsistent_sound _ _ U env).
958		rewrite eval_cnf_tt with (1:= eval_nformula).
	958	rewrite eval_cnf_tt.
959	959	tauto.
960	960	- rewrite cnf_of_list_correct.
961	961	apply xnegate_correct.

-3

plugins/micromega/Tauto.v less more

937	937	Qed.
938	938
939	939
940		Variable eval : Env -> Term -> Prop.
941
942	940	Variable eval' : Env -> Term' -> Prop.
943	941
944	942	Variable no_middle_eval' : forall env d, (eval' env d) \/ ~ (eval' env d).

1201	1199	Qed.
1202	1200
1203	1201
1204
	1202	Variable eval : Env -> Term -> Prop.
1205	1203
1206	1204	Variable normalise_correct : forall env t tg, eval_cnf env (normalise t tg) -> eval env t.
1207	1205

+474

-480

plugins/micromega/ZMicromega.v less more

17	17	Require Import Bool.
18	18	Require Import OrderedRing.
19	19	Require Import RingMicromega.
20		Require FSetPositive FSetEqProperties.
21	20	Require Import ZCoeff.
22	21	Require Import Refl.
23	22	Require Import ZArith_base.
24	23	Require Import ZArithRing.
	24	Require Import Ztac.
25	25	Require PreOmega.
26	26	(Declare ML Module "micromega_plugin".)
27	27	Local Open Scope Z_scope.

29	29	Ltac flatten_bool :=
30	30	repeat match goal with
31	31	[ id : (_ && _)%bool = true \|- _ ] => destruct (andb_prop _ _ id); clear id
32		\| [ id : (_ \|\| _)%bool = true \|- _ ] => destruct (orb_prop _ _ id); clear id
	32	\| [ id : (_ \|\| _)%bool = true \|- _ ] => destruct (orb_prop _ _ id); clear id
33	33	end.
34	34
35	35	Ltac inv H := inversion H ; try subst ; clear H.

185	185	\| OpGt => Z.gt
186	186	end.
187	187
	188
188	189	Definition Zeval_formula (env : PolEnv Z) (f : Formula Z):=
189	190	let (lhs, op, rhs) := f in
190	191	(Zeval_op2 op) (Zeval_expr env lhs) (Zeval_expr env rhs).

192	193	Definition Zeval_formula' :=
193	194	eval_formula Z.add Z.mul Z.sub Z.opp (@eq Z) Z.le Z.lt (fun x => x) (fun x => x) (pow_N 1 Z.mul).
194	195
195		Lemma Zeval_formula_compat : forall env f, Zeval_formula env f <-> Zeval_formula' env f.
196		Proof.
197		destruct f ; simpl.
198		rewrite Zeval_expr_compat. rewrite Zeval_expr_compat.
	196	Lemma Zeval_formula_compat' : forall env f, Zeval_formula env f <-> Zeval_formula' env f.
	197	Proof.
	198	intros.
	199	unfold Zeval_formula.
	200	destruct f.
	201	repeat rewrite Zeval_expr_compat.
	202	unfold Zeval_formula' ; simpl.
199	203	unfold eval_expr.
200	204	generalize (eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x)
201	205	(fun x : N => x) (pow_N 1 Z.mul) env Flhs).

307	311
308	312	Lemma xnnormalise_correct :
309	313	forall env f,
310		eval_nformula env (xnnormalise f) <-> Zeval_formula env f.
311		Proof.
312		intros.
313		rewrite Zeval_formula_compat.
	314	eval_nformula env (xnnormalise f) <-> Zeval_formula env f.
	315	Proof.
	316	intros.
	317	rewrite Zeval_formula_compat'.
314	318	unfold xnnormalise.
315	319	destruct f as [lhs o rhs].
316	320	destruct o eqn:O ; cbn ; rewrite ?eval_pol_sub;

417	421	specialize (Zunsat_sound _ EQ env).
418	422	tauto.
419	423	+
420		rewrite <- eval_cnf_cons_iff with (1:= fun env (term:Formula Z) => True) .
	424	rewrite <- eval_cnf_cons_iff.
421	425	rewrite IHf.
422	426	simpl.
423	427	unfold E at 2.

438	442	generalize (xnnormalise t) as f;intro.
439	443	destruct (Zunsat f) eqn:U.
440	444	- assert (US := Zunsat_sound _ U env).
441		rewrite eval_cnf_ff with (1:= eval_nformula).
	445	rewrite eval_cnf_ff.
442	446	tauto.
443	447	- rewrite cnf_of_list_correct.
444	448	apply xnormalise_correct.

473	477	- tauto.
474	478	Qed.
475	479
476		Lemma negate_correct : forall T env t (tg:T), eval_cnf eval_nformula env (negate t tg) <-> ~ Zeval_formula env t.
	480	Lemma negate_correct : forall T env t (tg:T), eval_cnf eval_nformula env (negate t tg) <-> ~ Zeval_formula env t.
477	481	Proof.
478	482	intros.
479	483	rewrite <- xnnormalise_correct.

481	485	generalize (xnnormalise t) as f;intro.
482	486	destruct (Zunsat f) eqn:U.
483	487	- assert (US := Zunsat_sound _ U env).
484		rewrite eval_cnf_tt with (1:= eval_nformula).
	488	rewrite eval_cnf_tt.
485	489	tauto.
486	490	- rewrite cnf_of_list_correct.
487	491	apply xnegate_correct.
488	492	Qed.
489	493
490		Definition cnfZ (Annot TX AF : Type) (f : TFormula (Formula Z) Annot TX AF) :=
	494	Definition cnfZ (Annot: Type) (TX : Type) (AF : Type) (f : TFormula (Formula Z) Annot TX AF) :=
491	495	rxcnf Zunsat Zdeduce normalise negate true f.
492	496
493	497	Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z)) : bool :=

554	558	\| RatProof : ZWitness -> ZArithProof -> ZArithProof
555	559	\| CutProof : ZWitness -> ZArithProof -> ZArithProof
556	560	\| EnumProof : ZWitness -> ZWitness -> list ZArithProof -> ZArithProof
557		(\| ExProof : positive -> positive -> positive -> ZArithProof ExProof z t x : exists z t, x = z - t /\ z >= 0 /\ t >= 0 )
	561	\| ExProof : positive -> ZArithProof -> ZArithProof
	562	(ExProof x : exists z t, x = z - t /\ z >= 0 /\ t >= 0 )
558	563	.
559	564	(\| SplitProof : PolC Z -> ZArithProof -> ZArithProof -> ZArithProof.)
560	565

825	830	\| _ => false
826	831	end.
827	832
828		Module Vars.
829		Import FSetPositive.
830		Include PositiveSet.
831
832		Module Facts := FSetEqProperties.EqProperties(PositiveSet).
833
834		Lemma mem_union_l : forall x s s',
835		mem x s = true ->
836		mem x (union s s') = true.
837		Proof.
838		intros.
839		rewrite Facts.union_mem.
840		rewrite H. reflexivity.
841		Qed.
842
843		Lemma mem_union_r : forall x s s',
844		mem x s' = true ->
845		mem x (union s s') = true.
846		Proof.
847		intros.
848		rewrite Facts.union_mem.
849		rewrite H. rewrite orb_comm. reflexivity.
850		Qed.
851
852		Lemma mem_singleton : forall p,
853		mem p (singleton p) = true.
854		Proof.
855		apply Facts.singleton_mem_1.
856		Qed.
857
858		Lemma mem_elements : forall x v,
859		mem x v = true <-> List.In x (PositiveSet.elements v).
860		Proof.
861		intros.
862		rewrite Facts.MP.FM.elements_b.
863		rewrite existsb_exists.
864		unfold Facts.MP.FM.eqb.
865		split ; intros.
866		- destruct H as (x' & IN & EQ).
867		destruct (PositiveSet.E.eq_dec x x') ; try congruence.
868		subst ; auto.
869		- exists x.
870		split ; auto.
871		destruct (PositiveSet.E.eq_dec x x) ; congruence.
872		Qed.
873
874		Definition max_element (vars : t) :=
875		fold Pos.max vars xH.
876
877		Lemma max_element_max :
878		forall x vars, mem x vars = true -> Pos.le x (max_element vars).
879		Proof.
880		unfold max_element.
881		intros.
882		rewrite mem_elements in H.
883		rewrite PositiveSet.fold_1.
884		set (F := (fun (a : positive) (e : PositiveSet.elt) => Pos.max e a)).
885		revert H.
886		assert (((x <= 1 -> x <= fold_left F (PositiveSet.elements vars) 1)
887		/\
888		(List.In x (PositiveSet.elements vars) ->
889		x <= fold_left F (PositiveSet.elements vars) 1))%positive).
890		{
891		revert x.
892		generalize xH as acc.
893		induction (PositiveSet.elements vars).
894		- simpl. tauto.
895		- simpl.
896		intros.
897		destruct (IHl (F acc a) x).
898		split ; intros.
899		apply H.
900		unfold F.
901		rewrite Pos.max_le_iff.
902		tauto.
903		destruct H1 ; subst.
904		apply H.
905		unfold F.
906		rewrite Pos.max_le_iff.
907		simpl.
908		left.
909		apply Pos.le_refl.
910		tauto.
911		}
912		tauto.
913		Qed.
914
915		Definition is_subset (v1 v2 : t) :=
916		forall x, mem x v1 = true -> mem x v2 = true.
917
918		Lemma is_subset_union_l : forall v1 v2,
919		is_subset v1 (union v1 v2).
920		Proof.
921		unfold is_subset.
922		intros.
923		apply mem_union_l; auto.
924		Qed.
925
926		Lemma is_subset_union_r : forall v1 v2,
927		is_subset v1 (union v2 v1).
928		Proof.
929		unfold is_subset.
930		intros.
931		apply mem_union_r; auto.
932		Qed.
933
934
935		End Vars.
936
937
938		Fixpoint vars_of_pexpr (e : PExpr Z) : Vars.t :=
939		match e with
940		\| PEc _ => Vars.empty
941		\| PEX x => Vars.singleton x
942		\| PEadd e1 e2 \| PEsub e1 e2 \| PEmul e1 e2 =>
943		let v1 := vars_of_pexpr e1 in
944		let v2 := vars_of_pexpr e2 in
945		Vars.union v1 v2
946		\| PEopp c => vars_of_pexpr c
947		\| PEpow e n => vars_of_pexpr e
948		end.
949
950		Definition vars_of_formula (f : Formula Z) :=
951		match f with
952		\| Build_Formula l o r =>
953		let v1 := vars_of_pexpr l in
954		let v2 := vars_of_pexpr r in
955		Vars.union v1 v2
956		end.
957
958		Fixpoint vars_of_bformula {TX : Type} {TG : Type} {ID : Type}
959		(F : @GFormula (Formula Z) TX TG ID) : Vars.t :=
960		match F with
961		\| TT => Vars.empty
962		\| FF => Vars.empty
963		\| X p => Vars.empty
964		\| A a t => vars_of_formula a
965		\| Cj f1 f2 \| D f1 f2 \| I f1 _ f2 =>
966		let v1 := vars_of_bformula f1 in
967		let v2 := vars_of_bformula f2 in
968		Vars.union v1 v2
969		\| Tauto.N f => vars_of_bformula f
970		end.
971	833
972	834	Definition bound_var (v : positive) : Formula Z :=
973	835	Build_Formula (PEX v) OpGe (PEc 0).

975	837	Definition mk_eq_pos (x : positive) (y:positive) (t : positive) : Formula Z :=
976	838	Build_Formula (PEX x) OpEq (PEsub (PEX y) (PEX t)).
977	839
978		Section BOUND.
979		Context {TX TG ID : Type}.
980
981		Variable tag_of_var : positive -> positive -> option bool -> TG.
982
983		Definition bound_vars (fr : positive)
984		(v : Vars.t) : @GFormula (Formula Z) TX TG ID :=
985		Vars.fold (fun k acc =>
986		let y := (xO (fr + k)) in
987		let z := (xI (fr + k)) in
988		Cj
989		(Cj (A (mk_eq_pos k y z) (tag_of_var fr k None))
990		(Cj (A (bound_var y) (tag_of_var fr k (Some false)))
991		(A (bound_var z) (tag_of_var fr k (Some true)))))
992		acc) v TT.
993
994		Definition bound_problem (F : @GFormula (Formula Z) TX TG ID) : GFormula :=
995		let v := vars_of_bformula F in
996		I (bound_vars (Pos.succ (Vars.max_element v)) v) None F.
997
998
999		Definition bound_problem_fr (fr : positive) (F : @GFormula (Formula Z) TX TG ID) : GFormula :=
1000		let v := vars_of_bformula F in
1001		I (bound_vars fr v) None F.
1002
1003
1004		End BOUND.
1005
1006
1007
1008		Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool :=
	840
	841	Fixpoint vars (jmp : positive) (p : Pol Z) : list positive :=
	842	match p with
	843	\| Pc c => nil
	844	\| Pinj j p => vars (Pos.add j jmp) p
	845	\| PX p j q => jmp::(vars jmp p)++vars (Pos.succ jmp) q
	846	end.
	847
	848	Fixpoint max_var (jmp : positive) (p : Pol Z) : positive :=
	849	match p with
	850	\| Pc _ => jmp
	851	\| Pinj j p => max_var (Pos.add j jmp) p
	852	\| PX p j q => Pos.max (max_var jmp p) (max_var (Pos.succ jmp) q)
	853	end.
	854
	855	Lemma pos_le_add : forall y x,
	856	(x <= y + x)%positive.
	857	Proof.
	858	intros.
	859	assert ((Z.pos x) <= Z.pos (x + y))%Z.
	860	rewrite <- (Z.add_0_r (Zpos x)).
	861	rewrite <- Pos2Z.add_pos_pos.
	862	apply Z.add_le_mono_l.
	863	compute. congruence.
	864	rewrite Pos.add_comm in H.
	865	apply H.
	866	Qed.
	867
	868
	869	Lemma max_var_le : forall p v,
	870	(v <= max_var v p)%positive.
	871	Proof.
	872	induction p; simpl.
	873	- intros.
	874	apply Pos.le_refl.
	875	- intros.
	876	specialize (IHp (p+v)%positive).
	877	eapply Pos.le_trans ; eauto.
	878	assert (xH + v <= p + v)%positive.
	879	{ apply Pos.add_le_mono.
	880	apply Pos.le_1_l.
	881	apply Pos.le_refl.
	882	}
	883	eapply Pos.le_trans ; eauto.
	884	apply pos_le_add.
	885	- intros.
	886	apply Pos.max_case_strong;intros ; auto.
	887	specialize (IHp2 (Pos.succ v)%positive).
	888	eapply Pos.le_trans ; eauto.
	889	Qed.
	890
	891	Lemma max_var_correct : forall p j v,
	892	In v (vars j p) -> Pos.le v (max_var j p).
	893	Proof.
	894	induction p; simpl.
	895	- tauto.
	896	- auto.
	897	- intros.
	898	rewrite in_app_iff in H.
	899	destruct H as [H \|[ H \| H]].
	900	+ subst.
	901	apply Pos.max_case_strong;intros ; auto.
	902	apply max_var_le.
	903	eapply Pos.le_trans ; eauto.
	904	apply max_var_le.
	905	+ apply Pos.max_case_strong;intros ; auto.
	906	eapply Pos.le_trans ; eauto.
	907	+ apply Pos.max_case_strong;intros ; auto.
	908	eapply Pos.le_trans ; eauto.
	909	Qed.
	910
	911	Definition max_var_nformulae (l : list (NFormula Z)) :=
	912	List.fold_left (fun acc f => Pos.max acc (max_var xH (fst f))) l xH.
	913
	914	Section MaxVar.
	915
	916	Definition F (acc : positive) (f : Pol Z * Op1) := Pos.max acc (max_var 1 (fst f)).
	917
	918	Lemma max_var_nformulae_mono_aux :
	919	forall l v acc,
	920	(v <= acc ->
	921	v <= fold_left F l acc)%positive.
	922	Proof.
	923	induction l ; simpl ; [easy\|].
	924	intros.
	925	apply IHl.
	926	unfold F.
	927	apply Pos.max_case_strong;intros ; auto.
	928	eapply Pos.le_trans ; eauto.
	929	Qed.
	930
	931	Lemma max_var_nformulae_mono_aux' :
	932	forall l acc acc',
	933	(acc <= acc' ->
	934	fold_left F l acc <= fold_left F l acc')%positive.
	935	Proof.
	936	induction l ; simpl ; [easy\|].
	937	intros.
	938	apply IHl.
	939	unfold F.
	940	apply Pos.max_le_compat_r; auto.
	941	Qed.
	942
	943
	944
	945
	946	Lemma max_var_nformulae_correct_aux : forall l p o v,
	947	In (p,o) l -> In v (vars xH p) -> Pos.le v (fold_left F l 1)%positive.
	948	Proof.
	949	intros.
	950	generalize 1%positive as acc.
	951	revert p o v H H0.
	952	induction l.
	953	- simpl. tauto.
	954	- simpl.
	955	intros.
	956	destruct H ; subst.
	957	+ unfold F at 2.
	958	simpl.
	959	apply max_var_correct in H0.
	960	apply max_var_nformulae_mono_aux.
	961	apply Pos.max_case_strong;intros ; auto.
	962	eapply Pos.le_trans ; eauto.
	963	+ eapply IHl ; eauto.
	964	Qed.
	965
	966	End MaxVar.
	967
	968	Lemma max_var_nformalae_correct : forall l p o v,
	969	In (p,o) l -> In v (vars xH p) -> Pos.le v (max_var_nformulae l)%positive.
	970	Proof.
	971	intros l p o v.
	972	apply max_var_nformulae_correct_aux.
	973	Qed.
	974
	975
	976	Fixpoint max_var_psatz (w : Psatz Z) : positive :=
	977	match w with
	978	\| PsatzIn _ n => xH
	979	\| PsatzSquare p => max_var xH (Psquare 0 1 Z.add Z.mul Zeq_bool p)
	980	\| PsatzMulC p w => Pos.max (max_var xH p) (max_var_psatz w)
	981	\| PsatzMulE w1 w2 => Pos.max (max_var_psatz w1) (max_var_psatz w2)
	982	\| PsatzAdd w1 w2 => Pos.max (max_var_psatz w1) (max_var_psatz w2)
	983	\| _ => xH
	984	end.
	985
	986	Fixpoint max_var_prf (w : ZArithProof) : positive :=
	987	match w with
	988	\| DoneProof => xH
	989	\| RatProof w pf \| CutProof w pf => Pos.max (max_var_psatz w) (max_var_prf pf)
	990	\| EnumProof w1 w2 l => List.fold_left (fun acc prf => Pos.max acc (max_var_prf prf)) l
	991	(Pos.max (max_var_psatz w1) (max_var_psatz w2))
	992	\| ExProof _ pf => max_var_prf pf
	993	end.
	994
	995
	996
	997	Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool :=
1009	998	match pf with
1010	999	\| DoneProof => false
1011	1000	\| RatProof w pf =>

1024	1013	\| Some cp => ZChecker (nformula_of_cutting_plane cp::l) pf
1025	1014	end
1026	1015	end
1027		(* \| SplitProof e pf1 pf2 =>
1028		match ZChecker ((e,NonStrict)::l) pf1 , ZChecker ((
1029		*)
1030
1031		\| EnumProof w1 w2 pf =>
	1016	\| ExProof x prf =>
	1017	let fr := max_var_nformulae l in
	1018	if Pos.leb x fr then
	1019	let z := Pos.succ fr in
	1020	let t := Pos.succ z in
	1021	let nfx := xnnormalise (mk_eq_pos x z t) in
	1022	let posz := xnnormalise (bound_var z) in
	1023	let post := xnnormalise (bound_var t) in
	1024	ZChecker (nfx::posz::post::l) prf
	1025	else false
	1026	\| EnumProof w1 w2 pf =>
1032	1027	match eval_Psatz l w1 , eval_Psatz l w2 with
1033	1028	\| Some f1 , Some f2 =>
1034	1029	match genCuttingPlane f1 , genCuttingPlane f2 with

1039	1034	fun lb ub =>
1040	1035	match pfs with
1041	1036	\| nil => if Z.gtb lb ub then true else false
1042		\| pf::rsr => andb (ZChecker ((psub e1 (Pc lb), Equal) :: l) pf) (label rsr (Z.add lb 1%Z) ub)
	1037	\| pf::rsr => andb (ZChecker ((psub e1 (Pc lb), Equal) :: l) pf) (label rsr (Z.add lb 1%Z) ub)
1043	1038	end) pf (Z.opp z1) z2
1044	1039	else false
1045	1040	\| _ , _ => true

1056	1051	\| RatProof _ p => S (bdepth p)
1057	1052	\| CutProof _ p => S (bdepth p)
1058	1053	\| EnumProof _ _ l => S (List.fold_right (fun pf x => Nat.max (bdepth pf) x) O l)
	1054	\| ExProof _ p => S (bdepth p)
1059	1055	end.
1060	1056
1061	1057	Require Import Wf_nat.

1245	1241	destruct (makeCuttingPlane p) ; discriminate.
1246	1242	Qed.
1247	1243
1248
1249		Lemma ZChecker_sound : forall w l, ZChecker l w = true -> forall env, make_impl (eval_nformula env) l False.
	1244	Lemma eval_nformula_mk_eq_pos : forall env x z t,
	1245	env x = env z - env t ->
	1246	eval_nformula env (xnnormalise (mk_eq_pos x z t)).
	1247	Proof.
	1248	intros.
	1249	rewrite xnnormalise_correct.
	1250	simpl. auto.
	1251	Qed.
	1252
	1253	Lemma eval_nformula_bound_var : forall env x,
	1254	env x >= 0 ->
	1255	eval_nformula env (xnnormalise (bound_var x)).
	1256	Proof.
	1257	intros.
	1258	rewrite xnnormalise_correct.
	1259	simpl. auto.
	1260	Qed.
	1261
	1262
	1263	Definition agree_env (fr : positive) (env env' : positive -> Z) : Prop :=
	1264	forall x, Pos.le x fr -> env x = env' x.
	1265
	1266	Lemma agree_env_subset : forall v1 v2 env env',
	1267	agree_env v1 env env' ->
	1268	Pos.le v2 v1 ->
	1269	agree_env v2 env env'.
	1270	Proof.
	1271	unfold agree_env.
	1272	intros.
	1273	apply H.
	1274	eapply Pos.le_trans ; eauto.
	1275	Qed.
	1276
	1277
	1278	Lemma agree_env_jump : forall fr j env env',
	1279	agree_env (fr + j) env env' ->
	1280	agree_env fr (Env.jump j env) (Env.jump j env').
	1281	Proof.
	1282	intros.
	1283	unfold agree_env ; intro.
	1284	intros.
	1285	unfold Env.jump.
	1286	apply H.
	1287	apply Pos.add_le_mono_r; auto.
	1288	Qed.
	1289
	1290
	1291	Lemma agree_env_tail : forall fr env env',
	1292	agree_env (Pos.succ fr) env env' ->
	1293	agree_env fr (Env.tail env) (Env.tail env').
	1294	Proof.
	1295	intros.
	1296	unfold Env.tail.
	1297	apply agree_env_jump.
	1298	rewrite <- Pos.add_1_r in H.
	1299	apply H.
	1300	Qed.
	1301
	1302
	1303	Lemma max_var_acc : forall p i j,
	1304	(max_var (i + j) p = max_var i p + j)%positive.
	1305	Proof.
	1306	induction p; simpl.
	1307	- reflexivity.
	1308	- intros.
	1309	rewrite ! IHp.
	1310	rewrite Pos.add_assoc.
	1311	reflexivity.
	1312	- intros.
	1313	rewrite !Pplus_one_succ_l.
	1314	rewrite ! IHp1.
	1315	rewrite ! IHp2.
	1316	rewrite ! Pos.add_assoc.
	1317	rewrite <- Pos.add_max_distr_r.
	1318	reflexivity.
	1319	Qed.
	1320
	1321
	1322
	1323	Lemma agree_env_eval_nformula :
	1324	forall env env' e
	1325	(AGREE : agree_env (max_var xH (fst e)) env env'),
	1326	eval_nformula env e <-> eval_nformula env' e.
	1327	Proof.
	1328	destruct e.
	1329	simpl; intros.
	1330	assert ((RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x) env p)
	1331	=
	1332	(RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x) env' p)).
	1333	{
	1334	revert env env' AGREE.
	1335	generalize xH.
	1336	induction p ; simpl.
	1337	- reflexivity.
	1338	- intros.
	1339	apply IHp with (p := p1%positive).
	1340	apply agree_env_jump.
	1341	eapply agree_env_subset; eauto.
	1342	rewrite (Pos.add_comm p).
	1343	rewrite max_var_acc.
	1344	apply Pos.le_refl.
	1345	- intros.
	1346	f_equal.
	1347	f_equal.
	1348	{ apply IHp1 with (p:= p).
	1349	eapply agree_env_subset; eauto.
	1350	apply Pos.le_max_l.
	1351	}
	1352	f_equal.
	1353	{ unfold Env.hd.
	1354	unfold Env.nth.
	1355	apply AGREE.
	1356	apply Pos.le_1_l.
	1357	}
	1358	{
	1359	apply IHp2 with (p := p).
	1360	apply agree_env_tail.
	1361	eapply agree_env_subset; eauto.
	1362	rewrite !Pplus_one_succ_r.
	1363	rewrite max_var_acc.
	1364	apply Pos.le_max_r.
	1365	}
	1366	}
	1367	rewrite H. tauto.
	1368	Qed.
	1369
	1370	Lemma agree_env_eval_nformulae :
	1371	forall env env' l
	1372	(AGREE : agree_env (max_var_nformulae l) env env'),
	1373	make_conj (eval_nformula env) l <->
	1374	make_conj (eval_nformula env') l.
	1375	Proof.
	1376	induction l.
	1377	- simpl. tauto.
	1378	- intros.
	1379	rewrite ! make_conj_cons.
	1380	assert (eval_nformula env a <-> eval_nformula env' a).
	1381	{
	1382	apply agree_env_eval_nformula.
	1383	eapply agree_env_subset ; eauto.
	1384	unfold max_var_nformulae.
	1385	simpl.
	1386	rewrite Pos.max_1_l.
	1387	apply max_var_nformulae_mono_aux.
	1388	apply Pos.le_refl.
	1389	}
	1390	rewrite H.
	1391	apply and_iff_compat_l.
	1392	apply IHl.
	1393	eapply agree_env_subset ; eauto.
	1394	unfold max_var_nformulae.
	1395	simpl.
	1396	apply max_var_nformulae_mono_aux'.
	1397	apply Pos.le_1_l.
	1398	Qed.
	1399
	1400
	1401	Lemma eq_true_iff_eq :
	1402	forall b1 b2 : bool, (b1 = true <-> b2 = true) <-> b1 = b2.
	1403	Proof.
	1404	destruct b1,b2 ; intuition congruence.
	1405	Qed.
	1406
	1407	Ltac pos_tac :=
	1408	repeat
	1409	match goal with
	1410	\| \|- false = _ => symmetry
	1411	\| \|- Pos.eqb ?X ?Y = false => rewrite Pos.eqb_neq ; intro
	1412	\| H : @eq positive ?X ?Y \|- _ => apply Zpos_eq in H
	1413	\| H : context[Z.pos (Pos.succ ?X)] \|- _ => rewrite (Pos2Z.inj_succ X) in H
	1414	\| H : Pos.leb ?X ?Y = true \|- _ => rewrite Pos.leb_le in H ;
	1415	apply (Pos2Z.pos_le_pos X Y) in H
	1416	end.
	1417
	1418	Lemma ZChecker_sound : forall w l,
	1419	ZChecker l w = true -> forall env, make_impl (eval_nformula env) l False.
1250	1420	Proof.
1251	1421	induction w using (well_founded_ind (well_founded_ltof _ bdepth)).
1252		destruct w as [ \| w pf \| w pf \| w1 w2 pf].
1253		(* DoneProof *)
	1422	destruct w as [ \| w pf \| w pf \| w1 w2 pf \| x pf].
	1423	- (* DoneProof *)
1254	1424	simpl. discriminate.
1255		(* RatProof *)
1256		simpl.
1257		intro l. case_eq (eval_Psatz l w) ; [\| discriminate].
	1425	- (* RatProof *)
	1426	simpl.
	1427	intros l. case_eq (eval_Psatz l w) ; [\| discriminate].
1258	1428	intros f Hf.
1259	1429	case_eq (Zunsat f).
1260	1430	intros.

1275	1445	apply H2.
1276	1446	split ; auto.
1277	1447	apply eval_Psatz_sound with (2:= Hf) ; assumption.
1278		(* CutProof *)
1279		simpl.
1280		intro l.
	1448	- (* CutProof *)
	1449	simpl.
	1450	intros l.
1281	1451	case_eq (eval_Psatz l w) ; [ \| discriminate].
1282	1452	intros f' Hlc.
1283	1453	case_eq (genCuttingPlane f').
1284	1454	intros.
1285	1455	assert (make_impl (eval_nformula env) (nformula_of_cutting_plane p::l) False).
1286		eapply (H pf) ; auto.
	1456	eapply (H pf) ; auto.
1287	1457	unfold ltof.
1288	1458	simpl.
1289	1459	auto with arith.

1302	1472	intros.
1303	1473	apply eval_Psatz_sound with (2:= Hlc) in H2.
1304	1474	apply genCuttingPlaneNone with (2:= H2) ; auto.
1305		(* EnumProof *)
1306		intro.
	1475	- (* EnumProof *)
	1476	intros l.
1307	1477	simpl.
1308	1478	case_eq (eval_Psatz l w1) ; [ \| discriminate].
1309	1479	case_eq (eval_Psatz l w2) ; [ \| discriminate].

1358	1528	intros.
1359	1529	assert (HH :forall x, -z1 <= x <= z2 -> exists pr,
1360	1530	(In pr pf /\
1361		ZChecker ((PsubC Z.sub p1 x,Equal) :: l) pr = true)%Z).
	1531	ZChecker ((PsubC Z.sub p1 x,Equal) :: l) pr = true)%Z).
1362	1532	clear HZ0 Hop1 Hop2 HCutL HCutR H0 H1.
1363	1533	revert Hfix.
1364	1534	generalize (-z1). clear z1. intro z1.

1385	1555	(/asser )
1386	1556	destruct (HH _ H1) as [pr [Hin Hcheker]].
1387	1557	assert (make_impl (eval_nformula env) ((PsubC Z.sub p1 (eval_pol env p1),Equal) :: l) False).
1388		apply (H pr);auto.
	1558	eapply (H pr) ;auto.
1389	1559	apply in_bdepth ; auto.
1390	1560	rewrite <- make_conj_impl in H2.
1391	1561	apply H2.

1409	1579	intros.
1410	1580	apply eval_Psatz_sound with (2:= Hf2) in H2.
1411	1581	apply genCuttingPlaneNone with (2:= H2) ; auto.
	1582	- intros l.
	1583	unfold ZChecker.
	1584	fold ZChecker.
	1585	set (fr := (max_var_nformulae l)%positive).
	1586	set (z1 := (Pos.succ fr)) in *.
	1587	set (t1 := (Pos.succ z1)) in *.
	1588	destruct (x <=? fr)%positive eqn:LE ; [\|congruence].
	1589	intros.
	1590	set (env':= fun v => if Pos.eqb v z1
	1591	then if Z.leb (env x) 0 then 0 else env x
	1592	else if Pos.eqb v t1
	1593	then if Z.leb (env x) 0 then -(env x) else 0
	1594	else env v).
	1595	apply H with (env:=env') in H0.
	1596	+ rewrite <- make_conj_impl in *.
	1597	intro.
	1598	rewrite !make_conj_cons in H0.
	1599	apply H0 ; repeat split.
	1600	*
	1601	apply eval_nformula_mk_eq_pos.
	1602	unfold env'.
	1603	rewrite! Pos.eqb_refl.
	1604	replace (x=?z1)%positive with false.
	1605	replace (x=?t1)%positive with false.
	1606	replace (t1=?z1)%positive with false.
	1607	destruct (env x <=? 0); ring.
	1608	{ unfold t1.
	1609	pos_tac; normZ.
	1610	lia (Hyp H2).
	1611	}
	1612	{
	1613	unfold t1, z1.
	1614	pos_tac; normZ.
	1615	lia (Add (Hyp LE) (Hyp H3)).
	1616	}
	1617	{
	1618	unfold z1.
	1619	pos_tac; normZ.
	1620	lia (Add (Hyp LE) (Hyp H3)).
	1621	}
	1622	*
	1623	apply eval_nformula_bound_var.
	1624	unfold env'.
	1625	rewrite! Pos.eqb_refl.
	1626	destruct (env x <=? 0) eqn:EQ.
	1627	compute. congruence.
	1628	rewrite Z.leb_gt in EQ.
	1629	normZ.
	1630	lia (Add (Hyp EQ) (Hyp H2)).
	1631	*
	1632	apply eval_nformula_bound_var.
	1633	unfold env'.
	1634	rewrite! Pos.eqb_refl.
	1635	replace (t1 =? z1)%positive with false.
	1636	destruct (env x <=? 0) eqn:EQ.
	1637	rewrite Z.leb_le in EQ.
	1638	normZ.
	1639	lia (Add (Hyp EQ) (Hyp H2)).
	1640	compute; congruence.
	1641	unfold t1.
	1642	clear.
	1643	pos_tac; normZ.
	1644	lia (Hyp H).
	1645	*
	1646	rewrite agree_env_eval_nformulae with (env':= env') in H1;auto.
	1647	unfold agree_env; intros.
	1648	unfold env'.
	1649	replace (x0 =? z1)%positive with false.
	1650	replace (x0 =? t1)%positive with false.
	1651	reflexivity.
	1652	{
	1653	unfold t1, z1.
	1654	unfold fr in *.
	1655	apply Pos2Z.pos_le_pos in H2.
	1656	pos_tac; normZ.
	1657	lia (Add (Hyp H2) (Hyp H4)).
	1658	}
	1659	{
	1660	unfold z1, fr in *.
	1661	apply Pos2Z.pos_le_pos in H2.
	1662	pos_tac; normZ.
	1663	lia (Add (Hyp H2) (Hyp H4)).
	1664	}
	1665	+ unfold ltof.
	1666	simpl.
	1667	apply Nat.lt_succ_diag_r.
1412	1668	Qed.
1413	1669
1414	1670

1416	1672	Definition ZTautoChecker (f : BFormula (Formula Z)) (w: list ZArithProof): bool :=
1417	1673	@tauto_checker (Formula Z) (NFormula Z) unit Zunsat Zdeduce normalise negate ZArithProof (fun cl => ZChecker (List.map fst cl)) f w.
1418	1674
1419		Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_f (fun x => x) (Zeval_formula env) f.
	1675	Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_bf (Zeval_formula env) f.
1420	1676	Proof.
1421	1677	intros f w.
1422	1678	unfold ZTautoChecker.

1429	1685	- unfold Zdeduce. intros. revert H.
1430	1686	apply (nformula_plus_nformula_correct Zsor ZSORaddon); auto.
1431	1687	-
1432		intros env t tg.
1433		rewrite normalise_correct ; auto.
	1688	intros.
	1689	rewrite normalise_correct in H.
	1690	auto.
1434	1691	-
1435		intros env t tg.
1436		rewrite negate_correct ; auto.
	1692	intros.
	1693	rewrite negate_correct in H ; auto.
1437	1694	- intros t w0.
1438	1695	unfold eval_tt.
1439	1696	intros.

1442	1699	tauto.
1443	1700	Qed.
1444	1701
1445		Record is_diff_env_elt (fr : positive) (env env' : positive -> Z) (x:positive):=
1446		{
1447		eq_env : env x = env' x;
1448		eq_diff : env x = env' (xO (fr+ x)) - env' (xI (fr + x));
1449		pos_xO : env' (xO (fr+x)) >= 0;
1450		pos_xI : env' (xI (fr+x)) >= 0;
1451		}.
1452
1453
1454		Definition is_diff_env (s : Vars.t) (env env' : positive -> Z) :=
1455		let fr := Pos.succ (Vars.max_element s) in
1456		forall x, Vars.mem x s = true ->
1457		is_diff_env_elt fr env env' x.
1458
1459		Definition mk_diff_env (s : Vars.t) (env : positive -> Z) :=
1460		let fr := Vars.max_element s in
1461		fun x =>
1462		if Pos.leb x fr
1463		then env x
1464		else
1465		let fr' := Pos.succ fr in
1466		match x with
1467		\| xO x => if Z.leb (env (x - fr')%positive) 0
1468		then 0 else env (x -fr')%positive
1469		\| xI x => if Z.leb (env (x - fr')%positive) 0
1470		then - (env (x - fr')%positive) else 0
1471		\| xH => 0
1472		end.
1473
1474		Lemma le_xO : forall x, (x <= xO x)%positive.
1475		Proof.
1476		intros.
1477		change x with (1 * x)%positive at 1.
1478		change (xO x) with (2 * x)%positive.
1479		apply Pos.mul_le_mono.
1480		compute. congruence.
1481		apply Pos.le_refl.
1482		Qed.
1483
1484		Lemma leb_xO_false :
1485		(forall x y, x <=? y = false ->
1486		xO x <=? y = false)%positive.
1487		Proof.
1488		intros.
1489		rewrite Pos.leb_nle in *.
1490		intro. apply H.
1491		eapply Pos.le_trans ; eauto.
1492		apply le_xO.
1493		Qed.
1494
1495		Lemma leb_xI_false :
1496		(forall x y, x <=? y = false ->
1497		xI x <=? y = false)%positive.
1498		Proof.
1499		intros.
1500		rewrite Pos.leb_nle in *.
1501		intro. apply H.
1502		eapply Pos.le_trans ; eauto.
1503		generalize (le_xO x).
1504		intros.
1505		eapply Pos.le_trans ; eauto.
1506		change (xI x) with (Pos.succ (xO x))%positive.
1507		apply Pos.lt_le_incl.
1508		apply Pos.lt_succ_diag_r.
1509		Qed.
1510
1511		Lemma is_diff_env_ex : forall s env,
1512		is_diff_env s env (mk_diff_env s env).
1513		Proof.
1514		intros.
1515		unfold is_diff_env, mk_diff_env.
1516		intros.
1517		assert
1518		((Pos.succ (Vars.max_element s) + x <=? Vars.max_element s = false)%positive).
1519		{
1520		rewrite Pos.leb_nle.
1521		intro.
1522		eapply (Pos.lt_irrefl (Pos.succ (Vars.max_element s) + x)).
1523		eapply Pos.le_lt_trans ; eauto.
1524		generalize (Pos.lt_succ_diag_r (Vars.max_element s)).
1525		intro.
1526		eapply Pos.lt_trans ; eauto.
1527		apply Pos.lt_add_r.
1528		}
1529		constructor.
1530		- apply Vars.max_element_max in H.
1531		rewrite <- Pos.leb_le in H.
1532		rewrite H. auto.
1533		-
1534		rewrite leb_xO_false by auto.
1535		rewrite leb_xI_false by auto.
1536		rewrite Pos.add_comm.
1537		rewrite Pos.add_sub.
1538		destruct (env x <=? 0); ring.
1539		- rewrite leb_xO_false by auto.
1540		rewrite Pos.add_comm.
1541		rewrite Pos.add_sub.
1542		destruct (env x <=? 0) eqn:EQ.
1543		apply Z.le_ge.
1544		apply Z.le_refl.
1545		rewrite Z.leb_gt in EQ.
1546		apply Z.le_ge.
1547		apply Z.lt_le_incl.
1548		auto.
1549		- rewrite leb_xI_false by auto.
1550		rewrite Pos.add_comm.
1551		rewrite Pos.add_sub.
1552		destruct (env x <=? 0) eqn:EQ.
1553		rewrite Z.leb_le in EQ.
1554		apply Z.le_ge.
1555		apply Z.opp_nonneg_nonpos; auto.
1556		apply Z.le_ge.
1557		apply Z.le_refl.
1558		Qed.
1559
1560		Lemma env_bounds : forall tg env s,
1561		let fr := Pos.succ (Vars.max_element s) in
1562		exists env', is_diff_env s env env'
1563		/\
1564		eval_bf (Zeval_formula env') (bound_vars tg fr s).
1565		Proof.
1566		intros.
1567		assert (DIFF:=is_diff_env_ex s env).
1568		exists (mk_diff_env s env). split ; auto.
1569		unfold bound_vars.
1570		rewrite FSetPositive.PositiveSet.fold_1.
1571		revert DIFF.
1572		set (env' := mk_diff_env s env).
1573		intro.
1574		assert (ACC : eval_bf (Zeval_formula env') TT ).
1575		{
1576		simpl. auto.
1577		}
1578		revert ACC.
1579		match goal with
1580		\| \|- context[@TT ?A ?B ?C ?D] => generalize (@TT A B C D) as acc
1581		end.
1582		unfold is_diff_env in DIFF.
1583		assert (DIFFL : forall x, In x (FSetPositive.PositiveSet.elements s) ->
1584		(x < fr)%positive /\
1585		is_diff_env_elt fr env env' x).
1586		{
1587		intros.
1588		rewrite <- Vars.mem_elements in H.
1589		split.
1590		apply Vars.max_element_max in H.
1591		unfold fr in *.
1592		eapply Pos.le_lt_trans ; eauto.
1593		apply Pos.lt_succ_diag_r.
1594		apply DIFF; auto.
1595		}
1596		clear DIFF.
1597		match goal with
1598		\| \|- context[fold_left ?F _ _] =>
1599		set (FUN := F)
1600		end.
1601		induction (FSetPositive.PositiveSet.elements s).
1602		- simpl; auto.
1603		- simpl.
1604		intros.
1605		eapply IHl ; eauto.
1606		+ intros. apply DIFFL.
1607		simpl ; auto.
1608		+ unfold FUN.
1609		simpl.
1610		split ; auto.
1611		assert (HYP : (a < fr /\ is_diff_env_elt fr env env' a)%positive).
1612		{
1613		apply DIFFL.
1614		simpl. tauto.
1615		}
1616		destruct HYP as (LT & DIFF).
1617		destruct DIFF.
1618		rewrite <- eq_env0.
1619		tauto.
1620		Qed.
1621
1622		Definition agree_env (v : Vars.t) (env env' : positive -> Z) : Prop :=
1623		forall x, Vars.mem x v = true -> env x = env' x.
1624
1625		Lemma agree_env_subset : forall s1 s2 env env',
1626		agree_env s1 env env' ->
1627		Vars.is_subset s2 s1 ->
1628		agree_env s2 env env'.
1629		Proof.
1630		unfold agree_env.
1631		intros.
1632		apply H. apply H0; auto.
1633		Qed.
1634
1635		Lemma agree_env_union : forall s1 s2 env env',
1636		agree_env (Vars.union s1 s2) env env' ->
1637		agree_env s1 env env' /\ agree_env s2 env env'.
1638		Proof.
1639		split;
1640		eapply agree_env_subset; eauto.
1641		apply Vars.is_subset_union_l.
1642		apply Vars.is_subset_union_r.
1643		Qed.
1644
1645
1646
1647		Lemma agree_env_eval_expr :
1648		forall env env' e
1649		(AGREE : agree_env (vars_of_pexpr e) env env'),
1650		Zeval_expr env e = Zeval_expr env' e.
1651		Proof.
1652		induction e; simpl;intros;
1653		try (apply agree_env_union in AGREE; destruct AGREE); try f_equal ; auto.
1654		- intros ; apply AGREE.
1655		apply Vars.mem_singleton.
1656		Qed.
1657
1658		Lemma agree_env_eval_bf :
1659		forall env env' f
1660		(AGREE: agree_env (vars_of_bformula f) env env'),
1661		eval_bf (Zeval_formula env') f <->
1662		eval_bf (Zeval_formula env) f.
1663		Proof.
1664		induction f; simpl; intros ;
1665		try (apply agree_env_union in AGREE; destruct AGREE) ; try intuition fail.
1666		-
1667		unfold Zeval_formula.
1668		destruct t.
1669		simpl in * ; intros.
1670		apply agree_env_union in AGREE ; destruct AGREE.
1671		rewrite <- agree_env_eval_expr with (env:=env) by auto.
1672		rewrite <- agree_env_eval_expr with (e:= Frhs) (env:=env) by auto.
1673		tauto.
1674		Qed.
1675
1676		Lemma bound_problem_sound : forall tg f,
1677		(forall env' : PolEnv Z,
1678		eval_bf (Zeval_formula env')
1679		(bound_problem tg f)) ->
1680		forall env,
1681		eval_bf (Zeval_formula env) f.
1682		Proof.
1683		intros.
1684		unfold bound_problem in H.
1685		destruct (env_bounds tg env (vars_of_bformula f))
1686		as (env' & DIFF & EVAL).
1687		simpl in H.
1688		apply H in EVAL.
1689		eapply agree_env_eval_bf ; eauto.
1690		unfold is_diff_env, agree_env in *.
1691		intros.
1692		apply DIFF in H0.
1693		destruct H0.
1694		intuition.
1695		Qed.
1696
1697
1698
1699		Definition ZTautoCheckerExt (f : BFormula (Formula Z)) (w : list ZArithProof) : bool :=
1700		ZTautoChecker (bound_problem (fun _ _ _ => tt) f) w.
1701
1702		Lemma ZTautoCheckerExt_sound : forall f w, ZTautoCheckerExt f w = true -> forall env, eval_bf (Zeval_formula env) f.
1703		Proof.
1704		intros.
1705		unfold ZTautoCheckerExt in H.
1706		specialize (ZTautoChecker_sound _ _ H).
1707		intros ; apply bound_problem_sound with (tg:= fun _ _ _ => tt); auto.
1708		Qed.
1709	1702
1710	1703	Fixpoint xhyps_of_pt (base:nat) (acc : list nat) (pt:ZArithProof) : list nat :=
1711	1704	match pt with

1715	1708	\| EnumProof c1 c2 l =>
1716	1709	let acc := xhyps_of_psatz base (xhyps_of_psatz base acc c2) c1 in
1717	1710	List.fold_left (xhyps_of_pt (S base)) l acc
	1711	\| ExProof _ pt => xhyps_of_pt (S (S (S base ))) acc pt
1718	1712	end.
1719	1713
1720	1714	Definition hyps_of_pt (pt : ZArithProof) : list nat := xhyps_of_pt 0 nil pt.

-3

plugins/micromega/ZifyInst.v less more

389	389	{ TUOp := Z.sgn ; TUOpInj := ltac:(reflexivity) }.
390	390	Add UnOp Op_Z_sgn.
391	391
392		Instance Op_Z_pow_pos : BinOp Z.pow_pos :=
393		{ TBOp := Z.pow ; TBOpInj := ltac:(reflexivity) }.
394		Add BinOp Op_Z_pow_pos.
395	392
396	393	Lemma of_nat_to_nat_eq : forall x, Z.of_nat (Z.to_nat x) = Z.max 0 x.
397	394	Proof.

-0

plugins/micromega/ZifyPow.v less more

	0	Require Import Arith Max Min BinInt BinNat Znat Nnat.
	1	Require Import ZifyClasses.
	2	Require Export ZifyInst.
	3
	4	Instance Op_Z_pow_pos : BinOp Z.pow_pos :=
	5	{ TBOp := Z.pow ; TBOpInj := ltac:(reflexivity) }.
	6	Add BinOp Op_Z_pow_pos.

+140

-0

plugins/micromega/Ztac.v less more

	0	(************************************************************************)
	1	(* * The Coq Proof Assistant / The Coq Development Team *)
	2	(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *)
	3	(* <O___,, * (see CREDITS file for the list of authors) *)
	4	(* \VV/ **************************************************************)
	5	(* // * This file is distributed under the terms of the *)
	6	(* * GNU Lesser General Public License Version 2.1 *)
	7	(* * (see LICENSE file for the text of the license) *)
	8	(************************************************************************)
	9
	10	(** Tactics for doing arithmetic proofs.
	11	Useful to bootstrap lia.
	12	*)
	13
	14	Require Import ZArithRing.
	15	Require Import ZArith_base.
	16	Local Open Scope Z_scope.
	17
	18	Lemma eq_incl :
	19	forall (x y:Z), x = y -> x <= y /\ y <= x.
	20	Proof.
	21	intros; split;
	22	apply Z.eq_le_incl; auto.
	23	Qed.
	24
	25	Lemma elim_concl_eq :
	26	forall x y, (x < y \/ y < x -> False) -> x = y.
	27	Proof.
	28	intros.
	29	destruct (Z_lt_le_dec x y).
	30	exfalso. apply H ; auto.
	31	destruct (Zle_lt_or_eq y x);auto.
	32	exfalso.
	33	apply H ; auto.
	34	Qed.
	35
	36	Lemma elim_concl_le :
	37	forall x y, (y < x -> False) -> x <= y.
	38	Proof.
	39	intros.
	40	destruct (Z_lt_le_dec y x).
	41	exfalso ; auto.
	42	auto.
	43	Qed.
	44
	45	Lemma elim_concl_lt :
	46	forall x y, (y <= x -> False) -> x < y.
	47	Proof.
	48	intros.
	49	destruct (Z_lt_le_dec x y).
	50	auto.
	51	exfalso ; auto.
	52	Qed.
	53
	54
	55
	56	Lemma Zlt_le_add_1 : forall n m : Z, n < m -> n + 1 <= m.
	57	Proof. exact (Zlt_le_succ). Qed.
	58
	59
	60	Ltac normZ :=
	61	repeat
	62	match goal with
	63	\| H : _ < _ \|- _ => apply Zlt_le_add_1 in H
	64	\| H : ?Y <= _ \|- _ =>
	65	lazymatch Y with
	66	\| 0 => fail
	67	\| _ => apply Zle_minus_le_0 in H
	68	end
	69	\| H : _ >= _ \|- _ => apply Z.ge_le in H
	70	\| H : _ > _ \|- _ => apply Z.gt_lt in H
	71	\| H : _ = _ \|- _ => apply eq_incl in H ; destruct H
	72	\| \|- @eq Z _ _ => apply elim_concl_eq ; let H := fresh "HZ" in intros [H\|H]
	73	\| \|- _ <= _ => apply elim_concl_le ; intros
	74	\| \|- _ < _ => apply elim_concl_lt ; intros
	75	\| \|- _ >= _ => apply Z.le_ge
	76	end.
	77
	78
	79	Inductive proof :=
	80	\| Hyp (e : Z) (prf : 0 <= e)
	81	\| Add (p1 p2: proof)
	82	\| Mul (p1 p2: proof)
	83	\| Cst (c : Z)
	84	.
	85
	86	Lemma add_le : forall e1 e2, 0 <= e1 -> 0 <= e2 -> 0 <= e1+e2.
	87	Proof.
	88	intros.
	89	change 0 with (0+ 0).
	90	apply Z.add_le_mono; auto.
	91	Qed.
	92
	93	Lemma mul_le : forall e1 e2, 0 <= e1 -> 0 <= e2 -> 0 <= e1*e2.
	94	Proof.
	95	intros.
	96	change 0 with (0* e2).
	97	apply Zmult_le_compat_r; auto.
	98	Qed.
	99
	100	Fixpoint eval_proof (p : proof) : { e : Z \| 0 <= e} :=
	101	match p with
	102	\| Hyp e prf => exist _ e prf
	103	\| Add p1 p2 => let (e1,p1) := eval_proof p1 in
	104	let (e2,p2) := eval_proof p2 in
	105	exist _ _ (add_le _ _ p1 p2)
	106	\| Mul p1 p2 => let (e1,p1) := eval_proof p1 in
	107	let (e2,p2) := eval_proof p2 in
	108	exist _ _ (mul_le _ _ p1 p2)
	109	\| Cst c => match Z_le_dec 0 c with
	110	\| left prf => exist _ _ prf
	111	\| _ => exist _ _ Z.le_0_1
	112	end
	113	end.
	114
	115	Ltac lia_step p :=
	116	let H := fresh in
	117	let prf := (eval cbn - [Z.le Z.mul Z.opp Z.sub Z.add] in (eval_proof p)) in
	118	match prf with
	119	\| @exist _ _ _ ?P => pose proof P as H
	120	end ; ring_simplify in H.
	121
	122	Ltac lia_contr :=
	123	match goal with
	124	\| H : 0 <= - (Zpos _) \|- _ =>
	125	rewrite <- Z.leb_le in H;
	126	compute in H ; discriminate
	127	\| H : 0 <= (Zneg _) \|- _ =>
	128	rewrite <- Z.leb_le in H;
	129	compute in H ; discriminate
	130	end.
	131
	132
	133	Ltac lia p :=
	134	lia_step p ; lia_contr.
	135
	136	Ltac slia H1 H2 :=
	137	normZ ; lia (Add (Hyp _ H1) (Hyp _ H2)).
	138
	139	Arguments Hyp {_} prf.

+667

-691

plugins/micromega/certificate.ml less more

21	21	open Big_int
22	22	open Num
23	23	open Polynomial
24
25	24	module Mc = Micromega
26	25	module Ml2C = Mutils.CamlToCoq
27	26	module C2Ml = Mutils.CoqToCaml
28	27
29	28	let use_simplex = ref true
30	29
31
32		type ('prf,'model) res =
33		\| Prf of 'prf
34		\| Model of 'model
35		\| Unknown
36
37		type zres = (Mc.zArithProof , (int * Mc.z list)) res
38
39		type qres = (Mc.q Mc.psatz , (int * Mc.q list)) res
40
	30	type ('prf, 'model) res = Prf of 'prf \| Model of 'model \| Unknown
	31	type zres = (Mc.zArithProof, int * Mc.z list) res
	32	type qres = (Mc.q Mc.psatz, int * Mc.q list) res
41	33
42	34	open Mutils
43		type 'a number_spec = {
44		bigint_to_number : big_int -> 'a;
45		number_to_num : 'a -> num;
46		zero : 'a;
47		unit : 'a;
48		mult : 'a -> 'a -> 'a;
49		eqb : 'a -> 'a -> bool
50		}
51
52		let z_spec = {
53		bigint_to_number = Ml2C.bigint ;
54		number_to_num = (fun x -> Big_int (C2Ml.z_big_int x));
55		zero = Mc.Z0;
56		unit = Mc.Zpos Mc.XH;
57		mult = Mc.Z.mul;
58		eqb = Mc.zeq_bool
59		}
60
61
62		let q_spec = {
63		bigint_to_number = (fun x -> {Mc.qnum = Ml2C.bigint x; Mc.qden = Mc.XH});
64		number_to_num = C2Ml.q_to_num;
65		zero = {Mc.qnum = Mc.Z0;Mc.qden = Mc.XH};
66		unit = {Mc.qnum = (Mc.Zpos Mc.XH) ; Mc.qden = Mc.XH};
67		mult = Mc.qmult;
68		eqb = Mc.qeq_bool
69		}
70
71		let dev_form n_spec p =
	35
	36	type 'a number_spec =
	37	{ bigint_to_number : big_int -> 'a
	38	; number_to_num : 'a -> num
	39	; zero : 'a
	40	; unit : 'a
	41	; mult : 'a -> 'a -> 'a
	42	; eqb : 'a -> 'a -> bool }
	43
	44	let z_spec =
	45	{ bigint_to_number = Ml2C.bigint
	46	; number_to_num = (fun x -> Big_int (C2Ml.z_big_int x))
	47	; zero = Mc.Z0
	48	; unit = Mc.Zpos Mc.XH
	49	; mult = Mc.Z.mul
	50	; eqb = Mc.zeq_bool }
	51
	52	let q_spec =
	53	{ bigint_to_number = (fun x -> {Mc.qnum = Ml2C.bigint x; Mc.qden = Mc.XH})
	54	; number_to_num = C2Ml.q_to_num
	55	; zero = {Mc.qnum = Mc.Z0; Mc.qden = Mc.XH}
	56	; unit = {Mc.qnum = Mc.Zpos Mc.XH; Mc.qden = Mc.XH}
	57	; mult = Mc.qmult
	58	; eqb = Mc.qeq_bool }
	59
	60	let dev_form n_spec p =
72	61	let rec dev_form p =
73	62	match p with
74		\| Mc.PEc z -> Poly.constant (n_spec.number_to_num z)
75		\| Mc.PEX v -> Poly.variable (C2Ml.positive v)
76		\| Mc.PEmul(p1,p2) ->
77		let p1 = dev_form p1 in
78		let p2 = dev_form p2 in
79		Poly.product p1 p2
80		\| Mc.PEadd(p1,p2) -> Poly.addition (dev_form p1) (dev_form p2)
81		\| Mc.PEopp p -> Poly.uminus (dev_form p)
82		\| Mc.PEsub(p1,p2) -> Poly.addition (dev_form p1) (Poly.uminus (dev_form p2))
83		\| Mc.PEpow(p,n) ->
84		let p = dev_form p in
85		let n = C2Ml.n n in
86		let rec pow n =
87		if Int.equal n 0
88		then Poly.constant (n_spec.number_to_num n_spec.unit)
89		else Poly.product p (pow (n-1)) in
90		pow n in
	63	\| Mc.PEc z -> Poly.constant (n_spec.number_to_num z)
	64	\| Mc.PEX v -> Poly.variable (C2Ml.positive v)
	65	\| Mc.PEmul (p1, p2) ->
	66	let p1 = dev_form p1 in
	67	let p2 = dev_form p2 in
	68	Poly.product p1 p2
	69	\| Mc.PEadd (p1, p2) -> Poly.addition (dev_form p1) (dev_form p2)
	70	\| Mc.PEopp p -> Poly.uminus (dev_form p)
	71	\| Mc.PEsub (p1, p2) ->
	72	Poly.addition (dev_form p1) (Poly.uminus (dev_form p2))
	73	\| Mc.PEpow (p, n) ->
	74	let p = dev_form p in
	75	let n = C2Ml.n n in
	76	let rec pow n =
	77	if Int.equal n 0 then Poly.constant (n_spec.number_to_num n_spec.unit)
	78	else Poly.product p (pow (n - 1))
	79	in
	80	pow n
	81	in
91	82	dev_form p
92	83
93	84	let rec fixpoint f x =
94	85	let y' = f x in
95		if (=) y' x then y'
96		else fixpoint f y'
97
98		let rec_simpl_cone n_spec e =
	86	if y' = x then y' else fixpoint f y'
	87
	88	let rec_simpl_cone n_spec e =
99	89	let simpl_cone =
100		Mc.simpl_cone n_spec.zero n_spec.unit n_spec.mult n_spec.eqb in
101
102		let rec rec_simpl_cone = function
103		\| Mc.PsatzMulE(t1, t2) ->
104		simpl_cone (Mc.PsatzMulE (rec_simpl_cone t1, rec_simpl_cone t2))
105		\| Mc.PsatzAdd(t1,t2) ->
106		simpl_cone (Mc.PsatzAdd (rec_simpl_cone t1, rec_simpl_cone t2))
107		\| x -> simpl_cone x in
	90	Mc.simpl_cone n_spec.zero n_spec.unit n_spec.mult n_spec.eqb
	91	in
	92	let rec rec_simpl_cone = function
	93	\| Mc.PsatzMulE (t1, t2) ->
	94	simpl_cone (Mc.PsatzMulE (rec_simpl_cone t1, rec_simpl_cone t2))
	95	\| Mc.PsatzAdd (t1, t2) ->
	96	simpl_cone (Mc.PsatzAdd (rec_simpl_cone t1, rec_simpl_cone t2))
	97	\| x -> simpl_cone x
	98	in
108	99	rec_simpl_cone e
109	100
110
111	101	let simplify_cone n_spec c = fixpoint (rec_simpl_cone n_spec) c
112
113
114	102
115	103	(* The binding with Fourier might be a bit obsolete
116	104	-- how does it handle equalities ? *)

132	120	(* fold_left followed by a rev ! *)
133	121
134	122	let constrain_variable v l =
135		let coeffs = List.fold_left (fun acc p -> (Vect.get v p.coeffs)::acc) [] l in
136		{ coeffs = Vect.from_list ((Big_int zero_big_int):: (Big_int zero_big_int):: (List.rev coeffs)) ;
137		op = Eq ;
138		cst = Big_int zero_big_int }
139
140
	123	let coeffs = List.fold_left (fun acc p -> Vect.get v p.coeffs :: acc) [] l in
	124	{ coeffs =
	125	Vect.from_list
	126	(Big_int zero_big_int :: Big_int zero_big_int :: List.rev coeffs)
	127	; op = Eq
	128	; cst = Big_int zero_big_int }
141	129
142	130	let constrain_constant l =
143		let coeffs = List.fold_left (fun acc p -> minus_num p.cst ::acc) [] l in
144		{ coeffs = Vect.from_list ((Big_int zero_big_int):: (Big_int unit_big_int):: (List.rev coeffs)) ;
145		op = Eq ;
146		cst = Big_int zero_big_int }
	131	let coeffs = List.fold_left (fun acc p -> minus_num p.cst :: acc) [] l in
	132	{ coeffs =
	133	Vect.from_list
	134	(Big_int zero_big_int :: Big_int unit_big_int :: List.rev coeffs)
	135	; op = Eq
	136	; cst = Big_int zero_big_int }
147	137
148	138	let positivity l =
149	139	let rec xpositivity i l =
150	140	match l with
151	141	\| [] -> []
152		\| c::l -> match c.op with
153		\| Eq -> xpositivity (i+1) l
154		\| _ ->
155		{coeffs = Vect.update (i+1) (fun _ -> Int 1) Vect.null ;
156		op = Ge ;
157		cst = Int 0 } :: (xpositivity (i+1) l)
	142	\| c :: l -> (
	143	match c.op with
	144	\| Eq -> xpositivity (i + 1) l
	145	\| _ ->
	146	{ coeffs = Vect.update (i + 1) (fun _ -> Int 1) Vect.null
	147	; op = Ge
	148	; cst = Int 0 }
	149	:: xpositivity (i + 1) l )
158	150	in
159	151	xpositivity 1 l
160	152
161
162		let cstr_of_poly (p,o) =
163		let (c,l) = Vect.decomp_cst p in
164		{coeffs = l; op = o ; cst = minus_num c}
165
166
	153	let cstr_of_poly (p, o) =
	154	let c, l = Vect.decomp_cst p in
	155	{coeffs = l; op = o; cst = minus_num c}
167	156
168	157	let variables_of_cstr c = Vect.variables c.coeffs
169
170	158
171	159	(* If the certificate includes at least one strict inequality,
172	160	the obtained polynomial can also be 0 *)
173	161
174	162	let build_dual_linear_system l =
175
176	163	let variables =
177		List.fold_left (fun acc p -> ISet.union acc (variables_of_cstr p)) ISet.empty l in
	164	List.fold_left
	165	(fun acc p -> ISet.union acc (variables_of_cstr p))
	166	ISet.empty l
	167	in
178	168	(* For each monomial, compute a constraint *)
179	169	let s0 =
180		ISet.fold (fun mn res -> (constrain_variable mn l)::res) variables [] in
181		let c = constrain_constant l in
182
	170	ISet.fold (fun mn res -> constrain_variable mn l :: res) variables []
	171	in
	172	let c = constrain_constant l in
183	173	(* I need at least something strictly positive *)
184		let strict = {
185		coeffs = Vect.from_list ((Big_int zero_big_int) :: (Big_int unit_big_int)::
186		(List.map (fun c -> if is_strict c then Big_int unit_big_int else Big_int zero_big_int) l));
187		op = Ge ; cst = Big_int unit_big_int } in
	174	let strict =
	175	{ coeffs =
	176	Vect.from_list
	177	( Big_int zero_big_int :: Big_int unit_big_int
	178	:: List.map
	179	(fun c ->
	180	if is_strict c then Big_int unit_big_int
	181	else Big_int zero_big_int)
	182	l )
	183	; op = Ge
	184	; cst = Big_int unit_big_int }
	185	in
188	186	(* Add the positivity constraint *)
189		{coeffs = Vect.from_list ([Big_int zero_big_int ;Big_int unit_big_int]) ;
190		op = Ge ;
191		cst = Big_int zero_big_int}::(strict::(positivity l)@c::s0)
	187	{ coeffs = Vect.from_list [Big_int zero_big_int; Big_int unit_big_int]
	188	; op = Ge
	189	; cst = Big_int zero_big_int }
	190	:: ((strict :: positivity l) @ (c :: s0))
	191
192	192	open Util
193	193
194	194	(** [direct_linear_prover l] does not handle strict inegalities *)
195	195	let fourier_linear_prover l =
196	196	match Mfourier.Fourier.find_point l with
197	197	\| Inr prf ->
198		if debug then Printf.printf "AProof : %a\n" Mfourier.pp_proof prf ;
199		let cert = (List.map (fun (x,n) -> x+1,n)) (fst (List.hd (Mfourier.Proof.mk_proof l prf))) in
200		if debug then Printf.printf "CProof : %a" Vect.pp cert ;
201		(Some (rats_to_ints (Vect.to_list cert)))
202		Some (Vect.normalise cert)
203		\| Inl _ -> None
204
	198	if debug then Printf.printf "AProof : %a\n" Mfourier.pp_proof prf;
	199	let cert =
	200	(List.map (fun (x,n) -> x+1,n))
	201	fst (List.hd (Mfourier.Proof.mk_proof l prf))
	202	in
	203	if debug then Printf.printf "CProof : %a" Vect.pp cert;
	204	(Some (rats_to_ints (Vect.to_list cert)))
	205	Some (Vect.normalise cert)
	206	\| Inl _ -> None
205	207
206	208	let direct_linear_prover l =
207		if !use_simplex
208		then Simplex.find_unsat_certificate l
	209	if !use_simplex then Simplex.find_unsat_certificate l
209	210	else fourier_linear_prover l
210	211
211	212	let find_point l =
212		if !use_simplex
213		then Simplex.find_point l
214		else match Mfourier.Fourier.find_point l with
215		\| Inr _ -> None
216		\| Inl cert -> Some cert
	213	if !use_simplex then Simplex.find_point l
	214	else
	215	match Mfourier.Fourier.find_point l with
	216	\| Inr _ -> None
	217	\| Inl cert -> Some cert
217	218
218	219	let optimise v l =
219		if !use_simplex
220		then Simplex.optimise v l
221		else Mfourier.Fourier.optimise v l
222
223
	220	if !use_simplex then Simplex.optimise v l else Mfourier.Fourier.optimise v l
224	221
225	222	let dual_raw_certificate l =
226		if debug
227		then begin
228		Printf.printf "dual_raw_certificate\n";
229		List.iter (fun c -> Printf.fprintf stdout "%a\n" output_cstr c) l
230		end;
231
	223	if debug then begin
	224	Printf.printf "dual_raw_certificate\n";
	225	List.iter (fun c -> Printf.fprintf stdout "%a\n" output_cstr c) l
	226	end;
232	227	let sys = build_dual_linear_system l in
233
234	228	if debug then begin
235		Printf.printf "dual_system\n";
236		List.iter (fun c -> Printf.fprintf stdout "%a\n" output_cstr c) sys
237		end;
238
	229	Printf.printf "dual_system\n";
	230	List.iter (fun c -> Printf.fprintf stdout "%a\n" output_cstr c) sys
	231	end;
239	232	try
240	233	match find_point sys with
241	234	\| None -> None
242		\| Some cert ->
243		match Vect.choose cert with
244		\| None -> failwith "dual_raw_certificate: empty_certificate"
245		\| Some _ ->
246		(Some (rats_to_ints (Vect.to_list (Vect.decr_var 2 (Vect.set 1 (Int 0) cert)))))
247		Some (Vect.normalise (Vect.decr_var 2 (Vect.set 1 (Int 0) cert)))
248		(* should not use rats_to_ints *)
	235	\| Some cert -> (
	236	match Vect.choose cert with
	237	\| None -> failwith "dual_raw_certificate: empty_certificate"
	238	\| Some _ ->
	239	(Some (rats_to_ints (Vect.to_list (Vect.decr_var 2 (Vect.set 1 (Int 0) cert)))))
	240	Some (Vect.normalise (Vect.decr_var 2 (Vect.set 1 (Int 0) cert))) )
	241	(* should not use rats_to_ints *)
249	242	with x when CErrors.noncritical x ->
250		if debug
251		then (Printf.printf "dual raw certificate %s" (Printexc.to_string x);
252		flush stdout) ;
253		None
254
255
	243	if debug then (
	244	Printf.printf "dual raw certificate %s" (Printexc.to_string x);
	245	flush stdout );
	246	None
256	247
257	248	let simple_linear_prover l =
258		try
259		direct_linear_prover l
	249	try direct_linear_prover l
260	250	with Strict ->
261	251	(* Fourier elimination should handle > *)
262	252	dual_raw_certificate l
263	253
264	254	let env_of_list l =
265		snd (List.fold_left (fun (i,m) p -> (i+1,IMap.add i p m)) (0,IMap.empty) l)
266
267
268
	255	snd
	256	(List.fold_left (fun (i, m) p -> (i + 1, IMap.add i p m)) (0, IMap.empty) l)
269	257
270	258	let linear_prover_cstr sys =
271		let (sysi,prfi) = List.split sys in
272
273
	259	let sysi, prfi = List.split sys in
274	260	match simple_linear_prover sysi with
275	261	\| None -> None
276	262	\| Some cert -> Some (ProofFormat.proof_of_farkas (env_of_list prfi) cert)
277	263
278		let linear_prover_cstr =
279		if debug
280		then
281		fun sys ->
282		Printf.printf "<linear_prover"; flush stdout ;
	264	let linear_prover_cstr =
	265	if debug then ( fun sys ->
	266	Printf.printf "<linear_prover";
	267	flush stdout;
283	268	let res = linear_prover_cstr sys in
284		Printf.printf ">"; flush stdout ;
285		res
	269	Printf.printf ">"; flush stdout; res )
286	270	else linear_prover_cstr
287
288
289	271
290	272	let compute_max_nb_cstr l d =
291	273	let len = List.length l in
292	274	max len (max d (len * d))
293	275
294
295		let develop_constraint z_spec (e,k) =
296		(dev_form z_spec e,
297		match k with
298		\| Mc.NonStrict -> Ge
299		\| Mc.Equal -> Eq
300		\| Mc.Strict -> Gt
301		\| _ -> assert false
302		)
	276	let develop_constraint z_spec (e, k) =
	277	( dev_form z_spec e
	278	, match k with
	279	\| Mc.NonStrict -> Ge
	280	\| Mc.Equal -> Eq
	281	\| Mc.Strict -> Gt
	282	\| _ -> assert false )
303	283
304	284	(** A single constraint can be unsat for the following reasons:
305	285	- 0 >= c for c a negative constant

311	291	\| Tauto (* Tautology *)
312	292	\| Unsat of ProofFormat.prf_rule (* Unsatisfiable *)
313	293	\| Cut of cstr * ProofFormat.prf_rule (* Cutting plane *)
314		\| Normalise of cstr * ProofFormat.prf_rule (* Coefficients may be normalised i.e relatively prime *)
315
316		exception FoundProof of ProofFormat.prf_rule
317
	294	\| Normalise of cstr * ProofFormat.prf_rule
	295
	296	(* Coefficients may be normalised i.e relatively prime *)
	297
	298	exception FoundProof of ProofFormat.prf_rule
318	299
319	300	(** [check_sat]
320	301	- detects constraints that are not satisfiable;
321	302	- normalises constraints and generate cuts.
322	303	*)
323	304
324		let check_int_sat (cstr,prf) =
325		let {coeffs=coeffs ; op=op ; cst=cst} = cstr in
	305	let check_int_sat (cstr, prf) =
	306	let {coeffs; op; cst} = cstr in
326	307	match Vect.choose coeffs with
327		\| None ->
328		if eval_op op (Int 0) cst then Tauto else Unsat prf
329		\| _ ->
330		let gcdi = Vect.gcd coeffs in
331		let gcd = Big_int gcdi in
332		if eq_num gcd (Int 1)
333		then Normalise(cstr,prf)
334		else
335		if Int.equal (sign_num (mod_num cst gcd)) 0
336		then (* We can really normalise *)
337		begin
338		assert (sign_num gcd >=1 ) ;
339		let cstr = {
340		coeffs = Vect.div gcd coeffs;
341		op = op ; cst = cst // gcd
342		} in
343		Normalise(cstr,ProofFormat.Gcd(gcdi,prf))
344		(* Normalise(cstr,CutPrf prf)*)
345		end
346		else
347		match op with
348		\| Eq -> Unsat (ProofFormat.CutPrf prf)
349		\| Ge ->
350		let cstr = {
351		coeffs = Vect.div gcd coeffs;
352		op = op ; cst = ceiling_num (cst // gcd)
353		} in Cut(cstr,ProofFormat.CutPrf prf)
354		\| Gt -> failwith "check_sat : Unexpected operator"
355
	308	\| None -> if eval_op op (Int 0) cst then Tauto else Unsat prf
	309	\| _ -> (
	310	let gcdi = Vect.gcd coeffs in
	311	let gcd = Big_int gcdi in
	312	if eq_num gcd (Int 1) then Normalise (cstr, prf)
	313	else if Int.equal (sign_num (mod_num cst gcd)) 0 then begin
	314	(* We can really normalise *)
	315	assert (sign_num gcd >= 1);
	316	let cstr = {coeffs = Vect.div gcd coeffs; op; cst = cst // gcd} in
	317	Normalise (cstr, ProofFormat.Gcd (gcdi, prf))
	318	(* Normalise(cstr,CutPrf prf)*)
	319	end
	320	else
	321	match op with
	322	\| Eq -> Unsat (ProofFormat.CutPrf prf)
	323	\| Ge ->
	324	let cstr =
	325	{coeffs = Vect.div gcd coeffs; op; cst = ceiling_num (cst // gcd)}
	326	in
	327	Cut (cstr, ProofFormat.CutPrf prf)
	328	\| Gt -> failwith "check_sat : Unexpected operator" )
356	329
357	330	let apply_and_normalise check f psys =
358		List.fold_left (fun acc pc' ->
	331	List.fold_left
	332	(fun acc pc' ->
359	333	match f pc' with
360		\| None -> pc'::acc
361		\| Some pc' ->
362		match check pc' with
363		\| Tauto -> acc
364		\| Unsat prf -> raise (FoundProof prf)
365		\| Cut(c,p) -> (c,p)::acc
366		\| Normalise (c,p) -> (c,p)::acc
367		) [] psys
368
369
	334	\| None -> pc' :: acc
	335	\| Some pc' -> (
	336	match check pc' with
	337	\| Tauto -> acc
	338	\| Unsat prf -> raise (FoundProof prf)
	339	\| Cut (c, p) -> (c, p) :: acc
	340	\| Normalise (c, p) -> (c, p) :: acc ))
	341	[] psys
370	342
371	343	let is_linear_for v pc =
372	344	LinPoly.is_linear (fst (fst pc)) \|\| LinPoly.is_linear_for v (fst (fst pc))
373
374
375
376	345
377	346	(*let non_linear_pivot sys pc v pc' =
378	347	if LinPoly.is_linear (fst (fst pc'))

380	349	else WithProof.linear_pivot sys pc v pc'
381	350	*)
382	351
383		let is_linear_substitution sys ((p,o),prf) =
384		let pred v = v =/ Int 1 \|\| v =/ Int (-1) in
	352	let is_linear_substitution sys ((p, o), prf) =
	353	let pred v = v =/ Int 1 \|\| v =/ Int (-1) in
385	354	match o with
386		\| Eq -> begin
387		match
388		List.filter (fun v -> List.for_all (is_linear_for v) sys) (LinPoly.search_all_linear pred p)
389		with
390		\| [] -> None
391		\| v::_ -> Some v (* make a choice *)
392		end
393		\| _ -> None
394
	355	\| Eq -> (
	356	match
	357	List.filter
	358	(fun v -> List.for_all (is_linear_for v) sys)
	359	(LinPoly.search_all_linear pred p)
	360	with
	361	\| [] -> None
	362	\| v :: _ -> Some v (* make a choice *) )
	363	\| _ -> None
395	364
396	365	let elim_simple_linear_equality sys0 =
397
398	366	let elim sys =
399		let (oeq,sys') = extract (is_linear_substitution sys) sys in
	367	let oeq, sys' = extract (is_linear_substitution sys) sys in
400	368	match oeq with
401	369	\| None -> None
402		\| Some(v,pc) -> simplify (WithProof.linear_pivot sys0 pc v) sys' in
403
	370	\| Some (v, pc) -> simplify (WithProof.linear_pivot sys0 pc v) sys'
	371	in
404	372	iterate_until_stable elim sys0
405
406
407	373
408	374	let output_sys o sys =
409	375	List.iter (fun s -> Printf.fprintf o "%a\n" WithProof.output s) sys
410	376
411	377	let subst sys =
412	378	let sys' = WithProof.subst sys in
413		if debug then Printf.fprintf stdout "[subst:\n%a\n==>\n%a\n]" output_sys sys output_sys sys' ;
	379	if debug then
	380	Printf.fprintf stdout "[subst:\n%a\n==>\n%a\n]" output_sys sys output_sys
	381	sys';
414	382	sys'
415
416
417	383
418	384	(** [saturate_linear_equality sys] generate new constraints
419	385	obtained by eliminating linear equalities by pivoting.
420	386	For integers, the obtained constraints are sound but not complete.
421	387	*)
422		let saturate_by_linear_equalities sys0 =
423		WithProof.saturate_subst false sys0
424
	388	let saturate_by_linear_equalities sys0 = WithProof.saturate_subst false sys0
425	389
426	390	let saturate_by_linear_equalities sys =
427	391	let sys' = saturate_by_linear_equalities sys in
428		if debug then Printf.fprintf stdout "[saturate_by_linear_equalities:\n%a\n==>\n%a\n]" output_sys sys output_sys sys' ;
	392	if debug then
	393	Printf.fprintf stdout "[saturate_by_linear_equalities:\n%a\n==>\n%a\n]"
	394	output_sys sys output_sys sys';
429	395	sys'
430
431
432	396
433	397	(* let saturate_linear_equality_non_linear sys0 =
434	398	let (l,_) = extract_all (is_substitution false) sys0 in

441	405	elim l []
442	406	*)
443	407
444		let bounded_vars (sys: WithProof.t list) =
445		let l = (fst (extract_all (fun ((p,o),prf) ->
446		LinPoly.is_variable p
447		) sys)) in
448		List.fold_left (fun acc (i,wp) -> IMap.add i wp acc) IMap.empty l
449
450		let rec power n p =
451		if n = 1 then p
452		else WithProof.product p (power (n-1) p)
	408	let bounded_vars (sys : WithProof.t list) =
	409	let l = fst (extract_all (fun ((p, o), prf) -> LinPoly.is_variable p) sys) in
	410	List.fold_left (fun acc (i, wp) -> IMap.add i wp acc) IMap.empty l
	411
	412	let rec power n p = if n = 1 then p else WithProof.product p (power (n - 1) p)
453	413
454	414	let bound_monomial mp m =
455		if Monomial.is_var m \|\| Monomial.is_const m
456		then None
	415	if Monomial.is_var m \|\| Monomial.is_const m then None
457	416	else
458		try
459		Some (Monomial.fold
460		(fun v i acc ->
461		let wp = IMap.find v mp in
462		WithProof.product (power i wp) acc) m (WithProof.const (Int 1))
463		)
464		with Not_found -> None
465
466
467		let bound_monomials (sys:WithProof.t list) =
	417	try
	418	Some
	419	(Monomial.fold
	420	(fun v i acc ->
	421	let wp = IMap.find v mp in
	422	WithProof.product (power i wp) acc)
	423	m (WithProof.const (Int 1)))
	424	with Not_found -> None
	425
	426	let bound_monomials (sys : WithProof.t list) =
468	427	let mp = bounded_vars sys in
469		let m =
470		List.fold_left (fun acc ((p,_),_) ->
471		Vect.fold (fun acc v _ -> let m = LinPoly.MonT.retrieve v in
472		match bound_monomial mp m with
473		\| None -> acc
474		\| Some r -> IMap.add v r acc) acc p) IMap.empty sys in
475		IMap.fold (fun _ e acc -> e::acc) m []
476
	428	let m =
	429	List.fold_left
	430	(fun acc ((p, _), _) ->
	431	Vect.fold
	432	(fun acc v _ ->
	433	let m = LinPoly.MonT.retrieve v in
	434	match bound_monomial mp m with
	435	\| None -> acc
	436	\| Some r -> IMap.add v r acc)
	437	acc p)
	438	IMap.empty sys
	439	in
	440	IMap.fold (fun _ e acc -> e :: acc) m []
477	441
478	442	let develop_constraints prfdepth n_spec sys =
479	443	LinPoly.MonT.clear ();
480		max_nb_cstr := compute_max_nb_cstr sys prfdepth ;
	444	max_nb_cstr := compute_max_nb_cstr sys prfdepth;
481	445	let sys = List.map (develop_constraint n_spec) sys in
482		List.mapi (fun i (p,o) -> ((LinPoly.linpol_of_pol p,o),ProofFormat.Hyp i)) sys
	446	List.mapi
	447	(fun i (p, o) -> ((LinPoly.linpol_of_pol p, o), ProofFormat.Hyp i))
	448	sys
483	449
484	450	let square_of_var i =
485	451	let x = LinPoly.var i in
486		((LinPoly.product x x,Ge),(ProofFormat.Square x))
487
	452	((LinPoly.product x x, Ge), ProofFormat.Square x)
488	453
489	454	(** [nlinear_preprocess sys] augments the system [sys] by performing some limited non-linear reasoning.
490	455	For instance, it asserts that the x² ≥0 but also that if c₁ ≥ 0 ∈ sys and c₂ ≥ 0 ∈ sys then c₁ × c₂ ≥ 0.
491	456	The resulting system is linearised.
492	457	*)
493	458
494		let nlinear_preprocess (sys:WithProof.t list) =
495
496		let is_linear = List.for_all (fun ((p,_),_) -> LinPoly.is_linear p) sys in
497
	459	let nlinear_preprocess (sys : WithProof.t list) =
	460	let is_linear = List.for_all (fun ((p, _), _) -> LinPoly.is_linear p) sys in
498	461	if is_linear then sys
499	462	else
500	463	let collect_square =
501		List.fold_left (fun acc ((p,_),_) -> MonMap.union (fun k e1 e2 -> Some e1) acc (LinPoly.collect_square p)) MonMap.empty sys in
502		let sys = MonMap.fold (fun s m acc ->
503		let s = LinPoly.of_monomial s in
504		let m = LinPoly.of_monomial m in
505		((m, Ge), (ProofFormat.Square s))::acc) collect_square sys in
506
507		let collect_vars = List.fold_left (fun acc p -> ISet.union acc (LinPoly.variables (fst (fst p)))) ISet.empty sys in
508
509		let sys = ISet.fold (fun i acc -> square_of_var i :: acc) collect_vars sys in
510
511		let sys = sys @ (all_pairs WithProof.product sys) in
512
	464	List.fold_left
	465	(fun acc ((p, _), _) ->
	466	MonMap.union (fun k e1 e2 -> Some e1) acc (LinPoly.collect_square p))
	467	MonMap.empty sys
	468	in
	469	let sys =
	470	MonMap.fold
	471	(fun s m acc ->
	472	let s = LinPoly.of_monomial s in
	473	let m = LinPoly.of_monomial m in
	474	((m, Ge), ProofFormat.Square s) :: acc)
	475	collect_square sys
	476	in
	477	let collect_vars =
	478	List.fold_left
	479	(fun acc p -> ISet.union acc (LinPoly.variables (fst (fst p))))
	480	ISet.empty sys
	481	in
	482	let sys =
	483	ISet.fold (fun i acc -> square_of_var i :: acc) collect_vars sys
	484	in
	485	let sys = sys @ all_pairs WithProof.product sys in
513	486	if debug then begin
514		Printf.fprintf stdout "Preprocessed\n";
515		List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys;
516		end ;
517
	487	Printf.fprintf stdout "Preprocessed\n";
	488	List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys
	489	end;
518	490	List.map (WithProof.annot "P") sys
519
520
521	491
522	492	let nlinear_prover prfdepth sys =
523	493	let sys = develop_constraints prfdepth q_spec sys in
524	494	let sys1 = elim_simple_linear_equality sys in
525	495	let sys2 = saturate_by_linear_equalities sys1 in
526		let sys = nlinear_preprocess sys1@sys2 in
527		let sys = List.map (fun ((p,o),prf) -> (cstr_of_poly (p,o), prf)) sys in
528		let id = (List.fold_left
529		(fun acc (_,r) -> max acc (ProofFormat.pr_rule_max_id r)) 0 sys) in
	496	let sys = nlinear_preprocess sys1 @ sys2 in
	497	let sys = List.map (fun ((p, o), prf) -> (cstr_of_poly (p, o), prf)) sys in
	498	let id =
	499	List.fold_left
	500	(fun acc (_, r) -> max acc (ProofFormat.pr_rule_max_id r))
	501	0 sys
	502	in
530	503	let env = CList.interval 0 id in
531	504	match linear_prover_cstr sys with
532	505	\| None -> Unknown
533		\| Some cert ->
534		Prf (ProofFormat.cmpl_prf_rule Mc.normQ CamlToCoq.q env cert)
535
	506	\| Some cert -> Prf (ProofFormat.cmpl_prf_rule Mc.normQ CamlToCoq.q env cert)
536	507
537	508	let linear_prover_with_cert prfdepth sys =
538	509	let sys = develop_constraints prfdepth q_spec sys in
539	510	(* let sys = nlinear_preprocess sys in *)
540		let sys = List.map (fun (c,p) -> cstr_of_poly c,p) sys in
541
	511	let sys = List.map (fun (c, p) -> (cstr_of_poly c, p)) sys in
542	512	match linear_prover_cstr sys with
543	513	\| None -> Unknown
544	514	\| Some cert ->
545		Prf (ProofFormat.cmpl_prf_rule Mc.normQ CamlToCoq.q (List.mapi (fun i e -> i) sys) cert)
	515	Prf
	516	(ProofFormat.cmpl_prf_rule Mc.normQ CamlToCoq.q
	517	(List.mapi (fun i e -> i) sys)
	518	cert)
546	519
547	520	(* The prover is (probably) incomplete --
548	521	only searching for naive cutting planes *)

551	524
552	525	let rec scale_term t =
553	526	match t with
554		\| Zero -> unit_big_int , Zero
555		\| Const n -> (denominator n) , Const (Big_int (numerator n))
556		\| Var n -> unit_big_int , Var n
557		\| Opp t -> let s, t = scale_term t in s, Opp t
558		\| Add(t1,t2) -> let s1,y1 = scale_term t1 and s2,y2 = scale_term t2 in
559		let g = gcd_big_int s1 s2 in
560		let s1' = div_big_int s1 g in
561		let s2' = div_big_int s2 g in
562		let e = mult_big_int g (mult_big_int s1' s2') in
563		if Int.equal (compare_big_int e unit_big_int) 0
564		then (unit_big_int, Add (y1,y2))
565		else e, Add (Mul(Const (Big_int s2'), y1),
566		Mul (Const (Big_int s1'), y2))
	527	\| Zero -> (unit_big_int, Zero)
	528	\| Const n -> (denominator n, Const (Big_int (numerator n)))
	529	\| Var n -> (unit_big_int, Var n)
	530	\| Opp t ->
	531	let s, t = scale_term t in
	532	(s, Opp t)
	533	\| Add (t1, t2) ->
	534	let s1, y1 = scale_term t1 and s2, y2 = scale_term t2 in
	535	let g = gcd_big_int s1 s2 in
	536	let s1' = div_big_int s1 g in
	537	let s2' = div_big_int s2 g in
	538	let e = mult_big_int g (mult_big_int s1' s2') in
	539	if Int.equal (compare_big_int e unit_big_int) 0 then
	540	(unit_big_int, Add (y1, y2))
	541	else (e, Add (Mul (Const (Big_int s2'), y1), Mul (Const (Big_int s1'), y2)))
567	542	\| Sub _ -> failwith "scale term: not implemented"
568		\| Mul(y,z) -> let s1,y1 = scale_term y and s2,y2 = scale_term z in
569		mult_big_int s1 s2 , Mul (y1, y2)
570		\| Pow(t,n) -> let s,t = scale_term t in
571		power_big_int_positive_int s n , Pow(t,n)
	543	\| Mul (y, z) ->
	544	let s1, y1 = scale_term y and s2, y2 = scale_term z in
	545	(mult_big_int s1 s2, Mul (y1, y2))
	546	\| Pow (t, n) ->
	547	let s, t = scale_term t in
	548	(power_big_int_positive_int s n, Pow (t, n))
572	549
573	550	let scale_term t =
574		let (s,t') = scale_term t in
575		s,t'
576
577		let rec scale_certificate pos = match pos with
578		\| Axiom_eq i -> unit_big_int , Axiom_eq i
579		\| Axiom_le i -> unit_big_int , Axiom_le i
580		\| Axiom_lt i -> unit_big_int , Axiom_lt i
581		\| Monoid l -> unit_big_int , Monoid l
582		\| Rational_eq n -> (denominator n) , Rational_eq (Big_int (numerator n))
583		\| Rational_le n -> (denominator n) , Rational_le (Big_int (numerator n))
584		\| Rational_lt n -> (denominator n) , Rational_lt (Big_int (numerator n))
585		\| Square t -> let s,t' = scale_term t in
586		mult_big_int s s , Square t'
587		\| Eqmul (t, y) -> let s1,y1 = scale_term t and s2,y2 = scale_certificate y in
588		mult_big_int s1 s2 , Eqmul (y1,y2)
589		\| Sum (y, z) -> let s1,y1 = scale_certificate y
590		and s2,y2 = scale_certificate z in
591		let g = gcd_big_int s1 s2 in
592		let s1' = div_big_int s1 g in
593		let s2' = div_big_int s2 g in
594		mult_big_int g (mult_big_int s1' s2'),
595		Sum (Product(Rational_le (Big_int s2'), y1),
596		Product (Rational_le (Big_int s1'), y2))
	551	let s, t' = scale_term t in
	552	(s, t')
	553
	554	let rec scale_certificate pos =
	555	match pos with
	556	\| Axiom_eq i -> (unit_big_int, Axiom_eq i)
	557	\| Axiom_le i -> (unit_big_int, Axiom_le i)
	558	\| Axiom_lt i -> (unit_big_int, Axiom_lt i)
	559	\| Monoid l -> (unit_big_int, Monoid l)
	560	\| Rational_eq n -> (denominator n, Rational_eq (Big_int (numerator n)))
	561	\| Rational_le n -> (denominator n, Rational_le (Big_int (numerator n)))
	562	\| Rational_lt n -> (denominator n, Rational_lt (Big_int (numerator n)))
	563	\| Square t ->
	564	let s, t' = scale_term t in
	565	(mult_big_int s s, Square t')
	566	\| Eqmul (t, y) ->
	567	let s1, y1 = scale_term t and s2, y2 = scale_certificate y in
	568	(mult_big_int s1 s2, Eqmul (y1, y2))
	569	\| Sum (y, z) ->
	570	let s1, y1 = scale_certificate y and s2, y2 = scale_certificate z in
	571	let g = gcd_big_int s1 s2 in
	572	let s1' = div_big_int s1 g in
	573	let s2' = div_big_int s2 g in
	574	( mult_big_int g (mult_big_int s1' s2')
	575	, Sum
	576	( Product (Rational_le (Big_int s2'), y1)
	577	, Product (Rational_le (Big_int s1'), y2) ) )
597	578	\| Product (y, z) ->
598		let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in
599		mult_big_int s1 s2 , Product (y1,y2)
600
	579	let s1, y1 = scale_certificate y and s2, y2 = scale_certificate z in
	580	(mult_big_int s1 s2, Product (y1, y2))
601	581
602	582	open Micromega
	583
603	584	let rec term_to_q_expr = function
604		\| Const n -> PEc (Ml2C.q n)
605		\| Zero -> PEc ( Ml2C.q (Int 0))
606		\| Var s -> PEX (Ml2C.index
607		(int_of_string (String.sub s 1 (String.length s - 1))))
608		\| Mul(p1,p2) -> PEmul(term_to_q_expr p1, term_to_q_expr p2)
609		\| Add(p1,p2) -> PEadd(term_to_q_expr p1, term_to_q_expr p2)
610		\| Opp p -> PEopp (term_to_q_expr p)
611		\| Pow(t,n) -> PEpow (term_to_q_expr t,Ml2C.n n)
612		\| Sub(t1,t2) -> PEsub (term_to_q_expr t1, term_to_q_expr t2)
613
614		let term_to_q_pol e = Mc.norm_aux (Ml2C.q (Int 0)) (Ml2C.q (Int 1)) Mc.qplus Mc.qmult Mc.qminus Mc.qopp Mc.qeq_bool (term_to_q_expr e)
615
	585	\| Const n -> PEc (Ml2C.q n)
	586	\| Zero -> PEc (Ml2C.q (Int 0))
	587	\| Var s ->
	588	PEX (Ml2C.index (int_of_string (String.sub s 1 (String.length s - 1))))
	589	\| Mul (p1, p2) -> PEmul (term_to_q_expr p1, term_to_q_expr p2)
	590	\| Add (p1, p2) -> PEadd (term_to_q_expr p1, term_to_q_expr p2)
	591	\| Opp p -> PEopp (term_to_q_expr p)
	592	\| Pow (t, n) -> PEpow (term_to_q_expr t, Ml2C.n n)
	593	\| Sub (t1, t2) -> PEsub (term_to_q_expr t1, term_to_q_expr t2)
	594
	595	let term_to_q_pol e =
	596	Mc.norm_aux (Ml2C.q (Int 0)) (Ml2C.q (Int 1)) Mc.qplus Mc.qmult Mc.qminus
	597	Mc.qopp Mc.qeq_bool (term_to_q_expr e)
616	598
617	599	let rec product l =
618	600	match l with
619	601	\| [] -> Mc.PsatzZ
620	602	\| [i] -> Mc.PsatzIn (Ml2C.nat i)
621		\| i ::l -> Mc.PsatzMulE(Mc.PsatzIn (Ml2C.nat i), product l)
622
623
624		let q_cert_of_pos pos =
	603	\| i :: l -> Mc.PsatzMulE (Mc.PsatzIn (Ml2C.nat i), product l)
	604
	605	let q_cert_of_pos pos =
625	606	let rec _cert_of_pos = function
626		Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i)
627		\| Axiom_le i -> Mc.PsatzIn (Ml2C.nat i)
628		\| Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i)
629		\| Monoid l -> product l
	607	\| Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i)
	608	\| Axiom_le i -> Mc.PsatzIn (Ml2C.nat i)
	609	\| Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i)
	610	\| Monoid l -> product l
630	611	\| Rational_eq n \| Rational_le n \| Rational_lt n ->
631		if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else
632		Mc.PsatzC (Ml2C.q n)
633		\| Square t -> Mc.PsatzSquare (term_to_q_pol t)
634		\| Eqmul (t, y) -> Mc.PsatzMulC(term_to_q_pol t, _cert_of_pos y)
635		\| Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z)
636		\| Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) in
	612	if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ
	613	else Mc.PsatzC (Ml2C.q n)
	614	\| Square t -> Mc.PsatzSquare (term_to_q_pol t)
	615	\| Eqmul (t, y) -> Mc.PsatzMulC (term_to_q_pol t, _cert_of_pos y)
	616	\| Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z)
	617	\| Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z)
	618	in
637	619	simplify_cone q_spec (_cert_of_pos pos)
638	620
639
640	621	let rec term_to_z_expr = function
641		\| Const n -> PEc (Ml2C.bigint (big_int_of_num n))
642		\| Zero -> PEc ( Z0)
643		\| Var s -> PEX (Ml2C.index
644		(int_of_string (String.sub s 1 (String.length s - 1))))
645		\| Mul(p1,p2) -> PEmul(term_to_z_expr p1, term_to_z_expr p2)
646		\| Add(p1,p2) -> PEadd(term_to_z_expr p1, term_to_z_expr p2)
647		\| Opp p -> PEopp (term_to_z_expr p)
648		\| Pow(t,n) -> PEpow (term_to_z_expr t,Ml2C.n n)
649		\| Sub(t1,t2) -> PEsub (term_to_z_expr t1, term_to_z_expr t2)
650
651		let term_to_z_pol e = Mc.norm_aux (Ml2C.z 0) (Ml2C.z 1) Mc.Z.add Mc.Z.mul Mc.Z.sub Mc.Z.opp Mc.zeq_bool (term_to_z_expr e)
652
653		let z_cert_of_pos pos =
654		let s,pos = (scale_certificate pos) in
	622	\| Const n -> PEc (Ml2C.bigint (big_int_of_num n))
	623	\| Zero -> PEc Z0
	624	\| Var s ->
	625	PEX (Ml2C.index (int_of_string (String.sub s 1 (String.length s - 1))))
	626	\| Mul (p1, p2) -> PEmul (term_to_z_expr p1, term_to_z_expr p2)
	627	\| Add (p1, p2) -> PEadd (term_to_z_expr p1, term_to_z_expr p2)
	628	\| Opp p -> PEopp (term_to_z_expr p)
	629	\| Pow (t, n) -> PEpow (term_to_z_expr t, Ml2C.n n)
	630	\| Sub (t1, t2) -> PEsub (term_to_z_expr t1, term_to_z_expr t2)
	631
	632	let term_to_z_pol e =
	633	Mc.norm_aux (Ml2C.z 0) (Ml2C.z 1) Mc.Z.add Mc.Z.mul Mc.Z.sub Mc.Z.opp
	634	Mc.zeq_bool (term_to_z_expr e)
	635
	636	let z_cert_of_pos pos =
	637	let s, pos = scale_certificate pos in
655	638	let rec _cert_of_pos = function
656		Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i)
657		\| Axiom_le i -> Mc.PsatzIn (Ml2C.nat i)
658		\| Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i)
659		\| Monoid l -> product l
	639	\| Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i)
	640	\| Axiom_le i -> Mc.PsatzIn (Ml2C.nat i)
	641	\| Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i)
	642	\| Monoid l -> product l
660	643	\| Rational_eq n \| Rational_le n \| Rational_lt n ->
661		if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else
662		Mc.PsatzC (Ml2C.bigint (big_int_of_num n))
663		\| Square t -> Mc.PsatzSquare (term_to_z_pol t)
	644	if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ
	645	else Mc.PsatzC (Ml2C.bigint (big_int_of_num n))
	646	\| Square t -> Mc.PsatzSquare (term_to_z_pol t)
664	647	\| Eqmul (t, y) ->
665		let is_unit =
666		match t with
667		\| Const n -> n =/ Int 1
668		\| _ -> false in
669		if is_unit
670		then _cert_of_pos y
671		else Mc.PsatzMulC(term_to_z_pol t, _cert_of_pos y)
672		\| Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z)
673		\| Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) in
	648	let is_unit = match t with Const n -> n =/ Int 1 \| _ -> false in
	649	if is_unit then _cert_of_pos y
	650	else Mc.PsatzMulC (term_to_z_pol t, _cert_of_pos y)
	651	\| Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z)
	652	\| Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z)
	653	in
674	654	simplify_cone z_spec (_cert_of_pos pos)
675	655
	656	open Mutils
676	657	(** All constraints (initial or derived) have an index and have a justification i.e., proof.
677	658	Given a constraint, all the coefficients are always integers.
678	659	*)
679		open Mutils
	660
680	661	open Num
681	662	open Big_int
682	663	open Polynomial
683	664
684
685
686	665	type prf_sys = (cstr * ProofFormat.prf_rule) list
687	666
688
689
690	667	(** Proof generating pivoting over variable v *)
691		let pivot v (c1,p1) (c2,p2) =
692		let {coeffs = v1 ; op = op1 ; cst = n1} = c1
693		and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in
694
695
696
	668	let pivot v (c1, p1) (c2, p2) =
	669	let {coeffs = v1; op = op1; cst = n1} = c1
	670	and {coeffs = v2; op = op2; cst = n2} = c2 in
697	671	(* Could factorise gcd... *)
698	672	let xpivot cv1 cv2 =
699		(
700		{coeffs = Vect.add (Vect.mul cv1 v1) (Vect.mul cv2 v2) ;
701		op = opAdd op1 op2 ;
702		cst = n1 / cv1 +/ n2 / cv2 },
703
704		ProofFormat.add_proof (ProofFormat.mul_cst_proof cv1 p1) (ProofFormat.mul_cst_proof cv2 p2)) in
705
706		match Vect.get v v1 , Vect.get v v2 with
707		\| Int 0 , _ \| _ , Int 0 -> None
708		\| a , b ->
709		if Int.equal ((sign_num a) * (sign_num b)) (-1)
710		then
711		let cv1 = abs_num b
712		and cv2 = abs_num a in
713		Some (xpivot cv1 cv2)
714		else
715		if op1 == Eq
716		then
717		let cv1 = minus_num (b */ (Int (sign_num a)))
718		and cv2 = abs_num a in
719		Some (xpivot cv1 cv2)
720		else if op2 == Eq
721		then
722		let cv1 = abs_num b
723		and cv2 = minus_num (a */ (Int (sign_num b))) in
724		Some (xpivot cv1 cv2)
725		else None (* op2 could be Eq ... this might happen *)
726
	673	( { coeffs = Vect.add (Vect.mul cv1 v1) (Vect.mul cv2 v2)
	674	; op = opAdd op1 op2
	675	; cst = (n1 / cv1) +/ (n2 / cv2) }
	676	, ProofFormat.add_proof
	677	(ProofFormat.mul_cst_proof cv1 p1)
	678	(ProofFormat.mul_cst_proof cv2 p2) )
	679	in
	680	match (Vect.get v v1, Vect.get v v2) with
	681	\| Int 0, _ \| _, Int 0 -> None
	682	\| a, b ->
	683	if Int.equal (sign_num a * sign_num b) (-1) then
	684	let cv1 = abs_num b and cv2 = abs_num a in
	685	Some (xpivot cv1 cv2)
	686	else if op1 == Eq then
	687	let cv1 = minus_num (b */ Int (sign_num a)) and cv2 = abs_num a in
	688	Some (xpivot cv1 cv2)
	689	else if op2 == Eq then
	690	let cv1 = abs_num b and cv2 = minus_num (a */ Int (sign_num b)) in
	691	Some (xpivot cv1 cv2)
	692	else None
	693
	694	(* op2 could be Eq ... this might happen *)
727	695
728	696	let simpl_sys sys =
729		List.fold_left (fun acc (c,p) ->
730		match check_int_sat (c,p) with
	697	List.fold_left
	698	(fun acc (c, p) ->
	699	match check_int_sat (c, p) with
731	700	\| Tauto -> acc
732	701	\| Unsat prf -> raise (FoundProof prf)
733		\| Cut(c,p) -> (c,p)::acc
734		\| Normalise (c,p) -> (c,p)::acc) [] sys
735
	702	\| Cut (c, p) -> (c, p) :: acc
	703	\| Normalise (c, p) -> (c, p) :: acc)
	704	[] sys
736	705
737	706	(** [ext_gcd a b] is the extended Euclid algorithm.
738	707	[ext_gcd a b = (x,y,g)] iff [ax+by=g]
739	708	Source: http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm
740	709	*)
741	710	let rec ext_gcd a b =
742		if Int.equal (sign_big_int b) 0
743		then (unit_big_int,zero_big_int)
	711	if Int.equal (sign_big_int b) 0 then (unit_big_int, zero_big_int)
744	712	else
745		let (q,r) = quomod_big_int a b in
746		let (s,t) = ext_gcd b r in
	713	let q, r = quomod_big_int a b in
	714	let s, t = ext_gcd b r in
747	715	(t, sub_big_int s (mult_big_int q t))
748	716
749		let extract_coprime (c1,p1) (c2,p2) =
750		if c1.op == Eq && c2.op == Eq
751		then Vect.exists2 (fun n1 n2 ->
752		Int.equal (compare_big_int (gcd_big_int (numerator n1) (numerator n2)) unit_big_int) 0)
753		c1.coeffs c2.coeffs
	717	let extract_coprime (c1, p1) (c2, p2) =
	718	if c1.op == Eq && c2.op == Eq then
	719	Vect.exists2
	720	(fun n1 n2 ->
	721	Int.equal
	722	(compare_big_int
	723	(gcd_big_int (numerator n1) (numerator n2))
	724	unit_big_int)
	725	0)
	726	c1.coeffs c2.coeffs
754	727	else None
755	728
756	729	let extract2 pred l =
757	730	let rec xextract2 rl l =
758	731	match l with
759		\| [] -> (None,rl) (* Did not find *)
760		\| e::l ->
761		match extract (pred e) l with
762		\| None,_ -> xextract2 (e::rl) l
763		\| Some (r,e'),l' -> Some (r,e,e'), List.rev_append rl l' in
764
	732	\| [] -> (None, rl) (* Did not find *)
	733	\| e :: l -> (
	734	match extract (pred e) l with
	735	\| None, _ -> xextract2 (e :: rl) l
	736	\| Some (r, e'), l' -> (Some (r, e, e'), List.rev_append rl l') )
	737	in
765	738	xextract2 [] l
766	739
767
768		let extract_coprime_equation psys =
769		extract2 extract_coprime psys
770
771
772
773
774
775
	740	let extract_coprime_equation psys = extract2 extract_coprime psys
776	741	let pivot_sys v pc psys = apply_and_normalise check_int_sat (pivot v pc) psys
777	742
778	743	let reduce_coprime psys =
779		let oeq,sys = extract_coprime_equation psys in
	744	let oeq, sys = extract_coprime_equation psys in
780	745	match oeq with
781	746	\| None -> None (* Nothing to do *)
782		\| Some((v,n1,n2),(c1,p1),(c2,p2) ) ->
783		let (l1,l2) = ext_gcd (numerator n1) (numerator n2) in
784		let l1' = Big_int l1 and l2' = Big_int l2 in
785		let cstr =
786		{coeffs = Vect.add (Vect.mul l1' c1.coeffs) (Vect.mul l2' c2.coeffs);
787		op = Eq ;
788		cst = (l1' / c1.cst) +/ (l2' / c2.cst)
789		} in
790		let prf = ProofFormat.add_proof (ProofFormat.mul_cst_proof l1' p1) (ProofFormat.mul_cst_proof l2' p2) in
791
792		Some (pivot_sys v (cstr,prf) ((c1,p1)::sys))
	747	\| Some ((v, n1, n2), (c1, p1), (c2, p2)) ->
	748	let l1, l2 = ext_gcd (numerator n1) (numerator n2) in
	749	let l1' = Big_int l1 and l2' = Big_int l2 in
	750	let cstr =
	751	{ coeffs = Vect.add (Vect.mul l1' c1.coeffs) (Vect.mul l2' c2.coeffs)
	752	; op = Eq
	753	; cst = (l1' / c1.cst) +/ (l2' / c2.cst) }
	754	in
	755	let prf =
	756	ProofFormat.add_proof
	757	(ProofFormat.mul_cst_proof l1' p1)
	758	(ProofFormat.mul_cst_proof l2' p2)
	759	in
	760	Some (pivot_sys v (cstr, prf) ((c1, p1) :: sys))
793	761
794	762	(** If there is an equation [eq] of the form 1.x + e = c, do a pivot over x with equation [eq] *)
795	763	let reduce_unary psys =
796		let is_unary_equation (cstr,prf) =
797		if cstr.op == Eq
798		then
799		Vect.find (fun v n -> if n =/ (Int 1) \|\| n=/ (Int (-1)) then Some v else None) cstr.coeffs
800		else None in
801
802		let (oeq,sys) = extract is_unary_equation psys in
	764	let is_unary_equation (cstr, prf) =
	765	if cstr.op == Eq then
	766	Vect.find
	767	(fun v n -> if n =/ Int 1 \|\| n =/ Int (-1) then Some v else None)
	768	cstr.coeffs
	769	else None
	770	in
	771	let oeq, sys = extract is_unary_equation psys in
803	772	match oeq with
804	773	\| None -> None (* Nothing to do *)
805		\| Some(v,pc) ->
806		Some(pivot_sys v pc sys)
807
	774	\| Some (v, pc) -> Some (pivot_sys v pc sys)
808	775
809	776	let reduce_var_change psys =
810
811	777	let rec rel_prime vect =
812	778	match Vect.choose vect with
813	779	\| None -> None
814		\| Some(x,v,vect) ->
815		let v = numerator v in
816		match Vect.find (fun x' v' ->
817		let v' = numerator v' in
818		if eq_big_int (gcd_big_int v v') unit_big_int
819		then Some(x',v') else None) vect with
820		\| Some(x',v') -> Some ((x,v),(x', v'))
821		\| None -> rel_prime vect in
822
823		let rel_prime (cstr,prf) = if cstr.op == Eq then rel_prime cstr.coeffs else None in
824
825		let (oeq,sys) = extract rel_prime psys in
826
	780	\| Some (x, v, vect) -> (
	781	let v = numerator v in
	782	match
	783	Vect.find
	784	(fun x' v' ->
	785	let v' = numerator v' in
	786	if eq_big_int (gcd_big_int v v') unit_big_int then Some (x', v')
	787	else None)
	788	vect
	789	with
	790	\| Some (x', v') -> Some ((x, v), (x', v'))
	791	\| None -> rel_prime vect )
	792	in
	793	let rel_prime (cstr, prf) =
	794	if cstr.op == Eq then rel_prime cstr.coeffs else None
	795	in
	796	let oeq, sys = extract rel_prime psys in
827	797	match oeq with
828	798	\| None -> None
829		\| Some(((x,v),(x',v')),(c,p)) ->
830		let (l1,l2) = ext_gcd v v' in
831		let l1,l2 = Big_int l1 , Big_int l2 in
832
833
834		let pivot_eq (c',p') =
835		let {coeffs = coeffs ; op = op ; cst = cst} = c' in
836		let vx = Vect.get x coeffs in
837		let vx' = Vect.get x' coeffs in
838		let m = minus_num (vx / l1 +/ vx' / l2) in
839		Some ({coeffs =
840		Vect.add (Vect.mul m c.coeffs) coeffs ; op = op ; cst = m */ c.cst +/ cst} ,
841		ProofFormat.add_proof (ProofFormat.mul_cst_proof m p) p') in
842
843		Some (apply_and_normalise check_int_sat pivot_eq sys)
844
	799	\| Some (((x, v), (x', v')), (c, p)) ->
	800	let l1, l2 = ext_gcd v v' in
	801	let l1, l2 = (Big_int l1, Big_int l2) in
	802	let pivot_eq (c', p') =
	803	let {coeffs; op; cst} = c' in
	804	let vx = Vect.get x coeffs in
	805	let vx' = Vect.get x' coeffs in
	806	let m = minus_num ((vx / l1) +/ (vx' / l2)) in
	807	Some
	808	( { coeffs = Vect.add (Vect.mul m c.coeffs) coeffs
	809	; op
	810	; cst = (m */ c.cst) +/ cst }
	811	, ProofFormat.add_proof (ProofFormat.mul_cst_proof m p) p' )
	812	in
	813	Some (apply_and_normalise check_int_sat pivot_eq sys)
845	814
846	815	let reduction_equations psys =
847		iterate_until_stable (app_funs
848		[reduce_unary ; reduce_coprime ;
849		reduce_var_change (; reduce_pivot)]) psys
850
851
852
853
	816	iterate_until_stable
	817	(app_funs
	818	[reduce_unary; reduce_coprime; reduce_var_change (; reduce_pivot)])
	819	psys
854	820
855	821	(** [get_bound sys] returns upon success an interval (lb,e,ub) with proofs *)
856	822	let get_bound sys =
857		let is_small (v,i) =
858		match Itv.range i with
859		\| None -> false
860		\| Some i -> i <=/ (Int 1) in
861
862		let select_best (x1,i1) (x2,i2) =
863		if Itv.smaller_itv i1 i2
864		then (x1,i1) else (x2,i2) in
865
	823	let is_small (v, i) =
	824	match Itv.range i with None -> false \| Some i -> i <=/ Int 1
	825	in
	826	let select_best (x1, i1) (x2, i2) =
	827	if Itv.smaller_itv i1 i2 then (x1, i1) else (x2, i2)
	828	in
866	829	(* For lia, there are no equations => these precautions are not needed *)
867	830	(* For nlia, there are equations => do not enumerate over equations! *)
868	831	let all_planes sys =
869		let (eq,ineq) = List.partition (fun c -> c.op == Eq) sys in
	832	let eq, ineq = List.partition (fun c -> c.op == Eq) sys in
870	833	match eq with
871	834	\| [] -> List.rev_map (fun c -> c.coeffs) ineq
872		\| _ ->
873		List.fold_left (fun acc c ->
874		if List.exists (fun c' -> Vect.equal c.coeffs c'.coeffs) eq
875		then acc else c.coeffs ::acc) [] ineq in
876
	835	\| _ ->
	836	List.fold_left
	837	(fun acc c ->
	838	if List.exists (fun c' -> Vect.equal c.coeffs c'.coeffs) eq then acc
	839	else c.coeffs :: acc)
	840	[] ineq
	841	in
877	842	let smallest_interval =
878	843	List.fold_left
879	844	(fun acc vect ->
880		if is_small acc
881		then acc
	845	if is_small acc then acc
882	846	else
883	847	match optimise vect sys with
884	848	\| None -> acc
885	849	\| Some i ->
886		if debug then Printf.printf "Found a new bound %a in %a" Vect.pp vect Itv.pp i;
887		select_best (vect,i) acc) (Vect.null, (None,None)) (all_planes sys) in
	850	if debug then
	851	Printf.printf "Found a new bound %a in %a" Vect.pp vect Itv.pp i;
	852	select_best (vect, i) acc)
	853	(Vect.null, (None, None))
	854	(all_planes sys)
	855	in
888	856	let smallest_interval =
889		match smallest_interval
	857	match smallest_interval with
	858	\| x, (Some i, Some j) -> Some (i, x, j)
	859	\| x -> None
	860	(* This should not be possible *)
	861	in
	862	match smallest_interval with
	863	\| Some (lb, e, ub) -> (
	864	let lbn, lbd = (sub_big_int (numerator lb) unit_big_int, denominator lb) in
	865	let ubn, ubd = (add_big_int unit_big_int (numerator ub), denominator ub) in
	866	(* x <= ub -> x > ub *)
	867	match
	868	( direct_linear_prover
	869	( {coeffs = Vect.mul (Big_int ubd) e; op = Ge; cst = Big_int ubn}
	870	:: sys )
	871	, (* lb <= x -> lb > x *)
	872	direct_linear_prover
	873	( { coeffs = Vect.mul (minus_num (Big_int lbd)) e
	874	; op = Ge
	875	; cst = minus_num (Big_int lbn) }
	876	:: sys ) )
890	877	with
891		\| (x,(Some i, Some j)) -> Some(i,x,j)
892		\| x -> None (* This should not be possible *)
893		in
894		match smallest_interval with
895		\| Some (lb,e,ub) ->
896		let (lbn,lbd) = (sub_big_int (numerator lb) unit_big_int, denominator lb) in
897		let (ubn,ubd) = (add_big_int unit_big_int (numerator ub) , denominator ub) in
898		(match
899		(* x <= ub -> x > ub *)
900		direct_linear_prover ({coeffs = Vect.mul (Big_int ubd) e ; op = Ge ; cst = Big_int ubn} :: sys),
901		(* lb <= x -> lb > x *)
902		direct_linear_prover
903		({coeffs = Vect.mul (minus_num (Big_int lbd)) e ; op = Ge ; cst = minus_num (Big_int lbn)} :: sys)
904		with
905		\| Some cub , Some clb -> Some(List.tl (Vect.to_list clb),(lb,e,ub), List.tl (Vect.to_list cub))
906		\| _ -> failwith "Interval without proof"
907		)
	878	\| Some cub, Some clb ->
	879	Some (List.tl (Vect.to_list clb), (lb, e, ub), List.tl (Vect.to_list cub))
	880	\| _ -> failwith "Interval without proof" )
908	881	\| None -> None
909	882
910
911	883	let check_sys sys =
912		List.for_all (fun (c,p) -> Vect.for_all (fun _ n -> sign_num n <> 0) c.coeffs) sys
	884	List.for_all
	885	(fun (c, p) -> Vect.for_all (fun _ n -> sign_num n <> 0) c.coeffs)
	886	sys
913	887
914	888	open ProofFormat
915	889
916		let xlia (can_enum:bool) reduction_equations sys =
917
918
919		let rec enum_proof (id:int) (sys:prf_sys) =
920		if debug then (Printf.printf "enum_proof\n" ; flush stdout) ;
921		assert (check_sys sys) ;
922
923		let nsys,prf = List.split sys in
	890	let xlia (can_enum : bool) reduction_equations sys =
	891	let rec enum_proof (id : int) (sys : prf_sys) =
	892	if debug then (
	893	Printf.printf "enum_proof\n";
	894	flush stdout );
	895	assert (check_sys sys);
	896	let nsys, prf = List.split sys in
924	897	match get_bound nsys with
925	898	\| None -> Unknown (* Is the systeme really unbounded ? *)
926		\| Some(prf1,(lb,e,ub),prf2) ->
927		if debug then Printf.printf "Found interval: %a in [%s;%s] -> " Vect.pp e (string_of_num lb) (string_of_num ub) ;
928		(match start_enum id e (ceiling_num lb) (floor_num ub) sys
929		with
930		\| Prf prfl ->
931		Prf(ProofFormat.Enum(id,ProofFormat.proof_of_farkas (env_of_list prf) (Vect.from_list prf1),e,
932		ProofFormat.proof_of_farkas (env_of_list prf) (Vect.from_list prf2),prfl))
933		\| _ -> Unknown
934		)
935
936		and start_enum id e clb cub sys =
937		if clb >/ cub
938		then Prf []
	899	\| Some (prf1, (lb, e, ub), prf2) -> (
	900	if debug then
	901	Printf.printf "Found interval: %a in [%s;%s] -> " Vect.pp e
	902	(string_of_num lb) (string_of_num ub);
	903	match start_enum id e (ceiling_num lb) (floor_num ub) sys with
	904	\| Prf prfl ->
	905	Prf
	906	(ProofFormat.Enum
	907	( id
	908	, ProofFormat.proof_of_farkas (env_of_list prf)
	909	(Vect.from_list prf1)
	910	, e
	911	, ProofFormat.proof_of_farkas (env_of_list prf)
	912	(Vect.from_list prf2)
	913	, prfl ))
	914	\| _ -> Unknown )
	915	and start_enum id e clb cub sys =
	916	if clb >/ cub then Prf []
939	917	else
940		let eq = {coeffs = e ; op = Eq ; cst = clb} in
941		match aux_lia (id+1) ((eq, ProofFormat.Def id) :: sys) with
	918	let eq = {coeffs = e; op = Eq; cst = clb} in
	919	match aux_lia (id + 1) ((eq, ProofFormat.Def id) :: sys) with
942	920	\| Unknown \| Model _ -> Unknown
943		\| Prf prf ->
944		match start_enum id e (clb +/ (Int 1)) cub sys with
945		\| Prf l -> Prf (prf::l)
946		\| _ -> Unknown
947
948
949		and aux_lia (id:int) (sys:prf_sys) =
950		assert (check_sys sys) ;
951		if debug then Printf.printf "xlia: %a \n" (pp_list ";" (fun o (c,_) -> output_cstr o c)) sys ;
	921	\| Prf prf -> (
	922	match start_enum id e (clb +/ Int 1) cub sys with
	923	\| Prf l -> Prf (prf :: l)
	924	\| _ -> Unknown )
	925	and aux_lia (id : int) (sys : prf_sys) =
	926	assert (check_sys sys);
	927	if debug then
	928	Printf.printf "xlia: %a \n"
	929	(pp_list ";" (fun o (c, _) -> output_cstr o c))
	930	sys;
952	931	try
953	932	let sys = reduction_equations sys in
954	933	if debug then
955		Printf.printf "after reduction: %a \n" (pp_list ";" (fun o (c,_) -> output_cstr o c)) sys ;
	934	Printf.printf "after reduction: %a \n"
	935	(pp_list ";" (fun o (c, _) -> output_cstr o c))
	936	sys;
956	937	match linear_prover_cstr sys with
957		\| Some prf -> Prf (Step(id,prf,Done))
958		\| None -> if can_enum then enum_proof id sys else Unknown
	938	\| Some prf -> Prf (Step (id, prf, Done))
	939	\| None -> if can_enum then enum_proof id sys else Unknown
959	940	with FoundProof prf ->
960	941	(* [reduction_equations] can find a proof *)
961		Prf(Step(id,prf,Done)) in
962
	942	Prf (Step (id, prf, Done))
	943	in
963	944	(* let sys' = List.map (fun (p,o) -> Mc.norm0 p , o) sys in*)
964		let id = 1 + (List.fold_left
965		(fun acc (_,r) -> max acc (ProofFormat.pr_rule_max_id r)) 0 sys) in
	945	let id =
	946	1
	947	+ List.fold_left
	948	(fun acc (_, r) -> max acc (ProofFormat.pr_rule_max_id r))
	949	0 sys
	950	in
966	951	let orpf =
967	952	try
968	953	let sys = simpl_sys sys in
969	954	aux_lia id sys
970		with FoundProof pr -> Prf(Step(id,pr,Done)) in
	955	with FoundProof pr -> Prf (Step (id, pr, Done))
	956	in
971	957	match orpf with
972	958	\| Unknown \| Model _ -> Unknown
973	959	\| Prf prf ->
974		let env = CList.interval 0 (id - 1) in
975		if debug then begin
976		Printf.fprintf stdout "direct proof %a\n" output_proof prf;
977		flush stdout;
978		end;
979		let prf = compile_proof env prf in
980		(*try
	960	let env = CList.interval 0 (id - 1) in
	961	if debug then begin
	962	Printf.fprintf stdout "direct proof %a\n" output_proof prf;
	963	flush stdout
	964	end;
	965	let prf = compile_proof env prf in
	966	(*try
981	967	if Mc.zChecker sys' prf then Some prf else
982	968	raise Certificate.BadCertificate
983	969	with Failure s -> (Printf.printf "%s" s ; Some prf)
984		*) Prf prf
	970	*)
	971	Prf prf
985	972
986	973	let xlia_simplex env red sys =
987	974	let compile_prf sys prf =
988		let id = 1 + (List.fold_left
989		(fun acc (_,r) -> max acc (ProofFormat.pr_rule_max_id r)) 0 sys) in
	975	let id =
	976	1
	977	+ List.fold_left
	978	(fun acc (_, r) -> max acc (ProofFormat.pr_rule_max_id r))
	979	0 sys
	980	in
990	981	let env = CList.interval 0 (id - 1) in
991		Prf (compile_proof env prf) in
992
	982	Prf (compile_proof env prf)
	983	in
993	984	try
994	985	let sys = red sys in
995
996	986	match Simplex.integer_solver sys with
997	987	\| None -> Unknown
998	988	\| Some prf -> compile_prf sys prf
999		with FoundProof prf -> compile_prf sys (Step(0,prf,Done))
	989	with FoundProof prf -> compile_prf sys (Step (0, prf, Done))
1000	990
1001	991	let xlia env0 en red sys =
1002		if !use_simplex then xlia_simplex env0 red sys
1003		else xlia en red sys
1004
	992	if !use_simplex then xlia_simplex env0 red sys else xlia en red sys
1005	993
1006	994	let dump_file = ref None
1007	995
1008	996	let gen_bench (tac, prover) can_enum prfdepth sys =
1009	997	let res = prover can_enum prfdepth sys in
1010		(match !dump_file with
	998	( match !dump_file with
1011	999	\| None -> ()
1012	1000	\| Some file ->
1013		begin
1014		let o = open_out (Filename.temp_file ~temp_dir:(Sys.getcwd ()) file ".v") in
1015		let sys = develop_constraints prfdepth z_spec sys in
1016		Printf.fprintf o "Require Import ZArith Lia. Open Scope Z_scope.\n";
1017		Printf.fprintf o "Goal %a.\n" (LinPoly.pp_goal "Z") (List.map fst sys) ;
1018		begin
1019		match res with
1020		\| Unknown \| Model _ ->
1021		Printf.fprintf o "Proof.\n intros. Fail %s.\nAbort.\n" tac
1022		\| Prf res ->
1023		Printf.fprintf o "Proof.\n intros. %s.\nQed.\n" tac
1024		end
1025		;
1026		flush o ;
1027		close_out o ;
1028		end);
	1001	let o = open_out (Filename.temp_file ~temp_dir:(Sys.getcwd ()) file ".v") in
	1002	let sys = develop_constraints prfdepth z_spec sys in
	1003	Printf.fprintf o "Require Import ZArith Lia. Open Scope Z_scope.\n";
	1004	Printf.fprintf o "Goal %a.\n" (LinPoly.pp_goal "Z") (List.map fst sys);
	1005	begin
	1006	match res with
	1007	\| Unknown \| Model _ ->
	1008	Printf.fprintf o "Proof.\n intros. Fail %s.\nAbort.\n" tac
	1009	\| Prf res -> Printf.fprintf o "Proof.\n intros. %s.\nQed.\n" tac
	1010	end;
	1011	flush o; close_out o );
1029	1012	res
1030	1013
1031		let lia (can_enum:bool) (prfdepth:int) sys =
	1014	let lia (can_enum : bool) (prfdepth : int) sys =
1032	1015	let sys = develop_constraints prfdepth z_spec sys in
1033	1016	if debug then begin
1034		Printf.fprintf stdout "Input problem\n";
1035		List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys;
1036		Printf.fprintf stdout "Input problem\n";
1037		let string_of_op = function Eq -> "=" \| Ge -> ">=" \| Gt -> ">" in
1038		List.iter (fun ((p,op),_) -> Printf.fprintf stdout "(assert (%s %a))\n" (string_of_op op) Vect.pp_smt p) sys;
1039		end;
	1017	Printf.fprintf stdout "Input problem\n";
	1018	List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys;
	1019	Printf.fprintf stdout "Input problem\n";
	1020	let string_of_op = function Eq -> "=" \| Ge -> ">=" \| Gt -> ">" in
	1021	List.iter
	1022	(fun ((p, op), _) ->
	1023	Printf.fprintf stdout "(assert (%s %a))\n" (string_of_op op) Vect.pp_smt
	1024	p)
	1025	sys
	1026	end;
1040	1027	let sys = subst sys in
1041		let bnd = bound_monomials sys in (* To deal with non-linear monomials *)
1042		let sys = bnd@(saturate_by_linear_equalities sys)@sys in
1043
1044
1045		let sys' = List.map (fun ((p,o),prf) -> (cstr_of_poly (p,o), prf)) sys in
	1028	let bnd = bound_monomials sys in
	1029	(* To deal with non-linear monomials *)
	1030	let sys = bnd @ saturate_by_linear_equalities sys @ sys in
	1031	let sys' = List.map (fun ((p, o), prf) -> (cstr_of_poly (p, o), prf)) sys in
1046	1032	xlia (List.map fst sys) can_enum reduction_equations sys'
1047	1033
1048	1034	let make_cstr_system sys =
1049		List.map (fun ((p,o),prf) -> (cstr_of_poly (p,o), prf)) sys
	1035	List.map (fun ((p, o), prf) -> (cstr_of_poly (p, o), prf)) sys
1050	1036
1051	1037	let nlia enum prfdepth sys =
1052	1038	let sys = develop_constraints prfdepth z_spec sys in
1053		let is_linear = List.for_all (fun ((p,_),_) -> LinPoly.is_linear p) sys in
1054
	1039	let is_linear = List.for_all (fun ((p, _), _) -> LinPoly.is_linear p) sys in
1055	1040	if debug then begin
1056		Printf.fprintf stdout "Input problem\n";
1057		List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys;
1058		end;
1059
1060		if is_linear
1061		then xlia (List.map fst sys) enum reduction_equations (make_cstr_system sys)
	1041	Printf.fprintf stdout "Input problem\n";
	1042	List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys
	1043	end;
	1044	if is_linear then
	1045	xlia (List.map fst sys) enum reduction_equations (make_cstr_system sys)
1062	1046	else
1063	1047	(*
1064	1048	let sys1 = elim_every_substitution sys in

1067	1051	*)
1068	1052	let sys1 = elim_simple_linear_equality sys in
1069	1053	let sys2 = saturate_by_linear_equalities sys1 in
1070		let sys3 = nlinear_preprocess (sys1@sys2) in
1071
1072		let sys4 = make_cstr_system ((sys2@)sys3) in
	1054	let sys3 = nlinear_preprocess (sys1 @ sys2) in
	1055	let sys4 = make_cstr_system (sys2@) sys3 in
1073	1056	(* [reduction_equations] is too brutal - there should be some non-linear reasoning *)
1074		xlia (List.map fst sys) enum reduction_equations sys4
	1057	xlia (List.map fst sys) enum reduction_equations sys4
1075	1058
1076	1059	(* For regression testing, if bench = true generate a Coq goal *)
1077	1060
1078		let lia can_enum prfdepth sys =
1079		gen_bench ("lia",lia) can_enum prfdepth sys
1080
1081		let nlia enum prfdepth sys =
1082		gen_bench ("nia",nlia) enum prfdepth sys
1083
1084
1085
1086
	1061	let lia can_enum prfdepth sys = gen_bench ("lia", lia) can_enum prfdepth sys
	1062	let nlia enum prfdepth sys = gen_bench ("nia", nlia) enum prfdepth sys
1087	1063
1088	1064	(* Local Variables: *)
1089	1065	(* coding: utf-8 *)

+11

-17

plugins/micromega/certificate.mli less more

9	9
10	10	module Mc = Micromega
11	11
12
	12	val use_simplex : bool ref
13	13	(** [use_simplex] is bound to the Coq option Simplex.
14	14	If set, use the Simplex method, otherwise use Fourier *)
15		val use_simplex : bool ref
16	15
17		type ('prf,'model) res =
18		\| Prf of 'prf
19		\| Model of 'model
20		\| Unknown
	16	type ('prf, 'model) res = Prf of 'prf \| Model of 'model \| Unknown
	17	type zres = (Mc.zArithProof, int * Mc.z list) res
	18	type qres = (Mc.q Mc.psatz, int * Mc.q list) res
21	19
22		type zres = (Mc.zArithProof , (int * Mc.z list)) res
23
24		type qres = (Mc.q Mc.psatz , (int * Mc.q list)) res
25
	20	val dump_file : string option ref
26	21	(** [dump_file] is bound to the Coq option Dump Arith.
27	22	If set to some [file], arithmetic goals are dumped in filexxx.v *)
28		val dump_file : string option ref
29	23
	24	val q_cert_of_pos : Sos_types.positivstellensatz -> Mc.q Mc.psatz
30	25	(** [q_cert_of_pos prf] converts a Sos proof into a rational Coq proof *)
31		val q_cert_of_pos : Sos_types.positivstellensatz -> Mc.q Mc.psatz
32	26
	27	val z_cert_of_pos : Sos_types.positivstellensatz -> Mc.z Mc.psatz
33	28	(** [z_cert_of_pos prf] converts a Sos proof into an integer Coq proof *)
34		val z_cert_of_pos : Sos_types.positivstellensatz -> Mc.z Mc.psatz
35	29
	30	val lia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> zres
36	31	(** [lia enum depth sys] generates an unsat proof for the linear constraints in [sys].
37	32	If the Simplex option is set, any failure to find a proof should be considered as a bug. *)
38		val lia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> zres
39	33
	34	val nlia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> zres
40	35	(** [nlia enum depth sys] generates an unsat proof for the non-linear constraints in [sys].
41	36	The solver is incomplete -- the problem is undecidable *)
42		val nlia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> zres
43	37
	38	val linear_prover_with_cert : int -> (Mc.q Mc.pExpr * Mc.op1) list -> qres
44	39	(** [linear_prover_with_cert depth sys] generates an unsat proof for the linear constraints in [sys].
45	40	Over the rationals, the solver is complete. *)
46		val linear_prover_with_cert : int -> (Mc.q Mc.pExpr * Mc.op1) list -> qres
47	41
	42	val nlinear_prover : int -> (Mc.q Mc.pExpr * Mc.op1) list -> qres
48	43	(** [nlinear depth sys] generates an unsat proof for the non-linear constraints in [sys].
49	44	The solver is incompete -- the problem is decidable. *)
50		val nlinear_prover : int -> (Mc.q Mc.pExpr * Mc.op1) list -> qres

+1701

-1646

plugins/micromega/coq_micromega.ml less more

38	38	(* Search limit for provers over Q R *)
39	39	let lra_proof_depth = ref max_depth
40	40
41
42	41	(* Search limit for provers over Z *)
43		let lia_enum = ref true
	42	let lia_enum = ref true
44	43	let lia_proof_depth = ref max_depth
45
46		let get_lia_option () =
47		(!Certificate.use_simplex,!lia_enum,!lia_proof_depth)
48
49		let get_lra_option () =
50		!lra_proof_depth
	44	let get_lia_option () = (!Certificate.use_simplex, !lia_enum, !lia_proof_depth)
	45	let get_lra_option () = !lra_proof_depth
51	46
52	47	(* Enable/disable caches *)
53	48

57	52	let use_csdp_cache = ref true
58	53
59	54	let () =
60
61		let int_opt l vref =
62		{
63		optdepr = false;
64		optname = List.fold_right (^) l "";
65		optkey = l ;
66		optread = (fun () -> Some !vref);
67		optwrite = (fun x -> vref := (match x with None -> max_depth \| Some v -> v))
68		} in
69
70		let lia_enum_opt =
71		{
72		optdepr = false;
73		optname = "Lia Enum";
74		optkey = ["Lia";"Enum"];
75		optread = (fun () -> !lia_enum);
76		optwrite = (fun x -> lia_enum := x)
77		} in
78
79		let solver_opt =
80		{
81		optdepr = false;
82		optname = "Use the Simplex instead of Fourier elimination";
83		optkey = ["Simplex"];
84		optread = (fun () -> !Certificate.use_simplex);
85		optwrite = (fun x -> Certificate.use_simplex := x)
86		} in
87
88		let dump_file_opt =
89		{
90		optdepr = false;
91		optname = "Generate Coq goals in file from calls to 'lia' 'nia'";
92		optkey = ["Dump"; "Arith"];
93		optread = (fun () -> !Certificate.dump_file);
94		optwrite = (fun x -> Certificate.dump_file := x)
95		} in
96
97		let lia_cache_opt =
98		{
99		optdepr = false;
100		optname = "cache of lia (.lia.cache)";
101		optkey = ["Lia" ; "Cache"];
102		optread = (fun () -> !use_lia_cache);
103		optwrite = (fun x -> use_lia_cache := x)
104		} in
105
106		let nia_cache_opt =
107		{
108		optdepr = false;
109		optname = "cache of nia (.nia.cache)";
110		optkey = ["Nia" ; "Cache"];
111		optread = (fun () -> !use_nia_cache);
112		optwrite = (fun x -> use_nia_cache := x)
113		} in
114
115		let nra_cache_opt =
116		{
117		optdepr = false;
118		optname = "cache of nra (.nra.cache)";
119		optkey = ["Nra" ; "Cache"];
120		optread = (fun () -> !use_nra_cache);
121		optwrite = (fun x -> use_nra_cache := x)
122		} in
123
124
125		let () = declare_bool_option solver_opt in
126		let () = declare_bool_option lia_cache_opt in
127		let () = declare_bool_option nia_cache_opt in
128		let () = declare_bool_option nra_cache_opt in
129		let () = declare_stringopt_option dump_file_opt in
130		let () = declare_int_option (int_opt ["Lra"; "Depth"] lra_proof_depth) in
131		let () = declare_int_option (int_opt ["Lia"; "Depth"] lia_proof_depth) in
132		let () = declare_bool_option lia_enum_opt in
133		()
134
	55	let int_opt l vref =
	56	{ optdepr = false
	57	; optname = List.fold_right ( ^ ) l ""
	58	; optkey = l
	59	; optread = (fun () -> Some !vref)
	60	; optwrite =
	61	(fun x -> vref := match x with None -> max_depth \| Some v -> v) }
	62	in
	63	let lia_enum_opt =
	64	{ optdepr = false
	65	; optname = "Lia Enum"
	66	; optkey = ["Lia"; "Enum"]
	67	; optread = (fun () -> !lia_enum)
	68	; optwrite = (fun x -> lia_enum := x) }
	69	in
	70	let solver_opt =
	71	{ optdepr = false
	72	; optname = "Use the Simplex instead of Fourier elimination"
	73	; optkey = ["Simplex"]
	74	; optread = (fun () -> !Certificate.use_simplex)
	75	; optwrite = (fun x -> Certificate.use_simplex := x) }
	76	in
	77	let dump_file_opt =
	78	{ optdepr = false
	79	; optname = "Generate Coq goals in file from calls to 'lia' 'nia'"
	80	; optkey = ["Dump"; "Arith"]
	81	; optread = (fun () -> !Certificate.dump_file)
	82	; optwrite = (fun x -> Certificate.dump_file := x) }
	83	in
	84	let lia_cache_opt =
	85	{ optdepr = false
	86	; optname = "cache of lia (.lia.cache)"
	87	; optkey = ["Lia"; "Cache"]
	88	; optread = (fun () -> !use_lia_cache)
	89	; optwrite = (fun x -> use_lia_cache := x) }
	90	in
	91	let nia_cache_opt =
	92	{ optdepr = false
	93	; optname = "cache of nia (.nia.cache)"
	94	; optkey = ["Nia"; "Cache"]
	95	; optread = (fun () -> !use_nia_cache)
	96	; optwrite = (fun x -> use_nia_cache := x) }
	97	in
	98	let nra_cache_opt =
	99	{ optdepr = false
	100	; optname = "cache of nra (.nra.cache)"
	101	; optkey = ["Nra"; "Cache"]
	102	; optread = (fun () -> !use_nra_cache)
	103	; optwrite = (fun x -> use_nra_cache := x) }
	104	in
	105	let () = declare_bool_option solver_opt in
	106	let () = declare_bool_option lia_cache_opt in
	107	let () = declare_bool_option nia_cache_opt in
	108	let () = declare_bool_option nra_cache_opt in
	109	let () = declare_stringopt_option dump_file_opt in
	110	let () = declare_int_option (int_opt ["Lra"; "Depth"] lra_proof_depth) in
	111	let () = declare_int_option (int_opt ["Lia"; "Depth"] lia_proof_depth) in
	112	let () = declare_bool_option lia_enum_opt in
	113	()
135	114
136	115	(**
137	116	* Initialize a tag type to the Tag module declaration (see Mutils).
138	117	*)
139	118
140	119	type tag = Tag.t
	120
141	121	module Mc = Micromega
142	122
143	123	(**

149	129
150	130	type 'cst atom = 'cst Mc.formula
151	131
152		type 'cst formula = ('cst atom, EConstr.constr,tag * EConstr.constr,Names.Id.t) Mc.gFormula
	132	type 'cst formula =
	133	('cst atom, EConstr.constr, tag * EConstr.constr, Names.Id.t) Mc.gFormula
153	134
154	135	type 'cst clause = ('cst Mc.nFormula, tag * EConstr.constr) Mc.clause
155	136	type 'cst cnf = ('cst Mc.nFormula, tag * EConstr.constr) Mc.cnf
156	137
157
158		let rec pp_formula o (f:'cst formula) =
	138	let rec pp_formula o (f : 'cst formula) =
159	139	Mc.(
160		match f with
161		\| TT -> output_string o "tt"
162		\| FF -> output_string o "ff"
	140	match f with
	141	\| TT -> output_string o "tt"
	142	\| FF -> output_string o "ff"
163	143	\| X c -> output_string o "X "
164		\| A(_,(t,_)) -> Printf.fprintf o "A(%a)" Tag.pp t
165		\| Cj(f1,f2) -> Printf.fprintf o "C(%a,%a)" pp_formula f1 pp_formula f2
166		\| D(f1,f2) -> Printf.fprintf o "D(%a,%a)" pp_formula f1 pp_formula f2
167		\| I(f1,n,f2) -> Printf.fprintf o "I(%a,%s,%a)"
168		pp_formula f1
169		(match n with
170		\| Some id -> Names.Id.to_string id
171		\| None -> "") pp_formula f2
172		\| N(f) -> Printf.fprintf o "N(%a)" pp_formula f
173		)
174
	144	\| A (_, (t, _)) -> Printf.fprintf o "A(%a)" Tag.pp t
	145	\| Cj (f1, f2) -> Printf.fprintf o "C(%a,%a)" pp_formula f1 pp_formula f2
	146	\| D (f1, f2) -> Printf.fprintf o "D(%a,%a)" pp_formula f1 pp_formula f2
	147	\| I (f1, n, f2) ->
	148	Printf.fprintf o "I(%a,%s,%a)" pp_formula f1
	149	(match n with Some id -> Names.Id.to_string id \| None -> "")
	150	pp_formula f2
	151	\| N f -> Printf.fprintf o "N(%a)" pp_formula f)
175	152
176	153	(**
177	154	* Given a set of integers s=\{i0,...,iN\} and a list m, return the list of

181	158	let selecti s m =
182	159	let rec xselecti i m =
183	160	match m with
184		\| [] -> []
185		\| e::m -> if ISet.mem i s then e::(xselecti (i+1) m) else xselecti (i+1) m in
186		xselecti 0 m
	161	\| [] -> []
	162	\| e :: m ->
	163	if ISet.mem i s then e :: xselecti (i + 1) m else xselecti (i + 1) m
	164	in
	165	xselecti 0 m
187	166
188	167	(**
189	168	* MODULE: Mapping of the Coq data-strustures into Caml and Caml extracted

193	172	* Opened here and in csdpcert.ml.
194	173	*)
195	174
196		module M =
197		struct
198
	175	(**
	176	* MODULE END: M
	177	*)
	178	module M = struct
199	179	(**
200	180	* Location of the Coq libraries.
201	181	*)
202	182
203		let logic_dir = ["Coq";"Logic";"Decidable"]
	183	let logic_dir = ["Coq"; "Logic"; "Decidable"]
204	184
205	185	let mic_modules =
206		[
207		["Coq";"Lists";"List"];
208		["Coq"; "micromega";"ZMicromega"];
209		["Coq"; "micromega";"Tauto"];
210		["Coq"; "micromega"; "DeclConstant"];
211		["Coq"; "micromega";"RingMicromega"];
212		["Coq"; "micromega";"EnvRing"];
213		["Coq"; "micromega"; "ZMicromega"];
214		["Coq"; "micromega"; "RMicromega"];
215		["Coq" ; "micromega" ; "Tauto"];
216		["Coq" ; "micromega" ; "RingMicromega"];
217		["Coq" ; "micromega" ; "EnvRing"];
218		["Coq";"QArith"; "QArith_base"];
219		["Coq";"Reals" ; "Rdefinitions"];
220		["Coq";"Reals" ; "Rpow_def"];
221		["LRing_normalise"]]
222
223		[@@@ocaml.warning "-3"]
	186	[ ["Coq"; "Lists"; "List"]
	187	; ["Coq"; "micromega"; "ZMicromega"]
	188	; ["Coq"; "micromega"; "Tauto"]
	189	; ["Coq"; "micromega"; "DeclConstant"]
	190	; ["Coq"; "micromega"; "RingMicromega"]
	191	; ["Coq"; "micromega"; "EnvRing"]
	192	; ["Coq"; "micromega"; "ZMicromega"]
	193	; ["Coq"; "micromega"; "RMicromega"]
	194	; ["Coq"; "micromega"; "Tauto"]
	195	; ["Coq"; "micromega"; "RingMicromega"]
	196	; ["Coq"; "micromega"; "EnvRing"]
	197	; ["Coq"; "QArith"; "QArith_base"]
	198	; ["Coq"; "Reals"; "Rdefinitions"]
	199	; ["Coq"; "Reals"; "Rpow_def"]
	200	; ["LRing_normalise"] ]
	201
	202	[@@@ocaml.warning "-3"]
224	203
225	204	let coq_modules =
226		Coqlib.(init_modules @
227		[logic_dir] @ arith_modules @ zarith_base_modules @ mic_modules)
228
229		let bin_module = [["Coq";"Numbers";"BinNums"]]
	205	Coqlib.(
	206	init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules
	207	@ mic_modules)
	208
	209	let bin_module = [["Coq"; "Numbers"; "BinNums"]]
230	210
231	211	let r_modules =
232		[["Coq";"Reals" ; "Rdefinitions"];
233		["Coq";"Reals" ; "Rpow_def"] ;
234		["Coq";"Reals" ; "Raxioms"] ;
235		["Coq";"QArith"; "Qreals"] ;
236		]
237
238		let z_modules = [["Coq";"ZArith";"BinInt"]]
	212	[ ["Coq"; "Reals"; "Rdefinitions"]
	213	; ["Coq"; "Reals"; "Rpow_def"]
	214	; ["Coq"; "Reals"; "Raxioms"]
	215	; ["Coq"; "QArith"; "Qreals"] ]
	216
	217	let z_modules = [["Coq"; "ZArith"; "BinInt"]]
239	218
240	219	(**
241	220	* Initialization : a large amount of Caml symbols are derived from
242	221	* ZMicromega.v
243	222	*)
244	223
245		let gen_constant_in_modules s m n = EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.gen_reference_in_modules s m n)
	224	let gen_constant_in_modules s m n =
	225	EConstr.of_constr
	226	( UnivGen.constr_of_monomorphic_global
	227	@@ Coqlib.gen_reference_in_modules s m n )
	228
246	229	let init_constant = gen_constant_in_modules "ZMicromega" Coqlib.init_modules
	230
247	231	[@@@ocaml.warning "+3"]
248	232
249	233	let constant = gen_constant_in_modules "ZMicromega" coq_modules

251	235	let r_constant = gen_constant_in_modules "ZMicromega" r_modules
252	236	let z_constant = gen_constant_in_modules "ZMicromega" z_modules
253	237	let m_constant = gen_constant_in_modules "ZMicromega" mic_modules
254
255	238	let coq_and = lazy (init_constant "and")
256	239	let coq_or = lazy (init_constant "or")
257	240	let coq_not = lazy (init_constant "not")
258
259	241	let coq_iff = lazy (init_constant "iff")
260	242	let coq_True = lazy (init_constant "True")
261	243	let coq_False = lazy (init_constant "False")
262
263	244	let coq_cons = lazy (constant "cons")
264	245	let coq_nil = lazy (constant "nil")
265	246	let coq_list = lazy (constant "list")
266
267	247	let coq_O = lazy (init_constant "O")
268	248	let coq_S = lazy (init_constant "S")
269
270	249	let coq_nat = lazy (init_constant "nat")
271	250	let coq_unit = lazy (init_constant "unit")
	251
272	252	(* let coq_option = lazy (init_constant "option")*)
273	253	let coq_None = lazy (init_constant "None")
274	254	let coq_tt = lazy (init_constant "tt")
275	255	let coq_Inl = lazy (init_constant "inl")
276	256	let coq_Inr = lazy (init_constant "inr")
277
278
279	257	let coq_N0 = lazy (bin_constant "N0")
280	258	let coq_Npos = lazy (bin_constant "Npos")
281
282	259	let coq_xH = lazy (bin_constant "xH")
283	260	let coq_xO = lazy (bin_constant "xO")
284	261	let coq_xI = lazy (bin_constant "xI")
285
286	262	let coq_Z = lazy (bin_constant "Z")
287	263	let coq_ZERO = lazy (bin_constant "Z0")
288	264	let coq_POS = lazy (bin_constant "Zpos")
289	265	let coq_NEG = lazy (bin_constant "Zneg")
290
291	266	let coq_Q = lazy (constant "Q")
292	267	let coq_R = lazy (constant "R")
293
294	268	let coq_Qmake = lazy (constant "Qmake")
295
296	269	let coq_Rcst = lazy (constant "Rcst")
297
298		let coq_C0 = lazy (m_constant "C0")
299		let coq_C1 = lazy (m_constant "C1")
300		let coq_CQ = lazy (m_constant "CQ")
301		let coq_CZ = lazy (m_constant "CZ")
	270	let coq_C0 = lazy (m_constant "C0")
	271	let coq_C1 = lazy (m_constant "C1")
	272	let coq_CQ = lazy (m_constant "CQ")
	273	let coq_CZ = lazy (m_constant "CZ")
302	274	let coq_CPlus = lazy (m_constant "CPlus")
303	275	let coq_CMinus = lazy (m_constant "CMinus")
304		let coq_CMult = lazy (m_constant "CMult")
305		let coq_CPow = lazy (m_constant "CPow")
306		let coq_CInv = lazy (m_constant "CInv")
307		let coq_COpp = lazy (m_constant "COpp")
308
309
310		let coq_R0 = lazy (constant "R0")
311		let coq_R1 = lazy (constant "R1")
312
	276	let coq_CMult = lazy (m_constant "CMult")
	277	let coq_CPow = lazy (m_constant "CPow")
	278	let coq_CInv = lazy (m_constant "CInv")
	279	let coq_COpp = lazy (m_constant "COpp")
	280	let coq_R0 = lazy (constant "R0")
	281	let coq_R1 = lazy (constant "R1")
313	282	let coq_proofTerm = lazy (constant "ZArithProof")
314	283	let coq_doneProof = lazy (constant "DoneProof")
315	284	let coq_ratProof = lazy (constant "RatProof")
316	285	let coq_cutProof = lazy (constant "CutProof")
317	286	let coq_enumProof = lazy (constant "EnumProof")
318
	287	let coq_ExProof = lazy (constant "ExProof")
319	288	let coq_Zgt = lazy (z_constant "Z.gt")
320	289	let coq_Zge = lazy (z_constant "Z.ge")
321	290	let coq_Zle = lazy (z_constant "Z.le")
322	291	let coq_Zlt = lazy (z_constant "Z.lt")
323		let coq_Eq = lazy (init_constant "eq")
324
	292	let coq_Eq = lazy (init_constant "eq")
325	293	let coq_Zplus = lazy (z_constant "Z.add")
326	294	let coq_Zminus = lazy (z_constant "Z.sub")
327	295	let coq_Zopp = lazy (z_constant "Z.opp")
328	296	let coq_Zmult = lazy (z_constant "Z.mul")
329	297	let coq_Zpower = lazy (z_constant "Z.pow")
330
331	298	let coq_Qle = lazy (constant "Qle")
332	299	let coq_Qlt = lazy (constant "Qlt")
333	300	let coq_Qeq = lazy (constant "Qeq")
334
335	301	let coq_Qplus = lazy (constant "Qplus")
336	302	let coq_Qminus = lazy (constant "Qminus")
337	303	let coq_Qopp = lazy (constant "Qopp")
338	304	let coq_Qmult = lazy (constant "Qmult")
339	305	let coq_Qpower = lazy (constant "Qpower")
340
341	306	let coq_Rgt = lazy (r_constant "Rgt")
342	307	let coq_Rge = lazy (r_constant "Rge")
343	308	let coq_Rle = lazy (r_constant "Rle")
344	309	let coq_Rlt = lazy (r_constant "Rlt")
345
346	310	let coq_Rplus = lazy (r_constant "Rplus")
347	311	let coq_Rminus = lazy (r_constant "Rminus")
348	312	let coq_Ropp = lazy (r_constant "Ropp")

350	314	let coq_Rinv = lazy (r_constant "Rinv")
351	315	let coq_Rpower = lazy (r_constant "pow")
352	316	let coq_powerZR = lazy (r_constant "powerRZ")
353		let coq_IZR = lazy (r_constant "IZR")
354		let coq_IQR = lazy (r_constant "Q2R")
355
356
357		let coq_PEX = lazy (constant "PEX" )
358		let coq_PEc = lazy (constant"PEc")
	317	let coq_IZR = lazy (r_constant "IZR")
	318	let coq_IQR = lazy (r_constant "Q2R")
	319	let coq_PEX = lazy (constant "PEX")
	320	let coq_PEc = lazy (constant "PEc")
359	321	let coq_PEadd = lazy (constant "PEadd")
360	322	let coq_PEopp = lazy (constant "PEopp")
361	323	let coq_PEmul = lazy (constant "PEmul")
362	324	let coq_PEsub = lazy (constant "PEsub")
363	325	let coq_PEpow = lazy (constant "PEpow")
364
365		let coq_PX = lazy (constant "PX" )
366		let coq_Pc = lazy (constant"Pc")
	326	let coq_PX = lazy (constant "PX")
	327	let coq_Pc = lazy (constant "Pc")
367	328	let coq_Pinj = lazy (constant "Pinj")
368
369	329	let coq_OpEq = lazy (constant "OpEq")
370	330	let coq_OpNEq = lazy (constant "OpNEq")
371	331	let coq_OpLe = lazy (constant "OpLe")
372		let coq_OpLt = lazy (constant "OpLt")
	332	let coq_OpLt = lazy (constant "OpLt")
373	333	let coq_OpGe = lazy (constant "OpGe")
374		let coq_OpGt = lazy (constant "OpGt")
375
	334	let coq_OpGt = lazy (constant "OpGt")
376	335	let coq_PsatzIn = lazy (constant "PsatzIn")
377	336	let coq_PsatzSquare = lazy (constant "PsatzSquare")
378	337	let coq_PsatzMulE = lazy (constant "PsatzMulE")
379	338	let coq_PsatzMultC = lazy (constant "PsatzMulC")
380		let coq_PsatzAdd = lazy (constant "PsatzAdd")
381		let coq_PsatzC = lazy (constant "PsatzC")
382		let coq_PsatzZ = lazy (constant "PsatzZ")
	339	let coq_PsatzAdd = lazy (constant "PsatzAdd")
	340	let coq_PsatzC = lazy (constant "PsatzC")
	341	let coq_PsatzZ = lazy (constant "PsatzZ")
383	342
384	343	(* let coq_GT = lazy (m_constant "GT")*)
385	344
386	345	let coq_DeclaredConstant = lazy (m_constant "DeclaredConstant")
387	346
388		let coq_TT = lazy
389		(gen_constant_in_modules "ZMicromega"
390		[["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "TT")
391		let coq_FF = lazy
392		(gen_constant_in_modules "ZMicromega"
393		[["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "FF")
394		let coq_And = lazy
395		(gen_constant_in_modules "ZMicromega"
396		[["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "Cj")
397		let coq_Or = lazy
398		(gen_constant_in_modules "ZMicromega"
399		[["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "D")
400		let coq_Neg = lazy
401		(gen_constant_in_modules "ZMicromega"
402		[["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "N")
403		let coq_Atom = lazy
404		(gen_constant_in_modules "ZMicromega"
405		[["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "A")
406		let coq_X = lazy
407		(gen_constant_in_modules "ZMicromega"
408		[["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "X")
409		let coq_Impl = lazy
410		(gen_constant_in_modules "ZMicromega"
411		[["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "I")
412		let coq_Formula = lazy
413		(gen_constant_in_modules "ZMicromega"
414		[["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "BFormula")
	347	let coq_TT =
	348	lazy
	349	(gen_constant_in_modules "ZMicromega"
	350	[["Coq"; "micromega"; "Tauto"]; ["Tauto"]]
	351	"TT")
	352
	353	let coq_FF =
	354	lazy
	355	(gen_constant_in_modules "ZMicromega"
	356	[["Coq"; "micromega"; "Tauto"]; ["Tauto"]]
	357	"FF")
	358
	359	let coq_And =
	360	lazy
	361	(gen_constant_in_modules "ZMicromega"
	362	[["Coq"; "micromega"; "Tauto"]; ["Tauto"]]
	363	"Cj")
	364
	365	let coq_Or =
	366	lazy
	367	(gen_constant_in_modules "ZMicromega"
	368	[["Coq"; "micromega"; "Tauto"]; ["Tauto"]]
	369	"D")
	370
	371	let coq_Neg =
	372	lazy
	373	(gen_constant_in_modules "ZMicromega"
	374	[["Coq"; "micromega"; "Tauto"]; ["Tauto"]]
	375	"N")
	376
	377	let coq_Atom =
	378	lazy
	379	(gen_constant_in_modules "ZMicromega"
	380	[["Coq"; "micromega"; "Tauto"]; ["Tauto"]]
	381	"A")
	382
	383	let coq_X =
	384	lazy
	385	(gen_constant_in_modules "ZMicromega"
	386	[["Coq"; "micromega"; "Tauto"]; ["Tauto"]]
	387	"X")
	388
	389	let coq_Impl =
	390	lazy
	391	(gen_constant_in_modules "ZMicromega"
	392	[["Coq"; "micromega"; "Tauto"]; ["Tauto"]]
	393	"I")
	394
	395	let coq_Formula =
	396	lazy
	397	(gen_constant_in_modules "ZMicromega"
	398	[["Coq"; "micromega"; "Tauto"]; ["Tauto"]]
	399	"BFormula")
415	400
416	401	(**
417	402	* Initialization : a few Caml symbols are derived from other libraries;
418	403	* QMicromega, ZArithRing, RingMicromega.
419	404	*)
420	405
421		let coq_QWitness = lazy
422		(gen_constant_in_modules "QMicromega"
423		[["Coq"; "micromega"; "QMicromega"]] "QWitness")
424
425		let coq_Build = lazy
426		(gen_constant_in_modules "RingMicromega"
427		[["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ]
428		"Build_Formula")
429		let coq_Cstr = lazy
430		(gen_constant_in_modules "RingMicromega"
431		[["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] "Formula")
	406	let coq_QWitness =
	407	lazy
	408	(gen_constant_in_modules "QMicromega"
	409	[["Coq"; "micromega"; "QMicromega"]]
	410	"QWitness")
	411
	412	let coq_Build =
	413	lazy
	414	(gen_constant_in_modules "RingMicromega"
	415	[["Coq"; "micromega"; "RingMicromega"]; ["RingMicromega"]]
	416	"Build_Formula")
	417
	418	let coq_Cstr =
	419	lazy
	420	(gen_constant_in_modules "RingMicromega"
	421	[["Coq"; "micromega"; "RingMicromega"]; ["RingMicromega"]]
	422	"Formula")
432	423
433	424	(**
434	425	* Parsing and dumping : transformation functions between Caml and Coq

444	435	(* A simple but useful getter function *)
445	436
446	437	let get_left_construct sigma term =
447		match EConstr.kind sigma term with
448		\| Construct((_,i),_) -> (i,[\| \|])
449		\| App(l,rst) ->
450		(match EConstr.kind sigma l with
451		\| Construct((_,i),_) -> (i,rst)
452		\| _ -> raise ParseError
453		)
454		\| _ -> raise ParseError
	438	match EConstr.kind sigma term with
	439	\| Construct ((_, i), _) -> (i, [\|\|])
	440	\| App (l, rst) -> (
	441	match EConstr.kind sigma l with
	442	\| Construct ((_, i), _) -> (i, rst)
	443	\| _ -> raise ParseError )
	444	\| _ -> raise ParseError
455	445
456	446	(* Access the Micromega module *)
457	447
458	448	(* parse/dump/print from numbers up to expressions and formulas *)
459	449
460	450	let rec parse_nat sigma term =
461		let (i,c) = get_left_construct sigma term in
	451	let i, c = get_left_construct sigma term in
462	452	match i with
463		\| 1 -> Mc.O
464		\| 2 -> Mc.S (parse_nat sigma (c.(0)))
465		\| i -> raise ParseError
	453	\| 1 -> Mc.O
	454	\| 2 -> Mc.S (parse_nat sigma c.(0))
	455	\| i -> raise ParseError
466	456
467	457	let pp_nat o n = Printf.fprintf o "%i" (CoqToCaml.nat n)
468	458
469	459	let rec dump_nat x =
470		match x with
	460	match x with
471	461	\| Mc.O -> Lazy.force coq_O
472		\| Mc.S p -> EConstr.mkApp(Lazy.force coq_S,[\| dump_nat p \|])
	462	\| Mc.S p -> EConstr.mkApp (Lazy.force coq_S, [\|dump_nat p\|])
473	463
474	464	let rec parse_positive sigma term =
475		let (i,c) = get_left_construct sigma term in
	465	let i, c = get_left_construct sigma term in
476	466	match i with
477	467	\| 1 -> Mc.XI (parse_positive sigma c.(0))
478	468	\| 2 -> Mc.XO (parse_positive sigma c.(0))

482	472	let rec dump_positive x =
483	473	match x with
484	474	\| Mc.XH -> Lazy.force coq_xH
485		\| Mc.XO p -> EConstr.mkApp(Lazy.force coq_xO,[\| dump_positive p \|])
486		\| Mc.XI p -> EConstr.mkApp(Lazy.force coq_xI,[\| dump_positive p \|])
	475	\| Mc.XO p -> EConstr.mkApp (Lazy.force coq_xO, [\|dump_positive p\|])
	476	\| Mc.XI p -> EConstr.mkApp (Lazy.force coq_xI, [\|dump_positive p\|])
487	477
488	478	let pp_positive o x = Printf.fprintf o "%i" (CoqToCaml.positive x)
489	479
490	480	let dump_n x =
491	481	match x with
492	482	\| Mc.N0 -> Lazy.force coq_N0
493		\| Mc.Npos p -> EConstr.mkApp(Lazy.force coq_Npos,[\| dump_positive p\|])
	483	\| Mc.Npos p -> EConstr.mkApp (Lazy.force coq_Npos, [\|dump_positive p\|])
494	484
495	485	(** [is_ground_term env sigma term] holds if the term [term]
496	486	is an instance of the typeclass [DeclConstant.GT term]

501	491
502	492	let is_declared_term env evd t =
503	493	match EConstr.kind evd t with
504		\| Const _ \| Construct _ -> (* Restrict typeclass resolution to trivial cases *)
505		begin
506		let typ = Retyping.get_type_of env evd t in
507		try
508		ignore (Typeclasses.resolve_one_typeclass env evd (EConstr.mkApp(Lazy.force coq_DeclaredConstant,[\| typ;t\|]))) ; true
509		with Not_found -> false
510		end
511		\| _ -> false
	494	\| Const _ \| Construct _ -> (
	495	(* Restrict typeclass resolution to trivial cases *)
	496	let typ = Retyping.get_type_of env evd t in
	497	try
	498	ignore
	499	(Typeclasses.resolve_one_typeclass env evd
	500	(EConstr.mkApp (Lazy.force coq_DeclaredConstant, [\|typ; t\|])));
	501	true
	502	with Not_found -> false )
	503	\| _ -> false
512	504
513	505	let rec is_ground_term env evd term =
514	506	match EConstr.kind evd term with
515		\| App(c,args) ->
516		is_declared_term env evd c &&
517		Array.for_all (is_ground_term env evd) args
	507	\| App (c, args) ->
	508	is_declared_term env evd c && Array.for_all (is_ground_term env evd) args
518	509	\| Const _ \| Construct _ -> is_declared_term env evd term
519		\| _ -> false
520
	510	\| _ -> false
521	511
522	512	let parse_z sigma term =
523		let (i,c) = get_left_construct sigma term in
	513	let i, c = get_left_construct sigma term in
524	514	match i with
525	515	\| 1 -> Mc.Z0
526	516	\| 2 -> Mc.Zpos (parse_positive sigma c.(0))

528	518	\| i -> raise ParseError
529	519
530	520	let dump_z x =
531		match x with
532		\| Mc.Z0 ->Lazy.force coq_ZERO
533		\| Mc.Zpos p -> EConstr.mkApp(Lazy.force coq_POS,[\| dump_positive p\|])
534		\| Mc.Zneg p -> EConstr.mkApp(Lazy.force coq_NEG,[\| dump_positive p\|])
535
536		let pp_z o x = Printf.fprintf o "%s" (Big_int.string_of_big_int (CoqToCaml.z_big_int x))
	521	match x with
	522	\| Mc.Z0 -> Lazy.force coq_ZERO
	523	\| Mc.Zpos p -> EConstr.mkApp (Lazy.force coq_POS, [\|dump_positive p\|])
	524	\| Mc.Zneg p -> EConstr.mkApp (Lazy.force coq_NEG, [\|dump_positive p\|])
	525
	526	let pp_z o x =
	527	Printf.fprintf o "%s" (Big_int.string_of_big_int (CoqToCaml.z_big_int x))
537	528
538	529	let dump_q q =
539		EConstr.mkApp(Lazy.force coq_Qmake,
540		[\| dump_z q.Micromega.qnum ; dump_positive q.Micromega.qden\|])
	530	EConstr.mkApp
	531	( Lazy.force coq_Qmake
	532	, [\|dump_z q.Micromega.qnum; dump_positive q.Micromega.qden\|] )
541	533
542	534	let parse_q sigma term =
543		match EConstr.kind sigma term with
544		\| App(c, args) -> if EConstr.eq_constr sigma c (Lazy.force coq_Qmake) then
545		{Mc.qnum = parse_z sigma args.(0) ; Mc.qden = parse_positive sigma args.(1) }
546		else raise ParseError
547		\| _ -> raise ParseError
548
	535	match EConstr.kind sigma term with
	536	\| App (c, args) ->
	537	if EConstr.eq_constr sigma c (Lazy.force coq_Qmake) then
	538	{ Mc.qnum = parse_z sigma args.(0)
	539	; Mc.qden = parse_positive sigma args.(1) }
	540	else raise ParseError
	541	\| _ -> raise ParseError
549	542
550	543	let rec pp_Rcst o cst =
551	544	match cst with
552		\| Mc.C0 -> output_string o "C0"
553		\| Mc.C1 -> output_string o "C1"
554		\| Mc.CQ q -> output_string o "CQ _"
555		\| Mc.CZ z -> pp_z o z
556		\| Mc.CPlus(x,y) -> Printf.fprintf o "(%a + %a)" pp_Rcst x pp_Rcst y
557		\| Mc.CMinus(x,y) -> Printf.fprintf o "(%a - %a)" pp_Rcst x pp_Rcst y
558		\| Mc.CMult(x,y) -> Printf.fprintf o "(%a * %a)" pp_Rcst x pp_Rcst y
559		\| Mc.CPow(x,y) -> Printf.fprintf o "(%a ^ _)" pp_Rcst x
560		\| Mc.CInv t -> Printf.fprintf o "(/ %a)" pp_Rcst t
561		\| Mc.COpp t -> Printf.fprintf o "(- %a)" pp_Rcst t
562
	545	\| Mc.C0 -> output_string o "C0"
	546	\| Mc.C1 -> output_string o "C1"
	547	\| Mc.CQ q -> output_string o "CQ _"
	548	\| Mc.CZ z -> pp_z o z
	549	\| Mc.CPlus (x, y) -> Printf.fprintf o "(%a + %a)" pp_Rcst x pp_Rcst y
	550	\| Mc.CMinus (x, y) -> Printf.fprintf o "(%a - %a)" pp_Rcst x pp_Rcst y
	551	\| Mc.CMult (x, y) -> Printf.fprintf o "(%a * %a)" pp_Rcst x pp_Rcst y
	552	\| Mc.CPow (x, y) -> Printf.fprintf o "(%a ^ _)" pp_Rcst x
	553	\| Mc.CInv t -> Printf.fprintf o "(/ %a)" pp_Rcst t
	554	\| Mc.COpp t -> Printf.fprintf o "(- %a)" pp_Rcst t
563	555
564	556	let rec dump_Rcst cst =
565	557	match cst with
566		\| Mc.C0 -> Lazy.force coq_C0
567		\| Mc.C1 -> Lazy.force coq_C1
568		\| Mc.CQ q -> EConstr.mkApp(Lazy.force coq_CQ, [\| dump_q q \|])
569		\| Mc.CZ z -> EConstr.mkApp(Lazy.force coq_CZ, [\| dump_z z \|])
570		\| Mc.CPlus(x,y) -> EConstr.mkApp(Lazy.force coq_CPlus, [\| dump_Rcst x ; dump_Rcst y \|])
571		\| Mc.CMinus(x,y) -> EConstr.mkApp(Lazy.force coq_CMinus, [\| dump_Rcst x ; dump_Rcst y \|])
572		\| Mc.CMult(x,y) -> EConstr.mkApp(Lazy.force coq_CMult, [\| dump_Rcst x ; dump_Rcst y \|])
573		\| Mc.CPow(x,y) -> EConstr.mkApp(Lazy.force coq_CPow, [\| dump_Rcst x ;
574		match y with
575		\| Mc.Inl z -> EConstr.mkApp(Lazy.force coq_Inl,[\| Lazy.force coq_Z ; Lazy.force coq_nat; dump_z z\|])
576		\| Mc.Inr n -> EConstr.mkApp(Lazy.force coq_Inr,[\| Lazy.force coq_Z ; Lazy.force coq_nat; dump_nat n\|])
577		\|])
578		\| Mc.CInv t -> EConstr.mkApp(Lazy.force coq_CInv, [\| dump_Rcst t \|])
579		\| Mc.COpp t -> EConstr.mkApp(Lazy.force coq_COpp, [\| dump_Rcst t \|])
	558	\| Mc.C0 -> Lazy.force coq_C0
	559	\| Mc.C1 -> Lazy.force coq_C1
	560	\| Mc.CQ q -> EConstr.mkApp (Lazy.force coq_CQ, [\|dump_q q\|])
	561	\| Mc.CZ z -> EConstr.mkApp (Lazy.force coq_CZ, [\|dump_z z\|])
	562	\| Mc.CPlus (x, y) ->
	563	EConstr.mkApp (Lazy.force coq_CPlus, [\|dump_Rcst x; dump_Rcst y\|])
	564	\| Mc.CMinus (x, y) ->
	565	EConstr.mkApp (Lazy.force coq_CMinus, [\|dump_Rcst x; dump_Rcst y\|])
	566	\| Mc.CMult (x, y) ->
	567	EConstr.mkApp (Lazy.force coq_CMult, [\|dump_Rcst x; dump_Rcst y\|])
	568	\| Mc.CPow (x, y) ->
	569	EConstr.mkApp
	570	( Lazy.force coq_CPow
	571	, [\| dump_Rcst x
	572	; ( match y with
	573	\| Mc.Inl z ->
	574	EConstr.mkApp
	575	( Lazy.force coq_Inl
	576	, [\|Lazy.force coq_Z; Lazy.force coq_nat; dump_z z\|] )
	577	\| Mc.Inr n ->
	578	EConstr.mkApp
	579	( Lazy.force coq_Inr
	580	, [\|Lazy.force coq_Z; Lazy.force coq_nat; dump_nat n\|] ) ) \|]
	581	)
	582	\| Mc.CInv t -> EConstr.mkApp (Lazy.force coq_CInv, [\|dump_Rcst t\|])
	583	\| Mc.COpp t -> EConstr.mkApp (Lazy.force coq_COpp, [\|dump_Rcst t\|])
580	584
581	585	let rec dump_list typ dump_elt l =
582		match l with
583		\| [] -> EConstr.mkApp(Lazy.force coq_nil,[\| typ \|])
584		\| e :: l -> EConstr.mkApp(Lazy.force coq_cons,
585		[\| typ; dump_elt e;dump_list typ dump_elt l\|])
	586	match l with
	587	\| [] -> EConstr.mkApp (Lazy.force coq_nil, [\|typ\|])
	588	\| e :: l ->
	589	EConstr.mkApp
	590	(Lazy.force coq_cons, [\|typ; dump_elt e; dump_list typ dump_elt l\|])
586	591
587	592	let pp_list op cl elt o l =
588		let rec _pp o l =
589		match l with
590		\| [] -> ()
591		\| [e] -> Printf.fprintf o "%a" elt e
592		\| e::l -> Printf.fprintf o "%a ,%a" elt e _pp l in
	593	let rec _pp o l =
	594	match l with
	595	\| [] -> ()
	596	\| [e] -> Printf.fprintf o "%a" elt e
	597	\| e :: l -> Printf.fprintf o "%a ,%a" elt e _pp l
	598	in
593	599	Printf.fprintf o "%s%a%s" op _pp l cl
594	600
595	601	let dump_var = dump_positive
596	602
597	603	let dump_expr typ dump_z e =
598		let rec dump_expr e =
599		match e with
600		\| Mc.PEX n -> EConstr.mkApp(Lazy.force coq_PEX,[\| typ; dump_var n \|])
601		\| Mc.PEc z -> EConstr.mkApp(Lazy.force coq_PEc,[\| typ ; dump_z z \|])
602		\| Mc.PEadd(e1,e2) -> EConstr.mkApp(Lazy.force coq_PEadd,
603		[\| typ; dump_expr e1;dump_expr e2\|])
604		\| Mc.PEsub(e1,e2) -> EConstr.mkApp(Lazy.force coq_PEsub,
605		[\| typ; dump_expr e1;dump_expr e2\|])
606		\| Mc.PEopp e -> EConstr.mkApp(Lazy.force coq_PEopp,
607		[\| typ; dump_expr e\|])
608		\| Mc.PEmul(e1,e2) -> EConstr.mkApp(Lazy.force coq_PEmul,
609		[\| typ; dump_expr e1;dump_expr e2\|])
610		\| Mc.PEpow(e,n) -> EConstr.mkApp(Lazy.force coq_PEpow,
611		[\| typ; dump_expr e; dump_n n\|])
612		in
	604	let rec dump_expr e =
	605	match e with
	606	\| Mc.PEX n -> EConstr.mkApp (Lazy.force coq_PEX, [\|typ; dump_var n\|])
	607	\| Mc.PEc z -> EConstr.mkApp (Lazy.force coq_PEc, [\|typ; dump_z z\|])
	608	\| Mc.PEadd (e1, e2) ->
	609	EConstr.mkApp (Lazy.force coq_PEadd, [\|typ; dump_expr e1; dump_expr e2\|])
	610	\| Mc.PEsub (e1, e2) ->
	611	EConstr.mkApp (Lazy.force coq_PEsub, [\|typ; dump_expr e1; dump_expr e2\|])
	612	\| Mc.PEopp e -> EConstr.mkApp (Lazy.force coq_PEopp, [\|typ; dump_expr e\|])
	613	\| Mc.PEmul (e1, e2) ->
	614	EConstr.mkApp (Lazy.force coq_PEmul, [\|typ; dump_expr e1; dump_expr e2\|])
	615	\| Mc.PEpow (e, n) ->
	616	EConstr.mkApp (Lazy.force coq_PEpow, [\|typ; dump_expr e; dump_n n\|])
	617	in
613	618	dump_expr e
614	619
615	620	let dump_pol typ dump_c e =
616	621	let rec dump_pol e =
617	622	match e with
618		\| Mc.Pc n -> EConstr.mkApp(Lazy.force coq_Pc, [\|typ ; dump_c n\|])
619		\| Mc.Pinj(p,pol) -> EConstr.mkApp(Lazy.force coq_Pinj , [\| typ ; dump_positive p ; dump_pol pol\|])
620		\| Mc.PX(pol1,p,pol2) -> EConstr.mkApp(Lazy.force coq_PX, [\| typ ; dump_pol pol1 ; dump_positive p ; dump_pol pol2\|]) in
621		dump_pol e
	623	\| Mc.Pc n -> EConstr.mkApp (Lazy.force coq_Pc, [\|typ; dump_c n\|])
	624	\| Mc.Pinj (p, pol) ->
	625	EConstr.mkApp
	626	(Lazy.force coq_Pinj, [\|typ; dump_positive p; dump_pol pol\|])
	627	\| Mc.PX (pol1, p, pol2) ->
	628	EConstr.mkApp
	629	( Lazy.force coq_PX
	630	, [\|typ; dump_pol pol1; dump_positive p; dump_pol pol2\|] )
	631	in
	632	dump_pol e
622	633
623	634	let pp_pol pp_c o e =
624	635	let rec pp_pol o e =
625	636	match e with
626		\| Mc.Pc n -> Printf.fprintf o "Pc %a" pp_c n
627		\| Mc.Pinj(p,pol) -> Printf.fprintf o "Pinj(%a,%a)" pp_positive p pp_pol pol
628		\| Mc.PX(pol1,p,pol2) -> Printf.fprintf o "PX(%a,%a,%a)" pp_pol pol1 pp_positive p pp_pol pol2 in
629		pp_pol o e
630
631		(* let pp_clause pp_c o (f: 'cst clause) =
	637	\| Mc.Pc n -> Printf.fprintf o "Pc %a" pp_c n
	638	\| Mc.Pinj (p, pol) ->
	639	Printf.fprintf o "Pinj(%a,%a)" pp_positive p pp_pol pol
	640	\| Mc.PX (pol1, p, pol2) ->
	641	Printf.fprintf o "PX(%a,%a,%a)" pp_pol pol1 pp_positive p pp_pol pol2
	642	in
	643	pp_pol o e
	644
	645	(* let pp_clause pp_c o (f: 'cst clause) =
632	646	List.iter (fun ((p,_),(t,_)) -> Printf.fprintf o "(%a @%a)" (pp_pol pp_c) p Tag.pp t) f *)
633	647
634		let pp_clause_tag o (f: 'cst clause) =
635		List.iter (fun ((p,_),(t,_)) -> Printf.fprintf o "(_ @%a)" Tag.pp t) f
636
637		(* let pp_cnf pp_c o (f:'cst cnf) =
	648	let pp_clause_tag o (f : 'cst clause) =
	649	List.iter (fun ((p, _), (t, _)) -> Printf.fprintf o "(_ @%a)" Tag.pp t) f
	650
	651	(* let pp_cnf pp_c o (f:'cst cnf) =
638	652	List.iter (fun l -> Printf.fprintf o "[%a]" (pp_clause pp_c) l) f *)
639	653
640		let pp_cnf_tag o (f:'cst cnf) =
	654	let pp_cnf_tag o (f : 'cst cnf) =
641	655	List.iter (fun l -> Printf.fprintf o "[%a]" pp_clause_tag l) f
642	656
643
644	657	let dump_psatz typ dump_z e =
645		let z = Lazy.force typ in
646		let rec dump_cone e =
647		match e with
648		\| Mc.PsatzIn n -> EConstr.mkApp(Lazy.force coq_PsatzIn,[\| z; dump_nat n \|])
649		\| Mc.PsatzMulC(e,c) -> EConstr.mkApp(Lazy.force coq_PsatzMultC,
650		[\| z; dump_pol z dump_z e ; dump_cone c \|])
651		\| Mc.PsatzSquare e -> EConstr.mkApp(Lazy.force coq_PsatzSquare,
652		[\| z;dump_pol z dump_z e\|])
653		\| Mc.PsatzAdd(e1,e2) -> EConstr.mkApp(Lazy.force coq_PsatzAdd,
654		[\| z; dump_cone e1; dump_cone e2\|])
655		\| Mc.PsatzMulE(e1,e2) -> EConstr.mkApp(Lazy.force coq_PsatzMulE,
656		[\| z; dump_cone e1; dump_cone e2\|])
657		\| Mc.PsatzC p -> EConstr.mkApp(Lazy.force coq_PsatzC,[\| z; dump_z p\|])
658		\| Mc.PsatzZ -> EConstr.mkApp(Lazy.force coq_PsatzZ,[\| z\|]) in
659		dump_cone e
660
661		let pp_psatz pp_z o e =
662		let rec pp_cone o e =
663		match e with
664		\| Mc.PsatzIn n ->
665		Printf.fprintf o "(In %a)%%nat" pp_nat n
666		\| Mc.PsatzMulC(e,c) ->
	658	let z = Lazy.force typ in
	659	let rec dump_cone e =
	660	match e with
	661	\| Mc.PsatzIn n -> EConstr.mkApp (Lazy.force coq_PsatzIn, [\|z; dump_nat n\|])
	662	\| Mc.PsatzMulC (e, c) ->
	663	EConstr.mkApp
	664	(Lazy.force coq_PsatzMultC, [\|z; dump_pol z dump_z e; dump_cone c\|])
	665	\| Mc.PsatzSquare e ->
	666	EConstr.mkApp (Lazy.force coq_PsatzSquare, [\|z; dump_pol z dump_z e\|])
	667	\| Mc.PsatzAdd (e1, e2) ->
	668	EConstr.mkApp
	669	(Lazy.force coq_PsatzAdd, [\|z; dump_cone e1; dump_cone e2\|])
	670	\| Mc.PsatzMulE (e1, e2) ->
	671	EConstr.mkApp
	672	(Lazy.force coq_PsatzMulE, [\|z; dump_cone e1; dump_cone e2\|])
	673	\| Mc.PsatzC p -> EConstr.mkApp (Lazy.force coq_PsatzC, [\|z; dump_z p\|])
	674	\| Mc.PsatzZ -> EConstr.mkApp (Lazy.force coq_PsatzZ, [\|z\|])
	675	in
	676	dump_cone e
	677
	678	let pp_psatz pp_z o e =
	679	let rec pp_cone o e =
	680	match e with
	681	\| Mc.PsatzIn n -> Printf.fprintf o "(In %a)%%nat" pp_nat n
	682	\| Mc.PsatzMulC (e, c) ->
667	683	Printf.fprintf o "( %a [*] %a)" (pp_pol pp_z) e pp_cone c
668		\| Mc.PsatzSquare e ->
669		Printf.fprintf o "(%a^2)" (pp_pol pp_z) e
670		\| Mc.PsatzAdd(e1,e2) ->
	684	\| Mc.PsatzSquare e -> Printf.fprintf o "(%a^2)" (pp_pol pp_z) e
	685	\| Mc.PsatzAdd (e1, e2) ->
671	686	Printf.fprintf o "(%a [+] %a)" pp_cone e1 pp_cone e2
672		\| Mc.PsatzMulE(e1,e2) ->
	687	\| Mc.PsatzMulE (e1, e2) ->
673	688	Printf.fprintf o "(%a [*] %a)" pp_cone e1 pp_cone e2
674		\| Mc.PsatzC p ->
675		Printf.fprintf o "(%a)%%positive" pp_z p
676		\| Mc.PsatzZ ->
677		Printf.fprintf o "0" in
	689	\| Mc.PsatzC p -> Printf.fprintf o "(%a)%%positive" pp_z p
	690	\| Mc.PsatzZ -> Printf.fprintf o "0"
	691	in
678	692	pp_cone o e
679	693
680	694	let dump_op = function
681		\| Mc.OpEq-> Lazy.force coq_OpEq
682		\| Mc.OpNEq-> Lazy.force coq_OpNEq
683		\| Mc.OpLe -> Lazy.force coq_OpLe
684		\| Mc.OpGe -> Lazy.force coq_OpGe
685		\| Mc.OpGt-> Lazy.force coq_OpGt
686		\| Mc.OpLt-> Lazy.force coq_OpLt
687
688		let dump_cstr typ dump_constant {Mc.flhs = e1 ; Mc.fop = o ; Mc.frhs = e2} =
689		EConstr.mkApp(Lazy.force coq_Build,
690		[\| typ; dump_expr typ dump_constant e1 ;
691		dump_op o ;
692		dump_expr typ dump_constant e2\|])
	695	\| Mc.OpEq -> Lazy.force coq_OpEq
	696	\| Mc.OpNEq -> Lazy.force coq_OpNEq
	697	\| Mc.OpLe -> Lazy.force coq_OpLe
	698	\| Mc.OpGe -> Lazy.force coq_OpGe
	699	\| Mc.OpGt -> Lazy.force coq_OpGt
	700	\| Mc.OpLt -> Lazy.force coq_OpLt
	701
	702	let dump_cstr typ dump_constant {Mc.flhs = e1; Mc.fop = o; Mc.frhs = e2} =
	703	EConstr.mkApp
	704	( Lazy.force coq_Build
	705	, [\| typ
	706	; dump_expr typ dump_constant e1
	707	; dump_op o
	708	; dump_expr typ dump_constant e2 \|] )
693	709
694	710	let assoc_const sigma x l =
695		try
696		snd (List.find (fun (x',y) -> EConstr.eq_constr sigma x (Lazy.force x')) l)
697		with
698		Not_found -> raise ParseError
699
700		let zop_table = [
701		coq_Zgt, Mc.OpGt ;
702		coq_Zge, Mc.OpGe ;
703		coq_Zlt, Mc.OpLt ;
704		coq_Zle, Mc.OpLe ]
705
706		let rop_table = [
707		coq_Rgt, Mc.OpGt ;
708		coq_Rge, Mc.OpGe ;
709		coq_Rlt, Mc.OpLt ;
710		coq_Rle, Mc.OpLe ]
711
712		let qop_table = [
713		coq_Qlt, Mc.OpLt ;
714		coq_Qle, Mc.OpLe ;
715		coq_Qeq, Mc.OpEq
716		]
717
718		type gl = { env : Environ.env; sigma : Evd.evar_map }
719
720		let is_convertible gl t1 t2 =
721		Reductionops.is_conv gl.env gl.sigma t1 t2
722
723		let parse_zop gl (op,args) =
	711	try
	712	snd
	713	(List.find (fun (x', y) -> EConstr.eq_constr sigma x (Lazy.force x')) l)
	714	with Not_found -> raise ParseError
	715
	716	let zop_table =
	717	[ (coq_Zgt, Mc.OpGt)
	718	; (coq_Zge, Mc.OpGe)
	719	; (coq_Zlt, Mc.OpLt)
	720	; (coq_Zle, Mc.OpLe) ]
	721
	722	let rop_table =
	723	[ (coq_Rgt, Mc.OpGt)
	724	; (coq_Rge, Mc.OpGe)
	725	; (coq_Rlt, Mc.OpLt)
	726	; (coq_Rle, Mc.OpLe) ]
	727
	728	let qop_table = [(coq_Qlt, Mc.OpLt); (coq_Qle, Mc.OpLe); (coq_Qeq, Mc.OpEq)]
	729
	730	type gl = {env : Environ.env; sigma : Evd.evar_map}
	731
	732	let is_convertible gl t1 t2 = Reductionops.is_conv gl.env gl.sigma t1 t2
	733
	734	let parse_zop gl (op, args) =
724	735	let sigma = gl.sigma in
725	736	match args with
726		\| [\| a1 ; a2\|] -> assoc_const sigma op zop_table, a1, a2
727		\| [\| ty ; a1 ; a2\|] ->
728		if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl ty (Lazy.force coq_Z)
729		then (Mc.OpEq, args.(1), args.(2))
730		else raise ParseError
731		\| _ -> raise ParseError
732
733		let parse_rop gl (op,args) =
	737	\| [\|a1; a2\|] -> (assoc_const sigma op zop_table, a1, a2)
	738	\| [\|ty; a1; a2\|] ->
	739	if
	740	EConstr.eq_constr sigma op (Lazy.force coq_Eq)
	741	&& is_convertible gl ty (Lazy.force coq_Z)
	742	then (Mc.OpEq, args.(1), args.(2))
	743	else raise ParseError
	744	\| _ -> raise ParseError
	745
	746	let parse_rop gl (op, args) =
734	747	let sigma = gl.sigma in
735	748	match args with
736		\| [\| a1 ; a2\|] -> assoc_const sigma op rop_table, a1 , a2
737		\| [\| ty ; a1 ; a2\|] ->
738		if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl ty (Lazy.force coq_R)
739		then (Mc.OpEq, a1, a2)
740		else raise ParseError
741		\| _ -> raise ParseError
742
743		let parse_qop gl (op,args) =
744		if Array.length args = 2
745		then (assoc_const gl.sigma op qop_table, args.(0) , args.(1))
	749	\| [\|a1; a2\|] -> (assoc_const sigma op rop_table, a1, a2)
	750	\| [\|ty; a1; a2\|] ->
	751	if
	752	EConstr.eq_constr sigma op (Lazy.force coq_Eq)
	753	&& is_convertible gl ty (Lazy.force coq_R)
	754	then (Mc.OpEq, a1, a2)
	755	else raise ParseError
	756	\| _ -> raise ParseError
	757
	758	let parse_qop gl (op, args) =
	759	if Array.length args = 2 then
	760	(assoc_const gl.sigma op qop_table, args.(0), args.(1))
746	761	else raise ParseError
747	762
748	763	type 'a op =

752	767	\| Ukn of string
753	768
754	769	let assoc_ops sigma x l =
755		try
756		snd (List.find (fun (x',y) -> EConstr.eq_constr sigma x (Lazy.force x')) l)
757		with
758		Not_found -> Ukn "Oups"
	770	try
	771	snd
	772	(List.find (fun (x', y) -> EConstr.eq_constr sigma x (Lazy.force x')) l)
	773	with Not_found -> Ukn "Oups"
759	774
760	775	(**
761	776	* MODULE: Env is for environment.
762	777	*)
763	778
764		module Env =
765		struct
766
767		type t = {
768		vars : EConstr.t list ;
769		(* The list represents a mapping from EConstr.t to indexes. *)
770		gl : gl;
771		(* The evar_map may be updated due to unification of universes *)
772		}
773
774		let empty gl =
775		{
776		vars = [];
777		gl = gl
778		}
779
	779	module Env = struct
	780	type t =
	781	{ vars : EConstr.t list
	782	; (* The list represents a mapping from EConstr.t to indexes. *)
	783	gl : gl
	784	(* The evar_map may be updated due to unification of universes *) }
	785
	786	let empty gl = {vars = []; gl}
780	787
781	788	(** [eq_constr gl x y] returns an updated [gl] if x and y can be unified *)
782	789	let eq_constr gl x y =
783	790	let evd = gl.sigma in
784	791	match EConstr.eq_constr_universes_proj gl.env evd x y with
785		\| Some csts ->
786		let csts = UnivProblem.to_constraints ~force_weak:false (Evd.universes evd) csts in
787		begin
788		match Evd.add_constraints evd csts with
789		\| evd -> Some {gl with sigma = evd}
790		\| exception Univ.UniverseInconsistency _ -> None
791		end
	792	\| Some csts -> (
	793	let csts =
	794	UnivProblem.to_constraints ~force_weak:false (Evd.universes evd) csts
	795	in
	796	match Evd.add_constraints evd csts with
	797	\| evd -> Some {gl with sigma = evd}
	798	\| exception Univ.UniverseInconsistency _ -> None )
792	799	\| None -> None
793	800
794	801	let compute_rank_add env v =
795	802	let rec _add gl vars n v =
796	803	match vars with
797		\| [] -> (gl, [v] ,n)
798		\| e::l ->
799		match eq_constr gl e v with
800		\| Some gl' -> (gl', vars , n)
801		\| None ->
802		let (gl,l',n) = _add gl l ( n+1) v in
803		(gl,e::l',n) in
804		let (gl',vars', n) = _add env.gl env.vars 1 v in
805		({vars=vars';gl=gl'}, CamlToCoq.positive n)
806
807		let get_rank env v =
808		let gl = env.gl in
809
810		let rec _get_rank env n =
811		match env with
812		\| [] -> raise (Invalid_argument "get_rank")
813		\| e::l ->
814		match eq_constr gl e v with
815		\| Some _ -> n
816		\| None -> _get_rank l (n+1)
817		in
818		_get_rank env.vars 1
819
820		let elements env = env.vars
821
822		(* let string_of_env gl env =
	804	\| [] -> (gl, [v], n)
	805	\| e :: l -> (
	806	match eq_constr gl e v with
	807	\| Some gl' -> (gl', vars, n)
	808	\| None ->
	809	let gl, l', n = _add gl l (n + 1) v in
	810	(gl, e :: l', n) )
	811	in
	812	let gl', vars', n = _add env.gl env.vars 1 v in
	813	({vars = vars'; gl = gl'}, CamlToCoq.positive n)
	814
	815	let get_rank env v =
	816	let gl = env.gl in
	817	let rec _get_rank env n =
	818	match env with
	819	\| [] -> raise (Invalid_argument "get_rank")
	820	\| e :: l -> (
	821	match eq_constr gl e v with Some _ -> n \| None -> _get_rank l (n + 1)
	822	)
	823	in
	824	_get_rank env.vars 1
	825
	826	let elements env = env.vars
	827
	828	(* let string_of_env gl env =
823	829	let rec string_of_env i env acc =
824	830	match env with
825	831	\| [] -> acc

829	835	(Printer.pr_econstr_env gl.env gl.sigma e)) acc) in
830	836	string_of_env 1 env IMap.empty
831	837	*)
832		let pp gl env =
833		let ppl = List.mapi (fun i e -> Pp.str "x" ++ Pp.int (i+1) ++ Pp.str ":" ++ Printer.pr_econstr_env gl.env gl.sigma e)env in
834		List.fold_right (fun e p -> e ++ Pp.str " ; " ++ p ) ppl (Pp.str "\n")
835
836		end (* MODULE END: Env *)
	838	let pp gl env =
	839	let ppl =
	840	List.mapi
	841	(fun i e ->
	842	Pp.str "x"
	843	++ Pp.int (i + 1)
	844	++ Pp.str ":"
	845	++ Printer.pr_econstr_env gl.env gl.sigma e)
	846	env
	847	in
	848	List.fold_right (fun e p -> e ++ Pp.str " ; " ++ p) ppl (Pp.str "\n")
	849	end
	850
	851	(* MODULE END: Env *)
837	852
838	853	(**
839	854	* This is the big generic function for expression parsers.
840	855	*)
841	856
842	857	let parse_expr gl parse_constant parse_exp ops_spec env term =
843		if debug
844		then (
845		Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.pr_leconstr_env gl.env gl.sigma term));
846
	858	if debug then
	859	Feedback.msg_debug
	860	(Pp.str "parse_expr: " ++ Printer.pr_leconstr_env gl.env gl.sigma term);
847	861	let parse_variable env term =
848		let (env,n) = Env.compute_rank_add env term in
849		(Mc.PEX n , env) in
850
	862	let env, n = Env.compute_rank_add env term in
	863	(Mc.PEX n, env)
	864	in
851	865	let rec parse_expr env term =
852		let combine env op (t1,t2) =
853		let (expr1,env) = parse_expr env t1 in
854		let (expr2,env) = parse_expr env t2 in
855		(op expr1 expr2,env) in
856
857		try (Mc.PEc (parse_constant gl term) , env)
858		with ParseError ->
859		match EConstr.kind gl.sigma term with
860		\| App(t,args) ->
861		(
862		match EConstr.kind gl.sigma t with
863		\| Const c ->
864		( match assoc_ops gl.sigma t ops_spec with
865		\| Binop f -> combine env f (args.(0),args.(1))
866		\| Opp -> let (expr,env) = parse_expr env args.(0) in
867		(Mc.PEopp expr, env)
868		\| Power ->
869		begin
870		try
871		let (expr,env) = parse_expr env args.(0) in
872		let power = (parse_exp expr args.(1)) in
873		(power , env)
874		with ParseError ->
875		(* if the exponent is a variable *)
876		let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env)
877		end
878		\| Ukn s ->
879		if debug
880		then (Printf.printf "unknown op: %s\n" s; flush stdout;);
881		let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env)
882		)
883		\| _ -> parse_variable env term
884		)
885		\| _ -> parse_variable env term in
886		parse_expr env term
	866	let combine env op (t1, t2) =
	867	let expr1, env = parse_expr env t1 in
	868	let expr2, env = parse_expr env t2 in
	869	(op expr1 expr2, env)
	870	in
	871	try (Mc.PEc (parse_constant gl term), env)
	872	with ParseError -> (
	873	match EConstr.kind gl.sigma term with
	874	\| App (t, args) -> (
	875	match EConstr.kind gl.sigma t with
	876	\| Const c -> (
	877	match assoc_ops gl.sigma t ops_spec with
	878	\| Binop f -> combine env f (args.(0), args.(1))
	879	\| Opp ->
	880	let expr, env = parse_expr env args.(0) in
	881	(Mc.PEopp expr, env)
	882	\| Power -> (
	883	try
	884	let expr, env = parse_expr env args.(0) in
	885	let power = parse_exp expr args.(1) in
	886	(power, env)
	887	with ParseError ->
	888	(* if the exponent is a variable *)
	889	let env, n = Env.compute_rank_add env term in
	890	(Mc.PEX n, env) )
	891	\| Ukn s ->
	892	if debug then (
	893	Printf.printf "unknown op: %s\n" s;
	894	flush stdout );
	895	let env, n = Env.compute_rank_add env term in
	896	(Mc.PEX n, env) )
	897	\| _ -> parse_variable env term )
	898	\| _ -> parse_variable env term )
	899	in
	900	parse_expr env term
887	901
888	902	let zop_spec =
889		[
890		coq_Zplus , Binop (fun x y -> Mc.PEadd(x,y)) ;
891		coq_Zminus , Binop (fun x y -> Mc.PEsub(x,y)) ;
892		coq_Zmult , Binop (fun x y -> Mc.PEmul (x,y)) ;
893		coq_Zopp , Opp ;
894		coq_Zpower , Power]
	903	[ (coq_Zplus, Binop (fun x y -> Mc.PEadd (x, y)))
	904	; (coq_Zminus, Binop (fun x y -> Mc.PEsub (x, y)))
	905	; (coq_Zmult, Binop (fun x y -> Mc.PEmul (x, y)))
	906	; (coq_Zopp, Opp)
	907	; (coq_Zpower, Power) ]
895	908
896	909	let qop_spec =
897		[
898		coq_Qplus , Binop (fun x y -> Mc.PEadd(x,y)) ;
899		coq_Qminus , Binop (fun x y -> Mc.PEsub(x,y)) ;
900		coq_Qmult , Binop (fun x y -> Mc.PEmul (x,y)) ;
901		coq_Qopp , Opp ;
902		coq_Qpower , Power]
	910	[ (coq_Qplus, Binop (fun x y -> Mc.PEadd (x, y)))
	911	; (coq_Qminus, Binop (fun x y -> Mc.PEsub (x, y)))
	912	; (coq_Qmult, Binop (fun x y -> Mc.PEmul (x, y)))
	913	; (coq_Qopp, Opp)
	914	; (coq_Qpower, Power) ]
903	915
904	916	let rop_spec =
905		[
906		coq_Rplus , Binop (fun x y -> Mc.PEadd(x,y)) ;
907		coq_Rminus , Binop (fun x y -> Mc.PEsub(x,y)) ;
908		coq_Rmult , Binop (fun x y -> Mc.PEmul (x,y)) ;
909		coq_Ropp , Opp ;
910		coq_Rpower , Power]
911
912		let parse_constant parse gl t = parse gl.sigma t
	917	[ (coq_Rplus, Binop (fun x y -> Mc.PEadd (x, y)))
	918	; (coq_Rminus, Binop (fun x y -> Mc.PEsub (x, y)))
	919	; (coq_Rmult, Binop (fun x y -> Mc.PEmul (x, y)))
	920	; (coq_Ropp, Opp)
	921	; (coq_Rpower, Power) ]
	922
	923	let parse_constant parse gl t = parse gl.sigma t
913	924
914	925	(** [parse_more_constant parse gl t] returns the reification of term [t].
915	926	If [t] is a ground term, then it is first reduced to normal form
916	927	before using a 'syntactic' parser *)
917	928	let parse_more_constant parse gl t =
918		try
919		parse gl t
920		with ParseError ->
921		begin
922		if debug then Feedback.msg_debug Pp.(str "try harder");
923		if is_ground_term gl.env gl.sigma t
924		then parse gl (Redexpr.cbv_vm gl.env gl.sigma t)
925		else raise ParseError
926		end
	929	try parse gl t
	930	with ParseError ->
	931	if debug then Feedback.msg_debug Pp.(str "try harder");
	932	if is_ground_term gl.env gl.sigma t then
	933	parse gl (Redexpr.cbv_vm gl.env gl.sigma t)
	934	else raise ParseError
927	935
928	936	let zconstant = parse_constant parse_z
929	937	let qconstant = parse_constant parse_q

934	942	[parse_constant_expr] returns a constant if the argument is an expression without variables. *)
935	943
936	944	let rec parse_zexpr gl =
937		parse_expr gl
938		zconstant
939		(fun expr (x:EConstr.t) ->
	945	parse_expr gl zconstant
	946	(fun expr (x : EConstr.t) ->
940	947	let z = parse_zconstant gl x in
941	948	match z with
942	949	\| Mc.Zneg _ -> Mc.PEc Mc.Z0
943		\| _ -> Mc.PEpow(expr, Mc.Z.to_N z)
944		)
945		zop_spec
946		and parse_zconstant gl e =
947		let (e,_) = parse_zexpr gl (Env.empty gl) e in
948		match Mc.zeval_const e with
949		\| None -> raise ParseError
950		\| Some z -> z
951
952
	950	\| _ -> Mc.PEpow (expr, Mc.Z.to_N z))
	951	zop_spec
	952
	953	and parse_zconstant gl e =
	954	let e, _ = parse_zexpr gl (Env.empty gl) e in
	955	match Mc.zeval_const e with None -> raise ParseError \| Some z -> z
953	956
954	957	(* NB: R is a different story.
955	958	Because it is axiomatised, reducing would not be effective.

957	960	*)
958	961
959	962	let rconst_assoc =
960		[
961		coq_Rplus , (fun x y -> Mc.CPlus(x,y)) ;
962		coq_Rminus , (fun x y -> Mc.CMinus(x,y)) ;
963		coq_Rmult , (fun x y -> Mc.CMult(x,y)) ;
964		(* coq_Rdiv , (fun x y -> Mc.CMult(x,Mc.CInv y)) ;*)
965		]
966
967
968
969
	963	[ (coq_Rplus, fun x y -> Mc.CPlus (x, y))
	964	; (coq_Rminus, fun x y -> Mc.CMinus (x, y))
	965	; (coq_Rmult, fun x y -> Mc.CMult (x, y))
	966	(* coq_Rdiv , (fun x y -> Mc.CMult(x,Mc.CInv y)) ;*) ]
970	967
971	968	let rconstant gl term =
972
973	969	let sigma = gl.sigma in
974
975	970	let rec rconstant term =
976	971	match EConstr.kind sigma term with
977	972	\| Const x ->
978		if EConstr.eq_constr sigma term (Lazy.force coq_R0)
979		then Mc.C0
980		else if EConstr.eq_constr sigma term (Lazy.force coq_R1)
981		then Mc.C1
982		else raise ParseError
983		\| App(op,args) ->
984		begin
985		try
986		(* the evaluation order is important in the following *)
987		let f = assoc_const sigma op rconst_assoc in
988		let a = rconstant args.(0) in
989		let b = rconstant args.(1) in
990		f a b
991		with
992		ParseError ->
993		match op with
994		\| op when EConstr.eq_constr sigma op (Lazy.force coq_Rinv) ->
995		let arg = rconstant args.(0) in
996		if Mc.qeq_bool (Mc.q_of_Rcst arg) {Mc.qnum = Mc.Z0 ; Mc.qden = Mc.XH}
997		then raise ParseError (* This is a division by zero -- no semantics *)
998		else Mc.CInv(arg)
999		\| op when EConstr.eq_constr sigma op (Lazy.force coq_Rpower) ->
1000		Mc.CPow(rconstant args.(0) , Mc.Inr (parse_more_constant nconstant gl args.(1)))
1001		\| op when EConstr.eq_constr sigma op (Lazy.force coq_IQR) ->
1002		Mc.CQ (qconstant gl args.(0))
1003		\| op when EConstr.eq_constr sigma op (Lazy.force coq_IZR) ->
1004		Mc.CZ (parse_more_constant zconstant gl args.(0))
1005		\| _ -> raise ParseError
1006		end
1007		\| _ -> raise ParseError in
1008
	973	if EConstr.eq_constr sigma term (Lazy.force coq_R0) then Mc.C0
	974	else if EConstr.eq_constr sigma term (Lazy.force coq_R1) then Mc.C1
	975	else raise ParseError
	976	\| App (op, args) -> (
	977	try
	978	(* the evaluation order is important in the following *)
	979	let f = assoc_const sigma op rconst_assoc in
	980	let a = rconstant args.(0) in
	981	let b = rconstant args.(1) in
	982	f a b
	983	with ParseError -> (
	984	match op with
	985	\| op when EConstr.eq_constr sigma op (Lazy.force coq_Rinv) ->
	986	let arg = rconstant args.(0) in
	987	if Mc.qeq_bool (Mc.q_of_Rcst arg) {Mc.qnum = Mc.Z0; Mc.qden = Mc.XH}
	988	then raise ParseError
	989	(* This is a division by zero -- no semantics *)
	990	else Mc.CInv arg
	991	\| op when EConstr.eq_constr sigma op (Lazy.force coq_Rpower) ->
	992	Mc.CPow
	993	( rconstant args.(0)
	994	, Mc.Inr (parse_more_constant nconstant gl args.(1)) )
	995	\| op when EConstr.eq_constr sigma op (Lazy.force coq_IQR) ->
	996	Mc.CQ (qconstant gl args.(0))
	997	\| op when EConstr.eq_constr sigma op (Lazy.force coq_IZR) ->
	998	Mc.CZ (parse_more_constant zconstant gl args.(0))
	999	\| _ -> raise ParseError ) )
	1000	\| _ -> raise ParseError
	1001	in
1009	1002	rconstant term
1010	1003
1011
1012
1013	1004	let rconstant gl term =
1014		if debug
1015		then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.pr_leconstr_env gl.env gl.sigma term ++ fnl ());
	1005	if debug then
	1006	Feedback.msg_debug
	1007	( Pp.str "rconstant: "
	1008	++ Printer.pr_leconstr_env gl.env gl.sigma term
	1009	++ fnl () );
1016	1010	let res = rconstant gl term in
1017		if debug then
1018		(Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ;
1019		res
1020
1021
1022
1023		let parse_qexpr gl = parse_expr gl
1024		qconstant
1025		(fun expr x ->
1026		let exp = zconstant gl x in
	1011	if debug then (
	1012	Printf.printf "rconstant -> %a\n" pp_Rcst res;
	1013	flush stdout );
	1014	res
	1015
	1016	let parse_qexpr gl =
	1017	parse_expr gl qconstant
	1018	(fun expr x ->
	1019	let exp = zconstant gl x in
1027	1020	match exp with
1028		\| Mc.Zneg _ ->
1029		begin
1030		match expr with
1031		\| Mc.PEc q -> Mc.PEc (Mc.qpower q exp)
1032		\| _ -> raise ParseError
1033		end
1034		\| _ -> let exp = Mc.Z.to_N exp in
1035		Mc.PEpow(expr,exp))
1036		qop_spec
1037
1038		let parse_rexpr gl = parse_expr gl
1039		rconstant
1040		(fun expr x ->
1041		let exp = Mc.N.of_nat (parse_nat gl.sigma x) in
1042		Mc.PEpow(expr,exp))
1043		rop_spec
1044
1045		let parse_arith parse_op parse_expr env cstr gl =
	1021	\| Mc.Zneg _ -> (
	1022	match expr with
	1023	\| Mc.PEc q -> Mc.PEc (Mc.qpower q exp)
	1024	\| _ -> raise ParseError )
	1025	\| _ ->
	1026	let exp = Mc.Z.to_N exp in
	1027	Mc.PEpow (expr, exp))
	1028	qop_spec
	1029
	1030	let parse_rexpr gl =
	1031	parse_expr gl rconstant
	1032	(fun expr x ->
	1033	let exp = Mc.N.of_nat (parse_nat gl.sigma x) in
	1034	Mc.PEpow (expr, exp))
	1035	rop_spec
	1036
	1037	let parse_arith parse_op parse_expr env cstr gl =
1046	1038	let sigma = gl.sigma in
1047		if debug
1048		then Feedback.msg_debug (Pp.str "parse_arith: " ++ Printer.pr_leconstr_env gl.env sigma cstr ++ fnl ());
	1039	if debug then
	1040	Feedback.msg_debug
	1041	( Pp.str "parse_arith: "
	1042	++ Printer.pr_leconstr_env gl.env sigma cstr
	1043	++ fnl () );
1049	1044	match EConstr.kind sigma cstr with
1050		\| App(op,args) ->
1051		let (op,lhs,rhs) = parse_op gl (op,args) in
1052		let (e1,env) = parse_expr gl env lhs in
1053		let (e2,env) = parse_expr gl env rhs in
1054		({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env)
1055		\| _ -> failwith "error : parse_arith(2)"
	1045	\| App (op, args) ->
	1046	let op, lhs, rhs = parse_op gl (op, args) in
	1047	let e1, env = parse_expr gl env lhs in
	1048	let e2, env = parse_expr gl env rhs in
	1049	({Mc.flhs = e1; Mc.fop = op; Mc.frhs = e2}, env)
	1050	\| _ -> failwith "error : parse_arith(2)"
1056	1051
1057	1052	let parse_zarith = parse_arith parse_zop parse_zexpr
1058
1059	1053	let parse_qarith = parse_arith parse_qop parse_qexpr
1060
1061	1054	let parse_rarith = parse_arith parse_rop parse_rexpr
1062	1055
1063	1056	(* generic parsing of arithmetic expressions *)
1064	1057
1065		let mkC f1 f2 = Mc.Cj(f1,f2)
1066		let mkD f1 f2 = Mc.D(f1,f2)
1067		let mkIff f1 f2 = Mc.Cj(Mc.I(f1,None,f2),Mc.I(f2,None,f1))
1068		let mkI f1 f2 = Mc.I(f1,None,f2)
	1058	let mkC f1 f2 = Mc.Cj (f1, f2)
	1059	let mkD f1 f2 = Mc.D (f1, f2)
	1060	let mkIff f1 f2 = Mc.Cj (Mc.I (f1, None, f2), Mc.I (f2, None, f1))
	1061	let mkI f1 f2 = Mc.I (f1, None, f2)
1069	1062
1070	1063	let mkformula_binary g term f1 f2 =
1071		match f1 , f2 with
1072		\| Mc.X _ , Mc.X _ -> Mc.X(term)
1073		\| _ -> g f1 f2
	1064	match (f1, f2) with Mc.X _, Mc.X _ -> Mc.X term \| _ -> g f1 f2
1074	1065
1075	1066	(**
1076	1067	* This is the big generic function for formula parsers.
1077	1068	*)
1078	1069
1079	1070	let is_prop env sigma term =
1080		let sort = Retyping.get_sort_of env sigma term in
	1071	let sort = Retyping.get_sort_of env sigma term in
1081	1072	Sorts.is_prop sort
1082	1073
1083	1074	let parse_formula gl parse_atom env tg term =
1084	1075	let sigma = gl.sigma in
1085
1086	1076	let is_prop term = is_prop gl.env gl.sigma term in
1087
1088	1077	let parse_atom env tg t =
1089	1078	try
1090		let (at,env) = parse_atom env t gl in
1091		(Mc.A(at,(tg,t)), env,Tag.next tg)
	1079	let at, env = parse_atom env t gl in
	1080	(Mc.A (at, (tg, t)), env, Tag.next tg)
1092	1081	with ParseError ->
1093		if is_prop t
1094		then (Mc.X(t),env,tg)
1095		else raise ParseError
1096		in
1097
	1082	if is_prop t then (Mc.X t, env, tg) else raise ParseError
	1083	in
1098	1084	let rec xparse_formula env tg term =
1099	1085	match EConstr.kind sigma term with
1100		\| App(l,rst) ->
1101		(match rst with
1102		\| [\|a;b\|] when EConstr.eq_constr sigma l (Lazy.force coq_and) ->
1103		let f,env,tg = xparse_formula env tg a in
1104		let g,env, tg = xparse_formula env tg b in
1105		mkformula_binary mkC term f g,env,tg
1106		\| [\|a;b\|] when EConstr.eq_constr sigma l (Lazy.force coq_or) ->
1107		let f,env,tg = xparse_formula env tg a in
1108		let g,env,tg = xparse_formula env tg b in
1109		mkformula_binary mkD term f g,env,tg
	1086	\| App (l, rst) -> (
	1087	match rst with
	1088	\| [\|a; b\|] when EConstr.eq_constr sigma l (Lazy.force coq_and) ->
	1089	let f, env, tg = xparse_formula env tg a in
	1090	let g, env, tg = xparse_formula env tg b in
	1091	(mkformula_binary mkC term f g, env, tg)
	1092	\| [\|a; b\|] when EConstr.eq_constr sigma l (Lazy.force coq_or) ->
	1093	let f, env, tg = xparse_formula env tg a in
	1094	let g, env, tg = xparse_formula env tg b in
	1095	(mkformula_binary mkD term f g, env, tg)
1110	1096	\| [\|a\|] when EConstr.eq_constr sigma l (Lazy.force coq_not) ->
1111		let (f,env,tg) = xparse_formula env tg a in (Mc.N(f), env,tg)
1112		\| [\|a;b\|] when EConstr.eq_constr sigma l (Lazy.force coq_iff) ->
1113		let f,env,tg = xparse_formula env tg a in
1114		let g,env,tg = xparse_formula env tg b in
1115		mkformula_binary mkIff term f g,env,tg
1116		\| _ -> parse_atom env tg term)
1117		\| Prod(typ,a,b) when typ.binder_name = Anonymous \|\| EConstr.Vars.noccurn sigma 1 b ->
1118		let f,env,tg = xparse_formula env tg a in
1119		let g,env,tg = xparse_formula env tg b in
1120		mkformula_binary mkI term f g,env,tg
1121		\| _ -> if EConstr.eq_constr sigma term (Lazy.force coq_True)
1122		then (Mc.TT,env,tg)
1123		else if EConstr.eq_constr sigma term (Lazy.force coq_False)
1124		then Mc.(FF,env,tg)
1125		else if is_prop term then Mc.X(term),env,tg
1126		else raise ParseError
1127		in
1128		xparse_formula env tg ((Reductionops.whd_zeta) term)
	1097	let f, env, tg = xparse_formula env tg a in
	1098	(Mc.N f, env, tg)
	1099	\| [\|a; b\|] when EConstr.eq_constr sigma l (Lazy.force coq_iff) ->
	1100	let f, env, tg = xparse_formula env tg a in
	1101	let g, env, tg = xparse_formula env tg b in
	1102	(mkformula_binary mkIff term f g, env, tg)
	1103	\| _ -> parse_atom env tg term )
	1104	\| Prod (typ, a, b)
	1105	when typ.binder_name = Anonymous \|\| EConstr.Vars.noccurn sigma 1 b ->
	1106	let f, env, tg = xparse_formula env tg a in
	1107	let g, env, tg = xparse_formula env tg b in
	1108	(mkformula_binary mkI term f g, env, tg)
	1109	\| _ ->
	1110	if EConstr.eq_constr sigma term (Lazy.force coq_True) then
	1111	(Mc.TT, env, tg)
	1112	else if EConstr.eq_constr sigma term (Lazy.force coq_False) then
	1113	Mc.(FF, env, tg)
	1114	else if is_prop term then (Mc.X term, env, tg)
	1115	else raise ParseError
	1116	in
	1117	xparse_formula env tg (Reductionops.whd_zeta) term
1129	1118
1130	1119	let dump_formula typ dump_atom f =
1131	1120	let app_ctor c args =
1132		EConstr.mkApp(Lazy.force c, Array.of_list (typ::EConstr.mkProp::Lazy.force coq_unit :: Lazy.force coq_unit :: args)) in
1133
	1121	EConstr.mkApp
	1122	( Lazy.force c
	1123	, Array.of_list
	1124	( typ :: EConstr.mkProp :: Lazy.force coq_unit
	1125	:: Lazy.force coq_unit :: args ) )
	1126	in
1134	1127	let rec xdump f =
1135		match f with
1136		\| Mc.TT -> app_ctor coq_TT []
1137		\| Mc.FF -> app_ctor coq_FF []
1138		\| Mc.Cj(x,y) -> app_ctor coq_And [xdump x ; xdump y]
1139		\| Mc.D(x,y) -> app_ctor coq_Or [xdump x ; xdump y]
1140		\| Mc.I(x,_,y) -> app_ctor coq_Impl [xdump x ; EConstr.mkApp(Lazy.force coq_None,[\|Lazy.force coq_unit\|]); xdump y]
1141		\| Mc.N(x) -> app_ctor coq_Neg [xdump x]
1142		\| Mc.A(x,_) -> app_ctor coq_Atom [dump_atom x;Lazy.force coq_tt]
1143		\| Mc.X(t) -> app_ctor coq_X [t] in
1144		xdump f
1145
	1128	match f with
	1129	\| Mc.TT -> app_ctor coq_TT []
	1130	\| Mc.FF -> app_ctor coq_FF []
	1131	\| Mc.Cj (x, y) -> app_ctor coq_And [xdump x; xdump y]
	1132	\| Mc.D (x, y) -> app_ctor coq_Or [xdump x; xdump y]
	1133	\| Mc.I (x, _, y) ->
	1134	app_ctor coq_Impl
	1135	[ xdump x
	1136	; EConstr.mkApp (Lazy.force coq_None, [\|Lazy.force coq_unit\|])
	1137	; xdump y ]
	1138	\| Mc.N x -> app_ctor coq_Neg [xdump x]
	1139	\| Mc.A (x, _) -> app_ctor coq_Atom [dump_atom x; Lazy.force coq_tt]
	1140	\| Mc.X t -> app_ctor coq_X [t]
	1141	in
	1142	xdump f
1146	1143
1147	1144	let prop_env_of_formula gl form =
1148	1145	Mc.(
1149		let rec doit env = function
1150		\| TT \| FF \| A(_,_) -> env
1151		\| X t -> fst (Env.compute_rank_add env t)
1152		\| Cj(f1,f2) \| D(f1,f2) \| I(f1,_,f2) ->
1153		doit (doit env f1) f2
1154		\| N f -> doit env f
1155		in
1156
1157		doit (Env.empty gl) form)
	1146	let rec doit env = function
	1147	\| TT \| FF \| A (_, _) -> env
	1148	\| X t -> fst (Env.compute_rank_add env t)
	1149	\| Cj (f1, f2) \| D (f1, f2) \| I (f1, _, f2) -> doit (doit env f1) f2
	1150	\| N f -> doit env f
	1151	in
	1152	doit (Env.empty gl) form)
1158	1153
1159	1154	let var_env_of_formula form =
1160
1161		let rec vars_of_expr = function
	1155	let rec vars_of_expr = function
1162	1156	\| Mc.PEX n -> ISet.singleton (CoqToCaml.positive n)
1163	1157	\| Mc.PEc z -> ISet.empty
1164		\| Mc.PEadd(e1,e2) \| Mc.PEmul(e1,e2) \| Mc.PEsub(e1,e2) ->
	1158	\| Mc.PEadd (e1, e2) \| Mc.PEmul (e1, e2) \| Mc.PEsub (e1, e2) ->
1165	1159	ISet.union (vars_of_expr e1) (vars_of_expr e2)
1166		\| Mc.PEopp e \| Mc.PEpow(e,_)-> vars_of_expr e
1167		in
1168
1169		let vars_of_atom {Mc.flhs ; Mc.fop; Mc.frhs} =
1170		ISet.union (vars_of_expr flhs) (vars_of_expr frhs) in
1171		Mc.(
1172		let rec doit = function
1173		\| TT \| FF \| X _ -> ISet.empty
1174		\| A (a,(t,c)) -> vars_of_atom a
1175		\| Cj(f1,f2) \| D(f1,f2) \|I (f1,_,f2) -> ISet.union (doit f1) (doit f2)
1176		\| N f -> doit f in
1177
1178		doit form)
1179
1180
1181
1182
1183		type 'cst dump_expr = (* 'cst is the type of the syntactic constants *)
1184		{
1185		interp_typ : EConstr.constr;
1186		dump_cst : 'cst -> EConstr.constr;
1187		dump_add : EConstr.constr;
1188		dump_sub : EConstr.constr;
1189		dump_opp : EConstr.constr;
1190		dump_mul : EConstr.constr;
1191		dump_pow : EConstr.constr;
1192		dump_pow_arg : Mc.n -> EConstr.constr;
1193		dump_op : (Mc.op2 * EConstr.constr) list
1194		}
1195
1196		let dump_zexpr = lazy
1197		{
1198		interp_typ = Lazy.force coq_Z;
1199		dump_cst = dump_z;
1200		dump_add = Lazy.force coq_Zplus;
1201		dump_sub = Lazy.force coq_Zminus;
1202		dump_opp = Lazy.force coq_Zopp;
1203		dump_mul = Lazy.force coq_Zmult;
1204		dump_pow = Lazy.force coq_Zpower;
1205		dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n)));
1206		dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) zop_table
1207		}
1208
1209		let dump_qexpr = lazy
1210		{
1211		interp_typ = Lazy.force coq_Q;
1212		dump_cst = dump_q;
1213		dump_add = Lazy.force coq_Qplus;
1214		dump_sub = Lazy.force coq_Qminus;
1215		dump_opp = Lazy.force coq_Qopp;
1216		dump_mul = Lazy.force coq_Qmult;
1217		dump_pow = Lazy.force coq_Qpower;
1218		dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n)));
1219		dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) qop_table
1220		}
1221
1222		let rec dump_Rcst_as_R cst =
1223		match cst with
1224		\| Mc.C0 -> Lazy.force coq_R0
1225		\| Mc.C1 -> Lazy.force coq_R1
1226		\| Mc.CQ q -> EConstr.mkApp(Lazy.force coq_IQR, [\| dump_q q \|])
1227		\| Mc.CZ z -> EConstr.mkApp(Lazy.force coq_IZR, [\| dump_z z \|])
1228		\| Mc.CPlus(x,y) -> EConstr.mkApp(Lazy.force coq_Rplus, [\| dump_Rcst_as_R x ; dump_Rcst_as_R y \|])
1229		\| Mc.CMinus(x,y) -> EConstr.mkApp(Lazy.force coq_Rminus, [\| dump_Rcst_as_R x ; dump_Rcst_as_R y \|])
1230		\| Mc.CMult(x,y) -> EConstr.mkApp(Lazy.force coq_Rmult, [\| dump_Rcst_as_R x ; dump_Rcst_as_R y \|])
1231		\| Mc.CPow(x,y) ->
1232		begin
1233		match y with
1234		\| Mc.Inl z -> EConstr.mkApp(Lazy.force coq_powerZR,[\| dump_Rcst_as_R x ; dump_z z\|])
1235		\| Mc.Inr n -> EConstr.mkApp(Lazy.force coq_Rpower,[\| dump_Rcst_as_R x ; dump_nat n\|])
1236		end
1237		\| Mc.CInv t -> EConstr.mkApp(Lazy.force coq_Rinv, [\| dump_Rcst_as_R t \|])
1238		\| Mc.COpp t -> EConstr.mkApp(Lazy.force coq_Ropp, [\| dump_Rcst_as_R t \|])
1239
1240
1241		let dump_rexpr = lazy
1242		{
1243		interp_typ = Lazy.force coq_R;
1244		dump_cst = dump_Rcst_as_R;
1245		dump_add = Lazy.force coq_Rplus;
1246		dump_sub = Lazy.force coq_Rminus;
1247		dump_opp = Lazy.force coq_Ropp;
1248		dump_mul = Lazy.force coq_Rmult;
1249		dump_pow = Lazy.force coq_Rpower;
1250		dump_pow_arg = (fun n -> dump_nat (CamlToCoq.nat (CoqToCaml.n n)));
1251		dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) rop_table
1252		}
1253
1254
1255
1256
1257		let prodn n env b =
1258		let rec prodrec = function
1259		\| (0, env, b) -> b
1260		\| (n, ((v,t)::l), b) -> prodrec (n-1, l, EConstr.mkProd (make_annot v Sorts.Relevant,t,b))
1261		\| _ -> assert false
1262		in
1263		prodrec (n,env,b)
1264
1265		(** [make_goal_of_formula depxr vars props form] where
	1160	\| Mc.PEopp e \| Mc.PEpow (e, _) -> vars_of_expr e
	1161	in
	1162	let vars_of_atom {Mc.flhs; Mc.fop; Mc.frhs} =
	1163	ISet.union (vars_of_expr flhs) (vars_of_expr frhs)
	1164	in
	1165	Mc.(
	1166	let rec doit = function
	1167	\| TT \| FF \| X _ -> ISet.empty
	1168	\| A (a, (t, c)) -> vars_of_atom a
	1169	\| Cj (f1, f2) \| D (f1, f2) \| I (f1, _, f2) ->
	1170	ISet.union (doit f1) (doit f2)
	1171	\| N f -> doit f
	1172	in
	1173	doit form)
	1174
	1175	type 'cst dump_expr =
	1176	{ (* 'cst is the type of the syntactic constants *)
	1177	interp_typ : EConstr.constr
	1178	; dump_cst : 'cst -> EConstr.constr
	1179	; dump_add : EConstr.constr
	1180	; dump_sub : EConstr.constr
	1181	; dump_opp : EConstr.constr
	1182	; dump_mul : EConstr.constr
	1183	; dump_pow : EConstr.constr
	1184	; dump_pow_arg : Mc.n -> EConstr.constr
	1185	; dump_op : (Mc.op2 * EConstr.constr) list }
	1186
	1187	let dump_zexpr =
	1188	lazy
	1189	{ interp_typ = Lazy.force coq_Z
	1190	; dump_cst = dump_z
	1191	; dump_add = Lazy.force coq_Zplus
	1192	; dump_sub = Lazy.force coq_Zminus
	1193	; dump_opp = Lazy.force coq_Zopp
	1194	; dump_mul = Lazy.force coq_Zmult
	1195	; dump_pow = Lazy.force coq_Zpower
	1196	; dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n)))
	1197	; dump_op = List.map (fun (x, y) -> (y, Lazy.force x)) zop_table }
	1198
	1199	let dump_qexpr =
	1200	lazy
	1201	{ interp_typ = Lazy.force coq_Q
	1202	; dump_cst = dump_q
	1203	; dump_add = Lazy.force coq_Qplus
	1204	; dump_sub = Lazy.force coq_Qminus
	1205	; dump_opp = Lazy.force coq_Qopp
	1206	; dump_mul = Lazy.force coq_Qmult
	1207	; dump_pow = Lazy.force coq_Qpower
	1208	; dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n)))
	1209	; dump_op = List.map (fun (x, y) -> (y, Lazy.force x)) qop_table }
	1210
	1211	let rec dump_Rcst_as_R cst =
	1212	match cst with
	1213	\| Mc.C0 -> Lazy.force coq_R0
	1214	\| Mc.C1 -> Lazy.force coq_R1
	1215	\| Mc.CQ q -> EConstr.mkApp (Lazy.force coq_IQR, [\|dump_q q\|])
	1216	\| Mc.CZ z -> EConstr.mkApp (Lazy.force coq_IZR, [\|dump_z z\|])
	1217	\| Mc.CPlus (x, y) ->
	1218	EConstr.mkApp
	1219	(Lazy.force coq_Rplus, [\|dump_Rcst_as_R x; dump_Rcst_as_R y\|])
	1220	\| Mc.CMinus (x, y) ->
	1221	EConstr.mkApp
	1222	(Lazy.force coq_Rminus, [\|dump_Rcst_as_R x; dump_Rcst_as_R y\|])
	1223	\| Mc.CMult (x, y) ->
	1224	EConstr.mkApp
	1225	(Lazy.force coq_Rmult, [\|dump_Rcst_as_R x; dump_Rcst_as_R y\|])
	1226	\| Mc.CPow (x, y) -> (
	1227	match y with
	1228	\| Mc.Inl z ->
	1229	EConstr.mkApp (Lazy.force coq_powerZR, [\|dump_Rcst_as_R x; dump_z z\|])
	1230	\| Mc.Inr n ->
	1231	EConstr.mkApp (Lazy.force coq_Rpower, [\|dump_Rcst_as_R x; dump_nat n\|])
	1232	)
	1233	\| Mc.CInv t -> EConstr.mkApp (Lazy.force coq_Rinv, [\|dump_Rcst_as_R t\|])
	1234	\| Mc.COpp t -> EConstr.mkApp (Lazy.force coq_Ropp, [\|dump_Rcst_as_R t\|])
	1235
	1236	let dump_rexpr =
	1237	lazy
	1238	{ interp_typ = Lazy.force coq_R
	1239	; dump_cst = dump_Rcst_as_R
	1240	; dump_add = Lazy.force coq_Rplus
	1241	; dump_sub = Lazy.force coq_Rminus
	1242	; dump_opp = Lazy.force coq_Ropp
	1243	; dump_mul = Lazy.force coq_Rmult
	1244	; dump_pow = Lazy.force coq_Rpower
	1245	; dump_pow_arg = (fun n -> dump_nat (CamlToCoq.nat (CoqToCaml.n n)))
	1246	; dump_op = List.map (fun (x, y) -> (y, Lazy.force x)) rop_table }
	1247
	1248	let prodn n env b =
	1249	let rec prodrec = function
	1250	\| 0, env, b -> b
	1251	\| n, (v, t) :: l, b ->
	1252	prodrec (n - 1, l, EConstr.mkProd (make_annot v Sorts.Relevant, t, b))
	1253	\| _ -> assert false
	1254	in
	1255	prodrec (n, env, b)
	1256
	1257	(** [make_goal_of_formula depxr vars props form] where
1266	1258	- vars is an environment for the arithmetic variables occurring in form
1267	1259	- props is an environment for the propositions occurring in form
1268	1260	@return a goal where all the variables and propositions of the formula are quantified
1269	1261
1270	1262	*)
1271	1263
1272		let make_goal_of_formula gl dexpr form =
1273
1274		let vars_idx =
1275		List.mapi (fun i v -> (v, i+1)) (ISet.elements (var_env_of_formula form)) in
1276
1277		(* List.iter (fun (v,i) -> Printf.fprintf stdout "var %i has index %i\n" v i) vars_idx ;*)
1278
1279		let props = prop_env_of_formula gl form in
1280
1281		let fresh_var str i = Names.Id.of_string (str^(string_of_int i)) in
1282
1283		let fresh_prop str i =
1284		Names.Id.of_string (str^(string_of_int i)) in
1285
1286		let vars_n = List.map (fun (_,i) -> fresh_var "__x" i, dexpr.interp_typ) vars_idx in
1287		let props_n = List.mapi (fun i _ -> fresh_prop "__p" (i+1) , EConstr.mkProp) (Env.elements props) in
1288
1289		let var_name_pos = List.map2 (fun (idx,_) (id,_) -> id,idx) vars_idx vars_n in
1290
1291		let dump_expr i e =
1292		let rec dump_expr = function
1293		\| Mc.PEX n -> EConstr.mkRel (i+(List.assoc (CoqToCaml.positive n) vars_idx))
1294		\| Mc.PEc z -> dexpr.dump_cst z
1295		\| Mc.PEadd(e1,e2) -> EConstr.mkApp(dexpr.dump_add,
1296		[\| dump_expr e1;dump_expr e2\|])
1297		\| Mc.PEsub(e1,e2) -> EConstr.mkApp(dexpr.dump_sub,
1298		[\| dump_expr e1;dump_expr e2\|])
1299		\| Mc.PEopp e -> EConstr.mkApp(dexpr.dump_opp,
1300		[\| dump_expr e\|])
1301		\| Mc.PEmul(e1,e2) -> EConstr.mkApp(dexpr.dump_mul,
1302		[\| dump_expr e1;dump_expr e2\|])
1303		\| Mc.PEpow(e,n) -> EConstr.mkApp(dexpr.dump_pow,
1304		[\| dump_expr e; dexpr.dump_pow_arg n\|])
1305		in dump_expr e in
1306
1307		let mkop op e1 e2 =
1308		try
1309		EConstr.mkApp(List.assoc op dexpr.dump_op, [\| e1; e2\|])
	1264	let make_goal_of_formula gl dexpr form =
	1265	let vars_idx =
	1266	List.mapi
	1267	(fun i v -> (v, i + 1))
	1268	(ISet.elements (var_env_of_formula form))
	1269	in
	1270	(* List.iter (fun (v,i) -> Printf.fprintf stdout "var %i has index %i\n" v i) vars_idx ;*)
	1271	let props = prop_env_of_formula gl form in
	1272	let fresh_var str i = Names.Id.of_string (str ^ string_of_int i) in
	1273	let fresh_prop str i = Names.Id.of_string (str ^ string_of_int i) in
	1274	let vars_n =
	1275	List.map (fun (_, i) -> (fresh_var "__x" i, dexpr.interp_typ)) vars_idx
	1276	in
	1277	let props_n =
	1278	List.mapi
	1279	(fun i _ -> (fresh_prop "__p" (i + 1), EConstr.mkProp))
	1280	(Env.elements props)
	1281	in
	1282	let var_name_pos =
	1283	List.map2 (fun (idx, _) (id, _) -> (id, idx)) vars_idx vars_n
	1284	in
	1285	let dump_expr i e =
	1286	let rec dump_expr = function
	1287	\| Mc.PEX n ->
	1288	EConstr.mkRel (i + List.assoc (CoqToCaml.positive n) vars_idx)
	1289	\| Mc.PEc z -> dexpr.dump_cst z
	1290	\| Mc.PEadd (e1, e2) ->
	1291	EConstr.mkApp (dexpr.dump_add, [\|dump_expr e1; dump_expr e2\|])
	1292	\| Mc.PEsub (e1, e2) ->
	1293	EConstr.mkApp (dexpr.dump_sub, [\|dump_expr e1; dump_expr e2\|])
	1294	\| Mc.PEopp e -> EConstr.mkApp (dexpr.dump_opp, [\|dump_expr e\|])
	1295	\| Mc.PEmul (e1, e2) ->
	1296	EConstr.mkApp (dexpr.dump_mul, [\|dump_expr e1; dump_expr e2\|])
	1297	\| Mc.PEpow (e, n) ->
	1298	EConstr.mkApp (dexpr.dump_pow, [\|dump_expr e; dexpr.dump_pow_arg n\|])
	1299	in
	1300	dump_expr e
	1301	in
	1302	let mkop op e1 e2 =
	1303	try EConstr.mkApp (List.assoc op dexpr.dump_op, [\|e1; e2\|])
1310	1304	with Not_found ->
1311		EConstr.mkApp(Lazy.force coq_Eq,[\|dexpr.interp_typ ; e1 ;e2\|]) in
1312
1313		let dump_cstr i { Mc.flhs ; Mc.fop ; Mc.frhs } =
1314		mkop fop (dump_expr i flhs) (dump_expr i frhs) in
1315
1316		let rec xdump pi xi f =
1317		match f with
1318		\| Mc.TT -> Lazy.force coq_True
1319		\| Mc.FF -> Lazy.force coq_False
1320		\| Mc.Cj(x,y) -> EConstr.mkApp(Lazy.force coq_and,[\|xdump pi xi x ; xdump pi xi y\|])
1321		\| Mc.D(x,y) -> EConstr.mkApp(Lazy.force coq_or,[\| xdump pi xi x ; xdump pi xi y\|])
1322		\| Mc.I(x,_,y) -> EConstr.mkArrow (xdump pi xi x) Sorts.Relevant (xdump (pi+1) (xi+1) y)
1323		\| Mc.N(x) -> EConstr.mkArrow (xdump pi xi x) Sorts.Relevant (Lazy.force coq_False)
1324		\| Mc.A(x,_) -> dump_cstr xi x
1325		\| Mc.X(t) -> let idx = Env.get_rank props t in
1326		EConstr.mkRel (pi+idx) in
1327
1328		let nb_vars = List.length vars_n in
1329		let nb_props = List.length props_n in
1330
1331		(* Printf.fprintf stdout "NBProps : %i\n" nb_props ;*)
1332
1333		let subst_prop p =
1334		let idx = Env.get_rank props p in
1335		EConstr.mkVar (Names.Id.of_string (Printf.sprintf "__p%i" idx)) in
1336
1337		let form' = Mc.mapX subst_prop form in
1338
1339		(prodn nb_props (List.map (fun (x,y) -> Name.Name x,y) props_n)
1340		(prodn nb_vars (List.map (fun (x,y) -> Name.Name x,y) vars_n)
1341		(xdump (List.length vars_n) 0 form)),
1342		List.rev props_n, List.rev var_name_pos,form')
	1305	EConstr.mkApp (Lazy.force coq_Eq, [\|dexpr.interp_typ; e1; e2\|])
	1306	in
	1307	let dump_cstr i {Mc.flhs; Mc.fop; Mc.frhs} =
	1308	mkop fop (dump_expr i flhs) (dump_expr i frhs)
	1309	in
	1310	let rec xdump pi xi f =
	1311	match f with
	1312	\| Mc.TT -> Lazy.force coq_True
	1313	\| Mc.FF -> Lazy.force coq_False
	1314	\| Mc.Cj (x, y) ->
	1315	EConstr.mkApp (Lazy.force coq_and, [\|xdump pi xi x; xdump pi xi y\|])
	1316	\| Mc.D (x, y) ->
	1317	EConstr.mkApp (Lazy.force coq_or, [\|xdump pi xi x; xdump pi xi y\|])
	1318	\| Mc.I (x, _, y) ->
	1319	EConstr.mkArrow (xdump pi xi x) Sorts.Relevant
	1320	(xdump (pi + 1) (xi + 1) y)
	1321	\| Mc.N x ->
	1322	EConstr.mkArrow (xdump pi xi x) Sorts.Relevant (Lazy.force coq_False)
	1323	\| Mc.A (x, _) -> dump_cstr xi x
	1324	\| Mc.X t ->
	1325	let idx = Env.get_rank props t in
	1326	EConstr.mkRel (pi + idx)
	1327	in
	1328	let nb_vars = List.length vars_n in
	1329	let nb_props = List.length props_n in
	1330	(* Printf.fprintf stdout "NBProps : %i\n" nb_props ;*)
	1331	let subst_prop p =
	1332	let idx = Env.get_rank props p in
	1333	EConstr.mkVar (Names.Id.of_string (Printf.sprintf "__p%i" idx))
	1334	in
	1335	let form' = Mc.mapX subst_prop form in
	1336	( prodn nb_props
	1337	(List.map (fun (x, y) -> (Name.Name x, y)) props_n)
	1338	(prodn nb_vars
	1339	(List.map (fun (x, y) -> (Name.Name x, y)) vars_n)
	1340	(xdump (List.length vars_n) 0 form))
	1341	, List.rev props_n
	1342	, List.rev var_name_pos
	1343	, form' )
1343	1344
1344	1345	(**
1345	1346	* Given a conclusion and a list of affectations, rebuild a term prefixed by

1348	1349	*)
1349	1350
1350	1351	let set l concl =
1351		let rec xset acc = function
1352		\| [] -> acc
1353		\| (e::l) ->
1354		let (name,expr,typ) = e in
1355		xset (EConstr.mkNamedLetIn
1356		(make_annot (Names.Id.of_string name) Sorts.Relevant)
1357		expr typ acc) l in
	1352	let rec xset acc = function
	1353	\| [] -> acc
	1354	\| e :: l ->
	1355	let name, expr, typ = e in
	1356	xset
	1357	(EConstr.mkNamedLetIn
	1358	(make_annot (Names.Id.of_string name) Sorts.Relevant)
	1359	expr typ acc)
	1360	l
	1361	in
1358	1362	xset concl l
1359
1360		end (**
1361		* MODULE END: M
1362		*)
	1363	end
1363	1364
1364	1365	open M
1365	1366
1366	1367	let coq_Branch =
1367		lazy (gen_constant_in_modules "VarMap"
1368		[["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Branch")
	1368	lazy
	1369	(gen_constant_in_modules "VarMap"
	1370	[["Coq"; "micromega"; "VarMap"]; ["VarMap"]]
	1371	"Branch")
	1372
1369	1373	let coq_Elt =
1370		lazy (gen_constant_in_modules "VarMap"
1371		[["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Elt")
	1374	lazy
	1375	(gen_constant_in_modules "VarMap"
	1376	[["Coq"; "micromega"; "VarMap"]; ["VarMap"]]
	1377	"Elt")
	1378
1372	1379	let coq_Empty =
1373		lazy (gen_constant_in_modules "VarMap"
1374		[["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty")
	1380	lazy
	1381	(gen_constant_in_modules "VarMap"
	1382	[["Coq"; "micromega"; "VarMap"]; ["VarMap"]]
	1383	"Empty")
1375	1384
1376	1385	let coq_VarMap =
1377		lazy (gen_constant_in_modules "VarMap"
1378		[["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t")
1379
	1386	lazy
	1387	(gen_constant_in_modules "VarMap"
	1388	[["Coq"; "micromega"; "VarMap"]; ["VarMap"]]
	1389	"t")
1380	1390
1381	1391	let rec dump_varmap typ m =
1382	1392	match m with
1383		\| Mc.Empty -> EConstr.mkApp(Lazy.force coq_Empty,[\| typ \|])
1384		\| Mc.Elt v -> EConstr.mkApp(Lazy.force coq_Elt,[\| typ; v\|])
1385		\| Mc.Branch(l,o,r) ->
1386		EConstr.mkApp (Lazy.force coq_Branch, [\| typ; dump_varmap typ l; o ; dump_varmap typ r \|])
1387
	1393	\| Mc.Empty -> EConstr.mkApp (Lazy.force coq_Empty, [\|typ\|])
	1394	\| Mc.Elt v -> EConstr.mkApp (Lazy.force coq_Elt, [\|typ; v\|])
	1395	\| Mc.Branch (l, o, r) ->
	1396	EConstr.mkApp
	1397	(Lazy.force coq_Branch, [\|typ; dump_varmap typ l; o; dump_varmap typ r\|])
1388	1398
1389	1399	let vm_of_list env =
1390	1400	match env with
1391	1401	\| [] -> Mc.Empty
1392		\| (d,_)::_ ->
1393		List.fold_left (fun vm (c,i) ->
1394		Mc.vm_add d (CamlToCoq.positive i) c vm) Mc.Empty env
	1402	\| (d, _) :: _ ->
	1403	List.fold_left
	1404	(fun vm (c, i) -> Mc.vm_add d (CamlToCoq.positive i) c vm)
	1405	Mc.Empty env
1395	1406
1396	1407	let rec dump_proof_term = function
1397	1408	\| Micromega.DoneProof -> Lazy.force coq_doneProof
1398		\| Micromega.RatProof(cone,rst) ->
1399		EConstr.mkApp(Lazy.force coq_ratProof, [\| dump_psatz coq_Z dump_z cone; dump_proof_term rst\|])
1400		\| Micromega.CutProof(cone,prf) ->
1401		EConstr.mkApp(Lazy.force coq_cutProof,
1402		[\| dump_psatz coq_Z dump_z cone ;
1403		dump_proof_term prf\|])
1404		\| Micromega.EnumProof(c1,c2,prfs) ->
1405		EConstr.mkApp (Lazy.force coq_enumProof,
1406		[\| dump_psatz coq_Z dump_z c1 ; dump_psatz coq_Z dump_z c2 ;
1407		dump_list (Lazy.force coq_proofTerm) dump_proof_term prfs \|])
1408
	1409	\| Micromega.RatProof (cone, rst) ->
	1410	EConstr.mkApp
	1411	( Lazy.force coq_ratProof
	1412	, [\|dump_psatz coq_Z dump_z cone; dump_proof_term rst\|] )
	1413	\| Micromega.CutProof (cone, prf) ->
	1414	EConstr.mkApp
	1415	( Lazy.force coq_cutProof
	1416	, [\|dump_psatz coq_Z dump_z cone; dump_proof_term prf\|] )
	1417	\| Micromega.EnumProof (c1, c2, prfs) ->
	1418	EConstr.mkApp
	1419	( Lazy.force coq_enumProof
	1420	, [\| dump_psatz coq_Z dump_z c1
	1421	; dump_psatz coq_Z dump_z c2
	1422	; dump_list (Lazy.force coq_proofTerm) dump_proof_term prfs \|] )
	1423	\| Micromega.ExProof (p, prf) ->
	1424	EConstr.mkApp
	1425	(Lazy.force coq_ExProof, [\|dump_positive p; dump_proof_term prf\|])
1409	1426
1410	1427	let rec size_of_psatz = function
1411	1428	\| Micromega.PsatzIn _ -> 1
1412	1429	\| Micromega.PsatzSquare _ -> 1
1413		\| Micromega.PsatzMulC(_,p) -> 1 + (size_of_psatz p)
1414		\| Micromega.PsatzMulE(p1,p2) \| Micromega.PsatzAdd(p1,p2) -> size_of_psatz p1 + size_of_psatz p2
	1430	\| Micromega.PsatzMulC (_, p) -> 1 + size_of_psatz p
	1431	\| Micromega.PsatzMulE (p1, p2) \| Micromega.PsatzAdd (p1, p2) ->
	1432	size_of_psatz p1 + size_of_psatz p2
1415	1433	\| Micromega.PsatzC _ -> 1
1416		\| Micromega.PsatzZ -> 1
	1434	\| Micromega.PsatzZ -> 1
1417	1435
1418	1436	let rec size_of_pf = function
1419	1437	\| Micromega.DoneProof -> 1
1420		\| Micromega.RatProof(p,a) -> (size_of_pf a) + (size_of_psatz p)
1421		\| Micromega.CutProof(p,a) -> (size_of_pf a) + (size_of_psatz p)
1422		\| 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)
	1438	\| Micromega.RatProof (p, a) -> size_of_pf a + size_of_psatz p
	1439	\| Micromega.CutProof (p, a) -> size_of_pf a + size_of_psatz p
	1440	\| Micromega.EnumProof (p1, p2, l) ->
	1441	size_of_psatz p1 + size_of_psatz p2
	1442	+ List.fold_left (fun acc p -> size_of_pf p + acc) 0 l
	1443	\| Micromega.ExProof (_, a) -> size_of_pf a + 1
1423	1444
1424	1445	let dump_proof_term t =
1425		if debug then Printf.printf "dump_proof_term %i\n" (size_of_pf t) ;
	1446	if debug then Printf.printf "dump_proof_term %i\n" (size_of_pf t);
1426	1447	dump_proof_term t
1427	1448
1428
1429
1430		let pp_q o q = Printf.fprintf o "%a/%a" pp_z q.Micromega.qnum pp_positive q.Micromega.qden
1431
	1449	let pp_q o q =
	1450	Printf.fprintf o "%a/%a" pp_z q.Micromega.qnum pp_positive q.Micromega.qden
1432	1451
1433	1452	let rec pp_proof_term o = function
1434	1453	\| Micromega.DoneProof -> Printf.fprintf o "D"
1435		\| Micromega.RatProof(cone,rst) -> Printf.fprintf o "R[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst
1436		\| Micromega.CutProof(cone,rst) -> Printf.fprintf o "C[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst
1437		\| Micromega.EnumProof(c1,c2,rst) ->
1438		Printf.fprintf o "EP[%a,%a,%a]"
1439		(pp_psatz pp_z) c1 (pp_psatz pp_z) c2
1440		(pp_list "[" "]" pp_proof_term) rst
	1454	\| Micromega.RatProof (cone, rst) ->
	1455	Printf.fprintf o "R[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst
	1456	\| Micromega.CutProof (cone, rst) ->
	1457	Printf.fprintf o "C[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst
	1458	\| Micromega.EnumProof (c1, c2, rst) ->
	1459	Printf.fprintf o "EP[%a,%a,%a]" (pp_psatz pp_z) c1 (pp_psatz pp_z) c2
	1460	(pp_list "[" "]" pp_proof_term)
	1461	rst
	1462	\| Micromega.ExProof (p, prf) ->
	1463	Printf.fprintf o "Ex[%a,%a]" pp_positive p pp_proof_term prf
1441	1464
1442	1465	let rec parse_hyps gl parse_arith env tg hyps =
1443		match hyps with
1444		\| [] -> ([],env,tg)
1445		\| (i,t)::l ->
1446		let (lhyps,env,tg) = parse_hyps gl parse_arith env tg l in
1447		if is_prop gl.env gl.sigma t
1448		then
1449		try
1450		let (c,env,tg) = parse_formula gl parse_arith env tg t in
1451		((i,c)::lhyps, env,tg)
1452		with ParseError -> (lhyps,env,tg)
1453		else (lhyps,env,tg)
1454
1455
1456		let parse_goal gl parse_arith (env:Env.t) hyps term =
1457		let (f,env,tg) = parse_formula gl parse_arith env (Tag.from 0) term in
1458		let (lhyps,env,tg) = parse_hyps gl parse_arith env tg hyps in
1459		(lhyps,f,env)
1460
	1466	match hyps with
	1467	\| [] -> ([], env, tg)
	1468	\| (i, t) :: l ->
	1469	let lhyps, env, tg = parse_hyps gl parse_arith env tg l in
	1470	if is_prop gl.env gl.sigma t then
	1471	try
	1472	let c, env, tg = parse_formula gl parse_arith env tg t in
	1473	((i, c) :: lhyps, env, tg)
	1474	with ParseError -> (lhyps, env, tg)
	1475	else (lhyps, env, tg)
	1476
	1477	let parse_goal gl parse_arith (env : Env.t) hyps term =
	1478	let f, env, tg = parse_formula gl parse_arith env (Tag.from 0) term in
	1479	let lhyps, env, tg = parse_hyps gl parse_arith env tg hyps in
	1480	(lhyps, f, env)
	1481
	1482	type ('synt_c, 'prf) domain_spec =
	1483	{ typ : EConstr.constr
	1484	; (* is the type of the interpretation domain - Z, Q, R*)
	1485	coeff : EConstr.constr
	1486	; (* is the type of the syntactic coeffs - Z , Q , Rcst *)
	1487	dump_coeff : 'synt_c -> EConstr.constr
	1488	; proof_typ : EConstr.constr
	1489	; dump_proof : 'prf -> EConstr.constr }
1461	1490	(**
1462	1491	* The datastructures that aggregate theory-dependent proof values.
1463	1492	*)
1464		type ('synt_c, 'prf) domain_spec = {
1465		typ : EConstr.constr; (* is the type of the interpretation domain - Z, Q, R*)
1466		coeff : EConstr.constr ; (* is the type of the syntactic coeffs - Z , Q , Rcst *)
1467		dump_coeff : 'synt_c -> EConstr.constr ;
1468		proof_typ : EConstr.constr ;
1469		dump_proof : 'prf -> EConstr.constr
1470		}
1471
1472		let zz_domain_spec = lazy {
1473		typ = Lazy.force coq_Z;
1474		coeff = Lazy.force coq_Z;
1475		dump_coeff = dump_z ;
1476		proof_typ = Lazy.force coq_proofTerm ;
1477		dump_proof = dump_proof_term
1478		}
1479
1480		let qq_domain_spec = lazy {
1481		typ = Lazy.force coq_Q;
1482		coeff = Lazy.force coq_Q;
1483		dump_coeff = dump_q ;
1484		proof_typ = Lazy.force coq_QWitness ;
1485		dump_proof = dump_psatz coq_Q dump_q
1486		}
1487
1488		let max_tag f = 1 + (Tag.to_int (Mc.foldA (fun t1 (t2,_) -> Tag.max t1 t2) f (Tag.from 0)))
1489
1490
1491		(** For completeness of the cutting-plane procedure,
1492		each variable 'x' is replaced by 'y' - 'z' where
1493		'y' and 'z' are positive *)
1494		let pre_processZ mt f =
1495
1496		let x0 i = 2 * i in
1497		let x1 i = 2 * i + 1 in
1498
1499		let tag_of_var fr p b =
1500
1501		let ip = CoqToCaml.positive fr + (CoqToCaml.positive p) in
1502
1503		match b with
1504		\| None ->
1505		let y = Mc.XO (Mc.Coq_Pos.add fr p) in
1506		let z = Mc.XI (Mc.Coq_Pos.add fr p) in
1507		let tag = Tag.from (- x0 (x0 ip)) in
1508		let constr = Mc.mk_eq_pos p y z in
1509		(tag, dump_cstr (Lazy.force coq_Z) dump_z constr)
1510		\| Some false ->
1511		let y = Mc.XO (Mc.Coq_Pos.add fr p) in
1512		let tag = Tag.from (- x0 (x1 ip)) in
1513		let constr = Mc.bound_var (Mc.XO y) in
1514		(tag, dump_cstr (Lazy.force coq_Z) dump_z constr)
1515		\| Some true ->
1516		let z = Mc.XI (Mc.Coq_Pos.add fr p) in
1517		let tag = Tag.from (- x1 (x1 ip)) in
1518		let constr = Mc.bound_var (Mc.XI z) in
1519		(tag, dump_cstr (Lazy.force coq_Z) dump_z constr) in
1520
1521		Mc.bound_problem_fr tag_of_var mt f
	1493
	1494	let zz_domain_spec =
	1495	lazy
	1496	{ typ = Lazy.force coq_Z
	1497	; coeff = Lazy.force coq_Z
	1498	; dump_coeff = dump_z
	1499	; proof_typ = Lazy.force coq_proofTerm
	1500	; dump_proof = dump_proof_term }
	1501
	1502	let qq_domain_spec =
	1503	lazy
	1504	{ typ = Lazy.force coq_Q
	1505	; coeff = Lazy.force coq_Q
	1506	; dump_coeff = dump_q
	1507	; proof_typ = Lazy.force coq_QWitness
	1508	; dump_proof = dump_psatz coq_Q dump_q }
	1509
	1510	let max_tag f =
	1511	1 + Tag.to_int (Mc.foldA (fun t1 (t2, _) -> Tag.max t1 t2) f (Tag.from 0))
	1512
1522	1513	(** Naive topological sort of constr according to the subterm-ordering *)
1523	1514
1524	1515	(* An element is minimal x is minimal w.r.t y if

1529	1520	* witness.
1530	1521	*)
1531	1522
1532		let micromega_order_change spec cert cert_typ env ff (: unit Proofview.tactic) =
1533		(* let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *)
1534		let formula_typ = (EConstr.mkApp (Lazy.force coq_Cstr,[\|spec.coeff\|])) in
1535		let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in
1536		let vm = dump_varmap (spec.typ) (vm_of_list env) in
1537		(* todo : directly generate the proof term - or generalize before conversion? *)
1538		Proofview.Goal.enter begin fun gl ->
1539		Tacticals.New.tclTHENLIST
1540		[
1541		Tactics.change_concl
1542		(set
1543		[
1544		("__ff", ff, EConstr.mkApp(Lazy.force coq_Formula, [\|formula_typ \|]));
1545		("__varmap", vm, EConstr.mkApp(Lazy.force coq_VarMap, [\|spec.typ\|]));
1546		("__wit", cert, cert_typ)
1547		]
1548		(Tacmach.New.pf_concl gl))
1549		]
1550		end
1551
	1523	let micromega_order_change spec cert cert_typ env ff (: unit Proofview.tactic)
	1524	=
	1525	(* let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *)
	1526	let formula_typ = EConstr.mkApp (Lazy.force coq_Cstr, [\|spec.coeff\|]) in
	1527	let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in
	1528	let vm = dump_varmap spec.typ (vm_of_list env) in
	1529	(* todo : directly generate the proof term - or generalize before conversion? *)
	1530	Proofview.Goal.enter (fun gl ->
	1531	Tacticals.New.tclTHENLIST
	1532	[ Tactics.change_concl
	1533	(set
	1534	[ ( "__ff"
	1535	, ff
	1536	, EConstr.mkApp (Lazy.force coq_Formula, [\|formula_typ\|]) )
	1537	; ( "__varmap"
	1538	, vm
	1539	, EConstr.mkApp (Lazy.force coq_VarMap, [\|spec.typ\|]) )
	1540	; ("__wit", cert, cert_typ) ]
	1541	(Tacmach.New.pf_concl gl)) ])
1552	1542
1553	1543	(**
1554	1544	* The datastructures that aggregate prover attributes.

1556	1546
1557	1547	open Certificate
1558	1548
1559		type ('option,'a,'prf,'model) prover = {
1560		name : string ; (* name of the prover *)
1561		get_option : unit ->'option ; (* find the options of the prover *)
1562		prover : ('option * 'a list) -> ('prf, 'model) Certificate.res ; (* the prover itself *)
1563		hyps : 'prf -> ISet.t ; (* extract the indexes of the hypotheses really used in the proof *)
1564		compact : 'prf -> (int -> int) -> 'prf ; (* remap the hyp indexes according to function *)
1565		pp_prf : out_channel -> 'prf -> unit ;(* pretting printing of proof *)
1566		pp_f : out_channel -> 'a -> unit (* pretty printing of the formulas (polynomials)*)
1567		}
1568
1569
	1549	type ('option, 'a, 'prf, 'model) prover =
	1550	{ name : string
	1551	; (* name of the prover *)
	1552	get_option : unit -> 'option
	1553	; (* find the options of the prover *)
	1554	prover : 'option * 'a list -> ('prf, 'model) Certificate.res
	1555	; (* the prover itself *)
	1556	hyps : 'prf -> ISet.t
	1557	; (* extract the indexes of the hypotheses really used in the proof *)
	1558	compact : 'prf -> (int -> int) -> 'prf
	1559	; (* remap the hyp indexes according to function *)
	1560	pp_prf : out_channel -> 'prf -> unit
	1561	; (* pretting printing of proof *)
	1562	pp_f : out_channel -> 'a -> unit
	1563	(* pretty printing of the formulas (polynomials)*) }
1570	1564
1571	1565	(**
1572	1566	* Given a prover and a disjunction of atoms, find a proof of any of

1574	1568	* datastructure.
1575	1569	*)
1576	1570
1577		let find_witness p polys1 =
	1571	let find_witness p polys1 =
1578	1572	let polys1 = List.map fst polys1 in
1579	1573	match p.prover (p.get_option (), polys1) with
1580	1574	\| Model m -> Model m
1581	1575	\| Unknown -> Unknown
1582		\| Prf prf -> Prf(prf,p)
	1576	\| Prf prf -> Prf (prf, p)
1583	1577
1584	1578	(**
1585	1579	* Given a prover and a CNF, find a proof for each of the clauses.
1586	1580	* Return the proofs as a list.
1587	1581	*)
1588	1582
1589		let witness_list prover l =
1590		let rec xwitness_list l =
1591		match l with
1592		\| [] -> Prf []
1593		\| e :: l ->
	1583	let witness_list prover l =
	1584	let rec xwitness_list l =
	1585	match l with
	1586	\| [] -> Prf []
	1587	\| e :: l -> (
1594	1588	match xwitness_list l with
1595		\| Model (m,e) -> Model (m,e)
1596		\| Unknown -> Unknown
1597		\| Prf l ->
1598		match find_witness prover e with
1599		\| Model m -> Model (m,e)
1600		\| Unknown -> Unknown
1601		\| Prf w -> Prf (w::l) in
1602		xwitness_list l
1603
1604		let witness_list_tags p g = witness_list p g
	1589	\| Model (m, e) -> Model (m, e)
	1590	\| Unknown -> Unknown
	1591	\| Prf l -> (
	1592	match find_witness prover e with
	1593	\| Model m -> Model (m, e)
	1594	\| Unknown -> Unknown
	1595	\| Prf w -> Prf (w :: l) ) )
	1596	in
	1597	xwitness_list l
	1598
	1599	let witness_list_tags p g = witness_list p g
	1600
1605	1601	(* let t1 = System.get_time () in
1606	1602	let res = witness_list p g in
1607	1603	let t2 = System.get_time () in

1613	1609	* Prune the proof object, according to the 'diff' between two cnf formulas.
1614	1610	*)
1615	1611
1616
1617		let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) =
1618
1619		let compact_proof (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) =
1620		let new_cl = List.mapi (fun i (f,_) -> (f,i)) new_cl in
	1612	let compact_proofs (cnf_ff : 'cst cnf) res (cnf_ff' : 'cst cnf) =
	1613	let compact_proof (old_cl : 'cst clause) (prf, prover) (new_cl : 'cst clause)
	1614	=
	1615	let new_cl = List.mapi (fun i (f, _) -> (f, i)) new_cl in
1621	1616	let remap i =
1622		let formula = try fst (List.nth old_cl i) with Failure _ -> failwith "bad old index" in
1623		List.assoc formula new_cl in
1624		(* if debug then
	1617	let formula =
	1618	try fst (List.nth old_cl i) with Failure _ -> failwith "bad old index"
	1619	in
	1620	List.assoc formula new_cl
	1621	in
	1622	(* if debug then
1625	1623	begin
1626	1624	Printf.printf "\ncompact_proof : %a %a %a"
1627	1625	(pp_ml_list prover.pp_f) (List.map fst old_cl)

1629	1627	(pp_ml_list prover.pp_f) (List.map fst new_cl) ;
1630	1628	flush stdout
1631	1629	end ; *)
1632		let res = try prover.compact prf remap with x when CErrors.noncritical x ->
1633		if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ;
1634		(* This should not happen -- this is the recovery plan... *)
1635		match prover.prover (prover.get_option (), List.map fst new_cl) with
	1630	let res =
	1631	try prover.compact prf remap
	1632	with x when CErrors.noncritical x -> (
	1633	if debug then
	1634	Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x);
	1635	(* This should not happen -- this is the recovery plan... *)
	1636	match prover.prover (prover.get_option (), List.map fst new_cl) with
1636	1637	\| Unknown \| Model _ -> failwith "proof compaction error"
1637		\| Prf p -> p
1638		in
1639		if debug then
1640		begin
1641		Printf.printf " -> %a\n"
1642		prover.pp_prf res ;
1643		flush stdout
1644		end ;
1645		res in
1646
1647		let is_proof_compatible (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) =
	1638	\| Prf p -> p )
	1639	in
	1640	if debug then begin
	1641	Printf.printf " -> %a\n" prover.pp_prf res;
	1642	flush stdout
	1643	end;
	1644	res
	1645	in
	1646	let is_proof_compatible (old_cl : 'cst clause) (prf, prover)
	1647	(new_cl : 'cst clause) =
1648	1648	let hyps_idx = prover.hyps prf in
1649	1649	let hyps = selecti hyps_idx old_cl in
1650		is_sublist (=) hyps new_cl in
1651
1652
1653
1654		let cnf_res = List.combine cnf_ff res in (* we get pairs clause * proof *)
1655		if debug then
1656		begin
1657		Printf.printf "CNFRES\n"; flush stdout;
1658		Printf.printf "CNFOLD %a\n" pp_cnf_tag cnf_ff;
1659		List.iter (fun (cl,(prf,prover)) ->
1660		let hyps_idx = prover.hyps prf in
1661		let hyps = selecti hyps_idx cl in
1662		Printf.printf "\nProver %a -> %a\n"
1663		pp_clause_tag cl pp_clause_tag hyps;flush stdout) cnf_res;
1664		Printf.printf "CNFNEW %a\n" pp_cnf_tag cnf_ff';
1665
1666		end;
1667
1668		List.map (fun x ->
1669		let (o,p) =
1670		try
1671		List.find (fun (l,p) -> is_proof_compatible l p x) cnf_res
	1650	is_sublist ( = ) hyps new_cl
	1651	in
	1652	let cnf_res = List.combine cnf_ff res in
	1653	(* we get pairs clause * proof *)
	1654	if debug then begin
	1655	Printf.printf "CNFRES\n";
	1656	flush stdout;
	1657	Printf.printf "CNFOLD %a\n" pp_cnf_tag cnf_ff;
	1658	List.iter
	1659	(fun (cl, (prf, prover)) ->
	1660	let hyps_idx = prover.hyps prf in
	1661	let hyps = selecti hyps_idx cl in
	1662	Printf.printf "\nProver %a -> %a\n" pp_clause_tag cl pp_clause_tag hyps;
	1663	flush stdout)
	1664	cnf_res;
	1665	Printf.printf "CNFNEW %a\n" pp_cnf_tag cnf_ff'
	1666	end;
	1667	List.map
	1668	(fun x ->
	1669	let o, p =
	1670	try List.find (fun (l, p) -> is_proof_compatible l p x) cnf_res
1672	1671	with Not_found ->
1673		begin
1674		Printf.printf "ERROR: no compatible proof" ; flush stdout;
1675		failwith "Cannot find compatible proof" end
1676		in
1677		compact_proof o p x) cnf_ff'
1678
	1672	Printf.printf "ERROR: no compatible proof";
	1673	flush stdout;
	1674	failwith "Cannot find compatible proof"
	1675	in
	1676	compact_proof o p x)
	1677	cnf_ff'
1679	1678
1680	1679	(**
1681	1680	* "Hide out" tagged atoms of a formula by transforming them into generic
1682	1681	* variables. See the Tag module in mutils.ml for more.
1683	1682	*)
1684	1683
1685
1686
1687	1684	let abstract_formula : TagSet.t -> 'a formula -> 'a formula =
1688		fun hyps f ->
1689		let to_constr = Mc.({
1690		mkTT = Lazy.force coq_True;
1691		mkFF = Lazy.force coq_False;
1692		mkA = (fun a (tg, t) -> t);
1693		mkCj = (let coq_and = Lazy.force coq_and in
1694		fun x y -> EConstr.mkApp(coq_and,[\|x;y\|]));
1695		mkD = (let coq_or = Lazy.force coq_or in
1696		fun x y -> EConstr.mkApp(coq_or,[\|x;y\|]));
1697		mkI = (fun x y -> EConstr.mkArrow x Sorts.Relevant y);
1698		mkN = (let coq_not = Lazy.force coq_not in
1699		(fun x -> EConstr.mkApp(coq_not,[\|x\|])))
1700		}) in
1701		Mc.abst_form to_constr (fun (t,_) -> TagSet.mem t hyps) true f
1702
	1685	fun hyps f ->
	1686	let to_constr =
	1687	Mc.
	1688	{ mkTT = Lazy.force coq_True
	1689	; mkFF = Lazy.force coq_False
	1690	; mkA = (fun a (tg, t) -> t)
	1691	; mkCj =
	1692	(let coq_and = Lazy.force coq_and in
	1693	fun x y -> EConstr.mkApp (coq_and, [\|x; y\|]))
	1694	; mkD =
	1695	(let coq_or = Lazy.force coq_or in
	1696	fun x y -> EConstr.mkApp (coq_or, [\|x; y\|]))
	1697	; mkI = (fun x y -> EConstr.mkArrow x Sorts.Relevant y)
	1698	; mkN =
	1699	(let coq_not = Lazy.force coq_not in
	1700	fun x -> EConstr.mkApp (coq_not, [\|x\|])) }
	1701	in
	1702	Mc.abst_form to_constr (fun (t, _) -> TagSet.mem t hyps) true f
1703	1703
1704	1704	(* [abstract_wrt_formula] is used in contexts whre f1 is already an abstraction of f2 *)
1705	1705	let rec abstract_wrt_formula f1 f2 =
1706	1706	Mc.(
1707		match f1 , f2 with
1708		\| X c , _ -> X c
1709		\| A _ , A _ -> f2
1710		\| Cj(a,b) , Cj(a',b') -> Cj(abstract_wrt_formula a a', abstract_wrt_formula b b')
1711		\| D(a,b) , D(a',b') -> D(abstract_wrt_formula a a', abstract_wrt_formula b b')
1712		\| I(a,_,b) , I(a',x,b') -> I(abstract_wrt_formula a a',x, abstract_wrt_formula b b')
1713		\| FF , FF -> FF
1714		\| TT , TT -> TT
1715		\| N x , N y -> N(abstract_wrt_formula x y)
1716		\| _ -> failwith "abstract_wrt_formula")
	1707	match (f1, f2) with
	1708	\| X c, _ -> X c
	1709	\| A _, A _ -> f2
	1710	\| Cj (a, b), Cj (a', b') ->
	1711	Cj (abstract_wrt_formula a a', abstract_wrt_formula b b')
	1712	\| D (a, b), D (a', b') ->
	1713	D (abstract_wrt_formula a a', abstract_wrt_formula b b')
	1714	\| I (a, _, b), I (a', x, b') ->
	1715	I (abstract_wrt_formula a a', x, abstract_wrt_formula b b')
	1716	\| FF, FF -> FF
	1717	\| TT, TT -> TT
	1718	\| N x, N y -> N (abstract_wrt_formula x y)
	1719	\| _ -> failwith "abstract_wrt_formula")
1717	1720
1718	1721	(**
1719	1722	* This exception is raised by really_call_csdpcert if Coq's configure didn't

1722	1725
1723	1726	exception CsdpNotFound
1724	1727
1725
1726	1728	(**
1727	1729	* This is the core of Micromega: apply the prover, analyze the result and
1728	1730	* prune unused fomulas, and finally modify the proof state.

1730	1732
1731	1733	let formula_hyps_concl hyps concl =
1732	1734	List.fold_right
1733		(fun (id,f) (cc,ids) ->
1734		match f with
1735		Mc.X _ -> (cc,ids)
1736		\| _ -> (Mc.I(f,Some id,cc), id::ids))
1737		hyps (concl,[])
1738
	1735	(fun (id, f) (cc, ids) ->
	1736	match f with
	1737	\| Mc.X _ -> (cc, ids)
	1738	\| _ -> (Mc.I (f, Some id, cc), id :: ids))
	1739	hyps (concl, [])
1739	1740
1740	1741	(* let time str f x =
1741	1742	let t1 = System.get_time () in

1745	1746	res
1746	1747	*)
1747	1748
1748		let micromega_tauto pre_process cnf spec prover env (polys1: (Names.Id.t * 'cst formula) list) (polys2: 'cst formula) gl =
1749
1750		(* Express the goal as one big implication *)
1751		let (ff,ids) = formula_hyps_concl polys1 polys2 in
1752		let mt = CamlToCoq.positive (max_tag ff) in
1753
1754		(* Construction of cnf *)
1755		let pre_ff = pre_process mt (ff:'a formula) in
1756		let (cnf_ff,cnf_ff_tags) = cnf pre_ff in
1757
1758		match witness_list_tags prover cnf_ff with
1759		\| Model m -> Model m
1760		\| Unknown -> Unknown
1761		\| Prf res -> (Printf.printf "\nList %i" (List.length `res); )
1762		let deps = List.fold_left
1763		(fun s (cl,(prf,p)) ->
1764		let tags = ISet.fold (fun i s ->
1765		let t = fst (snd (List.nth cl i)) in
1766		if debug then (Printf.fprintf stdout "T : %i -> %a" i Tag.pp t) ;
1767		(try) TagSet.add t s (* with Invalid_argument _ -> s*)) (p.hyps prf) TagSet.empty in
1768		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
1769
1770		let ff' = abstract_formula deps ff in
1771
1772		let pre_ff' = pre_process mt ff' in
1773
1774		let (cnf_ff',_) = cnf pre_ff' in
1775
1776		if debug then
1777		begin
	1749	let micromega_tauto pre_process cnf spec prover env
	1750	(polys1 : (Names.Id.t * 'cst formula) list) (polys2 : 'cst formula) gl =
	1751	(* Express the goal as one big implication *)
	1752	let ff, ids = formula_hyps_concl polys1 polys2 in
	1753	let mt = CamlToCoq.positive (max_tag ff) in
	1754	(* Construction of cnf *)
	1755	let pre_ff = pre_process mt (ff : 'a formula) in
	1756	let cnf_ff, cnf_ff_tags = cnf pre_ff in
	1757	match witness_list_tags prover cnf_ff with
	1758	\| Model m -> Model m
	1759	\| Unknown -> Unknown
	1760	\| Prf res ->
	1761	(Printf.printf "\nList %i" (List.length `res); )
	1762	let deps =
	1763	List.fold_left
	1764	(fun s (cl, (prf, p)) ->
	1765	let tags =
	1766	ISet.fold
	1767	(fun i s ->
	1768	let t = fst (snd (List.nth cl i)) in
	1769	if debug then Printf.fprintf stdout "T : %i -> %a" i Tag.pp t;
	1770	(try) TagSet.add t s
	1771	(* with Invalid_argument _ -> s*))
	1772	(p.hyps prf) TagSet.empty
	1773	in
	1774	TagSet.union s tags)
	1775	(List.fold_left
	1776	(fun s (i, _) -> TagSet.add i s)
	1777	TagSet.empty cnf_ff_tags)
	1778	(List.combine cnf_ff res)
	1779	in
	1780	let ff' = abstract_formula deps ff in
	1781	let pre_ff' = pre_process mt ff' in
	1782	let cnf_ff', _ = cnf pre_ff' in
	1783	if debug then begin
1778	1784	output_string stdout "\n";
1779		Printf.printf "TForm : %a\n" pp_formula ff ; flush stdout;
1780		Printf.printf "CNF : %a\n" pp_cnf_tag cnf_ff ; flush stdout;
1781		Printf.printf "TFormAbs : %a\n" pp_formula ff' ; flush stdout;
1782		Printf.printf "TFormPre : %a\n" pp_formula pre_ff ; flush stdout;
1783		Printf.printf "TFormPreAbs : %a\n" pp_formula pre_ff' ; flush stdout;
1784		Printf.printf "CNF : %a\n" pp_cnf_tag cnf_ff' ; flush stdout;
	1785	Printf.printf "TForm : %a\n" pp_formula ff;
	1786	flush stdout;
	1787	Printf.printf "CNF : %a\n" pp_cnf_tag cnf_ff;
	1788	flush stdout;
	1789	Printf.printf "TFormAbs : %a\n" pp_formula ff';
	1790	flush stdout;
	1791	Printf.printf "TFormPre : %a\n" pp_formula pre_ff;
	1792	flush stdout;
	1793	Printf.printf "TFormPreAbs : %a\n" pp_formula pre_ff';
	1794	flush stdout;
	1795	Printf.printf "CNF : %a\n" pp_cnf_tag cnf_ff';
	1796	flush stdout
1785	1797	end;
1786
1787		(* Even if it does not work, this does not mean it is not provable
	1798	(* Even if it does not work, this does not mean it is not provable
1788	1799	-- the prover is REALLY incomplete *)
1789		(* if debug then
	1800	(* if debug then
1790	1801	begin
1791	1802	(* recompute the proofs *)
1792	1803	match witness_list_tags prover cnf_ff' with
1793	1804	\| None -> failwith "abstraction is wrong"
1794	1805	\| Some res -> ()
1795	1806	end ; *)
1796
1797		let res' = compact_proofs cnf_ff res cnf_ff' in
1798
1799		let (ff',res',ids) = (ff',res', Mc.ids_of_formula ff') in
1800
1801		let res' = dump_list (spec.proof_typ) spec.dump_proof res' in
1802		Prf (ids,ff',res')
1803
1804		let micromega_tauto pre_process cnf spec prover env (polys1: (Names.Id.t * 'cst formula) list) (polys2: 'cst formula) gl =
	1807	let res' = compact_proofs cnf_ff res cnf_ff' in
	1808	let ff', res', ids = (ff', res', Mc.ids_of_formula ff') in
	1809	let res' = dump_list spec.proof_typ spec.dump_proof res' in
	1810	Prf (ids, ff', res')
	1811
	1812	let micromega_tauto pre_process cnf spec prover env
	1813	(polys1 : (Names.Id.t * 'cst formula) list) (polys2 : 'cst formula) gl =
1805	1814	try micromega_tauto pre_process cnf spec prover env polys1 polys2 gl
1806	1815	with Not_found ->
1807		begin
1808		Printexc.print_backtrace stdout; flush stdout;
1809		Unknown
1810		end
1811
	1816	Printexc.print_backtrace stdout;
	1817	flush stdout;
	1818	Unknown
1812	1819
1813	1820	(**
1814	1821	* Parse the proof environment, and call micromega_tauto

1817	1824	Tactics.fresh_id_in_env avoid id (Proofview.Goal.env gl)
1818	1825
1819	1826	let clear_all_no_check =
1820		Proofview.Goal.enter begin fun gl ->
1821		let concl = Tacmach.New.pf_concl gl in
1822		let env = Environ.reset_with_named_context Environ.empty_named_context_val (Tacmach.New.pf_env gl) in
1823		(Refine.refine ~typecheck:false begin fun sigma ->
1824		Evarutil.new_evar env sigma ~principal:true concl
1825		end)
1826		end
1827
1828
1829
1830		let micromega_gen
1831		parse_arith
1832		pre_process
1833		cnf
1834		spec dumpexpr prover tac =
1835		Proofview.Goal.enter begin fun gl ->
1836		let sigma = Tacmach.New.project gl in
1837		let concl = Tacmach.New.pf_concl gl in
1838		let hyps = Tacmach.New.pf_hyps_types gl in
1839		try
1840		let gl0 = { env = Tacmach.New.pf_env gl; sigma } in
1841		let (hyps,concl,env) = parse_goal gl0 parse_arith (Env.empty gl0) hyps concl in
1842		let env = Env.elements env in
1843		let spec = Lazy.force spec in
1844		let dumpexpr = Lazy.force dumpexpr in
1845
1846
1847		if debug then Feedback.msg_debug (Pp.str "Env " ++ (Env.pp gl0 env)) ;
1848
1849		match micromega_tauto pre_process cnf spec prover env hyps concl gl0 with
1850		\| Unknown -> flush stdout ; Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness")
1851		\| Model(m,e) -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness")
1852		\| Prf (ids,ff',res') ->
1853		let (arith_goal,props,vars,ff_arith) = make_goal_of_formula gl0 dumpexpr ff' in
1854		let intro (id,_) = Tactics.introduction id in
1855
1856		let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in
1857		let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in
1858		(* let ipat_of_name id = Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) in*)
1859		let goal_name = fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl in
1860		let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in
1861
1862		let tac_arith = Tacticals.New.tclTHENLIST [ clear_all_no_check ;intro_props ; intro_vars ;
1863		micromega_order_change spec res'
1864		(EConstr.mkApp(Lazy.force coq_list, [\|spec.proof_typ\|])) env' ff_arith ] in
1865
1866		let goal_props = List.rev (Env.elements (prop_env_of_formula gl0 ff')) in
1867
1868		let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in
1869
1870		let arith_args = goal_props @ goal_vars in
1871
1872		let kill_arith = Tacticals.New.tclTHEN tac_arith tac in
1873		(*
	1827	Proofview.Goal.enter (fun gl ->
	1828	let concl = Tacmach.New.pf_concl gl in
	1829	let env =
	1830	Environ.reset_with_named_context Environ.empty_named_context_val
	1831	(Tacmach.New.pf_env gl)
	1832	in
	1833	Refine.refine ~typecheck:false (fun sigma ->
	1834	Evarutil.new_evar env sigma ~principal:true concl))
	1835
	1836	let micromega_gen parse_arith pre_process cnf spec dumpexpr prover tac =
	1837	Proofview.Goal.enter (fun gl ->
	1838	let sigma = Tacmach.New.project gl in
	1839	let concl = Tacmach.New.pf_concl gl in
	1840	let hyps = Tacmach.New.pf_hyps_types gl in
	1841	try
	1842	let gl0 = {env = Tacmach.New.pf_env gl; sigma} in
	1843	let hyps, concl, env =
	1844	parse_goal gl0 parse_arith (Env.empty gl0) hyps concl
	1845	in
	1846	let env = Env.elements env in
	1847	let spec = Lazy.force spec in
	1848	let dumpexpr = Lazy.force dumpexpr in
	1849	if debug then Feedback.msg_debug (Pp.str "Env " ++ Env.pp gl0 env);
	1850	match
	1851	micromega_tauto pre_process cnf spec prover env hyps concl gl0
	1852	with
	1853	\| Unknown ->
	1854	flush stdout;
	1855	Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness")
	1856	\| Model (m, e) ->
	1857	Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness")
	1858	\| Prf (ids, ff', res') ->
	1859	let arith_goal, props, vars, ff_arith =
	1860	make_goal_of_formula gl0 dumpexpr ff'
	1861	in
	1862	let intro (id, _) = Tactics.introduction id in
	1863	let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in
	1864	let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in
	1865	(* let ipat_of_name id = Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) in*)
	1866	let goal_name =
	1867	fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl
	1868	in
	1869	let env' = List.map (fun (id, i) -> (EConstr.mkVar id, i)) vars in
	1870	let tac_arith =
	1871	Tacticals.New.tclTHENLIST
	1872	[ clear_all_no_check
	1873	; intro_props
	1874	; intro_vars
	1875	; micromega_order_change spec res'
	1876	(EConstr.mkApp (Lazy.force coq_list, [\|spec.proof_typ\|]))
	1877	env' ff_arith ]
	1878	in
	1879	let goal_props =
	1880	List.rev (Env.elements (prop_env_of_formula gl0 ff'))
	1881	in
	1882	let goal_vars = List.map (fun (_, i) -> List.nth env (i - 1)) vars in
	1883	let arith_args = goal_props @ goal_vars in
	1884	let kill_arith = Tacticals.New.tclTHEN tac_arith tac in
	1885	(*
1874	1886	(tclABSTRACT fails in certain corner cases.)
1875	1887	Tacticals.New.tclTHEN
1876	1888	clear_all_no_check
1877	1889	(Abstract.tclABSTRACT ~opaque:false None (Tacticals.New.tclTHEN tac_arith tac)) in *)
1878
1879		Tacticals.New.tclTHEN
1880		(Tactics.assert_by (Names.Name goal_name) arith_goal
1881		((Proofview.tclTIME (Some "kill_arith")) kill_arith))
1882		((Proofview.tclTIME (Some "apply_arith") )
1883		(Tactics.exact_check (EConstr.applist (EConstr.mkVar goal_name, arith_args@(List.map EConstr.mkVar ids)))))
1884		with
1885		\| Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout")
1886		\| CsdpNotFound -> flush stdout ;
1887		Tacticals.New.tclFAIL 0 (Pp.str
1888		(" Skipping what remains of this tactic: the complexity of the goal requires "
1889		^ "the use of a specialized external tool called csdp. \n\n"
1890		^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n"
1891		^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp"))
1892		\| x -> begin if debug then Tacticals.New.tclFAIL 0 (Pp.str (Printexc.get_backtrace ()))
1893		else raise x
1894		end
1895		end
1896
1897		let micromega_order_changer cert env ff =
	1890	Tacticals.New.tclTHEN
	1891	(Tactics.assert_by (Names.Name goal_name) arith_goal
	1892	(Proofview.tclTIME (Some "kill_arith")) kill_arith)
	1893	((Proofview.tclTIME (Some "apply_arith") )
	1894	Tactics.exact_check
	1895	(EConstr.applist
	1896	( EConstr.mkVar goal_name
	1897	, arith_args @ List.map EConstr.mkVar ids )))
	1898	with
	1899	\| Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout")
	1900	\| CsdpNotFound ->
	1901	flush stdout;
	1902	Tacticals.New.tclFAIL 0
	1903	(Pp.str
	1904	( " Skipping what remains of this tactic: the complexity of the \
	1905	goal requires "
	1906	^ "the use of a specialized external tool called csdp. \n\n"
	1907	^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" \
	1908	executable in the path. \n\n"
	1909	^ "Csdp packages are provided by some OS distributions; binaries \
	1910	and source code can be downloaded from \
	1911	https://projects.coin-or.org/Csdp" ))
	1912	\| x ->
	1913	if debug then
	1914	Tacticals.New.tclFAIL 0 (Pp.str (Printexc.get_backtrace ()))
	1915	else raise x)
	1916
	1917	let micromega_order_changer cert env ff =
1898	1918	(let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in )
1899	1919	let coeff = Lazy.force coq_Rcst in
1900	1920	let dump_coeff = dump_Rcst in
1901		let typ = Lazy.force coq_R in
1902		let cert_typ = (EConstr.mkApp(Lazy.force coq_list, [\|Lazy.force coq_QWitness \|])) in
1903
1904		let formula_typ = (EConstr.mkApp (Lazy.force coq_Cstr,[\| coeff\|])) in
	1921	let typ = Lazy.force coq_R in
	1922	let cert_typ =
	1923	EConstr.mkApp (Lazy.force coq_list, [\|Lazy.force coq_QWitness\|])
	1924	in
	1925	let formula_typ = EConstr.mkApp (Lazy.force coq_Cstr, [\|coeff\|]) in
1905	1926	let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in
1906		let vm = dump_varmap (typ) (vm_of_list env) in
1907		Proofview.Goal.enter begin fun gl ->
1908		Tacticals.New.tclTHENLIST
1909		[
1910		(Tactics.change_concl
1911		(set
1912		[
1913		("__ff", ff, EConstr.mkApp(Lazy.force coq_Formula, [\|formula_typ \|]));
1914		("__varmap", vm, EConstr.mkApp
1915		(gen_constant_in_modules "VarMap"
1916		[["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [\|typ\|]));
1917		("__wit", cert, cert_typ)
1918		]
1919		(Tacmach.New.pf_concl gl)));
1920		(* Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids)*)
1921		]
1922		end
	1927	let vm = dump_varmap typ (vm_of_list env) in
	1928	Proofview.Goal.enter (fun gl ->
	1929	Tacticals.New.tclTHENLIST
	1930	[ Tactics.change_concl
	1931	(set
	1932	[ ( "__ff"
	1933	, ff
	1934	, EConstr.mkApp (Lazy.force coq_Formula, [\|formula_typ\|]) )
	1935	; ( "__varmap"
	1936	, vm
	1937	, EConstr.mkApp
	1938	( gen_constant_in_modules "VarMap"
	1939	[["Coq"; "micromega"; "VarMap"]; ["VarMap"]]
	1940	"t"
	1941	, [\|typ\|] ) )
	1942	; ("__wit", cert, cert_typ) ]
	1943	(Tacmach.New.pf_concl gl))
	1944	(* Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids)*)
	1945	])
1923	1946
1924	1947	let micromega_genr prover tac =
1925	1948	let parse_arith = parse_rarith in
1926		let spec = lazy {
1927		typ = Lazy.force coq_R;
1928		coeff = Lazy.force coq_Rcst;
1929		dump_coeff = dump_q;
1930		proof_typ = Lazy.force coq_QWitness ;
1931		dump_proof = dump_psatz coq_Q dump_q
1932		} in
1933		Proofview.Goal.enter begin fun gl ->
1934		let sigma = Tacmach.New.project gl in
1935		let concl = Tacmach.New.pf_concl gl in
1936		let hyps = Tacmach.New.pf_hyps_types gl in
1937
1938		try
1939		let gl0 = { env = Tacmach.New.pf_env gl; sigma } in
1940		let (hyps,concl,env) = parse_goal gl0 parse_arith (Env.empty gl0) hyps concl in
1941		let env = Env.elements env in
1942		let spec = Lazy.force spec in
1943
1944		let hyps' = List.map (fun (n,f) -> (n, Mc.map_bformula (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in
1945		let concl' = Mc.map_bformula (Micromega.map_Formula Micromega.q_of_Rcst) concl in
1946
1947		match micromega_tauto (fun _ x -> x) Mc.cnfQ spec prover env hyps' concl' gl0 with
1948		\| Unknown \| Model _ -> flush stdout ; Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness")
1949		\| Prf (ids,ff',res') ->
1950		let (ff,ids) = formula_hyps_concl
1951		(List.filter (fun (n,_) -> List.mem n ids) hyps) concl in
1952
1953		let ff' = abstract_wrt_formula ff' ff in
1954
1955		let (arith_goal,props,vars,ff_arith) = make_goal_of_formula gl0 (Lazy.force dump_rexpr) ff' in
1956		let intro (id,_) = Tactics.introduction id in
1957
1958		let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in
1959		let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in
1960		let ipat_of_name id = Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) in
1961		let goal_name = fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl in
1962		let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in
1963
1964		let tac_arith = Tacticals.New.tclTHENLIST [ clear_all_no_check ; intro_props ; intro_vars ;
1965		micromega_order_changer res' env' ff_arith ] in
1966
1967		let goal_props = List.rev (Env.elements (prop_env_of_formula gl0 ff')) in
1968
1969		let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in
1970
1971		let arith_args = goal_props @ goal_vars in
1972
1973		let kill_arith = Tacticals.New.tclTHEN tac_arith tac in
1974		(* Tacticals.New.tclTHEN
	1949	let spec =
	1950	lazy
	1951	{ typ = Lazy.force coq_R
	1952	; coeff = Lazy.force coq_Rcst
	1953	; dump_coeff = dump_q
	1954	; proof_typ = Lazy.force coq_QWitness
	1955	; dump_proof = dump_psatz coq_Q dump_q }
	1956	in
	1957	Proofview.Goal.enter (fun gl ->
	1958	let sigma = Tacmach.New.project gl in
	1959	let concl = Tacmach.New.pf_concl gl in
	1960	let hyps = Tacmach.New.pf_hyps_types gl in
	1961	try
	1962	let gl0 = {env = Tacmach.New.pf_env gl; sigma} in
	1963	let hyps, concl, env =
	1964	parse_goal gl0 parse_arith (Env.empty gl0) hyps concl
	1965	in
	1966	let env = Env.elements env in
	1967	let spec = Lazy.force spec in
	1968	let hyps' =
	1969	List.map
	1970	(fun (n, f) ->
	1971	(n, Mc.map_bformula (Micromega.map_Formula Micromega.q_of_Rcst) f))
	1972	hyps
	1973	in
	1974	let concl' =
	1975	Mc.map_bformula (Micromega.map_Formula Micromega.q_of_Rcst) concl
	1976	in
	1977	match
	1978	micromega_tauto
	1979	(fun _ x -> x)
	1980	Mc.cnfQ spec prover env hyps' concl' gl0
	1981	with
	1982	\| Unknown \| Model _ ->
	1983	flush stdout;
	1984	Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness")
	1985	\| Prf (ids, ff', res') ->
	1986	let ff, ids =
	1987	formula_hyps_concl
	1988	(List.filter (fun (n, _) -> List.mem n ids) hyps)
	1989	concl
	1990	in
	1991	let ff' = abstract_wrt_formula ff' ff in
	1992	let arith_goal, props, vars, ff_arith =
	1993	make_goal_of_formula gl0 (Lazy.force dump_rexpr) ff'
	1994	in
	1995	let intro (id, _) = Tactics.introduction id in
	1996	let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in
	1997	let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in
	1998	let ipat_of_name id =
	1999	Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id))
	2000	in
	2001	let goal_name =
	2002	fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl
	2003	in
	2004	let env' = List.map (fun (id, i) -> (EConstr.mkVar id, i)) vars in
	2005	let tac_arith =
	2006	Tacticals.New.tclTHENLIST
	2007	[ clear_all_no_check
	2008	; intro_props
	2009	; intro_vars
	2010	; micromega_order_changer res' env' ff_arith ]
	2011	in
	2012	let goal_props =
	2013	List.rev (Env.elements (prop_env_of_formula gl0 ff'))
	2014	in
	2015	let goal_vars = List.map (fun (_, i) -> List.nth env (i - 1)) vars in
	2016	let arith_args = goal_props @ goal_vars in
	2017	let kill_arith = Tacticals.New.tclTHEN tac_arith tac in
	2018	(* Tacticals.New.tclTHEN
1975	2019	(Tactics.keep [])
1976	2020	(Tactics.tclABSTRACT None*)
1977
1978		Tacticals.New.tclTHENS
1979		(Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal)
1980		[
1981		kill_arith;
1982		(Tacticals.New.tclTHENLIST
1983		[(Tactics.generalize (List.map EConstr.mkVar ids));
1984		(Tactics.exact_check (EConstr.applist (EConstr.mkVar goal_name, arith_args)))
1985		] )
1986		]
1987
1988		with
1989		\| Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout")
1990		\| CsdpNotFound -> flush stdout ;
1991		Tacticals.New.tclFAIL 0 (Pp.str
1992		(" Skipping what remains of this tactic: the complexity of the goal requires "
1993		^ "the use of a specialized external tool called csdp. \n\n"
1994		^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n"
1995		^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp"))
1996		end
1997
1998
1999		let lift_ratproof prover l =
2000		match prover l with
	2021	Tacticals.New.tclTHENS
	2022	(Tactics.forward true (Some None) (ipat_of_name goal_name)
	2023	arith_goal)
	2024	[ kill_arith
	2025	; Tacticals.New.tclTHENLIST
	2026	[ Tactics.generalize (List.map EConstr.mkVar ids)
	2027	; Tactics.exact_check
	2028	(EConstr.applist (EConstr.mkVar goal_name, arith_args)) ] ]
	2029	with
	2030	\| Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout")
	2031	\| CsdpNotFound ->
	2032	flush stdout;
	2033	Tacticals.New.tclFAIL 0
	2034	(Pp.str
	2035	( " Skipping what remains of this tactic: the complexity of the \
	2036	goal requires "
	2037	^ "the use of a specialized external tool called csdp. \n\n"
	2038	^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" \
	2039	executable in the path. \n\n"
	2040	^ "Csdp packages are provided by some OS distributions; binaries \
	2041	and source code can be downloaded from \
	2042	https://projects.coin-or.org/Csdp" )))
	2043
	2044	let lift_ratproof prover l =
	2045	match prover l with
2001	2046	\| Unknown \| Model _ -> Unknown
2002		\| Prf c -> Prf (Mc.RatProof( c,Mc.DoneProof))
	2047	\| Prf c -> Prf (Mc.RatProof (c, Mc.DoneProof))
2003	2048
2004	2049	type micromega_polys = (Micromega.q Mc.pol * Mc.op1) list
2005	2050
2006	2051	[@@@ocaml.warning "-37"]
	2052
2007	2053	type csdp_certificate = S of Sos_types.positivstellensatz option \| F of string
	2054
2008	2055	(* Used to read the result of the execution of csdpcert *)
2009	2056
2010	2057	type provername = string * int option

2015	2062
2016	2063	open Persistent_cache
2017	2064
2018
2019		module MakeCache(T : sig type prover_option
2020		type coeff
2021		val hash_prover_option : int -> prover_option -> int
2022		val hash_coeff : int -> coeff -> int
2023		val eq_prover_option : prover_option -> prover_option -> bool
2024		val eq_coeff : coeff -> coeff -> bool
2025
2026		end) =
2027		struct
2028		module E =
2029		struct
2030		type t = T.prover_option * (T.coeff Mc.pol * Mc.op1) list
2031
2032		let equal = Hash.(eq_pair T.eq_prover_option (CList.equal (eq_pair (eq_pol T.eq_coeff) Hash.eq_op1)))
2033
2034		let hash =
2035		let hash_cstr = Hash.(hash_pair (hash_pol T.hash_coeff) hash_op1) in
2036		Hash.( (hash_pair T.hash_prover_option (List.fold_left hash_cstr)) 0)
2037		end
2038
2039		include PHashtable(E)
2040
2041		let memo_opt use_cache cache_file f =
2042		let memof = memo cache_file f in
2043		fun x -> if !use_cache then memof x else f x
2044
	2065	module MakeCache (T : sig
	2066	type prover_option
	2067	type coeff
	2068
	2069	val hash_prover_option : int -> prover_option -> int
	2070	val hash_coeff : int -> coeff -> int
	2071	val eq_prover_option : prover_option -> prover_option -> bool
	2072	val eq_coeff : coeff -> coeff -> bool
	2073	end) =
	2074	struct
	2075	module E = struct
	2076	type t = T.prover_option * (T.coeff Mc.pol * Mc.op1) list
	2077
	2078	let equal =
	2079	Hash.(
	2080	eq_pair T.eq_prover_option
	2081	(CList.equal (eq_pair (eq_pol T.eq_coeff) Hash.eq_op1)))
	2082
	2083	let hash =
	2084	let hash_cstr = Hash.(hash_pair (hash_pol T.hash_coeff) hash_op1) in
	2085	Hash.((hash_pair T.hash_prover_option (List.fold_left hash_cstr)) 0)
2045	2086	end
2046	2087
2047
2048
2049		module CacheCsdp = MakeCache(struct
2050		type prover_option = provername
2051		type coeff = Mc.q
2052		let hash_prover_option = Hash.(hash_pair hash_string
2053		(hash_elt (Option.hash (fun x -> x))))
2054		let eq_prover_option = Hash.(eq_pair String.equal
2055		(Option.equal Int.equal))
2056		let hash_coeff = Hash.hash_q
2057		let eq_coeff = Hash.eq_q
2058		end)
	2088	include PHashtable (E)
	2089
	2090	let memo_opt use_cache cache_file f =
	2091	let memof = memo cache_file f in
	2092	fun x -> if !use_cache then memof x else f x
	2093	end
	2094
	2095	module CacheCsdp = MakeCache (struct
	2096	type prover_option = provername
	2097	type coeff = Mc.q
	2098
	2099	let hash_prover_option =
	2100	Hash.(hash_pair hash_string (hash_elt (Option.hash (fun x -> x))))
	2101
	2102	let eq_prover_option = Hash.(eq_pair String.equal (Option.equal Int.equal))
	2103	let hash_coeff = Hash.hash_q
	2104	let eq_coeff = Hash.eq_q
	2105	end)
2059	2106
2060	2107	(**
2061	2108	* Build the command to call csdpcert, and launch it. This in turn will call

2064	2111	*)
2065	2112
2066	2113	let require_csdp =
2067		if System.is_in_system_path "csdp"
2068		then lazy ()
2069		else lazy (raise CsdpNotFound)
2070
2071		let really_call_csdpcert : provername -> micromega_polys -> Sos_types.positivstellensatz option =
2072		fun provername poly ->
2073
	2114	if System.is_in_system_path "csdp" then lazy () else lazy (raise CsdpNotFound)
	2115
	2116	let really_call_csdpcert :
	2117	provername -> micromega_polys -> Sos_types.positivstellensatz option =
	2118	fun provername poly ->
2074	2119	Lazy.force require_csdp;
2075
2076	2120	let cmdname =
2077	2121	List.fold_left Filename.concat (Envars.coqlib ())
2078		["plugins"; "micromega"; "csdpcert" ^ Coq_config.exec_extension] in
2079
2080		match ((command cmdname [\|cmdname\|] (provername,poly)) : csdp_certificate) with
2081		\| F str ->
2082		if debug then Printf.fprintf stdout "really_call_csdpcert : %s\n" str;
2083		raise (failwith str)
2084		\| S res -> res
	2122	["plugins"; "micromega"; "csdpcert" ^ Coq_config.exec_extension]
	2123	in
	2124	match (command cmdname [\|cmdname\|] (provername, poly) : csdp_certificate) with
	2125	\| F str ->
	2126	if debug then Printf.fprintf stdout "really_call_csdpcert : %s\n" str;
	2127	raise (failwith str)
	2128	\| S res -> res
2085	2129
2086	2130	(**
2087	2131	* Check the cache before calling the prover.
2088	2132	*)
2089	2133
2090	2134	let xcall_csdpcert =
2091		CacheCsdp.memo_opt use_csdp_cache ".csdp.cache" (fun (prover,pb) -> really_call_csdpcert prover pb)
	2135	CacheCsdp.memo_opt use_csdp_cache ".csdp.cache" (fun (prover, pb) ->
	2136	really_call_csdpcert prover pb)
2092	2137
2093	2138	(**
2094	2139	* Prover callback functions.
2095	2140	*)
2096	2141
2097		let call_csdpcert prover pb = xcall_csdpcert (prover,pb)
	2142	let call_csdpcert prover pb = xcall_csdpcert (prover, pb)
2098	2143
2099	2144	let rec z_to_q_pol e =
2100		match e with
2101		\| Mc.Pc z -> Mc.Pc {Mc.qnum = z ; Mc.qden = Mc.XH}
2102		\| Mc.Pinj(p,pol) -> Mc.Pinj(p,z_to_q_pol pol)
2103		\| Mc.PX(pol1,p,pol2) -> Mc.PX(z_to_q_pol pol1, p, z_to_q_pol pol2)
	2145	match e with
	2146	\| Mc.Pc z -> Mc.Pc {Mc.qnum = z; Mc.qden = Mc.XH}
	2147	\| Mc.Pinj (p, pol) -> Mc.Pinj (p, z_to_q_pol pol)
	2148	\| Mc.PX (pol1, p, pol2) -> Mc.PX (z_to_q_pol pol1, p, z_to_q_pol pol2)
2104	2149
2105	2150	let call_csdpcert_q provername poly =
2106		match call_csdpcert provername poly with
	2151	match call_csdpcert provername poly with
2107	2152	\| None -> Unknown
2108	2153	\| Some cert ->
2109		let cert = Certificate.q_cert_of_pos cert in
2110		if Mc.qWeakChecker poly cert
2111		then Prf cert
2112		else ((print_string "buggy certificate") ;Unknown)
	2154	let cert = Certificate.q_cert_of_pos cert in
	2155	if Mc.qWeakChecker poly cert then Prf cert
	2156	else (
	2157	print_string "buggy certificate";
	2158	Unknown )
2113	2159
2114	2160	let call_csdpcert_z provername poly =
2115		let l = List.map (fun (e,o) -> (z_to_q_pol e,o)) poly in
	2161	let l = List.map (fun (e, o) -> (z_to_q_pol e, o)) poly in
2116	2162	match call_csdpcert provername l with
2117		\| None -> Unknown
2118		\| Some cert ->
2119		let cert = Certificate.z_cert_of_pos cert in
2120		if Mc.zWeakChecker poly cert
2121		then Prf cert
2122		else ((print_string "buggy certificate" ; flush stdout) ;Unknown)
	2163	\| None -> Unknown
	2164	\| Some cert ->
	2165	let cert = Certificate.z_cert_of_pos cert in
	2166	if Mc.zWeakChecker poly cert then Prf cert
	2167	else (
	2168	print_string "buggy certificate";
	2169	flush stdout;
	2170	Unknown )
2123	2171
2124	2172	let xhyps_of_cone base acc prf =
2125	2173	let rec xtract e acc =
2126	2174	match e with
2127	2175	\| Mc.PsatzC _ \| Mc.PsatzZ \| Mc.PsatzSquare _ -> acc
2128		\| Mc.PsatzIn n -> let n = (CoqToCaml.nat n) in
2129		if n >= base
2130		then ISet.add (n-base) acc
2131		else acc
2132		\| Mc.PsatzMulC(_,c) -> xtract c acc
2133		\| Mc.PsatzAdd(e1,e2) \| Mc.PsatzMulE(e1,e2) -> xtract e1 (xtract e2 acc) in
2134
2135		xtract prf acc
	2176	\| Mc.PsatzIn n ->
	2177	let n = CoqToCaml.nat n in
	2178	if n >= base then ISet.add (n - base) acc else acc
	2179	\| Mc.PsatzMulC (_, c) -> xtract c acc
	2180	\| Mc.PsatzAdd (e1, e2) \| Mc.PsatzMulE (e1, e2) -> xtract e1 (xtract e2 acc)
	2181	in
	2182	xtract prf acc
2136	2183
2137	2184	let hyps_of_cone prf = xhyps_of_cone 0 ISet.empty prf
2138	2185
2139		let compact_cone prf f =
	2186	let compact_cone prf f =
2140	2187	let np n = CamlToCoq.nat (f (CoqToCaml.nat n)) in
2141
2142	2188	let rec xinterp prf =
2143	2189	match prf with
2144	2190	\| Mc.PsatzC _ \| Mc.PsatzZ \| Mc.PsatzSquare _ -> prf
2145	2191	\| Mc.PsatzIn n -> Mc.PsatzIn (np n)
2146		\| Mc.PsatzMulC(e,c) -> Mc.PsatzMulC(e,xinterp c)
2147		\| Mc.PsatzAdd(e1,e2) -> Mc.PsatzAdd(xinterp e1,xinterp e2)
2148		\| Mc.PsatzMulE(e1,e2) -> Mc.PsatzMulE(xinterp e1,xinterp e2) in
2149
2150		xinterp prf
	2192	\| Mc.PsatzMulC (e, c) -> Mc.PsatzMulC (e, xinterp c)
	2193	\| Mc.PsatzAdd (e1, e2) -> Mc.PsatzAdd (xinterp e1, xinterp e2)
	2194	\| Mc.PsatzMulE (e1, e2) -> Mc.PsatzMulE (xinterp e1, xinterp e2)
	2195	in
	2196	xinterp prf
2151	2197
2152	2198	let hyps_of_pt pt =
2153
2154	2199	let rec xhyps base pt acc =
2155	2200	match pt with
2156		\| Mc.DoneProof -> acc
2157		\| Mc.RatProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c)
2158		\| Mc.CutProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c)
2159		\| Mc.EnumProof(c1,c2,l) ->
2160		let s = xhyps_of_cone base (xhyps_of_cone base acc c2) c1 in
2161		List.fold_left (fun s x -> xhyps (base + 1) x s) s l in
2162
2163		xhyps 0 pt ISet.empty
	2201	\| Mc.DoneProof -> acc
	2202	\| Mc.RatProof (c, pt) -> xhyps (base + 1) pt (xhyps_of_cone base acc c)
	2203	\| Mc.CutProof (c, pt) -> xhyps (base + 1) pt (xhyps_of_cone base acc c)
	2204	\| Mc.EnumProof (c1, c2, l) ->
	2205	let s = xhyps_of_cone base (xhyps_of_cone base acc c2) c1 in
	2206	List.fold_left (fun s x -> xhyps (base + 1) x s) s l
	2207	\| Mc.ExProof (_, pt) -> xhyps (base + 3) pt acc
	2208	in
	2209	xhyps 0 pt ISet.empty
2164	2210
2165	2211	let compact_pt pt f =
2166		let translate ofset x =
2167		if x < ofset then x
2168		else (f (x-ofset) + ofset) in
2169
	2212	let translate ofset x = if x < ofset then x else f (x - ofset) + ofset in
2170	2213	let rec compact_pt ofset pt =
2171	2214	match pt with
2172		\| Mc.DoneProof -> Mc.DoneProof
2173		\| Mc.RatProof(c,pt) -> Mc.RatProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt )
2174		\| Mc.CutProof(c,pt) -> Mc.CutProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt )
2175		\| Mc.EnumProof(c1,c2,l) -> Mc.EnumProof(compact_cone c1 (translate (ofset)), compact_cone c2 (translate (ofset)),
2176		Mc.map (fun x -> compact_pt (ofset+1) x) l) in
2177		compact_pt 0 pt
	2215	\| Mc.DoneProof -> Mc.DoneProof
	2216	\| Mc.RatProof (c, pt) ->
	2217	Mc.RatProof (compact_cone c (translate ofset), compact_pt (ofset + 1) pt)
	2218	\| Mc.CutProof (c, pt) ->
	2219	Mc.CutProof (compact_cone c (translate ofset), compact_pt (ofset + 1) pt)
	2220	\| Mc.EnumProof (c1, c2, l) ->
	2221	Mc.EnumProof
	2222	( compact_cone c1 (translate ofset)
	2223	, compact_cone c2 (translate ofset)
	2224	, Mc.map (fun x -> compact_pt (ofset + 1) x) l )
	2225	\| Mc.ExProof (x, pt) -> Mc.ExProof (x, compact_pt (ofset + 3) pt)
	2226	in
	2227	compact_pt 0 pt
2178	2228
2179	2229	(**
2180	2230	* Definition of provers.
2181	2231	* Instantiates the type ('a,'prf) prover defined above.
2182	2232	*)
2183	2233
2184		let lift_pexpr_prover p l = p (List.map (fun (e,o) -> Mc.denorm e , o) l)
2185
2186
2187		module CacheZ = MakeCache(struct
2188		type prover_option = bool * bool* int
2189		type coeff = Mc.z
2190		let hash_prover_option : int -> prover_option -> int = Hash.hash_elt Hashtbl.hash
2191		let eq_prover_option : prover_option -> prover_option -> bool = (=)
2192		let eq_coeff = Hash.eq_z
2193		let hash_coeff = Hash.hash_z
2194		end)
2195
2196		module CacheQ = MakeCache(struct
2197		type prover_option = int
2198		type coeff = Mc.q
2199		let hash_prover_option : int -> int -> int = Hash.hash_elt Hashtbl.hash
2200		let eq_prover_option = Int.equal
2201		let eq_coeff = Hash.eq_q
2202		let hash_coeff = Hash.hash_q
2203		end)
2204
2205		let memo_lia = CacheZ.memo_opt use_lia_cache ".lia.cache"
2206		(fun ((_,ce,b),s) -> lift_pexpr_prover (Certificate.lia ce b) s)
2207		let memo_nlia = CacheZ.memo_opt use_nia_cache ".nia.cache"
2208		(fun ((_,ce,b),s) -> lift_pexpr_prover (Certificate.nlia ce b) s)
2209		let memo_nra = CacheQ.memo_opt use_nra_cache ".nra.cache"
2210		(fun (o,s) -> lift_pexpr_prover (Certificate.nlinear_prover o) s)
2211
2212
2213
2214		let linear_prover_Q = {
2215		name = "linear prover";
2216		get_option = get_lra_option ;
2217		prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o ) l) ;
2218		hyps = hyps_of_cone ;
2219		compact = compact_cone ;
2220		pp_prf = pp_psatz pp_q ;
2221		pp_f = fun o x -> pp_pol pp_q o (fst x)
2222		}
2223
2224
2225		let linear_prover_R = {
2226		name = "linear prover";
2227		get_option = get_lra_option ;
2228		prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o ) l) ;
2229		hyps = hyps_of_cone ;
2230		compact = compact_cone ;
2231		pp_prf = pp_psatz pp_q ;
2232		pp_f = fun o x -> pp_pol pp_q o (fst x)
2233		}
2234
2235		let nlinear_prover_R = {
2236		name = "nra";
2237		get_option = get_lra_option;
2238		prover = memo_nra ;
2239		hyps = hyps_of_cone ;
2240		compact = compact_cone ;
2241		pp_prf = pp_psatz pp_q ;
2242		pp_f = fun o x -> pp_pol pp_q o (fst x)
2243		}
2244
2245		let non_linear_prover_Q str o = {
2246		name = "real nonlinear prover";
2247		get_option = (fun () -> (str,o));
2248		prover = (fun (o,l) -> call_csdpcert_q o l);
2249		hyps = hyps_of_cone;
2250		compact = compact_cone ;
2251		pp_prf = pp_psatz pp_q ;
2252		pp_f = fun o x -> pp_pol pp_q o (fst x)
2253		}
2254
2255		let non_linear_prover_R str o = {
2256		name = "real nonlinear prover";
2257		get_option = (fun () -> (str,o));
2258		prover = (fun (o,l) -> call_csdpcert_q o l);
2259		hyps = hyps_of_cone;
2260		compact = compact_cone;
2261		pp_prf = pp_psatz pp_q;
2262		pp_f = fun o x -> pp_pol pp_q o (fst x)
2263		}
2264
2265		let non_linear_prover_Z str o = {
2266		name = "real nonlinear prover";
2267		get_option = (fun () -> (str,o));
2268		prover = (fun (o,l) -> lift_ratproof (call_csdpcert_z o) l);
2269		hyps = hyps_of_pt;
2270		compact = compact_pt;
2271		pp_prf = pp_proof_term;
2272		pp_f = fun o x -> pp_pol pp_z o (fst x)
2273		}
2274
2275		let linear_Z = {
2276		name = "lia";
2277		get_option = get_lia_option;
2278		prover = memo_lia ;
2279		hyps = hyps_of_pt;
2280		compact = compact_pt;
2281		pp_prf = pp_proof_term;
2282		pp_f = fun o x -> pp_pol pp_z o (fst x)
2283		}
2284
2285		let nlinear_Z = {
2286		name = "nlia";
2287		get_option = get_lia_option;
2288		prover = memo_nlia ;
2289		hyps = hyps_of_pt;
2290		compact = compact_pt;
2291		pp_prf = pp_proof_term;
2292		pp_f = fun o x -> pp_pol pp_z o (fst x)
2293		}
	2234	let lift_pexpr_prover p l = p (List.map (fun (e, o) -> (Mc.denorm e, o)) l)
	2235
	2236	module CacheZ = MakeCache (struct
	2237	type prover_option = bool * bool * int
	2238	type coeff = Mc.z
	2239
	2240	let hash_prover_option : int -> prover_option -> int =
	2241	Hash.hash_elt Hashtbl.hash
	2242
	2243	let eq_prover_option : prover_option -> prover_option -> bool = ( = )
	2244	let eq_coeff = Hash.eq_z
	2245	let hash_coeff = Hash.hash_z
	2246	end)
	2247
	2248	module CacheQ = MakeCache (struct
	2249	type prover_option = int
	2250	type coeff = Mc.q
	2251
	2252	let hash_prover_option : int -> int -> int = Hash.hash_elt Hashtbl.hash
	2253	let eq_prover_option = Int.equal
	2254	let eq_coeff = Hash.eq_q
	2255	let hash_coeff = Hash.hash_q
	2256	end)
	2257
	2258	let memo_lia =
	2259	CacheZ.memo_opt use_lia_cache ".lia.cache" (fun ((_, ce, b), s) ->
	2260	lift_pexpr_prover (Certificate.lia ce b) s)
	2261
	2262	let memo_nlia =
	2263	CacheZ.memo_opt use_nia_cache ".nia.cache" (fun ((_, ce, b), s) ->
	2264	lift_pexpr_prover (Certificate.nlia ce b) s)
	2265
	2266	let memo_nra =
	2267	CacheQ.memo_opt use_nra_cache ".nra.cache" (fun (o, s) ->
	2268	lift_pexpr_prover (Certificate.nlinear_prover o) s)
	2269
	2270	let linear_prover_Q =
	2271	{ name = "linear prover"
	2272	; get_option = get_lra_option
	2273	; prover =
	2274	(fun (o, l) ->
	2275	lift_pexpr_prover (Certificate.linear_prover_with_cert o) l)
	2276	; hyps = hyps_of_cone
	2277	; compact = compact_cone
	2278	; pp_prf = pp_psatz pp_q
	2279	; pp_f = (fun o x -> pp_pol pp_q o (fst x)) }
	2280
	2281	let linear_prover_R =
	2282	{ name = "linear prover"
	2283	; get_option = get_lra_option
	2284	; prover =
	2285	(fun (o, l) ->
	2286	lift_pexpr_prover (Certificate.linear_prover_with_cert o) l)
	2287	; hyps = hyps_of_cone
	2288	; compact = compact_cone
	2289	; pp_prf = pp_psatz pp_q
	2290	; pp_f = (fun o x -> pp_pol pp_q o (fst x)) }
	2291
	2292	let nlinear_prover_R =
	2293	{ name = "nra"
	2294	; get_option = get_lra_option
	2295	; prover = memo_nra
	2296	; hyps = hyps_of_cone
	2297	; compact = compact_cone
	2298	; pp_prf = pp_psatz pp_q
	2299	; pp_f = (fun o x -> pp_pol pp_q o (fst x)) }
	2300
	2301	let non_linear_prover_Q str o =
	2302	{ name = "real nonlinear prover"
	2303	; get_option = (fun () -> (str, o))
	2304	; prover = (fun (o, l) -> call_csdpcert_q o l)
	2305	; hyps = hyps_of_cone
	2306	; compact = compact_cone
	2307	; pp_prf = pp_psatz pp_q
	2308	; pp_f = (fun o x -> pp_pol pp_q o (fst x)) }
	2309
	2310	let non_linear_prover_R str o =
	2311	{ name = "real nonlinear prover"
	2312	; get_option = (fun () -> (str, o))
	2313	; prover = (fun (o, l) -> call_csdpcert_q o l)
	2314	; hyps = hyps_of_cone
	2315	; compact = compact_cone
	2316	; pp_prf = pp_psatz pp_q
	2317	; pp_f = (fun o x -> pp_pol pp_q o (fst x)) }
	2318
	2319	let non_linear_prover_Z str o =
	2320	{ name = "real nonlinear prover"
	2321	; get_option = (fun () -> (str, o))
	2322	; prover = (fun (o, l) -> lift_ratproof (call_csdpcert_z o) l)
	2323	; hyps = hyps_of_pt
	2324	; compact = compact_pt
	2325	; pp_prf = pp_proof_term
	2326	; pp_f = (fun o x -> pp_pol pp_z o (fst x)) }
	2327
	2328	let linear_Z =
	2329	{ name = "lia"
	2330	; get_option = get_lia_option
	2331	; prover = memo_lia
	2332	; hyps = hyps_of_pt
	2333	; compact = compact_pt
	2334	; pp_prf = pp_proof_term
	2335	; pp_f = (fun o x -> pp_pol pp_z o (fst x)) }
	2336
	2337	let nlinear_Z =
	2338	{ name = "nlia"
	2339	; get_option = get_lia_option
	2340	; prover = memo_nlia
	2341	; hyps = hyps_of_pt
	2342	; compact = compact_pt
	2343	; pp_prf = pp_proof_term
	2344	; pp_f = (fun o x -> pp_pol pp_z o (fst x)) }
2294	2345
2295	2346	(**
2296	2347	* Functions instantiating micromega_gen with the appropriate theories and

2298	2349	*)
2299	2350
2300	2351	let exfalso_if_concl_not_Prop =
2301		Proofview.Goal.enter begin fun gl ->
2302		Tacmach.New.(
2303		if is_prop (pf_env gl) (project gl) (pf_concl gl)
2304		then Tacticals.New.tclIDTAC
2305		else Tactics.elim_type (Lazy.force coq_False)
2306		)
2307		end
	2352	Proofview.Goal.enter (fun gl ->
	2353	Tacmach.New.(
	2354	if is_prop (pf_env gl) (project gl) (pf_concl gl) then
	2355	Tacticals.New.tclIDTAC
	2356	else Tactics.elim_type (Lazy.force coq_False)))
2308	2357
2309	2358	let micromega_gen parse_arith pre_process cnf spec dumpexpr prover tac =
2310		Tacticals.New.tclTHEN exfalso_if_concl_not_Prop (micromega_gen parse_arith pre_process cnf spec dumpexpr prover tac)
	2359	Tacticals.New.tclTHEN exfalso_if_concl_not_Prop
	2360	(micromega_gen parse_arith pre_process cnf spec dumpexpr prover tac)
2311	2361
2312	2362	let micromega_genr prover tac =
2313	2363	Tacticals.New.tclTHEN exfalso_if_concl_not_Prop (micromega_genr prover tac)
2314	2364
2315	2365	let lra_Q =
2316		micromega_gen parse_qarith (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr
2317		linear_prover_Q
2318
2319		let psatz_Q i =
2320		micromega_gen parse_qarith (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr
2321		(non_linear_prover_Q "real_nonlinear_prover" (Some i) )
2322
2323		let lra_R =
2324		micromega_genr linear_prover_R
2325
2326		let psatz_R i =
2327		micromega_genr (non_linear_prover_R "real_nonlinear_prover" (Some i))
2328
2329
2330		let psatz_Z i =
2331		micromega_gen parse_zarith (fun _ x -> x) Mc.cnfZ zz_domain_spec dump_zexpr
2332		(non_linear_prover_Z "real_nonlinear_prover" (Some i) )
2333
2334		let sos_Z =
2335		micromega_gen parse_zarith (fun _ x -> x) Mc.cnfZ zz_domain_spec dump_zexpr
2336		(non_linear_prover_Z "pure_sos" None)
2337
2338		let sos_Q =
2339		micromega_gen parse_qarith (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr
2340		(non_linear_prover_Q "pure_sos" None)
2341
2342
2343		let sos_R =
2344		micromega_genr (non_linear_prover_R "pure_sos" None)
2345
	2366	micromega_gen parse_qarith
	2367	(fun _ x -> x)
	2368	Mc.cnfQ qq_domain_spec dump_qexpr linear_prover_Q
	2369
	2370	let psatz_Q i =
	2371	micromega_gen parse_qarith
	2372	(fun _ x -> x)
	2373	Mc.cnfQ qq_domain_spec dump_qexpr
	2374	(non_linear_prover_Q "real_nonlinear_prover" (Some i))
	2375
	2376	let lra_R = micromega_genr linear_prover_R
	2377
	2378	let psatz_R i =
	2379	micromega_genr (non_linear_prover_R "real_nonlinear_prover" (Some i))
	2380
	2381	let psatz_Z i =
	2382	micromega_gen parse_zarith
	2383	(fun _ x -> x)
	2384	Mc.cnfZ zz_domain_spec dump_zexpr
	2385	(non_linear_prover_Z "real_nonlinear_prover" (Some i))
	2386
	2387	let sos_Z =
	2388	micromega_gen parse_zarith
	2389	(fun _ x -> x)
	2390	Mc.cnfZ zz_domain_spec dump_zexpr
	2391	(non_linear_prover_Z "pure_sos" None)
	2392
	2393	let sos_Q =
	2394	micromega_gen parse_qarith
	2395	(fun _ x -> x)
	2396	Mc.cnfQ qq_domain_spec dump_qexpr
	2397	(non_linear_prover_Q "pure_sos" None)
	2398
	2399	let sos_R = micromega_genr (non_linear_prover_R "pure_sos" None)
2346	2400
2347	2401	let xlia =
2348		micromega_gen parse_zarith pre_processZ Mc.cnfZ zz_domain_spec dump_zexpr
2349		linear_Z
2350
2351
2352		let xnlia =
2353		micromega_gen parse_zarith (fun _ x -> x) Mc.cnfZ zz_domain_spec dump_zexpr
2354		nlinear_Z
2355
2356		let nra =
2357		micromega_genr nlinear_prover_R
2358
2359		let nqa =
2360		micromega_gen parse_qarith (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr
2361		nlinear_prover_R
	2402	micromega_gen parse_zarith
	2403	(fun _ x -> x)
	2404	Mc.cnfZ zz_domain_spec dump_zexpr linear_Z
	2405
	2406	let xnlia =
	2407	micromega_gen parse_zarith
	2408	(fun _ x -> x)
	2409	Mc.cnfZ zz_domain_spec dump_zexpr nlinear_Z
	2410
	2411	let nra = micromega_genr nlinear_prover_R
	2412
	2413	let nqa =
	2414	micromega_gen parse_qarith
	2415	(fun _ x -> x)
	2416	Mc.cnfQ qq_domain_spec dump_qexpr nlinear_prover_R
2362	2417
2363	2418	(* Local Variables: *)
2364	2419	(* coding: utf-8 *)

-2

plugins/micromega/coq_micromega.mli less more

21	21	val lra_Q : unit Proofview.tactic -> unit Proofview.tactic
22	22	val lra_R : unit Proofview.tactic -> unit Proofview.tactic
23	23
24
25	24	(** {5 Use Micromega independently from tactics. } *)
26	25
	26	val dump_proof_term : Micromega.zArithProof -> EConstr.t
27	27	(** [dump_proof_term] generates the Coq representation of a Micromega proof witness *)
28		val dump_proof_term : Micromega.zArithProof -> EConstr.t

+142

-121

plugins/micromega/csdpcert.ml less more

17	17	open Sos
18	18	open Sos_types
19	19	open Sos_lib
20
21	20	module Mc = Micromega
22	21	module C2Ml = Mutils.CoqToCaml
23	22

25	24	type csdp_certificate = S of Sos_types.positivstellensatz option \| F of string
26	25	type provername = string * int option
27	26
28
29		let flags = [Open_append;Open_binary;Open_creat]
30
	27	let flags = [Open_append; Open_binary; Open_creat]
31	28	let chan = open_out_gen flags 0o666 "trace"
32	29
33
34		module M =
35		struct
36		open Mc
37
38		let rec expr_to_term = function
39		\| PEc z -> Const (C2Ml.q_to_num z)
40		\| PEX v -> Var ("x"^(string_of_int (C2Ml.index v)))
41		\| PEmul(p1,p2) ->
	30	module M = struct
	31	open Mc
	32
	33	let rec expr_to_term = function
	34	\| PEc z -> Const (C2Ml.q_to_num z)
	35	\| PEX v -> Var ("x" ^ string_of_int (C2Ml.index v))
	36	\| PEmul (p1, p2) ->
42	37	let p1 = expr_to_term p1 in
43	38	let p2 = expr_to_term p2 in
44		let res = Mul(p1,p2) in res
45
46		\| PEadd(p1,p2) -> Add(expr_to_term p1, expr_to_term p2)
47		\| PEsub(p1,p2) -> Sub(expr_to_term p1, expr_to_term p2)
48		\| PEpow(p,n) -> Pow(expr_to_term p , C2Ml.n n)
49		\| PEopp p -> Opp (expr_to_term p)
50
51
	39	let res = Mul (p1, p2) in
	40	res
	41	\| PEadd (p1, p2) -> Add (expr_to_term p1, expr_to_term p2)
	42	\| PEsub (p1, p2) -> Sub (expr_to_term p1, expr_to_term p2)
	43	\| PEpow (p, n) -> Pow (expr_to_term p, C2Ml.n n)
	44	\| PEopp p -> Opp (expr_to_term p)
52	45	end
	46
53	47	open M
54	48
55	49	let partition_expr l =
56		let rec f i = function
57		\| [] -> ([],[],[])
58		\| (e,k)::l ->
59		let (eq,ge,neq) = f (i+1) l in
	50	let rec f i = function
	51	\| [] -> ([], [], [])
	52	\| (e, k) :: l -> (
	53	let eq, ge, neq = f (i + 1) l in
60	54	match k with
61		\| Mc.Equal -> ((e,i)::eq,ge,neq)
62		\| Mc.NonStrict -> (eq,(e,Axiom_le i)::ge,neq)
63		\| Mc.Strict -> (* e > 0 == e >= 0 /\ e <> 0 *)
64		(eq, (e,Axiom_lt i)::ge,(e,Axiom_lt i)::neq)
65		\| Mc.NonEqual -> (eq,ge,(e,Axiom_eq i)::neq)
66		(* Not quite sure -- Coq interface has changed *)
67		in f 0 l
68
	55	\| Mc.Equal -> ((e, i) :: eq, ge, neq)
	56	\| Mc.NonStrict -> (eq, (e, Axiom_le i) :: ge, neq)
	57	\| Mc.Strict ->
	58	(* e > 0 == e >= 0 /\ e <> 0 *)
	59	(eq, (e, Axiom_lt i) :: ge, (e, Axiom_lt i) :: neq)
	60	\| Mc.NonEqual -> (eq, ge, (e, Axiom_eq i) :: neq) )
	61	(* Not quite sure -- Coq interface has changed *)
	62	in
	63	f 0 l
69	64
70	65	let rec sets_of_list l =
71		match l with
	66	match l with
72	67	\| [] -> [[]]
73		\| e::l -> let s = sets_of_list l in
74		s@(List.map (fun s0 -> e::s0) s)
	68	\| e :: l ->
	69	let s = sets_of_list l in
	70	s @ List.map (fun s0 -> e :: s0) s
75	71
76	72	(* The exploration is probably not complete - for simple cases, it works... *)
77	73	let real_nonlinear_prover d l =
78		let l = List.map (fun (e,op) -> (Mc.denorm e,op)) l in
79		try
80		let (eq,ge,neq) = partition_expr l in
81
82		let rec elim_const = function
83		[] -> []
84		\| (x,y)::l -> let p = poly_of_term (expr_to_term x) in
85		if poly_isconst p
86		then elim_const l
87		else (p,y)::(elim_const l) in
88
89		let eq = elim_const eq in
90		let peq = List.map fst eq in
91
92		let pge = List.map
93		(fun (e,psatz) -> poly_of_term (expr_to_term e),psatz) ge in
94
95		let monoids = List.map (fun m -> (List.fold_right (fun (p,kd) y ->
96		let p = poly_of_term (expr_to_term p) in
97		match kd with
98		\| Axiom_lt i -> poly_mul p y
99		\| Axiom_eq i -> poly_mul (poly_pow p 2) y
100		\| _ -> failwith "monoids") m (poly_const (Int 1)) , List.map snd m))
101		(sets_of_list neq) in
102
103		let (cert_ideal, cert_cone,monoid) = deepen_until d (fun d ->
104		tryfind (fun m -> let (ci,cc) =
105		real_positivnullstellensatz_general false d peq pge (poly_neg (fst m) ) in
106		(ci,cc,snd m)) monoids) 0 in
107
108		let proofs_ideal = List.map2 (fun q i -> Eqmul(term_of_poly q,Axiom_eq i))
109		cert_ideal (List.map snd eq) in
110
111		let proofs_cone = List.map term_of_sos cert_cone in
112
113		let proof_ne =
114		let (neq , lt) = List.partition
115		(function Axiom_eq _ -> true \| _ -> false ) monoid in
116		let sq = match
117		(List.map (function Axiom_eq i -> i \| _ -> failwith "error") neq)
118		with
119		\| [] -> Rational_lt (Int 1)
120		\| l -> Monoid l in
121		List.fold_right (fun x y -> Product(x,y)) lt sq in
122
123		let proof = end_itlist
124		(fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in
125		S (Some proof)
126		with
	74	let l = List.map (fun (e, op) -> (Mc.denorm e, op)) l in
	75	try
	76	let eq, ge, neq = partition_expr l in
	77	let rec elim_const = function
	78	\| [] -> []
	79	\| (x, y) :: l ->
	80	let p = poly_of_term (expr_to_term x) in
	81	if poly_isconst p then elim_const l else (p, y) :: elim_const l
	82	in
	83	let eq = elim_const eq in
	84	let peq = List.map fst eq in
	85	let pge =
	86	List.map (fun (e, psatz) -> (poly_of_term (expr_to_term e), psatz)) ge
	87	in
	88	let monoids =
	89	List.map
	90	(fun m ->
	91	( List.fold_right
	92	(fun (p, kd) y ->
	93	let p = poly_of_term (expr_to_term p) in
	94	match kd with
	95	\| Axiom_lt i -> poly_mul p y
	96	\| Axiom_eq i -> poly_mul (poly_pow p 2) y
	97	\| _ -> failwith "monoids")
	98	m (poly_const (Int 1))
	99	, List.map snd m ))
	100	(sets_of_list neq)
	101	in
	102	let cert_ideal, cert_cone, monoid =
	103	deepen_until d
	104	(fun d ->
	105	tryfind
	106	(fun m ->
	107	let ci, cc =
	108	real_positivnullstellensatz_general false d peq pge
	109	(poly_neg (fst m))
	110	in
	111	(ci, cc, snd m))
	112	monoids)
	113	0
	114	in
	115	let proofs_ideal =
	116	List.map2
	117	(fun q i -> Eqmul (term_of_poly q, Axiom_eq i))
	118	cert_ideal (List.map snd eq)
	119	in
	120	let proofs_cone = List.map term_of_sos cert_cone in
	121	let proof_ne =
	122	let neq, lt =
	123	List.partition (function Axiom_eq _ -> true \| _ -> false) monoid
	124	in
	125	let sq =
	126	match
	127	List.map (function Axiom_eq i -> i \| _ -> failwith "error") neq
	128	with
	129	\| [] -> Rational_lt (Int 1)
	130	\| l -> Monoid l
	131	in
	132	List.fold_right (fun x y -> Product (x, y)) lt sq
	133	in
	134	let proof =
	135	end_itlist
	136	(fun s t -> Sum (s, t))
	137	((proof_ne :: proofs_ideal) @ proofs_cone)
	138	in
	139	S (Some proof)
	140	with
127	141	\| Sos_lib.TooDeep -> S None
128	142	\| any -> F (Printexc.to_string any)
129	143
130	144	(* This is somewhat buggy, over Z, strict inequality vanish... *)
131		let pure_sos l =
132		let l = List.map (fun (e,o) -> Mc.denorm e, o) l in
133
134		(* If there is no strict inequality,
	145	let pure_sos l =
	146	let l = List.map (fun (e, o) -> (Mc.denorm e, o)) l in
	147	(* If there is no strict inequality,
135	148	I should nonetheless be able to try something - over Z > is equivalent to -1 >= *)
136		try
137		let l = List.combine l (CList.interval 0 (List.length l -1)) in
138		let (lt,i) = try (List.find (fun (x,_) -> (=) (snd x) Mc.Strict) l)
139		with Not_found -> List.hd l in
140		let plt = poly_neg (poly_of_term (expr_to_term (fst lt))) in
141		let (n,polys) = sumofsquares plt in (* n * (ci * pi^2) *)
142		let pos = Product (Rational_lt n,
143		List.fold_right (fun (c,p) rst -> Sum (Product (Rational_lt c, Square
144		(term_of_poly p)), rst))
145		polys (Rational_lt (Int 0))) in
146		let proof = Sum(Axiom_lt i, pos) in
147		(* let s,proof' = scale_certificate proof in
	149	try
	150	let l = List.combine l (CList.interval 0 (List.length l - 1)) in
	151	let lt, i =
	152	try List.find (fun (x, _) -> snd x = Mc.Strict) l
	153	with Not_found -> List.hd l
	154	in
	155	let plt = poly_neg (poly_of_term (expr_to_term (fst lt))) in
	156	let n, polys = sumofsquares plt in
	157	(* n * (ci * pi^2) *)
	158	let pos =
	159	Product
	160	( Rational_lt n
	161	, List.fold_right
	162	(fun (c, p) rst ->
	163	Sum (Product (Rational_lt c, Square (term_of_poly p)), rst))
	164	polys (Rational_lt (Int 0)) )
	165	in
	166	let proof = Sum (Axiom_lt i, pos) in
	167	(* let s,proof' = scale_certificate proof in
148	168	let cert = snd (cert_of_pos proof') in *)
149	169	S (Some proof)
150		with
151		(* \| Sos.CsdpNotFound -> F "Sos.CsdpNotFound" *)
152		\| any -> (* May be that could be refined *) S None
153
154
	170	with (* \| Sos.CsdpNotFound -> F "Sos.CsdpNotFound" *)
	171	\| any ->
	172	(* May be that could be refined *) S None
155	173
156	174	let run_prover prover pb =
157		match prover with
158		\| "real_nonlinear_prover", Some d -> real_nonlinear_prover d pb
159		\| "pure_sos", None -> pure_sos pb
160		\| prover, _ -> (Printf.printf "unknown prover: %s\n" prover; exit 1)
	175	match prover with
	176	\| "real_nonlinear_prover", Some d -> real_nonlinear_prover d pb
	177	\| "pure_sos", None -> pure_sos pb
	178	\| prover, _ ->
	179	Printf.printf "unknown prover: %s\n" prover;
	180	exit 1
161	181
162	182	let main () =
163	183	try
164		let (prover,poly) = (input_value stdin : provername * micromega_polys) in
	184	let (prover, poly) = (input_value stdin : provername * micromega_polys) in
165	185	let cert = run_prover prover poly in
166		(* Printf.fprintf chan "%a -> %a" print_list_term poly output_csdp_certificate cert ;
	186	(* Printf.fprintf chan "%a -> %a" print_list_term poly output_csdp_certificate cert ;
167	187	close_out chan ; *)
168
169		output_value stdout (cert:csdp_certificate);
170		flush stdout ;
171		Marshal.to_channel chan (cert:csdp_certificate) [] ;
172		flush chan ;
173		exit 0
174		with any -> (Printf.fprintf chan "error %s" (Printexc.to_string any) ; exit 1)
	188	output_value stdout (cert : csdp_certificate);
	189	flush stdout;
	190	Marshal.to_channel chan (cert : csdp_certificate) [];
	191	flush chan;
	192	exit 0
	193	with any ->
	194	Printf.fprintf chan "error %s" (Printexc.to_string any);
	195	exit 1
175	196
176	197	;;
177
178		let _ = main () in ()
	198	let _ = main () in
	199	()
179	200
180	201	(* Local Variables: *)
181	202	(* coding: utf-8 *)

+40

-48

plugins/micromega/itv.ml less more

11	11
12	12	open Num
13	13
14		(** The type of intervals is *)
15		type interval = num option * num option
16		(** None models the absence of bound i.e. infinity
	14	(** The type of intervals is *)
	15	type interval = num option * num option
	16	(** None models the absence of bound i.e. infinity
17	17	As a result,
18	18	- None , None -> \]-oo,+oo\[
19	19	- None , Some v -> \]-oo,v\]

22	22	Intervals needs to be explicitly normalised.
23	23	*)
24	24
25		let pp o (n1,n2) =
26		(match n1 with
27		\| None -> output_string o "]-oo"
28		\| Some n -> Printf.fprintf o "[%s" (string_of_num n)
29		);
30		output_string o ",";
31		(match n2 with
32		\| None -> output_string o "+oo["
33		\| Some n -> Printf.fprintf o "%s]" (string_of_num n)
34		)
	25	let pp o (n1, n2) =
	26	( match n1 with
	27	\| None -> output_string o "]-oo"
	28	\| Some n -> Printf.fprintf o "[%s" (string_of_num n) );
	29	output_string o ",";
	30	match n2 with
	31	\| None -> output_string o "+oo["
	32	\| Some n -> Printf.fprintf o "%s]" (string_of_num n)
35	33
36
37
38		(** if then interval [itv] is empty, [norm_itv itv] returns [None]
	34	(** if then interval [itv] is empty, [norm_itv itv] returns [None]
39	35	otherwise, it returns [Some itv] *)
40	36
41		let norm_itv itv =
42		match itv with
43		\| Some a , Some b -> if a <=/ b then Some itv else None
44		\| _ -> Some itv
	37	let norm_itv itv =
	38	match itv with
	39	\| Some a, Some b -> if a <=/ b then Some itv else None
	40	\| _ -> Some itv
45	41
46	42	(** [inter i1 i2 = None] if the intersection of intervals is empty
47	43	[inter i1 i2 = Some i] if [i] is the intersection of the intervals [i1] and [i2] *)
48		let inter i1 i2 =
49		let (l1,r1) = i1
50		and (l2,r2) = i2 in
	44	let inter i1 i2 =
	45	let l1, r1 = i1 and l2, r2 = i2 in
	46	let inter f o1 o2 =
	47	match (o1, o2) with
	48	\| None, None -> None
	49	\| Some _, None -> o1
	50	\| None, Some _ -> o2
	51	\| Some n1, Some n2 -> Some (f n1 n2)
	52	in
	53	norm_itv (inter max_num l1 l2, inter min_num r1 r2)
51	54
52		let inter f o1 o2 =
53		match o1 , o2 with
54		\| None , None -> None
55		\| Some _ , None -> o1
56		\| None , Some _ -> o2
57		\| Some n1 , Some n2 -> Some (f n1 n2) in
	55	let range = function
	56	\| None, _ \| _, None -> None
	57	\| Some i, Some j -> Some (floor_num j -/ ceiling_num i +/ Int 1)
58	58
59		norm_itv (inter max_num l1 l2 , inter min_num r1 r2)
60
61		let range = function
62		\| None,_ \| _,None -> None
63		\| Some i,Some j -> Some (floor_num j -/ceiling_num i +/ (Int 1))
64
65
66		let smaller_itv i1 i2 =
67		match range i1 , range i2 with
68		\| None , _ -> false
69		\| _ , None -> true
70		\| Some i , Some j -> i <=/ j
71
	59	let smaller_itv i1 i2 =
	60	match (range i1, range i2) with
	61	\| None, _ -> false
	62	\| _, None -> true
	63	\| Some i, Some j -> i <=/ j
72	64
73	65	(** [in_bound bnd v] checks whether [v] is within the bounds [bnd] *)
74	66	let in_bound bnd v =
75		let (l,r) = bnd in
76		match l , r with
77		\| None , None -> true
78		\| None , Some a -> v <=/ a
79		\| Some a , None -> a <=/ v
80		\| Some a , Some b -> a <=/ v && v <=/ b
	67	let l, r = bnd in
	68	match (l, r) with
	69	\| None, None -> true
	70	\| None, Some a -> v <=/ a
	71	\| Some a, None -> a <=/ v
	72	\| Some a, Some b -> a <=/ v && v <=/ b

-0

plugins/micromega/itv.mli less more

9	9	open Num
10	10
11	11	type interval = num option * num option
	12
12	13	val pp : out_channel -> interval -> unit
13	14	val inter : interval -> interval -> interval option
14	15	val range : interval -> num option

+509

-545

plugins/micromega/mfourier.ml less more

13	13	open Vect
14	14
15	15	let debug = false
16
17	16	let compare_float (p : float) q = pervasives_compare p q
18	17
	18	open Itv
19	19	(** Implementation of intervals *)
20		open Itv
	20
21	21	type vector = Vect.t
22	22
23	23	(** 'cstr' is the type of constraints.
24	24	{coeffs = v ; bound = (l,r) } models the constraints l <= v <= r
25	25	**)
26	26
27		module ISet = Set.Make(Int)
28
29		module System = Hashtbl.Make(Vect)
30
31		type proof =
32		\| Assum of int
33		\| Elim of var * proof * proof
34		\| And of proof * proof
35
36		type system = {
37		sys : cstr_info ref System.t ;
38		vars : ISet.t
39		}
40		and cstr_info = {
41		bound : interval ;
42		prf : proof ;
43		pos : int ;
44		neg : int ;
45		}
46
	27	module ISet = Set.Make (Int)
	28	module System = Hashtbl.Make (Vect)
	29
	30	type proof = Assum of int \| Elim of var * proof * proof \| And of proof * proof
	31
	32	type system = {sys : cstr_info ref System.t; vars : ISet.t}
	33
	34	and cstr_info = {bound : interval; prf : proof; pos : int; neg : int}
47	35
48	36	(** A system of constraints has the form [\{sys = s ; vars = v\}].
49	37	[s] is a hashtable mapping a normalised vector to a [cstr_info] record where

57	45	[v] is an upper-bound of the set of variables which appear in [s].
58	46	*)
59	47
	48	exception SystemContradiction of proof
60	49	(** To be thrown when a system has no solution *)
61		exception SystemContradiction of proof
62	50
63	51	(** Pretty printing *)
64		let rec pp_proof o prf =
65		match prf with
66		\| Assum i -> Printf.fprintf o "H%i" i
67		\| Elim(v, prf1,prf2) -> Printf.fprintf o "E(%i,%a,%a)" v pp_proof prf1 pp_proof prf2
68		\| And(prf1,prf2) -> Printf.fprintf o "A(%a,%a)" pp_proof prf1 pp_proof prf2
69
70		let pp_cstr o (vect,bnd) =
71		let (l,r) = bnd in
72		(match l with
73		\| None -> ()
74		\| Some n -> Printf.fprintf o "%s <= " (string_of_num n))
75		;
76		Vect.pp o vect ;
77		(match r with
78		\| None -> output_string o"\n"
79		\| Some n -> Printf.fprintf o "<=%s\n" (string_of_num n))
80
81
82		let pp_system o sys=
83		System.iter (fun vect ibnd ->
84		pp_cstr o (vect,(!ibnd).bound)) sys
	52	let rec pp_proof o prf =
	53	match prf with
	54	\| Assum i -> Printf.fprintf o "H%i" i
	55	\| Elim (v, prf1, prf2) ->
	56	Printf.fprintf o "E(%i,%a,%a)" v pp_proof prf1 pp_proof prf2
	57	\| And (prf1, prf2) -> Printf.fprintf o "A(%a,%a)" pp_proof prf1 pp_proof prf2
	58
	59	let pp_cstr o (vect, bnd) =
	60	let l, r = bnd in
	61	( match l with
	62	\| None -> ()
	63	\| Some n -> Printf.fprintf o "%s <= " (string_of_num n) );
	64	Vect.pp o vect;
	65	match r with
	66	\| None -> output_string o "\n"
	67	\| Some n -> Printf.fprintf o "<=%s\n" (string_of_num n)
	68
	69	let pp_system o sys =
	70	System.iter (fun vect ibnd -> pp_cstr o (vect, !ibnd.bound)) sys
85	71
86	72	(** [merge_cstr_info] takes:
87	73	- the intersection of bounds and

89	75	- [pos] and [neg] fields should be identical *)
90	76
91	77	let merge_cstr_info i1 i2 =
92		let { pos = p1 ; neg = n1 ; bound = i1 ; prf = prf1 } = i1
93		and { pos = p2 ; neg = n2 ; bound = i2 ; prf = prf2 } = i2 in
94		assert (Int.equal p1 p2 && Int.equal n1 n2) ;
95		match inter i1 i2 with
96		\| None -> None (* Could directly raise a system contradiction exception *)
97		\| Some bnd ->
98		Some { pos = p1 ; neg = n1 ; bound = bnd ; prf = And(prf1,prf2) }
	78	let {pos = p1; neg = n1; bound = i1; prf = prf1} = i1
	79	and {pos = p2; neg = n2; bound = i2; prf = prf2} = i2 in
	80	assert (Int.equal p1 p2 && Int.equal n1 n2);
	81	match inter i1 i2 with
	82	\| None -> None (* Could directly raise a system contradiction exception *)
	83	\| Some bnd -> Some {pos = p1; neg = n1; bound = bnd; prf = And (prf1, prf2)}
99	84
100	85	(** [xadd_cstr vect cstr_info] loads an constraint into the system.
101	86	The constraint is neither redundant nor contradictory.

103	88	*)
104	89
105	90	let xadd_cstr vect cstr_info sys =
106		try
	91	try
107	92	let info = System.find sys vect in
108		match merge_cstr_info cstr_info !info with
109		\| None -> raise (SystemContradiction (And(cstr_info.prf, (!info).prf)))
110		\| Some info' -> info := info'
111		with
112		\| Not_found -> System.replace sys vect (ref cstr_info)
	93	match merge_cstr_info cstr_info !info with
	94	\| None -> raise (SystemContradiction (And (cstr_info.prf, !info.prf)))
	95	\| Some info' -> info := info'
	96	with Not_found -> System.replace sys vect (ref cstr_info)
113	97
114	98	exception TimeOut
115	99
116	100	let xadd_cstr vect cstr_info sys =
117		if debug && Int.equal (System.length sys mod 1000) 0 then (print_string "*" ; flush stdout) ;
118		if System.length sys < !max_nb_cstr
119		then xadd_cstr vect cstr_info sys
120		else raise TimeOut
	101	if debug && Int.equal (System.length sys mod 1000) 0 then (
	102	print_string "*"; flush stdout );
	103	if System.length sys < !max_nb_cstr then xadd_cstr vect cstr_info sys
	104	else raise TimeOut
121	105
122	106	type cstr_ext =
123		\| Contradiction (** The constraint is contradictory.
	107	\| Contradiction
	108	(** The constraint is contradictory.
124	109	Typically, a [SystemContradiction] exception will be raised. *)
125		\| Redundant (** The constrain is redundant.
	110	\| Redundant
	111	(** The constrain is redundant.
126	112	Typically, the constraint will be dropped *)
127		\| Cstr of vector * cstr_info (** Taken alone, the constraint is neither contradictory nor redundant.
	113	\| Cstr of vector * cstr_info
	114	(** Taken alone, the constraint is neither contradictory nor redundant.
128	115	Typically, it will be added to the constraint system. *)
129	116
130	117	(** [normalise_cstr] : vector -> cstr_info -> cstr_ext *)
131	118	let normalise_cstr vect cinfo =
132	119	match norm_itv cinfo.bound with
133		\| None -> Contradiction
134		\| Some (l,r) ->
135		match Vect.choose vect with
136		\| None -> if Itv.in_bound (l,r) (Int 0) then Redundant else Contradiction
137		\| Some (_,n,_) -> Cstr(Vect.div n vect,
138		let divn x = x // n in
139		if Int.equal (sign_num n) 1
140		then{cinfo with bound = (Option.map divn l , Option.map divn r) }
141		else {cinfo with pos = cinfo.neg ; neg = cinfo.pos ; bound = (Option.map divn r , Option.map divn l)})
142
	120	\| None -> Contradiction
	121	\| Some (l, r) -> (
	122	match Vect.choose vect with
	123	\| None -> if Itv.in_bound (l, r) (Int 0) then Redundant else Contradiction
	124	\| Some (_, n, _) ->
	125	Cstr
	126	( Vect.div n vect
	127	, let divn x = x // n in
	128	if Int.equal (sign_num n) 1 then
	129	{cinfo with bound = (Option.map divn l, Option.map divn r)}
	130	else
	131	{ cinfo with
	132	pos = cinfo.neg
	133	; neg = cinfo.pos
	134	; bound = (Option.map divn r, Option.map divn l) } ) )
143	135
144	136	(** For compatibility, there is an external representation of constraints *)
145	137
146
147	138	let count v =
148		Vect.fold (fun (n,p) _ vl ->
	139	Vect.fold
	140	(fun (n, p) _ vl ->
149	141	let sg = sign_num vl in
150		assert (sg <> 0) ;
151		if Int.equal sg 1 then (n,p+1)else (n+1, p)) (0,0) v
152
153
154		let norm_cstr {coeffs = v ; op = o ; cst = c} idx =
155		let (n,p) = count v in
156
157		normalise_cstr v {pos = p ; neg = n ; bound =
158		(match o with
159		\| Eq -> Some c , Some c
160		\| Ge -> Some c , None
161		\| Gt -> raise Polynomial.Strict
162		) ;
163		prf = Assum idx }
164
	142	assert (sg <> 0);
	143	if Int.equal sg 1 then (n, p + 1) else (n + 1, p))
	144	(0, 0) v
	145
	146	let norm_cstr {coeffs = v; op = o; cst = c} idx =
	147	let n, p = count v in
	148	normalise_cstr v
	149	{ pos = p
	150	; neg = n
	151	; bound =
	152	( match o with
	153	\| Eq -> (Some c, Some c)
	154	\| Ge -> (Some c, None)
	155	\| Gt -> raise Polynomial.Strict )
	156	; prf = Assum idx }
165	157
166	158	(** [load_system l] takes a list of constraints of type [cstr_compat]
167	159	@return a system of constraints
168	160	@raise SystemContradiction if a contradiction is found
169	161	*)
170	162	let load_system l =
171
172	163	let sys = System.create 1000 in
173
174		let li = List.mapi (fun i e -> (e,i)) l in
175
176		let vars = List.fold_left (fun vrs (cstr,i) ->
177		match norm_cstr cstr i with
178		\| Contradiction -> raise (SystemContradiction (Assum i))
179		\| Redundant -> vrs
180		\| Cstr(vect,info) ->
181		xadd_cstr vect info sys ;
182		Vect.fold (fun s v _ -> ISet.add v s) vrs cstr.coeffs) ISet.empty li in
183
184		{sys = sys ;vars = vars}
	164	let li = List.mapi (fun i e -> (e, i)) l in
	165	let vars =
	166	List.fold_left
	167	(fun vrs (cstr, i) ->
	168	match norm_cstr cstr i with
	169	\| Contradiction -> raise (SystemContradiction (Assum i))
	170	\| Redundant -> vrs
	171	\| Cstr (vect, info) ->
	172	xadd_cstr vect info sys;
	173	Vect.fold (fun s v _ -> ISet.add v s) vrs cstr.coeffs)
	174	ISet.empty li
	175	in
	176	{sys; vars}
185	177
186	178	let system_list sys =
187		let { sys = s ; vars = v } = sys in
188		System.fold (fun k bi l -> (k, !bi)::l) s []
189
	179	let {sys = s; vars = v} = sys in
	180	System.fold (fun k bi l -> (k, !bi) :: l) s []
190	181
191	182	(** [add (v1,c1) (v2,c2) ]
192	183	precondition: (c1 <>/ Int 0 && c2 <>/ Int 0)

195	186	Note that the resulting vector is not normalised.
196	187	*)
197	188
198		let add (v1,c1) (v2,c2) =
199		assert (c1 <>/ Int 0 && c2 <>/ Int 0) ;
200		let res = mul_add (Int 1 // c1) v1 (Int 1 // c2) v2 in
201		(res, count res)
202
203		let add (v1,c1) (v2,c2) =
204		let res = add (v1,c1) (v2,c2) in
205		(* Printf.printf "add(%a,%s,%a,%s) -> %a\n" pp_vect v1 (string_of_num c1) pp_vect v2 (string_of_num c2) pp_vect (fst res) ;*)
206		res
	189	let add (v1, c1) (v2, c2) =
	190	assert (c1 <>/ Int 0 && c2 <>/ Int 0);
	191	let res = mul_add (Int 1 // c1) v1 (Int 1 // c2) v2 in
	192	(res, count res)
	193
	194	let add (v1, c1) (v2, c2) =
	195	let res = add (v1, c1) (v2, c2) in
	196	(* Printf.printf "add(%a,%s,%a,%s) -> %a\n" pp_vect v1 (string_of_num c1) pp_vect v2 (string_of_num c2) pp_vect (fst res) ;*)
	197	res
207	198
208	199	(** To perform Fourier elimination, constraints are categorised depending on the sign of the variable to eliminate. *)
209	200

214	205	@param m contains constraints which do not mention [x]
215	206	*)
216	207
217		let split x (vect: vector) info (l,m,r) =
218		match get x vect with
219		\| Int 0 -> (* The constraint does not mention [x], store it in m *)
220		(l,(vect,info)::m,r)
221		\| vl -> (* otherwise *)
222
223		let cons_bound lst bd =
224		match bd with
225		\| None -> lst
226		\| Some bnd -> (vl,vect,{info with bound = Some bnd,None})::lst in
227
228		let lb,rb = info.bound in
229		if Int.equal (sign_num vl) 1
230		then (cons_bound l lb,m,cons_bound r rb)
231		else (* sign_num vl = -1 *)
232		(cons_bound l rb,m,cons_bound r lb)
233
	208	let split x (vect : vector) info (l, m, r) =
	209	match get x vect with
	210	\| Int 0 ->
	211	(* The constraint does not mention [x], store it in m *)
	212	(l, (vect, info) :: m, r)
	213	\| vl ->
	214	(* otherwise *)
	215	let cons_bound lst bd =
	216	match bd with
	217	\| None -> lst
	218	\| Some bnd -> (vl, vect, {info with bound = (Some bnd, None)}) :: lst
	219	in
	220	let lb, rb = info.bound in
	221	if Int.equal (sign_num vl) 1 then (cons_bound l lb, m, cons_bound r rb)
	222	else (* sign_num vl = -1 *)
	223	(cons_bound l rb, m, cons_bound r lb)
234	224
235	225	(** [project vr sys] projects system [sys] over the set of variables [ISet.remove vr sys.vars ].
236	226	This is a one step Fourier elimination.
237	227	*)
238	228	let project vr sys =
239
240		let (l,m,r) = System.fold (fun vect rf l_m_r -> split vr vect !rf l_m_r) sys.sys ([],[],[]) in
241
	229	let l, m, r =
	230	System.fold
	231	(fun vect rf l_m_r -> split vr vect !rf l_m_r)
	232	sys.sys ([], [], [])
	233	in
242	234	let new_sys = System.create (System.length sys.sys) in
243
244		(* Constraints in [m] belong to the projection - for those [vr] is already projected out *)
245		List.iter (fun (vect,info) -> System.replace new_sys vect (ref info) ) m ;
246
247		let elim (v1,vect1,info1) (v2,vect2,info2) =
248		let {neg = n1 ; pos = p1 ; bound = bound1 ; prf = prf1} = info1
249		and {neg = n2 ; pos = p2 ; bound = bound2 ; prf = prf2} = info2 in
250
251		let bnd1 = Option.get (fst bound1)
252		and bnd2 = Option.get (fst bound2) in
253		let bound = (bnd1 // v1) +/ (bnd2 // minus_num v2) in
254		let vres,(n,p) = add (vect1,v1) (vect2,minus_num v2) in
255		(vres,{neg = n ; pos = p ; bound = (Some bound, None); prf = Elim(vr,info1.prf,info2.prf)}) in
256
257		List.iter(fun l_elem -> List.iter (fun r_elem ->
258		let (vect,info) = elim l_elem r_elem in
	235	(* Constraints in [m] belong to the projection - for those [vr] is already projected out *)
	236	List.iter (fun (vect, info) -> System.replace new_sys vect (ref info)) m;
	237	let elim (v1, vect1, info1) (v2, vect2, info2) =
	238	let {neg = n1; pos = p1; bound = bound1; prf = prf1} = info1
	239	and {neg = n2; pos = p2; bound = bound2; prf = prf2} = info2 in
	240	let bnd1 = Option.get (fst bound1) and bnd2 = Option.get (fst bound2) in
	241	let bound = (bnd1 // v1) +/ (bnd2 // minus_num v2) in
	242	let vres, (n, p) = add (vect1, v1) (vect2, minus_num v2) in
	243	( vres
	244	, { neg = n
	245	; pos = p
	246	; bound = (Some bound, None)
	247	; prf = Elim (vr, info1.prf, info2.prf) } )
	248	in
	249	List.iter
	250	(fun l_elem ->
	251	List.iter
	252	(fun r_elem ->
	253	let vect, info = elim l_elem r_elem in
259	254	match normalise_cstr vect info with
260		\| Redundant -> ()
261		\| Contradiction -> raise (SystemContradiction info.prf)
262		\| Cstr(vect,info) -> xadd_cstr vect info new_sys) r ) l;
263		{sys = new_sys ; vars = ISet.remove vr sys.vars}
264
	255	\| Redundant -> ()
	256	\| Contradiction -> raise (SystemContradiction info.prf)
	257	\| Cstr (vect, info) -> xadd_cstr vect info new_sys)
	258	r)
	259	l;
	260	{sys = new_sys; vars = ISet.remove vr sys.vars}
265	261
266	262	(** [project_using_eq] performs elimination by pivoting using an equation.
267	263	This is the counter_part of the [elim] sub-function of [!project].

272	268	@param prf is the proof of the equation
273	269	*)
274	270
275		let project_using_eq vr c vect bound prf (vect',info') =
276		match get vr vect' with
277		\| Int 0 -> (vect',info')
278		\| c2 ->
279		let c1 = if c2 >=/ Int 0 then minus_num c else c in
280
281		let c2 = abs_num c2 in
282
283		let (vres,(n,p)) = add (vect,c1) (vect', c2) in
284
285		let cst = bound // c1 in
286
287		let bndres =
288		let f x = cst +/ x // c2 in
289		let (l,r) = info'.bound in
290		(Option.map f l , Option.map f r) in
291
292		(vres,{neg = n ; pos = p ; bound = bndres ; prf = Elim(vr,prf,info'.prf)})
293
294
295		let elim_var_using_eq vr vect cst prf sys =
	271	let project_using_eq vr c vect bound prf (vect', info') =
	272	match get vr vect' with
	273	\| Int 0 -> (vect', info')
	274	\| c2 ->
	275	let c1 = if c2 >=/ Int 0 then minus_num c else c in
	276	let c2 = abs_num c2 in
	277	let vres, (n, p) = add (vect, c1) (vect', c2) in
	278	let cst = bound // c1 in
	279	let bndres =
	280	let f x = cst +/ (x // c2) in
	281	let l, r = info'.bound in
	282	(Option.map f l, Option.map f r)
	283	in
	284	(vres, {neg = n; pos = p; bound = bndres; prf = Elim (vr, prf, info'.prf)})
	285
	286	let elim_var_using_eq vr vect cst prf sys =
296	287	let c = get vr vect in
297
298		let elim_var = project_using_eq vr c vect cst prf in
299
300		let new_sys = System.create (System.length sys.sys) in
301
302		System.iter(fun vect iref ->
303		let (vect',info') = elim_var (vect,!iref) in
304		match normalise_cstr vect' info' with
305		\| Redundant -> ()
306		\| Contradiction -> raise (SystemContradiction info'.prf)
307		\| Cstr(vect,info') -> xadd_cstr vect info' new_sys) sys.sys ;
308
309		{sys = new_sys ; vars = ISet.remove vr sys.vars}
310
	288	let elim_var = project_using_eq vr c vect cst prf in
	289	let new_sys = System.create (System.length sys.sys) in
	290	System.iter
	291	(fun vect iref ->
	292	let vect', info' = elim_var (vect, !iref) in
	293	match normalise_cstr vect' info' with
	294	\| Redundant -> ()
	295	\| Contradiction -> raise (SystemContradiction info'.prf)
	296	\| Cstr (vect, info') -> xadd_cstr vect info' new_sys)
	297	sys.sys;
	298	{sys = new_sys; vars = ISet.remove vr sys.vars}
311	299
312	300	(** [size sys] computes the number of entries in the system of constraints *)
313		let size sys = System.fold (fun v iref s -> s + (!iref).neg + (!iref).pos) sys 0
314
315		module IMap = CMap.Make(Int)
	301	let size sys = System.fold (fun v iref s -> s + !iref.neg + !iref.pos) sys 0
	302
	303	module IMap = CMap.Make (Int)
316	304
317	305	(** [eval_vect map vect] evaluates vector [vect] using the values of [map].
318	306	If [map] binds all the variables of [vect], we get
319	307	[eval_vect map [(x1,v1);...;(xn,vn)] = (IMap.find x1 map * v1) + ... + (IMap.find xn map) * vn , []]
320	308	The function returns as second argument, a sub-vector consisting in the variables that are not in [map]. *)
321	309
322		let eval_vect map vect =
323		Vect.fold (fun (sum,rst) v vl ->
	310	let eval_vect map vect =
	311	Vect.fold
	312	(fun (sum, rst) v vl ->
324	313	try
325	314	let val_v = IMap.find v map in
326	315	(sum +/ (val_v */ vl), rst)
327		with
328		Not_found -> (sum, Vect.set v vl rst)) (Int 0,Vect.null) vect
329
330
	316	with Not_found -> (sum, Vect.set v vl rst))
	317	(Int 0, Vect.null) vect
331	318
332	319	(** [restrict_bound n sum itv] returns the interval of [x]
333	320	given that (fst itv) <= x * n + sum <= (snd itv) *)
334		let restrict_bound n sum (itv:interval) =
335		let f x = (x -/ sum) // n in
336		let l,r = itv in
337		match sign_num n with
338		\| 0 -> if in_bound itv sum
339		then (None,None) (* redundant *)
340		else failwith "SystemContradiction"
341		\| 1 -> Option.map f l , Option.map f r
342		\| _ -> Option.map f r , Option.map f l
343
	321	let restrict_bound n sum (itv : interval) =
	322	let f x = (x -/ sum) // n in
	323	let l, r = itv in
	324	match sign_num n with
	325	\| 0 ->
	326	if in_bound itv sum then (None, None) (* redundant *)
	327	else failwith "SystemContradiction"
	328	\| 1 -> (Option.map f l, Option.map f r)
	329	\| _ -> (Option.map f r, Option.map f l)
344	330
345	331	(** [bound_of_variable map v sys] computes the interval of [v] in
346	332	[sys] given a mapping [map] binding all the other variables *)
347	333	let bound_of_variable map v sys =
348		System.fold (fun vect iref bnd ->
349		let sum,rst = eval_vect map vect in
350		let vl = Vect.get v rst in
351		match inter bnd (restrict_bound vl sum (!iref).bound) with
	334	System.fold
	335	(fun vect iref bnd ->
	336	let sum, rst = eval_vect map vect in
	337	let vl = Vect.get v rst in
	338	match inter bnd (restrict_bound vl sum !iref.bound) with
352	339	\| None ->
353		Printf.fprintf stdout "bound_of_variable: eval_vecr %a = %s,%a\n"
354		Vect.pp vect (Num.string_of_num sum) Vect.pp rst ;
355		Printf.fprintf stdout "current interval: %a\n" Itv.pp (!iref).bound;
356		failwith "bound_of_variable: impossible"
357		\| Some itv -> itv) sys (None,None)
358
	340	Printf.fprintf stdout "bound_of_variable: eval_vecr %a = %s,%a\n"
	341	Vect.pp vect (Num.string_of_num sum) Vect.pp rst;
	342	Printf.fprintf stdout "current interval: %a\n" Itv.pp !iref.bound;
	343	failwith "bound_of_variable: impossible"
	344	\| Some itv -> itv)
	345	sys (None, None)
359	346
360	347	(** [pick_small_value bnd] picks a value being closed to zero within the interval *)
361	348	let pick_small_value bnd =
362	349	match bnd with
363		\| None , None -> Int 0
364		\| None , Some i -> if (Int 0) <=/ (floor_num i) then Int 0 else floor_num i
365		\| Some i,None -> if i <=/ (Int 0) then Int 0 else ceiling_num i
366		\| Some i,Some j ->
367		if i <=/ Int 0 && Int 0 <=/ j
368		then Int 0
369		else if ceiling_num i <=/ floor_num j
370		then ceiling_num i (* why not *) else i
371
	350	\| None, None -> Int 0
	351	\| None, Some i -> if Int 0 <=/ floor_num i then Int 0 else floor_num i
	352	\| Some i, None -> if i <=/ Int 0 then Int 0 else ceiling_num i
	353	\| Some i, Some j ->
	354	if i <=/ Int 0 && Int 0 <=/ j then Int 0
	355	else if ceiling_num i <=/ floor_num j then ceiling_num i (* why not *)
	356	else i
372	357
373	358	(** [solution s1 sys_l = Some(sn,\[(vn-1,sn-1);...; (v1,s1)\]\@sys_l)]
374	359	then [sn] is a system which contains only [black_v] -- if it existed in [s1]

377	362	*)
378	363
379	364	let solve_sys black_v choose_eq choose_variable sys sys_l =
380
381	365	let rec solve_sys sys sys_l =
382		if debug then Printf.printf "S #%i size %i\n" (System.length sys.sys) (size sys.sys);
383		if debug then Printf.printf "solve_sys :\n %a" pp_system sys.sys ;
384
	366	if debug then
	367	Printf.printf "S #%i size %i\n" (System.length sys.sys) (size sys.sys);
	368	if debug then Printf.printf "solve_sys :\n %a" pp_system sys.sys;
385	369	let eqs = choose_eq sys in
	370	try
	371	let v, vect, cst, ln =
	372	fst (List.find (fun ((v, _, _, _), _) -> v <> black_v) eqs)
	373	in
	374	if debug then (
	375	Printf.printf "\nE %a = %s variable %i\n" Vect.pp vect
	376	(string_of_num cst) v;
	377	flush stdout );
	378	let sys' = elim_var_using_eq v vect cst ln sys in
	379	solve_sys sys' ((v, sys) :: sys_l)
	380	with Not_found -> (
	381	let vars = choose_variable sys in
386	382	try
387		let (v,vect,cst,ln) = fst (List.find (fun ((v,_,_,_),_) -> v <> black_v) eqs) in
388		if debug then
389		(Printf.printf "\nE %a = %s variable %i\n" Vect.pp vect (string_of_num cst) v ;
390		flush stdout);
391		let sys' = elim_var_using_eq v vect cst ln sys in
392		solve_sys sys' ((v,sys)::sys_l)
393		with Not_found ->
394		let vars = choose_variable sys in
395		try
396		let (v,est) = (List.find (fun (v,_) -> v <> black_v) vars) in
397		if debug then (Printf.printf "\nV : %i estimate %f\n" v est ; flush stdout) ;
398		let sys' = project v sys in
399		solve_sys sys' ((v,sys)::sys_l)
400		with Not_found -> (* we are done *) Inl (sys,sys_l) in
401		solve_sys sys sys_l
402
403
404
405
406		let solve black_v choose_eq choose_variable cstrs =
407
	383	let v, est = List.find (fun (v, _) -> v <> black_v) vars in
	384	if debug then (
	385	Printf.printf "\nV : %i estimate %f\n" v est;
	386	flush stdout );
	387	let sys' = project v sys in
	388	solve_sys sys' ((v, sys) :: sys_l)
	389	with Not_found -> (* we are done *) Inl (sys, sys_l) )
	390	in
	391	solve_sys sys sys_l
	392
	393	let solve black_v choose_eq choose_variable cstrs =
408	394	try
409	395	let sys = load_system cstrs in
410		if debug then Printf.printf "solve :\n %a" pp_system sys.sys ;
411		solve_sys black_v choose_eq choose_variable sys []
	396	if debug then Printf.printf "solve :\n %a" pp_system sys.sys;
	397	solve_sys black_v choose_eq choose_variable sys []
412	398	with SystemContradiction prf -> Inr prf
413
414	399
415	400	(** The purpose of module [EstimateElimVar] is to try to estimate the cost of eliminating a variable.
416	401	The output is an ordered list of (variable,cost).
417	402	*)
418	403
419		module EstimateElimVar =
420		struct
	404	module EstimateElimVar = struct
421	405	type sys_list = (vector * cstr_info) list
422	406
423		let abstract_partition (v:int) (l: sys_list) =
424
425		let rec xpart (l:sys_list) (ltl:sys_list) (n:int list) (z:int) (p:int list) =
	407	let abstract_partition (v : int) (l : sys_list) =
	408	let rec xpart (l : sys_list) (ltl : sys_list) (n : int list) (z : int)
	409	(p : int list) =
426	410	match l with
427		\| [] -> (ltl, n,z,p)
428		\| (l1,info) ::rl ->
429		match Vect.choose l1 with
430		\| None -> xpart rl ((Vect.null,info)::ltl) n (info.neg+info.pos+z) p
431		\| Some(vr, vl, rl1) ->
432		if Int.equal v vr
433		then
434		let cons_bound lst bd =
435		match bd with
436		\| None -> lst
437		\| Some bnd -> info.neg+info.pos::lst in
438
439		let lb,rb = info.bound in
440		if Int.equal (sign_num vl) 1
441		then xpart rl ((rl1,info)::ltl) (cons_bound n lb) z (cons_bound p rb)
442		else xpart rl ((rl1,info)::ltl) (cons_bound n rb) z (cons_bound p lb)
443		else
444		(* the variable is greater *)
445		xpart rl ((l1,info)::ltl) n (info.neg+info.pos+z) p
446
447		in
448		let (sys',n,z,p) = xpart l [] [] 0 [] in
449
	411	\| [] -> (ltl, n, z, p)
	412	\| (l1, info) :: rl -> (
	413	match Vect.choose l1 with
	414	\| None ->
	415	xpart rl ((Vect.null, info) :: ltl) n (info.neg + info.pos + z) p
	416	\| Some (vr, vl, rl1) ->
	417	if Int.equal v vr then
	418	let cons_bound lst bd =
	419	match bd with
	420	\| None -> lst
	421	\| Some bnd -> (info.neg + info.pos) :: lst
	422	in
	423	let lb, rb = info.bound in
	424	if Int.equal (sign_num vl) 1 then
	425	xpart rl ((rl1, info) :: ltl) (cons_bound n lb) z
	426	(cons_bound p rb)
	427	else
	428	xpart rl ((rl1, info) :: ltl) (cons_bound n rb) z
	429	(cons_bound p lb)
	430	else
	431	(* the variable is greater *)
	432	xpart rl ((l1, info) :: ltl) n (info.neg + info.pos + z) p )
	433	in
	434	let sys', n, z, p = xpart l [] [] 0 [] in
450	435	let ln = float_of_int (List.length n) in
451		let sn = float_of_int (List.fold_left (+) 0 n) in
	436	let sn = float_of_int (List.fold_left ( + ) 0 n) in
452	437	let lp = float_of_int (List.length p) in
453		let sp = float_of_int (List.fold_left (+) 0 p) in
454		(sys', float_of_int z +. lp . sn +. ln . sp -. lp*.ln)
455
456
457		let choose_variable sys =
458		let {sys = s ; vars = v} = sys in
459
	438	let sp = float_of_int (List.fold_left ( + ) 0 p) in
	439	(sys', float_of_int z +. (lp . sn) +. (ln . sp) -. (lp *. ln))
	440
	441	let choose_variable sys =
	442	let {sys = s; vars = v} = sys in
460	443	let sl = system_list sys in
461
462		let evals = fst
463		(ISet.fold (fun v (eval,s) -> let ts,vl = abstract_partition v s in
464		((v,vl)::eval, ts)) v ([],sl)) in
465
466		List.sort (fun x y -> compare_float (snd x) (snd y) ) evals
467
468
	444	let evals =
	445	fst
	446	(ISet.fold
	447	(fun v (eval, s) ->
	448	let ts, vl = abstract_partition v s in
	449	((v, vl) :: eval, ts))
	450	v ([], sl))
	451	in
	452	List.sort (fun x y -> compare_float (snd x) (snd y)) evals
469	453	end
	454
470	455	open EstimateElimVar
471	456
472	457	(** The module [EstimateElimEq] is similar to [EstimateElimVar] but it orders equations.
473	458	*)
474		module EstimateElimEq =
475		struct
476
477		let itv_point bnd =
478		match bnd with
479		\|(Some a, Some b) -> a =/ b
480		\| _ -> false
	459	module EstimateElimEq = struct
	460	let itv_point bnd = match bnd with Some a, Some b -> a =/ b \| _ -> false
481	461
482	462	let rec unroll_until v l =
483	463	match Vect.choose l with
484		\| None -> (false,Vect.null)
485		\| Some(i,_,rl) -> if Int.equal i v
486		then (true,rl)
487		else if i < v then unroll_until v rl else (false,l)
488
489
	464	\| None -> (false, Vect.null)
	465	\| Some (i, _, rl) ->
	466	if Int.equal i v then (true, rl)
	467	else if i < v then unroll_until v rl
	468	else (false, l)
490	469
491	470	let rec choose_simple_equation eqs =
492	471	match eqs with
493		\| [] -> None
494		\| (vect,a,prf,ln)::eqs ->
495		match Vect.choose vect with
496		\| Some(i,v,rst) -> if Vect.is_null rst
497		then Some (i,vect,a,prf,ln)
498		else choose_simple_equation eqs
499		\| _ -> choose_simple_equation eqs
500
501
502		let choose_primal_equation eqs (sys_l: (Vect.t *cstr_info) list) =
503
	472	\| [] -> None
	473	\| (vect, a, prf, ln) :: eqs -> (
	474	match Vect.choose vect with
	475	\| Some (i, v, rst) ->
	476	if Vect.is_null rst then Some (i, vect, a, prf, ln)
	477	else choose_simple_equation eqs
	478	\| _ -> choose_simple_equation eqs )
	479
	480	let choose_primal_equation eqs (sys_l : (Vect.t * cstr_info) list) =
504	481	(* Counts the number of equations referring to variable [v] --
505	482	It looks like nb_cst is dead...
506	483	*)
507	484	let is_primal_equation_var v =
508		List.fold_left (fun nb_eq (vect,info) ->
509		if fst (unroll_until v vect)
510		then if itv_point info.bound then nb_eq + 1 else nb_eq
511		else nb_eq) 0 sys_l in
512
	485	List.fold_left
	486	(fun nb_eq (vect, info) ->
	487	if fst (unroll_until v vect) then
	488	if itv_point info.bound then nb_eq + 1 else nb_eq
	489	else nb_eq)
	490	0 sys_l
	491	in
513	492	let rec find_var vect =
514	493	match Vect.choose vect with
515		\| None -> None
516		\| Some(i,_,vect) ->
517		let nb_eq = is_primal_equation_var i in
518		if Int.equal nb_eq 2
519		then Some i else find_var vect in
520
	494	\| None -> None
	495	\| Some (i, _, vect) ->
	496	let nb_eq = is_primal_equation_var i in
	497	if Int.equal nb_eq 2 then Some i else find_var vect
	498	in
521	499	let rec find_eq_var eqs =
522	500	match eqs with
523		\| [] -> None
524		\| (vect,a,prf,ln)::l ->
525		match find_var vect with
526		\| None -> find_eq_var l
527		\| Some r -> Some (r,vect,a,prf,ln)
528		in
529		match choose_simple_equation eqs with
530		\| None -> find_eq_var eqs
531		\| Some res -> Some res
532
533
534
535		let choose_equality_var sys =
536
	501	\| [] -> None
	502	\| (vect, a, prf, ln) :: l -> (
	503	match find_var vect with
	504	\| None -> find_eq_var l
	505	\| Some r -> Some (r, vect, a, prf, ln) )
	506	in
	507	match choose_simple_equation eqs with
	508	\| None -> find_eq_var eqs
	509	\| Some res -> Some res
	510
	511	let choose_equality_var sys =
537	512	let sys_l = system_list sys in
538
539		let equalities = List.fold_left
540		(fun l (vect,info) ->
541		match info.bound with
542		\| Some a , Some b ->
543		if a =/ b then (* This an equation *)
544		(vect,a,info.prf,info.neg+info.pos)::l else l
545		\| _ -> l
546		) [] sys_l in
547
	513	let equalities =
	514	List.fold_left
	515	(fun l (vect, info) ->
	516	match info.bound with
	517	\| Some a, Some b ->
	518	if a =/ b then
	519	(* This an equation *)
	520	(vect, a, info.prf, info.neg + info.pos) :: l
	521	else l
	522	\| _ -> l)
	523	[] sys_l
	524	in
548	525	let rec estimate_cost v ct sysl acc tlsys =
549	526	match sysl with
550		\| [] -> (acc,tlsys)
551		\| (l,info)::rsys ->
552		let ln = info.pos + info.neg in
553		let (b,l) = unroll_until v l in
554		match b with
555		\| true ->
556		if itv_point info.bound
557		then estimate_cost v ct rsys (acc+ln) ((l,info)::tlsys) (* this is free *)
558		else estimate_cost v ct rsys (acc+ln+ct) ((l,info)::tlsys) (* should be more ? *)
559		\| false -> estimate_cost v ct rsys (acc+ln) ((l,info)::tlsys) in
560
561		match choose_primal_equation equalities sys_l with
562		\| None ->
563		let cost_eq eq const prf ln acc_costs =
564
565		let rec cost_eq eqr sysl costs =
566		match Vect.choose eqr with
567		\| None -> costs
568		\| Some(v,_,eqr) -> let (cst,tlsys) = estimate_cost v (ln-1) sysl 0 [] in
569		cost_eq eqr tlsys (((v,eq,const,prf),cst)::costs) in
570		cost_eq eq sys_l acc_costs in
571
572		let all_costs = List.fold_left (fun all_costs (vect,const,prf,ln) -> cost_eq vect const prf ln all_costs) [] equalities in
573
574		(* pp_list (fun o ((v,eq,_,_),cst) -> Printf.fprintf o "((%i,%a),%i)\n" v pp_vect eq cst) stdout all_costs ; *)
575
576		List.sort (fun x y -> Int.compare (snd x) (snd y) ) all_costs
577		\| Some (v,vect, const,prf,_) -> [(v,vect,const,prf),0]
578
579
	527	\| [] -> (acc, tlsys)
	528	\| (l, info) :: rsys -> (
	529	let ln = info.pos + info.neg in
	530	let b, l = unroll_until v l in
	531	match b with
	532	\| true ->
	533	if itv_point info.bound then
	534	estimate_cost v ct rsys (acc + ln) ((l, info) :: tlsys)
	535	(* this is free *)
	536	else estimate_cost v ct rsys (acc + ln + ct) ((l, info) :: tlsys)
	537	(* should be more ? *)
	538	\| false -> estimate_cost v ct rsys (acc + ln) ((l, info) :: tlsys) )
	539	in
	540	match choose_primal_equation equalities sys_l with
	541	\| None ->
	542	let cost_eq eq const prf ln acc_costs =
	543	let rec cost_eq eqr sysl costs =
	544	match Vect.choose eqr with
	545	\| None -> costs
	546	\| Some (v, _, eqr) ->
	547	let cst, tlsys = estimate_cost v (ln - 1) sysl 0 [] in
	548	cost_eq eqr tlsys (((v, eq, const, prf), cst) :: costs)
	549	in
	550	cost_eq eq sys_l acc_costs
	551	in
	552	let all_costs =
	553	List.fold_left
	554	(fun all_costs (vect, const, prf, ln) ->
	555	cost_eq vect const prf ln all_costs)
	556	[] equalities
	557	in
	558	(* pp_list (fun o ((v,eq,_,_),cst) -> Printf.fprintf o "((%i,%a),%i)\n" v pp_vect eq cst) stdout all_costs ; *)
	559	List.sort (fun x y -> Int.compare (snd x) (snd y)) all_costs
	560	\| Some (v, vect, const, prf, _) -> [((v, vect, const, prf), 0)]
580	561	end
	562
581	563	open EstimateElimEq
582	564
583		module Fourier =
584		struct
585
	565	module Fourier = struct
586	566	let optimise vect l =
587	567	(* We add a dummy (fresh) variable for vector *)
588		let fresh =
589		List.fold_left (fun fr c -> max fr (Vect.fresh c.coeffs)) 0 l in
590		let cstr = {
591		coeffs = Vect.set fresh (Int (-1)) vect ;
592		op = Eq ;
593		cst = (Int 0)} in
594		match solve fresh choose_equality_var choose_variable (cstr::l) with
595		\| Inr prf -> None (* This is an unsatisfiability proof *)
596		\| Inl (s,_) ->
597		try
598		Some (bound_of_variable IMap.empty fresh s.sys)
599		with x when CErrors.noncritical x ->
600		Printf.printf "optimise Exception : %s" (Printexc.to_string x);
601		None
602
	568	let fresh = List.fold_left (fun fr c -> max fr (Vect.fresh c.coeffs)) 0 l in
	569	let cstr =
	570	{coeffs = Vect.set fresh (Int (-1)) vect; op = Eq; cst = Int 0}
	571	in
	572	match solve fresh choose_equality_var choose_variable (cstr :: l) with
	573	\| Inr prf -> None (* This is an unsatisfiability proof *)
	574	\| Inl (s, _) -> (
	575	try Some (bound_of_variable IMap.empty fresh s.sys)
	576	with x when CErrors.noncritical x ->
	577	Printf.printf "optimise Exception : %s" (Printexc.to_string x);
	578	None )
603	579
604	580	let find_point cstrs =
605
606	581	match solve max_int choose_equality_var choose_variable cstrs with
607		\| Inr prf -> Inr prf
608		\| Inl (_,l) ->
609
610		let rec rebuild_solution l map =
611		match l with
612		\| [] -> map
613		\| (v,e)::l ->
614		let itv = bound_of_variable map v e.sys in
615		let map = IMap.add v (pick_small_value itv) map in
616		rebuild_solution l map
617		in
618
619		let map = rebuild_solution l IMap.empty in
620		let vect = IMap.fold (fun v i vect -> Vect.set v i vect) map Vect.null in
621		if debug then Printf.printf "SOLUTION %a" Vect.pp vect ;
622		let res = Inl vect in
623		res
624
625
	582	\| Inr prf -> Inr prf
	583	\| Inl (_, l) ->
	584	let rec rebuild_solution l map =
	585	match l with
	586	\| [] -> map
	587	\| (v, e) :: l ->
	588	let itv = bound_of_variable map v e.sys in
	589	let map = IMap.add v (pick_small_value itv) map in
	590	rebuild_solution l map
	591	in
	592	let map = rebuild_solution l IMap.empty in
	593	let vect = IMap.fold (fun v i vect -> Vect.set v i vect) map Vect.null in
	594	if debug then Printf.printf "SOLUTION %a" Vect.pp vect;
	595	let res = Inl vect in
	596	res
626	597	end
627	598
628
629		module Proof =
630		struct
631
632
633
634
635		(** A proof term in the sense of a ZMicromega.RatProof is a positive combination of the hypotheses which leads to a contradiction.
	599	module Proof = struct
	600	(** A proof term in the sense of a ZMicromega.RatProof is a positive combination of the hypotheses which leads to a contradiction.
636	601	The proofs constructed by Fourier elimination are more like execution traces:
637	602	- certain facts are recorded but are useless
638	603	- certain inferences are implicit.

640	605	*)
641	606	let add x y = fst (add x y)
642	607
643
644	608	let forall_pairs f l1 l2 =
645		List.fold_left (fun acc e1 ->
646		List.fold_left (fun acc e2 ->
647		match f e1 e2 with
648		\| None -> acc
649		\| Some v -> v::acc) acc l2) [] l1
650
651
652		let add_op x y =
653		match x , y with
654		\| Eq , Eq -> Eq
655		\| _ -> Ge
656
657
658		let pivot v (p1,c1) (p2,c2) =
659		let {coeffs = v1 ; op = op1 ; cst = n1} = c1
660		and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in
661
662		match Vect.get v v1 , Vect.get v v2 with
663		\| Int 0 , _ \| _ , Int 0 -> None
664		\| a , b ->
665		if Int.equal ((sign_num a) * (sign_num b)) (-1)
666		then
667		Some (add (p1,abs_num a) (p2,abs_num b) ,
668		{coeffs = add (v1,abs_num a) (v2,abs_num b) ;
669		op = add_op op1 op2 ;
670		cst = n1 // (abs_num a) +/ n2 // (abs_num b) })
671		else if op1 == Eq
672		then Some (add (p1,minus_num (a // b)) (p2,Int 1),
673		{coeffs = add (v1,minus_num (a// b)) (v2 ,Int 1) ;
674		op = add_op op1 op2;
675		cst = n1 // (minus_num (a// b)) +/ n2 // (Int 1)})
676		else if op2 == Eq
677		then
678		Some (add (p2,minus_num (b // a)) (p1,Int 1),
679		{coeffs = add (v2,minus_num (b// a)) (v1 ,Int 1) ;
680		op = add_op op1 op2;
681		cst = n2 // (minus_num (b// a)) +/ n1 // (Int 1)})
682		else None (* op2 could be Eq ... this might happen *)
683
	609	List.fold_left
	610	(fun acc e1 ->
	611	List.fold_left
	612	(fun acc e2 -> match f e1 e2 with None -> acc \| Some v -> v :: acc)
	613	acc l2)
	614	[] l1
	615
	616	let add_op x y = match (x, y) with Eq, Eq -> Eq \| _ -> Ge
	617
	618	let pivot v (p1, c1) (p2, c2) =
	619	let {coeffs = v1; op = op1; cst = n1} = c1
	620	and {coeffs = v2; op = op2; cst = n2} = c2 in
	621	match (Vect.get v v1, Vect.get v v2) with
	622	\| Int 0, _ \| _, Int 0 -> None
	623	\| a, b ->
	624	if Int.equal (sign_num a * sign_num b) (-1) then
	625	Some
	626	( add (p1, abs_num a) (p2, abs_num b)
	627	, { coeffs = add (v1, abs_num a) (v2, abs_num b)
	628	; op = add_op op1 op2
	629	; cst = (n1 // abs_num a) +/ (n2 // abs_num b) } )
	630	else if op1 == Eq then
	631	Some
	632	( add (p1, minus_num (a // b)) (p2, Int 1)
	633	, { coeffs = add (v1, minus_num (a // b)) (v2, Int 1)
	634	; op = add_op op1 op2
	635	; cst = (n1 // minus_num (a // b)) +/ (n2 // Int 1) } )
	636	else if op2 == Eq then
	637	Some
	638	( add (p2, minus_num (b // a)) (p1, Int 1)
	639	, { coeffs = add (v2, minus_num (b // a)) (v1, Int 1)
	640	; op = add_op op1 op2
	641	; cst = (n2 // minus_num (b // a)) +/ (n1 // Int 1) } )
	642	else None
	643
	644	(* op2 could be Eq ... this might happen *)
684	645
685	646	let normalise_proofs l =
686		List.fold_left (fun acc (prf,cstr) ->
687		match acc with
	647	List.fold_left
	648	(fun acc (prf, cstr) ->
	649	match acc with
688	650	\| Inr _ -> acc (* I already found a contradiction *)
689		\| Inl acc ->
690		match norm_cstr cstr 0 with
691		\| Redundant -> Inl acc
692		\| Contradiction -> Inr (prf,cstr)
693		\| Cstr(v,info) -> Inl ((prf,cstr,v,info)::acc)) (Inl []) l
694
	651	\| Inl acc -> (
	652	match norm_cstr cstr 0 with
	653	\| Redundant -> Inl acc
	654	\| Contradiction -> Inr (prf, cstr)
	655	\| Cstr (v, info) -> Inl ((prf, cstr, v, info) :: acc) ))
	656	(Inl []) l
695	657
696	658	type oproof = (vector * cstr * num) option
697	659
698		let merge_proof (oleft:oproof) (prf,cstr,v,info) (oright:oproof) =
699		let (l,r) = info.bound in
700
	660	let merge_proof (oleft : oproof) (prf, cstr, v, info) (oright : oproof) =
	661	let l, r = info.bound in
701	662	let keep p ob bd =
702		match ob , bd with
703		\| None , None -> None
704		\| None , Some b -> Some(prf,cstr,b)
705		\| Some _ , None -> ob
706		\| Some(prfl,cstrl,bl) , Some b -> if p bl b then Some(prf,cstr, b) else ob in
707
708		let oleft = keep (<=/) oleft l in
709		let oright = keep (>=/) oright r in
710		(* Now, there might be a contradiction *)
711		match oleft , oright with
712		\| None , _ \| _ , None -> Inl (oleft,oright)
713		\| Some(prfl,cstrl,l) , Some(prfr,cstrr,r) ->
714		if l <=/ r
715		then Inl (oleft,oright)
716		else (* There is a contradiction - it should show up by scaling up the vectors - any pivot should do*)
717		match Vect.choose cstrr.coeffs with
718		\| None -> Inr (add (prfl,Int 1) (prfr,Int 1), cstrr) (* this is wrong *)
719		\| Some(v,_,_) ->
720		match pivot v (prfl,cstrl) (prfr,cstrr) with
721		\| None -> failwith "merge_proof : pivot is not possible"
722		\| Some x -> Inr x
723
724		let mk_proof hyps prf =
725		(* I am keeping list - I might have a proof for the left bound and a proof for the right bound.
	663	match (ob, bd) with
	664	\| None, None -> None
	665	\| None, Some b -> Some (prf, cstr, b)
	666	\| Some _, None -> ob
	667	\| Some (prfl, cstrl, bl), Some b ->
	668	if p bl b then Some (prf, cstr, b) else ob
	669	in
	670	let oleft = keep ( <=/ ) oleft l in
	671	let oright = keep ( >=/ ) oright r in
	672	(* Now, there might be a contradiction *)
	673	match (oleft, oright) with
	674	\| None, _ \| _, None -> Inl (oleft, oright)
	675	\| Some (prfl, cstrl, l), Some (prfr, cstrr, r) -> (
	676	if l <=/ r then Inl (oleft, oright)
	677	else
	678	(* There is a contradiction - it should show up by scaling up the vectors - any pivot should do*)
	679	match Vect.choose cstrr.coeffs with
	680	\| None ->
	681	Inr (add (prfl, Int 1) (prfr, Int 1), cstrr) (* this is wrong *)
	682	\| Some (v, _, _) -> (
	683	match pivot v (prfl, cstrl) (prfr, cstrr) with
	684	\| None -> failwith "merge_proof : pivot is not possible"
	685	\| Some x -> Inr x ) )
	686
	687	let mk_proof hyps prf =
	688	(* I am keeping list - I might have a proof for the left bound and a proof for the right bound.
726	689	If I perform aggressive elimination of redundancies, I expect the list to be of length at most 2.
727	690	For each proof list, all the vectors should be of the form a.v for different constants a.
728	691	*)
729
730		let rec mk_proof prf =
731		match prf with
732		\| Assum i -> [ (Vect.set i (Int 1) Vect.null , List.nth hyps i) ]
733
734		\| Elim(v,prf1,prf2) ->
735		let prfsl = mk_proof prf1
736		and prfsr = mk_proof prf2 in
737		(* I take only the pairs for which the elimination is meaningful *)
738		forall_pairs (pivot v) prfsl prfsr
739		\| And(prf1,prf2) ->
740		let prfsl1 = mk_proof prf1
741		and prfsl2 = mk_proof prf2 in
742		(* detect trivial redundancies and contradictions *)
743		match normalise_proofs (prfsl1@prfsl2) with
744		\| Inr x -> [x] (* This is a contradiction - this should be the end of the proof *)
745		\| Inl l -> (* All the vectors are the same *)
746		let prfs =
747		List.fold_left (fun acc e ->
748		match acc with
749		\| Inr _ -> acc (* I have a contradiction *)
750		\| Inl (oleft,oright) -> merge_proof oleft e oright) (Inl(None,None)) l in
751		match prfs with
752		\| Inr x -> [x]
753		\| Inl (oleft,oright) ->
754		match oleft , oright with
755		\| None , None -> []
756		\| None , Some(prf,cstr,_) \| Some(prf,cstr,_) , None -> [prf,cstr]
757		\| Some(prf1,cstr1,_) , Some(prf2,cstr2,_) -> [prf1,cstr1;prf2,cstr2] in
758
	692	let rec mk_proof prf =
	693	match prf with
	694	\| Assum i -> [(Vect.set i (Int 1) Vect.null, List.nth hyps i)]
	695	\| Elim (v, prf1, prf2) ->
	696	let prfsl = mk_proof prf1 and prfsr = mk_proof prf2 in
	697	(* I take only the pairs for which the elimination is meaningful *)
	698	forall_pairs (pivot v) prfsl prfsr
	699	\| And (prf1, prf2) -> (
	700	let prfsl1 = mk_proof prf1 and prfsl2 = mk_proof prf2 in
	701	(* detect trivial redundancies and contradictions *)
	702	match normalise_proofs (prfsl1 @ prfsl2) with
	703	\| Inr x -> [x]
	704	(* This is a contradiction - this should be the end of the proof *)
	705	\| Inl l -> (
	706	(* All the vectors are the same *)
	707	let prfs =
	708	List.fold_left
	709	(fun acc e ->
	710	match acc with
	711	\| Inr _ -> acc (* I have a contradiction *)
	712	\| Inl (oleft, oright) -> merge_proof oleft e oright)
	713	(Inl (None, None))
	714	l
	715	in
	716	match prfs with
	717	\| Inr x -> [x]
	718	\| Inl (oleft, oright) -> (
	719	match (oleft, oright) with
	720	\| None, None -> []
	721	\| None, Some (prf, cstr, _) \| Some (prf, cstr, _), None ->
	722	[(prf, cstr)]
	723	\| Some (prf1, cstr1, _), Some (prf2, cstr2, _) ->
	724	[(prf1, cstr1); (prf2, cstr2)] ) ) )
	725	in
759	726	mk_proof prf
760
761
762	727	end
763

-13

plugins/micromega/mfourier.mli less more

12	12	type proof
13	13
14	14	module Fourier : sig
15
16
17		val find_point : Polynomial.cstr list ->
18		(Vect.t, proof) Util.union
19
20		val optimise : Vect.t ->
21		Polynomial.cstr list ->
22		Itv.interval option
23
	15	val find_point : Polynomial.cstr list -> (Vect.t, proof) Util.union
	16	val optimise : Vect.t -> Polynomial.cstr list -> Itv.interval option
24	17	end
25	18
26	19	val pp_proof : out_channel -> proof -> unit
27	20
28	21	module Proof : sig
29
30		val mk_proof : Polynomial.cstr list ->
31		proof -> (Vect.t * Polynomial.cstr) list
	22	val mk_proof :
	23	Polynomial.cstr list -> proof -> (Vect.t * Polynomial.cstr) list
32	24
33	25	val add_op : Polynomial.op -> Polynomial.op -> Polynomial.op
34
35	26	end
36	27
37	28	exception TimeOut

+37

-135

plugins/micromega/micromega.ml less more

279	279
280	280	let compare =
281	281	compare_cont Eq
	282
	283	( val max : positive -> positive -> positive )
	284
	285	let max p p' =
	286	match compare p p' with
	287	\| Gt -> p
	288	\| _ -> p'
	289
	290	( val leb : positive -> positive -> bool )
	291
	292	let leb x y =
	293	match compare x y with
	294	\| Gt -> false
	295	\| _ -> true
282	296
283	297	( val gcdn : nat -> positive -> positive -> positive )
284	298

1759	1773	\| _ -> PsatzAdd (t1, t2)))
1760	1774	\| _ -> e
1761	1775
1762		module PositiveSet =
1763		struct
1764		type tree =
1765		\| Leaf
1766		\| Node of tree * bool * tree
1767		end
1768
1769	1776	type q = { qnum : z; qden : positive }
1770	1777
1771	1778	( val qeq_bool : q -> q -> bool )

1979	1986	\| RatProof of zWitness * zArithProof
1980	1987	\| CutProof of zWitness * zArithProof
1981	1988	\| EnumProof of zWitness * zWitness * zArithProof list
	1989	\| ExProof of positive * zArithProof
1982	1990
1983	1991	( val zgcdM : z -> z -> z )
1984	1992

2050	2058	\| NonStrict -> true
2051	2059	\| _ -> false
2052	2060
2053		module Vars =
2054		struct
2055		type elt = positive
2056
2057		type tree = PositiveSet.tree =
2058		\| Leaf
2059		\| Node of tree * bool * tree
2060
2061		type t = tree
2062
2063		( val empty : t )
2064
2065		let empty =
2066		Leaf
2067
2068		( val add : elt -> t -> t )
2069
2070		let rec add i = function
2071		\| Leaf ->
2072		(match i with
2073		\| XI i0 -> Node (Leaf, false, (add i0 Leaf))
2074		\| XO i0 -> Node ((add i0 Leaf), false, Leaf)
2075		\| XH -> Node (Leaf, true, Leaf))
2076		\| Node (l, o, r) ->
2077		(match i with
2078		\| XI i0 -> Node (l, o, (add i0 r))
2079		\| XO i0 -> Node ((add i0 l), o, r)
2080		\| XH -> Node (l, true, r))
2081
2082		( val singleton : elt -> t )
2083
2084		let singleton i =
2085		add i empty
2086
2087		( val union : t -> t -> t )
2088
2089		let rec union m m' =
2090		match m with
2091		\| Leaf -> m'
2092		\| Node (l, o, r) ->
2093		(match m' with
2094		\| Leaf -> m
2095		\| Node (l', o', r') ->
2096		Node ((union l l'), (if o then true else o'), (union r r')))
2097
2098		( val rev_append : elt -> elt -> elt )
2099
2100		let rec rev_append y x =
2101		match y with
2102		\| XI y0 -> rev_append y0 (XI x)
2103		\| XO y0 -> rev_append y0 (XO x)
2104		\| XH -> x
2105
2106		( val rev : elt -> elt )
2107
2108		let rev x =
2109		rev_append x XH
2110
2111		( val xfold : (elt -> 'a1 -> 'a1) -> t -> 'a1 -> elt -> 'a1 )
2112
2113		let rec xfold f m v i =
2114		match m with
2115		\| Leaf -> v
2116		\| Node (l, b, r) ->
2117		if b
2118		then xfold f r (f (rev i) (xfold f l v (XO i))) (XI i)
2119		else xfold f r (xfold f l v (XO i)) (XI i)
2120
2121		( val fold : (elt -> 'a1 -> 'a1) -> t -> 'a1 -> 'a1 )
2122
2123		let fold f m i =
2124		xfold f m i XH
2125		end
2126
2127		( val vars_of_pexpr : z pExpr -> Vars.t )
2128
2129		let rec vars_of_pexpr = function
2130		\| PEc _ -> Vars.empty
2131		\| PEX x -> Vars.singleton x
2132		\| PEadd (e1, e2) ->
2133		let v1 = vars_of_pexpr e1 in let v2 = vars_of_pexpr e2 in Vars.union v1 v2
2134		\| PEsub (e1, e2) ->
2135		let v1 = vars_of_pexpr e1 in let v2 = vars_of_pexpr e2 in Vars.union v1 v2
2136		\| PEmul (e1, e2) ->
2137		let v1 = vars_of_pexpr e1 in let v2 = vars_of_pexpr e2 in Vars.union v1 v2
2138		\| PEopp c -> vars_of_pexpr c
2139		\| PEpow (e0, _) -> vars_of_pexpr e0
2140
2141		( val vars_of_formula : z formula -> Vars.t )
2142
2143		let vars_of_formula f =
2144		let { flhs = l; fop = _; frhs = r } = f in
2145		let v1 = vars_of_pexpr l in let v2 = vars_of_pexpr r in Vars.union v1 v2
2146
2147		( val vars_of_bformula : (z formula, 'a1, 'a2, 'a3) gFormula -> Vars.t )
2148
2149		let rec vars_of_bformula = function
2150		\| A (a, _) -> vars_of_formula a
2151		\| Cj (f1, f2) ->
2152		let v1 = vars_of_bformula f1 in
2153		let v2 = vars_of_bformula f2 in Vars.union v1 v2
2154		\| D (f1, f2) ->
2155		let v1 = vars_of_bformula f1 in
2156		let v2 = vars_of_bformula f2 in Vars.union v1 v2
2157		\| N f0 -> vars_of_bformula f0
2158		\| I (f1, _, f2) ->
2159		let v1 = vars_of_bformula f1 in
2160		let v2 = vars_of_bformula f2 in Vars.union v1 v2
2161		\| _ -> Vars.empty
2162
2163	2061	( val bound_var : positive -> z formula )
2164	2062
2165	2063	let bound_var v =

2170	2068	let mk_eq_pos x y t0 =
2171	2069	{ flhs = (PEX x); fop = OpEq; frhs = (PEsub ((PEX y), (PEX t0))) }
2172	2070
2173		(** val bound_vars :
2174		(positive -> positive -> bool option -> 'a2) -> positive -> Vars.t -> (z
2175		formula, 'a1, 'a2, 'a3) gFormula **)
2176
2177		let bound_vars tag_of_var fr v =
2178		Vars.fold (fun k acc ->
2179		let y = XO (Coq_Pos.add fr k) in
2180		let z0 = XI (Coq_Pos.add fr k) in
2181		Cj ((Cj ((A ((mk_eq_pos k y z0), (tag_of_var fr k None))), (Cj ((A
2182		((bound_var y), (tag_of_var fr k (Some false)))), (A ((bound_var z0),
2183		(tag_of_var fr k (Some true)))))))), acc)) v TT
2184
2185		(** val bound_problem_fr :
2186		(positive -> positive -> bool option -> 'a2) -> positive -> (z formula,
2187		'a1, 'a2, 'a3) gFormula -> (z formula, 'a1, 'a2, 'a3) gFormula **)
2188
2189		let bound_problem_fr tag_of_var fr f =
2190		let v = vars_of_bformula f in I ((bound_vars tag_of_var fr v), None, f)
	2071	( val max_var : positive -> z pol -> positive )
	2072
	2073	let rec max_var jmp = function
	2074	\| Pc _ -> jmp
	2075	\| Pinj (j, p2) -> max_var (Coq_Pos.add j jmp) p2
	2076	\| PX (p2, _, q0) ->
	2077	Coq_Pos.max (max_var jmp p2) (max_var (Coq_Pos.succ jmp) q0)
	2078
	2079	( val max_var_nformulae : z nFormula list -> positive )
	2080
	2081	let max_var_nformulae l =
	2082	fold_left (fun acc f -> Coq_Pos.max acc (max_var XH (fst f))) l XH
2191	2083
2192	2084	( val zChecker : z nFormula list -> zArithProof -> bool )
2193	2085

2231	2123	\| None -> true)
2232	2124	\| None -> false)
2233	2125	\| None -> false)
	2126	\| ExProof (x, prf) ->
	2127	let fr = max_var_nformulae l in
	2128	if Coq_Pos.leb x fr
	2129	then let z0 = Coq_Pos.succ fr in
	2130	let t0 = Coq_Pos.succ z0 in
	2131	let nfx = xnnormalise (mk_eq_pos x z0 t0) in
	2132	let posz = xnnormalise (bound_var z0) in
	2133	let post = xnnormalise (bound_var t0) in
	2134	zChecker (nfx::(posz::(post::l))) prf
	2135	else false
2234	2136
2235	2137	( val zTautoChecker : z formula bFormula -> zArithProof list -> bool )
2236	2138

+425

-386

plugins/micromega/micromega.mli less more

0
1	0	type __ = Obj.t
2
3		type unit0 =
4		\| Tt
	1	type unit0 = Tt
5	2
6	3	val negb : bool -> bool
7	4
8		type nat =
9		\| O
10		\| S of nat
11
12		type ('a, 'b) sum =
13		\| Inl of 'a
14		\| Inr of 'b
15
16		val fst : ('a1 * 'a2) -> 'a1
17
18		val snd : ('a1 * 'a2) -> 'a2
19
	5	type nat = O \| S of nat
	6	type ('a, 'b) sum = Inl of 'a \| Inr of 'b
	7
	8	val fst : 'a1 * 'a2 -> 'a1
	9	val snd : 'a1 * 'a2 -> 'a2
20	10	val app : 'a1 list -> 'a1 list -> 'a1 list
21	11
22		type comparison =
23		\| Eq
24		\| Lt
25		\| Gt
	12	type comparison = Eq \| Lt \| Gt
26	13
27	14	val compOpp : comparison -> comparison
28
29	15	val add : nat -> nat -> nat
30
31	16	val nth : nat -> 'a1 list -> 'a1 -> 'a1
32
33	17	val rev_append : 'a1 list -> 'a1 list -> 'a1 list
34
35	18	val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list
36
37	19	val fold_left : ('a1 -> 'a2 -> 'a1) -> 'a2 list -> 'a1 -> 'a1
38
39	20	val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1
40	21
41		type positive =
42		\| XI of positive
43		\| XO of positive
44		\| XH
45
46		type n =
47		\| N0
48		\| Npos of positive
49
50		type z =
51		\| Z0
52		\| Zpos of positive
53		\| Zneg of positive
54
55		module Pos :
56		sig
57		type mask =
58		\| IsNul
59		\| IsPos of positive
60		\| IsNeg
61		end
62
63		module Coq_Pos :
64		sig
	22	type positive = XI of positive \| XO of positive \| XH
	23	type n = N0 \| Npos of positive
	24	type z = Z0 \| Zpos of positive \| Zneg of positive
	25
	26	module Pos : sig
	27	type mask = IsNul \| IsPos of positive \| IsNeg
	28	end
	29
	30	module Coq_Pos : sig
65	31	val succ : positive -> positive
66
67	32	val add : positive -> positive -> positive
68
69	33	val add_carry : positive -> positive -> positive
70
71	34	val pred_double : positive -> positive
72	35
73		type mask = Pos.mask =
74		\| IsNul
75		\| IsPos of positive
76		\| IsNeg
	36	type mask = Pos.mask = IsNul \| IsPos of positive \| IsNeg
77	37
78	38	val succ_double_mask : mask -> mask
79
80	39	val double_mask : mask -> mask
81
82	40	val double_pred_mask : positive -> mask
83
84	41	val sub_mask : positive -> positive -> mask
85
86	42	val sub_mask_carry : positive -> positive -> mask
87
88	43	val sub : positive -> positive -> positive
89
90	44	val mul : positive -> positive -> positive
91
92	45	val iter : ('a1 -> 'a1) -> 'a1 -> positive -> 'a1
93
94	46	val size_nat : positive -> nat
95
96	47	val compare_cont : comparison -> positive -> positive -> comparison
97
98	48	val compare : positive -> positive -> comparison
99
	49	val max : positive -> positive -> positive
	50	val leb : positive -> positive -> bool
100	51	val gcdn : nat -> positive -> positive -> positive
101
102	52	val gcd : positive -> positive -> positive
103
104	53	val of_succ_nat : nat -> positive
105		end
106
107		module N :
108		sig
	54	end
	55
	56	module N : sig
109	57	val of_nat : nat -> n
110		end
	58	end
111	59
112	60	val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1
113	61
114		module Z :
115		sig
	62	module Z : sig
116	63	val double : z -> z
117
118	64	val succ_double : z -> z
119
120	65	val pred_double : z -> z
121
122	66	val pos_sub : positive -> positive -> z
123
124	67	val add : z -> z -> z
125
126	68	val opp : z -> z
127
128	69	val sub : z -> z -> z
129
130	70	val mul : z -> z -> z
131
132	71	val pow_pos : z -> positive -> z
133
134	72	val pow : z -> z -> z
135
136	73	val compare : z -> z -> comparison
137
138	74	val leb : z -> z -> bool
139
140	75	val ltb : z -> z -> bool
141
142	76	val gtb : z -> z -> bool
143
144	77	val max : z -> z -> z
145
146	78	val abs : z -> z
147
148	79	val to_N : z -> n
149
150	80	val of_nat : nat -> z
151
152	81	val of_N : n -> z
153
154	82	val pos_div_eucl : positive -> z -> z * z
155
156	83	val div_eucl : z -> z -> z * z
157
158	84	val div : z -> z -> z
159
160	85	val gcd : z -> z -> z
161		end
	86	end
162	87
163	88	val zeq_bool : z -> z -> bool
164	89
165	90	type 'c pol =
166		\| Pc of 'c
167		\| Pinj of positive * 'c pol
168		\| PX of 'c pol * positive * 'c pol
	91	\| Pc of 'c
	92	\| Pinj of positive * 'c pol
	93	\| PX of 'c pol * positive * 'c pol
169	94
170	95	val p0 : 'a1 -> 'a1 pol
171
172	96	val p1 : 'a1 -> 'a1 pol
173
174	97	val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool
175
176	98	val mkPinj : positive -> 'a1 pol -> 'a1 pol
177
178	99	val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol
179	100
180		val mkPX : 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol
	101	val mkPX :
	102	'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol
181	103
182	104	val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol
183
184	105	val mkX : 'a1 -> 'a1 -> 'a1 pol
185
186	106	val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol
187
188	107	val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol
189
190	108	val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol
191	109
192	110	val paddI :
193		('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol ->
194		'a1 pol
	111	('a1 -> 'a1 -> 'a1)
	112	-> ('a1 pol -> 'a1 pol -> 'a1 pol)
	113	-> 'a1 pol
	114	-> positive
	115	-> 'a1 pol
	116	-> 'a1 pol
195	117
196	118	val psubI :
197		('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive
198		-> 'a1 pol -> 'a1 pol
	119	('a1 -> 'a1 -> 'a1)
	120	-> ('a1 -> 'a1)
	121	-> ('a1 pol -> 'a1 pol -> 'a1 pol)
	122	-> 'a1 pol
	123	-> positive
	124	-> 'a1 pol
	125	-> 'a1 pol
199	126
200	127	val paddX :
201		'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1
202		pol -> 'a1 pol
	128	'a1
	129	-> ('a1 -> 'a1 -> bool)
	130	-> ('a1 pol -> 'a1 pol -> 'a1 pol)
	131	-> 'a1 pol
	132	-> positive
	133	-> 'a1 pol
	134	-> 'a1 pol
203	135
204	136	val psubX :
205		'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol ->
206		positive -> 'a1 pol -> 'a1 pol
207
208		val padd : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol
	137	'a1
	138	-> ('a1 -> 'a1)
	139	-> ('a1 -> 'a1 -> bool)
	140	-> ('a1 pol -> 'a1 pol -> 'a1 pol)
	141	-> 'a1 pol
	142	-> positive
	143	-> 'a1 pol
	144	-> 'a1 pol
	145
	146	val padd :
	147	'a1
	148	-> ('a1 -> 'a1 -> 'a1)
	149	-> ('a1 -> 'a1 -> bool)
	150	-> 'a1 pol
	151	-> 'a1 pol
	152	-> 'a1 pol
209	153
210	154	val psub :
211		'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) ->
212		'a1 pol -> 'a1 pol -> 'a1 pol
213
214		val pmulC_aux : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol
	155	'a1
	156	-> ('a1 -> 'a1 -> 'a1)
	157	-> ('a1 -> 'a1 -> 'a1)
	158	-> ('a1 -> 'a1)
	159	-> ('a1 -> 'a1 -> bool)
	160	-> 'a1 pol
	161	-> 'a1 pol
	162	-> 'a1 pol
	163
	164	val pmulC_aux :
	165	'a1
	166	-> ('a1 -> 'a1 -> 'a1)
	167	-> ('a1 -> 'a1 -> bool)
	168	-> 'a1 pol
	169	-> 'a1
	170	-> 'a1 pol
215	171
216	172	val pmulC :
217		'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol
	173	'a1
	174	-> 'a1
	175	-> ('a1 -> 'a1 -> 'a1)
	176	-> ('a1 -> 'a1 -> bool)
	177	-> 'a1 pol
	178	-> 'a1
	179	-> 'a1 pol
218	180
219	181	val pmulI :
220		'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol)
221		-> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol
	182	'a1
	183	-> 'a1
	184	-> ('a1 -> 'a1 -> 'a1)
	185	-> ('a1 -> 'a1 -> bool)
	186	-> ('a1 pol -> 'a1 pol -> 'a1 pol)
	187	-> 'a1 pol
	188	-> positive
	189	-> 'a1 pol
	190	-> 'a1 pol
222	191
223	192	val pmul :
224		'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol
225		-> 'a1 pol -> 'a1 pol
	193	'a1
	194	-> 'a1
	195	-> ('a1 -> 'a1 -> 'a1)
	196	-> ('a1 -> 'a1 -> 'a1)
	197	-> ('a1 -> 'a1 -> bool)
	198	-> 'a1 pol
	199	-> 'a1 pol
	200	-> 'a1 pol
226	201
227	202	val psquare :
228		'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol
	203	'a1
	204	-> 'a1
	205	-> ('a1 -> 'a1 -> 'a1)
	206	-> ('a1 -> 'a1 -> 'a1)
	207	-> ('a1 -> 'a1 -> bool)
	208	-> 'a1 pol
229	209	-> 'a1 pol
230	210
231	211	type 'c pExpr =
232		\| PEc of 'c
233		\| PEX of positive
234		\| PEadd of 'c pExpr * 'c pExpr
235		\| PEsub of 'c pExpr * 'c pExpr
236		\| PEmul of 'c pExpr * 'c pExpr
237		\| PEopp of 'c pExpr
238		\| PEpow of 'c pExpr * n
	212	\| PEc of 'c
	213	\| PEX of positive
	214	\| PEadd of 'c pExpr * 'c pExpr
	215	\| PEsub of 'c pExpr * 'c pExpr
	216	\| PEmul of 'c pExpr * 'c pExpr
	217	\| PEopp of 'c pExpr
	218	\| PEpow of 'c pExpr * n
239	219
240	220	val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol
241	221
242	222	val ppow_pos :
243		'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol
244		-> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol
	223	'a1
	224	-> 'a1
	225	-> ('a1 -> 'a1 -> 'a1)
	226	-> ('a1 -> 'a1 -> 'a1)
	227	-> ('a1 -> 'a1 -> bool)
	228	-> ('a1 pol -> 'a1 pol)
	229	-> 'a1 pol
	230	-> 'a1 pol
	231	-> positive
	232	-> 'a1 pol
245	233
246	234	val ppow_N :
247		'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol
248		-> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol
	235	'a1
	236	-> 'a1
	237	-> ('a1 -> 'a1 -> 'a1)
	238	-> ('a1 -> 'a1 -> 'a1)
	239	-> ('a1 -> 'a1 -> bool)
	240	-> ('a1 pol -> 'a1 pol)
	241	-> 'a1 pol
	242	-> n
	243	-> 'a1 pol
249	244
250	245	val norm_aux :
251		'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
252		'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol
	246	'a1
	247	-> 'a1
	248	-> ('a1 -> 'a1 -> 'a1)
	249	-> ('a1 -> 'a1 -> 'a1)
	250	-> ('a1 -> 'a1 -> 'a1)
	251	-> ('a1 -> 'a1)
	252	-> ('a1 -> 'a1 -> bool)
	253	-> 'a1 pExpr
	254	-> 'a1 pol
253	255
254	256	type ('tA, 'tX, 'aA, 'aF) gFormula =
255		\| TT
256		\| FF
257		\| X of 'tX
258		\| A of 'tA * 'aA
259		\| Cj of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula
260		\| D of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula
261		\| N of ('tA, 'tX, 'aA, 'aF) gFormula
262		\| I of ('tA, 'tX, 'aA, 'aF) gFormula * 'aF option * ('tA, 'tX, 'aA, 'aF) gFormula
263
264		val mapX : ('a2 -> 'a2) -> ('a1, 'a2, 'a3, 'a4) gFormula -> ('a1, 'a2, 'a3, 'a4) gFormula
	257	\| TT
	258	\| FF
	259	\| X of 'tX
	260	\| A of 'tA * 'aA
	261	\| Cj of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula
	262	\| D of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula
	263	\| N of ('tA, 'tX, 'aA, 'aF) gFormula
	264	\| I of
	265	('tA, 'tX, 'aA, 'aF) gFormula * 'aF option * ('tA, 'tX, 'aA, 'aF) gFormula
	266
	267	val mapX :
	268	('a2 -> 'a2) -> ('a1, 'a2, 'a3, 'a4) gFormula -> ('a1, 'a2, 'a3, 'a4) gFormula
265	269
266	270	val foldA : ('a5 -> 'a3 -> 'a5) -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a5 -> 'a5
267
268	271	val cons_id : 'a1 option -> 'a1 list -> 'a1 list
269
270	272	val ids_of_formula : ('a1, 'a2, 'a3, 'a4) gFormula -> 'a4 list
271
272	273	val collect_annot : ('a1, 'a2, 'a3, 'a4) gFormula -> 'a3 list
273	274
274	275	type 'a bFormula = ('a, __, unit0, unit0) gFormula

277	278	('a1 -> 'a2) -> ('a1, 'a3, 'a4, 'a5) gFormula -> ('a2, 'a3, 'a4, 'a5) gFormula
278	279
279	280	type ('x, 'annot) clause = ('x * 'annot) list
280
281	281	type ('x, 'annot) cnf = ('x, 'annot) clause list
282	282
283	283	val cnf_tt : ('a1, 'a2) cnf
284
285	284	val cnf_ff : ('a1, 'a2) cnf
286	285
287	286	val add_term :
288		('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> ('a1, 'a2)
289		clause option
	287	('a1 -> bool)
	288	-> ('a1 -> 'a1 -> 'a1 option)
	289	-> 'a1 * 'a2
	290	-> ('a1, 'a2) clause
	291	-> ('a1, 'a2) clause option
290	292
291	293	val or_clause :
292		('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) clause ->
293		('a1, 'a2) clause option
	294	('a1 -> bool)
	295	-> ('a1 -> 'a1 -> 'a1 option)
	296	-> ('a1, 'a2) clause
	297	-> ('a1, 'a2) clause
	298	-> ('a1, 'a2) clause option
294	299
295	300	val xor_clause_cnf :
296		('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf -> ('a1,
297		'a2) cnf
	301	('a1 -> bool)
	302	-> ('a1 -> 'a1 -> 'a1 option)
	303	-> ('a1, 'a2) clause
	304	-> ('a1, 'a2) cnf
	305	-> ('a1, 'a2) cnf
298	306
299	307	val or_clause_cnf :
300		('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf -> ('a1,
301		'a2) cnf
	308	('a1 -> bool)
	309	-> ('a1 -> 'a1 -> 'a1 option)
	310	-> ('a1, 'a2) clause
	311	-> ('a1, 'a2) cnf
	312	-> ('a1, 'a2) cnf
302	313
303	314	val or_cnf :
304		('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2)
305		cnf
	315	('a1 -> bool)
	316	-> ('a1 -> 'a1 -> 'a1 option)
	317	-> ('a1, 'a2) cnf
	318	-> ('a1, 'a2) cnf
	319	-> ('a1, 'a2) cnf
306	320
307	321	val and_cnf : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf
308	322
309	323	type ('term, 'annot, 'tX, 'aF) tFormula = ('term, 'tX, 'annot, 'aF) gFormula
310	324
311	325	val is_cnf_tt : ('a1, 'a2) cnf -> bool
312
313	326	val is_cnf_ff : ('a1, 'a2) cnf -> bool
314
315	327	val and_cnf_opt : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf
316	328
317	329	val or_cnf_opt :
318		('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2)
319		cnf
	330	('a1 -> bool)
	331	-> ('a1 -> 'a1 -> 'a1 option)
	332	-> ('a1, 'a2) cnf
	333	-> ('a1, 'a2) cnf
	334	-> ('a1, 'a2) cnf
320	335
321	336	val xcnf :
322		('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> 'a3
323		-> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf
	337	('a2 -> bool)
	338	-> ('a2 -> 'a2 -> 'a2 option)
	339	-> ('a1 -> 'a3 -> ('a2, 'a3) cnf)
	340	-> ('a1 -> 'a3 -> ('a2, 'a3) cnf)
	341	-> bool
	342	-> ('a1, 'a3, 'a4, 'a5) tFormula
	343	-> ('a2, 'a3) cnf
324	344
325	345	val radd_term :
326		('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> (('a1,
327		'a2) clause, 'a2 list) sum
	346	('a1 -> bool)
	347	-> ('a1 -> 'a1 -> 'a1 option)
	348	-> 'a1 * 'a2
	349	-> ('a1, 'a2) clause
	350	-> (('a1, 'a2) clause, 'a2 list) sum
328	351
329	352	val ror_clause :
330		('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause ->
331		(('a1, 'a2) clause, 'a2 list) sum
	353	('a1 -> bool)
	354	-> ('a1 -> 'a1 -> 'a1 option)
	355	-> ('a1 * 'a2) list
	356	-> ('a1, 'a2) clause
	357	-> (('a1, 'a2) clause, 'a2 list) sum
332	358
333	359	val xror_clause_cnf :
334		('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause list ->
335		('a1, 'a2) clause list * 'a2 list
	360	('a1 -> bool)
	361	-> ('a1 -> 'a1 -> 'a1 option)
	362	-> ('a1 * 'a2) list
	363	-> ('a1, 'a2) clause list
	364	-> ('a1, 'a2) clause list * 'a2 list
336	365
337	366	val ror_clause_cnf :
338		('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause list ->
339		('a1, 'a2) clause list * 'a2 list
	367	('a1 -> bool)
	368	-> ('a1 -> 'a1 -> 'a1 option)
	369	-> ('a1 * 'a2) list
	370	-> ('a1, 'a2) clause list
	371	-> ('a1, 'a2) clause list * 'a2 list
340	372
341	373	val ror_cnf :
342		('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause list -> ('a1, 'a2) clause
343		list -> ('a1, 'a2) cnf * 'a2 list
	374	('a1 -> bool)
	375	-> ('a1 -> 'a1 -> 'a1 option)
	376	-> ('a1, 'a2) clause list
	377	-> ('a1, 'a2) clause list
	378	-> ('a1, 'a2) cnf * 'a2 list
344	379
345	380	val ror_cnf_opt :
346		('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2)
347		cnf * 'a2 list
	381	('a1 -> bool)
	382	-> ('a1 -> 'a1 -> 'a1 option)
	383	-> ('a1, 'a2) cnf
	384	-> ('a1, 'a2) cnf
	385	-> ('a1, 'a2) cnf * 'a2 list
348	386
349	387	val ratom : ('a1, 'a2) cnf -> 'a2 -> ('a1, 'a2) cnf * 'a2 list
350	388
351	389	val rxcnf :
352		('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> 'a3
353		-> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 list
354
355		type ('term, 'annot, 'tX) to_constrT = { mkTT : 'tX; mkFF : 'tX;
356		mkA : ('term -> 'annot -> 'tX);
357		mkCj : ('tX -> 'tX -> 'tX); mkD : ('tX -> 'tX -> 'tX);
358		mkI : ('tX -> 'tX -> 'tX); mkN : ('tX -> 'tX) }
359
360		val aformula : ('a1, 'a2, 'a3) to_constrT -> ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3
	390	('a2 -> bool)
	391	-> ('a2 -> 'a2 -> 'a2 option)
	392	-> ('a1 -> 'a3 -> ('a2, 'a3) cnf)
	393	-> ('a1 -> 'a3 -> ('a2, 'a3) cnf)
	394	-> bool
	395	-> ('a1, 'a3, 'a4, 'a5) tFormula
	396	-> ('a2, 'a3) cnf * 'a3 list
	397
	398	type ('term, 'annot, 'tX) to_constrT =
	399	{ mkTT : 'tX
	400	; mkFF : 'tX
	401	; mkA : 'term -> 'annot -> 'tX
	402	; mkCj : 'tX -> 'tX -> 'tX
	403	; mkD : 'tX -> 'tX -> 'tX
	404	; mkI : 'tX -> 'tX -> 'tX
	405	; mkN : 'tX -> 'tX }
	406
	407	val aformula :
	408	('a1, 'a2, 'a3) to_constrT -> ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3
361	409
362	410	val is_X : ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 option
363	411
364	412	val abs_and :
365		('a1, 'a2, 'a3) to_constrT -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula
366		-> (('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4)
367		tFormula) -> ('a1, 'a3, 'a2, 'a4) gFormula
	413	('a1, 'a2, 'a3) to_constrT
	414	-> ('a1, 'a2, 'a3, 'a4) tFormula
	415	-> ('a1, 'a2, 'a3, 'a4) tFormula
	416	-> ( ('a1, 'a2, 'a3, 'a4) tFormula
	417	-> ('a1, 'a2, 'a3, 'a4) tFormula
	418	-> ('a1, 'a2, 'a3, 'a4) tFormula)
	419	-> ('a1, 'a3, 'a2, 'a4) gFormula
368	420
369	421	val abs_or :
370		('a1, 'a2, 'a3) to_constrT -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula
371		-> (('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4)
372		tFormula) -> ('a1, 'a3, 'a2, 'a4) gFormula
	422	('a1, 'a2, 'a3) to_constrT
	423	-> ('a1, 'a2, 'a3, 'a4) tFormula
	424	-> ('a1, 'a2, 'a3, 'a4) tFormula
	425	-> ( ('a1, 'a2, 'a3, 'a4) tFormula
	426	-> ('a1, 'a2, 'a3, 'a4) tFormula
	427	-> ('a1, 'a2, 'a3, 'a4) tFormula)
	428	-> ('a1, 'a3, 'a2, 'a4) gFormula
373	429
374	430	val mk_arrow :
375		'a4 option -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2,
376		'a3, 'a4) tFormula
	431	'a4 option
	432	-> ('a1, 'a2, 'a3, 'a4) tFormula
	433	-> ('a1, 'a2, 'a3, 'a4) tFormula
	434	-> ('a1, 'a2, 'a3, 'a4) tFormula
377	435
378	436	val abst_form :
379		('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> bool -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1,
380		'a3, 'a2, 'a4) gFormula
381
382		val cnf_checker : (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool
	437	('a1, 'a2, 'a3) to_constrT
	438	-> ('a2 -> bool)
	439	-> bool
	440	-> ('a1, 'a2, 'a3, 'a4) tFormula
	441	-> ('a1, 'a3, 'a2, 'a4) gFormula
	442
	443	val cnf_checker :
	444	(('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool
383	445
384	446	val tauto_checker :
385		('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> 'a3
386		-> ('a2, 'a3) cnf) -> (('a2 * 'a3) list -> 'a4 -> bool) -> ('a1, __, 'a3, unit0) gFormula ->
387		'a4 list -> bool
	447	('a2 -> bool)
	448	-> ('a2 -> 'a2 -> 'a2 option)
	449	-> ('a1 -> 'a3 -> ('a2, 'a3) cnf)
	450	-> ('a1 -> 'a3 -> ('a2, 'a3) cnf)
	451	-> (('a2 * 'a3) list -> 'a4 -> bool)
	452	-> ('a1, __, 'a3, unit0) gFormula
	453	-> 'a4 list
	454	-> bool
388	455
389	456	val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool
390
391	457	val cltb : ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool
392	458
393	459	type 'c polC = 'c pol
394
395		type op1 =
396		\| Equal
397		\| NonEqual
398		\| Strict
399		\| NonStrict
400
	460	type op1 = Equal \| NonEqual \| Strict \| NonStrict
401	461	type 'c nFormula = 'c polC * op1
402	462
403	463	val opMult : op1 -> op1 -> op1 option
404
405	464	val opAdd : op1 -> op1 -> op1 option
406	465
407	466	type 'c psatz =
408		\| PsatzIn of nat
409		\| PsatzSquare of 'c polC
410		\| PsatzMulC of 'c polC * 'c psatz
411		\| PsatzMulE of 'c psatz * 'c psatz
412		\| PsatzAdd of 'c psatz * 'c psatz
413		\| PsatzC of 'c
414		\| PsatzZ
	467	\| PsatzIn of nat
	468	\| PsatzSquare of 'c polC
	469	\| PsatzMulC of 'c polC * 'c psatz
	470	\| PsatzMulE of 'c psatz * 'c psatz
	471	\| PsatzAdd of 'c psatz * 'c psatz
	472	\| PsatzC of 'c
	473	\| PsatzZ
415	474
416	475	val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option
417	476
418		val map_option2 : ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option
	477	val map_option2 :
	478	('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option
419	479
420	480	val pexpr_times_nformula :
421		'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 polC
422		-> 'a1 nFormula -> 'a1 nFormula option
	481	'a1
	482	-> 'a1
	483	-> ('a1 -> 'a1 -> 'a1)
	484	-> ('a1 -> 'a1 -> 'a1)
	485	-> ('a1 -> 'a1 -> bool)
	486	-> 'a1 polC
	487	-> 'a1 nFormula
	488	-> 'a1 nFormula option
423	489
424	490	val nformula_times_nformula :
425		'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1
426		nFormula -> 'a1 nFormula -> 'a1 nFormula option
	491	'a1
	492	-> 'a1
	493	-> ('a1 -> 'a1 -> 'a1)
	494	-> ('a1 -> 'a1 -> 'a1)
	495	-> ('a1 -> 'a1 -> bool)
	496	-> 'a1 nFormula
	497	-> 'a1 nFormula
	498	-> 'a1 nFormula option
427	499
428	500	val nformula_plus_nformula :
429		'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1
430		nFormula option
	501	'a1
	502	-> ('a1 -> 'a1 -> 'a1)
	503	-> ('a1 -> 'a1 -> bool)
	504	-> 'a1 nFormula
	505	-> 'a1 nFormula
	506	-> 'a1 nFormula option
431	507
432	508	val eval_Psatz :
433		'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 ->
434		'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 nFormula option
	509	'a1
	510	-> 'a1
	511	-> ('a1 -> 'a1 -> 'a1)
	512	-> ('a1 -> 'a1 -> 'a1)
	513	-> ('a1 -> 'a1 -> bool)
	514	-> ('a1 -> 'a1 -> bool)
	515	-> 'a1 nFormula list
	516	-> 'a1 psatz
	517	-> 'a1 nFormula option
435	518
436	519	val check_inconsistent :
437	520	'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool
438	521
439	522	val check_normalised_formulas :
440		'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 ->
441		'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool
442
443		type op2 =
444		\| OpEq
445		\| OpNEq
446		\| OpLe
447		\| OpGe
448		\| OpLt
449		\| OpGt
450
451		type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr }
	523	'a1
	524	-> 'a1
	525	-> ('a1 -> 'a1 -> 'a1)
	526	-> ('a1 -> 'a1 -> 'a1)
	527	-> ('a1 -> 'a1 -> bool)
	528	-> ('a1 -> 'a1 -> bool)
	529	-> 'a1 nFormula list
	530	-> 'a1 psatz
	531	-> bool
	532
	533	type op2 = OpEq \| OpNEq \| OpLe \| OpGe \| OpLt \| OpGt
	534	type 't formula = {flhs : 't pExpr; fop : op2; frhs : 't pExpr}
452	535
453	536	val norm :
454		'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
455		'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol
	537	'a1
	538	-> 'a1
	539	-> ('a1 -> 'a1 -> 'a1)
	540	-> ('a1 -> 'a1 -> 'a1)
	541	-> ('a1 -> 'a1 -> 'a1)
	542	-> ('a1 -> 'a1)
	543	-> ('a1 -> 'a1 -> bool)
	544	-> 'a1 pExpr
	545	-> 'a1 pol
456	546
457	547	val psub0 :
458		'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) ->
459		'a1 pol -> 'a1 pol -> 'a1 pol
460
461		val padd0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol
	548	'a1
	549	-> ('a1 -> 'a1 -> 'a1)
	550	-> ('a1 -> 'a1 -> 'a1)
	551	-> ('a1 -> 'a1)
	552	-> ('a1 -> 'a1 -> bool)
	553	-> 'a1 pol
	554	-> 'a1 pol
	555	-> 'a1 pol
	556
	557	val padd0 :
	558	'a1
	559	-> ('a1 -> 'a1 -> 'a1)
	560	-> ('a1 -> 'a1 -> bool)
	561	-> 'a1 pol
	562	-> 'a1 pol
	563	-> 'a1 pol
462	564
463	565	val popp0 : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol
464	566
465	567	val normalise :
466		'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
467		'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula
	568	'a1
	569	-> 'a1
	570	-> ('a1 -> 'a1 -> 'a1)
	571	-> ('a1 -> 'a1 -> 'a1)
	572	-> ('a1 -> 'a1 -> 'a1)
	573	-> ('a1 -> 'a1)
	574	-> ('a1 -> 'a1 -> bool)
	575	-> 'a1 formula
	576	-> 'a1 nFormula
468	577
469	578	val xnormalise : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list
470
471	579	val xnegate : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list
472	580
473	581	val cnf_of_list :
474		'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a2 -> ('a1
475		nFormula, 'a2) cnf
	582	'a1
	583	-> ('a1 -> 'a1 -> bool)
	584	-> ('a1 -> 'a1 -> bool)
	585	-> 'a1 nFormula list
	586	-> 'a2
	587	-> ('a1 nFormula, 'a2) cnf
476	588
477	589	val cnf_normalise :
478		'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
479		'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula,
480		'a2) cnf
	590	'a1
	591	-> 'a1
	592	-> ('a1 -> 'a1 -> 'a1)
	593	-> ('a1 -> 'a1 -> 'a1)
	594	-> ('a1 -> 'a1 -> 'a1)
	595	-> ('a1 -> 'a1)
	596	-> ('a1 -> 'a1 -> bool)
	597	-> ('a1 -> 'a1 -> bool)
	598	-> 'a1 formula
	599	-> 'a2
	600	-> ('a1 nFormula, 'a2) cnf
481	601
482	602	val cnf_negate :
483		'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
484		'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula,
485		'a2) cnf
	603	'a1
	604	-> 'a1
	605	-> ('a1 -> 'a1 -> 'a1)
	606	-> ('a1 -> 'a1 -> 'a1)
	607	-> ('a1 -> 'a1 -> 'a1)
	608	-> ('a1 -> 'a1)
	609	-> ('a1 -> 'a1 -> bool)
	610	-> ('a1 -> 'a1 -> bool)
	611	-> 'a1 formula
	612	-> 'a2
	613	-> ('a1 nFormula, 'a2) cnf
486	614
487	615	val xdenorm : positive -> 'a1 pol -> 'a1 pExpr
488
489	616	val denorm : 'a1 pol -> 'a1 pExpr
490
491	617	val map_PExpr : ('a2 -> 'a1) -> 'a2 pExpr -> 'a1 pExpr
492
493	618	val map_Formula : ('a2 -> 'a1) -> 'a2 formula -> 'a1 formula
494	619
495	620	val simpl_cone :
496		'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz -> 'a1 psatz
497
498		module PositiveSet :
499		sig
500		type tree =
501		\| Leaf
502		\| Node of tree * bool * tree
503		end
504
505		type q = { qnum : z; qden : positive }
	621	'a1
	622	-> 'a1
	623	-> ('a1 -> 'a1 -> 'a1)
	624	-> ('a1 -> 'a1 -> bool)
	625	-> 'a1 psatz
	626	-> 'a1 psatz
	627
	628	type q = {qnum : z; qden : positive}
506	629
507	630	val qeq_bool : q -> q -> bool
508
509	631	val qle_bool : q -> q -> bool
510
511	632	val qplus : q -> q -> q
512
513	633	val qmult : q -> q -> q
514
515	634	val qopp : q -> q
516
517	635	val qminus : q -> q -> q
518
519	636	val qinv : q -> q
520
521	637	val qpower_positive : q -> positive -> q
522
523	638	val qpower : q -> z -> q
524	639
525		type 'a t =
526		\| Empty
527		\| Elt of 'a
528		\| Branch of 'a t * 'a * 'a t
	640	type 'a t = Empty \| Elt of 'a \| Branch of 'a t * 'a * 'a t
529	641
530	642	val find : 'a1 -> 'a1 t -> positive -> 'a1
531
532	643	val singleton : 'a1 -> positive -> 'a1 -> 'a1 t
533
534	644	val vm_add : 'a1 -> positive -> 'a1 -> 'a1 t -> 'a1 t
535
536	645	val zeval_const : z pExpr -> z option
537	646
538	647	type zWitness = z psatz
539	648
540	649	val zWeakChecker : z nFormula list -> z psatz -> bool
541
542	650	val psub1 : z pol -> z pol -> z pol
543
544	651	val padd1 : z pol -> z pol -> z pol
545
546	652	val normZ : z pExpr -> z pol
547
548	653	val zunsat : z nFormula -> bool
549
550	654	val zdeduce : z nFormula -> z nFormula -> z nFormula option
551
552	655	val xnnormalise : z formula -> z nFormula
553
554	656	val xnormalise0 : z nFormula -> z nFormula list
555
556	657	val cnf_of_list0 : 'a1 -> z nFormula list -> (z nFormula * 'a1) list list
557
558	658	val normalise0 : z formula -> 'a1 -> (z nFormula, 'a1) cnf
559
560	659	val xnegate0 : z nFormula -> z nFormula list
561
562	660	val negate : z formula -> 'a1 -> (z nFormula, 'a1) cnf
563	661
564		val cnfZ : (z formula, 'a1, 'a2, 'a3) tFormula -> (z nFormula, 'a1) cnf * 'a1 list
	662	val cnfZ :
	663	(z formula, 'a1, 'a2, 'a3) tFormula -> (z nFormula, 'a1) cnf * 'a1 list
565	664
566	665	val ceiling : z -> z -> z
567	666
568	667	type zArithProof =
569		\| DoneProof
570		\| RatProof of zWitness * zArithProof
571		\| CutProof of zWitness * zArithProof
572		\| EnumProof of zWitness * zWitness * zArithProof list
	668	\| DoneProof
	669	\| RatProof of zWitness * zArithProof
	670	\| CutProof of zWitness * zArithProof
	671	\| EnumProof of zWitness * zWitness * zArithProof list
	672	\| ExProof of positive * zArithProof
573	673
574	674	val zgcdM : z -> z -> z
575
576	675	val zgcd_pol : z polC -> z * z
577
578	676	val zdiv_pol : z polC -> z -> z polC
579
580	677	val makeCuttingPlane : z polC -> z polC * z
581
582	678	val genCuttingPlane : z nFormula -> ((z polC * z) * op1) option
583
584		val nformula_of_cutting_plane : ((z polC * z) * op1) -> z nFormula
585
	679	val nformula_of_cutting_plane : (z polC * z) * op1 -> z nFormula
586	680	val is_pol_Z0 : z polC -> bool
587
588	681	val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option
589
590	682	val valid_cut_sign : op1 -> bool
591
592		module Vars :
593		sig
594		type elt = positive
595
596		type tree = PositiveSet.tree =
597		\| Leaf
598		\| Node of tree * bool * tree
599
600		type t = tree
601
602		val empty : t
603
604		val add : elt -> t -> t
605
606		val singleton : elt -> t
607
608		val union : t -> t -> t
609
610		val rev_append : elt -> elt -> elt
611
612		val rev : elt -> elt
613
614		val xfold : (elt -> 'a1 -> 'a1) -> t -> 'a1 -> elt -> 'a1
615
616		val fold : (elt -> 'a1 -> 'a1) -> t -> 'a1 -> 'a1
617		end
618
619		val vars_of_pexpr : z pExpr -> Vars.t
620
621		val vars_of_formula : z formula -> Vars.t
622
623		val vars_of_bformula : (z formula, 'a1, 'a2, 'a3) gFormula -> Vars.t
624
625	683	val bound_var : positive -> z formula
626
627	684	val mk_eq_pos : positive -> positive -> positive -> z formula
628
629		val bound_vars :
630		(positive -> positive -> bool option -> 'a2) -> positive -> Vars.t -> (z formula, 'a1, 'a2,
631		'a3) gFormula
632
633		val bound_problem_fr :
634		(positive -> positive -> bool option -> 'a2) -> positive -> (z formula, 'a1, 'a2, 'a3)
635		gFormula -> (z formula, 'a1, 'a2, 'a3) gFormula
636
	685	val max_var : positive -> z pol -> positive
	686	val max_var_nformulae : z nFormula list -> positive
637	687	val zChecker : z nFormula list -> zArithProof -> bool
638
639	688	val zTautoChecker : z formula bFormula -> zArithProof list -> bool
640	689
641	690	type qWitness = q psatz
642	691
643	692	val qWeakChecker : q nFormula list -> q psatz -> bool
644
645	693	val qnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf
646
647	694	val qnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf
648
649	695	val qunsat : q nFormula -> bool
650
651	696	val qdeduce : q nFormula -> q nFormula -> q nFormula option
652
653	697	val normQ : q pExpr -> q pol
654	698
655		val cnfQ : (q formula, 'a1, 'a2, 'a3) tFormula -> (q nFormula, 'a1) cnf * 'a1 list
	699	val cnfQ :
	700	(q formula, 'a1, 'a2, 'a3) tFormula -> (q nFormula, 'a1) cnf * 'a1 list
656	701
657	702	val qTautoChecker : q formula bFormula -> qWitness list -> bool
658	703
659	704	type rcst =
660		\| C0
661		\| C1
662		\| CQ of q
663		\| CZ of z
664		\| CPlus of rcst * rcst
665		\| CMinus of rcst * rcst
666		\| CMult of rcst * rcst
667		\| CPow of rcst * (z, nat) sum
668		\| CInv of rcst
669		\| COpp of rcst
	705	\| C0
	706	\| C1
	707	\| CQ of q
	708	\| CZ of z
	709	\| CPlus of rcst * rcst
	710	\| CMinus of rcst * rcst
	711	\| CMult of rcst * rcst
	712	\| CPow of rcst * (z, nat) sum
	713	\| CInv of rcst
	714	\| COpp of rcst
670	715
671	716	val z_of_exp : (z, nat) sum -> z
672
673	717	val q_of_Rcst : rcst -> q
674	718
675	719	type rWitness = q psatz
676	720
677	721	val rWeakChecker : q nFormula list -> q psatz -> bool
678
679	722	val rnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf
680
681	723	val rnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf
682
683	724	val runsat : q nFormula -> bool
684
685	725	val rdeduce : q nFormula -> q nFormula -> q nFormula option
686
687	726	val rTautoChecker : rcst formula bFormula -> rWitness list -> bool

+286

-360

plugins/micromega/mutils.ml less more

20	20
21	21	module Int = struct
22	22	type t = int
	23
23	24	let compare : int -> int -> int = compare
24		let equal : int -> int -> bool = (=)
25		end
26
27		module ISet =
28		struct
29		include Set.Make(Int)
30
31		let pp o s = iter (fun i -> Printf.fprintf o "%i " i) s
32		end
33
34		module IMap =
35		struct
36		include Map.Make(Int)
37
38		let from k m =
39		let (_,_,r) = split (k-1) m in
40		r
41		end
	25	let equal : int -> int -> bool = ( = )
	26	end
	27
	28	module ISet = struct
	29	include Set.Make (Int)
	30
	31	let pp o s = iter (fun i -> Printf.fprintf o "%i " i) s
	32	end
	33
	34	module IMap = struct
	35	include Map.Make (Int)
	36
	37	let from k m =
	38	let _, _, r = split (k - 1) m in
	39	r
	40	end
42	41
43	42	let rec pp_list s f o l =
44	43	match l with
45		\| [] -> ()
46		\| [e] -> f o e
47		\| e::l -> f o e ; output_string o s ; pp_list s f o l
	44	\| [] -> ()
	45	\| [e] -> f o e
	46	\| e :: l -> f o e; output_string o s; pp_list s f o l
48	47
49	48	let finally f rst =
50	49	try
51	50	let res = f () in
52		rst () ; res
	51	rst (); res
53	52	with reraise ->
54		(try rst ()
55		with any -> raise reraise
56		); raise reraise
	53	(try rst () with any -> raise reraise);
	54	raise reraise
57	55
58	56	let rec try_any l x =
59		match l with
	57	match l with
60	58	\| [] -> None
61		\| (f,s)::l -> match f x with
62		\| None -> try_any l x
63		\| x -> x
	59	\| (f, s) :: l -> ( match f x with None -> try_any l x \| x -> x )
64	60
65	61	let all_pairs f l =
66		let pair_with acc e l = List.fold_left (fun acc x -> (f e x) ::acc) acc l in
67
	62	let pair_with acc e l = List.fold_left (fun acc x -> f e x :: acc) acc l in
68	63	let rec xpairs acc l =
69		match l with
70		\| [] -> acc
71		\| e::lx -> xpairs (pair_with acc e l) lx in
72		xpairs [] l
	64	match l with [] -> acc \| e :: lx -> xpairs (pair_with acc e l) lx
	65	in
	66	xpairs [] l
73	67
74	68	let rec is_sublist f l1 l2 =
75		match l1 ,l2 with
76		\| [] ,_ -> true
77		\| e::l1', [] -> false
78		\| e::l1' , e'::l2' ->
79		if f e e' then is_sublist f l1' l2'
80		else is_sublist f l1 l2'
	69	match (l1, l2) with
	70	\| [], _ -> true
	71	\| e :: l1', [] -> false
	72	\| e :: l1', e' :: l2' ->
	73	if f e e' then is_sublist f l1' l2' else is_sublist f l1 l2'
81	74
82	75	let extract pred l =
83		List.fold_left (fun (fd,sys) e ->
84		match fd with
85		\| None ->
86		begin
87		match pred e with
88		\| None -> fd, e::sys
89		\| Some v -> Some(v,e) , sys
90		end
91		\| _ -> (fd, e::sys)
92		) (None,[]) l
	76	List.fold_left
	77	(fun (fd, sys) e ->
	78	match fd with
	79	\| None -> (
	80	match pred e with None -> (fd, e :: sys) \| Some v -> (Some (v, e), sys)
	81	)
	82	\| _ -> (fd, e :: sys))
	83	(None, []) l
93	84
94	85	let extract_best red lt l =
95	86	let rec extractb c e rst l =
96	87	match l with
97		[] -> Some (c,e) , rst
98		\| e'::l' -> match red e' with
99		\| None -> extractb c e (e'::rst) l'
100		\| Some c' -> if lt c' c
101		then extractb c' e' (e::rst) l'
102		else extractb c e (e'::rst) l' in
	88	\| [] -> (Some (c, e), rst)
	89	\| e' :: l' -> (
	90	match red e' with
	91	\| None -> extractb c e (e' :: rst) l'
	92	\| Some c' ->
	93	if lt c' c then extractb c' e' (e :: rst) l'
	94	else extractb c e (e' :: rst) l' )
	95	in
103	96	match extract red l with
104		\| None , _ -> None,l
105		\| Some(c,e), rst -> extractb c e [] rst
106
	97	\| None, _ -> (None, l)
	98	\| Some (c, e), rst -> extractb c e [] rst
107	99
108	100	let rec find_option pred l =
109	101	match l with
110	102	\| [] -> raise Not_found
111		\| e::l -> match pred e with
112		\| Some r -> r
113		\| None -> find_option pred l
114
115		let find_some pred l =
116		try Some (find_option pred l) with Not_found -> None
117
118
119		let extract_all pred l =
120		List.fold_left (fun (s1,s2) e ->
121		match pred e with
122		\| None -> s1,e::s2
123		\| Some v -> (v,e)::s1 , s2) ([],[]) l
	103	\| e :: l -> ( match pred e with Some r -> r \| None -> find_option pred l )
	104
	105	let find_some pred l = try Some (find_option pred l) with Not_found -> None
	106
	107	let extract_all pred l =
	108	List.fold_left
	109	(fun (s1, s2) e ->
	110	match pred e with None -> (s1, e :: s2) \| Some v -> ((v, e) :: s1, s2))
	111	([], []) l
124	112
125	113	let simplify f sys =
126		let (sys',b) =
127		List.fold_left (fun (sys',b) c ->
128		match f c with
129		\| None -> (c::sys',b)
130		\| Some c' ->
131		(c'::sys',true)
132		) ([],false) sys in
	114	let sys', b =
	115	List.fold_left
	116	(fun (sys', b) c ->
	117	match f c with None -> (c :: sys', b) \| Some c' -> (c' :: sys', true))
	118	([], false) sys
	119	in
133	120	if b then Some sys' else None
134	121
135	122	let generate_acc f acc sys =
136		List.fold_left (fun sys' c -> match f c with
137		\| None -> sys'
138		\| Some c' -> c'::sys'
139		) acc sys
140
	123	List.fold_left
	124	(fun sys' c -> match f c with None -> sys' \| Some c' -> c' :: sys')
	125	acc sys
141	126
142	127	let generate f sys = generate_acc f [] sys
143	128
144
145	129	let saturate p f sys =
146		let rec sat acc l =
	130	let rec sat acc l =
147	131	match extract p l with
148		\| None,_ -> acc
149		\| Some r,l' ->
150		let n = generate (f r) (l'@acc) in
151		sat (n@acc) l' in
152		try sat [] sys with
153		x ->
154		begin
155		Printexc.print_backtrace stdout ;
156		raise x
157		end
158
	132	\| None, _ -> acc
	133	\| Some r, l' ->
	134	let n = generate (f r) (l' @ acc) in
	135	sat (n @ acc) l'
	136	in
	137	try sat [] sys
	138	with x ->
	139	Printexc.print_backtrace stdout;
	140	raise x
159	141
160	142	open Num
161	143	open Big_int
162	144
163	145	let ppcm x y =
164		let g = gcd_big_int x y in
165		let x' = div_big_int x g in
166		let y' = div_big_int y g in
	146	let g = gcd_big_int x y in
	147	let x' = div_big_int x g in
	148	let y' = div_big_int y g in
167	149	mult_big_int g (mult_big_int x' y')
168	150
169	151	let denominator = function
170		\| Int _ \| Big_int _ -> unit_big_int
171		\| Ratio r -> Ratio.denominator_ratio r
	152	\| Int _ \| Big_int _ -> unit_big_int
	153	\| Ratio r -> Ratio.denominator_ratio r
172	154
173	155	let numerator = function
174		\| Ratio r -> Ratio.numerator_ratio r
175		\| Int i -> Big_int.big_int_of_int i
176		\| Big_int i -> i
	156	\| Ratio r -> Ratio.numerator_ratio r
	157	\| Int i -> Big_int.big_int_of_int i
	158	\| Big_int i -> i
177	159
178	160	let iterate_until_stable f x =
179		let rec iter x =
180		match f x with
181		\| None -> x
182		\| Some x' -> iter x' in
183		iter x
	161	let rec iter x = match f x with None -> x \| Some x' -> iter x' in
	162	iter x
184	163
185	164	let rec app_funs l x =
186		match l with
187		\| [] -> None
188		\| f::fl ->
189		match f x with
190		\| None -> app_funs fl x
191		\| Some x' -> Some x'
192
	165	match l with
	166	\| [] -> None
	167	\| f :: fl -> ( match f x with None -> app_funs fl x \| Some x' -> Some x' )
193	168
194	169	(**
195	170	* MODULE: Coq to Caml data-structure mappings
196	171	*)
197	172
198		module CoqToCaml =
199		struct
200		open Micromega
201
202		let rec nat = function
203		\| O -> 0
204		\| S n -> (nat n) + 1
205
206
207		let rec positive p =
208		match p with
209		\| XH -> 1
210		\| XI p -> 1+ 2*(positive p)
211		\| XO p -> 2*(positive p)
212
213		let n nt =
214		match nt with
215		\| N0 -> 0
216		\| Npos p -> positive p
217
218		let rec index i = (* Swap left-right ? *)
219		match i with
220		\| XH -> 1
221		\| XI i -> 1+(2*(index i))
222		\| XO i -> 2*(index i)
223
224		open Big_int
225
226		let rec positive_big_int p =
227		match p with
228		\| XH -> unit_big_int
229		\| XI p -> add_int_big_int 1 (mult_int_big_int 2 (positive_big_int p))
230		\| XO p -> (mult_int_big_int 2 (positive_big_int p))
231
232		let z_big_int x =
233		match x with
234		\| Z0 -> zero_big_int
235		\| Zpos p -> (positive_big_int p)
236		\| Zneg p -> minus_big_int (positive_big_int p)
237
238		let z x =
239		match x with
240		\| Z0 -> 0
241		\| Zpos p -> index p
242		\| Zneg p -> - (index p)
243
244
245		let q_to_num {qnum = x ; qden = y} =
246		Big_int (z_big_int x) // (Big_int (z_big_int (Zpos y)))
247
248		end
249
	173	module CoqToCaml = struct
	174	open Micromega
	175
	176	let rec nat = function O -> 0 \| S n -> nat n + 1
	177
	178	let rec positive p =
	179	match p with
	180	\| XH -> 1
	181	\| XI p -> 1 + (2 * positive p)
	182	\| XO p -> 2 * positive p
	183
	184	let n nt = match nt with N0 -> 0 \| Npos p -> positive p
	185
	186	let rec index i =
	187	(* Swap left-right ? *)
	188	match i with XH -> 1 \| XI i -> 1 + (2 * index i) \| XO i -> 2 * index i
	189
	190	open Big_int
	191
	192	let rec positive_big_int p =
	193	match p with
	194	\| XH -> unit_big_int
	195	\| XI p -> add_int_big_int 1 (mult_int_big_int 2 (positive_big_int p))
	196	\| XO p -> mult_int_big_int 2 (positive_big_int p)
	197
	198	let z_big_int x =
	199	match x with
	200	\| Z0 -> zero_big_int
	201	\| Zpos p -> positive_big_int p
	202	\| Zneg p -> minus_big_int (positive_big_int p)
	203
	204	let z x = match x with Z0 -> 0 \| Zpos p -> index p \| Zneg p -> -index p
	205
	206	let q_to_num {qnum = x; qden = y} =
	207	Big_int (z_big_int x) // Big_int (z_big_int (Zpos y))
	208	end
250	209
251	210	(**
252	211	* MODULE: Caml to Coq data-structure mappings
253	212	*)
254	213
255		module CamlToCoq =
256		struct
257		open Micromega
258
259		let rec nat = function
260		\| 0 -> O
261		\| n -> S (nat (n-1))
262
263
264		let rec positive n =
265		if Int.equal n 1 then XH
266		else if Int.equal (n land 1) 1 then XI (positive (n lsr 1))
267		else XO (positive (n lsr 1))
268
269		let n nt =
270		if nt < 0
271		then assert false
272		else if Int.equal nt 0 then N0
273		else Npos (positive nt)
274
275		let rec index n =
276		if Int.equal n 1 then XH
277		else if Int.equal (n land 1) 1 then XI (index (n lsr 1))
278		else XO (index (n lsr 1))
279
280
281		let z x =
282		match compare x 0 with
283		\| 0 -> Z0
284		\| 1 -> Zpos (positive x)
285		\| _ -> (* this should be -1 *)
	214	module CamlToCoq = struct
	215	open Micromega
	216
	217	let rec nat = function 0 -> O \| n -> S (nat (n - 1))
	218
	219	let rec positive n =
	220	if Int.equal n 1 then XH
	221	else if Int.equal (n land 1) 1 then XI (positive (n lsr 1))
	222	else XO (positive (n lsr 1))
	223
	224	let n nt =
	225	if nt < 0 then assert false
	226	else if Int.equal nt 0 then N0
	227	else Npos (positive nt)
	228
	229	let rec index n =
	230	if Int.equal n 1 then XH
	231	else if Int.equal (n land 1) 1 then XI (index (n lsr 1))
	232	else XO (index (n lsr 1))
	233
	234	let z x =
	235	match compare x 0 with
	236	\| 0 -> Z0
	237	\| 1 -> Zpos (positive x)
	238	\| _ ->
	239	(* this should be -1 *)
286	240	Zneg (positive (-x))
287	241
288		open Big_int
289
290		let positive_big_int n =
291		let two = big_int_of_int 2 in
292		let rec _pos n =
293		if eq_big_int n unit_big_int then XH
294		else
295		let (q,m) = quomod_big_int n two in
296		if eq_big_int unit_big_int m
297		then XI (_pos q)
298		else XO (_pos q) in
299		_pos n
300
301		let bigint x =
302		match sign_big_int x with
303		\| 0 -> Z0
304		\| 1 -> Zpos (positive_big_int x)
305		\| _ -> Zneg (positive_big_int (minus_big_int x))
306
307		let q n =
308		{Micromega.qnum = bigint (numerator n) ;
309		Micromega.qden = positive_big_int (denominator n)}
310
	242	open Big_int
	243
	244	let positive_big_int n =
	245	let two = big_int_of_int 2 in
	246	let rec _pos n =
	247	if eq_big_int n unit_big_int then XH
	248	else
	249	let q, m = quomod_big_int n two in
	250	if eq_big_int unit_big_int m then XI (_pos q) else XO (_pos q)
	251	in
	252	_pos n
	253
	254	let bigint x =
	255	match sign_big_int x with
	256	\| 0 -> Z0
	257	\| 1 -> Zpos (positive_big_int x)
	258	\| _ -> Zneg (positive_big_int (minus_big_int x))
	259
	260	let q n =
	261	{ Micromega.qnum = bigint (numerator n)
	262	; Micromega.qden = positive_big_int (denominator n) }
311	263	end
312	264
313	265	(**

315	267	* between two lists given an ordering, and using a hash computation
316	268	*)
317	269
318		module Cmp =
319		struct
320
321		let rec compare_lexical l =
322		match l with
323		\| [] -> 0 (* Equal *)
324		\| f::l ->
	270	module Cmp = struct
	271	let rec compare_lexical l =
	272	match l with
	273	\| [] -> 0 (* Equal *)
	274	\| f :: l ->
325	275	let cmp = f () in
326		if Int.equal cmp 0 then compare_lexical l else cmp
327
328		let rec compare_list cmp l1 l2 =
329		match l1 , l2 with
330		\| [] , [] -> 0
331		\| [] , _ -> -1
332		\| _ , [] -> 1
333		\| e1::l1 , e2::l2 ->
	276	if Int.equal cmp 0 then compare_lexical l else cmp
	277
	278	let rec compare_list cmp l1 l2 =
	279	match (l1, l2) with
	280	\| [], [] -> 0
	281	\| [], _ -> -1
	282	\| _, [] -> 1
	283	\| e1 :: l1, e2 :: l2 ->
334	284	let c = cmp e1 e2 in
335		if Int.equal c 0 then compare_list cmp l1 l2 else c
336
	285	if Int.equal c 0 then compare_list cmp l1 l2 else c
337	286	end
338	287
339	288	(**

343	292	* superfluous items, which speeds the translation up a bit.
344	293	*)
345	294
346		module type Tag =
347		sig
348
349		type t
	295	module type Tag = sig
	296	type t = int
350	297
351	298	val from : int -> t
352	299	val next : t -> t
353	300	val pp : out_channel -> t -> unit
354	301	val compare : t -> t -> int
355	302	val max : t -> t -> t
356		val to_int : t -> int
357		end
358
359		module Tag : Tag =
360		struct
361
	303	val to_int : t -> int
	304	end
	305
	306	module Tag : Tag = struct
362	307	type t = int
363	308
364	309	let from i = i

367	312	let pp o i = output_string o (string_of_int i)
368	313	let compare : int -> int -> int = Int.compare
369	314	let to_int x = x
370
371	315	end
372	316
373	317	(**
374	318	* MODULE: Ordered sets of tags.
375	319	*)
376	320
377		module TagSet = Set.Make(Tag)
	321	module TagSet = struct
	322	include Set.Make (Tag)
	323	end
378	324
379	325	(** As for Unix.close_process, our Unix.waipid will ignore all EINTR *)
380	326

388	334
389	335	let command exe_path args vl =
390	336	(* creating pipes for stdin, stdout, stderr *)
391		let (stdin_read,stdin_write) = Unix.pipe ()
392		and (stdout_read,stdout_write) = Unix.pipe ()
393		and (stderr_read,stderr_write) = Unix.pipe () in
394
	337	let stdin_read, stdin_write = Unix.pipe ()
	338	and stdout_read, stdout_write = Unix.pipe ()
	339	and stderr_read, stderr_write = Unix.pipe () in
395	340	(* Create the process *)
396		let pid = Unix.create_process exe_path args stdin_read stdout_write stderr_write in
397
	341	let pid =
	342	Unix.create_process exe_path args stdin_read stdout_write stderr_write
	343	in
398	344	(* Write the data on the stdin of the created process *)
399	345	let outch = Unix.out_channel_of_descr stdin_write in
400		output_value outch vl ;
401		flush outch ;
402
	346	output_value outch vl;
	347	flush outch;
403	348	(* Wait for its completion *)
404		let status = waitpid_non_intr pid in
405
406		finally
407		(* Recover the result *)
408		(fun () ->
409		match status with
410		\| Unix.WEXITED 0 ->
411		let inch = Unix.in_channel_of_descr stdout_read in
412		begin
413		try Marshal.from_channel inch
414		with any ->
415		failwith
416		(Printf.sprintf "command \"%s\" exited %s" exe_path
417		(Printexc.to_string any))
418		end
419		\| Unix.WEXITED i ->
420		failwith (Printf.sprintf "command \"%s\" exited %i" exe_path i)
421		\| Unix.WSIGNALED i ->
422		failwith (Printf.sprintf "command \"%s\" killed %i" exe_path i)
423		\| Unix.WSTOPPED i ->
424		failwith (Printf.sprintf "command \"%s\" stopped %i" exe_path i))
425		(* Cleanup *)
426		(fun () ->
427		List.iter (fun x -> try Unix.close x with any -> ())
428		[stdin_read; stdin_write;
429		stdout_read; stdout_write;
430		stderr_read; stderr_write])
	349	let status = waitpid_non_intr pid in
	350	finally
	351	(* Recover the result *)
	352	(fun () ->
	353	match status with
	354	\| Unix.WEXITED 0 -> (
	355	let inch = Unix.in_channel_of_descr stdout_read in
	356	try Marshal.from_channel inch
	357	with any ->
	358	failwith
	359	(Printf.sprintf "command \"%s\" exited %s" exe_path
	360	(Printexc.to_string any)) )
	361	\| Unix.WEXITED i ->
	362	failwith (Printf.sprintf "command \"%s\" exited %i" exe_path i)
	363	\| Unix.WSIGNALED i ->
	364	failwith (Printf.sprintf "command \"%s\" killed %i" exe_path i)
	365	\| Unix.WSTOPPED i ->
	366	failwith (Printf.sprintf "command \"%s\" stopped %i" exe_path i))
	367	(* Cleanup *)
	368	(fun () ->
	369	List.iter
	370	(fun x -> try Unix.close x with any -> ())
	371	[ stdin_read
	372	; stdin_write
	373	; stdout_read
	374	; stdout_write
	375	; stderr_read
	376	; stderr_write ])
431	377
432	378	(** Hashing utilities *)
433	379
434		module Hash =
435		struct
436
437		module Mc = Micromega
438
439		open Hashset.Combine
440
441		let int_of_eq_op1 = Mc.(function
442		\| Equal -> 0
443		\| NonEqual -> 1
444		\| Strict -> 2
445		\| NonStrict -> 3)
446
447		let eq_op1 o1 o2 = int_of_eq_op1 o1 = int_of_eq_op1 o2
448
449		let hash_op1 h o = combine h (int_of_eq_op1 o)
450
451
452		let rec eq_positive p1 p2 =
453		match p1 , p2 with
454		\| Mc.XH , Mc.XH -> true
455		\| Mc.XI p1 , Mc.XI p2 -> eq_positive p1 p2
456		\| Mc.XO p1 , Mc.XO p2 -> eq_positive p1 p2
457		\| _ , _ -> false
458
459		let eq_z z1 z2 =
460		match z1 , z2 with
461		\| Mc.Z0 , Mc.Z0 -> true
462		\| Mc.Zpos p1, Mc.Zpos p2
463		\| Mc.Zneg p1, Mc.Zneg p2 -> eq_positive p1 p2
464		\| _ , _ -> false
465
466		let eq_q {Mc.qnum = qn1 ; Mc.qden = qd1} {Mc.qnum = qn2 ; Mc.qden = qd2} =
467		eq_z qn1 qn2 && eq_positive qd1 qd2
468
469		let rec eq_pol eq p1 p2 =
470		match p1 , p2 with
471		\| Mc.Pc c1 , Mc.Pc c2 -> eq c1 c2
472		\| Mc.Pinj(i1,p1) , Mc.Pinj(i2,p2) -> eq_positive i1 i2 && eq_pol eq p1 p2
473		\| Mc.PX(p1,i1,p1') , Mc.PX(p2,i2,p2') ->
474		eq_pol eq p1 p2 && eq_positive i1 i2 && eq_pol eq p1' p2'
475		\| _ , _ -> false
476
477
478		let eq_pair eq1 eq2 (x1,y1) (x2,y2) =
479		eq1 x1 x2 && eq2 y1 y2
480
481
482		let hash_pol helt =
483		let rec hash acc = function
484		\| Mc.Pc c -> helt (combine acc 1) c
485		\| Mc.Pinj(p,c) -> hash (combine (combine acc 1) (CoqToCaml.index p)) c
486		\| Mc.PX(p1,i,p2) -> hash (hash (combine (combine acc 2) (CoqToCaml.index i)) p1) p2 in
487		hash
488
489
490		let hash_pair h1 h2 h (e1,e2) =
491		h2 (h1 h e1) e2
492
493		let hash_elt f h e = combine h (f e)
494
495		let hash_string h (e:string) = hash_elt Hashtbl.hash h e
496
497		let hash_z = hash_elt CoqToCaml.z
498
499		let hash_q = hash_elt (fun q -> Hashtbl.hash (CoqToCaml.q_to_num q))
500
501		end
502
503
504
	380	module Hash = struct
	381	module Mc = Micromega
	382	open Hashset.Combine
	383
	384	let int_of_eq_op1 =
	385	Mc.(function Equal -> 0 \| NonEqual -> 1 \| Strict -> 2 \| NonStrict -> 3)
	386
	387	let eq_op1 o1 o2 = int_of_eq_op1 o1 = int_of_eq_op1 o2
	388	let hash_op1 h o = combine h (int_of_eq_op1 o)
	389
	390	let rec eq_positive p1 p2 =
	391	match (p1, p2) with
	392	\| Mc.XH, Mc.XH -> true
	393	\| Mc.XI p1, Mc.XI p2 -> eq_positive p1 p2
	394	\| Mc.XO p1, Mc.XO p2 -> eq_positive p1 p2
	395	\| _, _ -> false
	396
	397	let eq_z z1 z2 =
	398	match (z1, z2) with
	399	\| Mc.Z0, Mc.Z0 -> true
	400	\| Mc.Zpos p1, Mc.Zpos p2 \| Mc.Zneg p1, Mc.Zneg p2 -> eq_positive p1 p2
	401	\| _, _ -> false
	402
	403	let eq_q {Mc.qnum = qn1; Mc.qden = qd1} {Mc.qnum = qn2; Mc.qden = qd2} =
	404	eq_z qn1 qn2 && eq_positive qd1 qd2
	405
	406	let rec eq_pol eq p1 p2 =
	407	match (p1, p2) with
	408	\| Mc.Pc c1, Mc.Pc c2 -> eq c1 c2
	409	\| Mc.Pinj (i1, p1), Mc.Pinj (i2, p2) -> eq_positive i1 i2 && eq_pol eq p1 p2
	410	\| Mc.PX (p1, i1, p1'), Mc.PX (p2, i2, p2') ->
	411	eq_pol eq p1 p2 && eq_positive i1 i2 && eq_pol eq p1' p2'
	412	\| _, _ -> false
	413
	414	let eq_pair eq1 eq2 (x1, y1) (x2, y2) = eq1 x1 x2 && eq2 y1 y2
	415
	416	let hash_pol helt =
	417	let rec hash acc = function
	418	\| Mc.Pc c -> helt (combine acc 1) c
	419	\| Mc.Pinj (p, c) -> hash (combine (combine acc 1) (CoqToCaml.index p)) c
	420	\| Mc.PX (p1, i, p2) ->
	421	hash (hash (combine (combine acc 2) (CoqToCaml.index i)) p1) p2
	422	in
	423	hash
	424
	425	let hash_pair h1 h2 h (e1, e2) = h2 (h1 h e1) e2
	426	let hash_elt f h e = combine h (f e)
	427	let hash_string h (e : string) = hash_elt Hashtbl.hash h e
	428	let hash_z = hash_elt CoqToCaml.z
	429	let hash_q = hash_elt (fun q -> Hashtbl.hash (CoqToCaml.q_to_num q))
	430	end
505	431
506	432	(* Local Variables: *)
507	433	(* coding: utf-8 *)

+35

-48

plugins/micromega/mutils.mli less more

7	7	(* * (see LICENSE file for the text of the license) *)
8	8	(************************************************************************)
9	9
10		module Int : sig type t = int val compare : int -> int -> int val equal : int -> int -> bool end
	10	module Int : sig
	11	type t = int
11	12
	13	val compare : int -> int -> int
	14	val equal : int -> int -> bool
	15	end
12	16
13	17	module ISet : sig
14	18	include Set.S with type elt = int
	19
15	20	val pp : out_channel -> t -> unit
16	21	end
17	22
18		module IMap :
19		sig
	23	module IMap : sig
20	24	include Map.S with type key = int
21	25
	26	val from : key -> 'elt t -> 'elt t
22	27	(** [from k m] returns the submap of [m] with keys greater or equal k *)
23		val from : key -> 'elt t -> 'elt t
24
25	28	end
26	29
27	30	val numerator : Num.num -> Big_int.big_int
28	31	val denominator : Num.num -> Big_int.big_int
29	32
30	33	module Cmp : sig
31
32	34	val compare_list : ('a -> 'b -> int) -> 'a list -> 'b list -> int
33	35	val compare_lexical : (unit -> int) list -> int
34
35	36	end
36	37
37	38	module Tag : sig
38
39	39	type t
40	40
41	41	val pp : out_channel -> t -> unit
42	42	val next : t -> t
43		val max : t -> t -> t
	43	val max : t -> t -> t
44	44	val from : int -> t
45	45	val to_int : t -> int
46
47	46	end
48	47
49	48	module TagSet : CSig.SetS with type elt = Tag.t
50	49
51		val pp_list : string -> (out_channel -> 'a -> unit) -> out_channel -> 'a list -> unit
	50	val pp_list :
	51	string -> (out_channel -> 'a -> unit) -> out_channel -> 'a list -> unit
52	52
53	53	module CamlToCoq : sig
54
55	54	val positive : int -> Micromega.positive
56	55	val bigint : Big_int.big_int -> Micromega.z
57	56	val n : int -> Micromega.n

60	59	val index : int -> Micromega.positive
61	60	val z : int -> Micromega.z
62	61	val positive_big_int : Big_int.big_int -> Micromega.positive
63
64	62	end
65	63
66	64	module CoqToCaml : sig
67
68	65	val z_big_int : Micromega.z -> Big_int.big_int
69		val z : Micromega.z -> int
70		val q_to_num : Micromega.q -> Num.num
71		val positive : Micromega.positive -> int
72		val n : Micromega.n -> int
73		val nat : Micromega.nat -> int
74		val index : Micromega.positive -> int
75
	66	val z : Micromega.z -> int
	67	val q_to_num : Micromega.q -> Num.num
	68	val positive : Micromega.positive -> int
	69	val n : Micromega.n -> int
	70	val nat : Micromega.nat -> int
	71	val index : Micromega.positive -> int
76	72	end
77	73
78	74	module Hash : sig
79
80		val eq_op1 : Micromega.op1 -> Micromega.op1 -> bool
81
	75	val eq_op1 : Micromega.op1 -> Micromega.op1 -> bool
82	76	val eq_positive : Micromega.positive -> Micromega.positive -> bool
83
84	77	val eq_z : Micromega.z -> Micromega.z -> bool
85
86	78	val eq_q : Micromega.q -> Micromega.q -> bool
87	79
88		val eq_pol : ('a -> 'a -> bool) -> 'a Micromega.pol -> 'a Micromega.pol -> bool
	80	val eq_pol :
	81	('a -> 'a -> bool) -> 'a Micromega.pol -> 'a Micromega.pol -> bool
89	82
90		val eq_pair : ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> 'a * 'b -> 'a * 'b -> bool
	83	val eq_pair :
	84	('a -> 'a -> bool) -> ('b -> 'b -> bool) -> 'a * 'b -> 'a * 'b -> bool
91	85
92	86	val hash_op1 : int -> Micromega.op1 -> int
	87	val hash_pol : (int -> 'a -> int) -> int -> 'a Micromega.pol -> int
93	88
94		val hash_pol : (int -> 'a -> int) -> int -> 'a Micromega.pol -> int
	89	val hash_pair :
	90	(int -> 'a -> int) -> (int -> 'b -> int) -> int -> 'a * 'b -> int
95	91
96		val hash_pair : (int -> 'a -> int) -> (int -> 'b -> int) -> int -> 'a * 'b -> int
97
98		val hash_z : int -> Micromega.z -> int
99
100		val hash_q : int -> Micromega.q -> int
101
	92	val hash_z : int -> Micromega.z -> int
	93	val hash_q : int -> Micromega.q -> int
102	94	val hash_string : int -> string -> int
103
104	95	val hash_elt : ('a -> int) -> int -> 'a -> int
105
106	96	end
107	97
108
109	98	val ppcm : Big_int.big_int -> Big_int.big_int -> Big_int.big_int
110
111	99	val all_pairs : ('a -> 'a -> 'b) -> 'a list -> 'b list
112	100	val try_any : (('a -> 'b option) * 'c) list -> 'a -> 'b option
113	101	val is_sublist : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
114
115	102	val extract : ('a -> 'b option) -> 'a list -> ('b * 'a) option * 'a list
116
117	103	val extract_all : ('a -> 'b option) -> 'a list -> ('b * 'a) list * 'a list
118	104
119		val extract_best : ('a -> 'b option) -> ('b -> 'b -> bool) -> 'a list -> ('b 'a) option 'a list
	105	val extract_best :
	106	('a -> 'b option)
	107	-> ('b -> 'b -> bool)
	108	-> 'a list
	109	-> ('b * 'a) option * 'a list
120	110
121		val find_some : ('a -> 'b option) -> 'a list -> 'b option
122
	111	val find_some : ('a -> 'b option) -> 'a list -> 'b option
123	112	val iterate_until_stable : ('a -> 'a option) -> 'a -> 'a
124
125	113	val simplify : ('a -> 'a option) -> 'a list -> 'a list option
126	114
127		val saturate : ('a -> 'b option) -> ('b * 'a -> 'a -> 'a option) -> 'a list -> 'a list
	115	val saturate :
	116	('a -> 'b option) -> ('b * 'a -> 'a -> 'a option) -> 'a list -> 'a list
128	117
129	118	val generate : ('a -> 'b option) -> 'a list -> 'b list
130
131	119	val app_funs : ('a -> 'b option) list -> 'a -> 'b option
132
133	120	val command : string -> string array -> 'a -> 'b

+106

-155

plugins/micromega/persistent_cache.ml less more

13	13	(* *)
14	14	(************************************************************************)
15	15
16		module type PHashtable =
17		sig
18		(* see documentation in [persistent_cache.mli] *)
19		type 'a t
20		type key
	16	module type PHashtable = sig
	17	(* see documentation in [persistent_cache.mli] *)
	18	type 'a t
	19	type key
21	20
22		val open_in : string -> 'a t
23
24		val find : 'a t -> key -> 'a
25
26		val add : 'a t -> key -> 'a -> unit
27
28		val memo : string -> (key -> 'a) -> (key -> 'a)
29
30		val memo_cond : string -> (key -> bool) -> (key -> 'a) -> (key -> 'a)
31
32		end
	21	val open_in : string -> 'a t
	22	val find : 'a t -> key -> 'a
	23	val add : 'a t -> key -> 'a -> unit
	24	val memo : string -> (key -> 'a) -> key -> 'a
	25	val memo_cond : string -> (key -> bool) -> (key -> 'a) -> key -> 'a
	26	end
33	27
34	28	open Hashtbl
35	29
36		module PHashtable(Key:HashedType) : PHashtable with type key = Key.t =
37		struct
	30	module PHashtable (Key : HashedType) : PHashtable with type key = Key.t = struct
38	31	open Unix
39	32
40	33	type key = Key.t
41	34
42		module Table = Hashtbl.Make(Key)
	35	module Table = Hashtbl.Make (Key)
43	36
44	37	exception InvalidTableFormat
45	38	exception UnboundTable
46	39
47	40	type mode = Closed \| Open
	41	type 'a t = {outch : out_channel; mutable status : mode; htbl : 'a Table.t}
48	42
49		type 'a t =
50		{
51		outch : out_channel ;
52		mutable status : mode ;
53		htbl : 'a Table.t
54		}
	43	let finally f rst =
	44	try
	45	let res = f () in
	46	rst (); res
	47	with reraise ->
	48	(try rst () with any -> raise reraise);
	49	raise reraise
55	50
56
57		let finally f rst =
58		try
59		let res = f () in
60		rst () ; res
61		with reraise ->
62		(try rst ()
63		with any -> raise reraise
64		); raise reraise
65
66
67		let read_key_elem inch =
68		try
69		Some (Marshal.from_channel inch)
70		with
	51	let read_key_elem inch =
	52	try Some (Marshal.from_channel inch) with
71	53	\| End_of_file -> None
72	54	\| e when CErrors.noncritical e -> raise InvalidTableFormat
73	55
74		(**
	56	(**
75	57	We used to only lock/unlock regions.
76	58	Is-it more robust/portable to lock/unlock a fixed region e.g. [0;1]?
77	59	In case of locking failure, the cache is not used.
78	60	**)
79	61
80		type lock_kind = Read \| Write
	62	type lock_kind = Read \| Write
81	63
82		let lock kd fd =
83		let pos = lseek fd 0 SEEK_CUR in
84		let success =
85		try
86		ignore (lseek fd 0 SEEK_SET);
87		let lk = match kd with
88		\| Read -> F_RLOCK
89		\| Write -> F_LOCK in
90		lockf fd lk 1; true
91		with Unix.Unix_error(_,_,_) -> false in
92		ignore (lseek fd pos SEEK_SET) ;
93		success
	64	let lock kd fd =
	65	let pos = lseek fd 0 SEEK_CUR in
	66	let success =
	67	try
	68	ignore (lseek fd 0 SEEK_SET);
	69	let lk = match kd with Read -> F_RLOCK \| Write -> F_LOCK in
	70	lockf fd lk 1; true
	71	with Unix.Unix_error (_, _, _) -> false
	72	in
	73	ignore (lseek fd pos SEEK_SET);
	74	success
94	75
95		let unlock fd =
96		let pos = lseek fd 0 SEEK_CUR in
97		try
98		ignore (lseek fd 0 SEEK_SET) ;
99		lockf fd F_ULOCK 1
100		with
101		Unix.Unix_error(_,_,_) -> ()
102		(* Here, this is really bad news --
	76	let unlock fd =
	77	let pos = lseek fd 0 SEEK_CUR in
	78	try
	79	ignore (lseek fd 0 SEEK_SET);
	80	lockf fd F_ULOCK 1
	81	with Unix.Unix_error (_, _, _) ->
	82	()
	83	(* Here, this is really bad news --
103	84	there is a pending lock which could cause a deadlock.
104	85	Should it be an anomaly or produce a warning ?
105	86	*);
106		ignore (lseek fd pos SEEK_SET)
	87	ignore (lseek fd pos SEEK_SET)
107	88
	89	(* We make the assumption that an acquired lock can always be released *)
108	90
109		(* We make the assumption that an acquired lock can always be released *)
	91	let do_under_lock kd fd f =
	92	if lock kd fd then finally f (fun () -> unlock fd) else f ()
110	93
111		let do_under_lock kd fd f =
112		if lock kd fd
113		then
114		finally f (fun () -> unlock fd)
115		else f ()
116
117
118
119		let open_in f =
120		let flags = [O_RDONLY ; O_CREAT] in
121		let finch = openfile f flags 0o666 in
122		let inch = in_channel_of_descr finch in
123		let htbl = Table.create 100 in
124
125		let rec xload () =
126		match read_key_elem inch with
	94	let open_in f =
	95	let flags = [O_RDONLY; O_CREAT] in
	96	let finch = openfile f flags 0o666 in
	97	let inch = in_channel_of_descr finch in
	98	let htbl = Table.create 100 in
	99	let rec xload () =
	100	match read_key_elem inch with
127	101	\| None -> ()
128		\| Some (key,elem) ->
129		Table.add htbl key elem ;
130		xload () in
	102	\| Some (key, elem) -> Table.add htbl key elem; xload ()
	103	in
131	104	try
132	105	(* Locking of the (whole) file while reading *)
133		do_under_lock Read finch xload ;
134		close_in_noerr inch ;
135		{
136		outch = out_channel_of_descr (openfile f [O_WRONLY;O_APPEND;O_CREAT] 0o666) ;
137		status = Open ;
138		htbl = htbl
139		}
	106	do_under_lock Read finch xload;
	107	close_in_noerr inch;
	108	{ outch =
	109	out_channel_of_descr (openfile f [O_WRONLY; O_APPEND; O_CREAT] 0o666)
	110	; status = Open
	111	; htbl }
140	112	with InvalidTableFormat ->
141		(* The file is corrupted *)
142		begin
143		close_in_noerr inch ;
144		let flags = [O_WRONLY; O_TRUNC;O_CREAT] in
145		let out = (openfile f flags 0o666) in
	113	(* The file is corrupted *)
	114	close_in_noerr inch;
	115	let flags = [O_WRONLY; O_TRUNC; O_CREAT] in
	116	let out = openfile f flags 0o666 in
146	117	let outch = out_channel_of_descr out in
147		do_under_lock Write out
148		(fun () ->
149		Table.iter
150		(fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl;
151		flush outch) ;
152		{ outch = outch ;
153		status = Open ;
154		htbl = htbl
155		}
156		end
	118	do_under_lock Write out (fun () ->
	119	Table.iter
	120	(fun k e -> Marshal.to_channel outch (k, e) [Marshal.No_sharing])
	121	htbl;
	122	flush outch);
	123	{outch; status = Open; htbl}
157	124
158
159		let add t k e =
160		let {outch = outch ; status = status ; htbl = tbl} = t in
161		if status == Closed
162		then raise UnboundTable
	125	let add t k e =
	126	let {outch; status; htbl = tbl} = t in
	127	if status == Closed then raise UnboundTable
163	128	else
164	129	let fd = descr_of_out_channel outch in
165		begin
166		Table.add tbl k e ;
167		do_under_lock Write fd
168		(fun _ ->
169		Marshal.to_channel outch (k,e) [Marshal.No_sharing] ;
170		flush outch
171		)
172		end
	130	Table.add tbl k e;
	131	do_under_lock Write fd (fun _ ->
	132	Marshal.to_channel outch (k, e) [Marshal.No_sharing];
	133	flush outch)
173	134
174		let find t k =
175		let {outch = outch ; status = status ; htbl = tbl} = t in
176		if status == Closed
177		then raise UnboundTable
	135	let find t k =
	136	let {outch; status; htbl = tbl} = t in
	137	if status == Closed then raise UnboundTable
178	138	else
179	139	let res = Table.find tbl k in
180		res
	140	res
181	141
182		let memo cache f =
183		let tbl = lazy (try Some (open_in cache) with _ -> None) in
184		fun x ->
185		match Lazy.force tbl with
186		\| None -> f x
187		\| Some tbl ->
188		try
189		find tbl x
190		with
191		Not_found ->
192		let res = f x in
193		add tbl x res ;
194		res
	142	let memo cache f =
	143	let tbl = lazy (try Some (open_in cache) with _ -> None) in
	144	fun x ->
	145	match Lazy.force tbl with
	146	\| None -> f x
	147	\| Some tbl -> (
	148	try find tbl x
	149	with Not_found ->
	150	let res = f x in
	151	add tbl x res; res )
195	152
196		let memo_cond cache cond f =
197		let tbl = lazy (try Some (open_in cache) with _ -> None) in
198		fun x ->
199		match Lazy.force tbl with
200		\| None -> f x
201		\| Some tbl ->
202		if cond x
203		then
204		begin
205		try find tbl x
206		with Not_found ->
207		let res = f x in
208		add tbl x res ;
209		res
210		end
211		else f x
212
213
	153	let memo_cond cache cond f =
	154	let tbl = lazy (try Some (open_in cache) with _ -> None) in
	155	fun x ->
	156	match Lazy.force tbl with
	157	\| None -> f x
	158	\| Some tbl ->
	159	if cond x then begin
	160	try find tbl x
	161	with Not_found ->
	162	let res = f x in
	163	add tbl x res; res
	164	end
	165	else f x
214	166	end
215
216	167
217	168	(* Local Variables: *)
218	169	(* coding: utf-8 *)

+15

-18

plugins/micromega/persistent_cache.mli less more

9	9
10	10	open Hashtbl
11	11
12		module type PHashtable =
13		sig
14		type 'a t
15		type key
	12	module type PHashtable = sig
	13	type 'a t
	14	type key
16	15
17		val open_in : string -> 'a t
18		(** [open_in f] rebuilds a table from the records stored in file [f].
	16	val open_in : string -> 'a t
	17	(** [open_in f] rebuilds a table from the records stored in file [f].
19	18	As marshaling is not type-safe, it might segfault.
20	19	*)
21	20
22		val find : 'a t -> key -> 'a
23		(** find has the specification of Hashtable.find *)
	21	val find : 'a t -> key -> 'a
	22	(** find has the specification of Hashtable.find *)
24	23
25		val add : 'a t -> key -> 'a -> unit
26		(** [add tbl key elem] adds the binding [key] [elem] to the table [tbl].
	24	val add : 'a t -> key -> 'a -> unit
	25	(** [add tbl key elem] adds the binding [key] [elem] to the table [tbl].
27	26	(and writes the binding to the file associated with [tbl].)
28	27	If [key] is already bound, raises KeyAlreadyBound *)
29	28
30		val memo : string -> (key -> 'a) -> (key -> 'a)
31		(** [memo cache f] returns a memo function for [f] using file [cache] as persistent table.
	29	val memo : string -> (key -> 'a) -> key -> 'a
	30	(** [memo cache f] returns a memo function for [f] using file [cache] as persistent table.
32	31	Note that the cache will only be loaded when the function is used for the first time *)
33	32
34		val memo_cond : string -> (key -> bool) -> (key -> 'a) -> (key -> 'a)
35		(** [memo cache cond f] only use the cache if [cond k] holds for the key [k]. *)
	33	val memo_cond : string -> (key -> bool) -> (key -> 'a) -> key -> 'a
	34	(** [memo cache cond f] only use the cache if [cond k] holds for the key [k]. *)
	35	end
36	36
37
38		end
39
40		module PHashtable(Key:HashedType) : PHashtable with type key = Key.t
	37	module PHashtable (Key : HashedType) : PHashtable with type key = Key.t

+668

-709

plugins/micromega/polynomial.ml less more

14	14	(************************************************************************)
15	15
16	16	open Num
17		module Utils = Mutils
18		open Utils
19
	17	open Mutils
20	18	module Mc = Micromega
21	19
22	20	let max_nb_cstr = ref max_int

24	22	type var = int
25	23
26	24	let debug = false
27
28		let (<+>) = add_num
29		let (<*>) = mult_num
30
31		module Monomial :
32		sig
	25	let ( <+> ) = add_num
	26	let ( <*> ) = mult_num
	27
	28	module Monomial : sig
33	29	type t
	30
34	31	val const : t
35	32	val is_const : t -> bool
36	33	val var : var -> t
37	34	val is_var : t -> bool
38	35	val get_var : t -> var option
39	36	val prod : t -> t -> t
40		val exp : t -> int -> t
41		val div : t -> t -> t * int
	37	val exp : t -> int -> t
	38	val div : t -> t -> t * int
42	39	val compare : t -> t -> int
43	40	val pp : out_channel -> t -> unit
44	41	val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a
45	42	val sqrt : t -> t option
46	43	val variables : t -> ISet.t
47		end
48		= struct
	44	val degree : t -> int
	45	end = struct
49	46	(* A monomial is represented by a multiset of variables *)
50		module Map = Map.Make(Int)
	47	module Map = Map.Make (Int)
51	48	open Map
52	49
53	50	type t = int Map.t
	51
	52	let degree m = Map.fold (fun _ i d -> i + d) m 0
54	53
55	54	let is_singleton m =
56	55	try
57		let (k,v) = choose m in
58		let (l,e,r) = split k m in
59		if is_empty l && is_empty r
60		then Some(k,v) else None
	56	let k, v = choose m in
	57	let l, e, r = split k m in
	58	if is_empty l && is_empty r then Some (k, v) else None
61	59	with Not_found -> None
62	60
63	61	let pp o m =
64		let pp_elt o (k,v)=
65		if v = 1 then Printf.fprintf o "x%i" k
66		else Printf.fprintf o "x%i^%i" k v in
67
	62	let pp_elt o (k, v) =
	63	if v = 1 then Printf.fprintf o "x%i" k else Printf.fprintf o "x%i^%i" k v
	64	in
68	65	let rec pp_list o l =
69	66	match l with
70		[] -> ()
	67	\| [] -> ()
71	68	\| [e] -> pp_elt o e
72		\| e::l -> Printf.fprintf o "%a*%a" pp_elt e pp_list l in
73
74		pp_list o (Map.bindings m)
75
76
	69	\| e :: l -> Printf.fprintf o "%a*%a" pp_elt e pp_list l
	70	in
	71	pp_list o (Map.bindings m)
77	72
78	73	(* The monomial that corresponds to a constant *)
79	74	let const = Map.empty
80
81	75	let sum_degree m = Map.fold (fun _ n s -> s + n) m 0
82	76
83	77	(* Total ordering of monomials *)
84		let compare: t -> t -> int =
85		fun m1 m2 ->
86		let s1 = sum_degree m1
87		and s2 = sum_degree m2 in
88		if Int.equal s1 s2 then Map.compare Int.compare m1 m2
89		else Int.compare s1 s2
90
91		let is_const m = (m = Map.empty)
	78	let compare : t -> t -> int =
	79	fun m1 m2 ->
	80	let s1 = sum_degree m1 and s2 = sum_degree m2 in
	81	if Int.equal s1 s2 then Map.compare Int.compare m1 m2 else Int.compare s1 s2
	82
	83	let is_const m = m = Map.empty
92	84
93	85	(* The monomial 'x' *)
94	86	let var x = Map.add x 1 Map.empty
95	87
96	88	let is_var m =
97		match is_singleton m with
98		\| None -> false
99		\| Some (_,i) -> i = 1
	89	match is_singleton m with None -> false \| Some (_, i) -> i = 1
100	90
101	91	let get_var m =
102	92	match is_singleton m with
103	93	\| None -> None
104		\| Some (k,i) -> if i = 1 then Some k else None
105
	94	\| Some (k, i) -> if i = 1 then Some k else None
106	95
107	96	let sqrt m =
108	97	if is_const m then None
109	98	else
110	99	try
111		Some (Map.fold (fun v i acc ->
112		let i' = i / 2 in
113		if i mod 2 = 0
114		then add v i' acc
115		else raise Not_found) m const)
	100	Some
	101	(Map.fold
	102	(fun v i acc ->
	103	let i' = i / 2 in
	104	if i mod 2 = 0 then add v i' acc else raise Not_found)
	105	m const)
116	106	with Not_found -> None
117
118	107
119	108	(* Get the degre of a variable in a monomial *)
120	109	let find x m = try find x m with Not_found -> 0
121	110
122	111	(* Product of monomials *)
123		let prod m1 m2 = Map.fold (fun k d m -> add k ((find k m) + d) m) m1 m2
	112	let prod m1 m2 = Map.fold (fun k d m -> add k (find k m + d) m) m1 m2
124	113
125	114	let exp m n =
126		let rec exp acc n =
127		if n = 0 then acc
128		else exp (prod acc m) (n - 1) in
129
	115	let rec exp acc n = if n = 0 then acc else exp (prod acc m) (n - 1) in
130	116	exp const n
131	117
132	118	(* [div m1 m2 = mr,n] such that mr * (m2)^n = m1 *)
133	119	let div m1 m2 =
134		let n = fold (fun x i n -> let i' = find x m1 in
135		let nx = i' / i in
136		min n nx) m2 max_int in
137
138		let mr = fold (fun x i' m ->
139		let i = find x m2 in
140		let ir = i' - i * n in
141		if ir = 0 then m
142		else add x ir m) m1 empty in
143		(mr,n)
144
	120	let n =
	121	fold
	122	(fun x i n ->
	123	let i' = find x m1 in
	124	let nx = i' / i in
	125	min n nx)
	126	m2 max_int
	127	in
	128	let mr =
	129	fold
	130	(fun x i' m ->
	131	let i = find x m2 in
	132	let ir = i' - (i * n) in
	133	if ir = 0 then m else add x ir m)
	134	m1 empty
	135	in
	136	(mr, n)
145	137
146	138	let variables m = fold (fun v i acc -> ISet.add v acc) m ISet.empty
147
148	139	let fold = fold
149
150	140	end
151	141
152		module MonMap =
153		struct
154		include Map.Make(Monomial)
155
156		let union f = merge
157		(fun x v1 v2 ->
158		match v1 , v2 with
159		\| None , None -> None
160		\| Some v , None \| None , Some v -> Some v
161		\| Some v1 , Some v2 -> f x v1 v2)
162		end
	142	module MonMap = struct
	143	include Map.Make (Monomial)
	144
	145	let union f =
	146	merge (fun x v1 v2 ->
	147	match (v1, v2) with
	148	\| None, None -> None
	149	\| Some v, None \| None, Some v -> Some v
	150	\| Some v1, Some v2 -> f x v1 v2)
	151	end
163	152
164	153	let pp_mon o (m, i) =
165		if Monomial.is_const m
166		then if eq_num (Int 0) i then ()
167		else Printf.fprintf o "%s" (string_of_num i)
	154	if Monomial.is_const m then
	155	if eq_num (Int 0) i then () else Printf.fprintf o "%s" (string_of_num i)
168	156	else
169	157	match i with
170		\| Int 1 -> Monomial.pp o m
	158	\| Int 1 -> Monomial.pp o m
171	159	\| Int -1 -> Printf.fprintf o "-%a" Monomial.pp m
172		\| Int 0 -> ()
173		\| _ -> Printf.fprintf o "%s*%a" (string_of_num i) Monomial.pp m
174
175
176
177		module Poly :
178		(* A polynomial is a map of monomials *)
179		(*
	160	\| Int 0 -> ()
	161	\| _ -> Printf.fprintf o "%s*%a" (string_of_num i) Monomial.pp m
	162
	163	module Poly : (* A polynomial is a map of monomials *)
	164	(*
180	165	This is probably a naive implementation
181	166	(expected to be fast enough - Coq is probably the bottleneck)
182	167	*The new ring contribution is using a sparse Horner representation.
183	168	*)
184	169	sig
185	170	type t
	171
186	172	val pp : out_channel -> t -> unit
187	173	val get : Monomial.t -> t -> num
188	174	val variable : var -> t

192	178	val addition : t -> t -> t
193	179	val uminus : t -> t
194	180	val fold : (Monomial.t -> num -> 'a -> 'a) -> t -> 'a -> 'a
195		val factorise : var -> t -> t * t
196		end = struct
	181	val factorise : var -> t -> t * t
	182	end = struct
197	183	(normalisation bug : 0x ... *)
198		module P = Map.Make(Monomial)
	184	module P = Map.Make (Monomial)
199	185	open P
200	186
201	187	type t = num P.t
202	188
203
204		let pp o p = P.iter (fun mn i -> Printf.fprintf o "%a + " pp_mon (mn, i)) p
205
	189	let pp o p = P.iter (fun mn i -> Printf.fprintf o "%a + " pp_mon (mn, i)) p
206	190
207	191	(* Get the coefficient of monomial mn *)
208	192	let get : Monomial.t -> t -> num =
209		fun mn p -> try find mn p with Not_found -> (Int 0)
210
	193	fun mn p -> try find mn p with Not_found -> Int 0
211	194
212	195	(* The polynomial 1.x *)
213		let variable : var -> t =
214		fun x -> add (Monomial.var x) (Int 1) empty
	196	let variable : var -> t = fun x -> add (Monomial.var x) (Int 1) empty
215	197
216	198	(The constant polynomial )
217		let constant : num -> t =
218		fun c -> add (Monomial.const) c empty
	199	let constant : num -> t = fun c -> add Monomial.const c empty
219	200
220	201	(* The addition of a monomial *)
221	202
222	203	let add : Monomial.t -> num -> t -> t =
223		fun mn v p ->
	204	fun mn v p ->
224	205	if sign_num v = 0 then p
225	206	else
226		let vl = (get mn p) <+> v in
227		if sign_num vl = 0 then
228		remove mn p
229		else add mn vl p
230
	207	let vl = get mn p <+> v in
	208	if sign_num vl = 0 then remove mn p else add mn vl p
231	209
232	210	(** Design choice: empty is not a polynomial
233	211	I do not remember why ....

235	213
236	214	(* The product by a monomial *)
237	215	let mult : Monomial.t -> num -> t -> t =
238		fun mn v p ->
239		if sign_num v = 0
240		then constant (Int 0)
	216	fun mn v p ->
	217	if sign_num v = 0 then constant (Int 0)
241	218	else
242		fold (fun mn' v' res -> P.add (Monomial.prod mn mn') (v<*>v') res) p empty
243
244
245		let addition : t -> t -> t =
246		fun p1 p2 -> fold (fun mn v p -> add mn v p) p1 p2
247
	219	fold
	220	(fun mn' v' res -> P.add (Monomial.prod mn mn') (v <*> v') res)
	221	p empty
	222
	223	let addition : t -> t -> t =
	224	fun p1 p2 -> fold (fun mn v p -> add mn v p) p1 p2
248	225
249	226	let product : t -> t -> t =
250		fun p1 p2 ->
251		fold (fun mn v res -> addition (mult mn v p2) res ) p1 empty
252
253
254		let uminus : t -> t =
255		fun p -> map (fun v -> minus_num v) p
256
	227	fun p1 p2 -> fold (fun mn v res -> addition (mult mn v p2) res) p1 empty
	228
	229	let uminus : t -> t = fun p -> map (fun v -> minus_num v) p
257	230	let fold = P.fold
258	231
259	232	let factorise x p =
260	233	let x = Monomial.var x in
261		P.fold (fun m v (px,cx) ->
262		let (m1,i) = Monomial.div m x in
263		if i = 0
264		then (px, add m v cx)
	234	P.fold
	235	(fun m v (px, cx) ->
	236	let m1, i = Monomial.div m x in
	237	if i = 0 then (px, add m v cx)
265	238	else
266		let mx = Monomial.prod m1 (Monomial.exp x (i-1)) in
267		(add mx v px,cx) ) p (constant (Int 0) , constant (Int 0))
268
	239	let mx = Monomial.prod m1 (Monomial.exp x (i - 1)) in
	240	(add mx v px, cx))
	241	p
	242	(constant (Int 0), constant (Int 0))
269	243	end
270	244
271
272
273	245	type vector = Vect.t
274	246
275		type cstr = {coeffs : vector ; op : op ; cst : num}
276		and op = \|Eq \| Ge \| Gt
	247	type cstr = {coeffs : vector; op : op; cst : num}
	248
	249	and op = Eq \| Ge \| Gt
277	250
278	251	exception Strict
279	252
280		let is_strict c = (=) c.op Gt
281
282		let eval_op = function
283		\| Eq -> (=/)
284		\| Ge -> (>=/)
285		\| Gt -> (>/)
286
287
	253	let is_strict c = c.op = Gt
	254	let eval_op = function Eq -> ( =/ ) \| Ge -> ( >=/ ) \| Gt -> ( >/ )
288	255	let string_of_op = function Eq -> "=" \| Ge -> ">=" \| Gt -> ">"
289	256
290		let output_cstr o { coeffs ; op ; cst } =
291		Printf.fprintf o "%a %s %s" Vect.pp coeffs (string_of_op op) (string_of_num cst)
292
	257	let output_cstr o {coeffs; op; cst} =
	258	Printf.fprintf o "%a %s %s" Vect.pp coeffs (string_of_op op)
	259	(string_of_num cst)
293	260
294	261	let opMult o1 o2 =
295		match o1, o2 with
296		\| Eq , _ \| _ , Eq -> Eq
297		\| Ge , _ \| _ , Ge -> Ge
298		\| Gt , Gt -> Gt
	262	match (o1, o2) with Eq, _ \| _, Eq -> Eq \| Ge, _ \| _, Ge -> Ge \| Gt, Gt -> Gt
299	263
300	264	let opAdd o1 o2 =
301		match o1, o2 with
302		\| Eq , x \| x , Eq -> x
303		\| Gt , x \| x , Gt -> Gt
304		\| Ge , Ge -> Ge
305
306
307
	265	match (o1, o2) with Eq, x \| x, Eq -> x \| Gt, x \| x, Gt -> Gt \| Ge, Ge -> Ge
308	266
309	267	module LinPoly = struct
310	268	(** A linear polynomial a0 + a1.x1 + ... + an.xn

313	271
314	272	type t = Vect.t
315	273
316		module MonT = struct
317		module MonoMap = Map.Make(Monomial)
318		module IntMap = Map.Make(Int)
	274	module MonT = struct
	275	module MonoMap = Map.Make (Monomial)
	276	module IntMap = Map.Make (Int)
319	277
320	278	(** A hash table might be preferable but requires a hash function. *)
321		let (index_of_monomial : int MonoMap.t ref) = ref (MonoMap.empty)
322		let (monomial_of_index : Monomial.t IntMap.t ref) = ref (IntMap.empty)
	279	let (index_of_monomial : int MonoMap.t ref) = ref MonoMap.empty
	280
	281	let (monomial_of_index : Monomial.t IntMap.t ref) = ref IntMap.empty
323	282	let fresh = ref 0
	283
	284	let reserve vr =
	285	if !fresh > vr then failwith (Printf.sprintf "Cannot reserve %i" vr)
	286	else fresh := vr + 1
	287
	288	let get_fresh () = !fresh
	289
	290	let register m =
	291	try MonoMap.find m !index_of_monomial
	292	with Not_found ->
	293	let res = !fresh in
	294	index_of_monomial := MonoMap.add m res !index_of_monomial;
	295	monomial_of_index := IntMap.add res m !monomial_of_index;
	296	incr fresh;
	297	res
	298
	299	let retrieve i = IntMap.find i !monomial_of_index
324	300
325	301	let clear () =
326	302	index_of_monomial := MonoMap.empty;
327		monomial_of_index := IntMap.empty ;
328		fresh := 0
329
330
331		let register m =
332		try
333		MonoMap.find m !index_of_monomial
334		with Not_found ->
335		begin
336		let res = !fresh in
337		index_of_monomial := MonoMap.add m res !index_of_monomial ;
338		monomial_of_index := IntMap.add res m !monomial_of_index ;
339		incr fresh ; res
340		end
341
342		let retrieve i = IntMap.find i !monomial_of_index
	303	monomial_of_index := IntMap.empty;
	304	fresh := 0;
	305	ignore (register Monomial.const)
343	306
344	307	let _ = register Monomial.const
345
346	308	end
347	309
348	310	let var v = Vect.set (MonT.register (Monomial.var v)) (Int 1) Vect.null

352	314	Vect.set v (Int 1) Vect.null
353	315
354	316	let linpol_of_pol p =
355		Poly.fold
356		(fun mon num vct ->
357		let vr = MonT.register mon in
358		Vect.set vr num vct) p Vect.null
	317	Poly.fold
	318	(fun mon num vct ->
	319	let vr = MonT.register mon in
	320	Vect.set vr num vct)
	321	p Vect.null
359	322
360	323	let pol_of_linpol v =
361		Vect.fold (fun p vr n -> Poly.add (MonT.retrieve vr) n p) (Poly.constant (Int 0)) v
362
363		let coq_poly_of_linpol cst p =
364
	324	Vect.fold
	325	(fun p vr n -> Poly.add (MonT.retrieve vr) n p)
	326	(Poly.constant (Int 0)) v
	327
	328	let coq_poly_of_linpol cst p =
365	329	let pol_of_mon m =
366		Monomial.fold (fun x v p -> Mc.PEmul(Mc.PEpow(Mc.PEX(CamlToCoq.positive x),CamlToCoq.n v),p)) m (Mc.PEc (cst (Int 1))) in
367
368		Vect.fold (fun acc x v ->
	330	Monomial.fold
	331	(fun x v p ->
	332	Mc.PEmul (Mc.PEpow (Mc.PEX (CamlToCoq.positive x), CamlToCoq.n v), p))
	333	m
	334	(Mc.PEc (cst (Int 1)))
	335	in
	336	Vect.fold
	337	(fun acc x v ->
369	338	let mn = MonT.retrieve x in
370		Mc.PEadd(Mc.PEmul(Mc.PEc (cst v), pol_of_mon mn),acc)) (Mc.PEc (cst (Int 0))) p
	339	Mc.PEadd (Mc.PEmul (Mc.PEc (cst v), pol_of_mon mn), acc))
	340	(Mc.PEc (cst (Int 0)))
	341	p
371	342
372	343	let pp_var o vr =
373		try
374		Monomial.pp o (MonT.retrieve vr) (* this is a non-linear variable *)
375		with Not_found -> Printf.fprintf o "v%i" vr
376
377
378		let pp o p = Vect.pp_gen pp_var o p
379
380
381		let constant c =
382		if sign_num c = 0
383		then Vect.null
384		else Vect.set 0 c Vect.null
385
	344	try Monomial.pp o (MonT.retrieve vr) (* this is a non-linear variable *)
	345	with Not_found -> Printf.fprintf o "v%i" vr
	346
	347	let pp o p = Vect.pp_gen pp_var o p
	348	let constant c = if sign_num c = 0 then Vect.null else Vect.set 0 c Vect.null
386	349
387	350	let is_linear p =
388		Vect.for_all (fun v _ ->
389		let mn = (MonT.retrieve v) in
390		Monomial.is_var mn \|\| Monomial.is_const mn) p
	351	Vect.for_all
	352	(fun v _ ->
	353	let mn = MonT.retrieve v in
	354	Monomial.is_var mn \|\| Monomial.is_const mn)
	355	p
391	356
392	357	let is_variable p =
393		let ((x,v),r) = Vect.decomp_fst p in
394		if Vect.is_null r && v >/ Int 0
395		then Monomial.get_var (MonT.retrieve x)
	358	let (x, v), r = Vect.decomp_fst p in
	359	if Vect.is_null r && v >/ Int 0 then Monomial.get_var (MonT.retrieve x)
396	360	else None
397	361
398
399	362	let factorise x p =
400		let (px,cx) = Poly.factorise x (pol_of_linpol p) in
	363	let px, cx = Poly.factorise x (pol_of_linpol p) in
401	364	(linpol_of_pol px, linpol_of_pol cx)
402	365
403
404	366	let is_linear_for x p =
405		let (a,b) = factorise x p in
	367	let a, b = factorise x p in
406	368	Vect.is_constant a
407	369
408	370	let search_all_linear p l =
409		Vect.fold (fun acc x v ->
410		if p v
411		then
	371	Vect.fold
	372	(fun acc x v ->
	373	if p v then
412	374	let x' = MonT.retrieve x in
413	375	match Monomial.get_var x' with
414	376	\| None -> acc
415		\| Some x ->
416		if is_linear_for x l
417		then x::acc
418		else acc
419		else acc) [] l
420
421		let min_list (l:int list) =
422		match l with
423		\| [] -> None
424		\| e::l -> Some (List.fold_left min e l)
425
426		let search_linear p l =
427		min_list (search_all_linear p l)
428
	377	\| Some x -> if is_linear_for x l then x :: acc else acc
	378	else acc)
	379	[] l
	380
	381	let min_list (l : int list) =
	382	match l with [] -> None \| e :: l -> Some (List.fold_left min e l)
	383
	384	let search_linear p l = min_list (search_all_linear p l)
429	385
430	386	let product p1 p2 =
431	387	linpol_of_pol (Poly.product (pol_of_linpol p1) (pol_of_linpol p2))
432	388
433	389	let addition p1 p2 = Vect.add p1 p2
434	390
435
436	391	let of_vect v =
437		Vect.fold (fun acc v vl -> addition (product (var v) (constant vl)) acc) Vect.null v
438
439		let variables p = Vect.fold
440		(fun acc v _ ->
441		ISet.union (Monomial.variables (MonT.retrieve v)) acc) ISet.empty p
442
443
444		let pp_goal typ o l =
445		let vars = List.fold_left (fun acc p -> ISet.union acc (variables (fst p))) ISet.empty l in
446		let pp_vars o i = ISet.iter (fun v -> Printf.fprintf o "(x%i : %s) " v typ) vars in
447
448		Printf.fprintf o "forall %a\n" pp_vars vars ;
449		List.iteri (fun i (p,op) -> Printf.fprintf o "(H%i : %a %s 0)\n" i pp p (string_of_op op)) l;
	392	Vect.fold
	393	(fun acc v vl -> addition (product (var v) (constant vl)) acc)
	394	Vect.null v
	395
	396	let variables p =
	397	Vect.fold
	398	(fun acc v _ -> ISet.union (Monomial.variables (MonT.retrieve v)) acc)
	399	ISet.empty p
	400
	401	let monomials p = Vect.fold (fun acc v _ -> ISet.add v acc) ISet.empty p
	402
	403	let degree v =
	404	Vect.fold (fun acc v vl -> max acc (Monomial.degree (MonT.retrieve v))) 0 v
	405
	406	let pp_goal typ o l =
	407	let vars =
	408	List.fold_left
	409	(fun acc p -> ISet.union acc (variables (fst p)))
	410	ISet.empty l
	411	in
	412	let pp_vars o i =
	413	ISet.iter (fun v -> Printf.fprintf o "(x%i : %s) " v typ) vars
	414	in
	415	Printf.fprintf o "forall %a\n" pp_vars vars;
	416	List.iteri
	417	(fun i (p, op) ->
	418	Printf.fprintf o "(H%i : %a %s 0)\n" i pp p (string_of_op op))
	419	l;
450	420	Printf.fprintf o ", False\n"
451	421
452
453
454
455
456		let collect_square p =
457		Vect.fold (fun acc v _ ->
458		let m = (MonT.retrieve v) in
459		match Monomial.sqrt m with
460		\| None -> acc
461		\| Some s -> MonMap.add s m acc
462		) MonMap.empty p
463
464
	422	let collect_square p =
	423	Vect.fold
	424	(fun acc v _ ->
	425	let m = MonT.retrieve v in
	426	match Monomial.sqrt m with None -> acc \| Some s -> MonMap.add s m acc)
	427	MonMap.empty p
465	428	end
466	429
467		module ProofFormat = struct
	430	module ProofFormat = struct
468	431	open Big_int
469	432
470	433	type prf_rule =
471	434	\| Annot of string * prf_rule
472	435	\| Hyp of int
473	436	\| Def of int
474		\| Cst of Num.num
	437	\| Cst of Num.num
475	438	\| Zero
476	439	\| Square of Vect.t
477	440	\| MulC of Vect.t * prf_rule

484	447	\| Done
485	448	\| Step of int * prf_rule * proof
486	449	\| Enum of int * prf_rule * Vect.t * prf_rule * proof list
487
	450	\| ExProof of int * int * int * var * var * var * proof
	451
	452	(* x = z - t, z >= 0, t >= 0 *)
488	453
489	454	let rec output_prf_rule o = function
490		\| Annot(s,p) -> Printf.fprintf o "(%a)@%s" output_prf_rule p s
	455	\| Annot (s, p) -> Printf.fprintf o "(%a)@%s" output_prf_rule p s
491	456	\| Hyp i -> Printf.fprintf o "Hyp %i" i
492	457	\| Def i -> Printf.fprintf o "Def %i" i
493	458	\| Cst c -> Printf.fprintf o "Cst %s" (string_of_num c)
494		\| Zero -> Printf.fprintf o "Zero"
	459	\| Zero -> Printf.fprintf o "Zero"
495	460	\| Square s -> Printf.fprintf o "(%a)^2" Poly.pp (LinPoly.pol_of_linpol s)
496		\| MulC(p,pr) -> Printf.fprintf o "(%a) * (%a)" Poly.pp (LinPoly.pol_of_linpol p) output_prf_rule pr
497		\| MulPrf(p1,p2) -> Printf.fprintf o "(%a) * (%a)" output_prf_rule p1 output_prf_rule p2
498		\| AddPrf(p1,p2) -> Printf.fprintf o "%a + %a" output_prf_rule p1 output_prf_rule p2
499		\| CutPrf(p) -> Printf.fprintf o "[%a]" output_prf_rule p
500		\| Gcd(c,p) -> Printf.fprintf o "(%a)/%s" output_prf_rule p (string_of_big_int c)
	461	\| MulC (p, pr) ->
	462	Printf.fprintf o "(%a) * (%a)" Poly.pp (LinPoly.pol_of_linpol p)
	463	output_prf_rule pr
	464	\| MulPrf (p1, p2) ->
	465	Printf.fprintf o "(%a) * (%a)" output_prf_rule p1 output_prf_rule p2
	466	\| AddPrf (p1, p2) ->
	467	Printf.fprintf o "%a + %a" output_prf_rule p1 output_prf_rule p2
	468	\| CutPrf p -> Printf.fprintf o "[%a]" output_prf_rule p
	469	\| Gcd (c, p) ->
	470	Printf.fprintf o "(%a)/%s" output_prf_rule p (string_of_big_int c)
501	471
502	472	let rec output_proof o = function
503	473	\| Done -> Printf.fprintf o "."
504		\| Step(i,p,pf) -> Printf.fprintf o "%i:= %a ; %a" i output_prf_rule p output_proof pf
505		\| Enum(i,p1,v,p2,pl) -> Printf.fprintf o "%i{%a<=%a<=%a}%a" i
506		output_prf_rule p1 Vect.pp v output_prf_rule p2
507		(pp_list ";" output_proof) pl
	474	\| Step (i, p, pf) ->
	475	Printf.fprintf o "%i:= %a ; %a" i output_prf_rule p output_proof pf
	476	\| Enum (i, p1, v, p2, pl) ->
	477	Printf.fprintf o "%i{%a<=%a<=%a}%a" i output_prf_rule p1 Vect.pp v
	478	output_prf_rule p2 (pp_list ";" output_proof) pl
	479	\| ExProof (i, j, k, x, z, t, pr) ->
	480	Printf.fprintf o "%i := %i = %i - %i ; %i := %i >= 0 ; %i := %i >= 0 ; %a"
	481	i x z t j z k t output_proof pr
508	482
509	483	let rec pr_size = function
510		\| Annot(_,p) -> pr_size p
511		\| Zero\| Square _ -> Int 0
512		\| Hyp _ -> Int 1
513		\| Def _ -> Int 1
514		\| Cst n -> n
515		\| Gcd(i, p) -> pr_size p // (Big_int i)
516		\| MulPrf(p1,p2) \| AddPrf(p1,p2) -> pr_size p1 +/ pr_size p2
517		\| CutPrf p -> pr_size p
518		\| MulC(v, p) -> pr_size p
519
	484	\| Annot (_, p) -> pr_size p
	485	\| Zero \| Square _ -> Int 0
	486	\| Hyp _ -> Int 1
	487	\| Def _ -> Int 1
	488	\| Cst n -> n
	489	\| Gcd (i, p) -> pr_size p // Big_int i
	490	\| MulPrf (p1, p2) \| AddPrf (p1, p2) -> pr_size p1 +/ pr_size p2
	491	\| CutPrf p -> pr_size p
	492	\| MulC (v, p) -> pr_size p
520	493
521	494	let rec pr_rule_max_id = function
522		\| Annot(_,p) -> pr_rule_max_id p
	495	\| Annot (_, p) -> pr_rule_max_id p
523	496	\| Hyp i \| Def i -> i
524	497	\| Cst _ \| Zero \| Square _ -> -1
525		\| MulC(_,p) \| CutPrf p \| Gcd(_,p) -> pr_rule_max_id p
526		\| MulPrf(p1,p2)\| AddPrf(p1,p2) -> max (pr_rule_max_id p1) (pr_rule_max_id p2)
	498	\| MulC (_, p) \| CutPrf p \| Gcd (_, p) -> pr_rule_max_id p
	499	\| MulPrf (p1, p2) \| AddPrf (p1, p2) ->
	500	max (pr_rule_max_id p1) (pr_rule_max_id p2)
527	501
528	502	let rec proof_max_id = function
529	503	\| Done -> -1
530		\| Step(i,pr,prf) -> max i (max (pr_rule_max_id pr) (proof_max_id prf))
531		\| Enum(i,p1,_,p2,l) ->
532		let m = max (pr_rule_max_id p1) (pr_rule_max_id p2) in
533		List.fold_left (fun i prf -> max i (proof_max_id prf)) (max i m) l
534
	504	\| Step (i, pr, prf) -> max i (max (pr_rule_max_id pr) (proof_max_id prf))
	505	\| Enum (i, p1, _, p2, l) ->
	506	let m = max (pr_rule_max_id p1) (pr_rule_max_id p2) in
	507	List.fold_left (fun i prf -> max i (proof_max_id prf)) (max i m) l
	508	\| ExProof (i, j, k, _, _, _, prf) ->
	509	max (max (max i j) k) (proof_max_id prf)
535	510
536	511	let rec pr_rule_def_cut id = function
537		\| Annot(_,p) -> pr_rule_def_cut id p
538		\| MulC(p,prf) ->
539		let (bds,id',prf') = pr_rule_def_cut id prf in
540		(bds, id', MulC(p,prf'))
541		\| MulPrf(p1,p2) ->
542		let (bds1,id,p1) = pr_rule_def_cut id p1 in
543		let (bds2,id,p2) = pr_rule_def_cut id p2 in
544		(bds2@bds1,id,MulPrf(p1,p2))
545		\| AddPrf(p1,p2) ->
546		let (bds1,id,p1) = pr_rule_def_cut id p1 in
547		let (bds2,id,p2) = pr_rule_def_cut id p2 in
548		(bds2@bds1,id,AddPrf(p1,p2))
	512	\| Annot (_, p) -> pr_rule_def_cut id p
	513	\| MulC (p, prf) ->
	514	let bds, id', prf' = pr_rule_def_cut id prf in
	515	(bds, id', MulC (p, prf'))
	516	\| MulPrf (p1, p2) ->
	517	let bds1, id, p1 = pr_rule_def_cut id p1 in
	518	let bds2, id, p2 = pr_rule_def_cut id p2 in
	519	(bds2 @ bds1, id, MulPrf (p1, p2))
	520	\| AddPrf (p1, p2) ->
	521	let bds1, id, p1 = pr_rule_def_cut id p1 in
	522	let bds2, id, p2 = pr_rule_def_cut id p2 in
	523	(bds2 @ bds1, id, AddPrf (p1, p2))
549	524	\| CutPrf p ->
550		let (bds,id,p) = pr_rule_def_cut id p in
551		((id,p)::bds,id+1,Def id)
552		\| Gcd(c,p) ->
553		let (bds,id,p) = pr_rule_def_cut id p in
554		((id,p)::bds,id+1,Def id)
555		\| Square _\|Cst _\|Def _\|Hyp _\|Zero as x -> ([],id,x)
556
	525	let bds, id, p = pr_rule_def_cut id p in
	526	((id, p) :: bds, id + 1, Def id)
	527	\| Gcd (c, p) ->
	528	let bds, id, p = pr_rule_def_cut id p in
	529	((id, p) :: bds, id + 1, Def id)
	530	\| (Square _ \| Cst _ \| Def _ \| Hyp _ \| Zero) as x -> ([], id, x)
557	531
558	532	(* Do not define top-level cuts *)
559	533	let pr_rule_def_cut id = function
560	534	\| CutPrf p ->
561		let (bds,ids,p') = pr_rule_def_cut id p in
562		bds,ids, CutPrf p'
563		\| p -> pr_rule_def_cut id p
564
565
566		let rec implicit_cut p =
567		match p with
568		\| CutPrf p -> implicit_cut p
569		\| _ -> p
570
	535	let bds, ids, p' = pr_rule_def_cut id p in
	536	(bds, ids, CutPrf p')
	537	\| p -> pr_rule_def_cut id p
	538
	539	let rec implicit_cut p = match p with CutPrf p -> implicit_cut p \| _ -> p
571	540
572	541	let rec pr_rule_collect_hyps pr =
573	542	match pr with
574		\| Annot(_,pr) -> pr_rule_collect_hyps pr
	543	\| Annot (_, pr) -> pr_rule_collect_hyps pr
575	544	\| Hyp i \| Def i -> ISet.add i ISet.empty
576	545	\| Cst _ \| Zero \| Square _ -> ISet.empty
577		\| MulC(_,pr) \| Gcd(_,pr)\| CutPrf pr -> pr_rule_collect_hyps pr
578		\| MulPrf(p1,p2) \| AddPrf(p1,p2) -> ISet.union (pr_rule_collect_hyps p1) (pr_rule_collect_hyps p2)
579
580		let simplify_proof p =
	546	\| MulC (_, pr) \| Gcd (_, pr) \| CutPrf pr -> pr_rule_collect_hyps pr
	547	\| MulPrf (p1, p2) \| AddPrf (p1, p2) ->
	548	ISet.union (pr_rule_collect_hyps p1) (pr_rule_collect_hyps p2)
	549
	550	let simplify_proof p =
581	551	let rec simplify_proof p =
582	552	match p with
583	553	\| Done -> (Done, ISet.empty)
584		\| Step(i,pr,Done) -> (p, ISet.add i (pr_rule_collect_hyps pr))
585		\| Step(i,pr,prf) ->
586		let (prf',hyps) = simplify_proof prf in
587		if not (ISet.mem i hyps)
588		then (prf',hyps)
589		else
590		(Step(i,pr,prf'), ISet.add i (ISet.union (pr_rule_collect_hyps pr) hyps))
591		\| Enum(i,p1,v,p2,pl) ->
592		let (pl,hl) = List.split (List.map simplify_proof pl) in
593		let hyps = List.fold_left ISet.union ISet.empty hl in
594		(Enum(i,p1,v,p2,pl),ISet.add i (ISet.union (ISet.union (pr_rule_collect_hyps p1) (pr_rule_collect_hyps p2)) hyps)) in
	554	\| Step (i, pr, Done) -> (p, ISet.add i (pr_rule_collect_hyps pr))
	555	\| Step (i, pr, prf) ->
	556	let prf', hyps = simplify_proof prf in
	557	if not (ISet.mem i hyps) then (prf', hyps)
	558	else
	559	( Step (i, pr, prf')
	560	, ISet.add i (ISet.union (pr_rule_collect_hyps pr) hyps) )
	561	\| Enum (i, p1, v, p2, pl) ->
	562	let pl, hl = List.split (List.map simplify_proof pl) in
	563	let hyps = List.fold_left ISet.union ISet.empty hl in
	564	( Enum (i, p1, v, p2, pl)
	565	, ISet.add i
	566	(ISet.union
	567	(ISet.union (pr_rule_collect_hyps p1) (pr_rule_collect_hyps p2))
	568	hyps) )
	569	\| ExProof (i, j, k, x, z, t, prf) ->
	570	let prf', hyps = simplify_proof prf in
	571	if
	572	(not (ISet.mem i hyps))
	573	&& (not (ISet.mem j hyps))
	574	&& not (ISet.mem k hyps)
	575	then (prf', hyps)
	576	else
	577	( ExProof (i, j, k, x, z, t, prf')
	578	, ISet.add i (ISet.add j (ISet.add k hyps)) )
	579	in
595	580	fst (simplify_proof p)
596
597	581
598	582	let rec normalise_proof id prf =
599	583	match prf with
600		\| Done -> (id,Done)
601		\| Step(i,Gcd(c,p),Done) -> normalise_proof id (Step(i,p,Done))
602		\| Step(i,p,prf) ->
603		let bds,id,p' = pr_rule_def_cut id p in
604		let (id,prf) = normalise_proof id prf in
605		let prf = List.fold_left (fun acc (i,p) -> Step(i, CutPrf p,acc))
606		(Step(i,p',prf)) bds in
607
608		(id,prf)
609		\| Enum(i,p1,v,p2,pl) ->
610		(* Why do I have top-level cuts ? *)
611		(* let p1 = implicit_cut p1 in
	584	\| Done -> (id, Done)
	585	\| Step (i, Gcd (c, p), Done) -> normalise_proof id (Step (i, p, Done))
	586	\| Step (i, p, prf) ->
	587	let bds, id, p' = pr_rule_def_cut id p in
	588	let id, prf = normalise_proof id prf in
	589	let prf =
	590	List.fold_left
	591	(fun acc (i, p) -> Step (i, CutPrf p, acc))
	592	(Step (i, p', prf))
	593	bds
	594	in
	595	(id, prf)
	596	\| ExProof (i, j, k, x, z, t, prf) ->
	597	let id, prf = normalise_proof id prf in
	598	(id, ExProof (i, j, k, x, z, t, prf))
	599	\| Enum (i, p1, v, p2, pl) ->
	600	(* Why do I have top-level cuts ? *)
	601	(* let p1 = implicit_cut p1 in
612	602	let p2 = implicit_cut p2 in
613	603	let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in
614	604	(List.fold_left max 0 ids ,
615	605	Enum(i,p1,v,p2,prfs))
616	606	*)
617
618		let bds1,id,p1' = pr_rule_def_cut id (implicit_cut p1) in
619		let bds2,id,p2' = pr_rule_def_cut id (implicit_cut p2) in
620		let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in
621		(List.fold_left max 0 ids ,
622		List.fold_left (fun acc (i,p) -> Step(i, CutPrf p,acc))
623		(Enum(i,p1',v,p2',prfs)) (bds2@bds1))
624
	607	let bds1, id, p1' = pr_rule_def_cut id (implicit_cut p1) in
	608	let bds2, id, p2' = pr_rule_def_cut id (implicit_cut p2) in
	609	let ids, prfs = List.split (List.map (normalise_proof id) pl) in
	610	( List.fold_left max 0 ids
	611	, List.fold_left
	612	(fun acc (i, p) -> Step (i, CutPrf p, acc))
	613	(Enum (i, p1', v, p2', prfs))
	614	(bds2 @ bds1) )
625	615
626	616	let normalise_proof id prf =
627	617	let prf = simplify_proof prf in
628	618	let res = normalise_proof id prf in
629		if debug then Printf.printf "normalise_proof %a -> %a" output_proof prf output_proof (snd res) ;
	619	if debug then
	620	Printf.printf "normalise_proof %a -> %a" output_proof prf output_proof
	621	(snd res);
630	622	res
631	623
632		module OrdPrfRule =
633		struct
634		type t = prf_rule
635
636		let id_of_constr = function
637		\| Annot _ -> 0
638		\| Hyp _ -> 1
639		\| Def _ -> 2
640		\| Cst _ -> 3
641		\| Zero -> 4
642		\| Square _ -> 5
643		\| MulC _ -> 6
644		\| Gcd _ -> 7
645		\| MulPrf _ -> 8
646		\| AddPrf _ -> 9
647		\| CutPrf _ -> 10
648
649		let cmp_pair c1 c2 (x1,x2) (y1,y2) =
650		match c1 x1 y1 with
651		\| 0 -> c2 x2 y2
652		\| i -> i
653
654
655		let rec compare p1 p2 =
656		match p1, p2 with
657		\| Annot(s1,p1) , Annot(s2,p2) -> if s1 = s2 then compare p1 p2
658		else Util.pervasives_compare s1 s2
659		\| Hyp i , Hyp j -> Util.pervasives_compare i j
660		\| Def i , Def j -> Util.pervasives_compare i j
661		\| Cst n , Cst m -> Num.compare_num n m
662		\| Zero , Zero -> 0
663		\| Square v1 , Square v2 -> Vect.compare v1 v2
664		\| MulC(v1,p1) , MulC(v2,p2) -> cmp_pair Vect.compare compare (v1,p1) (v2,p2)
665		\| Gcd(b1,p1) , Gcd(b2,p2) -> cmp_pair Big_int.compare_big_int compare (b1,p1) (b2,p2)
666		\| MulPrf(p1,q1) , MulPrf(p2,q2) -> cmp_pair compare compare (p1,q1) (p2,q2)
667		\| AddPrf(p1,q1) , MulPrf(p2,q2) -> cmp_pair compare compare (p1,q1) (p2,q2)
668		\| CutPrf p , CutPrf p' -> compare p p'
669		\| _ , _ -> Util.pervasives_compare (id_of_constr p1) (id_of_constr p2)
670
671		end
672
673
674
	624	module OrdPrfRule = struct
	625	type t = prf_rule
	626
	627	let id_of_constr = function
	628	\| Annot _ -> 0
	629	\| Hyp _ -> 1
	630	\| Def _ -> 2
	631	\| Cst _ -> 3
	632	\| Zero -> 4
	633	\| Square _ -> 5
	634	\| MulC _ -> 6
	635	\| Gcd _ -> 7
	636	\| MulPrf _ -> 8
	637	\| AddPrf _ -> 9
	638	\| CutPrf _ -> 10
	639
	640	let cmp_pair c1 c2 (x1, x2) (y1, y2) =
	641	match c1 x1 y1 with 0 -> c2 x2 y2 \| i -> i
	642
	643	let rec compare p1 p2 =
	644	match (p1, p2) with
	645	\| Annot (s1, p1), Annot (s2, p2) ->
	646	if s1 = s2 then compare p1 p2 else String.compare s1 s2
	647	\| Hyp i, Hyp j -> Int.compare i j
	648	\| Def i, Def j -> Int.compare i j
	649	\| Cst n, Cst m -> Num.compare_num n m
	650	\| Zero, Zero -> 0
	651	\| Square v1, Square v2 -> Vect.compare v1 v2
	652	\| MulC (v1, p1), MulC (v2, p2) ->
	653	cmp_pair Vect.compare compare (v1, p1) (v2, p2)
	654	\| Gcd (b1, p1), Gcd (b2, p2) ->
	655	cmp_pair Big_int.compare_big_int compare (b1, p1) (b2, p2)
	656	\| MulPrf (p1, q1), MulPrf (p2, q2) ->
	657	cmp_pair compare compare (p1, q1) (p2, q2)
	658	\| AddPrf (p1, q1), MulPrf (p2, q2) ->
	659	cmp_pair compare compare (p1, q1) (p2, q2)
	660	\| CutPrf p, CutPrf p' -> compare p p'
	661	\| _, _ -> Int.compare (id_of_constr p1) (id_of_constr p2)
	662	end
675	663
676	664	let add_proof x y =
677		match x, y with
678		\| Zero , p \| p , Zero -> p
679		\| _ -> AddPrf(x,y)
680
	665	match (x, y) with Zero, p \| p, Zero -> p \| _ -> AddPrf (x, y)
681	666
682	667	let rec mul_cst_proof c p =
683	668	match p with
684		\| Annot(s,p) -> Annot(s,mul_cst_proof c p)
685		\| MulC(v,p') -> MulC(Vect.mul c v,p')
686		\| _ ->
687		match sign_num c with
688		\| 0 -> Zero (* This is likely to be a bug *)
689		\| -1 -> MulC(LinPoly.constant c, p) (* [p] should represent an equality *)
690		\| 1 ->
691		if eq_num (Int 1) c
692		then p
693		else MulPrf(Cst c,p)
694		\| _ -> assert false
695
	669	\| Annot (s, p) -> Annot (s, mul_cst_proof c p)
	670	\| MulC (v, p') -> MulC (Vect.mul c v, p')
	671	\| _ -> (
	672	match sign_num c with
	673	\| 0 -> Zero (* This is likely to be a bug *)
	674	\| -1 ->
	675	MulC (LinPoly.constant c, p) (* [p] should represent an equality *)
	676	\| 1 -> if eq_num (Int 1) c then p else MulPrf (Cst c, p)
	677	\| _ -> assert false )
696	678
697	679	let sMulC v p =
698		let (c,v') = Vect.decomp_cst v in
699		if Vect.is_null v' then mul_cst_proof c p
700		else MulC(v,p)
701
	680	let c, v' = Vect.decomp_cst v in
	681	if Vect.is_null v' then mul_cst_proof c p else MulC (v, p)
702	682
703	683	let mul_proof p1 p2 =
704		match p1 , p2 with
705		\| Zero , _ \| _ , Zero -> Zero
706		\| Cst c , p \| p , Cst c -> mul_cst_proof c p
707		\| _ , _ ->
708		MulPrf(p1,p2)
709
710
711		module PrfRuleMap = Map.Make(OrdPrfRule)
712
713		let prf_rule_of_map m =
714		PrfRuleMap.fold (fun k v acc -> add_proof (sMulC v k) acc) m Zero
715
716
717		let rec dev_prf_rule p =
718		match p with
719		\| Annot(s,p) -> dev_prf_rule p
720		\| Hyp _ \| Def _ \| Cst _ \| Zero \| Square _ -> PrfRuleMap.singleton p (LinPoly.constant (Int 1))
721		\| MulC(v,p) -> PrfRuleMap.map (fun v1 -> LinPoly.product v v1) (dev_prf_rule p)
722		\| AddPrf(p1,p2) -> PrfRuleMap.merge (fun k o1 o2 ->
723		match o1 , o2 with
724		\| None , None -> None
725		\| None , Some v \| Some v, None -> Some v
726		\| Some v1 , Some v2 -> Some (LinPoly.addition v1 v2)) (dev_prf_rule p1) (dev_prf_rule p2)
727		\| MulPrf(p1, p2) ->
728		begin
729		let p1' = dev_prf_rule p1 in
730		let p2' = dev_prf_rule p2 in
731
732		let p1'' = prf_rule_of_map p1' in
733		let p2'' = prf_rule_of_map p2' in
734
735		match p1'' with
736		\| Cst c -> PrfRuleMap.map (fun v1 -> Vect.mul c v1) p2'
737		\| _ -> PrfRuleMap.singleton (MulPrf(p1'',p2'')) (LinPoly.constant (Int 1))
738		end
739		\| _ -> PrfRuleMap.singleton p (LinPoly.constant (Int 1))
740
741		let simplify_prf_rule p =
742		prf_rule_of_map (dev_prf_rule p)
743
744
745		(*
	684	match (p1, p2) with
	685	\| Zero, _ \| _, Zero -> Zero
	686	\| Cst c, p \| p, Cst c -> mul_cst_proof c p
	687	\| _, _ -> MulPrf (p1, p2)
	688
	689	module PrfRuleMap = Map.Make (OrdPrfRule)
	690
	691	let prf_rule_of_map m =
	692	PrfRuleMap.fold (fun k v acc -> add_proof (sMulC v k) acc) m Zero
	693
	694	let rec dev_prf_rule p =
	695	match p with
	696	\| Annot (s, p) -> dev_prf_rule p
	697	\| Hyp _ \| Def _ \| Cst _ \| Zero \| Square _ ->
	698	PrfRuleMap.singleton p (LinPoly.constant (Int 1))
	699	\| MulC (v, p) ->
	700	PrfRuleMap.map (fun v1 -> LinPoly.product v v1) (dev_prf_rule p)
	701	\| AddPrf (p1, p2) ->
	702	PrfRuleMap.merge
	703	(fun k o1 o2 ->
	704	match (o1, o2) with
	705	\| None, None -> None
	706	\| None, Some v \| Some v, None -> Some v
	707	\| Some v1, Some v2 -> Some (LinPoly.addition v1 v2))
	708	(dev_prf_rule p1) (dev_prf_rule p2)
	709	\| MulPrf (p1, p2) -> (
	710	let p1' = dev_prf_rule p1 in
	711	let p2' = dev_prf_rule p2 in
	712	let p1'' = prf_rule_of_map p1' in
	713	let p2'' = prf_rule_of_map p2' in
	714	match p1'' with
	715	\| Cst c -> PrfRuleMap.map (fun v1 -> Vect.mul c v1) p2'
	716	\| _ ->
	717	PrfRuleMap.singleton (MulPrf (p1'', p2'')) (LinPoly.constant (Int 1)) )
	718	\| _ -> PrfRuleMap.singleton p (LinPoly.constant (Int 1))
	719
	720	let simplify_prf_rule p = prf_rule_of_map (dev_prf_rule p)
	721
	722	(*
746	723	let mul_proof p1 p2 =
747	724	let res = mul_proof p1 p2 in
748	725	Printf.printf "mul_proof %a %a = %a\n"

766	743	*)
767	744
768	745	let proof_of_farkas env vect =
769		Vect.fold (fun prf x n ->
770		add_proof (mul_cst_proof n (IMap.find x env)) prf) Zero vect
771
772
773
774
775		module Env = struct
776
	746	Vect.fold
	747	(fun prf x n -> add_proof (mul_cst_proof n (IMap.find x env)) prf)
	748	Zero vect
	749
	750	module Env = struct
777	751	let rec string_of_int_list l =
778	752	match l with
779	753	\| [] -> ""
780		\| i::l -> Printf.sprintf "%i,%s" i (string_of_int_list l)
781
	754	\| i :: l -> Printf.sprintf "%i,%s" i (string_of_int_list l)
782	755
783	756	let id_of_hyp hyp l =
784	757	let rec xid_of_hyp i l' =
785	758	match l' with
786		\| [] -> failwith (Printf.sprintf "id_of_hyp %i %s" hyp (string_of_int_list l))
787		\| hyp'::l' -> if (=) hyp hyp' then i else xid_of_hyp (i+1) l' in
	759	\| [] ->
	760	failwith (Printf.sprintf "id_of_hyp %i %s" hyp (string_of_int_list l))
	761	\| hyp' :: l' -> if hyp = hyp' then i else xid_of_hyp (i + 1) l'
	762	in
788	763	xid_of_hyp 0 l
789
790	764	end
791	765
792		let cmpl_prf_rule norm (cst:num-> 'a) env prf =
793		let rec cmpl =
794		function
795		\| Annot(s,p) -> cmpl p
	766	let cmpl_prf_rule norm (cst : num -> 'a) env prf =
	767	let rec cmpl = function
	768	\| Annot (s, p) -> cmpl p
796	769	\| Hyp i \| Def i -> Mc.PsatzIn (CamlToCoq.nat (Env.id_of_hyp i env))
797		\| Cst i -> Mc.PsatzC (cst i)
798		\| Zero -> Mc.PsatzZ
799		\| MulPrf(p1,p2) -> Mc.PsatzMulE(cmpl p1, cmpl p2)
800		\| AddPrf(p1,p2) -> Mc.PsatzAdd(cmpl p1 , cmpl p2)
801		\| MulC(lp,p) -> let lp = norm (LinPoly.coq_poly_of_linpol cst lp) in
802		Mc.PsatzMulC(lp,cmpl p)
803		\| Square lp -> Mc.PsatzSquare (norm (LinPoly.coq_poly_of_linpol cst lp))
804		\| _ -> failwith "Cuts should already be compiled" in
	770	\| Cst i -> Mc.PsatzC (cst i)
	771	\| Zero -> Mc.PsatzZ
	772	\| MulPrf (p1, p2) -> Mc.PsatzMulE (cmpl p1, cmpl p2)
	773	\| AddPrf (p1, p2) -> Mc.PsatzAdd (cmpl p1, cmpl p2)
	774	\| MulC (lp, p) ->
	775	let lp = norm (LinPoly.coq_poly_of_linpol cst lp) in
	776	Mc.PsatzMulC (lp, cmpl p)
	777	\| Square lp -> Mc.PsatzSquare (norm (LinPoly.coq_poly_of_linpol cst lp))
	778	\| _ -> failwith "Cuts should already be compiled"
	779	in
805	780	cmpl prf
806	781
807
808
809
810		let cmpl_prf_rule_z env r = cmpl_prf_rule Mc.normZ (fun x -> CamlToCoq.bigint (numerator x)) env r
811
812		let rec cmpl_proof env = function
813		\| Done -> Mc.DoneProof
814		\| Step(i,p,prf) ->
815		begin
816		match p with
817		\| CutPrf p' ->
818		Mc.CutProof(cmpl_prf_rule_z env p', cmpl_proof (i::env) prf)
819		\| _ -> Mc.RatProof(cmpl_prf_rule_z env p,cmpl_proof (i::env) prf)
820		end
821		\| Enum(i,p1,_,p2,l) ->
822		Mc.EnumProof(cmpl_prf_rule_z env p1,cmpl_prf_rule_z env p2,List.map (cmpl_proof (i::env)) l)
823
	782	let cmpl_prf_rule_z env r =
	783	cmpl_prf_rule Mc.normZ (fun x -> CamlToCoq.bigint (numerator x)) env r
	784
	785	let rec cmpl_proof env = function
	786	\| Done -> Mc.DoneProof
	787	\| Step (i, p, prf) -> (
	788	match p with
	789	\| CutPrf p' ->
	790	Mc.CutProof (cmpl_prf_rule_z env p', cmpl_proof (i :: env) prf)
	791	\| _ -> Mc.RatProof (cmpl_prf_rule_z env p, cmpl_proof (i :: env) prf) )
	792	\| Enum (i, p1, _, p2, l) ->
	793	Mc.EnumProof
	794	( cmpl_prf_rule_z env p1
	795	, cmpl_prf_rule_z env p2
	796	, List.map (cmpl_proof (i :: env)) l )
	797	\| ExProof (i, j, k, x, _, _, prf) ->
	798	Mc.ExProof (CamlToCoq.positive x, cmpl_proof (i :: j :: k :: env) prf)
824	799
825	800	let compile_proof env prf =
826	801	let id = 1 + proof_max_id prf in
827		let _,prf = normalise_proof id prf in
	802	let _, prf = normalise_proof id prf in
828	803	cmpl_proof env prf
829	804
830	805	let rec eval_prf_rule env = function
831		\| Annot(s,p) -> eval_prf_rule env p
	806	\| Annot (s, p) -> eval_prf_rule env p
832	807	\| Hyp i \| Def i -> env i
833		\| Cst n -> (Vect.set 0 n Vect.null,
834		match Num.compare_num n (Int 0) with
835		\| 0 -> Ge
836		\| 1 -> Gt
837		\| _ -> failwith "eval_prf_rule : negative constant"
838		)
839		\| Zero -> (Vect.null, Ge)
840		\| Square v -> (LinPoly.product v v,Ge)
841		\| MulC(v, p) ->
842		let (p1,o) = eval_prf_rule env p in
843		begin match o with
844		\| Eq -> (LinPoly.product v p1,Eq)
845		\| _ ->
846		Printf.fprintf stdout "MulC(%a,%a) invalid 2d arg %a %s" Vect.pp v output_prf_rule p Vect.pp p1 (string_of_op o);
847		failwith "eval_prf_rule : not an equality"
848		end
849		\| Gcd(g,p) -> let (v,op) = eval_prf_rule env p in
850		(Vect.div (Big_int g) v, op)
851		\| MulPrf(p1,p2) ->
852		let (v1,o1) = eval_prf_rule env p1 in
853		let (v2,o2) = eval_prf_rule env p2 in
854		(LinPoly.product v1 v2, opMult o1 o2)
855		\| AddPrf(p1,p2) ->
856		let (v1,o1) = eval_prf_rule env p1 in
857		let (v2,o2) = eval_prf_rule env p2 in
858		(LinPoly.addition v1 v2, opAdd o1 o2)
859		\| CutPrf p -> eval_prf_rule env p
860
861
862		let is_unsat (p,o) =
863		let (c,r) = Vect.decomp_cst p in
864		if Vect.is_null r
865		then not (eval_op o c (Int 0))
866		else false
	808	\| Cst n -> (
	809	( Vect.set 0 n Vect.null
	810	, match Num.compare_num n (Int 0) with
	811	\| 0 -> Ge
	812	\| 1 -> Gt
	813	\| _ -> failwith "eval_prf_rule : negative constant" ) )
	814	\| Zero -> (Vect.null, Ge)
	815	\| Square v -> (LinPoly.product v v, Ge)
	816	\| MulC (v, p) -> (
	817	let p1, o = eval_prf_rule env p in
	818	match o with
	819	\| Eq -> (LinPoly.product v p1, Eq)
	820	\| _ ->
	821	Printf.fprintf stdout "MulC(%a,%a) invalid 2d arg %a %s" Vect.pp v
	822	output_prf_rule p Vect.pp p1 (string_of_op o);
	823	failwith "eval_prf_rule : not an equality" )
	824	\| Gcd (g, p) ->
	825	let v, op = eval_prf_rule env p in
	826	(Vect.div (Big_int g) v, op)
	827	\| MulPrf (p1, p2) ->
	828	let v1, o1 = eval_prf_rule env p1 in
	829	let v2, o2 = eval_prf_rule env p2 in
	830	(LinPoly.product v1 v2, opMult o1 o2)
	831	\| AddPrf (p1, p2) ->
	832	let v1, o1 = eval_prf_rule env p1 in
	833	let v2, o2 = eval_prf_rule env p2 in
	834	(LinPoly.addition v1 v2, opAdd o1 o2)
	835	\| CutPrf p -> eval_prf_rule env p
	836
	837	let is_unsat (p, o) =
	838	let c, r = Vect.decomp_cst p in
	839	if Vect.is_null r then not (eval_op o c (Int 0)) else false
867	840
868	841	let rec eval_proof env p =
869	842	match p with
870	843	\| Done -> failwith "Proof is not finished"
871		\| Step(i, prf, rst) ->
872		let (p,o) = eval_prf_rule (fun i -> IMap.find i env) prf in
873		if is_unsat (p,o) then true
874		else
875		if (=) rst Done
876		then
877		begin
878		Printf.fprintf stdout "Last inference %a %s\n" LinPoly.pp p (string_of_op o);
879		false
880		end
881		else eval_proof (IMap.add i (p,o) env) rst
882		\| Enum(i,r1,v,r2,l) -> let _ = eval_prf_rule (fun i -> IMap.find i env) r1 in
883		let _ = eval_prf_rule (fun i -> IMap.find i env) r2 in
884		(* Should check bounds *)
885		failwith "Not implemented"
886
	844	\| Step (i, prf, rst) ->
	845	let p, o = eval_prf_rule (fun i -> IMap.find i env) prf in
	846	if is_unsat (p, o) then true
	847	else if rst = Done then begin
	848	Printf.fprintf stdout "Last inference %a %s\n" LinPoly.pp p
	849	(string_of_op o);
	850	false
	851	end
	852	else eval_proof (IMap.add i (p, o) env) rst
	853	\| Enum (i, r1, v, r2, l) ->
	854	let _ = eval_prf_rule (fun i -> IMap.find i env) r1 in
	855	let _ = eval_prf_rule (fun i -> IMap.find i env) r2 in
	856	(* Should check bounds *)
	857	failwith "Not implemented"
	858	\| ExProof _ -> failwith "Not implemented"
887	859	end
888	860
889		module WithProof = struct
890
891		type t = ((LinPoly.t * op) * ProofFormat.prf_rule)
892
893		let annot s (p,prf) = (p, ProofFormat.Annot(s,prf))
894
895		let output o ((lp,op),prf) =
896		Printf.fprintf o "%a %s 0 by %a\n" LinPoly.pp lp (string_of_op op) ProofFormat.output_prf_rule prf
897
898		let output_sys o l =
899		List.iter (Printf.fprintf o "%a\n" output) l
	861	module WithProof = struct
	862	type t = (LinPoly.t * op) * ProofFormat.prf_rule
	863
	864	let annot s (p, prf) = (p, ProofFormat.Annot (s, prf))
	865
	866	let output o ((lp, op), prf) =
	867	Printf.fprintf o "%a %s 0 by %a\n" LinPoly.pp lp (string_of_op op)
	868	ProofFormat.output_prf_rule prf
	869
	870	let output_sys o l = List.iter (Printf.fprintf o "%a\n" output) l
900	871
901	872	exception InvalidProof
902	873
903		let zero = ((Vect.null,Eq), ProofFormat.Zero)
904
905		let const n = ((LinPoly.constant n,Ge), ProofFormat.Cst n)
906
907		let of_cstr (c,prf) =
908		(Vect.set 0 (Num.minus_num (c.cst)) c.coeffs,c.op), prf
909
910		let product : t -> t -> t = fun ((p1,o1),prf1) ((p2,o2),prf2) ->
911		((LinPoly.product p1 p2 , opMult o1 o2), ProofFormat.mul_proof prf1 prf2)
912
913		let addition : t -> t -> t = fun ((p1,o1),prf1) ((p2,o2),prf2) ->
	874	let zero = ((Vect.null, Eq), ProofFormat.Zero)
	875	let const n = ((LinPoly.constant n, Ge), ProofFormat.Cst n)
	876	let of_cstr (c, prf) = ((Vect.set 0 (Num.minus_num c.cst) c.coeffs, c.op), prf)
	877
	878	let product : t -> t -> t =
	879	fun ((p1, o1), prf1) ((p2, o2), prf2) ->
	880	((LinPoly.product p1 p2, opMult o1 o2), ProofFormat.mul_proof prf1 prf2)
	881
	882	let addition : t -> t -> t =
	883	fun ((p1, o1), prf1) ((p2, o2), prf2) ->
914	884	((Vect.add p1 p2, opAdd o1 o2), ProofFormat.add_proof prf1 prf2)
915	885
916		let mult p ((p1,o1),prf1) =
	886	let mult p ((p1, o1), prf1) =
917	887	match o1 with
918		\| Eq -> ((LinPoly.product p p1,o1), ProofFormat.sMulC p prf1)
919		\| Gt\| Ge -> let (n,r) = Vect.decomp_cst p in
920		if Vect.is_null r && n >/ Int 0
921		then ((LinPoly.product p p1, o1), ProofFormat.mul_cst_proof n prf1)
922		else raise InvalidProof
923
924
925		let cutting_plane ((p,o),prf) =
926		let (c,p') = Vect.decomp_cst p in
927		let g = (Vect.gcd p') in
928		if (Big_int.eq_big_int Big_int.unit_big_int g) \|\| c =/ Int 0 \|\|
929		not (Big_int.eq_big_int (denominator c) Big_int.unit_big_int)
	888	\| Eq -> ((LinPoly.product p p1, o1), ProofFormat.sMulC p prf1)
	889	\| Gt \| Ge ->
	890	let n, r = Vect.decomp_cst p in
	891	if Vect.is_null r && n >/ Int 0 then
	892	((LinPoly.product p p1, o1), ProofFormat.mul_cst_proof n prf1)
	893	else (
	894	Printf.printf "mult_error %a [*] %a\n" LinPoly.pp p output
	895	((p1, o1), prf1);
	896	raise InvalidProof )
	897
	898	let cutting_plane ((p, o), prf) =
	899	let c, p' = Vect.decomp_cst p in
	900	let g = Vect.gcd p' in
	901	if
	902	Big_int.eq_big_int Big_int.unit_big_int g
	903	\|\| c =/ Int 0
	904	\|\| not (Big_int.eq_big_int (denominator c) Big_int.unit_big_int)
930	905	then None (* Nothing to do *)
931	906	else
932		let c1 = c // (Big_int g) in
	907	let c1 = c // Big_int g in
933	908	let c1' = Num.floor_num c1 in
934		if c1 =/ c1'
935		then None
	909	if c1 =/ c1' then None
936	910	else
937	911	match o with
938		\| Eq -> Some ((Vect.set 0 (Int (-1)) Vect.null,Eq), ProofFormat.Gcd(g,prf))
	912	\| Eq ->
	913	Some ((Vect.set 0 (Int (-1)) Vect.null, Eq), ProofFormat.Gcd (g, prf))
939	914	\| Gt -> failwith "cutting_plane ignore strict constraints"
940	915	\| Ge ->
941		(* This is a non-trivial common divisor *)
942		Some ((Vect.set 0 c1' (Vect.div (Big_int g) p),o),ProofFormat.Gcd(g, prf))
943
	916	(* This is a non-trivial common divisor *)
	917	Some
	918	( (Vect.set 0 c1' (Vect.div (Big_int g) p), o)
	919	, ProofFormat.Gcd (g, prf) )
944	920
945	921	let construct_sign p =
946		let (c,p') = Vect.decomp_cst p in
947		if Vect.is_null p'
948		then
949		Some (begin match sign_num c with
950		\| 0 -> (true, Eq, ProofFormat.Zero)
951		\| 1 -> (true,Gt, ProofFormat.Cst c)
952		\| _ (-1) -> (false,Gt, ProofFormat.Cst (minus_num c))
953		end)
	922	let c, p' = Vect.decomp_cst p in
	923	if Vect.is_null p' then
	924	Some
	925	( match sign_num c with
	926	\| 0 -> (true, Eq, ProofFormat.Zero)
	927	\| 1 -> (true, Gt, ProofFormat.Cst c)
	928	\| _ (-1) -> (false, Gt, ProofFormat.Cst (minus_num c)) )
954	929	else None
955
956	930
957	931	let get_sign l p =
958	932	match construct_sign p with
959		\| None -> begin
	933	\| None -> (
	934	try
	935	let (p', o), prf =
	936	List.find (fun ((p', o), prf) -> Vect.equal p p') l
	937	in
	938	Some (true, o, prf)
	939	with Not_found -> (
	940	let p = Vect.uminus p in
960	941	try
961		let ((p',o),prf) =
962		List.find (fun ((p',o),prf) -> Vect.equal p p') l in
963		Some (true,o,prf)
964		with Not_found ->
965		let p = Vect.uminus p in
966		try
967		let ((p',o),prf) = List.find (fun ((p',o),prf) -> Vect.equal p p') l in
968		Some (false,o,prf)
969		with Not_found -> None
970		end
	942	let (p', o), prf =
	943	List.find (fun ((p', o), prf) -> Vect.equal p p') l
	944	in
	945	Some (false, o, prf)
	946	with Not_found -> None ) )
971	947	\| Some s -> Some s
972	948
973
974		let mult_sign : bool -> t -> t = fun b ((p,o),prf) ->
975		if b then ((p,o),prf)
976		else ((Vect.uminus p,o),prf)
977
978
979		let rec linear_pivot sys ((lp1,op1), prf1) x ((lp2,op2), prf2) =
980
	949	let mult_sign : bool -> t -> t =
	950	fun b ((p, o), prf) -> if b then ((p, o), prf) else ((Vect.uminus p, o), prf)
	951
	952	let rec linear_pivot sys ((lp1, op1), prf1) x ((lp2, op2), prf2) =
981	953	(* lp1 = a1.x + b1 *)
982		let (a1,b1) = LinPoly.factorise x lp1 in
983
	954	let a1, b1 = LinPoly.factorise x lp1 in
984	955	(* lp2 = a2.x + b2 *)
985		let (a2,b2) = LinPoly.factorise x lp2 in
986
987		if Vect.is_null a2
988		then (* We are done *)
989		Some ((lp2,op2),prf2)
	956	let a2, b2 = LinPoly.factorise x lp2 in
	957	if Vect.is_null a2 then (* We are done *)
	958	Some ((lp2, op2), prf2)
990	959	else
991		match op1,op2 with
992		\| Eq , (Ge\|Gt) -> begin
993		match get_sign sys a1 with
994		\| None -> None (* Impossible to pivot without sign information *)
995		\| Some(b,o,prf) ->
996		let sa1 = mult_sign b ((a1,o),prf) in
997		let sa2 = if b then (Vect.uminus a2) else a2 in
998
999		let ((lp2,op2),prf2) =
1000		addition (product sa1 ((lp2,op2),prf2))
1001		(mult sa2 ((lp1,op1),prf1)) in
1002		linear_pivot sys ((lp1,op1),prf1) x ((lp2,op2),prf2)
1003
1004		end
1005		\| Eq , Eq ->
1006		let ((lp2,op2),prf2) = addition (mult a1 ((lp2,op2),prf2))
1007		(mult (Vect.uminus a2) ((lp1,op1),prf1)) in
1008		linear_pivot sys ((lp1,op1),prf1) x ((lp2,op2),prf2)
1009
1010		\| (Ge \| Gt) , (Ge\| Gt) -> begin
1011		match get_sign sys a1 , get_sign sys a2 with
1012		\| Some(b1,o1,p1) , Some(b2,o2,p2) ->
1013		if b1 <> b2
1014		then
1015		let ((lp2,op2),prf2) =
1016		addition (product (mult_sign b1 ((a1,o1), p1)) ((lp2,op2),prf2))
1017		(product (mult_sign b2 ((a2,o2), p2)) ((lp1,op1),prf1)) in
1018		linear_pivot sys ((lp1,op1),prf1) x ((lp2,op2),prf2)
1019		else None
1020		\| _ -> None
1021		end
1022		\| (Ge\|Gt) , Eq -> failwith "pivot: equality as second argument"
1023
1024		let linear_pivot sys ((lp1,op1), prf1) x ((lp2,op2), prf2) =
1025		match linear_pivot sys ((lp1,op1), prf1) x ((lp2,op2), prf2) with
	960	match (op1, op2) with
	961	\| Eq, (Ge \| Gt) -> (
	962	match get_sign sys a1 with
	963	\| None -> None (* Impossible to pivot without sign information *)
	964	\| Some (b, o, prf) ->
	965	let sa1 = mult_sign b ((a1, o), prf) in
	966	let sa2 = if b then Vect.uminus a2 else a2 in
	967	let (lp2, op2), prf2 =
	968	addition
	969	(product sa1 ((lp2, op2), prf2))
	970	(mult sa2 ((lp1, op1), prf1))
	971	in
	972	linear_pivot sys ((lp1, op1), prf1) x ((lp2, op2), prf2) )
	973	\| Eq, Eq ->
	974	let (lp2, op2), prf2 =
	975	addition
	976	(mult a1 ((lp2, op2), prf2))
	977	(mult (Vect.uminus a2) ((lp1, op1), prf1))
	978	in
	979	linear_pivot sys ((lp1, op1), prf1) x ((lp2, op2), prf2)
	980	\| (Ge \| Gt), (Ge \| Gt) -> (
	981	match (get_sign sys a1, get_sign sys a2) with
	982	\| Some (b1, o1, p1), Some (b2, o2, p2) ->
	983	if b1 <> b2 then
	984	let (lp2, op2), prf2 =
	985	addition
	986	(product (mult_sign b1 ((a1, o1), p1)) ((lp2, op2), prf2))
	987	(product (mult_sign b2 ((a2, o2), p2)) ((lp1, op1), prf1))
	988	in
	989	linear_pivot sys ((lp1, op1), prf1) x ((lp2, op2), prf2)
	990	else None
	991	\| _ -> None )
	992	\| (Ge \| Gt), Eq -> failwith "pivot: equality as second argument"
	993
	994	let linear_pivot sys ((lp1, op1), prf1) x ((lp2, op2), prf2) =
	995	match linear_pivot sys ((lp1, op1), prf1) x ((lp2, op2), prf2) with
1026	996	\| None -> None
1027		\| Some (c,p) -> Some(c, ProofFormat.simplify_prf_rule p)
1028
1029
1030		let is_substitution strict ((p,o),prf) =
1031		let pred v = if strict then v =/ Int 1 \|\| v =/ Int (-1) else true in
1032
1033		match o with
1034		\| Eq -> LinPoly.search_linear pred p
1035		\| _ -> None
1036
1037
1038		let subst1 sys0 =
1039		let (oeq,sys') = extract (is_substitution true) sys0 in
1040		match oeq with
	997	\| Some (c, p) -> Some (c, ProofFormat.simplify_prf_rule p)
	998
	999	let is_substitution strict ((p, o), prf) =
	1000	let pred v = if strict then v =/ Int 1 \|\| v =/ Int (-1) else true in
	1001	match o with Eq -> LinPoly.search_linear pred p \| _ -> None
	1002
	1003	let subst1 sys0 =
	1004	let oeq, sys' = extract (is_substitution true) sys0 in
	1005	match oeq with
1041	1006	\| None -> sys0
1042		\| Some(v,pc) ->
1043		match simplify (linear_pivot sys0 pc v) sys' with
1044		\| None -> sys0
1045		\| Some sys' -> sys'
1046
1047
1048
1049		let subst sys0 =
1050		let elim sys =
1051		let (oeq,sys') = extract (is_substitution true) sys in
1052		match oeq with
1053		\| None -> None
1054		\| Some(v,pc) -> simplify (linear_pivot sys0 pc v) sys' in
1055
1056		iterate_until_stable elim sys0
1057
1058
1059		let saturate_subst b sys0 =
1060		let select = is_substitution b in
1061		let gen (v,pc) ((c,op),prf) =
1062		if ISet.mem v (LinPoly.variables c)
1063		then linear_pivot sys0 pc v ((c,op),prf)
1064		else None
1065		in
1066		saturate select gen sys0
1067
1068
	1007	\| Some (v, pc) -> (
	1008	match simplify (linear_pivot sys0 pc v) sys' with
	1009	\| None -> sys0
	1010	\| Some sys' -> sys' )
	1011
	1012	let subst sys0 =
	1013	let elim sys =
	1014	let oeq, sys' = extract (is_substitution true) sys in
	1015	match oeq with
	1016	\| None -> None
	1017	\| Some (v, pc) -> simplify (linear_pivot sys0 pc v) sys'
	1018	in
	1019	iterate_until_stable elim sys0
	1020
	1021	let saturate_subst b sys0 =
	1022	let select = is_substitution b in
	1023	let gen (v, pc) ((c, op), prf) =
	1024	if ISet.mem v (LinPoly.variables c) then
	1025	linear_pivot sys0 pc v ((c, op), prf)
	1026	else None
	1027	in
	1028	saturate select gen sys0
1069	1029	end
1070
1071	1030
1072	1031	(* Local Variables: *)
1073	1032	(* coding: utf-8 *)

+132

-129

plugins/micromega/polynomial.mli less more

8	8	(************************************************************************)
9	9
10	10	open Mutils
11
12	11	module Mc = Micromega
13	12
14	13	val max_nb_cstr : int ref

16	15	type var = int
17	16
18	17	module Monomial : sig
	18	type t
19	19	(** A monomial is represented by a multiset of variables *)
20		type t
21
22		(** [fold f m acc]
	20
	21	val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a
	22	(** [fold f m acc]
23	23	folds over the variables with multiplicities *)
24		val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a
25
	24
	25	val degree : t -> int
	26	(** [degree m] is the sum of the degrees of each variable *)
	27
	28	val const : t
26	29	(** [const]
27	30	@return the empty monomial i.e. without any variable *)
28		val const : t
29	31
30	32	val is_const : t -> bool
31	33
	34	val var : var -> t
32	35	(** [var x]
33	36	@return the monomial x^1 *)
34		val var : var -> t
35
	37
	38	val prod : t -> t -> t
	39	(** [prod n m]
	40	@return the monomial nm )
	41
	42	val sqrt : t -> t option
36	43	(** [sqrt m]
37	44	@return [Some r] iff r^2 = m *)
38		val sqrt : t -> t option
39
	45
	46	val is_var : t -> bool
40	47	(** [is_var m]
41	48	@return [true] iff m = x^1 for some variable x *)
42		val is_var : t -> bool
43
	49
	50	val get_var : t -> var option
44	51	(** [get_var m]
45	52	@return [x] iff m = x^1 for variable x *)
46		val get_var : t -> var option
47
48
	53
	54	val div : t -> t -> t * int
49	55	(** [div m1 m2]
50	56	@return a pair [mr,n] such that mr * (m2)^n = m1 where n is maximum *)
51		val div : t -> t -> t * int
52
	57
	58	val compare : t -> t -> int
53	59	(** [compare m1 m2] provides a total order over monomials*)
54		val compare : t -> t -> int
55
	60
	61	val variables : t -> ISet.t
56	62	(** [variables m]
57	63	@return the set of variables with (strictly) positive multiplicities *)
58		val variables : t -> ISet.t
59	64	end
60	65
61	66	module MonMap : sig

75	80
76	81	type t
77	82
	83	val constant : Num.num -> t
78	84	(** [constant c]
79	85	@return the constant polynomial c *)
80		val constant : Num.num -> t
81
	86
	87	val variable : var -> t
82	88	(** [variable x]
83	89	@return the polynomial 1.x^1 *)
84		val variable : var -> t
85
	90
	91	val addition : t -> t -> t
86	92	(** [addition p1 p2]
87	93	@return the polynomial p1+p2 *)
88		val addition : t -> t -> t
89
	94
	95	val product : t -> t -> t
90	96	(** [product p1 p2]
91	97	@return the polynomial p1p2 )
92		val product : t -> t -> t
93
	98
	99	val uminus : t -> t
94	100	(** [uminus p]
95	101	@return the polynomial -p i.e product by -1 *)
96		val uminus : t -> t
97
	102
	103	val get : Monomial.t -> t -> Num.num
98	104	(** [get mi p]
99	105	@return the coefficient ai of the monomial mi. *)
100		val get : Monomial.t -> t -> Num.num
101
102
	106
	107	val fold : (Monomial.t -> Num.num -> 'a -> 'a) -> t -> 'a -> 'a
103	108	(** [fold f p a] folds f over the monomials of p with non-zero coefficient *)
104		val fold : (Monomial.t -> Num.num -> 'a -> 'a) -> t -> 'a -> 'a
105
	109
	110	val add : Monomial.t -> Num.num -> t -> t
106	111	(** [add m n p]
107	112	@return the polynomial nm + p )
108		val add : Monomial.t -> Num.num -> t -> t
109
110		end
111
112		type cstr = {coeffs : Vect.t ; op : op ; cst : Num.num} (* Representation of linear constraints *)
	113	end
	114
	115	type cstr = {coeffs : Vect.t; op : op; cst : Num.num}
	116
	117	(* Representation of linear constraints *)
113	118	and op = Eq \| Ge \| Gt
114	119
115	120	val eval_op : op -> Num.num -> Num.num -> bool
116	121
117	122	(val opMult : op -> op -> op)
118	123
119		val opAdd : op -> op -> op
120
	124	val opAdd : op -> op -> op
	125
	126	val is_strict : cstr -> bool
121	127	(** [is_strict c]
122	128	@return whether the constraint is strict i.e. c.op = Gt *)
123		val is_strict : cstr -> bool
124	129
125	130	exception Strict
126	131

140	145	This is done using the monomial tables of the module MonT. *)
141	146
142	147	module MonT : sig
	148	val clear : unit -> unit
143	149	(** [clear ()] clears the mapping. *)
144		val clear : unit -> unit
145
	150
	151	val reserve : int -> unit
	152	(** [reserve i] reserves the integer i *)
	153
	154	val get_fresh : unit -> int
	155	(** [get_fresh ()] return the first fresh variable *)
	156
	157	val retrieve : int -> Monomial.t
146	158	(** [retrieve x]
147	159	@return the monomial corresponding to the variable [x] *)
148		val retrieve : int -> Monomial.t
149
	160
	161	val register : Monomial.t -> int
150	162	(** [register m]
151	163	@return the variable index for the monomial m *)
152		val register : Monomial.t -> int
153
154	164	end
155	165
	166	val linpol_of_pol : Poly.t -> t
156	167	(** [linpol_of_pol p] linearise the polynomial p *)
157		val linpol_of_pol : Poly.t -> t
158
	168
	169	val var : var -> t
159	170	(** [var x]
160	171	@return 1.y where y is the variable index of the monomial x^1.
161	172	*)
162		val var : var -> t
163
	173
	174	val coq_poly_of_linpol : (Num.num -> 'a) -> t -> 'a Mc.pExpr
164	175	(** [coq_poly_of_linpol c p]
165	176	@param p is a multi-variate polynomial.
166	177	@param c maps a rational to a Coq polynomial coefficient.
167	178	@return the coq expression corresponding to polynomial [p].*)
168		val coq_poly_of_linpol : (Num.num -> 'a) -> t -> 'a Mc.pExpr
169
	179
	180	val of_monomial : Monomial.t -> t
170	181	(** [of_monomial m]
171	182	@returns 1.x where x is the variable (index) for monomial m *)
172		val of_monomial : Monomial.t -> t
173
174		(** [of_vect v]
	183
	184	val of_vect : Vect.t -> t
	185	(** [of_vect v]
175	186	@returns a1.x1 + ... + an.xn
176	187	This is not the identity because xi is the variable index of xi^1
177	188	*)
178		val of_vect : Vect.t -> t
179
	189
	190	val variables : t -> ISet.t
180	191	(** [variables p]
181	192	@return the set of variables of the polynomial p
182	193	interpreted as a multi-variate polynomial *)
183		val variables : t -> ISet.t
184
	194
	195	val is_variable : t -> var option
185	196	(** [is_variable p]
186	197	@return Some x if p = a.x for a >= 0 *)
187		val is_variable : t -> var option
188
	198
	199	val is_linear : t -> bool
189	200	(** [is_linear p]
190	201	@return whether the multi-variate polynomial is linear. *)
191		val is_linear : t -> bool
192
	202
	203	val is_linear_for : var -> t -> bool
193	204	(** [is_linear_for x p]
194	205	@return true if the polynomial is linear in x
195	206	i.e can be written cx+r where c is a constant and r is independent from x )
196		val is_linear_for : var -> t -> bool
197
	207
	208	val constant : Num.num -> t
198	209	(** [constant c]
199	210	@return the constant polynomial c
200	211	*)
201		val constant : Num.num -> t
202	212
203	213	(** [search_linear pred p]
204	214	@return a variable x such p = a.x + b such that

207	217
208	218	val search_linear : (Num.num -> bool) -> t -> var option
209	219
	220	val search_all_linear : (Num.num -> bool) -> t -> var list
210	221	(** [search_all_linear pred p]
211	222	@return all the variables x such p = a.x + b such that
212	223	p is linear in x i.e x does not occur in b and
213	224	a is a constant such that [pred a] *)
214		val search_all_linear : (Num.num -> bool) -> t -> var list
215
216		(** [product p q]
	225
	226	val product : t -> t -> t
	227	(** [product p q]
217	228	@return the product of the polynomial [pq] )
218		val product : t -> t -> t
219
	229
	230	val factorise : var -> t -> t * t
220	231	(** [factorise x p]
221	232	@return [a,b] such that [p = a.x + b]
222	233	and [x] does not occur in [b] *)
223		val factorise : var -> t -> t * t
224
	234
	235	val collect_square : t -> Monomial.t MonMap.t
225	236	(** [collect_square p]
226	237	@return a mapping m such that m[s] = s^2
227	238	for every s^2 that is a monomial of [p] *)
228		val collect_square : t -> Monomial.t MonMap.t
229
230
	239
	240	val monomials : t -> ISet.t
	241	(** [monomials p]
	242	@return the set of monomials. *)
	243
	244	val degree : t -> int
	245	(** [degree p]
	246	@return return the maximum degree *)
	247
	248	val pp_var : out_channel -> var -> unit
231	249	(** [pp_var o v] pretty-prints a monomial indexed by v. *)
232		val pp_var : out_channel -> var -> unit
233
	250
	251	val pp : out_channel -> t -> unit
234	252	(** [pp o p] pretty-prints a polynomial. *)
235		val pp : out_channel -> t -> unit
236
	253
	254	val pp_goal : string -> out_channel -> (t * op) list -> unit
237	255	(** [pp_goal typ o l] pretty-prints the list of constraints as a Coq goal. *)
238		val pp_goal : string -> out_channel -> (t * op) list -> unit
239
240	256	end
241	257
242	258	module ProofFormat : sig

251	267	\| Annot of string * prf_rule
252	268	\| Hyp of int
253	269	\| Def of int
254		\| Cst of Num.num
	270	\| Cst of Num.num
255	271	\| Zero
256	272	\| Square of Vect.t
257	273	\| MulC of Vect.t * prf_rule

264	280	\| Done
265	281	\| Step of int * prf_rule * proof
266	282	\| Enum of int * prf_rule * Vect.t * prf_rule * proof list
	283	\| ExProof of int * int * int * var * var * var * proof
	284
	285	(* x = z - t, z >= 0, t >= 0 *)
267	286
268	287	val pr_size : prf_rule -> Num.num
269
270	288	val pr_rule_max_id : prf_rule -> int
271
272	289	val proof_max_id : proof -> int
273
274	290	val normalise_proof : int -> proof -> int * proof
275
276	291	val output_prf_rule : out_channel -> prf_rule -> unit
277
278	292	val output_proof : out_channel -> proof -> unit
279
280	293	val add_proof : prf_rule -> prf_rule -> prf_rule
281
282	294	val mul_cst_proof : Num.num -> prf_rule -> prf_rule
283
284	295	val mul_proof : prf_rule -> prf_rule -> prf_rule
285
286	296	val compile_proof : int list -> proof -> Micromega.zArithProof
287	297
288		val cmpl_prf_rule : ('a Micromega.pExpr -> 'a Micromega.pol) ->
289		(Num.num -> 'a) -> (int list) -> prf_rule -> 'a Micromega.psatz
	298	val cmpl_prf_rule :
	299	('a Micromega.pExpr -> 'a Micromega.pol)
	300	-> (Num.num -> 'a)
	301	-> int list
	302	-> prf_rule
	303	-> 'a Micromega.psatz
290	304
291	305	val proof_of_farkas : prf_rule IMap.t -> Vect.t -> prf_rule
292
293	306	val eval_prf_rule : (int -> LinPoly.t * op) -> prf_rule -> LinPoly.t * op
294
295	307	val eval_proof : (LinPoly.t * op) IMap.t -> proof -> bool
296
297	308	end
298	309
299	310	val output_cstr : out_channel -> cstr -> unit
300
301	311	val opMult : op -> op -> op
302	312
303	313	(** [module WithProof] constructs polynomials packed with the proof that their sign is correct. *)
304		module WithProof :
305		sig
306
	314	module WithProof : sig
307	315	type t = (LinPoly.t * op) * ProofFormat.prf_rule
308	316
	317	exception InvalidProof
309	318	(** [InvalidProof] is raised if the operation is invalid. *)
310		exception InvalidProof
311	319
312	320	val annot : string -> t -> t
313
314	321	val of_cstr : cstr * ProofFormat.prf_rule -> t
315	322
	323	val output : out_channel -> t -> unit
316	324	(** [out_channel chan c] pretty-prints the constraint [c] over the channel [chan] *)
317		val output : out_channel -> t -> unit
318	325
319	326	val output_sys : out_channel -> t list -> unit
320	327
	328	val zero : t
321	329	(** [zero] represents the tautology (0=0) *)
322		val zero : t
323
	330
	331	val const : Num.num -> t
324	332	(** [const n] represents the tautology (n>=0) *)
325		val const : Num.num -> t
326
	333
	334	val product : t -> t -> t
327	335	(** [product p q]
328	336	@return the polynomial pq with its sign and proof )
329		val product : t -> t -> t
330
	337
	338	val addition : t -> t -> t
331	339	(** [addition p q]
332	340	@return the polynomial p+q with its sign and proof *)
333		val addition : t -> t -> t
334
	341
	342	val mult : LinPoly.t -> t -> t
335	343	(** [mult p q]
336	344	@return the polynomial p*q with its sign and proof.
337	345	@raise InvalidProof if p is not a constant and p is not an equality *)
338		val mult : LinPoly.t -> t -> t
339
	346
	347	val cutting_plane : t -> t option
340	348	(** [cutting_plane p] does integer reasoning and adjust the constant to be integral *)
341		val cutting_plane : t -> t option
342
	349
	350	val linear_pivot : t list -> t -> Vect.var -> t -> t option
343	351	(** [linear_pivot sys p x q]
344	352	@return the polynomial [q] where [x] is eliminated using the polynomial [p]
345	353	The pivoting operation is only defined if
346	354	- p is linear in x i.e p = a.x+b and x neither occurs in a and b
347	355	- The pivoting also requires some sign conditions for [a]
348	356	*)
349		val linear_pivot : t list -> t -> Vect.var -> t -> t option
350
351
352		(** [subst sys] performs the equivalent of the 'subst' tactic of Coq.
	357
	358	(** [subst sys] performs the equivalent of the 'subst' tactic of Coq.
353	359	For every p=0 \in sys such that p is linear in x with coefficient +/- 1
354	360	i.e. p = 0 <-> x = e and x \notin e.
355	361	Replace x by e in sys

360	366
361	367	val subst : t list -> t list
362	368
	369	val subst1 : t list -> t list
363	370	(** [subst1 sys] performs a single substitution *)
364		val subst1 : t list -> t list
365	371
366	372	val saturate_subst : bool -> t list -> t list
367
368
369	373	val is_substitution : bool -> t -> var option
370
371		end
	374	end

+456

-438

plugins/micromega/simplex.ml less more

7	7	(* * (see LICENSE file for the text of the license) *)
8	8	(************************************************************************)
9	9
10		(** A naive simplex *)
11	10	open Polynomial
12	11	open Num
	12
13	13	(open Util)
14	14	open Mutils
15	15
16		type ('a,'b) sum = Inl of 'a \| Inr of 'b
	16	type ('a, 'b) sum = Inl of 'a \| Inr of 'b
17	17
18	18	let debug = false
19	19
20	20	type iset = unit IMap.t
21	21
22		type tableau = Vect.t IMap.t (** Mapping basic variables to their equation.
	22	type tableau = Vect.t IMap.t
	23	(** Mapping basic variables to their equation.
23	24	All variables >= than a threshold rst are restricted.*)
24	25
25		module Restricted =
26		struct
27		type t =
28		{
29		base : int; (** All variables above [base] are restricted *)
30		exc : int option (** Except [exc] which is currently optimised *)
31		}
32
33		let pp o {base;exc} =
34		Printf.fprintf o ">= %a " LinPoly.pp_var base;
35		match exc with
36		\| None ->Printf.fprintf o "-"
37		\| Some x ->Printf.fprintf o "-%a" LinPoly.pp_var base
38
39		let is_exception (x:var) (r:t) =
40		match r.exc with
41		\| None -> false
42		\| Some x' -> x = x'
43
44		let restrict x rst =
45		if is_exception x rst
46		then
47		{base = rst.base;exc= None}
48		else failwith (Printf.sprintf "Cannot restrict %i" x)
49
50
51		let is_restricted x r0 =
52		x >= r0.base && not (is_exception x r0)
53
54		let make x = {base = x ; exc = None}
55
56		let set_exc x rst = {base = rst.base ; exc = Some x}
57
58		let fold rst f m acc =
59		IMap.fold (fun k v acc ->
60		if is_exception k rst then acc
61		else f k v acc) (IMap.from rst.base m) acc
62
63		end
64
65
	26	module Restricted = struct
	27	type t =
	28	{ base : int (** All variables above [base] are restricted *)
	29	; exc : int option (** Except [exc] which is currently optimised *) }
	30
	31	let pp o {base; exc} =
	32	Printf.fprintf o ">= %a " LinPoly.pp_var base;
	33	match exc with
	34	\| None -> Printf.fprintf o "-"
	35	\| Some x -> Printf.fprintf o "-%a" LinPoly.pp_var base
	36
	37	let is_exception (x : var) (r : t) =
	38	match r.exc with None -> false \| Some x' -> x = x'
	39
	40	let restrict x rst =
	41	if is_exception x rst then {base = rst.base; exc = None}
	42	else failwith (Printf.sprintf "Cannot restrict %i" x)
	43
	44	let is_restricted x r0 = x >= r0.base && not (is_exception x r0)
	45	let make x = {base = x; exc = None}
	46	let set_exc x rst = {base = rst.base; exc = Some x}
	47
	48	let fold rst f m acc =
	49	IMap.fold
	50	(fun k v acc -> if is_exception k rst then acc else f k v acc)
	51	(IMap.from rst.base m) acc
	52	end
66	53
67	54	let pp_row o v = LinPoly.pp o v
68	55
69		let output_tableau o t =
70		IMap.iter (fun k v ->
71		Printf.fprintf o "%a = %a\n" LinPoly.pp_var k pp_row v) t
	56	let output_tableau o t =
	57	IMap.iter
	58	(fun k v -> Printf.fprintf o "%a = %a\n" LinPoly.pp_var k pp_row v)
	59	t
	60
	61	let output_env o t =
	62	IMap.iter
	63	(fun k v ->
	64	Printf.fprintf o "%a : %a\n" LinPoly.pp_var k WithProof.output v)
	65	t
72	66
73	67	let output_vars o m =
74	68	IMap.iter (fun k _ -> Printf.fprintf o "%a " LinPoly.pp_var k) m
75
76	69
77	70	(** A tableau is feasible iff for every basic restricted variable xi,
78	71	we have ci>=0.

82	75	if ci>=0.
83	76	*)
84	77
85
86		let unfeasible (rst:Restricted.t) tbl =
87		Restricted.fold rst (fun k v m ->
88		if Vect.get_cst v >=/ Int 0 then m
89		else IMap.add k () m) tbl IMap.empty
90
	78	let unfeasible (rst : Restricted.t) tbl =
	79	Restricted.fold rst
	80	(fun k v m -> if Vect.get_cst v >=/ Int 0 then m else IMap.add k () m)
	81	tbl IMap.empty
91	82
92	83	let is_feasible rst tb = IMap.is_empty (unfeasible rst tb)
93	84

104	95	*)
105	96
106	97	let is_maximised_vect rst v =
107		Vect.for_all (fun xi ai ->
108		if ai >/ Int 0
109		then false
110		else Restricted.is_restricted xi rst) v
111
	98	Vect.for_all
	99	(fun xi ai ->
	100	if ai >/ Int 0 then false else Restricted.is_restricted xi rst)
	101	v
112	102
113	103	(** [is_maximised rst v]
114	104	@return None if the variable is not maximised

116	106	*)
117	107	let is_maximised rst v =
118	108	try
119		let (vl,v) = Vect.decomp_cst v in
120		if is_maximised_vect rst v
121		then Some vl
122		else None
	109	let vl, v = Vect.decomp_cst v in
	110	if is_maximised_vect rst v then Some vl else None
123	111	with Not_found -> None
124	112
125	113	(** A variable xi is unbounded if for every

131	119	violating a restriction.
132	120	*)
133	121
134
135	122	type result =
136		\| Max of num (** Maximum is reached *)
	123	\| Max of num (** Maximum is reached *)
137	124	\| Ubnd of var (** Problem is unbounded *)
138		\| Feas (** Problem is feasible *)
139
140		type pivot =
141		\| Done of result
142		\| Pivot of int * int * num
143
144
145
146
147		type simplex =
148		\| Opt of tableau * result
	125	\| Feas (** Problem is feasible *)
	126
	127	type pivot = Done of result \| Pivot of int * int * num
	128	type simplex = Opt of tableau * result
149	129
150	130	(** For a row, x = ao.xo+...+ai.xi
151	131	a valid pivot variable is such that it can improve the value of xi.

155	135	This is the entering variable.
156	136	*)
157	137
158		let rec find_pivot_column (rst:Restricted.t) (r:Vect.t) =
	138	let rec find_pivot_column (rst : Restricted.t) (r : Vect.t) =
159	139	match Vect.choose r with
160	140	\| None -> failwith "find_pivot_column"
161		\| Some(xi,ai,r') -> if ai </ Int 0
162		then if Restricted.is_restricted xi rst
163		then find_pivot_column rst r' (* ai.xi cannot be improved *)
164		else (xi, -1) (* r is not restricted, sign of ai does not matter *)
165		else (* ai is positive, xi can be increased *)
166		(xi,1)
	141	\| Some (xi, ai, r') ->
	142	if ai </ Int 0 then
	143	if Restricted.is_restricted xi rst then find_pivot_column rst r'
	144	(* ai.xi cannot be improved *)
	145	else (xi, -1) (* r is not restricted, sign of ai does not matter *)
	146	else (* ai is positive, xi can be increased *)
	147	(xi, 1)
167	148
168	149	(** Finding the variable leaving the basis is more subtle because we need to:
169	150	- increase the objective function

172	153	This explains why we choose the pivot with the smallest score
173	154	*)
174	155
175		let min_score s (i1,sc1) =
	156	let min_score s (i1, sc1) =
176	157	match s with
177		\| None -> Some (i1,sc1)
178		\| Some(i0,sc0) ->
179		if sc0 </ sc1 then s
180		else if sc1 </ sc0 then Some (i1,sc1)
181		else if i0 < i1 then s else Some(i1,sc1)
	158	\| None -> Some (i1, sc1)
	159	\| Some (i0, sc0) ->
	160	if sc0 </ sc1 then s
	161	else if sc1 </ sc0 then Some (i1, sc1)
	162	else if i0 < i1 then s
	163	else Some (i1, sc1)
182	164
183	165	let find_pivot_row rst tbl j sgn =
184	166	Restricted.fold rst
185	167	(fun i' v res ->
186	168	let aij = Vect.get j v in
187		if (Int sgn) */ aij </ Int 0
188		then (* This would improve *)
189		let score' = Num.abs_num ((Vect.get_cst v) // aij) in
190		min_score res (i',score')
191		else res) tbl None
	169	if Int sgn */ aij </ Int 0 then
	170	(* This would improve *)
	171	let score' = Num.abs_num (Vect.get_cst v // aij) in
	172	min_score res (i', score')
	173	else res)
	174	tbl None
192	175
193	176	let safe_find err x t =
194		try
195		IMap.find x t
	177	try IMap.find x t
196	178	with Not_found ->
197		if debug
198		then Printf.fprintf stdout "safe_find %s x%i %a\n" err x output_tableau t;
199		failwith err
200
	179	if debug then
	180	Printf.fprintf stdout "safe_find %s x%i %a\n" err x output_tableau t;
	181	failwith err
201	182
202	183	(** [find_pivot vr t] aims at improving the objective function of the basic variable vr *)
203		let find_pivot vr (rst:Restricted.t) tbl =
	184	let find_pivot vr (rst : Restricted.t) tbl =
204	185	(* Get the objective of the basic variable vr *)
205		let v = safe_find "find_pivot" vr tbl in
	186	let v = safe_find "find_pivot" vr tbl in
206	187	match is_maximised rst v with
207	188	\| Some mx -> Done (Max mx) (* Maximum is reached; we are done *)
208		\| None ->
209		(* Extract the vector *)
210		let (_,v) = Vect.decomp_cst v in
211		let (j',sgn) = find_pivot_column rst v in
212		match find_pivot_row rst (IMap.remove vr tbl) j' sgn with
213		\| None -> Done (Ubnd j')
214		\| Some (i',sc) -> Pivot(i', j', sc)
	189	\| None -> (
	190	(* Extract the vector *)
	191	let _, v = Vect.decomp_cst v in
	192	let j', sgn = find_pivot_column rst v in
	193	match find_pivot_row rst (IMap.remove vr tbl) j' sgn with
	194	\| None -> Done (Ubnd j')
	195	\| Some (i', sc) -> Pivot (i', j', sc) )
215	196
216	197	(** [solve_column c r e]
217	198	@param c is a non-basic variable

222	203	c = (r - e')/ai
223	204	*)
224	205
225		let solve_column (c : var) (r : var) (e : Vect.t) : Vect.t =
	206	let solve_column (c : var) (r : var) (e : Vect.t) : Vect.t =
226	207	let a = Vect.get c e in
227		if a =/ Int 0
228		then failwith "Cannot solve column"
	208	if a =/ Int 0 then failwith "Cannot solve column"
229	209	else
230		let a' = (Int (-1) // a) in
	210	let a' = Int (-1) // a in
231	211	Vect.mul a' (Vect.set r (Int (-1)) (Vect.set c (Int 0) e))
232	212
233	213	(** [pivot_row r c e]

235	215	@param r is a vector r = g.c + r'
236	216	@return g.e+r' *)
237	217
238		let pivot_row (row: Vect.t) (c : var) (e : Vect.t) : Vect.t =
	218	let pivot_row (row : Vect.t) (c : var) (e : Vect.t) : Vect.t =
239	219	let g = Vect.get c row in
240		if g =/ Int 0
241		then row
242		else Vect.mul_add g e (Int 1) (Vect.set c (Int 0) row)
243
244		let pivot_with (m : tableau) (v: var) (p : Vect.t) =
245		IMap.map (fun (r:Vect.t) -> pivot_row r v p) m
	220	if g =/ Int 0 then row else Vect.mul_add g e (Int 1) (Vect.set c (Int 0) row)
	221
	222	let pivot_with (m : tableau) (v : var) (p : Vect.t) =
	223	IMap.map (fun (r : Vect.t) -> pivot_row r v p) m
246	224
247	225	let pivot (m : tableau) (r : var) (c : var) =
248		let row = safe_find "pivot" r m in
	226	let row = safe_find "pivot" r m in
249	227	let piv = solve_column c r row in
250	228	IMap.add c piv (pivot_with (IMap.remove r m) c piv)
251	229
252
253	230	let adapt_unbounded vr x rst tbl =
254		if Vect.get_cst (IMap.find vr tbl) >=/ Int 0
255		then tbl
256		else pivot tbl vr x
257
258		module BaseSet = Set.Make(struct type t = iset let compare = IMap.compare (fun x y -> 0) end)
	231	if Vect.get_cst (IMap.find vr tbl) >=/ Int 0 then tbl else pivot tbl vr x
	232
	233	module BaseSet = Set.Make (struct
	234	type t = iset
	235
	236	let compare = IMap.compare (fun x y -> 0)
	237	end)
259	238
260	239	let get_base tbl = IMap.mapi (fun k _ -> ()) tbl
261	240
262	241	let simplex opt vr rst tbl =
263	242	let b = ref BaseSet.empty in
264
265		let rec simplex opt vr rst tbl =
266
267		if debug then begin
	243	let rec simplex opt vr rst tbl =
	244	( if debug then
268	245	let base = get_base tbl in
269		if BaseSet.mem base !b
270		then Printf.fprintf stdout "Cycling detected\n"
271		else b := BaseSet.add base !b
272		end;
273
274		if debug && not (is_feasible rst tbl)
275		then
276		begin
	246	if BaseSet.mem base !b then Printf.fprintf stdout "Cycling detected\n"
	247	else b := BaseSet.add base !b );
	248	if debug && not (is_feasible rst tbl) then begin
277	249	let m = unfeasible rst tbl in
278	250	Printf.fprintf stdout "Simplex error\n";
279	251	Printf.fprintf stdout "The current tableau is not feasible\n";
280		Printf.fprintf stdout "Restricted >= %a\n" Restricted.pp rst ;
	252	Printf.fprintf stdout "Restricted >= %a\n" Restricted.pp rst;
281	253	output_tableau stdout tbl;
282	254	Printf.fprintf stdout "Error for variables %a\n" output_vars m
283	255	end;
284
285		if not opt && (Vect.get_cst (IMap.find vr tbl) >=/ Int 0)
286		then Opt(tbl,Feas)
287		else
288		match find_pivot vr rst tbl with
289		\| Done r ->
290		begin match r with
291		\| Max _ -> Opt(tbl, r)
292		\| Ubnd x ->
	256	if (not opt) && Vect.get_cst (IMap.find vr tbl) >=/ Int 0 then
	257	Opt (tbl, Feas)
	258	else
	259	match find_pivot vr rst tbl with
	260	\| Done r -> (
	261	match r with
	262	\| Max _ -> Opt (tbl, r)
	263	\| Ubnd x ->
293	264	let t' = adapt_unbounded vr x rst tbl in
294		Opt(t',r)
295		\| Feas -> raise (Invalid_argument "find_pivot")
296		end
297		\| Pivot(i,j,s) ->
298		if debug then begin
299		Printf.fprintf stdout "Find pivot for x%i(%s)\n" vr (string_of_num s);
300		Printf.fprintf stdout "Leaving variable x%i\n" i;
301		Printf.fprintf stdout "Entering variable x%i\n" j;
302		end;
303		let m' = pivot tbl i j in
304		simplex opt vr rst m' in
305
306		simplex opt vr rst tbl
307
308
309
310		type certificate =
311		\| Unsat of Vect.t
312		\| Sat of tableau * var option
	265	Opt (t', r)
	266	\| Feas -> raise (Invalid_argument "find_pivot") )
	267	\| Pivot (i, j, s) ->
	268	if debug then begin
	269	Printf.fprintf stdout "Find pivot for x%i(%s)\n" vr (string_of_num s);
	270	Printf.fprintf stdout "Leaving variable x%i\n" i;
	271	Printf.fprintf stdout "Entering variable x%i\n" j
	272	end;
	273	let m' = pivot tbl i j in
	274	simplex opt vr rst m'
	275	in
	276	simplex opt vr rst tbl
	277
	278	type certificate = Unsat of Vect.t \| Sat of tableau * var option
313	279
314	280	(** [normalise_row t v]
315	281	@return a row obtained by pivoting the basic variables of the vector v
316	282	*)
317	283
318		let normalise_row (t : tableau) (v: Vect.t) =
319		Vect.fold (fun acc vr ai -> try
	284	let normalise_row (t : tableau) (v : Vect.t) =
	285	Vect.fold
	286	(fun acc vr ai ->
	287	try
320	288	let e = IMap.find vr t in
321	289	Vect.add (Vect.mul ai e) acc
322	290	with Not_found -> Vect.add (Vect.set vr ai Vect.null) acc)
323	291	Vect.null v
324	292
325		let normalise_row (t : tableau) (v: Vect.t) =
	293	let normalise_row (t : tableau) (v : Vect.t) =
326	294	let v' = normalise_row t v in
327	295	if debug then Printf.fprintf stdout "Normalised Optimising %a\n" LinPoly.pp v';
328	296	v'
329	297
330		let add_row (nw :var) (t : tableau) (v : Vect.t) : tableau =
	298	let add_row (nw : var) (t : tableau) (v : Vect.t) : tableau =
331	299	IMap.add nw (normalise_row t v) t
332	300
333
334
335	301	(** [push_real] performs reasoning over the rationals *)
336		let push_real (opt : bool) (nw : var) (v : Vect.t) (rst: Restricted.t) (t : tableau) : certificate =
337		if debug
338		then begin Printf.fprintf stdout "Current Tableau\n%a\n" output_tableau t;
339		Printf.fprintf stdout "Optimising %a=%a\n" LinPoly.pp_var nw LinPoly.pp v
340		end;
	302	let push_real (opt : bool) (nw : var) (v : Vect.t) (rst : Restricted.t)
	303	(t : tableau) : certificate =
	304	if debug then begin
	305	Printf.fprintf stdout "Current Tableau\n%a\n" output_tableau t;
	306	Printf.fprintf stdout "Optimising %a=%a\n" LinPoly.pp_var nw LinPoly.pp v
	307	end;
341	308	match simplex opt nw rst (add_row nw t v) with
342		\| Opt(t',r) -> (* Look at the optimal *)
343		match r with
344		\| Ubnd x->
345		if debug then Printf.printf "The objective is unbounded (variable %a)\n" LinPoly.pp_var x;
346		Sat (t',Some x) (* This is sat and we can extract a value *)
347		\| Feas -> Sat (t',None)
348		\| Max n ->
349		if debug then begin
350		Printf.printf "The objective is maximised %s\n" (string_of_num n);
351		Printf.printf "%a = %a\n" LinPoly.pp_var nw pp_row (IMap.find nw t')
352		end;
353
354		if n >=/ Int 0
355		then Sat (t',None)
356		else
357		let v' = safe_find "push_real" nw t' in
358		Unsat (Vect.set nw (Int 1) (Vect.set 0 (Int 0) (Vect.mul (Int (-1)) v')))
359
360
	309	\| Opt (t', r) -> (
	310	(* Look at the optimal *)
	311	match r with
	312	\| Ubnd x ->
	313	if debug then
	314	Printf.printf "The objective is unbounded (variable %a)\n"
	315	LinPoly.pp_var x;
	316	Sat (t', Some x) (* This is sat and we can extract a value *)
	317	\| Feas -> Sat (t', None)
	318	\| Max n ->
	319	if debug then begin
	320	Printf.printf "The objective is maximised %s\n" (string_of_num n);
	321	Printf.printf "%a = %a\n" LinPoly.pp_var nw pp_row (IMap.find nw t')
	322	end;
	323	if n >=/ Int 0 then Sat (t', None)
	324	else
	325	let v' = safe_find "push_real" nw t' in
	326	Unsat
	327	(Vect.set nw (Int 1) (Vect.set 0 (Int 0) (Vect.mul (Int (-1)) v'))) )
	328
	329	open Mutils
361	330	(** One complication is that equalities needs some pre-processing.
362	331	*)
363		open Mutils
	332
364	333	open Polynomial
365	334
366		let fresh_var l =
367		1 +
368		try
369		(ISet.max_elt (List.fold_left (fun acc c -> ISet.union acc (Vect.variables c.coeffs)) ISet.empty l))
370		with Not_found -> 0
371
372
373	335	(type varmap = (int bool) IMap.t*)
374	336
375
376	337	let make_certificate vm l =
377		Vect.normalise (Vect.fold (fun acc x n ->
378		let (x',b) = IMap.find x vm in
379		Vect.set x' (if b then n else Num.minus_num n) acc) Vect.null l)
380
381
382
383
384
385		let eliminate_equalities (vr0:var) (l:Polynomial.cstr list) =
	338	Vect.normalise
	339	(Vect.fold
	340	(fun acc x n ->
	341	let x', b = IMap.find x vm in
	342	Vect.set x' (if b then n else Num.minus_num n) acc)
	343	Vect.null l)
	344
	345	(** [eliminate_equalities vr0 l]
	346	represents an equality e = 0 of index idx in the list l
	347	by 2 constraints (vr:e >= 0) and (vr+1:-e >= 0)
	348	The mapping vm maps vr to idx
	349	*)
	350
	351	let eliminate_equalities (vr0 : var) (l : Polynomial.cstr list) =
386	352	let rec elim idx vr vm l acc =
387	353	match l with
388		\| [] -> (vr,vm,acc)
389		\| c::l -> match c.op with
390		\| Ge -> let v = Vect.set 0 (minus_num c.cst) c.coeffs in
391		elim (idx+1) (vr+1) (IMap.add vr (idx,true) vm) l ((vr,v)::acc)
392		\| Eq -> let v1 = Vect.set 0 (minus_num c.cst) c.coeffs in
393		let v2 = Vect.mul (Int (-1)) v1 in
394		let vm = IMap.add vr (idx,true) (IMap.add (vr+1) (idx,false) vm) in
395		elim (idx+1) (vr+2) vm l ((vr,v1)::(vr+1,v2)::acc)
396		\| Gt -> raise Strict in
	354	\| [] -> (vr, vm, acc)
	355	\| c :: l -> (
	356	match c.op with
	357	\| Ge ->
	358	let v = Vect.set 0 (minus_num c.cst) c.coeffs in
	359	elim (idx + 1) (vr + 1) (IMap.add vr (idx, true) vm) l ((vr, v) :: acc)
	360	\| Eq ->
	361	let v1 = Vect.set 0 (minus_num c.cst) c.coeffs in
	362	let v2 = Vect.mul (Int (-1)) v1 in
	363	let vm = IMap.add vr (idx, true) (IMap.add (vr + 1) (idx, false) vm) in
	364	elim (idx + 1) (vr + 2) vm l ((vr, v1) :: (vr + 1, v2) :: acc)
	365	\| Gt -> raise Strict )
	366	in
397	367	elim 0 vr0 IMap.empty l []
398	368
399	369	let find_solution rst tbl =
400		IMap.fold (fun vr v res -> if Restricted.is_restricted vr rst
401		then res
402		else Vect.set vr (Vect.get_cst v) res) tbl Vect.null
403
404		let choose_conflict (sol:Vect.t) (l: (var * Vect.t) list) =
	370	IMap.fold
	371	(fun vr v res ->
	372	if Restricted.is_restricted vr rst then res
	373	else Vect.set vr (Vect.get_cst v) res)
	374	tbl Vect.null
	375
	376	let find_full_solution rst tbl =
	377	IMap.fold (fun vr v res -> Vect.set vr (Vect.get_cst v) res) tbl Vect.null
	378
	379	let choose_conflict (sol : Vect.t) (l : (var * Vect.t) list) =
405	380	let esol = Vect.set 0 (Int 1) sol in
406
407		let rec most_violating l e (x,v) rst =
	381	let rec most_violating l e (x, v) rst =
408	382	match l with
409		\| [] -> Some((x,v),rst)
410		\| (x',v')::l ->
411		let e' = Vect.dotproduct esol v' in
412		if e' <=/ e
413		then most_violating l e' (x',v') ((x,v)::rst)
414		else most_violating l e (x,v) ((x',v')::rst) in
415
	383	\| [] -> Some ((x, v), rst)
	384	\| (x', v') :: l ->
	385	let e' = Vect.dotproduct esol v' in
	386	if e' <=/ e then most_violating l e' (x', v') ((x, v) :: rst)
	387	else most_violating l e (x, v) ((x', v') :: rst)
	388	in
416	389	match l with
417	390	\| [] -> None
418		\| (x,v)::l -> let e = Vect.dotproduct esol v in
419		most_violating l e (x,v) []
420
421
422
423		let rec solve opt l (rst:Restricted.t) (t:tableau) =
	391	\| (x, v) :: l ->
	392	let e = Vect.dotproduct esol v in
	393	most_violating l e (x, v) []
	394
	395	let rec solve opt l (rst : Restricted.t) (t : tableau) =
424	396	let sol = find_solution rst t in
425	397	match choose_conflict sol l with
426		\| None -> Inl (rst,t,None)
427		\| Some((vr,v),l) ->
428		match push_real opt vr v (Restricted.set_exc vr rst) t with
429		\| Sat (t',x) ->
430		(* let t' = remove_redundant rst t' in*)
431		begin
432		match l with
433		\| [] -> Inl(rst,t', x)
434		\| _ -> solve opt l rst t'
435		end
436		\| Unsat c -> Inr c
437
438		let find_unsat_certificate (l : Polynomial.cstr list ) =
439		let vr = fresh_var l in
440		let (_,vm,l') = eliminate_equalities vr l in
441
442		match solve false l' (Restricted.make vr) IMap.empty with
443		\| Inr c -> Some (make_certificate vm c)
	398	\| None -> Inl (rst, t, None)
	399	\| Some ((vr, v), l) -> (
	400	match push_real opt vr v (Restricted.set_exc vr rst) t with
	401	\| Sat (t', x) -> (
	402	(* let t' = remove_redundant rst t' in*)
	403	match l with
	404	\| [] -> Inl (rst, t', x)
	405	\| _ -> solve opt l rst t' )
	406	\| Unsat c -> Inr c )
	407
	408	let find_unsat_certificate (l : Polynomial.cstr list) =
	409	let vr = LinPoly.MonT.get_fresh () in
	410	let _, vm, l' = eliminate_equalities vr l in
	411	match solve false l' (Restricted.make vr) IMap.empty with
	412	\| Inr c -> Some (make_certificate vm c)
444	413	\| Inl _ -> None
445	414
446
	415	let fresh_var l =
	416	1
	417	+
	418	try
	419	ISet.max_elt
	420	(List.fold_left
	421	(fun acc c -> ISet.union acc (Vect.variables c.coeffs))
	422	ISet.empty l)
	423	with Not_found -> 0
447	424
448	425	let find_point (l : Polynomial.cstr list) =
449	426	let vr = fresh_var l in
450		let (_,vm,l') = eliminate_equalities vr l in
451
	427	let _, vm, l' = eliminate_equalities vr l in
452	428	match solve false l' (Restricted.make vr) IMap.empty with
453		\| Inl (rst,t,_) -> Some (find_solution rst t)
454		\| _ -> None
455
456
	429	\| Inl (rst, t, _) -> Some (find_solution rst t)
	430	\| _ -> None
457	431
458	432	let optimise obj l =
459		let vr0 = fresh_var l in
460		let (_,vm,l') = eliminate_equalities (vr0+1) l in
461
	433	let vr0 = LinPoly.MonT.get_fresh () in
	434	let _, vm, l' = eliminate_equalities (vr0 + 1) l in
462	435	let bound pos res =
463	436	match res with
464		\| Opt(_,Max n) -> Some (if pos then n else minus_num n)
465		\| Opt(_,Ubnd _) -> None
466		\| Opt(_,Feas) -> None
	437	\| Opt (_, Max n) -> Some (if pos then n else minus_num n)
	438	\| Opt (_, Ubnd _) -> None
	439	\| Opt (_, Feas) -> None
467	440	in
468
469	441	match solve false l' (Restricted.make vr0) IMap.empty with
470		\| Inl (rst,t,_) ->
471		Some (bound false
472		(simplex true vr0 rst (add_row vr0 t (Vect.uminus obj))),
473		bound true
474		(simplex true vr0 rst (add_row vr0 t obj)))
475		\| _ -> None
476
477
	442	\| Inl (rst, t, _) ->
	443	Some
	444	( bound false (simplex true vr0 rst (add_row vr0 t (Vect.uminus obj)))
	445	, bound true (simplex true vr0 rst (add_row vr0 t obj)) )
	446	\| _ -> None
478	447
479	448	open Polynomial
480	449
481	450	let env_of_list l =
482		List.fold_left (fun (i,m) l -> (i+1, IMap.add i l m)) (0,IMap.empty) l
483
	451	List.fold_left (fun (i, m) l -> (i + 1, IMap.add i l m)) (0, IMap.empty) l
484	452
485	453	open ProofFormat
486	454
487		let make_farkas_certificate (env: WithProof.t IMap.t) vm v =
488		Vect.fold (fun acc x n ->
	455	let make_farkas_certificate (env : WithProof.t IMap.t) vm v =
	456	Vect.fold
	457	(fun acc x n ->
489	458	add_proof acc
490	459	begin
491	460	try
492		let (x',b) = IMap.find x vm in
493		(mul_cst_proof
494		(if b then n else (Num.minus_num n))
495		(snd (IMap.find x' env)))
496		with Not_found -> (* This is an introduced hypothesis *)
497		(mul_cst_proof n (snd (IMap.find x env)))
498		end) Zero v
499
500		let make_farkas_proof (env: WithProof.t IMap.t) vm v =
501		Vect.fold (fun wp x n ->
502		WithProof.addition wp begin
	461	let x', b = IMap.find x vm in
	462	mul_cst_proof
	463	(if b then n else Num.minus_num n)
	464	(snd (IMap.find x' env))
	465	with Not_found ->
	466	(* This is an introduced hypothesis *)
	467	mul_cst_proof n (snd (IMap.find x env))
	468	end)
	469	Zero v
	470
	471	let make_farkas_proof (env : WithProof.t IMap.t) vm v =
	472	Vect.fold
	473	(fun wp x n ->
	474	WithProof.addition wp
	475	begin
503	476	try
504		let (x', b) = IMap.find x vm in
505		let n = if b then n else Num.minus_num n in
	477	let x', b = IMap.find x vm in
	478	let n = if b then n else Num.minus_num n in
506	479	WithProof.mult (Vect.cst n) (IMap.find x' env)
507		with Not_found ->
508		WithProof.mult (Vect.cst n) (IMap.find x env)
509		end) WithProof.zero v
510
	480	with Not_found -> WithProof.mult (Vect.cst n) (IMap.find x env)
	481	end)
	482	WithProof.zero v
511	483
512	484	let frac_num n = n -/ Num.floor_num n
513	485
514
515		(* [resolv_var v rst tbl] returns (if it exists) a restricted variable vr such that v = vr *)
516		exception FoundVar of int
517
518		let resolve_var v rst tbl =
519		let v = Vect.set v (Int 1) Vect.null in
520		try
521		IMap.iter (fun k vect ->
522		if Restricted.is_restricted k rst
523		then if Vect.equal v vect then raise (FoundVar k)
524		else ()) tbl ; None
525		with FoundVar k -> Some k
526
527		let prepare_cut env rst tbl x v =
528		(* extract the unrestricted part *)
529		let (unrst,rstv) = Vect.partition (fun x vl -> not (Restricted.is_restricted x rst) && frac_num vl <>/ Int 0) (Vect.set 0 (Int 0) v) in
530		if Vect.is_null unrst
531		then Some rstv
532		else Some (Vect.fold (fun acc k i ->
533		match resolve_var k rst tbl with
534		\| None -> acc (* Should not happen *)
535		\| Some v' -> Vect.set v' i acc)
536		rstv unrst)
537
538		let cut env rmin sol vm (rst:Restricted.t) tbl (x,v) =
539		begin
540		(* Printf.printf "Trying to cut %i\n" x;*)
541		let (n,r) = Vect.decomp_cst v in
542
543
	486	type ('a, 'b) hitkind =
	487	\| Forget
	488	(* Not interesting *)
	489	\| Hit of 'a
	490	(* Yes, we have a positive result *)
	491	\| Keep of 'b
	492
	493	let cut env rmin sol vm (rst : Restricted.t) tbl (x, v) =
	494	let n, r = Vect.decomp_cst v in
544	495	let f = frac_num n in
545
546		if f =/ Int 0
547		then None (* The solution is integral *)
	496	if f =/ Int 0 then Forget (* The solution is integral *)
548	497	else
549	498	(* This is potentially a cut *)
550		let t =
551		if f </ (Int 1) // (Int 2)
552		then
553		let t' = ((Int 1) // f) in
554		if Num.is_integer_num t'
555		then t' -/ Int 1
556		else Num.floor_num t'
557		else Int 1 in
558
	499	let t =
	500	if f </ Int 1 // Int 2 then
	501	let t' = Int 1 // f in
	502	if Num.is_integer_num t' then t' -/ Int 1 else Num.floor_num t'
	503	else Int 1
	504	in
559	505	let cut_coeff1 v =
560	506	let fv = frac_num v in
561		if fv <=/ (Int 1 -/ f)
562		then fv // (Int 1 -/ f)
563		else (Int 1 -/ fv) // f in
564
	507	if fv <=/ Int 1 -/ f then fv // (Int 1 -/ f) else (Int 1 -/ fv) // f
	508	in
565	509	let cut_coeff2 v = frac_num (t */ v) in
566
567	510	let cut_vector ccoeff =
568		match prepare_cut env rst tbl x v with
569		\| None -> Vect.null
570		\| Some r ->
571		(Printf.printf "Potential cut %a\n" LinPoly.pp r;)
572		Vect.fold (fun acc x n -> Vect.set x (ccoeff n) acc) Vect.null r
	511	Vect.fold
	512	(fun acc x n ->
	513	if Restricted.is_restricted x rst then Vect.set x (ccoeff n) acc
	514	else acc)
	515	Vect.null r
573	516	in
574
575		let lcut = List.map (fun cv -> Vect.normalise (cut_vector cv)) [cut_coeff1 ; cut_coeff2] in
576
577		let lcut = List.map (make_farkas_proof env vm) lcut in
578
	517	let lcut =
	518	List.map
	519	(fun cv -> Vect.normalise (cut_vector cv))
	520	[cut_coeff1; cut_coeff2]
	521	in
	522	let lcut = List.map (make_farkas_proof env vm) lcut in
579	523	let check_cutting_plane c =
580	524	match WithProof.cutting_plane c with
581	525	\| None ->
582		if debug then Printf.printf "This is not cutting plane for %a\n%a:" LinPoly.pp_var x WithProof.output c;
583		None
584		\| Some(v,prf) ->
585		if debug then begin
586		Printf.printf "This is a cutting plane for %a:" LinPoly.pp_var x;
587		Printf.printf " %a\n" WithProof.output (v,prf);
588		end;
589		if (=) (snd v) Eq
590		then (* Unsat *) Some (x,(v,prf))
591		else
592		let vl = (Vect.dotproduct (fst v) (Vect.set 0 (Int 1) sol)) in
593		if eval_op Ge vl (Int 0)
594		then begin
595		(* Can this happen? *)
596		if debug then Printf.printf "The cut is feasible %s >= 0 ??\n" (Num.string_of_num vl);
597		None
598		end
599		else Some(x,(v,prf)) in
600
601		find_some check_cutting_plane lcut
602		end
	526	if debug then
	527	Printf.printf "This is not a cutting plane for %a\n%a:" LinPoly.pp_var
	528	x WithProof.output c;
	529	None
	530	\| Some (v, prf) ->
	531	if debug then (
	532	Printf.printf "This is a cutting plane for %a:" LinPoly.pp_var x;
	533	Printf.printf " %a\n" WithProof.output (v, prf) );
	534	if snd v = Eq then (* Unsat *) Some (x, (v, prf))
	535	else
	536	let vl = Vect.dotproduct (fst v) (Vect.set 0 (Int 1) sol) in
	537	if eval_op Ge vl (Int 0) then (
	538	if debug then
	539	Printf.printf "The cut is feasible %s >= 0 \n"
	540	(Num.string_of_num vl);
	541	None )
	542	else Some (x, (v, prf))
	543	in
	544	match find_some check_cutting_plane lcut with
	545	\| Some r -> Hit r
	546	\| None -> Keep (x, v)
	547
	548	let merge_result_old oldr f x =
	549	match oldr with
	550	\| Hit v -> Hit v
	551	\| Forget -> (
	552	match f x with Forget -> Forget \| Hit v -> Hit v \| Keep v -> Keep v )
	553	\| Keep v -> (
	554	match f x with Forget -> Keep v \| Keep v' -> Keep v \| Hit v -> Hit v )
	555
	556	let merge_best lt oldr newr =
	557	match (oldr, newr) with
	558	\| x, Forget -> x
	559	\| Hit v, Hit v' -> if lt v v' then Hit v else Hit v'
	560	\| _, Hit v \| Hit v, _ -> Hit v
	561	\| Forget, Keep v -> Keep v
	562	\| Keep v, Keep v' -> Keep v'
603	563
604	564	let find_cut nb env u sol vm rst tbl =
605		if nb = 0
606		then
607		IMap.fold (fun x v acc ->
608		match acc with
609		\| None -> cut env u sol vm rst tbl (x,v)
610		\| Some c -> Some c) tbl None
	565	if nb = 0 then
	566	IMap.fold
	567	(fun x v acc -> merge_result_old acc (cut env u sol vm rst tbl) (x, v))
	568	tbl Forget
611	569	else
612		IMap.fold (fun x v acc ->
613		match cut env u sol vm rst tbl (x,v) , acc with
614		\| None , Some r \| Some r , None -> Some r
615		\| None , None -> None
616		\| Some (v,((lp,o),p1)) , Some (v',((lp',o'),p2)) ->
617		Some (if ProofFormat.pr_size p1 </ ProofFormat.pr_size p2
618		then (v,((lp,o),p1)) else (v',((lp',o'),p2)))
619		) tbl None
620
621
	570	let lt (_, (_, p1)) (_, (_, p2)) =
	571	ProofFormat.pr_size p1 </ ProofFormat.pr_size p2
	572	in
	573	IMap.fold
	574	(fun x v acc -> merge_best lt acc (cut env u sol vm rst tbl (x, v)))
	575	tbl Forget
	576
	577	let var_of_vect v = fst (fst (Vect.decomp_fst v))
	578
	579	let eliminate_variable (bounded, vr, env, tbl) x =
	580	if debug then
	581	Printf.printf "Eliminating variable %a from tableau\n%a\n" LinPoly.pp_var x
	582	output_tableau tbl;
	583	(* We identify the new variables with the constraint. *)
	584	LinPoly.MonT.reserve vr;
	585	let z = LinPoly.var (vr + 1) in
	586	let zv = var_of_vect z in
	587	let t = LinPoly.var (vr + 2) in
	588	let tv = var_of_vect t in
	589	(* x = z - t *)
	590	let xdef = Vect.add z (Vect.uminus t) in
	591	let xp = ((Vect.set x (Int 1) (Vect.uminus xdef), Eq), Def vr) in
	592	let zp = ((z, Ge), Def zv) in
	593	let tp = ((t, Ge), Def tv) in
	594	(* Pivot the current tableau using xdef *)
	595	let tbl = IMap.map (fun v -> Vect.subst x xdef v) tbl in
	596	(* Pivot the environment *)
	597	let env =
	598	IMap.map
	599	(fun lp ->
	600	let (v, o), p = lp in
	601	let ai = Vect.get x v in
	602	if ai =/ Int 0 then lp
	603	else
	604	WithProof.addition
	605	(WithProof.mult (Vect.cst (Num.minus_num ai)) xp)
	606	lp)
	607	env
	608	in
	609	(* Add the variables to the environment *)
	610	let env = IMap.add vr xp (IMap.add zv zp (IMap.add tv tp env)) in
	611	(* Remember the mapping *)
	612	let bounded = IMap.add x (vr, zv, tv) bounded in
	613	if debug then (
	614	Printf.printf "Tableau without\n %a\n" output_tableau tbl;
	615	Printf.printf "Environment\n %a\n" output_env env );
	616	(bounded, vr + 3, env, tbl)
622	617
623	618	let integer_solver lp =
624		let (l,_) = List.split lp in
625		let vr0 = fresh_var l in
626		let (vr,vm,l') = eliminate_equalities vr0 l in
627
628		let _,env = env_of_list (List.map WithProof.of_cstr lp) in
629
	619	let l, _ = List.split lp in
	620	let vr0 = 3 * LinPoly.MonT.get_fresh () in
	621	let vr, vm, l' = eliminate_equalities vr0 l in
	622	let _, env = env_of_list (List.map WithProof.of_cstr lp) in
630	623	let insert_row vr v rst tbl =
631	624	match push_real true vr v rst tbl with
632		\| Sat (t',x) -> Inl (Restricted.restrict vr rst,t',x)
633		\| Unsat c -> Inr c in
634
	625	\| Sat (t', x) -> Inl (Restricted.restrict vr rst, t', x)
	626	\| Unsat c -> Inr c
	627	in
635	628	let nb = ref 0 in
636
637	629	let rec isolve env cr vr res =
638	630	incr nb;
639	631	match res with
640		\| Inr c -> Some (Step (vr, make_farkas_certificate env vm (Vect.normalise c),Done))
641		\| Inl (rst,tbl,x) ->
642		if debug then begin
643		Printf.fprintf stdout "Looking for a cut\n";
644		Printf.fprintf stdout "Restricted %a ...\n" Restricted.pp rst;
645		Printf.fprintf stdout "Current Tableau\n%a\n" output_tableau tbl;
646		(* Printf.fprintf stdout "Bounding box\n%a\n" output_box (bounding_box (vr+1) rst tbl l')*)
647		end;
648		let sol = find_solution rst tbl in
649
650		match find_cut (!nb mod 2) env cr (x) sol vm rst tbl with
651		\| None -> None
652		\| Some(cr,((v,op),cut)) ->
653		if (=) op Eq
654		then (* This is a contradiction *)
655		Some(Step(vr,CutPrf cut, Done))
656		else
657		let res = insert_row vr v (Restricted.set_exc vr rst) tbl in
658		let prf = isolve (IMap.add vr ((v,op),Def vr) env) (Some cr) (vr+1) res in
659		match prf with
660		\| None -> None
661		\| Some p -> Some (Step(vr,CutPrf cut,p)) in
662
	632	\| Inr c ->
	633	Some (Step (vr, make_farkas_certificate env vm (Vect.normalise c), Done))
	634	\| Inl (rst, tbl, x) -> (
	635	if debug then begin
	636	Printf.fprintf stdout "Looking for a cut\n";
	637	Printf.fprintf stdout "Restricted %a ...\n" Restricted.pp rst;
	638	Printf.fprintf stdout "Current Tableau\n%a\n" output_tableau tbl;
	639	flush stdout
	640	(* Printf.fprintf stdout "Bounding box\n%a\n" output_box (bounding_box (vr+1) rst tbl l')*)
	641	end;
	642	let sol = find_full_solution rst tbl in
	643	match find_cut (!nb mod 2) env cr (x) sol vm rst tbl with
	644	\| Forget ->
	645	None (* There is no hope, there should be an integer solution *)
	646	\| Hit (cr, ((v, op), cut)) ->
	647	if op = Eq then
	648	(* This is a contradiction *)
	649	Some (Step (vr, CutPrf cut, Done))
	650	else (
	651	LinPoly.MonT.reserve vr;
	652	let res = insert_row vr v (Restricted.set_exc vr rst) tbl in
	653	let prf =
	654	isolve (IMap.add vr ((v, op), Def vr) env) (Some cr) (vr + 1) res
	655	in
	656	match prf with
	657	\| None -> None
	658	\| Some p -> Some (Step (vr, CutPrf cut, p)) )
	659	\| Keep (x, v) -> (
	660	if debug then
	661	Printf.fprintf stdout "Remove %a from Tableau\n" LinPoly.pp_var x;
	662	let bounded, vr, env, tbl =
	663	Vect.fold
	664	(fun acc x n ->
	665	if x <> 0 && not (Restricted.is_restricted x rst) then
	666	eliminate_variable acc x
	667	else acc)
	668	(IMap.empty, vr, env, tbl) v
	669	in
	670	let prf = isolve env cr vr (Inl (rst, tbl, None)) in
	671	match prf with
	672	\| None -> None
	673	\| Some pf ->
	674	Some
	675	(IMap.fold
	676	(fun x (vr, zv, tv) acc -> ExProof (vr, zv, tv, x, zv, tv, acc))
	677	bounded pf) ) )
	678	in
663	679	let res = solve true l' (Restricted.make vr0) IMap.empty in
664	680	isolve env None vr res
665	681
666	682	let integer_solver lp =
667		if debug then Printf.printf "Input integer solver\n%a\n" WithProof.output_sys (List.map WithProof.of_cstr lp);
668
	683	if debug then
	684	Printf.printf "Input integer solver\n%a\n" WithProof.output_sys
	685	(List.map WithProof.of_cstr lp);
669	686	match integer_solver lp with
670	687	\| None -> None
671		\| Some prf -> if debug
672		then Printf.fprintf stdout "Proof %a\n" ProofFormat.output_proof prf ;
673		Some prf
	688	\| Some prf ->
	689	if debug then
	690	Printf.fprintf stdout "Proof %a\n" ProofFormat.output_proof prf;
	691	Some prf

-3

plugins/micromega/simplex.mli less more

9	9	open Polynomial
10	10
11	11	val optimise : Vect.t -> cstr list -> (Num.num option * Num.num option) option
12
13	12	val find_point : cstr list -> Vect.t option
14
15	13	val find_unsat_certificate : cstr list -> Vect.t option
16	14
17		val integer_solver : (cstr * ProofFormat.prf_rule) list -> ProofFormat.proof option
	15	val integer_solver :
	16	(cstr * ProofFormat.prf_rule) list -> ProofFormat.proof option

+748

-605

plugins/micromega/sos.ml less more

8	8	(* ========================================================================= *)
9	9	(* Nonlinear universal reals procedure using SOS decomposition. *)
10	10	(* ========================================================================= *)
11		open Num;;
12		open Sos_types;;
13		open Sos_lib;;
	11	open Num
	12	open Sos_types
	13	open Sos_lib
14	14
15	15	(*
16	16	prioritize_real();;
17	17	*)
18	18
19		let debugging = ref false;;
20
21		exception Sanity;;
	19	let debugging = ref false
	20
	21	exception Sanity
22	22
23	23	(* ------------------------------------------------------------------------- *)
24	24	(* Turn a rational into a decimal string with d sig digits. *)

28	28	let rec normalize y =
29	29	if abs_num y </ Int 1 // Int 10 then normalize (Int 10 */ y) - 1
30	30	else if abs_num y >=/ Int 1 then normalize (y // Int 10) + 1
31		else 0 in
	31	else 0
	32	in
32	33	fun d x ->
33		if x =/ Int 0 then "0.0" else
34		let y = abs_num x in
35		let e = normalize y in
36		let z = pow10(-e) */ y +/ Int 1 in
37		let k = round_num(pow10 d */ z) in
38		(if x </ Int 0 then "-0." else "0.") ^
39		implode(List.tl(explode(string_of_num k))) ^
40		(if e = 0 then "" else "e"^string_of_int e);;
	34	if x =/ Int 0 then "0.0"
	35	else
	36	let y = abs_num x in
	37	let e = normalize y in
	38	let z = (pow10 (-e) */ y) +/ Int 1 in
	39	let k = round_num (pow10 d */ z) in
	40	(if x </ Int 0 then "-0." else "0.")
	41	^ implode (List.tl (explode (string_of_num k)))
	42	^ if e = 0 then "" else "e" ^ string_of_int e
41	43
42	44	(* ------------------------------------------------------------------------- *)
43	45	(* Iterations over numbers, and lists indexed by numbers. *)
44	46	(* ------------------------------------------------------------------------- *)
45	47
46	48	let rec itern k l f a =
47		match l with
48		[] -> a
49		\| h::t -> itern (k + 1) t f (f h k a);;
50
51		let rec iter (m,n) f a =
52		if n < m then a
53		else iter (m+1,n) f (f m a);;
	49	match l with [] -> a \| h :: t -> itern (k + 1) t f (f h k a)
	50
	51	let rec iter (m, n) f a = if n < m then a else iter (m + 1, n) f (f m a)
54	52
55	53	(* ------------------------------------------------------------------------- *)
56	54	(* The main types. *)
57	55	(* ------------------------------------------------------------------------- *)
58	56
59		type vector = int*(int,num)func;;
60
61		type matrix = (intint)(int*int,num)func;;
62
63		type monomial = (vname,int)func;;
64
65		type poly = (monomial,num)func;;
	57	type vector = int * (int, num) func
	58	type matrix = (int * int) * (int * int, num) func
	59	type monomial = (vname, int) func
	60	type poly = (monomial, num) func
66	61
67	62	(* ------------------------------------------------------------------------- *)
68	63	(* Assignment avoiding zeros. *)
69	64	(* ------------------------------------------------------------------------- *)
70	65
71		let (\|-->) x y a = if y =/ Int 0 then a else (x \|-> y) a;;
	66	let ( \|--> ) x y a = if y =/ Int 0 then a else (x \|-> y) a
72	67
73	68	(* ------------------------------------------------------------------------- *)
74	69	(* This can be generic. *)
75	70	(* ------------------------------------------------------------------------- *)
76	71
77		let element (d,v) i = tryapplyd v i (Int 0);;
78
79		let mapa f (d,v) =
80		d,foldl (fun a i c -> (i \|--> f(c)) a) undefined v;;
81
82		let is_zero (d,v) =
83		match v with
84		Empty -> true
85		\| _ -> false;;
	72	let element (d, v) i = tryapplyd v i (Int 0)
	73	let mapa f (d, v) = (d, foldl (fun a i c -> (i \|--> f c) a) undefined v)
	74	let is_zero (d, v) = match v with Empty -> true \| _ -> false
86	75
87	76	(* ------------------------------------------------------------------------- *)
88	77	(* Vectors. Conventionally indexed 1..n. *)
89	78	(* ------------------------------------------------------------------------- *)
90	79
91		let vector_0 n = (n,undefined:vector);;
92
93		let dim (v:vector) = fst v;;
	80	let vector_0 n = ((n, undefined) : vector)
	81	let dim (v : vector) = fst v
94	82
95	83	let vector_const c n =
96	84	if c =/ Int 0 then vector_0 n
97		else (n,List.fold_right (fun k -> k \|-> c) (1--n) undefined :vector);;
98
99		let vector_cmul c (v:vector) =
	85	else ((n, List.fold_right (fun k -> k \|-> c) (1 -- n) undefined) : vector)
	86
	87	let vector_cmul c (v : vector) =
100	88	let n = dim v in
101		if c =/ Int 0 then vector_0 n
102		else n,mapf (fun x -> c */ x) (snd v)
	89	if c =/ Int 0 then vector_0 n else (n, mapf (fun x -> c */ x) (snd v))
103	90
104	91	let vector_of_list l =
105	92	let n = List.length l in
106		(n,List.fold_right2 (\|->) (1--n) l undefined :vector);;
	93	((n, List.fold_right2 ( \|-> ) (1 -- n) l undefined) : vector)
107	94
108	95	(* ------------------------------------------------------------------------- *)
109	96	(* Matrices; again rows and columns indexed from 1. *)
110	97	(* ------------------------------------------------------------------------- *)
111	98
112		let matrix_0 (m,n) = ((m,n),undefined:matrix);;
113
114		let dimensions (m:matrix) = fst m;;
115
116		let matrix_cmul c (m:matrix) =
117		let (i,j) = dimensions m in
118		if c =/ Int 0 then matrix_0 (i,j)
119		else (i,j),mapf (fun x -> c */ x) (snd m);;
120
121		let matrix_neg (m:matrix) = (dimensions m,mapf minus_num (snd m) :matrix);;
122
123		let matrix_add (m1:matrix) (m2:matrix) =
	99	let matrix_0 (m, n) = (((m, n), undefined) : matrix)
	100	let dimensions (m : matrix) = fst m
	101
	102	let matrix_cmul c (m : matrix) =
	103	let i, j = dimensions m in
	104	if c =/ Int 0 then matrix_0 (i, j)
	105	else ((i, j), mapf (fun x -> c */ x) (snd m))
	106
	107	let matrix_neg (m : matrix) = ((dimensions m, mapf minus_num (snd m)) : matrix)
	108
	109	let matrix_add (m1 : matrix) (m2 : matrix) =
124	110	let d1 = dimensions m1 and d2 = dimensions m2 in
125	111	if d1 <> d2 then failwith "matrix_add: incompatible dimensions"
126		else (d1,combine (+/) (fun x -> x =/ Int 0) (snd m1) (snd m2) :matrix);;
127
128		let row k (m:matrix) =
129		let i,j = dimensions m in
130		(j,
131		foldl (fun a (i,j) c -> if i = k then (j \|-> c) a else a) undefined (snd m)
132		: vector);;
133
134		let column k (m:matrix) =
135		let i,j = dimensions m in
136		(i,
137		foldl (fun a (i,j) c -> if j = k then (i \|-> c) a else a) undefined (snd m)
138		: vector);;
139
140		let diagonal (v:vector) =
	112	else ((d1, combine ( +/ ) (fun x -> x =/ Int 0) (snd m1) (snd m2)) : matrix)
	113
	114	let row k (m : matrix) =
	115	let i, j = dimensions m in
	116	( ( j
	117	, foldl
	118	(fun a (i, j) c -> if i = k then (j \|-> c) a else a)
	119	undefined (snd m) )
	120	: vector )
	121
	122	let column k (m : matrix) =
	123	let i, j = dimensions m in
	124	( ( i
	125	, foldl
	126	(fun a (i, j) c -> if j = k then (i \|-> c) a else a)
	127	undefined (snd m) )
	128	: vector )
	129
	130	let diagonal (v : vector) =
141	131	let n = dim v in
142		((n,n),foldl (fun a i c -> ((i,i) \|-> c) a) undefined (snd v) : matrix);;
	132	(((n, n), foldl (fun a i c -> ((i, i) \|-> c) a) undefined (snd v)) : matrix)
143	133
144	134	(* ------------------------------------------------------------------------- *)
145	135	(* Monomials. *)
146	136	(* ------------------------------------------------------------------------- *)
147		let monomial_1 = (undefined:monomial);;
148
149		let monomial_var x = (x \|=> 1 :monomial);;
150
151		let (monomial_mul:monomial->monomial->monomial) =
152		combine (+) (fun x -> false);;
153
154		let monomial_degree x (m:monomial) = tryapplyd m x 0;;
155
156		let monomial_multidegree (m:monomial) = foldl (fun a x k -> k + a) 0 m;;
157
158		let monomial_variables m = dom m;;
	137	let monomial_1 = (undefined : monomial)
	138	let monomial_var x = (x \|=> 1 : monomial)
	139
	140	let (monomial_mul : monomial -> monomial -> monomial) =
	141	combine ( + ) (fun x -> false)
	142
	143	let monomial_degree x (m : monomial) = tryapplyd m x 0
	144	let monomial_multidegree (m : monomial) = foldl (fun a x k -> k + a) 0 m
	145	let monomial_variables m = dom m
159	146
160	147	(* ------------------------------------------------------------------------- *)
161	148	(* Polynomials. *)
162	149	(* ------------------------------------------------------------------------- *)
163		let poly_0 = (undefined:poly);;
164
165		let poly_isconst (p:poly) = foldl (fun a m c -> m = monomial_1 && a) true p;;
166
167		let poly_var x = ((monomial_var x) \|=> Int 1 :poly);;
168
169		let poly_const c =
170		if c =/ Int 0 then poly_0 else (monomial_1 \|=> c);;
171
172		let poly_cmul c (p:poly) =
173		if c =/ Int 0 then poly_0
174		else mapf (fun x -> c */ x) p;;
175
176		let poly_neg (p:poly) = (mapf minus_num p :poly);;
177
178		let poly_add (p1:poly) (p2:poly) =
179		(combine (+/) (fun x -> x =/ Int 0) p1 p2 :poly);;
180
181		let poly_sub p1 p2 = poly_add p1 (poly_neg p2);;
182
183		let poly_cmmul (c,m) (p:poly) =
	150	let poly_0 = (undefined : poly)
	151	let poly_isconst (p : poly) = foldl (fun a m c -> m = monomial_1 && a) true p
	152	let poly_var x = (monomial_var x \|=> Int 1 : poly)
	153	let poly_const c = if c =/ Int 0 then poly_0 else monomial_1 \|=> c
	154
	155	let poly_cmul c (p : poly) =
	156	if c =/ Int 0 then poly_0 else mapf (fun x -> c */ x) p
	157
	158	let poly_neg (p : poly) = (mapf minus_num p : poly)
	159
	160	let poly_add (p1 : poly) (p2 : poly) =
	161	(combine ( +/ ) (fun x -> x =/ Int 0) p1 p2 : poly)
	162
	163	let poly_sub p1 p2 = poly_add p1 (poly_neg p2)
	164
	165	let poly_cmmul (c, m) (p : poly) =
184	166	if c =/ Int 0 then poly_0
185	167	else if m = monomial_1 then mapf (fun d -> c */ d) p
186		else foldl (fun a m' d -> (monomial_mul m m' \|-> c */ d) a) poly_0 p;;
187
188		let poly_mul (p1:poly) (p2:poly) =
189		foldl (fun a m c -> poly_add (poly_cmmul (c,m) p2) a) poly_0 p1;;
190
191		let poly_square p = poly_mul p p;;
	168	else foldl (fun a m' d -> (monomial_mul m m' \|-> c */ d) a) poly_0 p
	169
	170	let poly_mul (p1 : poly) (p2 : poly) =
	171	foldl (fun a m c -> poly_add (poly_cmmul (c, m) p2) a) poly_0 p1
	172
	173	let poly_square p = poly_mul p p
192	174
193	175	let rec poly_pow p k =
194	176	if k = 0 then poly_const (Int 1)
195	177	else if k = 1 then p
196		else let q = poly_square(poly_pow p (k / 2)) in
197		if k mod 2 = 1 then poly_mul p q else q;;
198
199		let degree x (p:poly) = foldl (fun a m c -> max (monomial_degree x m) a) 0 p;;
200
201		let multidegree (p:poly) =
202		foldl (fun a m c -> max (monomial_multidegree m) a) 0 p;;
203
204		let poly_variables (p:poly) =
205		foldr (fun m c -> union (monomial_variables m)) p [];;
	178	else
	179	let q = poly_square (poly_pow p (k / 2)) in
	180	if k mod 2 = 1 then poly_mul p q else q
	181
	182	let degree x (p : poly) = foldl (fun a m c -> max (monomial_degree x m) a) 0 p
	183
	184	let multidegree (p : poly) =
	185	foldl (fun a m c -> max (monomial_multidegree m) a) 0 p
	186
	187	let poly_variables (p : poly) =
	188	foldr (fun m c -> union (monomial_variables m)) p []
206	189
207	190	(* ------------------------------------------------------------------------- *)
208	191	(* Order monomials for human presentation. *)
209	192	(* ------------------------------------------------------------------------- *)
210	193
211		let humanorder_varpow (x1,k1) (x2,k2) = x1 < x2 \|\| x1 = x2 && k1 > k2;;
	194	let humanorder_varpow (x1, k1) (x2, k2) = x1 < x2 \|\| (x1 = x2 && k1 > k2)
212	195
213	196	let humanorder_monomial =
214		let rec ord l1 l2 = match (l1,l2) with
215		_,[] -> true
216		\| [],_ -> false
217		\| h1::t1,h2::t2 -> humanorder_varpow h1 h2 \|\| h1 = h2 && ord t1 t2 in
218		fun m1 m2 -> m1 = m2 \|\|
219		ord (sort humanorder_varpow (graph m1))
220		(sort humanorder_varpow (graph m2));;
	197	let rec ord l1 l2 =
	198	match (l1, l2) with
	199	\| _, [] -> true
	200	\| [], _ -> false
	201	\| h1 :: t1, h2 :: t2 -> humanorder_varpow h1 h2 \|\| (h1 = h2 && ord t1 t2)
	202	in
	203	fun m1 m2 ->
	204	m1 = m2
	205	\|\| ord
	206	(sort humanorder_varpow (graph m1))
	207	(sort humanorder_varpow (graph m2))
221	208
222	209	(* ------------------------------------------------------------------------- *)
223	210	(* Conversions to strings. *)
224	211	(* ------------------------------------------------------------------------- *)
225	212
226		let string_of_vname (v:vname): string = (v: string);;
	213	let string_of_vname (v : vname) : string = (v : string)
227	214
228	215	let string_of_varpow x k =
229		if k = 1 then string_of_vname x else string_of_vname x^"^"^string_of_int k;;
	216	if k = 1 then string_of_vname x else string_of_vname x ^ "^" ^ string_of_int k
230	217
231	218	let string_of_monomial m =
232		if m = monomial_1 then "1" else
233		let vps = List.fold_right (fun (x,k) a -> string_of_varpow x k :: a)
234		(sort humanorder_varpow (graph m)) [] in
235		String.concat "*" vps;;
236
237		let string_of_cmonomial (c,m) =
	219	if m = monomial_1 then "1"
	220	else
	221	let vps =
	222	List.fold_right
	223	(fun (x, k) a -> string_of_varpow x k :: a)
	224	(sort humanorder_varpow (graph m))
	225	[]
	226	in
	227	String.concat "*" vps
	228
	229	let string_of_cmonomial (c, m) =
238	230	if m = monomial_1 then string_of_num c
239	231	else if c =/ Int 1 then string_of_monomial m
240		else string_of_num c ^ "*" ^ string_of_monomial m;;
241
242		let string_of_poly (p:poly) =
243		if p = poly_0 then "<<0>>" else
244		let cms = sort (fun (m1,_) (m2,_) -> humanorder_monomial m1 m2) (graph p) in
245		let s =
246		List.fold_left (fun a (m,c) ->
247		if c </ Int 0 then a ^ " - " ^ string_of_cmonomial(minus_num c,m)
248		else a ^ " + " ^ string_of_cmonomial(c,m))
249		"" cms in
250		let s1 = String.sub s 0 3
251		and s2 = String.sub s 3 (String.length s - 3) in
252		"<<" ^(if s1 = " + " then s2 else "-"^s2)^">>";;
	232	else string_of_num c ^ "*" ^ string_of_monomial m
	233
	234	let string_of_poly (p : poly) =
	235	if p = poly_0 then "<<0>>"
	236	else
	237	let cms =
	238	sort (fun (m1, _) (m2, _) -> humanorder_monomial m1 m2) (graph p)
	239	in
	240	let s =
	241	List.fold_left
	242	(fun a (m, c) ->
	243	if c </ Int 0 then a ^ " - " ^ string_of_cmonomial (minus_num c, m)
	244	else a ^ " + " ^ string_of_cmonomial (c, m))
	245	"" cms
	246	in
	247	let s1 = String.sub s 0 3 and s2 = String.sub s 3 (String.length s - 3) in
	248	"<<" ^ (if s1 = " + " then s2 else "-" ^ s2) ^ ">>"
253	249
254	250	(* ------------------------------------------------------------------------- *)
255	251	(* Printers. *)

274	270	(* Conversion from term. *)
275	271	(* ------------------------------------------------------------------------- *)
276	272
277		let rec poly_of_term t = match t with
278		Zero -> poly_0
279		\| Const n -> poly_const n
280		\| Var x -> poly_var x
281		\| Opp t1 -> poly_neg (poly_of_term t1)
282		\| Add (l, r) -> poly_add (poly_of_term l) (poly_of_term r)
283		\| Sub (l, r) -> poly_sub (poly_of_term l) (poly_of_term r)
284		\| Mul (l, r) -> poly_mul (poly_of_term l) (poly_of_term r)
285		\| Pow (t, n) ->
286		poly_pow (poly_of_term t) n;;
	273	let rec poly_of_term t =
	274	match t with
	275	\| Zero -> poly_0
	276	\| Const n -> poly_const n
	277	\| Var x -> poly_var x
	278	\| Opp t1 -> poly_neg (poly_of_term t1)
	279	\| Add (l, r) -> poly_add (poly_of_term l) (poly_of_term r)
	280	\| Sub (l, r) -> poly_sub (poly_of_term l) (poly_of_term r)
	281	\| Mul (l, r) -> poly_mul (poly_of_term l) (poly_of_term r)
	282	\| Pow (t, n) -> poly_pow (poly_of_term t) n
287	283
288	284	(* ------------------------------------------------------------------------- *)
289	285	(* String of vector (just a list of space-separated numbers). *)
290	286	(* ------------------------------------------------------------------------- *)
291	287
292		let sdpa_of_vector (v:vector) =
	288	let sdpa_of_vector (v : vector) =
293	289	let n = dim v in
294		let strs = List.map (o (decimalize 20) (element v)) (1--n) in
295		String.concat " " strs ^ "\n";;
	290	let strs = List.map (o (decimalize 20) (element v)) (1 -- n) in
	291	String.concat " " strs ^ "\n"
296	292
297	293	(* ------------------------------------------------------------------------- *)
298	294	(* String for a matrix numbered k, in SDPA sparse format. *)
299	295	(* ------------------------------------------------------------------------- *)
300	296
301		let sdpa_of_matrix k (m:matrix) =
	297	let sdpa_of_matrix k (m : matrix) =
302	298	let pfx = string_of_int k ^ " 1 " in
303		let ms = foldr (fun (i,j) c a -> if i > j then a else ((i,j),c)::a)
304		(snd m) [] in
	299	let ms =
	300	foldr (fun (i, j) c a -> if i > j then a else ((i, j), c) :: a) (snd m) []
	301	in
305	302	let mss = sort (increasing fst) ms in
306		List.fold_right (fun ((i,j),c) a ->
307		pfx ^ string_of_int i ^ " " ^ string_of_int j ^
308		" " ^ decimalize 20 c ^ "\n" ^ a) mss "";;
	303	List.fold_right
	304	(fun ((i, j), c) a ->
	305	pfx ^ string_of_int i ^ " " ^ string_of_int j ^ " " ^ decimalize 20 c
	306	^ "\n" ^ a)
	307	mss ""
309	308
310	309	(* ------------------------------------------------------------------------- *)
311	310	(* String in SDPA sparse format for standard SDP problem: *)

315	314	(* ------------------------------------------------------------------------- *)
316	315
317	316	let sdpa_of_problem comment obj mats =
318		let m = List.length mats - 1
319		and n,_ = dimensions (List.hd mats) in
320		"\"" ^ comment ^ "\"\n" ^
321		string_of_int m ^ "\n" ^
322		"1\n" ^
323		string_of_int n ^ "\n" ^
324		sdpa_of_vector obj ^
325		List.fold_right2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a)
326		(1--List.length mats) mats "";;
	317	let m = List.length mats - 1 and n, _ = dimensions (List.hd mats) in
	318	"\"" ^ comment ^ "\"\n" ^ string_of_int m ^ "\n" ^ "1\n" ^ string_of_int n
	319	^ "\n" ^ sdpa_of_vector obj
	320	^ List.fold_right2
	321	(fun k m a -> sdpa_of_matrix (k - 1) m ^ a)
	322	(1 -- List.length mats)
	323	mats ""
327	324
328	325	(* ------------------------------------------------------------------------- *)
329	326	(* More parser basics. *)
330	327	(* ------------------------------------------------------------------------- *)
331	328
332	329	let word s =
333		end_itlist (fun p1 p2 -> (p1 ++ p2) >> (fun (s,t) -> s^t))
334		(List.map a (explode s));;
	330	end_itlist
	331	(fun p1 p2 -> p1 ++ p2 >> fun (s, t) -> s ^ t)
	332	(List.map a (explode s))
	333
335	334	let token s =
336		many (some isspace) ++ word s ++ many (some isspace)
337		>> (fun ((_,t),_) -> t);;
	335	many (some isspace) ++ word s ++ many (some isspace) >> fun ((_, t), _) -> t
338	336
339	337	let decimal =
340		let (\|\|) = parser_or in
	338	let ( \|\| ) = parser_or in
341	339	let numeral = some isnum in
342		let decimalint = atleast 1 numeral >> ((o) Num.num_of_string implode) in
343		let decimalfrac = atleast 1 numeral
344		>> (fun s -> Num.num_of_string(implode s) // pow10 (List.length s)) in
	340	let decimalint = atleast 1 numeral >> o Num.num_of_string implode in
	341	let decimalfrac =
	342	atleast 1 numeral
	343	>> fun s -> Num.num_of_string (implode s) // pow10 (List.length s)
	344	in
345	345	let decimalsig =
346	346	decimalint ++ possibly (a "." ++ decimalfrac >> snd)
347		>> (function (h,[x]) -> h +/ x \| (h,_) -> h) in
	347	>> function h, [x] -> h +/ x \| h, _ -> h
	348	in
348	349	let signed prs =
349		a "-" ++ prs >> ((o) minus_num snd)
350		\|\| a "+" ++ prs >> snd
351		\|\| prs in
	350	a "-" ++ prs >> o minus_num snd \|\| a "+" ++ prs >> snd \|\| prs
	351	in
352	352	let exponent = (a "e" \|\| a "E") ++ signed decimalint >> snd in
353		signed decimalsig ++ possibly exponent
354		>> (function (h,[x]) -> h */ power_num (Int 10) x \| (h,_) -> h);;
	353	signed decimalsig ++ possibly exponent
	354	>> function h, [x] -> h */ power_num (Int 10) x \| h, _ -> h
355	355
356	356	let mkparser p s =
357		let x,rst = p(explode s) in
358		if rst = [] then x else failwith "mkparser: unparsed input";;
	357	let x, rst = p (explode s) in
	358	if rst = [] then x else failwith "mkparser: unparsed input"
359	359
360	360	(* ------------------------------------------------------------------------- *)
361	361	(* Parse back a vector. *)
362	362	(* ------------------------------------------------------------------------- *)
363	363
364	364	let _parse_sdpaoutput, parse_csdpoutput =
365		let (\|\|) = parser_or in
	365	let ( \|\| ) = parser_or in
366	366	let vector =
367	367	token "{" ++ listof decimal (token ",") "decimal" ++ token "}"
368		>> (fun ((_,v),_) -> vector_of_list v) in
	368	>> fun ((_, v), _) -> vector_of_list v
	369	in
369	370	let rec skipupto dscr prs inp =
370		(dscr ++ prs >> snd
371		\|\| some (fun c -> true) ++ skipupto dscr prs >> snd) inp in
372		let ignore inp = (),[] in
	371	(dscr ++ prs >> snd \|\| some (fun c -> true) ++ skipupto dscr prs >> snd) inp
	372	in
	373	let ignore inp = ((), []) in
373	374	let sdpaoutput =
374		skipupto (word "xVec" ++ token "=")
375		(vector ++ ignore >> fst) in
	375	skipupto (word "xVec" ++ token "=") (vector ++ ignore >> fst)
	376	in
376	377	let csdpoutput =
377		(decimal ++ many(a " " ++ decimal >> snd) >> (fun (h,t) -> h::t)) ++
378		(a " " ++ a "\n" ++ ignore) >> ((o) vector_of_list fst) in
379		mkparser sdpaoutput,mkparser csdpoutput;;
	378	(decimal ++ many (a " " ++ decimal >> snd) >> fun (h, t) -> h :: t)
	379	++ (a " " ++ a "\n" ++ ignore)
	380	>> o vector_of_list fst
	381	in
	382	(mkparser sdpaoutput, mkparser csdpoutput)
380	383
381	384	(* ------------------------------------------------------------------------- *)
382	385	(* The default parameters. Unfortunately this goes to a fixed file. *)
383	386	(* ------------------------------------------------------------------------- *)
384	387
385	388	let _sdpa_default_parameters =
386		"100 unsigned int maxIteration;\
387		\n1.0E-7 double 0.0 < epsilonStar;\
388		\n1.0E2 double 0.0 < lambdaStar;\
389		\n2.0 double 1.0 < omegaStar;\
390		\n-1.0E5 double lowerBound;\
391		\n1.0E5 double upperBound;\
392		\n0.1 double 0.0 <= betaStar < 1.0;\
393		\n0.2 double 0.0 <= betaBar < 1.0, betaStar <= betaBar;\
394		\n0.9 double 0.0 < gammaStar < 1.0;\
395		\n1.0E-7 double 0.0 < epsilonDash;\
396		\n";;
	389	"100 unsigned int maxIteration;\n\
	390	1.0E-7 double 0.0 < epsilonStar;\n\
	391	1.0E2 double 0.0 < lambdaStar;\n\
	392	2.0 double 1.0 < omegaStar;\n\
	393	-1.0E5 double lowerBound;\n\
	394	1.0E5 double upperBound;\n\
	395	0.1 double 0.0 <= betaStar < 1.0;\n\
	396	0.2 double 0.0 <= betaBar < 1.0, betaStar <= betaBar;\n\
	397	0.9 double 0.0 < gammaStar < 1.0;\n\
	398	1.0E-7 double 0.0 < epsilonDash;\n"
397	399
398	400	(* ------------------------------------------------------------------------- *)
399	401	(* These were suggested by Makoto Yamashita for problems where we are *)

401	403	(* ------------------------------------------------------------------------- *)
402	404
403	405	let sdpa_alt_parameters =
404		"1000 unsigned int maxIteration;\
405		\n1.0E-7 double 0.0 < epsilonStar;\
406		\n1.0E4 double 0.0 < lambdaStar;\
407		\n2.0 double 1.0 < omegaStar;\
408		\n-1.0E5 double lowerBound;\
409		\n1.0E5 double upperBound;\
410		\n0.1 double 0.0 <= betaStar < 1.0;\
411		\n0.2 double 0.0 <= betaBar < 1.0, betaStar <= betaBar;\
412		\n0.9 double 0.0 < gammaStar < 1.0;\
413		\n1.0E-7 double 0.0 < epsilonDash;\
414		\n";;
415
416		let _sdpa_params = sdpa_alt_parameters;;
	406	"1000 unsigned int maxIteration;\n\
	407	1.0E-7 double 0.0 < epsilonStar;\n\
	408	1.0E4 double 0.0 < lambdaStar;\n\
	409	2.0 double 1.0 < omegaStar;\n\
	410	-1.0E5 double lowerBound;\n\
	411	1.0E5 double upperBound;\n\
	412	0.1 double 0.0 <= betaStar < 1.0;\n\
	413	0.2 double 0.0 <= betaBar < 1.0, betaStar <= betaBar;\n\
	414	0.9 double 0.0 < gammaStar < 1.0;\n\
	415	1.0E-7 double 0.0 < epsilonDash;\n"
	416
	417	let _sdpa_params = sdpa_alt_parameters
417	418
418	419	(* ------------------------------------------------------------------------- *)
419	420	(* CSDP parameters; so far I'm sticking with the defaults. *)
420	421	(* ------------------------------------------------------------------------- *)
421	422
422	423	let csdp_default_parameters =
423		"axtol=1.0e-8\
424		\natytol=1.0e-8\
425		\nobjtol=1.0e-8\
426		\npinftol=1.0e8\
427		\ndinftol=1.0e8\
428		\nmaxiter=100\
429		\nminstepfrac=0.9\
430		\nmaxstepfrac=0.97\
431		\nminstepp=1.0e-8\
432		\nminstepd=1.0e-8\
433		\nusexzgap=1\
434		\ntweakgap=0\
435		\naffine=0\
436		\nprintlevel=1\
437		\n";;
438
439		let csdp_params = csdp_default_parameters;;
	424	"axtol=1.0e-8\n\
	425	atytol=1.0e-8\n\
	426	objtol=1.0e-8\n\
	427	pinftol=1.0e8\n\
	428	dinftol=1.0e8\n\
	429	maxiter=100\n\
	430	minstepfrac=0.9\n\
	431	maxstepfrac=0.97\n\
	432	minstepp=1.0e-8\n\
	433	minstepd=1.0e-8\n\
	434	usexzgap=1\n\
	435	tweakgap=0\n\
	436	affine=0\n\
	437	printlevel=1\n"
	438
	439	let csdp_params = csdp_default_parameters
440	440
441	441	(* ------------------------------------------------------------------------- *)
442	442	(* Now call CSDP on a problem and parse back the output. *)

449	449	and params_file = Filename.concat temp_path "param.csdp" in
450	450	file_of_string input_file (sdpa_of_problem "" obj mats);
451	451	file_of_string params_file csdp_params;
452		let rv = Sys.command("cd "^temp_path^"; csdp "^input_file ^
453		" " ^ output_file ^
454		(if dbg then "" else "> /dev/null")) in
	452	let rv =
	453	Sys.command
	454	( "cd " ^ temp_path ^ "; csdp " ^ input_file ^ " " ^ output_file
	455	^ if dbg then "" else "> /dev/null" )
	456	in
455	457	let op = string_of_file output_file in
456	458	let res = parse_csdpoutput op in
457		((if dbg then ()
458		else (Sys.remove input_file; Sys.remove output_file));
459		rv,res);;
	459	if dbg then () else (Sys.remove input_file; Sys.remove output_file);
	460	(rv, res)
460	461
461	462	(* ------------------------------------------------------------------------- *)
462	463	(* Try some apparently sensible scaling first. Note that this is purely to *)

469	470	let common_denominator amat acc =
470	471	foldl (fun a m c -> lcm_num (denominator c) a) acc amat
471	472	and maximal_element amat acc =
472		foldl (fun maxa m c -> max_num maxa (abs_num c)) acc amat in
	473	foldl (fun maxa m c -> max_num maxa (abs_num c)) acc amat
	474	in
473	475	fun solver obj mats ->
474	476	let cd1 = List.fold_right common_denominator mats (Int 1)
475		and cd2 = common_denominator (snd obj) (Int 1) in
	477	and cd2 = common_denominator (snd obj) (Int 1) in
476	478	let mats' = List.map (mapf (fun x -> cd1 */ x)) mats
477	479	and obj' = vector_cmul cd2 obj in
478	480	let max1 = List.fold_right maximal_element mats' (Int 0)
479	481	and max2 = maximal_element (snd obj') (Int 0) in
480		let scal1 = pow2 (20-int_of_float(log(float_of_num max1) /. log 2.0))
481		and scal2 = pow2 (20-int_of_float(log(float_of_num max2) /. log 2.0)) in
	482	let scal1 = pow2 (20 - int_of_float (log (float_of_num max1) /. log 2.0))
	483	and scal2 = pow2 (20 - int_of_float (log (float_of_num max2) /. log 2.0)) in
482	484	let mats'' = List.map (mapf (fun x -> x */ scal1)) mats'
483	485	and obj'' = vector_cmul scal2 obj' in
484		solver obj'' mats'';;
	486	solver obj'' mats''
485	487
486	488	(* ------------------------------------------------------------------------- *)
487	489	(* Round a vector to "nice" rationals. *)
488	490	(* ------------------------------------------------------------------------- *)
489	491
490		let nice_rational n x = round_num (n */ x) // n;;
491
492		let nice_vector n = mapa (nice_rational n);;
	492	let nice_rational n x = round_num (n */ x) // n
	493	let nice_vector n = mapa (nice_rational n)
493	494
494	495	(* ------------------------------------------------------------------------- *)
495	496	(* Reduce linear program to SDP (diagonal matrices) and test with CSDP. This *)

497	498	(* ------------------------------------------------------------------------- *)
498	499
499	500	let linear_program_basic a =
500		let m,n = dimensions a in
501		let mats = List.map (fun j -> diagonal (column j a)) (1--n)
	501	let m, n = dimensions a in
	502	let mats = List.map (fun j -> diagonal (column j a)) (1 -- n)
502	503	and obj = vector_const (Int 1) m in
503		let rv,res = run_csdp false obj mats in
	504	let rv, res = run_csdp false obj mats in
504	505	if rv = 1 \|\| rv = 2 then false
505	506	else if rv = 0 then true
506		else failwith "linear_program: An error occurred in the SDP solver";;
	507	else failwith "linear_program: An error occurred in the SDP solver"
507	508
508	509	(* ------------------------------------------------------------------------- *)
509	510	(* Test whether a point is in the convex hull of others. Rather than use *)

512	513	(* ------------------------------------------------------------------------- *)
513	514
514	515	let in_convex_hull pts pt =
515		let pts1 = (1::pt) :: List.map (fun x -> 1::x) pts in
	516	let pts1 = (1 :: pt) :: List.map (fun x -> 1 :: x) pts in
516	517	let pts2 = List.map (fun p -> List.map (fun x -> -x) p @ p) pts1 in
517		let n = List.length pts + 1
518		and v = 2 * (List.length pt + 1) in
	518	let n = List.length pts + 1 and v = 2 * (List.length pt + 1) in
519	519	let m = v + n - 1 in
520	520	let mat =
521		(m,n),
522		itern 1 pts2 (fun pts j -> itern 1 pts (fun x i -> (i,j) \|-> Int x))
523		(iter (1,n) (fun i -> (v + i,i+1) \|-> Int 1) undefined) in
524		linear_program_basic mat;;
	521	( (m, n)
	522	, itern 1 pts2
	523	(fun pts j -> itern 1 pts (fun x i -> (i, j) \|-> Int x))
	524	(iter (1, n) (fun i -> (v + i, i + 1) \|-> Int 1) undefined) )
	525	in
	526	linear_program_basic mat
525	527
526	528	(* ------------------------------------------------------------------------- *)
527	529	(* Filter down a set of points to a minimal set with the same convex hull. *)

530	532	let minimal_convex_hull =
531	533	let augment1 = function
532	534	\| [] -> assert false
533		\| (m::ms) -> if in_convex_hull ms m then ms else ms@[m] in
534		let augment m ms = funpow 3 augment1 (m::ms) in
	535	\| m :: ms -> if in_convex_hull ms m then ms else ms @ [m]
	536	in
	537	let augment m ms = funpow 3 augment1 (m :: ms) in
535	538	fun mons ->
536	539	let mons' = List.fold_right augment (List.tl mons) [List.hd mons] in
537		funpow (List.length mons') augment1 mons';;
	540	funpow (List.length mons') augment1 mons'
538	541
539	542	(* ------------------------------------------------------------------------- *)
540	543	(* Stuff for "equations" (generic A->num functions). *)
541	544	(* ------------------------------------------------------------------------- *)
542	545
543		let equation_cmul c eq =
544		if c =/ Int 0 then Empty else mapf (fun d -> c */ d) eq;;
545
546		let equation_add eq1 eq2 = combine (+/) (fun x -> x =/ Int 0) eq1 eq2;;
	546	let equation_cmul c eq = if c =/ Int 0 then Empty else mapf (fun d -> c */ d) eq
	547	let equation_add eq1 eq2 = combine ( +/ ) (fun x -> x =/ Int 0) eq1 eq2
547	548
548	549	let equation_eval assig eq =
549	550	let value v = apply assig v in
550		foldl (fun a v c -> a +/ value(v) */ c) (Int 0) eq;;
	551	foldl (fun a v c -> a +/ (value v */ c)) (Int 0) eq
551	552
552	553	(* ------------------------------------------------------------------------- *)
553	554	(* Eliminate all variables, in an essentially arbitrary order. *)

555	556
556	557	let eliminate_all_equations one =
557	558	let choose_variable eq =
558		let (v,_) = choose eq in
	559	let v, _ = choose eq in
559	560	if v = one then
560	561	let eq' = undefine v eq in
561		if is_undefined eq' then failwith "choose_variable" else
562		let (w,_) = choose eq' in w
563		else v in
	562	if is_undefined eq' then failwith "choose_variable"
	563	else
	564	let w, _ = choose eq' in
	565	w
	566	else v
	567	in
564	568	let rec eliminate dun eqs =
565	569	match eqs with
566		[] -> dun
567		\| eq::oeqs ->
568		if is_undefined eq then eliminate dun oeqs else
	570	\| [] -> dun
	571	\| eq :: oeqs ->
	572	if is_undefined eq then eliminate dun oeqs
	573	else
569	574	let v = choose_variable eq in
570	575	let a = apply eq v in
571		let eq' = equation_cmul (Int(-1) // a) (undefine v eq) in
	576	let eq' = equation_cmul (Int (-1) // a) (undefine v eq) in
572	577	let elim e =
573	578	let b = tryapplyd e v (Int 0) in
574		if b =/ Int 0 then e else
575		equation_add e (equation_cmul (minus_num b // a) eq) in
576		eliminate ((v \|-> eq') (mapf elim dun)) (List.map elim oeqs) in
	579	if b =/ Int 0 then e
	580	else equation_add e (equation_cmul (minus_num b // a) eq)
	581	in
	582	eliminate ((v \|-> eq') (mapf elim dun)) (List.map elim oeqs)
	583	in
577	584	fun eqs ->
578	585	let assig = eliminate undefined eqs in
579	586	let vs = foldl (fun a x f -> subtract (dom f) [one] @ a) [] assig in
580		setify vs,assig;;
	587	(setify vs, assig)
581	588
582	589	(* ------------------------------------------------------------------------- *)
583	590	(* Hence produce the "relevant" monomials: those whose squares lie in the *)

592	599
593	600	let newton_polytope pol =
594	601	let vars = poly_variables pol in
595		let mons = List.map (fun m -> List.map (fun x -> monomial_degree x m) vars) (dom pol)
	602	let mons =
	603	List.map (fun m -> List.map (fun x -> monomial_degree x m) vars) (dom pol)
596	604	and ds = List.map (fun x -> (degree x pol + 1) / 2) vars in
597		let all = List.fold_right (fun n -> allpairs (fun h t -> h::t) (0--n)) ds [[]]
	605	let all =
	606	List.fold_right (fun n -> allpairs (fun h t -> h :: t) (0 -- n)) ds [[]]
598	607	and mons' = minimal_convex_hull mons in
599	608	let all' =
600		List.filter (fun m -> in_convex_hull mons' (List.map (fun x -> 2 * x) m)) all in
601		List.map (fun m -> List.fold_right2 (fun v i a -> if i = 0 then a else (v \|-> i) a)
602		vars m monomial_1) (List.rev all');;
	609	List.filter
	610	(fun m -> in_convex_hull mons' (List.map (fun x -> 2 * x) m))
	611	all
	612	in
	613	List.map
	614	(fun m ->
	615	List.fold_right2
	616	(fun v i a -> if i = 0 then a else (v \|-> i) a)
	617	vars m monomial_1)
	618	(List.rev all')
603	619
604	620	(* ------------------------------------------------------------------------- *)
605	621	(* Diagonalize (Cholesky/LDU) the matrix corresponding to a quadratic form. *)

608	624	let diag m =
609	625	let nn = dimensions m in
610	626	let n = fst nn in
611		if snd nn <> n then failwith "diagonalize: non-square matrix" else
612		let rec diagonalize i m =
613		if is_zero m then [] else
614		let a11 = element m (i,i) in
615		if a11 </ Int 0 then failwith "diagonalize: not PSD"
616		else if a11 =/ Int 0 then
617		if is_zero(row i m) then diagonalize (i + 1) m
618		else failwith "diagonalize: not PSD"
619		else
620		let v = row i m in
621		let v' = mapa (fun a1k -> a1k // a11) v in
622		let m' =
623		(n,n),
624		iter (i+1,n) (fun j ->
625		iter (i+1,n) (fun k ->
626		((j,k) \|--> (element m (j,k) -/ element v j */ element v' k))))
627		undefined in
628		(a11,v')::diagonalize (i + 1) m' in
629		diagonalize 1 m;;
	627	if snd nn <> n then failwith "diagonalize: non-square matrix"
	628	else
	629	let rec diagonalize i m =
	630	if is_zero m then []
	631	else
	632	let a11 = element m (i, i) in
	633	if a11 </ Int 0 then failwith "diagonalize: not PSD"
	634	else if a11 =/ Int 0 then
	635	if is_zero (row i m) then diagonalize (i + 1) m
	636	else failwith "diagonalize: not PSD"
	637	else
	638	let v = row i m in
	639	let v' = mapa (fun a1k -> a1k // a11) v in
	640	let m' =
	641	( (n, n)
	642	, iter
	643	(i + 1, n)
	644	(fun j ->
	645	iter
	646	(i + 1, n)
	647	(fun k ->
	648	(j, k)
	649	\|--> element m (j, k) -/ (element v j */ element v' k)))
	650	undefined )
	651	in
	652	(a11, v') :: diagonalize (i + 1) m'
	653	in
	654	diagonalize 1 m
630	655
631	656	(* ------------------------------------------------------------------------- *)
632	657	(* Adjust a diagonalization to collect rationals at the start. *)
633	658	(* ------------------------------------------------------------------------- *)
634	659
635	660	let deration d =
636		if d = [] then Int 0,d else
637		let adj(c,l) =
638		let a = foldl (fun a i c -> lcm_num a (denominator c)) (Int 1) (snd l) //
639		foldl (fun a i c -> gcd_num a (numerator c)) (Int 0) (snd l) in
640		(c // (a / a)),mapa (fun x -> a / x) l in
641		let d' = List.map adj d in
642		let a = List.fold_right ((o) lcm_num ( (o) denominator fst)) d' (Int 1) //
643		List.fold_right ((o) gcd_num ( (o) numerator fst)) d' (Int 0) in
644		(Int 1 // a),List.map (fun (c,l) -> (a */ c,l)) d';;
	661	if d = [] then (Int 0, d)
	662	else
	663	let adj (c, l) =
	664	let a =
	665	foldl (fun a i c -> lcm_num a (denominator c)) (Int 1) (snd l)
	666	// foldl (fun a i c -> gcd_num a (numerator c)) (Int 0) (snd l)
	667	in
	668	(c // (a / a), mapa (fun x -> a / x) l)
	669	in
	670	let d' = List.map adj d in
	671	let a =
	672	List.fold_right (o lcm_num (o denominator fst)) d' (Int 1)
	673	// List.fold_right (o gcd_num (o numerator fst)) d' (Int 0)
	674	in
	675	(Int 1 // a, List.map (fun (c, l) -> (a */ c, l)) d')
645	676
646	677	(* ------------------------------------------------------------------------- *)
647	678	(* Enumeration of monomials with given multidegree bound. *)

650	681	let rec enumerate_monomials d vars =
651	682	if d < 0 then []
652	683	else if d = 0 then [undefined]
653		else if vars = [] then [monomial_1] else
654		let alts =
655		List.map (fun k -> let oths = enumerate_monomials (d - k) (List.tl vars) in
656		List.map (fun ks -> if k = 0 then ks else (List.hd vars \|-> k) ks) oths)
657		(0--d) in
658		end_itlist (@) alts;;
	684	else if vars = [] then [monomial_1]
	685	else
	686	let alts =
	687	List.map
	688	(fun k ->
	689	let oths = enumerate_monomials (d - k) (List.tl vars) in
	690	List.map
	691	(fun ks -> if k = 0 then ks else (List.hd vars \|-> k) ks)
	692	oths)
	693	(0 -- d)
	694	in
	695	end_itlist ( @ ) alts
659	696
660	697	(* ------------------------------------------------------------------------- *)
661	698	(* Enumerate products of distinct input polys with degree <= d. *)

664	701	(* ------------------------------------------------------------------------- *)
665	702
666	703	let rec enumerate_products d pols =
667		if d = 0 then [poly_const num_1,Rational_lt num_1] else if d < 0 then [] else
668		match pols with
669		[] -> [poly_const num_1,Rational_lt num_1]
670		\| (p,b)::ps -> let e = multidegree p in
671		if e = 0 then enumerate_products d ps else
672		enumerate_products d ps @
673		List.map (fun (q,c) -> poly_mul p q,Product(b,c))
674		(enumerate_products (d - e) ps);;
	704	if d = 0 then [(poly_const num_1, Rational_lt num_1)]
	705	else if d < 0 then []
	706	else
	707	match pols with
	708	\| [] -> [(poly_const num_1, Rational_lt num_1)]
	709	\| (p, b) :: ps ->
	710	let e = multidegree p in
	711	if e = 0 then enumerate_products d ps
	712	else
	713	enumerate_products d ps
	714	@ List.map
	715	(fun (q, c) -> (poly_mul p q, Product (b, c)))
	716	(enumerate_products (d - e) ps)
675	717
676	718	(* ------------------------------------------------------------------------- *)
677	719	(* Multiply equation-parametrized poly by regular poly and add accumulator. *)
678	720	(* ------------------------------------------------------------------------- *)
679	721
680	722	let epoly_pmul p q acc =
681		foldl (fun a m1 c ->
682		foldl (fun b m2 e ->
683		let m = monomial_mul m1 m2 in
684		let es = tryapplyd b m undefined in
685		(m \|-> equation_add (equation_cmul c e) es) b)
686		a q) acc p;;
	723	foldl
	724	(fun a m1 c ->
	725	foldl
	726	(fun b m2 e ->
	727	let m = monomial_mul m1 m2 in
	728	let es = tryapplyd b m undefined in
	729	(m \|-> equation_add (equation_cmul c e) es) b)
	730	a q)
	731	acc p
687	732
688	733	(* ------------------------------------------------------------------------- *)
689	734	(* Convert regular polynomial. Note that we treat (0,0,0) as -1. *)
690	735	(* ------------------------------------------------------------------------- *)
691	736
692	737	let epoly_of_poly p =
693		foldl (fun a m c -> (m \|-> ((0,0,0) \|=> minus_num c)) a) undefined p;;
	738	foldl (fun a m c -> (m \|-> ((0, 0, 0) \|=> minus_num c)) a) undefined p
694	739
695	740	(* ------------------------------------------------------------------------- *)
696	741	(* String for block diagonal matrix numbered k. *)
697	742	(* ------------------------------------------------------------------------- *)
698	743
699	744	let sdpa_of_blockdiagonal k m =
700		let pfx = string_of_int k ^" " in
	745	let pfx = string_of_int k ^ " " in
701	746	let ents =
702		foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in
	747	foldl (fun a (b, i, j) c -> if i > j then a else ((b, i, j), c) :: a) [] m
	748	in
703	749	let entss = sort (increasing fst) ents in
704		List.fold_right (fun ((b,i,j),c) a ->
705		pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^
706		" " ^ decimalize 20 c ^ "\n" ^ a) entss "";;
	750	List.fold_right
	751	(fun ((b, i, j), c) a ->
	752	pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j
	753	^ " " ^ decimalize 20 c ^ "\n" ^ a)
	754	entss ""
707	755
708	756	(* ------------------------------------------------------------------------- *)
709	757	(* SDPA for problem using block diagonal (i.e. multiple SDPs) *)

711	759
712	760	let sdpa_of_blockproblem comment nblocks blocksizes obj mats =
713	761	let m = List.length mats - 1 in
714		"\"" ^ comment ^ "\"\n" ^
715		string_of_int m ^ "\n" ^
716		string_of_int nblocks ^ "\n" ^
717		(String.concat " " (List.map string_of_int blocksizes)) ^
718		"\n" ^
719		sdpa_of_vector obj ^
720		List.fold_right2 (fun k m a -> sdpa_of_blockdiagonal (k - 1) m ^ a)
721		(1--List.length mats) mats "";;
	762	"\"" ^ comment ^ "\"\n" ^ string_of_int m ^ "\n" ^ string_of_int nblocks
	763	^ "\n"
	764	^ String.concat " " (List.map string_of_int blocksizes)
	765	^ "\n" ^ sdpa_of_vector obj
	766	^ List.fold_right2
	767	(fun k m a -> sdpa_of_blockdiagonal (k - 1) m ^ a)
	768	(1 -- List.length mats)
	769	mats ""
722	770
723	771	(* ------------------------------------------------------------------------- *)
724	772	(* Hence run CSDP on a problem in block diagonal form. *)

730	778	String.sub input_file 0 (String.length input_file - 6) ^ ".out"
731	779	and params_file = Filename.concat temp_path "param.csdp" in
732	780	file_of_string input_file
733		(sdpa_of_blockproblem "" nblocks blocksizes obj mats);
	781	(sdpa_of_blockproblem "" nblocks blocksizes obj mats);
734	782	file_of_string params_file csdp_params;
735		let rv = Sys.command("cd "^temp_path^"; csdp "^input_file ^
736		" " ^ output_file ^
737		(if dbg then "" else "> /dev/null")) in
	783	let rv =
	784	Sys.command
	785	( "cd " ^ temp_path ^ "; csdp " ^ input_file ^ " " ^ output_file
	786	^ if dbg then "" else "> /dev/null" )
	787	in
738	788	let op = string_of_file output_file in
739	789	let res = parse_csdpoutput op in
740		((if dbg then ()
741		else (Sys.remove input_file; Sys.remove output_file));
742		rv,res);;
	790	if dbg then () else (Sys.remove input_file; Sys.remove output_file);
	791	(rv, res)
743	792
744	793	let csdp nblocks blocksizes obj mats =
745		let rv,res = run_csdp (!debugging) nblocks blocksizes obj mats in
746		(if rv = 1 \|\| rv = 2 then failwith "csdp: Problem is infeasible"
747		else if rv = 3 then ()
	794	let rv, res = run_csdp !debugging nblocks blocksizes obj mats in
	795	if rv = 1 \|\| rv = 2 then failwith "csdp: Problem is infeasible"
	796	else if rv = 3 then ()
748	797	(*Format.print_string "csdp warning: Reduced accuracy";
749	798	Format.print_newline() *)
750		else if rv <> 0 then failwith("csdp: error "^string_of_int rv)
751		else ());
752		res;;
	799	else if rv <> 0 then failwith ("csdp: error " ^ string_of_int rv)
	800	else ();
	801	res
753	802
754	803	(* ------------------------------------------------------------------------- *)
755	804	(* 3D versions of matrix operations to consider blocks separately. *)
756	805	(* ------------------------------------------------------------------------- *)
757	806
758		let bmatrix_add = combine (+/) (fun x -> x =/ Int 0);;
	807	let bmatrix_add = combine ( +/ ) (fun x -> x =/ Int 0)
759	808
760	809	let bmatrix_cmul c bm =
761		if c =/ Int 0 then undefined
762		else mapf (fun x -> c */ x) bm;;
763
764		let bmatrix_neg = bmatrix_cmul (Int(-1));;
	810	if c =/ Int 0 then undefined else mapf (fun x -> c */ x) bm
	811
	812	let bmatrix_neg = bmatrix_cmul (Int (-1))
765	813
766	814	(* ------------------------------------------------------------------------- *)
767	815	(* Smash a block matrix into components. *)
768	816	(* ------------------------------------------------------------------------- *)
769	817
770	818	let blocks blocksizes bm =
771		List.map (fun (bs,b0) ->
772		let m = foldl
773		(fun a (b,i,j) c -> if b = b0 then ((i,j) \|-> c) a else a)
774		undefined bm in
775		(((bs,bs),m):matrix))
776		(List.combine blocksizes (1--List.length blocksizes));;
	819	List.map
	820	(fun (bs, b0) ->
	821	let m =
	822	foldl
	823	(fun a (b, i, j) c -> if b = b0 then ((i, j) \|-> c) a else a)
	824	undefined bm
	825	in
	826	(((bs, bs), m) : matrix))
	827	(List.combine blocksizes (1 -- List.length blocksizes))
777	828
778	829	(* ------------------------------------------------------------------------- *)
779	830	(* Positiv- and Nullstellensatz. Flag "linf" forces a linear representation. *)
780	831	(* ------------------------------------------------------------------------- *)
781	832
782	833	let real_positivnullstellensatz_general linf d eqs leqs pol =
783		let vars = List.fold_right ((o) union poly_variables) (pol::eqs @ List.map fst leqs) [] in
	834	let vars =
	835	List.fold_right (o union poly_variables)
	836	((pol :: eqs) @ List.map fst leqs)
	837	[]
	838	in
784	839	let monoid =
785	840	if linf then
786		(poly_const num_1,Rational_lt num_1)::
787		(List.filter (fun (p,c) -> multidegree p <= d) leqs)
788		else enumerate_products d leqs in
	841	(poly_const num_1, Rational_lt num_1)
	842	:: List.filter (fun (p, c) -> multidegree p <= d) leqs
	843	else enumerate_products d leqs
	844	in
789	845	let nblocks = List.length monoid in
790	846	let mk_idmultiplier k p =
791	847	let e = d - multidegree p in
792	848	let mons = enumerate_monomials e vars in
793		let nons = List.combine mons (1--List.length mons) in
794		mons,
795		List.fold_right (fun (m,n) -> (m \|-> ((-k,-n,n) \|=> Int 1))) nons undefined in
796		let mk_sqmultiplier k (p,c) =
	849	let nons = List.combine mons (1 -- List.length mons) in
	850	( mons
	851	, List.fold_right
	852	(fun (m, n) -> m \|-> ((-k, -n, n) \|=> Int 1))
	853	nons undefined )
	854	in
	855	let mk_sqmultiplier k (p, c) =
797	856	let e = (d - multidegree p) / 2 in
798	857	let mons = enumerate_monomials e vars in
799		let nons = List.combine mons (1--List.length mons) in
800		mons,
801		List.fold_right (fun (m1,n1) ->
802		List.fold_right (fun (m2,n2) a ->
803		let m = monomial_mul m1 m2 in
804		if n1 > n2 then a else
805		let c = if n1 = n2 then Int 1 else Int 2 in
806		let e = tryapplyd a m undefined in
807		(m \|-> equation_add ((k,n1,n2) \|=> c) e) a)
808		nons)
809		nons undefined in
810		let sqmonlist,sqs = List.split(List.map2 mk_sqmultiplier (1--List.length monoid) monoid)
811		and idmonlist,ids = List.split(List.map2 mk_idmultiplier (1--List.length eqs) eqs) in
	858	let nons = List.combine mons (1 -- List.length mons) in
	859	( mons
	860	, List.fold_right
	861	(fun (m1, n1) ->
	862	List.fold_right
	863	(fun (m2, n2) a ->
	864	let m = monomial_mul m1 m2 in
	865	if n1 > n2 then a
	866	else
	867	let c = if n1 = n2 then Int 1 else Int 2 in
	868	let e = tryapplyd a m undefined in
	869	(m \|-> equation_add ((k, n1, n2) \|=> c) e) a)
	870	nons)
	871	nons undefined )
	872	in
	873	let sqmonlist, sqs =
	874	List.split (List.map2 mk_sqmultiplier (1 -- List.length monoid) monoid)
	875	and idmonlist, ids =
	876	List.split (List.map2 mk_idmultiplier (1 -- List.length eqs) eqs)
	877	in
812	878	let blocksizes = List.map List.length sqmonlist in
813	879	let bigsum =
814		List.fold_right2 (fun p q a -> epoly_pmul p q a) eqs ids
815		(List.fold_right2 (fun (p,c) s a -> epoly_pmul p s a) monoid sqs
816		(epoly_of_poly(poly_neg pol))) in
817		let eqns = foldl (fun a m e -> e::a) [] bigsum in
818		let pvs,assig = eliminate_all_equations (0,0,0) eqns in
819		let qvars = (0,0,0)::pvs in
820		let allassig = List.fold_right (fun v -> (v \|-> (v \|=> Int 1))) pvs assig in
	880	List.fold_right2
	881	(fun p q a -> epoly_pmul p q a)
	882	eqs ids
	883	(List.fold_right2
	884	(fun (p, c) s a -> epoly_pmul p s a)
	885	monoid sqs
	886	(epoly_of_poly (poly_neg pol)))
	887	in
	888	let eqns = foldl (fun a m e -> e :: a) [] bigsum in
	889	let pvs, assig = eliminate_all_equations (0, 0, 0) eqns in
	890	let qvars = (0, 0, 0) :: pvs in
	891	let allassig = List.fold_right (fun v -> v \|-> (v \|=> Int 1)) pvs assig in
821	892	let mk_matrix v =
822		foldl (fun m (b,i,j) ass -> if b < 0 then m else
823		let c = tryapplyd ass v (Int 0) in
824		if c =/ Int 0 then m else
825		((b,j,i) \|-> c) (((b,i,j) \|-> c) m))
826		undefined allassig in
827		let diagents = foldl
828		(fun a (b,i,j) e -> if b > 0 && i = j then equation_add e a else a)
829		undefined allassig in
	893	foldl
	894	(fun m (b, i, j) ass ->
	895	if b < 0 then m
	896	else
	897	let c = tryapplyd ass v (Int 0) in
	898	if c =/ Int 0 then m else ((b, j, i) \|-> c) (((b, i, j) \|-> c) m))
	899	undefined allassig
	900	in
	901	let diagents =
	902	foldl
	903	(fun a (b, i, j) e -> if b > 0 && i = j then equation_add e a else a)
	904	undefined allassig
	905	in
830	906	let mats = List.map mk_matrix qvars
831		and obj = List.length pvs,
832		itern 1 pvs (fun v i -> (i \|--> tryapplyd diagents v (Int 0)))
833		undefined in
834		let raw_vec = if pvs = [] then vector_0 0
835		else scale_then (csdp nblocks blocksizes) obj mats in
	907	and obj =
	908	( List.length pvs
	909	, itern 1 pvs (fun v i -> i \|--> tryapplyd diagents v (Int 0)) undefined )
	910	in
	911	let raw_vec =
	912	if pvs = [] then vector_0 0
	913	else scale_then (csdp nblocks blocksizes) obj mats
	914	in
836	915	let find_rounding d =
837		(if !debugging then
838		(Format.print_string("Trying rounding with limit "^string_of_num d);
839		Format.print_newline())
840		else ());
	916	if !debugging then (
	917	Format.print_string ("Trying rounding with limit " ^ string_of_num d);
	918	Format.print_newline () )
	919	else ();
841	920	let vec = nice_vector d raw_vec in
842		let blockmat = iter (1,dim vec)
843		(fun i a -> bmatrix_add (bmatrix_cmul (element vec i) (List.nth mats i)) a)
844		(bmatrix_neg (List.nth mats 0)) in
	921	let blockmat =
	922	iter
	923	(1, dim vec)
	924	(fun i a ->
	925	bmatrix_add (bmatrix_cmul (element vec i) (List.nth mats i)) a)
	926	(bmatrix_neg (List.nth mats 0))
	927	in
845	928	let allmats = blocks blocksizes blockmat in
846		vec,List.map diag allmats in
847		let vec,ratdias =
	929	(vec, List.map diag allmats)
	930	in
	931	let vec, ratdias =
848	932	if pvs = [] then find_rounding num_1
849		else tryfind find_rounding (List.map Num.num_of_int (1--31) @
850		List.map pow2 (5--66)) in
	933	else
	934	tryfind find_rounding
	935	(List.map Num.num_of_int (1 -- 31) @ List.map pow2 (5 -- 66))
	936	in
851	937	let newassigs =
852		List.fold_right (fun k -> List.nth pvs (k - 1) \|-> element vec k)
853		(1--dim vec) ((0,0,0) \|=> Int(-1)) in
	938	List.fold_right
	939	(fun k -> List.nth pvs (k - 1) \|-> element vec k)
	940	(1 -- dim vec)
	941	((0, 0, 0) \|=> Int (-1))
	942	in
854	943	let finalassigs =
855		foldl (fun a v e -> (v \|-> equation_eval newassigs e) a) newassigs
856		allassig in
	944	foldl (fun a v e -> (v \|-> equation_eval newassigs e) a) newassigs allassig
	945	in
857	946	let poly_of_epoly p =
858		foldl (fun a v e -> (v \|--> equation_eval finalassigs e) a)
859		undefined p in
	947	foldl (fun a v e -> (v \|--> equation_eval finalassigs e) a) undefined p
	948	in
860	949	let mk_sos mons =
861		let mk_sq (c,m) =
862		c,List.fold_right (fun k a -> (List.nth mons (k - 1) \|--> element m k) a)
863		(1--List.length mons) undefined in
864		List.map mk_sq in
	950	let mk_sq (c, m) =
	951	( c
	952	, List.fold_right
	953	(fun k a -> (List.nth mons (k - 1) \|--> element m k) a)
	954	(1 -- List.length mons)
	955	undefined )
	956	in
	957	List.map mk_sq
	958	in
865	959	let sqs = List.map2 mk_sos sqmonlist ratdias
866	960	and cfs = List.map poly_of_epoly ids in
867		let msq = List.filter (fun (a,b) -> b <> []) (List.map2 (fun a b -> a,b) monoid sqs) in
868		let eval_sq sqs = List.fold_right
869		(fun (c,q) -> poly_add (poly_cmul c (poly_mul q q))) sqs poly_0 in
	961	let msq =
	962	List.filter
	963	(fun (a, b) -> b <> [])
	964	(List.map2 (fun a b -> (a, b)) monoid sqs)
	965	in
	966	let eval_sq sqs =
	967	List.fold_right
	968	(fun (c, q) -> poly_add (poly_cmul c (poly_mul q q)))
	969	sqs poly_0
	970	in
870	971	let sanity =
871		List.fold_right (fun ((p,c),s) -> poly_add (poly_mul p (eval_sq s))) msq
872		(List.fold_right2 (fun p q -> poly_add (poly_mul p q)) cfs eqs
873		(poly_neg pol)) in
874		if not(is_undefined sanity) then raise Sanity else
875		cfs,List.map (fun (a,b) -> snd a,b) msq;;
	972	List.fold_right
	973	(fun ((p, c), s) -> poly_add (poly_mul p (eval_sq s)))
	974	msq
	975	(List.fold_right2
	976	(fun p q -> poly_add (poly_mul p q))
	977	cfs eqs (poly_neg pol))
	978	in
	979	if not (is_undefined sanity) then raise Sanity
	980	else (cfs, List.map (fun (a, b) -> (snd a, b)) msq)
876	981
877	982	(* ------------------------------------------------------------------------- *)
878	983	(* The ordering so we can create canonical HOL polynomials. *)
879	984	(* ------------------------------------------------------------------------- *)
880	985
881		let dest_monomial mon = sort (increasing fst) (graph mon);;
	986	let dest_monomial mon = sort (increasing fst) (graph mon)
882	987
883	988	let monomial_order =
884	989	let rec lexorder l1 l2 =
885		match (l1,l2) with
886		[],[] -> true
887		\| vps,[] -> false
888		\| [],vps -> true
889		\| ((x1,n1)::vs1),((x2,n2)::vs2) ->
890		if x1 < x2 then true
891		else if x2 < x1 then false
892		else if n1 < n2 then false
893		else if n2 < n1 then true
894		else lexorder vs1 vs2 in
	990	match (l1, l2) with
	991	\| [], [] -> true
	992	\| vps, [] -> false
	993	\| [], vps -> true
	994	\| (x1, n1) :: vs1, (x2, n2) :: vs2 ->
	995	if x1 < x2 then true
	996	else if x2 < x1 then false
	997	else if n1 < n2 then false
	998	else if n2 < n1 then true
	999	else lexorder vs1 vs2
	1000	in
895	1001	fun m1 m2 ->
896		if m2 = monomial_1 then true else if m1 = monomial_1 then false else
897		let mon1 = dest_monomial m1 and mon2 = dest_monomial m2 in
898		let deg1 = List.fold_right ((o) (+) snd) mon1 0
899		and deg2 = List.fold_right ((o) (+) snd) mon2 0 in
900		if deg1 < deg2 then false else if deg1 > deg2 then true
901		else lexorder mon1 mon2;;
	1002	if m2 = monomial_1 then true
	1003	else if m1 = monomial_1 then false
	1004	else
	1005	let mon1 = dest_monomial m1 and mon2 = dest_monomial m2 in
	1006	let deg1 = List.fold_right (o ( + ) snd) mon1 0
	1007	and deg2 = List.fold_right (o ( + ) snd) mon2 0 in
	1008	if deg1 < deg2 then false
	1009	else if deg1 > deg2 then true
	1010	else lexorder mon1 mon2
902	1011
903	1012	(* ------------------------------------------------------------------------- *)
904	1013	(* Map back polynomials and their composites to HOL. *)
905	1014	(* ------------------------------------------------------------------------- *)
906	1015
907		let term_of_varpow =
908		fun x k ->
909		if k = 1 then Var x else Pow (Var x, k);;
910
911		let term_of_monomial =
912		fun m -> if m = monomial_1 then Const num_1 else
913		let m' = dest_monomial m in
914		let vps = List.fold_right (fun (x,k) a -> term_of_varpow x k :: a) m' [] in
915		end_itlist (fun s t -> Mul (s,t)) vps;;
916
917		let term_of_cmonomial =
918		fun (m,c) ->
919		if m = monomial_1 then Const c
920		else if c =/ num_1 then term_of_monomial m
921		else Mul (Const c,term_of_monomial m);;
922
923		let term_of_poly =
924		fun p ->
925		if p = poly_0 then Zero else
926		let cms = List.map term_of_cmonomial
927		(sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p)) in
928		end_itlist (fun t1 t2 -> Add (t1,t2)) cms;;
929
930		let term_of_sqterm (c,p) =
931		Product(Rational_lt c,Square(term_of_poly p));;
932
933		let term_of_sos (pr,sqs) =
	1016	let term_of_varpow x k = if k = 1 then Var x else Pow (Var x, k)
	1017
	1018	let term_of_monomial m =
	1019	if m = monomial_1 then Const num_1
	1020	else
	1021	let m' = dest_monomial m in
	1022	let vps = List.fold_right (fun (x, k) a -> term_of_varpow x k :: a) m' [] in
	1023	end_itlist (fun s t -> Mul (s, t)) vps
	1024
	1025	let term_of_cmonomial (m, c) =
	1026	if m = monomial_1 then Const c
	1027	else if c =/ num_1 then term_of_monomial m
	1028	else Mul (Const c, term_of_monomial m)
	1029
	1030	let term_of_poly p =
	1031	if p = poly_0 then Zero
	1032	else
	1033	let cms =
	1034	List.map term_of_cmonomial
	1035	(sort (fun (m1, _) (m2, _) -> monomial_order m1 m2) (graph p))
	1036	in
	1037	end_itlist (fun t1 t2 -> Add (t1, t2)) cms
	1038
	1039	let term_of_sqterm (c, p) = Product (Rational_lt c, Square (term_of_poly p))
	1040
	1041	let term_of_sos (pr, sqs) =
934	1042	if sqs = [] then pr
935		else Product(pr,end_itlist (fun a b -> Sum(a,b)) (List.map term_of_sqterm sqs));;
	1043	else
	1044	Product
	1045	(pr, end_itlist (fun a b -> Sum (a, b)) (List.map term_of_sqterm sqs))
936	1046
937	1047	(* ------------------------------------------------------------------------- *)
938	1048	(* Some combinatorial helper functions. *)
939	1049	(* ------------------------------------------------------------------------- *)
940	1050
941	1051	let rec allpermutations l =
942		if l = [] then [[]] else
943		List.fold_right (fun h acc -> List.map (fun t -> h::t)
944		(allpermutations (subtract l [h])) @ acc) l [];;
945
946		let changevariables_monomial zoln (m:monomial) =
947		foldl (fun a x k -> (List.assoc x zoln \|-> k) a) monomial_1 m;;
	1052	if l = [] then [[]]
	1053	else
	1054	List.fold_right
	1055	(fun h acc ->
	1056	List.map (fun t -> h :: t) (allpermutations (subtract l [h])) @ acc)
	1057	l []
	1058
	1059	let changevariables_monomial zoln (m : monomial) =
	1060	foldl (fun a x k -> (List.assoc x zoln \|-> k) a) monomial_1 m
948	1061
949	1062	let changevariables zoln pol =
950		foldl (fun a m c -> (changevariables_monomial zoln m \|-> c) a)
951		poly_0 pol;;
	1063	foldl (fun a m c -> (changevariables_monomial zoln m \|-> c) a) poly_0 pol
952	1064
953	1065	(* ------------------------------------------------------------------------- *)
954	1066	(* Return to original non-block matrices. *)
955	1067	(* ------------------------------------------------------------------------- *)
956	1068
957		let sdpa_of_vector (v:vector) =
	1069	let sdpa_of_vector (v : vector) =
958	1070	let n = dim v in
959		let strs = List.map (o (decimalize 20) (element v)) (1--n) in
960		String.concat " " strs ^ "\n";;
961
962		let sdpa_of_matrix k (m:matrix) =
	1071	let strs = List.map (o (decimalize 20) (element v)) (1 -- n) in
	1072	String.concat " " strs ^ "\n"
	1073
	1074	let sdpa_of_matrix k (m : matrix) =
963	1075	let pfx = string_of_int k ^ " 1 " in
964		let ms = foldr (fun (i,j) c a -> if i > j then a else ((i,j),c)::a)
965		(snd m) [] in
	1076	let ms =
	1077	foldr (fun (i, j) c a -> if i > j then a else ((i, j), c) :: a) (snd m) []
	1078	in
966	1079	let mss = sort (increasing fst) ms in
967		List.fold_right (fun ((i,j),c) a ->
968		pfx ^ string_of_int i ^ " " ^ string_of_int j ^
969		" " ^ decimalize 20 c ^ "\n" ^ a) mss "";;
	1080	List.fold_right
	1081	(fun ((i, j), c) a ->
	1082	pfx ^ string_of_int i ^ " " ^ string_of_int j ^ " " ^ decimalize 20 c
	1083	^ "\n" ^ a)
	1084	mss ""
970	1085
971	1086	let sdpa_of_problem comment obj mats =
972		let m = List.length mats - 1
973		and n,_ = dimensions (List.hd mats) in
974		"\"" ^ comment ^ "\"\n" ^
975		string_of_int m ^ "\n" ^
976		"1\n" ^
977		string_of_int n ^ "\n" ^
978		sdpa_of_vector obj ^
979		List.fold_right2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a)
980		(1--List.length mats) mats "";;
	1087	let m = List.length mats - 1 and n, _ = dimensions (List.hd mats) in
	1088	"\"" ^ comment ^ "\"\n" ^ string_of_int m ^ "\n" ^ "1\n" ^ string_of_int n
	1089	^ "\n" ^ sdpa_of_vector obj
	1090	^ List.fold_right2
	1091	(fun k m a -> sdpa_of_matrix (k - 1) m ^ a)
	1092	(1 -- List.length mats)
	1093	mats ""
981	1094
982	1095	let run_csdp dbg obj mats =
983	1096	let input_file = Filename.temp_file "sos" ".dat-s" in

986	1099	and params_file = Filename.concat temp_path "param.csdp" in
987	1100	file_of_string input_file (sdpa_of_problem "" obj mats);
988	1101	file_of_string params_file csdp_params;
989		let rv = Sys.command("cd "^temp_path^"; csdp "^input_file ^
990		" " ^ output_file ^
991		(if dbg then "" else "> /dev/null")) in
	1102	let rv =
	1103	Sys.command
	1104	( "cd " ^ temp_path ^ "; csdp " ^ input_file ^ " " ^ output_file
	1105	^ if dbg then "" else "> /dev/null" )
	1106	in
992	1107	let op = string_of_file output_file in
993	1108	let res = parse_csdpoutput op in
994		((if dbg then ()
995		else (Sys.remove input_file; Sys.remove output_file));
996		rv,res);;
	1109	if dbg then () else (Sys.remove input_file; Sys.remove output_file);
	1110	(rv, res)
997	1111
998	1112	let csdp obj mats =
999		let rv,res = run_csdp (!debugging) obj mats in
1000		(if rv = 1 \|\| rv = 2 then failwith "csdp: Problem is infeasible"
1001		else if rv = 3 then ()
1002		(* (Format.print_string "csdp warning: Reduced accuracy";
	1113	let rv, res = run_csdp !debugging obj mats in
	1114	if rv = 1 \|\| rv = 2 then failwith "csdp: Problem is infeasible"
	1115	else if rv = 3 then ()
	1116	(* (Format.print_string "csdp warning: Reduced accuracy";
1003	1117	Format.print_newline()) *)
1004		else if rv <> 0 then failwith("csdp: error "^string_of_int rv)
1005		else ());
1006		res;;
	1118	else if rv <> 0 then failwith ("csdp: error " ^ string_of_int rv)
	1119	else ();
	1120	res
1007	1121
1008	1122	(* ------------------------------------------------------------------------- *)
1009	1123	(* Sum-of-squares function with some lowbrow symmetry reductions. *)
1010	1124	(* ------------------------------------------------------------------------- *)
1011	1125
1012	1126	let sumofsquares_general_symmetry tool pol =
1013		let vars = poly_variables pol
1014		and lpps = newton_polytope pol in
	1127	let vars = poly_variables pol and lpps = newton_polytope pol in
1015	1128	let n = List.length lpps in
1016	1129	let sym_eqs =
1017		let invariants = List.filter
1018		(fun vars' ->
1019		is_undefined(poly_sub pol (changevariables (List.combine vars vars') pol)))
1020		(allpermutations vars) in
1021		let lpns = List.combine lpps (1--List.length lpps) in
	1130	let invariants =
	1131	List.filter
	1132	(fun vars' ->
	1133	is_undefined
	1134	(poly_sub pol (changevariables (List.combine vars vars') pol)))
	1135	(allpermutations vars)
	1136	in
	1137	let lpns = List.combine lpps (1 -- List.length lpps) in
1022	1138	let lppcs =
1023		List.filter (fun (m,(n1,n2)) -> n1 <= n2)
1024		(allpairs
1025		(fun (m1,n1) (m2,n2) -> (m1,m2),(n1,n2)) lpns lpns) in
1026		let clppcs = end_itlist (@)
1027		(List.map (fun ((m1,m2),(n1,n2)) ->
1028		List.map (fun vars' ->
1029		(changevariables_monomial (List.combine vars vars') m1,
1030		changevariables_monomial (List.combine vars vars') m2),(n1,n2))
1031		invariants)
1032		lppcs) in
1033		let clppcs_dom = setify(List.map fst clppcs) in
1034		let clppcs_cls = List.map (fun d -> List.filter (fun (e,_) -> e = d) clppcs)
1035		clppcs_dom in
	1139	List.filter
	1140	(fun (m, (n1, n2)) -> n1 <= n2)
	1141	(allpairs (fun (m1, n1) (m2, n2) -> ((m1, m2), (n1, n2))) lpns lpns)
	1142	in
	1143	let clppcs =
	1144	end_itlist ( @ )
	1145	(List.map
	1146	(fun ((m1, m2), (n1, n2)) ->
	1147	List.map
	1148	(fun vars' ->
	1149	( ( changevariables_monomial (List.combine vars vars') m1
	1150	, changevariables_monomial (List.combine vars vars') m2 )
	1151	, (n1, n2) ))
	1152	invariants)
	1153	lppcs)
	1154	in
	1155	let clppcs_dom = setify (List.map fst clppcs) in
	1156	let clppcs_cls =
	1157	List.map (fun d -> List.filter (fun (e, _) -> e = d) clppcs) clppcs_dom
	1158	in
1036	1159	let eqvcls = List.map (o setify (List.map snd)) clppcs_cls in
1037	1160	let mk_eq cls acc =
1038	1161	match cls with
1039		[] -> raise Sanity
	1162	\| [] -> raise Sanity
1040	1163	\| [h] -> acc
1041		\| h::t -> List.map (fun k -> (k \|-> Int(-1)) (h \|=> Int 1)) t @ acc in
1042		List.fold_right mk_eq eqvcls [] in
1043		let eqs = foldl (fun a x y -> y::a) []
1044		(itern 1 lpps (fun m1 n1 ->
1045		itern 1 lpps (fun m2 n2 f ->
1046		let m = monomial_mul m1 m2 in
1047		if n1 > n2 then f else
1048		let c = if n1 = n2 then Int 1 else Int 2 in
1049		(m \|-> ((n1,n2) \|-> c) (tryapplyd f m undefined)) f))
1050		(foldl (fun a m c -> (m \|-> ((0,0)\|=>c)) a)
1051		undefined pol)) @
1052		sym_eqs in
1053		let pvs,assig = eliminate_all_equations (0,0) eqs in
1054		let allassig = List.fold_right (fun v -> (v \|-> (v \|=> Int 1))) pvs assig in
1055		let qvars = (0,0)::pvs in
	1164	\| h :: t -> List.map (fun k -> (k \|-> Int (-1)) (h \|=> Int 1)) t @ acc
	1165	in
	1166	List.fold_right mk_eq eqvcls []
	1167	in
	1168	let eqs =
	1169	foldl
	1170	(fun a x y -> y :: a)
	1171	[]
	1172	(itern 1 lpps
	1173	(fun m1 n1 ->
	1174	itern 1 lpps (fun m2 n2 f ->
	1175	let m = monomial_mul m1 m2 in
	1176	if n1 > n2 then f
	1177	else
	1178	let c = if n1 = n2 then Int 1 else Int 2 in
	1179	(m \|-> ((n1, n2) \|-> c) (tryapplyd f m undefined)) f))
	1180	(foldl (fun a m c -> (m \|-> ((0, 0) \|=> c)) a) undefined pol))
	1181	@ sym_eqs
	1182	in
	1183	let pvs, assig = eliminate_all_equations (0, 0) eqs in
	1184	let allassig = List.fold_right (fun v -> v \|-> (v \|=> Int 1)) pvs assig in
	1185	let qvars = (0, 0) :: pvs in
1056	1186	let diagents =
1057		end_itlist equation_add (List.map (fun i -> apply allassig (i,i)) (1--n)) in
	1187	end_itlist equation_add (List.map (fun i -> apply allassig (i, i)) (1 -- n))
	1188	in
1058	1189	let mk_matrix v =
1059		((n,n),
1060		foldl (fun m (i,j) ass -> let c = tryapplyd ass v (Int 0) in
1061		if c =/ Int 0 then m else
1062		((j,i) \|-> c) (((i,j) \|-> c) m))
1063		undefined allassig :matrix) in
	1190	( ( (n, n)
	1191	, foldl
	1192	(fun m (i, j) ass ->
	1193	let c = tryapplyd ass v (Int 0) in
	1194	if c =/ Int 0 then m else ((j, i) \|-> c) (((i, j) \|-> c) m))
	1195	undefined allassig )
	1196	: matrix )
	1197	in
1064	1198	let mats = List.map mk_matrix qvars
1065		and obj = List.length pvs,
1066		itern 1 pvs (fun v i -> (i \|--> tryapplyd diagents v (Int 0)))
1067		undefined in
	1199	and obj =
	1200	( List.length pvs
	1201	, itern 1 pvs (fun v i -> i \|--> tryapplyd diagents v (Int 0)) undefined )
	1202	in
1068	1203	let raw_vec = if pvs = [] then vector_0 0 else tool obj mats in
1069	1204	let find_rounding d =
1070		(if !debugging then
1071		(Format.print_string("Trying rounding with limit "^string_of_num d);
1072		Format.print_newline())
1073		else ());
	1205	if !debugging then (
	1206	Format.print_string ("Trying rounding with limit " ^ string_of_num d);
	1207	Format.print_newline () )
	1208	else ();
1074	1209	let vec = nice_vector d raw_vec in
1075		let mat = iter (1,dim vec)
1076		(fun i a -> matrix_add (matrix_cmul (element vec i) (List.nth mats i)) a)
1077		(matrix_neg (List.nth mats 0)) in
1078		deration(diag mat) in
1079		let rat,dia =
	1210	let mat =
	1211	iter
	1212	(1, dim vec)
	1213	(fun i a ->
	1214	matrix_add (matrix_cmul (element vec i) (List.nth mats i)) a)
	1215	(matrix_neg (List.nth mats 0))
	1216	in
	1217	deration (diag mat)
	1218	in
	1219	let rat, dia =
1080	1220	if pvs = [] then
1081		let mat = matrix_neg (List.nth mats 0) in
1082		deration(diag mat)
	1221	let mat = matrix_neg (List.nth mats 0) in
	1222	deration (diag mat)
1083	1223	else
1084		tryfind find_rounding (List.map Num.num_of_int (1--31) @
1085		List.map pow2 (5--66)) in
1086		let poly_of_lin(d,v) =
1087		d,foldl(fun a i c -> (List.nth lpps (i - 1) \|-> c) a) undefined (snd v) in
	1224	tryfind find_rounding
	1225	(List.map Num.num_of_int (1 -- 31) @ List.map pow2 (5 -- 66))
	1226	in
	1227	let poly_of_lin (d, v) =
	1228	(d, foldl (fun a i c -> (List.nth lpps (i - 1) \|-> c) a) undefined (snd v))
	1229	in
1088	1230	let lins = List.map poly_of_lin dia in
1089		let sqs = List.map (fun (d,l) -> poly_mul (poly_const d) (poly_pow l 2)) lins in
	1231	let sqs =
	1232	List.map (fun (d, l) -> poly_mul (poly_const d) (poly_pow l 2)) lins
	1233	in
1090	1234	let sos = poly_cmul rat (end_itlist poly_add sqs) in
1091		if is_undefined(poly_sub sos pol) then rat,lins else raise Sanity;;
1092
1093		let sumofsquares = sumofsquares_general_symmetry csdp;;
1094
	1235	if is_undefined (poly_sub sos pol) then (rat, lins) else raise Sanity
	1236
	1237	let sumofsquares = sumofsquares_general_symmetry csdp

+10

-12

plugins/micromega/sos.mli less more

12	12	type poly
13	13
14	14	val poly_isconst : poly -> bool
15
16	15	val poly_neg : poly -> poly
17
18	16	val poly_mul : poly -> poly -> poly
19
20	17	val poly_pow : poly -> int -> poly
21
22	18	val poly_const : Num.num -> poly
23
24	19	val poly_of_term : term -> poly
25
26	20	val term_of_poly : poly -> term
27	21
28		val term_of_sos : positivstellensatz * (Num.num * poly) list ->
29		positivstellensatz
	22	val term_of_sos :
	23	positivstellensatz * (Num.num * poly) list -> positivstellensatz
30	24
31	25	val string_of_poly : poly -> string
32	26
33		val real_positivnullstellensatz_general : bool -> int -> poly list ->
34		(poly * positivstellensatz) list ->
35		poly -> poly list * (positivstellensatz * (Num.num * poly) list) list
	27	val real_positivnullstellensatz_general :
	28	bool
	29	-> int
	30	-> poly list
	31	-> (poly * positivstellensatz) list
	32	-> poly
	33	-> poly list * (positivstellensatz * (Num.num * poly) list) list
36	34
37		val sumofsquares : poly -> Num.num * ( Num.num * poly) list
	35	val sumofsquares : poly -> Num.num * (Num.num * poly) list

+273

-280

plugins/micromega/sos_lib.ml less more

12	12	(* Comparisons that are reflexive on NaN and also short-circuiting. *)
13	13	(* ------------------------------------------------------------------------- *)
14	14
15		let cmp = compare (** FIXME *)
16
17		let (=?) = fun x y -> cmp x y = 0;;
18		let (<?) = fun x y -> cmp x y < 0;;
19		let (<=?) = fun x y -> cmp x y <= 0;;
20		let (>?) = fun x y -> cmp x y > 0;;
	15	(** FIXME *)
	16	let cmp = compare
	17
	18	let ( =? ) x y = cmp x y = 0
	19	let ( <? ) x y = cmp x y < 0
	20	let ( <=? ) x y = cmp x y <= 0
	21	let ( >? ) x y = cmp x y > 0
21	22
22	23	(* ------------------------------------------------------------------------- *)
23	24	(* Combinators. *)
24	25	(* ------------------------------------------------------------------------- *)
25	26
26		let (o) = fun f g x -> f(g x);;
	27	let o f g x = f (g x)
27	28
28	29	(* ------------------------------------------------------------------------- *)
29	30	(* Some useful functions on "num" type. *)
30	31	(* ------------------------------------------------------------------------- *)
31
32	32
33	33	let num_0 = Int 0
34	34	and num_1 = Int 1
35	35	and num_2 = Int 2
36		and num_10 = Int 10;;
37
38		let pow2 n = power_num num_2 (Int n);;
39		let pow10 n = power_num num_10 (Int n);;
	36	and num_10 = Int 10
	37
	38	let pow2 n = power_num num_2 (Int n)
	39	let pow10 n = power_num num_10 (Int n)
40	40
41	41	let numdom r =
42	42	let r' = Ratio.normalize_ratio (ratio_of_num r) in
43		num_of_big_int(Ratio.numerator_ratio r'),
44		num_of_big_int(Ratio.denominator_ratio r');;
45
46		let numerator = (o) fst numdom
47		and denominator = (o) snd numdom;;
	43	( num_of_big_int (Ratio.numerator_ratio r')
	44	, num_of_big_int (Ratio.denominator_ratio r') )
	45
	46	let numerator = o fst numdom
	47	and denominator = o snd numdom
48	48
49	49	let gcd_num n1 n2 =
50		num_of_big_int(Big_int.gcd_big_int (big_int_of_num n1) (big_int_of_num n2));;
	50	num_of_big_int (Big_int.gcd_big_int (big_int_of_num n1) (big_int_of_num n2))
51	51
52	52	let lcm_num x y =
53		if x =/ num_0 && y =/ num_0 then num_0
54		else abs_num((x */ y) // gcd_num x y);;
55
	53	if x =/ num_0 && y =/ num_0 then num_0 else abs_num (x */ y // gcd_num x y)
56	54
57	55	(* ------------------------------------------------------------------------- *)
58	56	(* Various versions of list iteration. *)

60	58
61	59	let rec end_itlist f l =
62	60	match l with
63		[] -> failwith "end_itlist"
64		\| [x] -> x
65		\| (h::t) -> f h (end_itlist f t);;
	61	\| [] -> failwith "end_itlist"
	62	\| [x] -> x
	63	\| h :: t -> f h (end_itlist f t)
66	64
67	65	(* ------------------------------------------------------------------------- *)
68	66	(* All pairs arising from applying a function over two lists. *)

70	68
71	69	let rec allpairs f l1 l2 =
72	70	match l1 with
73		h1::t1 -> List.fold_right (fun x a -> f h1 x :: a) l2 (allpairs f t1 l2)
74		\| [] -> [];;
	71	\| h1 :: t1 -> List.fold_right (fun x a -> f h1 x :: a) l2 (allpairs f t1 l2)
	72	\| [] -> []
75	73
76	74	(* ------------------------------------------------------------------------- *)
77	75	(* String operations (surely there is a better way...) *)
78	76	(* ------------------------------------------------------------------------- *)
79	77
80		let implode l = List.fold_right (^) l "";;
	78	let implode l = List.fold_right ( ^ ) l ""
81	79
82	80	let explode s =
83	81	let rec exap n l =
84		if n < 0 then l else
85		exap (n - 1) ((String.sub s n 1)::l) in
86		exap (String.length s - 1) [];;
87
	82	if n < 0 then l else exap (n - 1) (String.sub s n 1 :: l)
	83	in
	84	exap (String.length s - 1) []
88	85
89	86	(* ------------------------------------------------------------------------- *)
90	87	(* Repetition of a function. *)
91	88	(* ------------------------------------------------------------------------- *)
92	89
93		let rec funpow n f x =
94		if n < 1 then x else funpow (n-1) f (f x);;
95
96
	90	let rec funpow n f x = if n < 1 then x else funpow (n - 1) f (f x)
97	91
98	92	(* ------------------------------------------------------------------------- *)
99	93	(* Sequences. *)
100	94	(* ------------------------------------------------------------------------- *)
101	95
102		let rec (--) = fun m n -> if m > n then [] else m::((m + 1) -- n);;
	96	let rec ( -- ) m n = if m > n then [] else m :: (m + 1 -- n)
103	97
104	98	(* ------------------------------------------------------------------------- *)
105	99	(* Various useful list operations. *)

107	101
108	102	let rec tryfind f l =
109	103	match l with
110		[] -> failwith "tryfind"
111		\| (h::t) -> try f h with Failure _ -> tryfind f t;;
	104	\| [] -> failwith "tryfind"
	105	\| h :: t -> ( try f h with Failure _ -> tryfind f t )
112	106
113	107	(* ------------------------------------------------------------------------- *)
114	108	(* "Set" operations on lists. *)
115	109	(* ------------------------------------------------------------------------- *)
116	110
117		let rec mem x lis =
118		match lis with
119		[] -> false
120		\| (h::t) -> x =? h \|\| mem x t;;
121
122		let insert x l =
123		if mem x l then l else x::l;;
124
125		let union l1 l2 = List.fold_right insert l1 l2;;
126
127		let subtract l1 l2 = List.filter (fun x -> not (mem x l2)) l1;;
	111	let rec mem x lis = match lis with [] -> false \| h :: t -> x =? h \|\| mem x t
	112	let insert x l = if mem x l then l else x :: l
	113	let union l1 l2 = List.fold_right insert l1 l2
	114	let subtract l1 l2 = List.filter (fun x -> not (mem x l2)) l1
128	115
129	116	(* ------------------------------------------------------------------------- *)
130	117	(* Common measure predicates to use with "sort". *)
131	118	(* ------------------------------------------------------------------------- *)
132	119
133		let increasing f x y = f x <? f y;;
	120	let increasing f x y = f x <? f y
134	121
135	122	(* ------------------------------------------------------------------------- *)
136	123	(* Iterating functions over lists. *)
137	124	(* ------------------------------------------------------------------------- *)
138	125
139		let rec do_list f l =
140		match l with
141		[] -> ()
142		\| (h::t) -> (f h; do_list f t);;
	126	let rec do_list f l = match l with [] -> () \| h :: t -> f h; do_list f t
143	127
144	128	(* ------------------------------------------------------------------------- *)
145	129	(* Sorting. *)

147	131
148	132	let rec sort cmp lis =
149	133	match lis with
150		[] -> []
151		\| piv::rest ->
152		let r,l = List.partition (cmp piv) rest in
153		(sort cmp l) @ (piv::(sort cmp r));;
	134	\| [] -> []
	135	\| piv :: rest ->
	136	let r, l = List.partition (cmp piv) rest in
	137	sort cmp l @ (piv :: sort cmp r)
154	138
155	139	(* ------------------------------------------------------------------------- *)
156	140	(* Removing adjacent (NB!) equal elements from list. *)

158	142
159	143	let rec uniq l =
160	144	match l with
161		x::(y::_ as t) -> let t' = uniq t in
162		if x =? y then t' else
163		if t'==t then l else x::t'
164		\| _ -> l;;
	145	\| x :: (y :: _ as t) ->
	146	let t' = uniq t in
	147	if x =? y then t' else if t' == t then l else x :: t'
	148	\| _ -> l
165	149
166	150	(* ------------------------------------------------------------------------- *)
167	151	(* Convert list into set by eliminating duplicates. *)
168	152	(* ------------------------------------------------------------------------- *)
169	153
170		let setify s = uniq (sort (<=?) s);;
	154	let setify s = uniq (sort ( <=? ) s)
171	155
172	156	(* ------------------------------------------------------------------------- *)
173	157	(* Polymorphic finite partial functions via Patricia trees. *)

178	162	(* Idea due to Diego Olivier Fernandez Pons (OCaml list, 2003/11/10). *)
179	163	(* ------------------------------------------------------------------------- *)
180	164
181		type ('a,'b)func =
182		Empty
183		\| Leaf of int * ('a*'b)list
184		\| Branch of int * int * ('a,'b)func * ('a,'b)func;;
	165	type ('a, 'b) func =
	166	\| Empty
	167	\| Leaf of int * ('a * 'b) list
	168	\| Branch of int * int * ('a, 'b) func * ('a, 'b) func
185	169
186	170	(* ------------------------------------------------------------------------- *)
187	171	(* Undefined function. *)
188	172	(* ------------------------------------------------------------------------- *)
189	173
190		let undefined = Empty;;
	174	let undefined = Empty
191	175
192	176	(* ------------------------------------------------------------------------- *)
193	177	(* In case of equality comparison worries, better use this. *)
194	178	(* ------------------------------------------------------------------------- *)
195	179
196		let is_undefined f =
197		match f with
198		Empty -> true
199		\| _ -> false;;
	180	let is_undefined f = match f with Empty -> true \| _ -> false
200	181
201	182	(* ------------------------------------------------------------------------- *)
202	183	(* Operation analogous to "map" for lists. *)

204	185
205	186	let mapf =
206	187	let rec map_list f l =
207		match l with
208		[] -> []
209		\| (x,y)::t -> (x,f(y))::(map_list f t) in
	188	match l with [] -> [] \| (x, y) :: t -> (x, f y) :: map_list f t
	189	in
210	190	let rec mapf f t =
211	191	match t with
212		Empty -> Empty
213		\| Leaf(h,l) -> Leaf(h,map_list f l)
214		\| Branch(p,b,l,r) -> Branch(p,b,mapf f l,mapf f r) in
215		mapf;;
	192	\| Empty -> Empty
	193	\| Leaf (h, l) -> Leaf (h, map_list f l)
	194	\| Branch (p, b, l, r) -> Branch (p, b, mapf f l, mapf f r)
	195	in
	196	mapf
216	197
217	198	(* ------------------------------------------------------------------------- *)
218	199	(* Operations analogous to "fold" for lists. *)

220	201
221	202	let foldl =
222	203	let rec foldl_list f a l =
223		match l with
224		[] -> a
225		\| (x,y)::t -> foldl_list f (f a x y) t in
	204	match l with [] -> a \| (x, y) :: t -> foldl_list f (f a x y) t
	205	in
226	206	let rec foldl f a t =
227	207	match t with
228		Empty -> a
229		\| Leaf(h,l) -> foldl_list f a l
230		\| Branch(p,b,l,r) -> foldl f (foldl f a l) r in
231		foldl;;
	208	\| Empty -> a
	209	\| Leaf (h, l) -> foldl_list f a l
	210	\| Branch (p, b, l, r) -> foldl f (foldl f a l) r
	211	in
	212	foldl
232	213
233	214	let foldr =
234	215	let rec foldr_list f l a =
235		match l with
236		[] -> a
237		\| (x,y)::t -> f x y (foldr_list f t a) in
	216	match l with [] -> a \| (x, y) :: t -> f x y (foldr_list f t a)
	217	in
238	218	let rec foldr f t a =
239	219	match t with
240		Empty -> a
241		\| Leaf(h,l) -> foldr_list f l a
242		\| Branch(p,b,l,r) -> foldr f l (foldr f r a) in
243		foldr;;
	220	\| Empty -> a
	221	\| Leaf (h, l) -> foldr_list f l a
	222	\| Branch (p, b, l, r) -> foldr f l (foldr f r a)
	223	in
	224	foldr
244	225
245	226	(* ------------------------------------------------------------------------- *)
246	227	(* Redefinition and combination. *)
247	228	(* ------------------------------------------------------------------------- *)
248	229
249		let (\|->),combine =
250		let ldb x y = let z = x lxor y in z land (-z) in
	230	let ( \|-> ), combine =
	231	let ldb x y =
	232	let z = x lxor y in
	233	z land -z
	234	in
251	235	let newbranch p1 t1 p2 t2 =
252	236	let b = ldb p1 p2 in
253	237	let p = p1 land (b - 1) in
254		if p1 land b = 0 then Branch(p,b,t1,t2)
255		else Branch(p,b,t2,t1) in
256		let rec define_list (x,y as xy) l =
	238	if p1 land b = 0 then Branch (p, b, t1, t2) else Branch (p, b, t2, t1)
	239	in
	240	let rec define_list ((x, y) as xy) l =
257	241	match l with
258		(a,b as ab)::t ->
259		if x =? a then xy::t
260		else if x <? a then xy::l
261		else ab::(define_list xy t)
	242	\| ((a, b) as ab) :: t ->
	243	if x =? a then xy :: t
	244	else if x <? a then xy :: l
	245	else ab :: define_list xy t
262	246	\| [] -> [xy]
263	247	and combine_list op z l1 l2 =
264		match (l1,l2) with
265		[],_ -> l2
266		\| _,[] -> l1
267		\| ((x1,y1 as xy1)::t1,(x2,y2 as xy2)::t2) ->
268		if x1 <? x2 then xy1::(combine_list op z t1 l2)
269		else if x2 <? x1 then xy2::(combine_list op z l1 t2) else
270		let y = op y1 y2 and l = combine_list op z t1 t2 in
271		if z(y) then l else (x1,y)::l in
272		let (\|->) x y =
	248	match (l1, l2) with
	249	\| [], _ -> l2
	250	\| _, [] -> l1
	251	\| ((x1, y1) as xy1) :: t1, ((x2, y2) as xy2) :: t2 ->
	252	if x1 <? x2 then xy1 :: combine_list op z t1 l2
	253	else if x2 <? x1 then xy2 :: combine_list op z l1 t2
	254	else
	255	let y = op y1 y2 and l = combine_list op z t1 t2 in
	256	if z y then l else (x1, y) :: l
	257	in
	258	let ( \|-> ) x y =
273	259	let k = Hashtbl.hash x in
274	260	let rec upd t =
275	261	match t with
276		Empty -> Leaf (k,[x,y])
277		\| Leaf(h,l) ->
278		if h = k then Leaf(h,define_list (x,y) l)
279		else newbranch h t k (Leaf(k,[x,y]))
280		\| Branch(p,b,l,r) ->
281		if k land (b - 1) <> p then newbranch p t k (Leaf(k,[x,y]))
282		else if k land b = 0 then Branch(p,b,upd l,r)
283		else Branch(p,b,l,upd r) in
284		upd in
	262	\| Empty -> Leaf (k, [(x, y)])
	263	\| Leaf (h, l) ->
	264	if h = k then Leaf (h, define_list (x, y) l)
	265	else newbranch h t k (Leaf (k, [(x, y)]))
	266	\| Branch (p, b, l, r) ->
	267	if k land (b - 1) <> p then newbranch p t k (Leaf (k, [(x, y)]))
	268	else if k land b = 0 then Branch (p, b, upd l, r)
	269	else Branch (p, b, l, upd r)
	270	in
	271	upd
	272	in
285	273	let rec combine op z t1 t2 =
286		match (t1,t2) with
287		Empty,_ -> t2
288		\| _,Empty -> t1
289		\| Leaf(h1,l1),Leaf(h2,l2) ->
290		if h1 = h2 then
291		let l = combine_list op z l1 l2 in
292		if l = [] then Empty else Leaf(h1,l)
293		else newbranch h1 t1 h2 t2
294		\| (Leaf(k,lis) as lf),(Branch(p,b,l,r) as br) \|
295		(Branch(p,b,l,r) as br),(Leaf(k,lis) as lf) ->
296		if k land (b - 1) = p then
297		if k land b = 0 then
298		let l' = combine op z lf l in
299		if is_undefined l' then r else Branch(p,b,l',r)
300		else
301		let r' = combine op z lf r in
302		if is_undefined r' then l else Branch(p,b,l,r')
303		else
304		newbranch k lf p br
305		\| Branch(p1,b1,l1,r1),Branch(p2,b2,l2,r2) ->
306		if b1 < b2 then
307		if p2 land (b1 - 1) <> p1 then newbranch p1 t1 p2 t2
308		else if p2 land b1 = 0 then
309		let l = combine op z l1 t2 in
310		if is_undefined l then r1 else Branch(p1,b1,l,r1)
311		else
312		let r = combine op z r1 t2 in
313		if is_undefined r then l1 else Branch(p1,b1,l1,r)
314		else if b2 < b1 then
315		if p1 land (b2 - 1) <> p2 then newbranch p1 t1 p2 t2
316		else if p1 land b2 = 0 then
317		let l = combine op z t1 l2 in
318		if is_undefined l then r2 else Branch(p2,b2,l,r2)
319		else
320		let r = combine op z t1 r2 in
321		if is_undefined r then l2 else Branch(p2,b2,l2,r)
322		else if p1 = p2 then
323		let l = combine op z l1 l2 and r = combine op z r1 r2 in
324		if is_undefined l then r
325		else if is_undefined r then l else Branch(p1,b1,l,r)
326		else
327		newbranch p1 t1 p2 t2 in
328		(\|->),combine;;
	274	match (t1, t2) with
	275	\| Empty, _ -> t2
	276	\| _, Empty -> t1
	277	\| Leaf (h1, l1), Leaf (h2, l2) ->
	278	if h1 = h2 then
	279	let l = combine_list op z l1 l2 in
	280	if l = [] then Empty else Leaf (h1, l)
	281	else newbranch h1 t1 h2 t2
	282	\| (Leaf (k, lis) as lf), (Branch (p, b, l, r) as br)
	283	\|(Branch (p, b, l, r) as br), (Leaf (k, lis) as lf) ->
	284	if k land (b - 1) = p then
	285	if k land b = 0 then
	286	let l' = combine op z lf l in
	287	if is_undefined l' then r else Branch (p, b, l', r)
	288	else
	289	let r' = combine op z lf r in
	290	if is_undefined r' then l else Branch (p, b, l, r')
	291	else newbranch k lf p br
	292	\| Branch (p1, b1, l1, r1), Branch (p2, b2, l2, r2) ->
	293	if b1 < b2 then
	294	if p2 land (b1 - 1) <> p1 then newbranch p1 t1 p2 t2
	295	else if p2 land b1 = 0 then
	296	let l = combine op z l1 t2 in
	297	if is_undefined l then r1 else Branch (p1, b1, l, r1)
	298	else
	299	let r = combine op z r1 t2 in
	300	if is_undefined r then l1 else Branch (p1, b1, l1, r)
	301	else if b2 < b1 then
	302	if p1 land (b2 - 1) <> p2 then newbranch p1 t1 p2 t2
	303	else if p1 land b2 = 0 then
	304	let l = combine op z t1 l2 in
	305	if is_undefined l then r2 else Branch (p2, b2, l, r2)
	306	else
	307	let r = combine op z t1 r2 in
	308	if is_undefined r then l2 else Branch (p2, b2, l2, r)
	309	else if p1 = p2 then
	310	let l = combine op z l1 l2 and r = combine op z r1 r2 in
	311	if is_undefined l then r
	312	else if is_undefined r then l
	313	else Branch (p1, b1, l, r)
	314	else newbranch p1 t1 p2 t2
	315	in
	316	(( \|-> ), combine)
329	317
330	318	(* ------------------------------------------------------------------------- *)
331	319	(* Special case of point function. *)
332	320	(* ------------------------------------------------------------------------- *)
333	321
334		let (\|=>) = fun x y -> (x \|-> y) undefined;;
335
	322	let ( \|=> ) x y = (x \|-> y) undefined
336	323
337	324	(* ------------------------------------------------------------------------- *)
338	325	(* Grab an arbitrary element. *)

340	327
341	328	let rec choose t =
342	329	match t with
343		Empty -> failwith "choose: completely undefined function"
344		\| Leaf(h,l) -> List.hd l
345		\| Branch(b,p,t1,t2) -> choose t1;;
	330	\| Empty -> failwith "choose: completely undefined function"
	331	\| Leaf (h, l) -> List.hd l
	332	\| Branch (b, p, t1, t2) -> choose t1
346	333
347	334	(* ------------------------------------------------------------------------- *)
348	335	(* Application. *)

351	338	let applyd =
352	339	let rec apply_listd l d x =
353	340	match l with
354		(a,b)::t -> if x =? a then b
355		else if x >? a then apply_listd t d x else d x
356		\| [] -> d x in
	341	\| (a, b) :: t ->
	342	if x =? a then b else if x >? a then apply_listd t d x else d x
	343	\| [] -> d x
	344	in
357	345	fun f d x ->
358	346	let k = Hashtbl.hash x in
359	347	let rec look t =
360	348	match t with
361		Leaf(h,l) when h = k -> apply_listd l d x
362		\| Branch(p,b,l,r) -> look (if k land b = 0 then l else r)
363		\| _ -> d x in
364		look f;;
365
366		let apply f = applyd f (fun x -> failwith "apply");;
367
368		let tryapplyd f a d = applyd f (fun x -> d) a;;
	349	\| Leaf (h, l) when h = k -> apply_listd l d x
	350	\| Branch (p, b, l, r) -> look (if k land b = 0 then l else r)
	351	\| _ -> d x
	352	in
	353	look f
	354
	355	let apply f = applyd f (fun x -> failwith "apply")
	356	let tryapplyd f a d = applyd f (fun x -> d) a
369	357
370	358	(* ------------------------------------------------------------------------- *)
371	359	(* Undefinition. *)

374	362	let undefine =
375	363	let rec undefine_list x l =
376	364	match l with
377		(a,b as ab)::t ->
378		if x =? a then t
379		else if x <? a then l else
380		let t' = undefine_list x t in
381		if t' == t then l else ab::t'
382		\| [] -> [] in
	365	\| ((a, b) as ab) :: t ->
	366	if x =? a then t
	367	else if x <? a then l
	368	else
	369	let t' = undefine_list x t in
	370	if t' == t then l else ab :: t'
	371	\| [] -> []
	372	in
383	373	fun x ->
384	374	let k = Hashtbl.hash x in
385	375	let rec und t =
386	376	match t with
387		Leaf(h,l) when h = k ->
388		let l' = undefine_list x l in
	377	\| Leaf (h, l) when h = k ->
	378	let l' = undefine_list x l in
	379	if l' == l then t else if l' = [] then Empty else Leaf (h, l')
	380	\| Branch (p, b, l, r) when k land (b - 1) = p ->
	381	if k land b = 0 then
	382	let l' = und l in
389	383	if l' == l then t
390		else if l' = [] then Empty
391		else Leaf(h,l')
392		\| Branch(p,b,l,r) when k land (b - 1) = p ->
393		if k land b = 0 then
394		let l' = und l in
395		if l' == l then t
396		else if is_undefined l' then r
397		else Branch(p,b,l',r)
398		else
399		let r' = und r in
400		if r' == r then t
401		else if is_undefined r' then l
402		else Branch(p,b,l,r')
403		\| _ -> t in
404		und;;
405
	384	else if is_undefined l' then r
	385	else Branch (p, b, l', r)
	386	else
	387	let r' = und r in
	388	if r' == r then t
	389	else if is_undefined r' then l
	390	else Branch (p, b, l, r')
	391	\| _ -> t
	392	in
	393	und
406	394
407	395	(* ------------------------------------------------------------------------- *)
408	396	(* Mapping to sorted-list representation of the graph, domain and range. *)
409	397	(* ------------------------------------------------------------------------- *)
410	398
411		let graph f = setify (foldl (fun a x y -> (x,y)::a) [] f);;
412
413		let dom f = setify(foldl (fun a x y -> x::a) [] f);;
	399	let graph f = setify (foldl (fun a x y -> (x, y) :: a) [] f)
	400	let dom f = setify (foldl (fun a x y -> x :: a) [] f)
414	401
415	402	(* ------------------------------------------------------------------------- *)
416	403	(* More parser basics. *)
417	404	(* ------------------------------------------------------------------------- *)
418	405
419		exception Noparse;;
420
421
422		let isspace,isnum =
423		let charcode s = Char.code(String.get s 0) in
	406	exception Noparse
	407
	408	let isspace, isnum =
	409	let charcode s = Char.code s.[0] in
424	410	let spaces = " \t\n\r"
425	411	and separators = ",;"
426	412	and brackets = "()[]{}"
427	413	and symbs = "\\!@#$%^&*-+\|\\<=>/?~.:"
428	414	and alphas = "'abcdefghijklmnopqrstuvwxyz_ABCDEFGHIJKLMNOPQRSTUVWXYZ"
429	415	and nums = "0123456789" in
430		let allchars = spaces^separators^brackets^symbs^alphas^nums in
431		let csetsize = List.fold_right ((o) max charcode) (explode allchars) 256 in
	416	let allchars = spaces ^ separators ^ brackets ^ symbs ^ alphas ^ nums in
	417	let csetsize = List.fold_right (o max charcode) (explode allchars) 256 in
432	418	let ctable = Array.make csetsize 0 in
433		do_list (fun c -> Array.set ctable (charcode c) 1) (explode spaces);
434		do_list (fun c -> Array.set ctable (charcode c) 2) (explode separators);
435		do_list (fun c -> Array.set ctable (charcode c) 4) (explode brackets);
436		do_list (fun c -> Array.set ctable (charcode c) 8) (explode symbs);
437		do_list (fun c -> Array.set ctable (charcode c) 16) (explode alphas);
438		do_list (fun c -> Array.set ctable (charcode c) 32) (explode nums);
439		let isspace c = Array.get ctable (charcode c) = 1
440		and isnum c = Array.get ctable (charcode c) = 32 in
441		isspace,isnum;;
	419	do_list (fun c -> ctable.(charcode c) <- 1) (explode spaces);
	420	do_list (fun c -> ctable.(charcode c) <- 2) (explode separators);
	421	do_list (fun c -> ctable.(charcode c) <- 4) (explode brackets);
	422	do_list (fun c -> ctable.(charcode c) <- 8) (explode symbs);
	423	do_list (fun c -> ctable.(charcode c) <- 16) (explode alphas);
	424	do_list (fun c -> ctable.(charcode c) <- 32) (explode nums);
	425	let isspace c = ctable.(charcode c) = 1
	426	and isnum c = ctable.(charcode c) = 32 in
	427	(isspace, isnum)
442	428
443	429	let parser_or parser1 parser2 input =
444		try parser1 input
445		with Noparse -> parser2 input;;
446
447		let (++) parser1 parser2 input =
448		let result1,rest1 = parser1 input in
449		let result2,rest2 = parser2 rest1 in
450		(result1,result2),rest2;;
	430	try parser1 input with Noparse -> parser2 input
	431
	432	let ( ++ ) parser1 parser2 input =
	433	let result1, rest1 = parser1 input in
	434	let result2, rest2 = parser2 rest1 in
	435	((result1, result2), rest2)
451	436
452	437	let rec many prs input =
453		try let result,next = prs input in
454		let results,rest = many prs next in
455		(result::results),rest
456		with Noparse -> [],input;;
457
458		let (>>) prs treatment input =
459		let result,rest = prs input in
460		treatment(result),rest;;
	438	try
	439	let result, next = prs input in
	440	let results, rest = many prs next in
	441	(result :: results, rest)
	442	with Noparse -> ([], input)
	443
	444	let ( >> ) prs treatment input =
	445	let result, rest = prs input in
	446	(treatment result, rest)
461	447
462	448	let fix err prs input =
463		try prs input
464		with Noparse -> failwith (err ^ " expected");;
	449	try prs input with Noparse -> failwith (err ^ " expected")
465	450
466	451	let listof prs sep err =
467		prs ++ many (sep ++ fix err prs >> snd) >> (fun (h,t) -> h::t);;
	452	prs ++ many (sep ++ fix err prs >> snd) >> fun (h, t) -> h :: t
468	453
469	454	let possibly prs input =
470		try let x,rest = prs input in [x],rest
471		with Noparse -> [],input;;
472
473		let some p =
474		function
475		[] -> raise Noparse
476		\| (h::t) -> if p h then (h,t) else raise Noparse;;
477
478		let a tok = some (fun item -> item = tok);;
	455	try
	456	let x, rest = prs input in
	457	([x], rest)
	458	with Noparse -> ([], input)
	459
	460	let some p = function
	461	\| [] -> raise Noparse
	462	\| h :: t -> if p h then (h, t) else raise Noparse
	463
	464	let a tok = some (fun item -> item = tok)
479	465
480	466	let rec atleast n prs i =
481		(if n <= 0 then many prs
482		else prs ++ atleast (n - 1) prs >> (fun (h,t) -> h::t)) i;;
483
484		(* ------------------------------------------------------------------------- *)
485
486		let temp_path = Filename.get_temp_dir_name ();;
	467	( if n <= 0 then many prs
	468	else prs ++ atleast (n - 1) prs >> fun (h, t) -> h :: t )
	469	i
	470
	471	(* ------------------------------------------------------------------------- *)
	472
	473	let temp_path = Filename.get_temp_dir_name ()
487	474
488	475	(* ------------------------------------------------------------------------- *)
489	476	(* Convenient conversion between files and (lists of) strings. *)
490	477	(* ------------------------------------------------------------------------- *)
491	478
492	479	let strings_of_file filename =
493		let fd = try open_in filename
494		with Sys_error _ ->
495		failwith("strings_of_file: can't open "^filename) in
	480	let fd =
	481	try open_in filename
	482	with Sys_error _ -> failwith ("strings_of_file: can't open " ^ filename)
	483	in
496	484	let rec suck_lines acc =
497		try let l = input_line fd in
498		suck_lines (l::acc)
499		with End_of_file -> List.rev acc in
	485	try
	486	let l = input_line fd in
	487	suck_lines (l :: acc)
	488	with End_of_file -> List.rev acc
	489	in
500	490	let data = suck_lines [] in
501		(close_in fd; data);;
502
503		let string_of_file filename =
504		String.concat "\n" (strings_of_file filename);;
	491	close_in fd; data
	492
	493	let string_of_file filename = String.concat "\n" (strings_of_file filename)
505	494
506	495	let file_of_string filename s =
507	496	let fd = open_out filename in
508		output_string fd s; close_out fd;;
509
	497	output_string fd s; close_out fd
510	498
511	499	(* ------------------------------------------------------------------------- *)
512	500	(* Iterative deepening. *)
513	501	(* ------------------------------------------------------------------------- *)
514	502
515	503	let rec deepen f n =
516		try (*print_string "Searching with depth limit ";
517		print_int n; print_newline();*) f n
518		with Failure _ -> deepen f (n + 1);;
	504	try
	505	(*print_string "Searching with depth limit ";
	506	print_int n; print_newline();*)
	507	f n
	508	with Failure _ -> deepen f (n + 1)
519	509
520	510	exception TooDeep
521	511
522	512	let deepen_until limit f n =
523	513	match compare limit 0 with
524		\| 0 -> raise TooDeep
525		\| -1 -> deepen f n
526		\| _ ->
527		let rec d_until f n =
528		try(* if !debugging
	514	\| 0 -> raise TooDeep
	515	\| -1 -> deepen f n
	516	\| _ ->
	517	let rec d_until f n =
	518	try
	519	(* if !debugging
529	520	then (print_string "Searching with depth limit ";
530		print_int n; print_newline()) ;*) f n
531		with Failure x ->
532		(if !debugging then (Printf.printf "solver error : %s\n" x) ; )
533		if n = limit then raise TooDeep else d_until f (n + 1) in
534		d_until f n
	521	print_int n; print_newline()) ;*)
	522	f n
	523	with Failure x ->
	524	(if !debugging then (Printf.printf "solver error : %s\n" x) ; )
	525	if n = limit then raise TooDeep else d_until f (n + 1)
	526	in
	527	d_until f n

+17

-22

plugins/micromega/sos_lib.mli less more

8	8	(************************************************************************)
9	9
10	10	val o : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b
11
12	11	val num_1 : Num.num
13	12	val pow10 : int -> Num.num
14	13	val pow2 : int -> Num.num
15
16	14	val implode : string list -> string
17	15	val explode : string -> string list
18
19	16	val funpow : int -> ('a -> 'a) -> 'a -> 'a
20	17	val tryfind : ('a -> 'b) -> 'a list -> 'b
21	18
22		type ('a,'b) func =
23		\| Empty
24		\| Leaf of int * ('a*'b) list
25		\| Branch of int * int * ('a,'b) func * ('a,'b) func
	19	type ('a, 'b) func =
	20	\| Empty
	21	\| Leaf of int * ('a * 'b) list
	22	\| Branch of int * int * ('a, 'b) func * ('a, 'b) func
26	23
27	24	val undefined : ('a, 'b) func
28	25	val is_undefined : ('a, 'b) func -> bool
29		val (\|->) : 'a -> 'b -> ('a, 'b) func -> ('a, 'b) func
30		val (\|=>) : 'a -> 'b -> ('a, 'b) func
	26	val ( \|-> ) : 'a -> 'b -> ('a, 'b) func -> ('a, 'b) func
	27	val ( \|=> ) : 'a -> 'b -> ('a, 'b) func
31	28	val choose : ('a, 'b) func -> 'a * 'b
32		val combine : ('a -> 'a -> 'a) -> ('a -> bool) -> ('b, 'a) func -> ('b, 'a) func -> ('b, 'a) func
33		val (--) : int -> int -> int list
34	29
	30	val combine :
	31	('a -> 'a -> 'a)
	32	-> ('a -> bool)
	33	-> ('b, 'a) func
	34	-> ('b, 'a) func
	35	-> ('b, 'a) func
	36
	37	val ( -- ) : int -> int -> int list
35	38	val tryapplyd : ('a, 'b) func -> 'a -> 'b -> 'b
36	39	val apply : ('a, 'b) func -> 'a -> 'b
37
38	40	val foldl : ('a -> 'b -> 'c -> 'a) -> 'a -> ('b, 'c) func -> 'a
39	41	val foldr : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) func -> 'c -> 'c
40	42	val mapf : ('a -> 'b) -> ('c, 'a) func -> ('c, 'b) func
41
42	43	val undefine : 'a -> ('a, 'b) func -> ('a, 'b) func
43
44	44	val dom : ('a, 'b) func -> 'a list
45	45	val graph : ('a, 'b) func -> ('a * 'b) list
46
47	46	val union : 'a list -> 'a list -> 'a list
48	47	val subtract : 'a list -> 'a list -> 'a list
49	48	val sort : ('a -> 'a -> bool) -> 'a list -> 'a list
50	49	val setify : 'a list -> 'a list
51	50	val increasing : ('a -> 'b) -> 'a -> 'a -> bool
52	51	val allpairs : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
53
54	52	val gcd_num : Num.num -> Num.num -> Num.num
55	53	val lcm_num : Num.num -> Num.num -> Num.num
56	54	val numerator : Num.num -> Num.num
57	55	val denominator : Num.num -> Num.num
58	56	val end_itlist : ('a -> 'a -> 'a) -> 'a list -> 'a
59
60		val (>>) : ('a -> 'b * 'c) -> ('b -> 'd) -> 'a -> 'd * 'c
61		val (++) : ('a -> 'b * 'c) -> ('c -> 'd * 'e) -> 'a -> ('b * 'd) * 'e
62
	57	val ( >> ) : ('a -> 'b * 'c) -> ('b -> 'd) -> 'a -> 'd * 'c
	58	val ( ++ ) : ('a -> 'b * 'c) -> ('c -> 'd * 'e) -> 'a -> ('b * 'd) * 'e
63	59	val a : 'a -> 'a list -> 'a * 'a list
64	60	val many : ('a -> 'b * 'a) -> 'a -> 'b list * 'a
65	61	val some : ('a -> bool) -> 'a list -> 'a * 'a list

69	65	val isnum : string -> bool
70	66	val atleast : int -> ('a -> 'b * 'a) -> 'a -> 'b list * 'a
71	67	val listof : ('a -> 'b * 'c) -> ('c -> 'd * 'a) -> string -> 'a -> 'b list * 'c
72
73	68	val temp_path : string
74	69	val string_of_file : string -> string
75	70	val file_of_string : string -> string -> unit
	71	val deepen_until : int -> (int -> 'a) -> int -> 'a
76	72
77		val deepen_until : int -> (int -> 'a) -> int -> 'a
78	73	exception TooDeep

+37

-37

plugins/micromega/sos_types.ml less more

13	13	type vname = string
14	14
15	15	type term =
16		\| Zero
17		\| Const of Num.num
18		\| Var of vname
19		\| Opp of term
20		\| Add of (term * term)
21		\| Sub of (term * term)
22		\| Mul of (term * term)
23		\| Pow of (term * int)
24
	16	\| Zero
	17	\| Const of Num.num
	18	\| Var of vname
	19	\| Opp of term
	20	\| Add of (term * term)
	21	\| Sub of (term * term)
	22	\| Mul of (term * term)
	23	\| Pow of (term * int)
25	24
26	25	let rec output_term o t =
27	26	match t with
28		\| Zero -> output_string o "0"
29		\| Const n -> output_string o (string_of_num n)
30		\| Var n -> Printf.fprintf o "v%s" n
31		\| Opp t -> Printf.fprintf o "- (%a)" output_term t
32		\| Add(t1,t2) -> Printf.fprintf o "(%a)+(%a)" output_term t1 output_term t2
33		\| Sub(t1,t2) -> Printf.fprintf o "(%a)-(%a)" output_term t1 output_term t2
34		\| Mul(t1,t2) -> Printf.fprintf o "(%a)*(%a)" output_term t1 output_term t2
35		\| Pow(t1,i) -> Printf.fprintf o "(%a)^(%i)" output_term t1 i
	27	\| Zero -> output_string o "0"
	28	\| Const n -> output_string o (string_of_num n)
	29	\| Var n -> Printf.fprintf o "v%s" n
	30	\| Opp t -> Printf.fprintf o "- (%a)" output_term t
	31	\| Add (t1, t2) -> Printf.fprintf o "(%a)+(%a)" output_term t1 output_term t2
	32	\| Sub (t1, t2) -> Printf.fprintf o "(%a)-(%a)" output_term t1 output_term t2
	33	\| Mul (t1, t2) -> Printf.fprintf o "(%a)*(%a)" output_term t1 output_term t2
	34	\| Pow (t1, i) -> Printf.fprintf o "(%a)^(%i)" output_term t1 i
	35
36	36	(* ------------------------------------------------------------------------- *)
37	37	(* Data structure for Positivstellensatz refutations. *)
38	38	(* ------------------------------------------------------------------------- *)
39	39
40	40	type positivstellensatz =
41		Axiom_eq of int
42		\| Axiom_le of int
43		\| Axiom_lt of int
44		\| Rational_eq of num
45		\| Rational_le of num
46		\| Rational_lt of num
47		\| Square of term
48		\| Monoid of int list
49		\| Eqmul of term * positivstellensatz
50		\| Sum of positivstellensatz * positivstellensatz
51		\| Product of positivstellensatz * positivstellensatz;;
52
	41	\| Axiom_eq of int
	42	\| Axiom_le of int
	43	\| Axiom_lt of int
	44	\| Rational_eq of num
	45	\| Rational_le of num
	46	\| Rational_lt of num
	47	\| Square of term
	48	\| Monoid of int list
	49	\| Eqmul of term * positivstellensatz
	50	\| Sum of positivstellensatz * positivstellensatz
	51	\| Product of positivstellensatz * positivstellensatz
53	52
54	53	let rec output_psatz o = function
55	54	\| Axiom_eq i -> Printf.fprintf o "Aeq(%i)" i
56	55	\| Axiom_le i -> Printf.fprintf o "Ale(%i)" i
57	56	\| Axiom_lt i -> Printf.fprintf o "Alt(%i)" i
58		\| Rational_eq n -> Printf.fprintf o "eq(%s)" (string_of_num n)
59		\| Rational_le n -> Printf.fprintf o "le(%s)" (string_of_num n)
60		\| Rational_lt n -> Printf.fprintf o "lt(%s)" (string_of_num n)
61		\| Square t -> Printf.fprintf o "(%a)^2" output_term t
62		\| Monoid l -> Printf.fprintf o "monoid"
63		\| Eqmul (t,ps) -> Printf.fprintf o "%a * %a" output_term t output_psatz ps
64		\| Sum (t1,t2) -> Printf.fprintf o "%a + %a" output_psatz t1 output_psatz t2
65		\| Product (t1,t2) -> Printf.fprintf o "%a * %a" output_psatz t1 output_psatz t2
	57	\| Rational_eq n -> Printf.fprintf o "eq(%s)" (string_of_num n)
	58	\| Rational_le n -> Printf.fprintf o "le(%s)" (string_of_num n)
	59	\| Rational_lt n -> Printf.fprintf o "lt(%s)" (string_of_num n)
	60	\| Square t -> Printf.fprintf o "(%a)^2" output_term t
	61	\| Monoid l -> Printf.fprintf o "monoid"
	62	\| Eqmul (t, ps) -> Printf.fprintf o "%a * %a" output_term t output_psatz ps
	63	\| Sum (t1, t2) -> Printf.fprintf o "%a + %a" output_psatz t1 output_psatz t2
	64	\| Product (t1, t2) ->
	65	Printf.fprintf o "%a * %a" output_psatz t1 output_psatz t2

+19

-19

plugins/micromega/sos_types.mli less more

12	12	type vname = string
13	13
14	14	type term =
15		\| Zero
16		\| Const of Num.num
17		\| Var of vname
18		\| Opp of term
19		\| Add of (term * term)
20		\| Sub of (term * term)
21		\| Mul of (term * term)
22		\| Pow of (term * int)
	15	\| Zero
	16	\| Const of Num.num
	17	\| Var of vname
	18	\| Opp of term
	19	\| Add of (term * term)
	20	\| Sub of (term * term)
	21	\| Mul of (term * term)
	22	\| Pow of (term * int)
23	23
24	24	val output_term : out_channel -> term -> unit
25	25
26	26	type positivstellensatz =
27		Axiom_eq of int
28		\| Axiom_le of int
29		\| Axiom_lt of int
30		\| Rational_eq of Num.num
31		\| Rational_le of Num.num
32		\| Rational_lt of Num.num
33		\| Square of term
34		\| Monoid of int list
35		\| Eqmul of term * positivstellensatz
36		\| Sum of positivstellensatz * positivstellensatz
37		\| Product of positivstellensatz * positivstellensatz
	27	\| Axiom_eq of int
	28	\| Axiom_le of int
	29	\| Axiom_lt of int
	30	\| Rational_eq of Num.num
	31	\| Rational_le of Num.num
	32	\| Rational_lt of Num.num
	33	\| Square of term
	34	\| Monoid of int list
	35	\| Eqmul of term * positivstellensatz
	36	\| Sum of positivstellensatz * positivstellensatz
	37	\| Product of positivstellensatz * positivstellensatz
38	38
39	39	val output_psatz : out_channel -> positivstellensatz -> unit

+175

-220

plugins/micromega/vect.ml less more

10	10	open Num
11	11	open Mutils
12	12
	13	type var = int
13	14	(** [t] is the type of vectors.
14	15	A vector [(x1,v1) ; ... ; (xn,vn)] is such that:
15	16	- variables indexes are ordered (x1 < ... < xn
16	17	- values are all non-zero
17	18	*)
18		type var = int
	19
19	20	type t = (var * num) list
	21	type vector = t
20	22
21	23	(** [equal v1 v2 = true] if the vectors are syntactically equal. *)
22	24
23	25	let rec equal v1 v2 =
24		match v1 , v2 with
25		\| [] , [] -> true
26		\| [] , _ -> false
27		\| _::_ , [] -> false
28		\| (i1,n1)::v1 , (i2,n2)::v2 ->
29		(Int.equal i1 i2) && n1 =/ n2 && equal v1 v2
	26	match (v1, v2) with
	27	\| [], [] -> true
	28	\| [], _ -> false
	29	\| _ :: _, [] -> false
	30	\| (i1, n1) :: v1, (i2, n2) :: v2 -> Int.equal i1 i2 && n1 =/ n2 && equal v1 v2
30	31
31	32	let hash v =
32	33	let rec hash i = function
33	34	\| [] -> i
34		\| (vr,vl)::l -> hash (i + (Hashtbl.hash (vr, float_of_num vl))) l in
35		Hashtbl.hash (hash 0 v )
36
	35	\| (vr, vl) :: l -> hash (i + Hashtbl.hash (vr, float_of_num vl)) l
	36	in
	37	Hashtbl.hash (hash 0 v)
37	38
38	39	let null = []
39
40		let is_null v =
41		match v with
42		\| [] \| [0,Int 0] -> true
43		\| _ -> false
44
45		let pp_var_num pp_var o (v,n) =
46		if Int.equal v 0
47		then if eq_num (Int 0) n then ()
48		else Printf.fprintf o "%s" (string_of_num n)
	40	let is_null v = match v with [] \| [(0, Int 0)] -> true \| _ -> false
	41
	42	let pp_var_num pp_var o (v, n) =
	43	if Int.equal v 0 then
	44	if eq_num (Int 0) n then () else Printf.fprintf o "%s" (string_of_num n)
49	45	else
50	46	match n with
51		\| Int 1 -> pp_var o v
	47	\| Int 1 -> pp_var o v
52	48	\| Int -1 -> Printf.fprintf o "-%a" pp_var v
53		\| Int 0 -> ()
54		\| _ -> Printf.fprintf o "%s*%a" (string_of_num n) pp_var v
55
56		let pp_var_num_smt pp_var o (v,n) =
57		if Int.equal v 0
58		then if eq_num (Int 0) n then ()
59		else Printf.fprintf o "%s" (string_of_num n)
	49	\| Int 0 -> ()
	50	\| _ -> Printf.fprintf o "%s*%a" (string_of_num n) pp_var v
	51
	52	let pp_var_num_smt pp_var o (v, n) =
	53	if Int.equal v 0 then
	54	if eq_num (Int 0) n then () else Printf.fprintf o "%s" (string_of_num n)
60	55	else
61	56	match n with
62		\| Int 1 -> pp_var o v
	57	\| Int 1 -> pp_var o v
63	58	\| Int -1 -> Printf.fprintf o "(- %a)" pp_var v
64		\| Int 0 -> ()
65		\| _ -> Printf.fprintf o "(* %s %a)" (string_of_num n) pp_var v
66
	59	\| Int 0 -> ()
	60	\| _ -> Printf.fprintf o "(* %s %a)" (string_of_num n) pp_var v
67	61
68	62	let rec pp_gen pp_var o v =
69	63	match v with
70	64	\| [] -> output_string o "0"
71	65	\| [e] -> pp_var_num pp_var o e
72		\| e::l -> Printf.fprintf o "%a + %a" (pp_var_num pp_var) e (pp_gen pp_var) l
73
	66	\| e :: l -> Printf.fprintf o "%a + %a" (pp_var_num pp_var) e (pp_gen pp_var) l
74	67
75	68	let pp_var o v = Printf.fprintf o "x%i" v
76
77	69	let pp o v = pp_gen pp_var o v
78	70
79		let pp_smt o v =
80		let list o v = List.iter (fun e -> Printf.fprintf o "%a " (pp_var_num_smt pp_var) e) v in
	71	let pp_smt o v =
	72	let list o v =
	73	List.iter (fun e -> Printf.fprintf o "%a " (pp_var_num_smt pp_var) e) v
	74	in
81	75	Printf.fprintf o "(+ %a)" list v
82	76
83		let from_list (l: num list) =
	77	let from_list (l : num list) =
84	78	let rec xfrom_list i l =
85	79	match l with
86	80	\| [] -> []
87		\| e::l ->
88		if e <>/ Int 0
89		then (i,e)::(xfrom_list (i+1) l)
90		else xfrom_list (i+1) l in
91
	81	\| e :: l ->
	82	if e <>/ Int 0 then (i, e) :: xfrom_list (i + 1) l
	83	else xfrom_list (i + 1) l
	84	in
92	85	xfrom_list 0 l
93	86
94	87	let zero_num = Int 0
95
96	88
97	89	let to_list m =
98	90	let rec xto_list i l =
99	91	match l with
100	92	\| [] -> []
101		\| (x,v)::l' ->
102		if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in
	93	\| (x, v) :: l' ->
	94	if i = x then v :: xto_list (i + 1) l' else zero_num :: xto_list (i + 1) l
	95	in
103	96	xto_list 0 m
104	97
105
106		let cons i v rst = if v =/ Int 0 then rst else (i,v)::rst
	98	let cons i v rst = if v =/ Int 0 then rst else (i, v) :: rst
107	99
108	100	let rec update i f t =
109	101	match t with
110	102	\| [] -> cons i (f zero_num) []
111		\| (k,v)::l ->
112		match Int.compare i k with
113		\| 0 -> cons k (f v) l
114		\| -1 -> cons i (f zero_num) t
115		\| 1 -> (k,v) ::(update i f l)
116		\| _ -> failwith "compare_num"
	103	\| (k, v) :: l -> (
	104	match Int.compare i k with
	105	\| 0 -> cons k (f v) l
	106	\| -1 -> cons i (f zero_num) t
	107	\| 1 -> (k, v) :: update i f l
	108	\| _ -> failwith "compare_num" )
117	109
118	110	let rec set i n t =
119	111	match t with
120	112	\| [] -> cons i n []
121		\| (k,v)::l ->
122		match Int.compare i k with
123		\| 0 -> cons k n l
124		\| -1 -> cons i n t
125		\| 1 -> (k,v) :: (set i n l)
126		\| _ -> failwith "compare_num"
127
128		let cst n = if n =/ Int 0 then [] else [0,n]
129
	113	\| (k, v) :: l -> (
	114	match Int.compare i k with
	115	\| 0 -> cons k n l
	116	\| -1 -> cons i n t
	117	\| 1 -> (k, v) :: set i n l
	118	\| _ -> failwith "compare_num" )
	119
	120	let cst n = if n =/ Int 0 then [] else [(0, n)]
130	121
131	122	let mul z t =
132	123	match z with
133	124	\| Int 0 -> []
134	125	\| Int 1 -> t
135		\| _ -> List.map (fun (i,n) -> (i, mult_num z n)) t
	126	\| _ -> List.map (fun (i, n) -> (i, mult_num z n)) t
136	127
137	128	let div z t =
138		if z <>/ Int 1
139		then List.map (fun (x,nx) -> (x,nx // z)) t
140		else t
141
142
143		let uminus t = List.map (fun (i,n) -> i, minus_num n) t
144
145
146		let rec add (ve1:t) (ve2:t) =
147		match ve1 , ve2 with
148		\| [] , v \| v , [] -> v
149		\| (v1,c1)::l1 , (v2,c2)::l2 ->
150		let cmp = Util.pervasives_compare v1 v2 in
151		if cmp == 0 then
152		let s = add_num c1 c2 in
153		if eq_num (Int 0) s
154		then add l1 l2
155		else (v1,s)::(add l1 l2)
156		else if cmp < 0 then (v1,c1) :: (add l1 ve2)
157		else (v2,c2) :: (add l2 ve1)
158
159
160		let rec xmul_add (n1:num) (ve1:t) (n2:num) (ve2:t) =
161		match ve1 , ve2 with
162		\| [] , _ -> mul n2 ve2
163		\| _ , [] -> mul n1 ve1
164		\| (v1,c1)::l1 , (v2,c2)::l2 ->
165		let cmp = Util.pervasives_compare v1 v2 in
166		if cmp == 0 then
167		let s = ( n1 / c1) +/ (n2 / c2) in
168		if eq_num (Int 0) s
169		then xmul_add n1 l1 n2 l2
170		else (v1,s)::(xmul_add n1 l1 n2 l2)
171		else if cmp < 0 then (v1,n1 */ c1) :: (xmul_add n1 l1 n2 ve2)
172		else (v2,n2 */c2) :: (xmul_add n1 ve1 n2 l2)
	129	if z <>/ Int 1 then List.map (fun (x, nx) -> (x, nx // z)) t else t
	130
	131	let uminus t = List.map (fun (i, n) -> (i, minus_num n)) t
	132
	133	let rec add (ve1 : t) (ve2 : t) =
	134	match (ve1, ve2) with
	135	\| [], v \| v, [] -> v
	136	\| (v1, c1) :: l1, (v2, c2) :: l2 ->
	137	let cmp = Int.compare v1 v2 in
	138	if cmp == 0 then
	139	let s = add_num c1 c2 in
	140	if eq_num (Int 0) s then add l1 l2 else (v1, s) :: add l1 l2
	141	else if cmp < 0 then (v1, c1) :: add l1 ve2
	142	else (v2, c2) :: add l2 ve1
	143
	144	let rec xmul_add (n1 : num) (ve1 : t) (n2 : num) (ve2 : t) =
	145	match (ve1, ve2) with
	146	\| [], _ -> mul n2 ve2
	147	\| _, [] -> mul n1 ve1
	148	\| (v1, c1) :: l1, (v2, c2) :: l2 ->
	149	let cmp = Int.compare v1 v2 in
	150	if cmp == 0 then
	151	let s = (n1 / c1) +/ (n2 / c2) in
	152	if eq_num (Int 0) s then xmul_add n1 l1 n2 l2
	153	else (v1, s) :: xmul_add n1 l1 n2 l2
	154	else if cmp < 0 then (v1, n1 */ c1) :: xmul_add n1 l1 n2 ve2
	155	else (v2, n2 */ c2) :: xmul_add n1 ve1 n2 l2
173	156
174	157	let mul_add n1 ve1 n2 ve2 =
175		if n1 =/ Int 1 && n2 =/ Int 1
176		then add ve1 ve2
177		else xmul_add n1 ve1 n2 ve2
178
179
180		let compare : t -> t -> int = Mutils.Cmp.compare_list (fun x y -> Mutils.Cmp.compare_lexical
181		[
182		(fun () -> Int.compare (fst x) (fst y));
183		(fun () -> compare_num (snd x) (snd y))])
	158	if n1 =/ Int 1 && n2 =/ Int 1 then add ve1 ve2 else xmul_add n1 ve1 n2 ve2
	159
	160	let compare : t -> t -> int =
	161	Mutils.Cmp.compare_list (fun x y ->
	162	Mutils.Cmp.compare_lexical
	163	[ (fun () -> Int.compare (fst x) (fst y))
	164	; (fun () -> compare_num (snd x) (snd y)) ])
184	165
185	166	(** [tail v vect] returns
186	167	- [None] if [v] is not a variable of the vector [vect]

188	169	and [rst] is the remaining of the vector
189	170	We exploit that vectors are ordered lists
190	171	*)
191		let rec tail (v:var) (vect:t) =
	172	let rec tail (v : var) (vect : t) =
192	173	match vect with
193	174	\| [] -> None
194		\| (v',vl)::vect' ->
195		match Int.compare v' v with
196		\| 0 -> Some (vl,vect) (* Ok, found *)
197		\| -1 -> tail v vect' (* Might be in the tail *)
198		\| _ -> None (* Hopeless *)
199
200		let get v vect =
201		match tail v vect with
202		\| None -> Int 0
203		\| Some(vl,_) -> vl
204
205		let is_constant v =
206		match v with
207		\| [] \| [0,_] -> true
208		\| _ -> false
209
210
211
212		let get_cst vect =
213		match vect with
214		\| (0,v)::_ -> v
215		\| _ -> Int 0
216
217		let choose v =
218		match v with
219		\| [] -> None
220		\| (vr,vl)::rst -> Some (vr,vl,rst)
221
222
223		let rec fresh v =
224		match v with
225		\| [] -> 1
226		\| [v,_] -> v + 1
227		\| _::v -> fresh v
228
229
230		let variables v =
231		List.fold_left (fun acc (x,_) -> ISet.add x acc) ISet.empty v
232
233		let decomp_cst v =
234		match v with
235		\| (0,vl)::v -> vl,v
236		\| _ -> Int 0,v
	175	\| (v', vl) :: vect' -> (
	176	match Int.compare v' v with
	177	\| 0 -> Some (vl, vect) (* Ok, found *)
	178	\| -1 -> tail v vect' (* Might be in the tail *)
	179	\| _ -> None )
	180
	181	(* Hopeless *)
	182
	183	let get v vect = match tail v vect with None -> Int 0 \| Some (vl, _) -> vl
	184	let is_constant v = match v with [] \| [(0, _)] -> true \| _ -> false
	185	let get_cst vect = match vect with (0, v) :: _ -> v \| _ -> Int 0
	186	let choose v = match v with [] -> None \| (vr, vl) :: rst -> Some (vr, vl, rst)
	187	let rec fresh v = match v with [] -> 1 \| [(v, _)] -> v + 1 \| _ :: v -> fresh v
	188	let variables v = List.fold_left (fun acc (x, _) -> ISet.add x acc) ISet.empty v
	189	let decomp_cst v = match v with (0, vl) :: v -> (vl, v) \| _ -> (Int 0, v)
237	190
238	191	let rec decomp_at i v =
239	192	match v with
240		\| [] -> (Int 0 , null)
241		\| (vr,vl)::r -> if i = vr then (vl,r)
242		else if i < vr then (Int 0,v)
243		else decomp_at i r
244
245		let decomp_fst v =
246		match v with
247		\| [] -> ((0,Int 0),[])
248		\| x::v -> (x,v)
249
250
251		let fold f acc v =
252		List.fold_left (fun acc (v,i) -> f acc v i) acc v
	193	\| [] -> (Int 0, null)
	194	\| (vr, vl) :: r ->
	195	if i = vr then (vl, r) else if i < vr then (Int 0, v) else decomp_at i r
	196
	197	let decomp_fst v = match v with [] -> ((0, Int 0), []) \| x :: v -> (x, v)
	198
	199	let rec subst (vr : int) (e : t) (v : t) =
	200	match v with
	201	\| [] -> []
	202	\| (x, n) :: v' -> (
	203	match Int.compare vr x with
	204	\| 0 -> mul_add n e (Int 1) v'
	205	\| -1 -> v
	206	\| 1 -> add [(x, n)] (subst vr e v')
	207	\| _ -> assert false )
	208
	209	let fold f acc v = List.fold_left (fun acc (v, i) -> f acc v i) acc v
253	210
254	211	let fold_error f acc v =
255	212	let rec fold acc v =
256	213	match v with
257	214	\| [] -> Some acc
258		\| (x,i)::v' -> match f acc x i with
259		\| None -> None
260		\| Some acc' -> fold acc' v' in
	215	\| (x, i) :: v' -> (
	216	match f acc x i with None -> None \| Some acc' -> fold acc' v' )
	217	in
261	218	fold acc v
262	219
263
264
265	220	let rec find p v =
266	221	match v with
267	222	\| [] -> None
268		\| (v,n)::v' -> match p v n with
269		\| None -> find p v'
270		\| Some r -> Some r
271
272
273		let for_all p l =
274		List.for_all (fun (v,n) -> p v n) l
275
276
277		let decr_var i v = List.map (fun (v,n) -> (v-i,n)) v
278		let incr_var i v = List.map (fun (v,n) -> (v+i,n)) v
	223	\| (v, n) :: v' -> ( match p v n with None -> find p v' \| Some r -> Some r )
	224
	225	let for_all p l = List.for_all (fun (v, n) -> p v n) l
	226	let decr_var i v = List.map (fun (v, n) -> (v - i, n)) v
	227	let incr_var i v = List.map (fun (v, n) -> (v + i, n)) v
279	228
280	229	open Big_int
281	230
282	231	let gcd v =
283		let res = fold (fun c _ n ->
284		assert (Int.equal (compare_big_int (denominator n) unit_big_int) 0);
285		gcd_big_int c (numerator n)) zero_big_int v in
286		if Int.equal (compare_big_int res zero_big_int) 0
287		then unit_big_int else res
	232	let res =
	233	fold
	234	(fun c _ n ->
	235	assert (Int.equal (compare_big_int (denominator n) unit_big_int) 0);
	236	gcd_big_int c (numerator n))
	237	zero_big_int v
	238	in
	239	if Int.equal (compare_big_int res zero_big_int) 0 then unit_big_int else res
288	240
289	241	let normalise v =
290	242	let ppcm = fold (fun c _ n -> ppcm c (denominator n)) unit_big_int v in
291		let gcd =
	243	let gcd =
292	244	let gcd = fold (fun c _ n -> gcd_big_int c (numerator n)) zero_big_int v in
293		if Int.equal (compare_big_int gcd zero_big_int) 0 then unit_big_int else gcd in
294		List.map (fun (x,v) -> (x, v */ (Big_int ppcm) // (Big_int gcd))) v
	245	if Int.equal (compare_big_int gcd zero_big_int) 0 then unit_big_int else gcd
	246	in
	247	List.map (fun (x, v) -> (x, v */ Big_int ppcm // Big_int gcd)) v
295	248
296	249	let rec exists2 p vect1 vect2 =
297		match vect1 , vect2 with
298		\| _ , [] \| [], _ -> None
299		\| (v1,n1)::vect1' , (v2, n2) :: vect2' ->
300		if Int.equal v1 v2
301		then
302		if p n1 n2
303		then Some (v1,n1,n2)
304		else
305		exists2 p vect1' vect2'
306		else
307		if v1 < v2
308		then exists2 p vect1' vect2
309		else exists2 p vect1 vect2'
	250	match (vect1, vect2) with
	251	\| _, [] \| [], _ -> None
	252	\| (v1, n1) :: vect1', (v2, n2) :: vect2' ->
	253	if Int.equal v1 v2 then
	254	if p n1 n2 then Some (v1, n1, n2) else exists2 p vect1' vect2'
	255	else if v1 < v2 then exists2 p vect1' vect2
	256	else exists2 p vect1 vect2'
310	257
311	258	let dotproduct v1 v2 =
312	259	let rec dot acc v1 v2 =
313		match v1, v2 with
314		\| [] , _ \| _ , [] -> acc
315		\| (x1,n1)::v1', (x2,n2)::v2' ->
316		if x1 == x2
317		then dot (acc +/ n1 */ n2) v1' v2'
318		else if x1 < x2
319		then dot acc v1' v2
320		else dot acc v1 v2' in
	260	match (v1, v2) with
	261	\| [], _ \| _, [] -> acc
	262	\| (x1, n1) :: v1', (x2, n2) :: v2' ->
	263	if x1 == x2 then dot (acc +/ (n1 */ n2)) v1' v2'
	264	else if x1 < x2 then dot acc v1' v2
	265	else dot acc v1 v2'
	266	in
321	267	dot (Int 0) v1 v2
322	268
323
324		let map f v = List.map (fun (x,v) -> f x v) v
	269	let map f v = List.map (fun (x, v) -> f x v) v
325	270
326	271	let abs_min_elt v =
327	272	match v with
328	273	\| [] -> None
329		\| (v,vl)::r ->
330		Some (List.fold_left (fun (v1,vl1) (v2,vl2) ->
331		if abs_num vl1 </ abs_num vl2
332		then (v1,vl1) else (v2,vl2) ) (v,vl) r)
333
334
335		let partition p = List.partition (fun (vr,vl) -> p vr vl)
336
	274	\| (v, vl) :: r ->
	275	Some
	276	(List.fold_left
	277	(fun (v1, vl1) (v2, vl2) ->
	278	if abs_num vl1 </ abs_num vl2 then (v1, vl1) else (v2, vl2))
	279	(v, vl) r)
	280
	281	let partition p = List.partition (fun (vr, vl) -> p vr vl)
337	282	let mkvar x = set x (Int 1) null
	283
	284	module Bound = struct
	285	type t = {cst : num; var : var; coeff : num}
	286
	287	let of_vect (v : vector) =
	288	match v with
	289	\| [(x, v)] -> if x = 0 then None else Some {cst = Int 0; var = x; coeff = v}
	290	\| [(0, v); (x, v')] -> Some {cst = v; var = x; coeff = v'}
	291	\| _ -> None
	292	end

+50

-39

plugins/micromega/vect.mli less more

10	10	open Num
11	11	open Mutils
12	12
13		type var = int (** Variables are simply (positive) integers. *)
	13	type var = int
	14	(** Variables are simply (positive) integers. *)
14	15
15		type t (** The type of vectors or equivalently linear expressions.
	16	type t
	17	(** The type of vectors or equivalently linear expressions.
16	18	The current implementation is using association lists.
17	19	A list [(0,c),(x1,ai),...,(xn,an)] represents the linear expression
18	20	c + a1.xn + ... an.xn where ai are rational constants and xi are variables.

21	23	Moreover, the representation is spare and variables with a zero coefficient
22	24	are not represented.
23	25	*)
	26
	27	type vector = t
24	28
25	29	(** {1 Generic functions} *)
26	30

33	37
34	38	(** {1 Basic accessors and utility functions} *)
35	39
	40	val pp_gen : (out_channel -> var -> unit) -> out_channel -> t -> unit
36	41	(** [pp_gen pp_var o v] prints the representation of the vector [v] over the channel [o] *)
37		val pp_gen : (out_channel -> var -> unit) -> out_channel -> t -> unit
38	42
	43	val pp : out_channel -> t -> unit
39	44	(** [pp o v] prints the representation of the vector [v] over the channel [o] *)
40		val pp : out_channel -> t -> unit
41	45
	46	val pp_smt : out_channel -> t -> unit
42	47	(** [pp_smt o v] prints the representation of the vector [v] over the channel [o] using SMTLIB conventions *)
43		val pp_smt : out_channel -> t -> unit
44	48
	49	val variables : t -> ISet.t
45	50	(** [variables v] returns the set of variables with non-zero coefficients *)
46		val variables : t -> ISet.t
47	51
	52	val get_cst : t -> num
48	53	(** [get_cst v] returns c i.e. the coefficient of the variable zero *)
49		val get_cst : t -> num
50	54
	55	val decomp_cst : t -> num * t
51	56	(** [decomp_cst v] returns the pair (c,a1.x1+...+an.xn) *)
52		val decomp_cst : t -> num * t
53	57
	58	val decomp_at : int -> t -> num * t
54	59	(** [decomp_cst v] returns the pair (ai, ai+1.xi+...+an.xn) *)
55		val decomp_at : int -> t -> num * t
56	60
57	61	val decomp_fst : t -> (var * num) * t
58	62
	63	val cst : num -> t
59	64	(** [cst c] returns the vector v=c+0.x1+...+0.xn *)
60		val cst : num -> t
61	65
	66	val is_constant : t -> bool
62	67	(** [is_constant v] holds if [v] is a constant vector i.e. v=c+0.x1+...+0.xn
63	68	*)
64		val is_constant : t -> bool
65	69
	70	val null : t
66	71	(** [null] is the empty vector i.e. 0+0.x1+...+0.xn *)
67		val null : t
68	72
	73	val is_null : t -> bool
69	74	(** [is_null v] returns whether [v] is the [null] vector i.e [equal v null] *)
70		val is_null : t -> bool
71	75
	76	val get : var -> t -> num
72	77	(** [get xi v] returns the coefficient ai of the variable [xi].
73	78	[get] is also defined for the variable 0 *)
74		val get : var -> t -> num
75	79
	80	val set : var -> num -> t -> t
76	81	(** [set xi ai' v] returns the vector c+a1.x1+...ai'.xi+...+an.xn
77	82	i.e. the coefficient of the variable xi is set to ai' *)
78		val set : var -> num -> t -> t
79	83
	84	val mkvar : var -> t
80	85	(** [mkvar xi] returns 1.xi *)
81		val mkvar : var -> t
82	86
	87	val update : var -> (num -> num) -> t -> t
83	88	(** [update xi f v] returns c+a1.x1+...+f(ai).xi+...+an.xn *)
84		val update : var -> (num -> num) -> t -> t
85	89
	90	val fresh : t -> int
86	91	(** [fresh v] return the fresh variable with index 1+ max (variables v) *)
87		val fresh : t -> int
88	92
	93	val choose : t -> (var * num * t) option
89	94	(** [choose v] decomposes a vector [v] depending on whether it is [null] or not.
90	95	@return None if v is [null]
91	96	@return Some(x,n,r) where v = r + n.x x is the smallest variable with non-zero coefficient n <> 0.
92	97	*)
93		val choose : t -> (var * num * t) option
94	98
	99	val from_list : num list -> t
95	100	(** [from_list l] returns the vector c+a1.x1...an.xn from the list of coefficient [l=c;a1;...;an] *)
96		val from_list : num list -> t
97	101
	102	val to_list : t -> num list
98	103	(** [to_list v] returns the list of all coefficient of the vector v i.e. [c;a1;...;an]
99	104	The list representation is (obviously) not sparsed
100	105	and therefore certain ai may be 0 *)
101		val to_list : t -> num list
102	106
	107	val decr_var : int -> t -> t
103	108	(** [decr_var i v] decrements the variables of the vector [v] by the amount [i].
104	109	Beware, it is only defined if all the variables of v are greater than i
105	110	*)
106		val decr_var : int -> t -> t
107	111
	112	val incr_var : int -> t -> t
108	113	(** [incr_var i v] increments the variables of the vector [v] by the amount [i].
109	114	*)
110		val incr_var : int -> t -> t
111	115
	116	val gcd : t -> Big_int.big_int
112	117	(** [gcd v] returns gcd(num(c),num(a1),...,num(an)) where num extracts
113	118	the numerator of a rational value. *)
114		val gcd : t -> Big_int.big_int
115	119
	120	val normalise : t -> t
116	121	(** [normalise v] returns a vector with only integer coefficients *)
117		val normalise : t -> t
118
119	122
120	123	(** {1 Linear arithmetics} *)
121	124
	125	val add : t -> t -> t
122	126	(** [add v1 v2] is vector addition.
123	127	@param v1 is of the form c +a1.x1 +...+an.xn
124	128	@param v2 is of the form c'+a1'.x1 +...+an'.xn
125	129	@return c1+c1'+ (a1+a1').x1 + ... + (an+an').xn
126	130	*)
127		val add : t -> t -> t
128	131
	132	val mul : num -> t -> t
129	133	(** [mul a v] is vector multiplication of vector [v] by a scalar [a].
130	134	@return a.v = a.c+a.a1.x1+...+a.an.xn *)
131		val mul : num -> t -> t
132	135
	136	val mul_add : num -> t -> num -> t -> t
133	137	(** [mul_add c1 v1 c2 v2] returns the linear combination c1.v1+c2.v2 *)
134		val mul_add : num -> t -> num -> t -> t
135	138
	139	val subst : int -> t -> t -> t
	140	(** [subst x v v'] replaces x by v in vector v' *)
	141
	142	val div : num -> t -> t
136	143	(** [div c1 v1] returns the mutiplication by the inverse of c1 i.e (1/c1).v1 *)
137		val div : num -> t -> t
138	144
	145	val uminus : t -> t
139	146	(** [uminus v] @return -v the opposite vector of v i.e. (-1).v *)
140		val uminus : t -> t
141	147
142	148	(** {1 Iterators} *)
143	149
	150	val fold : ('acc -> var -> num -> 'acc) -> 'acc -> t -> 'acc
144	151	(** [fold f acc v] returns f (f (f acc 0 c ) x1 a1 ) ... xn an *)
145		val fold : ('acc -> var -> num -> 'acc) -> 'acc -> t -> 'acc
146	152
	153	val fold_error : ('acc -> var -> num -> 'acc option) -> 'acc -> t -> 'acc option
147	154	(** [fold_error f acc v] is the same as
148	155	[fold (fun acc x i -> match acc with None -> None \| Some acc' -> f acc' x i) (Some acc) v]
149	156	but with early exit...
150	157	*)
151		val fold_error : ('acc -> var -> num -> 'acc option) -> 'acc -> t -> 'acc option
152	158
	159	val find : (var -> num -> 'c option) -> t -> 'c option
153	160	(** [find f v] returns the first [f xi ai] such that [f xi ai <> None].
154	161	If no such xi ai exists, it returns None *)
155		val find : (var -> num -> 'c option) -> t -> 'c option
156	162
	163	val for_all : (var -> num -> bool) -> t -> bool
157	164	(** [for_all p v] returns /\_{i>=0} (f xi ai) *)
158		val for_all : (var -> num -> bool) -> t -> bool
159	165
	166	val exists2 : (num -> num -> bool) -> t -> t -> (var * num * num) option
160	167	(** [exists2 p v v'] returns Some(xi,ai,ai')
161	168	if p(xi,ai,ai') holds and ai,ai' <> 0.
162	169	It returns None if no such pair of coefficient exists. *)
163		val exists2 : (num -> num -> bool) -> t -> t -> (var * num * num) option
164	170
	171	val dotproduct : t -> t -> num
165	172	(** [dotproduct v1 v2] is the dot product of v1 and v2. *)
166		val dotproduct : t -> t -> num
167	173
168	174	val map : (var -> num -> 'a) -> t -> 'a list
	175	val abs_min_elt : t -> (var * num) option
	176	val partition : (var -> num -> bool) -> t -> t * t
169	177
170		val abs_min_elt : t -> (var * num) option
	178	module Bound : sig
	179	type t = {cst : num; var : var; coeff : num}
	180	(** represents a0 + ai.xi *)
171	181
172		val partition : (var -> num -> bool) -> t -> t * t
	182	val of_vect : vector -> t option
	183	end

+370

-477

plugins/micromega/zify.ml less more

26	26	let rec find_option pred l =
27	27	match l with
28	28	\| [] -> raise Not_found
29		\| e::l -> match pred e with
30		\| Some r -> r
31		\| None -> find_option pred l
32
	29	\| e :: l -> ( match pred e with Some r -> r \| None -> find_option pred l )
33	30
34	31	(** [HConstr] is a map indexed by EConstr.t.
35	32	It should only be used using closed terms.

38	35	module M = Map.Make (struct
39	36	type t = EConstr.t
40	37
41		let compare c c' =
42		Constr.compare (unsafe_to_constr c) (unsafe_to_constr c')
	38	let compare c c' = Constr.compare (unsafe_to_constr c) (unsafe_to_constr c')
43	39	end)
44	40
45	41	type 'a t = 'a list M.t

51	47	M.add h (e :: l) m
52	48
53	49	let empty = M.empty
54
55	50	let find h m = match lfind h m with e :: _ -> e \| [] -> raise Not_found
56
57	51	let find_all = lfind
58	52
59	53	let fold f m acc =
60	54	M.fold (fun k l acc -> List.fold_left (fun acc e -> f k e acc) acc l) m acc
61
62		end
63
	55	end
64	56
65	57	(** [get_projections_from_constant (evd,c) ]
66	58	returns an array of constr [\| a1,.. an\|] such that [c] is defined as

68	60	ai is therefore either a type parameter or a projection.
69	61	*)
70	62
71
72	63	let get_projections_from_constant (evd, i) =
73		match EConstr.kind evd (Reductionops.clos_whd_flags CClosure.all (Global.env ()) evd i) with
	64	match
	65	EConstr.kind evd
	66	(Reductionops.clos_whd_flags CClosure.all (Global.env ()) evd i)
	67	with
74	68	\| App (c, a) -> Some a
75	69	\| _ ->
76		raise (CErrors.user_err Pp.(str "The hnf of term " ++ pr_constr (Global.env ()) evd i
77		++ str " should be an application i.e. (c a1 ... an)"))
	70	raise
	71	(CErrors.user_err
	72	Pp.(
	73	str "The hnf of term "
	74	++ pr_constr (Global.env ()) evd i
	75	++ str " should be an application i.e. (c a1 ... an)"))
78	76
79	77	(** An instance of type, say T, is registered into a hashtable, say TableT. *)
80	78
81	79	type 'a decl =
82		{ decl: EConstr.t
	80	{ decl : EConstr.t
83	81	; (* Registered type instance *)
84		deriv: 'a
85		(* Projections of insterest *) }
86
	82	deriv : 'a (* Projections of insterest *) }
87	83
88	84	module EInjT = struct
89	85	type t =
90		{ isid: bool
	86	{ isid : bool
91	87	; (* S = T -> inj = fun x -> x*)
92		source: EConstr.t
	88	source : EConstr.t
93	89	; (* S *)
94		target: EConstr.t
	90	target : EConstr.t
95	91	; (* T *)
96	92	(* projections *)
97		inj: EConstr.t
	93	inj : EConstr.t
98	94	; (* S -> T *)
99		pred: EConstr.t
	95	pred : EConstr.t
100	96	; (* T -> Prop *)
101		cstr: EConstr.t option
102		(* forall x, pred (inj x) *) }
	97	cstr : EConstr.t option (* forall x, pred (inj x) *) }
103	98	end
104	99
105	100	module EBinOpT = struct
106	101	type t =
107	102	{ (* Op : source1 -> source2 -> source3 *)
108		source1: EConstr.t
109		; source2: EConstr.t
110		; source3: EConstr.t
111		; target: EConstr.t
112		; inj1: EConstr.t
	103	source1 : EConstr.t
	104	; source2 : EConstr.t
	105	; source3 : EConstr.t
	106	; target : EConstr.t
	107	; inj1 : EConstr.t
113	108	; (* InjTyp source1 target *)
114		inj2: EConstr.t
	109	inj2 : EConstr.t
115	110	; (* InjTyp source2 target *)
116		inj3: EConstr.t
	111	inj3 : EConstr.t
117	112	; (* InjTyp source3 target *)
118		tbop: EConstr.t
119		(* TBOpInj *) }
	113	tbop : EConstr.t (* TBOpInj *) }
120	114	end
121	115
122	116	module ECstOpT = struct
123		type t = {source: EConstr.t; target: EConstr.t; inj: EConstr.t}
	117	type t = {source : EConstr.t; target : EConstr.t; inj : EConstr.t}
124	118	end
125	119
126	120	module EUnOpT = struct
127	121	type t =
128		{ source1: EConstr.t
129		; source2: EConstr.t
130		; target: EConstr.t
131		; inj1_t: EConstr.t
132		; inj2_t: EConstr.t
133		; unop: EConstr.t }
	122	{ source1 : EConstr.t
	123	; source2 : EConstr.t
	124	; target : EConstr.t
	125	; inj1_t : EConstr.t
	126	; inj2_t : EConstr.t
	127	; unop : EConstr.t }
134	128	end
135	129
136	130	module EBinRelT = struct
137	131	type t =
138		{source: EConstr.t; target: EConstr.t; inj: EConstr.t; brel: EConstr.t}
	132	{source : EConstr.t; target : EConstr.t; inj : EConstr.t; brel : EConstr.t}
139	133	end
140	134
141	135	module EPropBinOpT = struct

146	140	type t = EConstr.t
147	141	end
148	142
149
150	143	module ESatT = struct
151		type t = {parg1: EConstr.t; parg2: EConstr.t; satOK: EConstr.t}
	144	type t = {parg1 : EConstr.t; parg2 : EConstr.t; satOK : EConstr.t}
152	145	end
153	146
154	147	(* Different type of declarations *)
155	148	type decl_kind =
156	149	\| PropOp of EPropBinOpT.t decl
157		\| PropUnOp of EPropUnOpT.t decl
158		\| InjTyp of EInjT.t decl
159		\| BinRel of EBinRelT.t decl
160		\| BinOp of EBinOpT.t decl
161		\| UnOp of EUnOpT.t decl
162		\| CstOp of ECstOpT.t decl
163		\| Saturate of ESatT.t decl
164
165
166		let get_decl = function
	150	\| PropUnOp of EPropUnOpT.t decl
	151	\| InjTyp of EInjT.t decl
	152	\| BinRel of EBinRelT.t decl
	153	\| BinOp of EBinOpT.t decl
	154	\| UnOp of EUnOpT.t decl
	155	\| CstOp of ECstOpT.t decl
	156	\| Saturate of ESatT.t decl
	157
	158	let get_decl = function
167	159	\| PropOp d -> d.decl
168		\| PropUnOp d -> d.decl
169		\| InjTyp d -> d.decl
170		\| BinRel d -> d.decl
171		\| BinOp d -> d.decl
172		\| UnOp d -> d.decl
173		\| CstOp d -> d.decl
174		\| Saturate d -> d.decl
175
176		type term_kind =
177		\| Application of EConstr.constr
178		\| OtherTerm of EConstr.constr
179
	160	\| PropUnOp d -> d.decl
	161	\| InjTyp d -> d.decl
	162	\| BinRel d -> d.decl
	163	\| BinOp d -> d.decl
	164	\| UnOp d -> d.decl
	165	\| CstOp d -> d.decl
	166	\| Saturate d -> d.decl
	167
	168	type term_kind = Application of EConstr.constr \| OtherTerm of EConstr.constr
180	169
181	170	module type Elt = sig
182	171	type elt

184	173	val name : string
185	174	(** name *)
186	175
187		val table : (term_kind * decl_kind) HConstr.t ref
188
	176	val table : (term_kind * decl_kind) HConstr.t ref
189	177	val cast : elt decl -> decl_kind
190
191		val dest : decl_kind -> (elt decl) option
	178	val dest : decl_kind -> elt decl option
192	179
193	180	val get_key : int
194	181	(** [get_key] is the type-index used as key for the instance *)

198	185	built from the type-instance i and the arguments (type indexes and projections)
199	186	of the type-class constructor. *)
200	187
201		(* val arity : int*)
202
203		end
204
205
206		let table = Summary.ref ~name:("zify_table") HConstr.empty
207
208		let saturate = Summary.ref ~name:("zify_saturate") HConstr.empty
209
	188	(* val arity : int*)
	189	end
	190
	191	let table = Summary.ref ~name:"zify_table" HConstr.empty
	192	let saturate = Summary.ref ~name:"zify_saturate" HConstr.empty
210	193	let table_cache = ref HConstr.empty
211	194	let saturate_cache = ref HConstr.empty
212
213	195
214	196	(** Each type-class gives rise to a different table.
215	197	They only differ on how projections are extracted. *)

219	201	type elt = EInjT.t
220	202
221	203	let name = "EInj"
222
223	204	let table = table
224
225	205	let cast x = InjTyp x
226
227		let dest = function
228		\| InjTyp x -> Some x
229		\| _ -> None
230
	206	let dest = function InjTyp x -> Some x \| _ -> None
231	207
232	208	let mk_elt evd i (a : EConstr.t array) =
233	209	let isid = EConstr.eq_constr evd a.(0) a.(1) in
234	210	{ isid
235		; source= a.(0)
236		; target= a.(1)
237		; inj= a.(2)
238		; pred= a.(3)
239		; cstr= (if isid then None else Some a.(4)) }
	211	; source = a.(0)
	212	; target = a.(1)
	213	; inj = a.(2)
	214	; pred = a.(3)
	215	; cstr = (if isid then None else Some a.(4)) }
240	216
241	217	let get_key = 0
242
243	218	end
244	219
245	220	module EBinOp = struct
246	221	type elt = EBinOpT.t
	222
247	223	open EBinOpT
248	224
249	225	let name = "BinOp"
250
251	226	let table = table
252	227
253	228	let mk_elt evd i a =
254		{ source1= a.(0)
255		; source2= a.(1)
256		; source3= a.(2)
257		; target= a.(3)
258		; inj1= a.(5)
259		; inj2= a.(6)
260		; inj3= a.(7)
261		; tbop= a.(9) }
	229	{ source1 = a.(0)
	230	; source2 = a.(1)
	231	; source3 = a.(2)
	232	; target = a.(3)
	233	; inj1 = a.(5)
	234	; inj2 = a.(6)
	235	; inj3 = a.(7)
	236	; tbop = a.(9) }
262	237
263	238	let get_key = 4
264
265
266	239	let cast x = BinOp x
267
268		let dest = function
269		\| BinOp x -> Some x
270		\| _ -> None
271
	240	let dest = function BinOp x -> Some x \| _ -> None
272	241	end
273	242
274	243	module ECstOp = struct
275	244	type elt = ECstOpT.t
	245
276	246	open ECstOpT
277	247
278	248	let name = "CstOp"
279
280	249	let table = table
281
282	250	let cast x = CstOp x
283
284		let dest = function
285		\| CstOp x -> Some x
286		\| _ -> None
287
288
289		let mk_elt evd i a = {source= a.(0); target= a.(1); inj= a.(3)}
290
	251	let dest = function CstOp x -> Some x \| _ -> None
	252	let mk_elt evd i a = {source = a.(0); target = a.(1); inj = a.(3)}
291	253	let get_key = 2
292
293	254	end
294	255
295	256	module EUnOp = struct
296	257	type elt = EUnOpT.t
	258
297	259	open EUnOpT
298	260
299	261	let name = "UnOp"
300
301	262	let table = table
302
303	263	let cast x = UnOp x
304
305		let dest = function
306		\| UnOp x -> Some x
307		\| _ -> None
308
	264	let dest = function UnOp x -> Some x \| _ -> None
309	265
310	266	let mk_elt evd i a =
311		{ source1= a.(0)
312		; source2= a.(1)
313		; target= a.(2)
314		; inj1_t= a.(4)
315		; inj2_t= a.(5)
316		; unop= a.(6) }
	267	{ source1 = a.(0)
	268	; source2 = a.(1)
	269	; target = a.(2)
	270	; inj1_t = a.(4)
	271	; inj2_t = a.(5)
	272	; unop = a.(6) }
317	273
318	274	let get_key = 3
319
320	275	end
321	276
322	277	module EBinRel = struct
323	278	type elt = EBinRelT.t
	279
324	280	open EBinRelT
325	281
326	282	let name = "BinRel"
327
328	283	let table = table
329
330	284	let cast x = BinRel x
331
332		let dest = function
333		\| BinRel x -> Some x
334		\| _ -> None
335
336		let mk_elt evd i a = {source= a.(0); target= a.(1); inj= a.(3); brel= a.(4)}
	285	let dest = function BinRel x -> Some x \| _ -> None
	286
	287	let mk_elt evd i a =
	288	{source = a.(0); target = a.(1); inj = a.(3); brel = a.(4)}
337	289
338	290	let get_key = 2
339
340	291	end
341	292
342	293	module EPropOp = struct
343	294	type elt = EConstr.t
344	295
345	296	let name = "PropBinOp"
346
347	297	let table = table
348
349	298	let cast x = PropOp x
350
351		let dest = function
352		\| PropOp x -> Some x
353		\| _ -> None
354
	299	let dest = function PropOp x -> Some x \| _ -> None
355	300	let mk_elt evd i a = i
356
357	301	let get_key = 0
358
359	302	end
360	303
361	304	module EPropUnOp = struct
362	305	type elt = EConstr.t
363	306
364	307	let name = "PropUnOp"
365
366	308	let table = table
367
368	309	let cast x = PropUnOp x
369
370		let dest = function
371		\| PropUnOp x -> Some x
372		\| _ -> None
373
	310	let dest = function PropUnOp x -> Some x \| _ -> None
374	311	let mk_elt evd i a = i
375
376	312	let get_key = 0
377
378		end
379
380
381
382		let constr_of_term_kind = function
383		\| Application c -> c
384		\| OtherTerm c -> c
385
386
	313	end
	314
	315	let constr_of_term_kind = function Application c -> c \| OtherTerm c -> c
387	316
388	317	let fold_declared_const f evd acc =
389	318	HConstr.fold
390		(fun _ (_,e) acc -> f (fst (EConstr.destConst evd (get_decl e))) acc)
391		(!table_cache) acc
392
393
	319	(fun _ (_, e) acc -> f (fst (EConstr.destConst evd (get_decl e))) acc)
	320	!table_cache acc
394	321
395	322	module type S = sig
396	323	val register : Constrexpr.constr_expr -> unit
397
398	324	val print : unit -> unit
399	325	end
400
401	326
402	327	module MakeTable (E : Elt) = struct
403	328	(** Given a term [c] and its arguments ai,

409	334	let make_elt (evd, i) =
410	335	match get_projections_from_constant (evd, i) with
411	336	\| None ->
412		let env = Global.env () in
413		let t = string_of_ppcmds (pr_constr env evd i) in
414		failwith ("Cannot register term " ^ t)
	337	let env = Global.env () in
	338	let t = string_of_ppcmds (pr_constr env evd i) in
	339	failwith ("Cannot register term " ^ t)
415	340	\| Some a -> E.mk_elt evd i a
416	341
417		let register_hint evd t elt =
	342	let register_hint evd t elt =
418	343	match EConstr.kind evd t with
419		\| App(c,_) ->
420		E.table := HConstr.add c (Application t, E.cast elt) !E.table
421		\| _ -> E.table := HConstr.add t (OtherTerm t, E.cast elt) !E.table
422
423
424
	344	\| App (c, _) ->
	345	E.table := HConstr.add c (Application t, E.cast elt) !E.table
	346	\| _ -> E.table := HConstr.add t (OtherTerm t, E.cast elt) !E.table
425	347
426	348	let register_constr env evd c =
427	349	let c = EConstr.of_constr c in
428	350	let t = get_type_of env evd c in
429	351	match EConstr.kind evd t with
430	352	\| App (intyp, args) ->
431		let styp = args.(E.get_key) in
432		let elt = {decl= c; deriv= (make_elt (evd, c))} in
433		register_hint evd styp elt
	353	let styp = args.(E.get_key) in
	354	let elt = {decl = c; deriv = make_elt (evd, c)} in
	355	register_hint evd styp elt
434	356	\| _ ->
435		let env = Global.env () in
436		raise (CErrors.user_err Pp.
437		(str ": Cannot register term "++pr_constr env evd c++
438		str ". It has type "++pr_constr env evd t++str " which should be of the form [F X1 .. Xn]"))
	357	let env = Global.env () in
	358	raise
	359	(CErrors.user_err
	360	Pp.(
	361	str ": Cannot register term "
	362	++ pr_constr env evd c ++ str ". It has type "
	363	++ pr_constr env evd t
	364	++ str " which should be of the form [F X1 .. Xn]"))
439	365
440	366	let register_obj : Constr.constr -> Libobject.obj =
441	367	let cache_constr (_, c) =

446	372	let subst_constr (subst, c) = Mod_subst.subst_mps subst c in
447	373	Libobject.declare_object
448	374	@@ Libobject.superglobal_object_nodischarge
449		("register-zify-" ^ E.name)
	375	("register-zify-" ^ E.name)
450	376	~cache:cache_constr ~subst:(Some subst_constr)
451	377
452	378	(** [register c] is called from the VERNACULAR ADD [name] constr(t).

454	380	registered as a [superglobal_object_nodischarge].
455	381	TODO: pre-compute [get_type_of] - [cache_constr] is using another environment.
456	382	*)
457		let register = fun c ->
	383	let register c =
458	384	let env = Global.env () in
459	385	let evd = Evd.from_env env in
460	386	let evd, c = Constrintern.interp_open_constr env evd c in
461	387	let _ = Lib.add_anonymous_leaf (register_obj (EConstr.to_constr evd c)) in
462	388	()
463	389
464
465	390	let pp_keys () =
466	391	let env = Global.env () in
467	392	let evd = Evd.from_env env in
468	393	HConstr.fold
469		(fun _ (k,d) acc ->
	394	(fun _ (k, d) acc ->
470	395	match E.dest d with
471	396	\| None -> acc
472	397	\| Some _ ->
473		Pp.(pr_constr env evd (constr_of_term_kind k) ++ str " " ++ acc))
474		(!E.table) (Pp.str "")
475
476
477		let print () = Feedback.msg_info (pp_keys ())
478
479		end
480
	398	Pp.(pr_constr env evd (constr_of_term_kind k) ++ str " " ++ acc))
	399	!E.table (Pp.str "")
	400
	401	let print () = Feedback.msg_info (pp_keys ())
	402	end
481	403
482	404	module InjTable = MakeTable (EInj)
483
484	405
485	406	module ESat = struct
486	407	type elt = ESatT.t
	408
487	409	open ESatT
488	410
489	411	let name = "Saturate"
490
491	412	let table = saturate
492
493	413	let cast x = Saturate x
494
495		let dest = function
496		\| Saturate x -> Some x
497		\| _ -> None
498
499		let mk_elt evd i a = {parg1= a.(2); parg2= a.(3); satOK= a.(5)}
500
	414	let dest = function Saturate x -> Some x \| _ -> None
	415	let mk_elt evd i a = {parg1 = a.(2); parg2 = a.(3); satOK = a.(5)}
501	416	let get_key = 1
502
503	417	end
504	418
505	419	module BinOp = MakeTable (EBinOp)

511	425	module Saturate = MakeTable (ESat)
512	426
513	427	let init_cache () =
514		table_cache := !table;
	428	table_cache := !table;
515	429	saturate_cache := !saturate
516
517	430
518	431	(** The module [Spec] is used to register
519	432	the instances of [BinOpSpec], [UnOpSpec].

555	468	Feedback.msg_notice l
556	469	end
557	470
558
559	471	let unfold_decl evd =
560	472	let f cst acc = cst :: acc in
561	473	fold_declared_const f evd []

577	489
578	490	(* The following [constr] are necessary for constructing the proof terms *)
579	491	let mkapp2 = lazy (zify "mkapp2")
580
581	492	let mkapp = lazy (zify "mkapp")
582
583	493	let mkapp0 = lazy (zify "mkapp0")
584
585	494	let mkdp = lazy (zify "mkinjterm")
586
587	495	let eq_refl = lazy (zify "eq_refl")
588
589	496	let mkrel = lazy (zify "mkrel")
590
591	497	let mkprop_op = lazy (zify "mkprop_op")
592
593	498	let mkuprop_op = lazy (zify "mkuprop_op")
594
595	499	let mkdpP = lazy (zify "mkinjprop")
596
597	500	let iff_refl = lazy (zify "iff_refl")
598
599	501	let q = lazy (zify "target_prop")
600
601	502	let ieq = lazy (zify "injprop_ok")
602
603	503	let iff = lazy (zify "iff")
604
605
606	504
607	505	(* A super-set of the previous are needed to unfold the generated proof terms. *)
608	506

630	528	; "mkapp0"
631	529	; "mkprop_op" ])
632	530
633
634	531	(** Module [CstrTable] records terms [x] injected into [inj x]
635	532	together with the corresponding type constraint.
636	533	The terms are stored by side-effect during the traversal

643	540	type t = EConstr.t
644	541
645	542	let hash c = Constr.hash (unsafe_to_constr c)
646
647	543	let equal c c' = Constr.equal (unsafe_to_constr c) (unsafe_to_constr c')
648	544	end)
649	545
650	546	let table : EConstr.t HConstr.t = HConstr.create 10
651
652	547	let register evd t (i : EConstr.t) = HConstr.add table t i
653	548
654	549	let get () =
655	550	let l = HConstr.fold (fun k i acc -> (k, i) :: acc) table [] in
656		HConstr.clear table ; l
	551	HConstr.clear table; l
657	552
658	553	(** [gen_cstr table] asserts (cstr k) for each element of the table (k,cstr).
659	554	NB: the constraint is only asserted if it does not already exist in the context.

666	561	let hyps_table = HConstr.create 20 in
667	562	List.iter
668	563	(fun (_, (t : EConstr.types)) -> HConstr.add hyps_table t ())
669		(Tacmach.New.pf_hyps_types gl) ;
	564	(Tacmach.New.pf_hyps_types gl);
670	565	fun c -> HConstr.mem hyps_table c
671	566	in
672	567	(* Add the constraint (cstr k) if it is not already present *)

682	577	(Names.Id.of_string "cstr")
683	578	env
684	579	in
685		Tactics.pose_proof (Names.Name n) term )
	580	Tactics.pose_proof (Names.Name n) term)
686	581	in
687	582	List.fold_left
688	583	(fun acc (k, i) -> Tacticals.New.tclTHEN (gen k i) acc)
689		Tacticals.New.tclIDTAC table )
	584	Tacticals.New.tclIDTAC table)
690	585	end
691	586
692	587	let mkvar red evd inj v =
693	588	( if not red then
694		match inj.cstr with None -> () \| Some ctr -> CstrTable.register evd v ctr
695		) ;
	589	match inj.cstr with None -> () \| Some ctr -> CstrTable.register evd v ctr );
696	590	let iv = EConstr.mkApp (inj.inj, [\|v\|]) in
697	591	let iv = if red then Tacred.compute (Global.env ()) evd iv else iv in
698	592	EConstr.mkApp

723	617	\| Var (inj, e) -> mkvar false evd inj e
724	618	\| Constant (inj, e) -> mkvar true evd inj e
725	619
726		let mkapp2_id evd i (* InjTyp S3 T *)
727		inj (* deriv i *)
728		t (* S1 -> S2 -> S3 *)
729		b (* Binop S1 S2 S3 t ... *)
730		dbop (* deriv b *) e1 e2 =
	620	let mkapp2_id evd i (* InjTyp S3 T ) inj ( deriv i ) t ( S1 -> S2 -> S3 *) b
	621	(* Binop S1 S2 S3 t ... ) dbop ( deriv b *) e1 e2 =
731	622	let default () =
732	623	let e1' = inj_term_of_texpr evd e1 in
733	624	let e2' = inj_term_of_texpr evd e2 in

754	645	\|Var (_, e1), Var (_, e2)
755	646	\|Constant (_, e1), Var (_, e2)
756	647	\|Var (_, e1), Constant (_, e2) ->
757		Var (inj, EConstr.mkApp (t, [\|e1; e2\|]))
	648	Var (inj, EConstr.mkApp (t, [\|e1; e2\|]))
758	649	\| _, _ -> default ()
759	650
760	651	let mkapp_id evd i inj (unop, u) f e1 =
761		EUnOpT.(if EConstr.eq_constr evd u.unop f then
762		(* Injection does nothing *)
763		match e1 with
764		\| Constant (_, e) \| Var (_, e) -> Var (inj, EConstr.mkApp (f, [\|e\|]))
765		\| Injterm e1 ->
	652	EUnOpT.(
	653	if EConstr.eq_constr evd u.unop f then
	654	(* Injection does nothing *)
	655	match e1 with
	656	\| Constant (_, e) \| Var (_, e) -> Var (inj, EConstr.mkApp (f, [\|e\|]))
	657	\| Injterm e1 ->
766	658	Injterm
767	659	(EConstr.mkApp
768	660	( force mkapp

774	666	; u.inj2_t
775	667	; unop
776	668	; e1 \|] ))
777		else
778		let e1 = inj_term_of_texpr evd e1 in
779		Injterm
780		(EConstr.mkApp
781		( force mkapp
782		, [\|u.source1; u.source2; u.target; f; u.inj1_t; u.inj2_t; unop; e1\|]
783		)))
784
785		type typed_constr = {constr: EConstr.t; typ: EConstr.t}
786
787
	669	else
	670	let e1 = inj_term_of_texpr evd e1 in
	671	Injterm
	672	(EConstr.mkApp
	673	( force mkapp
	674	, [\|u.source1; u.source2; u.target; f; u.inj1_t; u.inj2_t; unop; e1\|]
	675	)))
	676
	677	type typed_constr = {constr : EConstr.t; typ : EConstr.t}
788	678
789	679	let get_injection env evd t =
790	680	match snd (HConstr.find t !table_cache) with
791	681	\| InjTyp i -> i
792		\| _ -> raise Not_found
793
794
795		(* [arrow] is the term (fun (x:Prop) (y : Prop) => x -> y) *)
796		let arrow =
797		let name x =
798		Context.make_annot (Name.mk_name (Names.Id.of_string x)) Sorts.Relevant in
799		EConstr.mkLambda
800		( name "x"
801		, EConstr.mkProp
802		, EConstr.mkLambda
803		( name "y"
804		, EConstr.mkProp
805		, EConstr.mkProd
806		( Context.make_annot Names.Anonymous Sorts.Relevant
807		, EConstr.mkRel 2
808		, EConstr.mkRel 2 ) ) )
809
810
811		let is_prop env sigma term =
812		let sort = Retyping.get_sort_of env sigma term in
	682	\| _ -> raise Not_found
	683
	684	(* [arrow] is the term (fun (x:Prop) (y : Prop) => x -> y) *)
	685	let arrow =
	686	let name x =
	687	Context.make_annot (Name.mk_name (Names.Id.of_string x)) Sorts.Relevant
	688	in
	689	EConstr.mkLambda
	690	( name "x"
	691	, EConstr.mkProp
	692	, EConstr.mkLambda
	693	( name "y"
	694	, EConstr.mkProp
	695	, EConstr.mkProd
	696	( Context.make_annot Names.Anonymous Sorts.Relevant
	697	, EConstr.mkRel 2
	698	, EConstr.mkRel 2 ) ) )
	699
	700	let is_prop env sigma term =
	701	let sort = Retyping.get_sort_of env sigma term in
813	702	Sorts.is_prop sort
814	703
815		(** [get_application env evd e] expresses [e] as an application (c a)
	704	(** [get_application env evd e] expresses [e] as an application (c a)
816	705	where c is the head symbol and [a] is the array of arguments.
817	706	The function also transforms (x -> y) as (arrow x y) *)
818		let get_operator env evd e =
819		let is_arrow a p1 p2 =
820		is_prop env evd p1 && is_prop (EConstr.push_rel (Context.Rel.Declaration.LocalAssum(a,p1)) env) evd p2
821		&& (a.Context.binder_name = Names.Anonymous \|\| EConstr.Vars.noccurn evd 1 p2) in
822		match EConstr.kind evd e with
823		\| Prod (a, p1, p2) when is_arrow a p1 p2 ->
824		(arrow,[\|p1 ;p2\|])
825		\| App(c,a) -> (c,a)
826		\| _ -> (e,[\|\|])
827
828
829		let is_convertible env evd k t =
830		Reductionops.check_conv env evd k t
831
832		(** [match_operator env evd hd arg (t,d)]
	707	let get_operator env evd e =
	708	let is_arrow a p1 p2 =
	709	is_prop env evd p1
	710	&& is_prop
	711	(EConstr.push_rel (Context.Rel.Declaration.LocalAssum (a, p1)) env)
	712	evd p2
	713	&& (a.Context.binder_name = Names.Anonymous \|\| EConstr.Vars.noccurn evd 1 p2)
	714	in
	715	match EConstr.kind evd e with
	716	\| Prod (a, p1, p2) when is_arrow a p1 p2 -> (arrow, [\|p1; p2\|])
	717	\| App (c, a) -> (c, a)
	718	\| _ -> (e, [\|\|])
	719
	720	let is_convertible env evd k t = Reductionops.check_conv env evd k t
	721
	722	(** [match_operator env evd hd arg (t,d)]
833	723	- hd is head operator of t
834	724	- If t = OtherTerm _, then t = hd
835	725	- If t = Application _, then
836	726	we extract the relevant number of arguments from arg
837	727	and check for convertibility *)
838		let match_operator env evd hd args (t, d) =
839		let decomp t i =
840		let n = Array.length args in
841		let t' = EConstr.mkApp(hd,Array.sub args 0 (n-i)) in
842		if is_convertible env evd t' t
843		then Some (d,t)
844		else None in
845
846		match t with
847		\| OtherTerm t -> Some(d,t)
848		\| Application t ->
849		match d with
850		\| CstOp _ -> decomp t 0
851		\| UnOp _ -> decomp t 1
852		\| BinOp _ -> decomp t 2
853		\| BinRel _ -> decomp t 2
854		\| PropOp _ -> decomp t 2
855		\| PropUnOp _ -> decomp t 1
856		\| _ -> None
857
858
859		let rec trans_expr env evd e =
	728	let match_operator env evd hd args (t, d) =
	729	let decomp t i =
	730	let n = Array.length args in
	731	let t' = EConstr.mkApp (hd, Array.sub args 0 (n - i)) in
	732	if is_convertible env evd t' t then Some (d, t) else None
	733	in
	734	match t with
	735	\| OtherTerm t -> Some (d, t)
	736	\| Application t -> (
	737	match d with
	738	\| CstOp _ -> decomp t 0
	739	\| UnOp _ -> decomp t 1
	740	\| BinOp _ -> decomp t 2
	741	\| BinRel _ -> decomp t 2
	742	\| PropOp _ -> decomp t 2
	743	\| PropUnOp _ -> decomp t 1
	744	\| _ -> None )
	745
	746	let rec trans_expr env evd e =
860	747	(* Get the injection *)
861		let {decl= i; deriv= inj} = get_injection env evd e.typ in
	748	let {decl = i; deriv = inj} = get_injection env evd e.typ in
862	749	let e = e.constr in
863	750	if EConstr.isConstruct evd e then Constant (inj, e) (* Evaluate later *)
864	751	else
865		let (c,a) = get_operator env evd e in
	752	let c, a = get_operator env evd e in
866	753	try
867		let (k,t) = find_option (match_operator env evd c a) (HConstr.find_all c !table_cache) in
	754	let k, t =
	755	find_option
	756	(match_operator env evd c a)
	757	(HConstr.find_all c !table_cache)
	758	in
868	759	let n = Array.length a in
869		match k with
870		\| CstOp {decl = c'} ->
871		Injterm (EConstr.mkApp (force mkapp0, [\|inj.source; inj.target; e; i; c'\|]))
872		\| UnOp {decl = unop ; deriv = u} ->
873		let a' = trans_expr env evd {constr= a.(n-1); typ= u.EUnOpT.source1} in
874		if is_constant a' && EConstr.isConstruct evd t then
875		Constant (inj, e)
876		else mkapp_id evd i inj (unop, u) t a'
877		\| BinOp {decl = binop ; deriv = b} ->
878		let a0 = trans_expr env evd {constr= a.(n-2); typ= b.EBinOpT.source1} in
879		let a1 = trans_expr env evd {constr= a.(n-1); typ= b.EBinOpT.source2} in
880		if is_constant a0 && is_constant a1 && EConstr.isConstruct evd t
881		then Constant (inj, e)
882		else mkapp2_id evd i inj t binop b a0 a1
883		\| d ->
884		Var (inj,e)
885		with Not_found -> Var (inj,e)
	760	match k with
	761	\| CstOp {decl = c'} ->
	762	Injterm
	763	(EConstr.mkApp (force mkapp0, [\|inj.source; inj.target; e; i; c'\|]))
	764	\| UnOp {decl = unop; deriv = u} ->
	765	let a' =
	766	trans_expr env evd {constr = a.(n - 1); typ = u.EUnOpT.source1}
	767	in
	768	if is_constant a' && EConstr.isConstruct evd t then Constant (inj, e)
	769	else mkapp_id evd i inj (unop, u) t a'
	770	\| BinOp {decl = binop; deriv = b} ->
	771	let a0 =
	772	trans_expr env evd {constr = a.(n - 2); typ = b.EBinOpT.source1}
	773	in
	774	let a1 =
	775	trans_expr env evd {constr = a.(n - 1); typ = b.EBinOpT.source2}
	776	in
	777	if is_constant a0 && is_constant a1 && EConstr.isConstruct evd t then
	778	Constant (inj, e)
	779	else mkapp2_id evd i inj t binop b a0 a1
	780	\| d -> Var (inj, e)
	781	with Not_found -> Var (inj, e)
886	782
887	783	let trans_expr env evd e =
888		try trans_expr env evd e with Not_found ->
	784	try trans_expr env evd e
	785	with Not_found ->
889	786	raise
890	787	(CErrors.user_err
891	788	( Pp.str "Missing injection for type "
892	789	++ Printer.pr_leconstr_env env evd e.typ ))
893	790
894
895	791	type tprop =
896	792	\| TProp of EConstr.t (** Transformed proposition *)
897	793	\| IProp of EConstr.t (** Identical proposition *)

902	798	let inj_prop_of_tprop = function TProp p -> p \| IProp e -> mk_iprop e
903	799
904	800	let rec trans_prop env evd e =
905		let (c,a) = get_operator env evd e in
	801	let c, a = get_operator env evd e in
906	802	try
907		let (k,t) = find_option (match_operator env evd c a) (HConstr.find_all c !table_cache) in
	803	let k, t =
	804	find_option (match_operator env evd c a) (HConstr.find_all c !table_cache)
	805	in
908	806	let n = Array.length a in
909	807	match k with
910		\| PropOp {decl= rop} ->
911		begin
912		try
913		let t1 = trans_prop env evd a.(n-2) in
914		let t2 = trans_prop env evd a.(n-1) in
915		match (t1, t2) with
916		\| IProp _, IProp _ -> IProp e
917		\| _, _ ->
918		let t1 = inj_prop_of_tprop t1 in
919		let t2 = inj_prop_of_tprop t2 in
920		TProp (EConstr.mkApp (force mkprop_op, [\|t; rop; t1; t2\|]))
921		with Not_found -> IProp e
922		end
923		\| BinRel {decl = br ; deriv = rop} ->
924		begin
925		try
926		let a1 = trans_expr env evd {constr = a.(n-2) ; typ = rop.EBinRelT.source} in
927		let a2 = trans_expr env evd {constr = a.(n-1) ; typ = rop.EBinRelT.source} in
928		if EConstr.eq_constr evd t rop.EBinRelT.brel then
929		match (constr_of_texpr a1, constr_of_texpr a2) with
930		\| Some e1, Some e2 -> IProp (EConstr.mkApp (t, [\|e1; e2\|]))
931		\| _, _ ->
932		let a1 = inj_term_of_texpr evd a1 in
933		let a2 = inj_term_of_texpr evd a2 in
934		TProp
935		(EConstr.mkApp
936		( force mkrel
937		, [\| rop.EBinRelT.source
938		; rop.EBinRelT.target
939		; t
940		; rop.EBinRelT.inj
941		; br
942		; a1
943		; a2 \|] ))
944		else
945		let a1 = inj_term_of_texpr evd a1 in
946		let a2 = inj_term_of_texpr evd a2 in
947		TProp
948		(EConstr.mkApp
949		( force mkrel
950		, [\| rop.EBinRelT.source
951		; rop.EBinRelT.target
952		; t
953		; rop.EBinRelT.inj
954		; br
955		; a1
956		; a2 \|] ))
957		with Not_found -> IProp e
958		end
959		\| PropUnOp {decl = rop} ->
960		begin
961		try
962		let t1 = trans_prop env evd a.(n-1) in
963		match t1 with
964		\| IProp _ -> IProp e
965		\| _ ->
966		let t1 = inj_prop_of_tprop t1 in
967		TProp (EConstr.mkApp (force mkuprop_op, [\|t; rop; t1\|]))
968		with Not_found -> IProp e
969		end
970		\| _ -> IProp e
	808	\| PropOp {decl = rop} -> (
	809	try
	810	let t1 = trans_prop env evd a.(n - 2) in
	811	let t2 = trans_prop env evd a.(n - 1) in
	812	match (t1, t2) with
	813	\| IProp _, IProp _ -> IProp e
	814	\| _, _ ->
	815	let t1 = inj_prop_of_tprop t1 in
	816	let t2 = inj_prop_of_tprop t2 in
	817	TProp (EConstr.mkApp (force mkprop_op, [\|t; rop; t1; t2\|]))
	818	with Not_found -> IProp e )
	819	\| BinRel {decl = br; deriv = rop} -> (
	820	try
	821	let a1 =
	822	trans_expr env evd {constr = a.(n - 2); typ = rop.EBinRelT.source}
	823	in
	824	let a2 =
	825	trans_expr env evd {constr = a.(n - 1); typ = rop.EBinRelT.source}
	826	in
	827	if EConstr.eq_constr evd t rop.EBinRelT.brel then
	828	match (constr_of_texpr a1, constr_of_texpr a2) with
	829	\| Some e1, Some e2 -> IProp (EConstr.mkApp (t, [\|e1; e2\|]))
	830	\| _, _ ->
	831	let a1 = inj_term_of_texpr evd a1 in
	832	let a2 = inj_term_of_texpr evd a2 in
	833	TProp
	834	(EConstr.mkApp
	835	( force mkrel
	836	, [\| rop.EBinRelT.source
	837	; rop.EBinRelT.target
	838	; t
	839	; rop.EBinRelT.inj
	840	; br
	841	; a1
	842	; a2 \|] ))
	843	else
	844	let a1 = inj_term_of_texpr evd a1 in
	845	let a2 = inj_term_of_texpr evd a2 in
	846	TProp
	847	(EConstr.mkApp
	848	( force mkrel
	849	, [\| rop.EBinRelT.source
	850	; rop.EBinRelT.target
	851	; t
	852	; rop.EBinRelT.inj
	853	; br
	854	; a1
	855	; a2 \|] ))
	856	with Not_found -> IProp e )
	857	\| PropUnOp {decl = rop} -> (
	858	try
	859	let t1 = trans_prop env evd a.(n - 1) in
	860	match t1 with
	861	\| IProp _ -> IProp e
	862	\| _ ->
	863	let t1 = inj_prop_of_tprop t1 in
	864	TProp (EConstr.mkApp (force mkuprop_op, [\|t; rop; t1\|]))
	865	with Not_found -> IProp e )
	866	\| _ -> IProp e
971	867	with Not_found -> IProp e
972	868
973	869	let unfold n env evd c =

983	879	match n with
984	880	\| None -> c
985	881	\| Some n ->
986		Tacred.unfoldn [(Locus.AllOccurrences, Names.EvalVarRef n)] env evd c
	882	Tacred.unfoldn [(Locus.AllOccurrences, Names.EvalVarRef n)] env evd c
987	883	in
988	884	(* Reduce the term *)
989		let c = cbv (List.rev_append (force to_unfold) unfold_decl) env evd c in
	885	let c = cbv (List.rev_append (force to_unfold) unfold_decl) env evd c in
990	886	c
991	887
992	888	let trans_check_prop env evd t =
993		if is_prop env evd t then
	889	if is_prop env evd t then
994	890	(let t = Tacred.unfoldn [Locus.AllOccurrences, Names.EvalConstRef coq_not] env evd t in)
995	891	match trans_prop env evd t with IProp e -> None \| TProp e -> Some e
996	892	else None

1000	896	(fun acc (h, p) ->
1001	897	match trans_check_prop env evd p with
1002	898	\| None -> acc
1003		\| Some p' -> (h, p, p') :: acc )
	899	\| Some p' -> (h, p, p') :: acc)
1004	900	[] (List.rev l)
1005	901
1006	902	(* Only used if a direct rewrite fails *)

1015	911	let h' = fresh_id_in_env Id.Set.empty h env in
1016	912	tclTHENLIST
1017	913	[ letin_tac None (Names.Name n) t None
1018		Locus.{onhyps= None; concl_occs= NoOccurrences}
	914	Locus.{onhyps = None; concl_occs = NoOccurrences}
1019	915	; assert_by (Name.Name h')
1020	916	(EConstr.mkApp (force q, [\|EConstr.mkVar n\|]))
1021	917	(tclTHEN

1026	922	(h', Locus.InHyp)
1027	923	; clear [n]
1028	924	; (* [clear H] may fail if [h] has dependencies *)
1029		tclTRY (clear [h]) ] )))
	925	tclTRY (clear [h]) ])))
1030	926
1031	927	let is_progress_rewrite evd t rew =
1032	928	match EConstr.kind evd rew with
1033	929	\| App (c, [\|lhs; rhs\|]) ->
1034		if EConstr.eq_constr evd (force iff) c then
1035		(* This is a successful rewriting *)
1036		not (EConstr.eq_constr evd lhs rhs)
1037		else
1038		CErrors.anomaly
1039		Pp.(
1040		str "is_progress_rewrite: not a rewrite"
1041		++ pr_constr (Global.env ()) evd rew)
	930	if EConstr.eq_constr evd (force iff) c then
	931	(* This is a successful rewriting *)
	932	not (EConstr.eq_constr evd lhs rhs)
	933	else
	934	CErrors.anomaly
	935	Pp.(
	936	str "is_progress_rewrite: not a rewrite"
	937	++ pr_constr (Global.env ()) evd rew)
1042	938	\| _ -> failwith "is_progress_rewrite: not even an application"
1043	939
1044	940	let trans_hyp h t0 t =

1049	945	let t' = unfold None env evd (EConstr.mkApp (force ieq, [\|t\|])) in
1050	946	if is_progress_rewrite evd t0 (get_type_of env evd t') then
1051	947	tclFIRST
1052		[ Equality.general_rewrite_in true Locus.AllOccurrences true false
1053		h t' false
	948	[ Equality.general_rewrite_in true Locus.AllOccurrences true false h
	949	t' false
1054	950	; trans_hyp h t ]
1055		else tclIDTAC ))
	951	else tclIDTAC))
1056	952
1057	953	let trans_concl t =
1058	954	Tacticals.New.(

1063	959	let t' = unfold None env evd (EConstr.mkApp (force ieq, [\|t\|])) in
1064	960	if is_progress_rewrite evd concl (get_type_of env evd t') then
1065	961	Equality.general_rewrite true Locus.AllOccurrences true false t'
1066		else tclIDTAC ))
	962	else tclIDTAC))
1067	963
1068	964	let tclTHENOpt e tac tac' =
1069	965	match e with None -> tac' \| Some e' -> Tacticals.New.tclTHEN (tac e') tac'
1070	966
1071	967	let zify_tac =
1072	968	Proofview.Goal.enter (fun gl ->
1073		Coqlib.check_required_library ["Coq"; "micromega"; "ZifyClasses"] ;
1074		Coqlib.check_required_library ["Coq"; "micromega"; "ZifyInst"] ;
	969	Coqlib.check_required_library ["Coq"; "micromega"; "ZifyClasses"];
	970	Coqlib.check_required_library ["Coq"; "micromega"; "ZifyInst"];
1075	971	init_cache ();
1076	972	let evd = Tacmach.New.project gl in
1077	973	let env = Tacmach.New.pf_env gl in

1082	978	(Tacticals.New.tclTHEN
1083	979	(Tacticals.New.tclTHENLIST
1084	980	(List.rev_map (fun (h, p, t) -> trans_hyp h p t) hyps))
1085		(CstrTable.gen_cstr l)) )
	981	(CstrTable.gen_cstr l)))
1086	982
1087	983	let iter_specs tac =
1088	984	Tacticals.New.tclTHENLIST
1089		(List.fold_left (fun acc d -> tac d :: acc) [] (Spec.get ()))
1090
1091
1092		let iter_specs (tac: Ltac_plugin.Tacinterp.Value.t) =
1093		iter_specs (fun c -> Ltac_plugin.Tacinterp.Value.apply tac [Ltac_plugin.Tacinterp.Value.of_constr c])
	985	(List.fold_left (fun acc d -> tac d :: acc) [] (Spec.get ()))
	986
	987	let iter_specs (tac : Ltac_plugin.Tacinterp.Value.t) =
	988	iter_specs (fun c ->
	989	Ltac_plugin.Tacinterp.Value.apply tac
	990	[Ltac_plugin.Tacinterp.Value.of_constr c])
1094	991
1095	992	let find_hyp evd t l =
1096	993	try Some (fst (List.find (fun (h, t') -> EConstr.eq_constr evd t t') l))

1103	1000	let hyps = Tacmach.New.pf_hyps_types gl in
1104	1001	match EConstr.kind evd c with
1105	1002	\| App (c, args) ->
1106		if Array.length args = 2 then (
1107		let h1 =
1108		Tacred.cbv_beta env evd
1109		(EConstr.mkApp (d.ESatT.parg1, [\|args.(0)\|]))
	1003	if Array.length args = 2 then
	1004	let h1 =
	1005	Tacred.cbv_beta env evd
	1006	(EConstr.mkApp (d.ESatT.parg1, [\|args.(0)\|]))
	1007	in
	1008	let h2 =
	1009	Tacred.cbv_beta env evd
	1010	(EConstr.mkApp (d.ESatT.parg2, [\|args.(1)\|]))
	1011	in
	1012	match (find_hyp evd h1 hyps, find_hyp evd h2 hyps) with
	1013	\| Some h1, Some h2 ->
	1014	let n =
	1015	Tactics.fresh_id_in_env Id.Set.empty
	1016	(Names.Id.of_string "__sat")
	1017	env
1110	1018	in
1111		let h2 =
1112		Tacred.cbv_beta env evd
1113		(EConstr.mkApp (d.ESatT.parg2, [\|args.(1)\|]))
	1019	let trm =
	1020	EConstr.mkApp
	1021	( d.ESatT.satOK
	1022	, [\|args.(0); args.(1); EConstr.mkVar h1; EConstr.mkVar h2\|] )
1114	1023	in
1115		match (find_hyp evd h1 hyps, find_hyp evd h2 hyps) with
1116		\| Some h1, Some h2 ->
1117		let n =
1118		Tactics.fresh_id_in_env Id.Set.empty
1119		(Names.Id.of_string "__sat")
1120		env
1121		in
1122		let trm =
1123		EConstr.mkApp
1124		( d.ESatT.satOK
1125		, [\|args.(0); args.(1); EConstr.mkVar h1; EConstr.mkVar h2\|]
1126		)
1127		in
1128		Tactics.pose_proof (Names.Name n) trm
1129		\| _, _ -> Tacticals.New.tclIDTAC )
1130		else Tacticals.New.tclIDTAC
1131		\| _ -> Tacticals.New.tclIDTAC )
1132
	1024	Tactics.pose_proof (Names.Name n) trm
	1025	\| _, _ -> Tacticals.New.tclIDTAC
	1026	else Tacticals.New.tclIDTAC
	1027	\| _ -> Tacticals.New.tclIDTAC)
1133	1028
1134	1029	let get_all_sat env evd c =
1135		List.fold_left (fun acc e ->
1136		match e with
1137		\| (_,Saturate s) -> s::acc
1138		\| _ -> acc) [] (HConstr.find_all c !saturate_cache )
	1030	List.fold_left
	1031	(fun acc e -> match e with _, Saturate s -> s :: acc \| _ -> acc)
	1032	[]
	1033	(HConstr.find_all c !saturate_cache)
1139	1034
1140	1035	let saturate =
1141	1036	Proofview.Goal.enter (fun gl ->

1148	1043	let rec sat t =
1149	1044	match EConstr.kind evd t with
1150	1045	\| App (c, args) ->
1151		sat c ;
1152		Array.iter sat args ;
1153		if Array.length args = 2 then
1154		let ds = get_all_sat env evd c in
1155		if ds = [] then ()
1156		else (
1157		List.iter (fun x -> CstrTable.HConstr.add table t x.deriv) ds )
1158		else ()
	1046	sat c;
	1047	Array.iter sat args;
	1048	if Array.length args = 2 then
	1049	let ds = get_all_sat env evd c in
	1050	if ds = [] then ()
	1051	else List.iter (fun x -> CstrTable.HConstr.add table t x.deriv) ds
	1052	else ()
1159	1053	\| Prod (a, t1, t2) when a.Context.binder_name = Names.Anonymous ->
1160		sat t1 ; sat t2
	1054	sat t1; sat t2
1161	1055	\| _ -> ()
1162	1056	in
1163	1057	(* Collect all the potential saturation lemma *)
1164		sat concl ;
1165		List.iter (fun (_, t) -> sat t) hyps ;
	1058	sat concl;
	1059	List.iter (fun (_, t) -> sat t) hyps;
1166	1060	Tacticals.New.tclTHENLIST
1167		(CstrTable.HConstr.fold (fun c d acc -> sat_constr c d :: acc) table [])
1168		)
	1061	(CstrTable.HConstr.fold (fun c d acc -> sat_constr c d :: acc) table []))

+10

-7

plugins/micromega/zify.mli less more

8	8	(************************************************************************)
9	9	open Constrexpr
10	10
11		module type S = sig val register : constr_expr -> unit val print : unit -> unit end
	11	module type S = sig
	12	val register : constr_expr -> unit
	13	val print : unit -> unit
	14	end
12	15
13	16	module InjTable : S
14		module UnOp : S
15		module BinOp : S
16		module CstOp : S
17		module BinRel : S
18		module PropOp : S
	17	module UnOp : S
	18	module BinOp : S
	19	module CstOp : S
	20	module BinRel : S
	21	module PropOp : S
19	22	module PropUnOp : S
20		module Spec : S
	23	module Spec : S
21	24	module Saturate : S
22	25
23	26	val zify_tac : unit Proofview.tactic

-1

plugins/omega/g_omega.mlg less more

44	44	(Tacticals.New.tclREPEAT (Tacticals.New.tclTHENLIST tacs))
45	45	(omega_solver)
46	46
	47	let omega_with_deprecation =
	48	Deprecation.make ~since:"8.11.0" ~note:"Use lia instead." ()
	49
47	50	}
48	51
49	52	TACTIC EXTEND omega
50	53	\| [ "omega" ] -> { omega_tactic [] }
51	54	END
52	55
53		TACTIC EXTEND omega'
	56	TACTIC EXTEND omega' DEPRECATED { omega_with_deprecation }
54	57	\| [ "omega" "with" ne_ident_list(l) ] ->
55	58	{ omega_tactic (List.map Names.Id.to_string l) }
56	59	\| [ "omega" "with" "*" ] ->

-85

plugins/ssr/ssrsetoid.v less more

17	17	than [eq] or [iff], e.g. a [RewriteRelation], by doing:
18	18	[Require Import ssreflect. Require Setoid.]
19	19
20		This file's instances have priority 12 > other stdlib instances
21		and each [Under_rel] instance comes with a [Hint Cut] directive
22		(otherwise Ring_polynom.v won't compile because of unbounded search).
	20	This file's instances have priority 12 > other stdlib instances.
23	21
24	22	(Note: this file could be skipped when porting [under] to stdlib2.)
25	23	*)

37	35	RelationClasses.Reflexive R ->
38	36	ssrclasses.Reflexive R \| 12.
39	37	Proof. now trivial. Qed.
40
41		(** Add instances so that ['Under[ F i ]] terms,
42		that is, [Under_rel T R (F i) (?G i)] terms,
43		can be manipulated with rewrite/setoid_rewrite with lemmas on [R].
44		Note that this requires that [R] is a [Prop] relation, otherwise
45		a [bool] relation may need to be "lifted": see the [TestPreOrder]
46		section in test-suite/ssr/under.v *)
47
48		Instance Under_subrelation {A} (R : relation A) : subrelation R (Under_rel _ R) \| 12.
49		Proof. now rewrite Under_relE. Qed.
50
51		(* see also Morphisms.trans_co_eq_inv_impl_morphism *)
52
53		Instance Under_Reflexive {A} (R : relation A) :
54		RelationClasses.Reflexive R ->
55		RelationClasses.Reflexive (Under_rel.Under_rel A R) \| 12.
56		Proof. now rewrite Under_rel.Under_relE. Qed.
57
58		Hint Cut [_* Under_Reflexive Under_Reflexive] : typeclass_instances.
59
60		(* These instances are a bit off-topic given that (Under_rel A R) will
61		typically be reflexive, to be able to trigger the [over] terminator
62
63		Instance under_Irreflexive {A} (R : relation A) :
64		RelationClasses.Irreflexive R ->
65		RelationClasses.Irreflexive (Under_rel.Under_rel A R) \| 12.
66		Proof. now rewrite Under_rel.Under_relE. Qed.
67
68		Hint Cut [_* Under_Irreflexive Under_Irreflexive] : typeclass_instances.
69
70		Instance under_Asymmetric {A} (R : relation A) :
71		RelationClasses.Asymmetric R ->
72		RelationClasses.Asymmetric (Under_rel.Under_rel A R) \| 12.
73		Proof. now rewrite Under_rel.Under_relE. Qed.
74
75		Hint Cut [_* Under_Asymmetric Under_Asymmetric] : typeclass_instances.
76
77		Instance under_StrictOrder {A} (R : relation A) :
78		RelationClasses.StrictOrder R ->
79		RelationClasses.StrictOrder (Under_rel.Under_rel A R) \| 12.
80		Proof. now rewrite Under_rel.Under_relE. Qed.
81
82		Hint Cut [_* Under_Strictorder Under_Strictorder] : typeclass_instances.
83		*)
84
85		Instance Under_Symmetric {A} (R : relation A) :
86		RelationClasses.Symmetric R ->
87		RelationClasses.Symmetric (Under_rel.Under_rel A R) \| 12.
88		Proof. now rewrite Under_rel.Under_relE. Qed.
89
90		Hint Cut [_* Under_Symmetric Under_Symmetric] : typeclass_instances.
91
92		Instance Under_Transitive {A} (R : relation A) :
93		RelationClasses.Transitive R ->
94		RelationClasses.Transitive (Under_rel.Under_rel A R) \| 12.
95		Proof. now rewrite Under_rel.Under_relE. Qed.
96
97		Hint Cut [_* Under_Transitive Under_Transitive] : typeclass_instances.
98
99		Instance Under_PreOrder {A} (R : relation A) :
100		RelationClasses.PreOrder R ->
101		RelationClasses.PreOrder (Under_rel.Under_rel A R) \| 12.
102		Proof. now rewrite Under_rel.Under_relE. Qed.
103
104		Hint Cut [_* Under_PreOrder Under_PreOrder] : typeclass_instances.
105
106		Instance Under_PER {A} (R : relation A) :
107		RelationClasses.PER R ->
108		RelationClasses.PER (Under_rel.Under_rel A R) \| 12.
109		Proof. now rewrite Under_rel.Under_relE. Qed.
110
111		Hint Cut [_* Under_PER Under_PER] : typeclass_instances.
112
113		Instance Under_Equivalence {A} (R : relation A) :
114		RelationClasses.Equivalence R ->
115		RelationClasses.Equivalence (Under_rel.Under_rel A R) \| 12.
116		Proof. now rewrite Under_rel.Under_relE. Qed.
117
118		Hint Cut [_* Under_Equivalence Under_Equivalence] : typeclass_instances.
119
120		(* Don't handle Antisymmetric and PartialOrder classes for now,
121		as these classes depend on two relation symbols... *)

-26

~~plugins/ssrmatching/g_ssrmatching.mli~~ less more

0		(************************************************************************)
1		(* * The Coq Proof Assistant / The Coq Development Team *)
2		(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *)
3		(* <O___,, * (see CREDITS file for the list of authors) *)
4		(* \VV/ **************************************************************)
5		(* // * This file is distributed under the terms of the *)
6		(* * GNU Lesser General Public License Version 2.1 *)
7		(* * (see LICENSE file for the text of the license) *)
8		(************************************************************************)
9
10		(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *)
11
12		open Genarg
13		open Ssrmatching
14
15		(** CS cpattern: (f _), (X in t), (t in X in t), (t as X in t) *)
16		val cpattern : cpattern Pcoq.Entry.t
17		val wit_cpattern : cpattern uniform_genarg_type
18
19		(** OS cpattern: f _, (X in t), (t in X in t), (t as X in t) *)
20		val lcpattern : cpattern Pcoq.Entry.t
21		val wit_lcpattern : cpattern uniform_genarg_type
22
23		(** OS rpattern: f _, in t, X in t, in X in t, t in X in t, t as X in t *)
24		val rpattern : rpattern Pcoq.Entry.t
25		val wit_rpattern : rpattern uniform_genarg_type

-3

pretyping/cases.ml less more

435	435	\| exception Evarconv.UnableToUnify _ -> sigma, current
436	436	\| sigma -> sigma, current
437	437	else
438		let sigma, j = Coercion.inh_conv_coerce_to ?loc ~program_mode true !!(pb.env) sigma (make_judge current typ) indt in
	438	let sigma, j, _trace = Coercion.inh_conv_coerce_to ?loc ~program_mode true !!(pb.env) sigma (make_judge current typ) indt in
439	439	sigma, j.uj_val
440	440	in
441	441	sigma, (current, try_find_ind !!(pb.env) sigma indt names))

1954	1954
1955	1955	let inh_conv_coerce_to_tycon ?loc ~program_mode env sigma j tycon =
1956	1956	match tycon with
1957		\| Some p -> Coercion.inh_conv_coerce_to ?loc ~program_mode true env sigma
1958		~flags:(default_flags_of TransparentState.full) j p
	1957	\| Some p ->
	1958	let (evd,v,_trace) =
	1959	Coercion.inh_conv_coerce_to ?loc ~program_mode true env sigma
	1960	~flags:(default_flags_of TransparentState.full) j p
	1961	in
	1962	(evd,v)
1959	1963	\| None -> sigma, j
1960	1964
1961	1965	(* We put the tycon inside the arity signature, possibly discovering dependencies. *)

+101

-50

pretyping/coercion.ml less more

136	136	in
137	137	liftrec (List.length sign) sign
138	138
139		let mu env evdref t =
140		let rec aux v =
141		let v' = hnf env !evdref v in
142		match disc_subset !evdref v' with
143		\| Some (u, p) ->
144		let f, ct = aux u in
145		let p = hnf_nodelta env !evdref p in
146		(Some (fun x ->
147		app_opt env evdref
148		f (papp evdref sig_proj1 [\| u; p; x \|])),
149		ct)
150		\| None -> (None, v)
151		in aux t
152
153		and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr)
	139	let coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr)
154	140	: (EConstr.constr -> EConstr.constr) option
155	141	=
156	142	let open Context.Rel.Declaration in

367	353	Typeclasses.resolve_typeclasses
368	354	~filter:Typeclasses.no_goals ~split:true ~fail:false env evd
369	355
	356	type coercion_trace =
	357	\| IdCoe
	358	\| PrimProjCoe of {
	359	proj : Projection.Repr.t;
	360	args : econstr list;
	361	previous : coercion_trace;
	362	}
	363	\| Coe of {
	364	head : econstr;
	365	args : econstr list;
	366	previous : coercion_trace;
	367	}
	368	\| ProdCoe of { na : Name.t binder_annot; ty : econstr; dom : coercion_trace; body : coercion_trace }
	369
	370	let empty_coercion_trace = IdCoe
	371
	372	(* similar to iterated apply_coercion_args *)
	373	let rec reapply_coercions sigma trace c = match trace with
	374	\| IdCoe -> c
	375	\| PrimProjCoe { proj; args; previous } ->
	376	let c = reapply_coercions sigma previous c in
	377	let args = args@[c] in
	378	let head, args = match args with [] -> assert false \| hd :: tl -> hd, tl in
	379	applist (mkProj (Projection.make proj false, head), args)
	380	\| Coe {head; args; previous} ->
	381	let c = reapply_coercions sigma previous c in
	382	let args = args@[c] in
	383	applist (head, args)
	384	\| ProdCoe { na; ty; dom; body } ->
	385	let x = reapply_coercions sigma dom (mkRel 1) in
	386	let c = beta_applist sigma (lift 1 c, [x]) in
	387	let c = reapply_coercions sigma body c in
	388	mkLambda (na, ty, c)
	389
370	390	(* Apply coercion path from p to hj; raise NoCoercion if not applicable *)
371	391	let apply_coercion env sigma p hj typ_cl =
372	392	try
373		let j,t,evd =
	393	let j,t,trace,evd =
374	394	List.fold_left
375		(fun (ja,typ_cl,sigma) i ->
	395	(fun (ja,typ_cl,trace,sigma) i ->
376	396	let isid = i.coe_is_identity in
377	397	let isproj = i.coe_is_projection in
378	398	let sigma, c = new_global sigma i.coe_value in
379	399	let typ = Retyping.get_type_of env sigma c in
380	400	let fv = make_judge c typ in
381		let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in
382		let sigma, jres =
383		apply_coercion_args env sigma true isproj argl fv
	401	let argl = class_args_of env sigma typ_cl in
	402	let trace =
	403	if isid then trace
	404	else match isproj with
	405	\| None -> Coe {head=fv.uj_val;args=argl;previous=trace}
	406	\| Some proj ->
	407	let args = List.skipn (Projection.Repr.npars proj) argl in
	408	PrimProjCoe {proj; args; previous=trace }
384	409	in
385		(if isid then
	410	let argl = argl@[ja.uj_val] in
	411	let sigma, jres = apply_coercion_args env sigma true isproj argl fv in
	412	let jres =
	413	if isid then
386	414	{ uj_val = ja.uj_val; uj_type = jres.uj_type }
387	415	else
388		jres),
389		jres.uj_type,sigma)
390		(hj,typ_cl,sigma) p
391		in evd, j
	416	jres
	417	in
	418	jres, jres.uj_type, trace, sigma)
	419	(hj,typ_cl,IdCoe,sigma) p
	420	in evd, j, trace
392	421	with NoCoercion as e -> raise e
	422
	423	let mu env evdref t =
	424	let rec aux v =
	425	let v' = hnf env !evdref v in
	426	match disc_subset !evdref v' with
	427	\| Some (u, p) ->
	428	let f, ct, trace = aux u in
	429	let p = hnf_nodelta env !evdref p in
	430	let p1 = delayed_force sig_proj1 in
	431	let evd, p1 = Evarutil.new_global !evdref p1 in
	432	evdref := evd;
	433	(Some (fun x ->
	434	app_opt env evdref
	435	f (mkApp (p1, [\| u; p; x \|]))),
	436	ct,
	437	Coe {head=p1; args=[u;p]; previous=trace})
	438	\| None -> (None, v, IdCoe)
	439	in aux t
393	440
394	441	(* Try to coerce to a funclass; raise NoCoercion if not possible *)
395	442	let inh_app_fun_core ~program_mode env evd j =
396	443	let t = whd_all env evd j.uj_type in
397	444	match EConstr.kind evd t with
398		\| Prod _ -> (evd,j)
	445	\| Prod _ -> (evd,j,IdCoe)
399	446	\| Evar ev ->
400	447	let (evd',t) = Evardefine.define_evar_as_product env evd ev in
401		(evd',{ uj_val = j.uj_val; uj_type = t })
	448	(evd',{ uj_val = j.uj_val; uj_type = t },IdCoe)
402	449	\| _ ->
403	450	try let t,p =
404	451	lookup_path_to_fun_from env evd j.uj_type in

407	454	if program_mode then
408	455	try
409	456	let evdref = ref evd in
410		let coercef, t = mu env evdref t in
	457	let coercef, t, trace = mu env evdref t in
411	458	let res = { uj_val = app_opt env evdref coercef j.uj_val; uj_type = t } in
412		(!evdref, res)
	459	(!evdref, res, trace)
413	460	with NoSubtacCoercion \| NoCoercion ->
414		(evd,j)
	461	(evd,j,IdCoe)
415	462	else raise NoCoercion
416	463
417	464	(* Try to coerce to a funclass; returns [j] if no coercion is applicable *)

419	466	try inh_app_fun_core ~program_mode env evd j
420	467	with
421	468	\| NoCoercion when not resolve_tc
422		\|\| not (get_use_typeclasses_for_conversion ()) -> (evd, j)
	469	\|\| not (get_use_typeclasses_for_conversion ()) -> (evd, j, IdCoe)
423	470	\| NoCoercion ->
424	471	try inh_app_fun_core ~program_mode env (saturate_evd env evd) j
425		with NoCoercion -> (evd, j)
	472	with NoCoercion -> (evd, j, IdCoe)
426	473
427	474	let type_judgment env sigma j =
428	475	match EConstr.kind sigma (whd_all env sigma j.uj_type) with

432	479	let inh_tosort_force ?loc env evd j =
433	480	try
434	481	let t,p = lookup_path_to_sort_from env evd j.uj_type in
435		let evd,j1 = apply_coercion env evd p j t in
	482	let evd,j1,_trace = apply_coercion env evd p j t in
436	483	let j2 = Environ.on_judgment_type (whd_evar evd) j1 in
437	484	(evd,type_judgment env evd j2)
438	485	with Not_found \| NoCoercion ->

451	498	let inh_coerce_to_base ?loc ~program_mode env evd j =
452	499	if program_mode then
453	500	let evdref = ref evd in
454		let ct, typ' = mu env evdref j.uj_type in
	501	let ct, typ', trace = mu env evdref j.uj_type in
455	502	let res =
456	503	{ uj_val = (app_coercion env evdref ct j.uj_val);
457	504	uj_type = typ' }

461	508	let inh_coerce_to_prod ?loc ~program_mode env evd t =
462	509	if program_mode then
463	510	let evdref = ref evd in
464		let _, typ' = mu env evdref t in
	511	let _, typ', _trace = mu env evdref t in
465	512	!evdref, typ'
466	513	else (evd, t)
467	514

470	517	then
471	518	raise NoCoercion
472	519	else
473		let evd, v', t' =
	520	let evd, v', t', trace =
474	521	try
475	522	let t2,t1,p = lookup_path_between env evd (t,c1) in
476	523	match v with
477	524	\| Some v ->
478		let evd,j =
	525	let evd,j,trace =
479	526	apply_coercion env evd p
480	527	{uj_val = v; uj_type = t} t2 in
481		evd, Some j.uj_val, j.uj_type
482		\| None -> evd, None, t
	528	evd, Some j.uj_val, j.uj_type,trace
	529	\| None -> evd, None, t, IdCoe
483	530	with Not_found -> raise NoCoercion
484	531	in
485		try (unify_leq_delay ~flags env evd t' c1, v')
	532	try (unify_leq_delay ~flags env evd t' c1, v', trace)
486	533	with UnableToUnify _ -> raise NoCoercion
487	534
488	535	let default_flags_of env =
489	536	default_flags_of TransparentState.full
490	537
491	538	let rec inh_conv_coerce_to_fail ?loc env evd ?(flags=default_flags_of env) rigidonly v t c1 =
492		try (unify_leq_delay ~flags env evd t c1, v)
	539	try (unify_leq_delay ~flags env evd t c1, v, IdCoe)
493	540	with UnableToUnify (best_failed_evd,e) ->
494	541	try inh_coerce_to_fail flags env evd rigidonly v t c1
495	542	with NoCoercion ->

509	556	\| na -> na) name in
510	557	let open Context.Rel.Declaration in
511	558	let env1 = push_rel (LocalAssum (name,u1)) env in
512		let (evd', v1) =
	559	let (evd', v1, trace1) =
513	560	inh_conv_coerce_to_fail ?loc env1 evd rigidonly
514	561	(Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in
515	562	let v1 = Option.get v1 in

517	564	let t2 = match v2 with
518	565	\| None -> subst_term evd' v1 t2
519	566	\| Some v2 -> Retyping.get_type_of env1 evd' v2 in
520		let (evd'',v2') = inh_conv_coerce_to_fail ?loc env1 evd' rigidonly v2 t2 u2 in
521		(evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2')
	567	let (evd'',v2',trace2) = inh_conv_coerce_to_fail ?loc env1 evd' rigidonly v2 t2 u2 in
	568	let trace = ProdCoe { na=name; ty=u1; dom=trace1; body=trace2 } in
	569	(evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2', trace)
522	570	\| _ -> raise (NoCoercionNoUnifier (best_failed_evd,e))
523	571
524	572	(* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *)
525	573	let inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc rigidonly flags env evd cj t =
526		let (evd', val') =
	574	let (evd', val', otrace) =
527	575	try
528		inh_conv_coerce_to_fail ?loc env evd ~flags rigidonly (Some cj.uj_val) cj.uj_type t
	576	let (evd', val', trace) = inh_conv_coerce_to_fail ?loc env evd ~flags rigidonly (Some cj.uj_val) cj.uj_type t in
	577	(evd', val', Some trace)
529	578	with NoCoercionNoUnifier (best_failed_evd,e) ->
530	579	try
531	580	if program_mode then
532		coerce_itf ?loc env evd (Some cj.uj_val) cj.uj_type t
	581	let (evd', val') = coerce_itf ?loc env evd (Some cj.uj_val) cj.uj_type t in
	582	(evd', val', None)
533	583	else raise NoSubtacCoercion
534	584	with
535	585	\| NoSubtacCoercion when not resolve_tc \|\| not (get_use_typeclasses_for_conversion ()) ->

540	590	if evd' == evd then
541	591	error_actual_type ?loc env best_failed_evd cj t e
542	592	else
543		inh_conv_coerce_to_fail ?loc env evd' rigidonly (Some cj.uj_val) cj.uj_type t
	593	let (evd', val', trace) = inh_conv_coerce_to_fail ?loc env evd' rigidonly (Some cj.uj_val) cj.uj_type t in
	594	(evd', val', Some trace)
544	595	with NoCoercionNoUnifier (_evd,_error) ->
545	596	error_actual_type ?loc env best_failed_evd cj t e
546	597	in
547	598	let val' = match val' with Some v -> v \| None -> assert(false) in
548		(evd',{ uj_val = val'; uj_type = t })
	599	(evd',{ uj_val = val'; uj_type = t }, otrace)
549	600
550	601	let inh_conv_coerce_to ?loc ~program_mode resolve_tc env evd ?(flags=default_flags_of env) =
551	602	inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc false flags env evd

554	605
555	606	let inh_conv_coerces_to ?loc env evd ?(flags=default_flags_of env) t t' =
556	607	try
557		fst (inh_conv_coerce_to_fail ?loc env evd ~flags true None t t')
	608	pi1 (inh_conv_coerce_to_fail ?loc env evd ~flags true None t t')
558	609	with NoCoercion ->
559	610	evd (* Maybe not enough information to unify *)
560	611

-3

pretyping/coercion.mli less more

15	15
16	16	(** {6 Coercions. } *)
17	17
	18	type coercion_trace
	19
	20	val empty_coercion_trace : coercion_trace
	21
	22	val reapply_coercions : evar_map -> coercion_trace -> EConstr.t -> EConstr.t
	23
18	24	(** [inh_app_fun resolve_tc env isevars j] coerces [j] to a function; i.e. it
19	25	inserts a coercion into [j], if needed, in such a way it gets as
20	26	type a product; it returns [j] if no coercion is applicable.
21	27	resolve_tc=false disables resolving type classes (as the last
22	28	resort before failing) *)
23	29	val inh_app_fun : program_mode:bool -> bool ->
24		env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment
	30	env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment * coercion_trace
25	31
26	32	(** [inh_coerce_to_sort env isevars j] coerces [j] to a type; i.e. it
27	33	inserts a coercion into [j], if needed, in such a way it gets as

47	53
48	54	val inh_conv_coerce_to : ?loc:Loc.t -> program_mode:bool -> bool ->
49	55	env -> evar_map -> ?flags:Evarconv.unify_flags ->
50		unsafe_judgment -> types -> evar_map * unsafe_judgment
	56	unsafe_judgment -> types -> evar_map * unsafe_judgment * coercion_trace option
51	57
52	58	val inh_conv_coerce_rigid_to : ?loc:Loc.t -> program_mode:bool ->bool ->
53	59	env -> evar_map -> ?flags:Evarconv.unify_flags ->
54		unsafe_judgment -> types -> evar_map * unsafe_judgment
	60	unsafe_judgment -> types -> evar_map * unsafe_judgment * coercion_trace option
55	61
56	62	(** [inh_conv_coerces_to loc env isevars t t'] checks if an object of type [t]
57	63	is coercible to an object of type [t'] adding evar constraints if needed;

-2

pretyping/detyping.ml less more

454	454	(avoid', add_name_opt na' body t env) sigma c
455	455
456	456	let rec build_tree na isgoal e sigma ci cl =
457		let mkpat n rhs pl = DAst.make @@ PatCstr((ci.ci_ind,n+1),pl,update_name sigma na rhs) in
	457	let mkpat n rhs pl =
	458	let na = update_name sigma na rhs in
	459	na, DAst.make @@ PatCstr((ci.ci_ind,n+1),pl,na) in
458	460	let cnl = ci.ci_pp_info.cstr_tags in
459	461	List.flatten
460	462	(List.init (Array.length cl)

484	486	and contract_branch isgoal e sigma (cdn,mkpat,rhs) =
485	487	let nal,rhs = decomp_branch cdn [] isgoal e sigma rhs in
486	488	let mat = align_tree nal isgoal rhs sigma in
487		List.map (fun (ids,hd,rhs) -> ids,mkpat rhs hd,rhs) mat
	489	List.map (fun (ids,hd,rhs) ->
	490	let na, pat = mkpat rhs hd in
	491	(Nameops.Name.fold_right Id.Set.add na ids, pat, rhs)) mat
488	492
489	493	(**********************************************************************)
490	494	(* Transform internal representation of pattern-matching into list of *)

+66

-45

pretyping/pretyping.ml less more

358	358
359	359	(* coerce to tycon if any *)
360	360	let inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma j = function
361		\| None -> sigma, j
	361	\| None -> sigma, j, Some Coercion.empty_coercion_trace
362	362	\| Some t ->
363	363	Coercion.inh_conv_coerce_to ?loc ~program_mode resolve_tc !!env sigma j t
364	364

481	481	(* in environment [env], with existential variables [sigma] and *)
482	482	(* the type constraint tycon *)
483	483
	484	let discard_trace (sigma,t,otrace) = sigma, t
	485
484	486	let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma : evar_map) t =
485	487	let inh_conv_coerce_to_tycon ?loc = inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc in
486	488	let pretype_type = pretype_type ~program_mode ~poly resolve_tc in

490	492	match DAst.get t with
491	493	\| GRef (ref,u) ->
492	494	let sigma, t_ref = pretype_ref ?loc sigma env ref u in
493		inh_conv_coerce_to_tycon ?loc env sigma t_ref tycon
	495	discard_trace @@ inh_conv_coerce_to_tycon ?loc env sigma t_ref tycon
494	496
495	497	\| GVar id ->
496	498	let sigma, t_id = pretype_id (fun e r t -> pretype tycon e r t) loc env sigma id in
497		inh_conv_coerce_to_tycon ?loc env sigma t_id tycon
	499	discard_trace @@ inh_conv_coerce_to_tycon ?loc env sigma t_id tycon
498	500
499	501	\| GEvar (id, inst) ->
500	502	(* Ne faudrait-il pas s'assurer que hyps est bien un

507	509	let sigma, args = pretype_instance ~program_mode ~poly resolve_tc env sigma loc hyps evk inst in
508	510	let c = mkEvar (evk, args) in
509	511	let j = Retyping.get_judgment_of !!env sigma c in
510		inh_conv_coerce_to_tycon ?loc env sigma j tycon
	512	discard_trace @@ inh_conv_coerce_to_tycon ?loc env sigma j tycon
511	513
512	514	\| GPatVar kind ->
513	515	let sigma, ty =

631	633	iraise (e, info));
632	634	make_judge (mkCoFix cofix) ftys.(i)
633	635	in
634		inh_conv_coerce_to_tycon ?loc env sigma fixj tycon
	636	discard_trace @@ inh_conv_coerce_to_tycon ?loc env sigma fixj tycon
635	637
636	638	\| GSort s ->
637	639	let sigma, j = pretype_sort ?loc sigma s in
638		inh_conv_coerce_to_tycon ?loc env sigma j tycon
	640	discard_trace @@ inh_conv_coerce_to_tycon ?loc env sigma j tycon
639	641
640	642	\| GApp (f,args) ->
641	643	let sigma, fj = pretype empty_tycon env sigma f in
642	644	let floc = loc_of_glob_constr f in
643	645	let length = List.length args in
644	646	let nargs_before_bidi =
	647	if Option.is_empty tycon then length
	648	(* We apply bidirectionality hints only if an expected type is specified *)
	649	else
645	650	(* if `f` is a global, we retrieve bidirectionality hints *)
646		try
647		let (gr,_) = destRef sigma fj.uj_val in
648		Option.default length @@ GlobRef.Map.find_opt gr !bidi_hints
649		with DestKO ->
650		length
	651	try
	652	let (gr,_) = destRef sigma fj.uj_val in
	653	Option.default length @@ GlobRef.Map.find_opt gr !bidi_hints
	654	with DestKO ->
	655	length
651	656	in
652	657	let candargs =
653	658	(* Bidirectional typechecking hint:

684	689	else fun f v -> applist (f, [v])
685	690	\| _ -> fun _ f v -> applist (f, [v])
686	691	in
687		let rec apply_rec env sigma n resj candargs bidiargs = function
688		\| [] -> sigma, resj, List.rev bidiargs
	692	let refresh_template env sigma resj =
	693	(* Special case for inductive type applications that must be
	694	refreshed right away. *)
	695	match EConstr.kind sigma resj.uj_val with
	696	\| App (f,args) ->
	697	if Termops.is_template_polymorphic_ind !!env sigma f then
	698	let c = mkApp (f, args) in
	699	let sigma, c = Evarsolve.refresh_universes (Some true) !!env sigma c in
	700	let t = Retyping.get_type_of !!env sigma c in
	701	sigma, make_judge c (* use this for keeping evars: resj.uj_val *) t
	702	else sigma, resj
	703	\| _ -> sigma, resj
	704	in
	705	let rec apply_rec env sigma n resj resj_before_bidi candargs bidiargs = function
	706	\| [] -> sigma, resj, resj_before_bidi, List.rev bidiargs
689	707	\| c::rest ->
690	708	let bidi = n >= nargs_before_bidi in
691	709	let argloc = loc_of_glob_constr c in
692		let sigma, resj = Coercion.inh_app_fun ~program_mode resolve_tc !!env sigma resj in
	710	let sigma, resj, trace = Coercion.inh_app_fun ~program_mode resolve_tc !!env sigma resj in
693	711	let resty = whd_all !!env sigma resj.uj_type in
694	712	match EConstr.kind sigma resty with
695	713	\| Prod (na,c1,c2) ->
696		let tycon = Some c1 in
697	714	let (sigma, hj), bidiargs =
698		if bidi && Option.has_some tycon then
	715	if bidi then
699	716	(* We want to get some typing information from the context before
700	717	typing the argument, so we replace it by an existential
701	718	variable *)
702	719	let sigma, c_hole = new_evar env sigma ~src:(loc,Evar_kinds.InternalHole) c1 in
703		(sigma, make_judge c_hole c1), (c_hole, c) :: bidiargs
704		else pretype tycon env sigma c, bidiargs
	720	(sigma, make_judge c_hole c1), (c_hole, c, trace) :: bidiargs
	721	else
	722	let tycon = Some c1 in
	723	pretype tycon env sigma c, bidiargs
705	724	in
706	725	let sigma, candargs, ujval =
707	726	match candargs with

716	735	in
717	736	let sigma, ujval = adjust_evar_source sigma na.binder_name ujval in
718	737	let value, typ = app_f n (j_val resj) ujval, subst1 ujval c2 in
719		let j = { uj_val = value; uj_type = typ } in
720		apply_rec env sigma (n+1) j candargs bidiargs rest
	738	let resj = { uj_val = value; uj_type = typ } in
	739	let resj_before_bidi = if bidi then resj_before_bidi else resj in
	740	apply_rec env sigma (n+1) resj resj_before_bidi candargs bidiargs rest
721	741	\| _ ->
722	742	let sigma, hj = pretype empty_tycon env sigma c in
723	743	error_cant_apply_not_functional
724	744	?loc:(Loc.merge_opt floc argloc) !!env sigma resj [\|hj\|]
725	745	in
726		let sigma, resj, bidiargs = apply_rec env sigma 0 fj candargs [] args in
727		let sigma, resj =
728		match EConstr.kind sigma resj.uj_val with
729		\| App (f,args) ->
730		if Termops.is_template_polymorphic_ind !!env sigma f then
731		(* Special case for inductive type applications that must be
732		refreshed right away. *)
733		let c = mkApp (f, args) in
734		let sigma, c = Evarsolve.refresh_universes (Some true) !!env sigma c in
735		let t = Retyping.get_type_of !!env sigma c in
736		sigma, make_judge c (* use this for keeping evars: resj.uj_val *) t
737		else sigma, resj
738		\| _ -> sigma, resj
739		in
740		let sigma, t = inh_conv_coerce_to_tycon ?loc env sigma resj tycon in
741		let refine_arg sigma (newarg,origarg) =
	746	let sigma, resj, resj_before_bidi, bidiargs = apply_rec env sigma 0 fj fj candargs [] args in
	747	let sigma, resj = refresh_template env sigma resj in
	748	let sigma, resj, otrace = inh_conv_coerce_to_tycon ?loc env sigma resj tycon in
	749	let refine_arg n (sigma,t) (newarg,origarg,trace) =
742	750	(* Refine an argument (originally `origarg`) represented by an evar
743	751	(`newarg`) to use typing information from the context *)
744	752	(* Recover the expected type of the argument *)

747	755	let sigma, j = pretype (Some ty) env sigma origarg in
748	756	(* Unify the (possibly refined) existential variable with the
749	757	(typechecked) original value *)
750		Evarconv.unify_delay !!env sigma newarg (j_val j)
	758	let sigma = Evarconv.unify_delay !!env sigma newarg (j_val j) in
	759	sigma, app_f n (Coercion.reapply_coercions sigma trace t) (j_val j)
751	760	in
752	761	(* We now refine any arguments whose typing was delayed for
753	762	bidirectionality *)
754		let sigma = List.fold_left refine_arg sigma bidiargs in
755		(sigma, t)
	763	let t = resj_before_bidi.uj_val in
	764	let sigma, t = List.fold_left_i refine_arg nargs_before_bidi (sigma,t) bidiargs in
	765	(* If we did not get a coercion trace (e.g. with `Program` coercions, we
	766	replaced user-provided arguments with inferred ones. Otherwise, we apply
	767	the coercion trace to the user-provided arguments. *)
	768	let resj =
	769	match otrace with
	770	\| None -> resj
	771	\| Some trace ->
	772	let resj = { resj with uj_val = t } in
	773	let sigma, resj = refresh_template env sigma resj in
	774	{ resj with uj_val = Coercion.reapply_coercions sigma trace t }
	775	in
	776	(sigma, resj)
756	777
757	778	\| GLambda(name,bk,c1,c2) ->
758	779	let sigma, tycon' =

772	793	let sigma, j' = pretype rng env' sigma c2 in
773	794	let name = get_name var' in
774	795	let resj = judge_of_abstraction !!env (orelse_name name name'.binder_name) j j' in
775		inh_conv_coerce_to_tycon ?loc env sigma resj tycon
	796	discard_trace @@ inh_conv_coerce_to_tycon ?loc env sigma resj tycon
776	797
777	798	\| GProd(name,bk,c1,c2) ->
778	799	let sigma, j = pretype_type empty_valcon env sigma c1 in

795	816	let (e, info) = CErrors.push e in
796	817	let info = Option.cata (Loc.add_loc info) info loc in
797	818	iraise (e, info) in
798		inh_conv_coerce_to_tycon ?loc env sigma resj tycon
	819	discard_trace @@ inh_conv_coerce_to_tycon ?loc env sigma resj tycon
799	820
800	821	\| GLetIn(name,c1,t,c2) ->
801	822	let sigma, tycon1 =

972	993	mkCase (ci, pred, cj.uj_val, [\|b1;b2\|])
973	994	in
974	995	let cj = { uj_val = v; uj_type = p } in
975		inh_conv_coerce_to_tycon ?loc env sigma cj tycon
	996	discard_trace @@ inh_conv_coerce_to_tycon ?loc env sigma cj tycon
976	997
977	998	\| GCases (sty,po,tml,eqns) ->
978	999	Cases.compile_cases ?loc ~program_mode sty (pretype, sigma) tycon env (po,tml,eqns)

1016	1037	in
1017	1038	let v = mkCast (cj.uj_val, k, tval) in
1018	1039	sigma, { uj_val = v; uj_type = tval }
1019		in inh_conv_coerce_to_tycon ?loc env sigma cj tycon
	1040	in discard_trace @@ inh_conv_coerce_to_tycon ?loc env sigma cj tycon
1020	1041
1021	1042	\| GInt i ->
1022	1043	let resj =

1024	1045	with Invalid_argument _ ->
1025	1046	user_err ?loc ~hdr:"pretype" (str "Type of int63 should be registered first.")
1026	1047	in
1027		inh_conv_coerce_to_tycon ?loc env sigma resj tycon
	1048	discard_trace @@ inh_conv_coerce_to_tycon ?loc env sigma resj tycon
1028	1049	\| GFloat f ->
1029	1050	let resj =
1030	1051	try Typing.judge_of_float !!env f
1031	1052	with Invalid_argument _ ->
1032	1053	user_err ?loc ~hdr:"pretype" (str "Type of float should be registered first.")
1033	1054	in
1034		inh_conv_coerce_to_tycon ?loc env sigma resj tycon
	1055	discard_trace @@ inh_conv_coerce_to_tycon ?loc env sigma resj tycon
1035	1056
1036	1057	and pretype_instance ~program_mode ~poly resolve_tc env sigma loc hyps evk update =
1037	1058	let f decl (subst,update,sigma) =

-1

pretyping/unification.ml less more

1289	1289
1290	1290	let try_to_coerce env evd c cty tycon =
1291	1291	let j = make_judge c cty in
1292		let (evd',j') = inh_conv_coerce_rigid_to ~program_mode:false true env evd j tycon in
	1292	let (evd',j',_trace) = inh_conv_coerce_rigid_to ~program_mode:false true env evd j tycon in
1293	1293	let evd' = Evarconv.solve_unif_constraints_with_heuristics env evd' in
1294	1294	let evd' = Evd.map_metas_fvalue (fun c -> nf_evar evd' c) evd' in
1295	1295	(evd',j'.uj_val)

-2

printing/ppconstr.ml less more

273	273	pr_reference r, latom
274	274
275	275	\| CPatOr pl ->
276		let pp = pr_patt mt (lpator,Any) in
	276	let pp p = hov 0 (pr_patt mt (lpator,Any) p) in
277	277	surround (hov 0 (prlist_with_sep pr_spcbar pp pl)), lpator
278	278
279	279	\| CPatNotation ((_,"( _ )"),([p],[]),[]) ->

302	302	spc() ++ hov 4
303	303	(pr_with_comments ?loc
304	304	(str "\| " ++
305		hov 0 (prlist_with_sep pr_spcbar (prlist_with_sep sep_v (pr_patt ltop)) pl
	305	hov 0 (prlist_with_sep pr_spcbar
	306	(fun p -> hov 0 (prlist_with_sep sep_v (pr_patt ltop) p)) pl
306	307	++ str " =>") ++
307	308	pr_sep_com spc (pr ltop) rhs))
308	309

-1

proofs/clenv.ml less more

677	677	let t = Retyping.get_type_of env sigma ev in
678	678	let ty = Retyping.get_type_of env sigma c in
679	679	let j = Environ.make_judge c ty in
680		let (sigma, j) = Coercion.inh_conv_coerce_to ~program_mode:false true env sigma j t in
	680	let (sigma, j, _trace) = Coercion.inh_conv_coerce_to ~program_mode:false true env sigma j t in
681	681	let (ev, _) = destEvar sigma ev in
682	682	let sigma = Evd.define ev j.Environ.uj_val sigma in
683	683	sigma

-1

proofs/clenvtac.ml less more

71	71	Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars
72	72	~fail:(not with_evars) clenv.env clenv.evd
73	73	in
74		Typeclasses.make_unresolvables (fun x -> List.mem_f Evar.equal x evars) evd'
	74	(* After an apply, all the subgoals including those dependent shelved ones are in
	75	the hands of the user and resolution won't be called implicitely on them. *)
	76	Typeclasses.make_unresolvables (fun x -> true) evd'
75	77	else clenv.evd
76	78	in
77	79	let clenv = { clenv with evd = evd' } in

-6

proofs/proof.ml less more

385	385	let sigma = Proofview.return proofview in
386	386	let to_shelve = undef sigma to_shelve in
387	387	let shelf = (undef sigma pr.shelf)@retrieved@to_shelve in
388		let proofview =
389		List.fold_left
390		Proofview.Unsafe.mark_as_unresolvable
391		proofview
392		to_shelve
393		in
	388	let proofview = Proofview.Unsafe.mark_as_unresolvables proofview to_shelve in
394	389	let given_up = pr.given_up@give_up in
395	390	let proofview = Proofview.Unsafe.reset_future_goals proofview in
396	391	{ pr with proofview ; shelf ; given_up },(status,info_trace),result

-0

proofs/refine.ml less more

93	93	in
94	94	(* Mark goals *)
95	95	let sigma = Proofview.Unsafe.mark_as_goals sigma comb in
	96	let sigma = Proofview.Unsafe.mark_unresolvables sigma shelf in
96	97	let comb = CList.map (fun x -> Proofview.goal_with_state x state) comb in
97	98	let trace env sigma = Pp.(hov 2 (str"simple refine"++spc()++
98	99	Termops.Internal.print_constr_env env sigma c)) in

-1

proofs/refine.mli less more

24	24	for the current goal (refine is a goal-dependent tactic), the
25	25	new holes created by [t] become the new subgoals. Exceptions
26	26	raised during the interpretation of [t] are caught and result in
27		tactic failures. If [typecheck] is [true] [t] is type-checked beforehand. *)
	27	tactic failures. If [typecheck] is [true] [t] is type-checked beforehand.
	28	Shelved evars and goals are all marked as unresolvable for typeclasses. *)
28	29
29	30	val generic_refine : typecheck:bool -> ('a * EConstr.t) tactic ->
30	31	Proofview.Goal.t -> 'a tactic

-1

tactics/declare.ml less more

361	361	classify_function = (fun () -> Dispose)}
362	362
363	363	let declare_variable ~name ~kind d =
364		(* Constr raisonne sur les noms courts *)
	364	(* Variables are distinguished by only short names *)
365	365	if Decls.variable_exists name then
366	366	raise (AlreadyDeclared (None, name));
367	367

+70

-30

tactics/tactics.ml less more

2976	2976
2977	2977	(* Modifying/Adding an hypothesis *)
2978	2978
	2979	(* This applies (f i) to all elements of ctxt where the debrujn i is
	2980	free (so it is lifted at each level). *)
	2981	let rec map_rel_context_lift f env i (ctxt:EConstr.rel_context):EConstr.rel_context =
	2982	match ctxt with
	2983	\| [] -> ctxt
	2984	\| decl::ctxt' -> f i decl :: map_rel_context_lift f env (i+1) ctxt'
	2985
2979	2986	(* Instantiating some arguments (whatever their position) of an hypothesis
2980	2987	or any term, leaving other arguments quantified. If operating on an
2981	2988	hypothesis of the goal, the new hypothesis replaces it.
2982	2989
2983	2990	(c,lbind) are supposed to be of the form
2984		((t t1 t2 ... tm) , someBindings)
2985
2986		in which case we pose a proof with body
2987
2988		(fun y1...yp => H t1 t2 ... tm u1 ... uq) where yi are the
2989		remaining arguments of H that lbind could not resolve, ui are a mix
2990		of inferred args and yi. The overall effect is to remove from H as
2991		much quantification as possible given lbind. *)
	2991	((H t1 t2 ... tm) , someBindings)
	2992	whete t1..tn are user given args, to which someBinding must be combined.
	2993
	2994	The goal is to pose a proof with body
	2995
	2996	(fun y1...yp => H t1 t2 ... tm u1 ... uq)
	2997
	2998	where yi are the remaining arguments of H that lbind could not
	2999	solve, ui are a mix of inferred args and yi. The overall effect
	3000	is to remove from H as much quantification as possible given
	3001	lbind. *)
	3002
2992	3003	let specialize (c,lbind) ipat =
2993	3004	Proofview.Goal.enter begin fun gl ->
2994	3005	let env = Proofview.Goal.env gl in
2995	3006	let sigma = Proofview.Goal.sigma gl in
2996		let sigma, term =
	3007	let typ_of_c = Retyping.get_type_of env sigma c in
	3008	let sigma, term, typ =
2997	3009	if lbind == NoBindings then
2998		sigma, c
	3010	sigma, c, typ_of_c
2999	3011	else
3000		let typ_of_c = Retyping.get_type_of env sigma c in
	3012	(* *** SOLVING ARGS ***** *)
3001	3013	(* If the term is lambda then we put a letin to put avoid
3002	3014	interaction between the term and the bindings. *)
3003	3015	let c = match EConstr.kind sigma c with

3009	3021	let clause = clenv_unify_meta_types ~flags clause in
3010	3022	let sigma = clause.evd in
3011	3023	let (thd,tstack) = whd_nored_stack sigma (clenv_value clause) in
3012		let c_hd , c_args = decompose_app sigma c in
	3024	(* The completely applied term is (thd tstack), but tstack may
	3025	contain unsolved metas, so now we must reabstract them
	3026	args with there name to have
	3027	fun unsolv1 unsolv2 ... => (thd tstack_with _rels)
	3028	Note: letins have been reudced, they are not present in tstack *)
	3029	(* **** REBUILDING UNSOLVED FORALLs **** *)
	3030	(* thd is the thing to which we reapply everything, solved or
	3031	unsolved, unsolved things are requantified too *)
3013	3032	let liftrel x =
3014	3033	match kind sigma x with
3015	3034	\| Rel n -> mkRel (n+1)
3016	3035	\| _ -> x in
3017	3036	(* We grab names used in product to remember them at re-abstracting phase *)
3018		let typ_of_c_hd = pf_get_type_of gl c_hd in
3019		let lprod, concl = decompose_prod_assum sigma typ_of_c_hd in
3020		(* accumulator args: arguments to apply to c_hd: all inferred
3021		args + re-abstracted rels *)
3022		let rec rebuild_lambdas sigma lprd args hd l =
	3037	let typ_of_c_hd = pf_get_type_of gl thd in
	3038	let (lprod:rel_context), concl = decompose_prod_assum sigma typ_of_c_hd in
	3039	(* lprd = initial products (including letins).
	3040	l(tstack initially) = the same products after unification vs lbind (some metas remain)
	3041	args: accumulator : args to apply to hd: inferred args + metas reabstracted *)
	3042	let rec rebuild sigma concl (lprd:rel_context) (accargs:EConstr.t list)
	3043	(accprods:rel_context) hd (l:EConstr.t list) =
	3044	let open Context.Rel.Declaration in
3023	3045	match lprd , l with
3024		\| _, [] -> sigma,applist (hd, (List.map (nf_evar sigma) args))
3025		\| Context.Rel.Declaration.LocalAssum(nme,_)::lp' , t::l' when occur_meta sigma t ->
	3046	\| _, [] -> sigma
	3047	, applist (hd, (List.map (nf_evar sigma) (List.rev accargs)))
	3048	, EConstr.it_mkProd_or_LetIn concl accprods
	3049	\| (LocalAssum(nme,_) as assum)::lp' , t::l' when occur_meta sigma t ->
3026	3050	(* nme has not been resolved, let us re-abstract it. Same
3027	3051	name but type updated by instantiation of other args. *)
3028	3052	let sigma,new_typ_of_t = Typing.type_of clause.env sigma t in
3029	3053	let r = Retyping.relevance_of_type env sigma new_typ_of_t in
3030		let liftedargs = List.map liftrel args in
3031	3054	(* lifting rels in the accumulator args *)
3032		let sigma,hd' = rebuild_lambdas sigma lp' (liftedargs@[mkRel 1 ]) hd l' in
	3055	let liftedargs = List.map liftrel accargs in
	3056	let sigma,hd',prods =
	3057	rebuild sigma concl lp' (mkRel 1 ::liftedargs) (assum::accprods) hd l' in
3033	3058	(* replace meta variable by the abstracted variable *)
3034	3059	let hd'' = subst_term sigma t hd' in
3035		(* lambda expansion *)
3036		sigma,mkLambda ({nme with binder_relevance=r},new_typ_of_t,hd'')
3037		\| Context.Rel.Declaration.LocalAssum _::lp' , t::l' ->
3038		let sigma,hd' = rebuild_lambdas sigma lp' (args@[t]) hd l' in
3039		sigma,hd'
	3060	(* we reabstract the non solved argument *)
	3061	sigma,mkLambda ({nme with binder_relevance=r},new_typ_of_t,hd''),prods
	3062	\| (LocalAssum (nme,tnme))::lp' , t::l' ->
	3063	(* thie arg was solved, we update thing accordingly *)
	3064	(* we replace in lprod the arg by rel 1 *)
	3065	let substlp' = (* rel 1 must be lifted along the context *)
	3066	map_rel_context_lift (fun i x -> map_constr (replace_term sigma (mkRel i) t) x)
	3067	env 1 lp' in
	3068	(* Then we lift every rel above the just removed arg *)
	3069	let updatedlp' =
	3070	map_rel_context_lift (fun i x -> map_constr (liftn (-1) i) x) env 1 substlp' in
	3071	(* We replace also the term in the conclusion, its rel index is the
	3072	length of the list lprd (remaining products before concl) *)
	3073	let concl'' = replace_term sigma (mkRel (List.length lprd)) t concl in
	3074	(* we also lift in concl the index above the arg *)
	3075	let concl' = liftn (-1) (List.length lprd) concl'' in
	3076	rebuild sigma concl' updatedlp' (t::accargs) accprods hd l'
	3077	\| LocalDef _ as assum::lp' , _ ->
	3078	(* letins have been reduced in l and should anyway not correspond to an arg, we
	3079	ignore them, but we remember them in accprod, so that they remain in the type. *)
	3080	rebuild sigma concl lp' accargs (assum::accprods) hd l
3040	3081	\| _ ,_ -> assert false in
3041		let sigma,hd = rebuild_lambdas sigma (List.rev lprod) [] c_hd tstack in
3042		Evd.clear_metas sigma, hd
3043		in
3044		let typ = Retyping.get_type_of env sigma term in
	3082	let sigma,hd,newtype = rebuild sigma concl (List.rev lprod) [] [] thd tstack in
	3083	Evd.clear_metas sigma, hd, newtype
	3084	in
3045	3085	let tac =
3046	3086	match EConstr.kind sigma (fst(EConstr.decompose_app sigma (snd(EConstr.decompose_lam_assum sigma c)))) with
3047	3087	\| Var id when Id.List.mem id (Tacmach.New.pf_ids_of_hyps gl) ->

-2

test-suite/Makefile less more

70	70	get_set_impredicativity= $(filter "-impredicative-set",$(call get_coq_prog_args,$(1)))
71	71
72	72	bogomips:=
	73	ifeq (win32,$(ARCH))
	74	$(warning windows detected: skipping complexity tests)
	75	else
73	76	ifneq (,$(wildcard /proc/cpuinfo))
74	77	sedbogo := -e "s/bogomips.: $[0-9]$.*/\1/p" # i386, ppc
75	78	sedbogo += -e "s/Cpu0Bogo.: $[0-9]$.*/\1/p" # sparc

79	82
80	83	ifeq (,$(bogomips))
81	84	$(warning cannot run complexity tests (no bogomips found))
	85	endif
82	86	endif
83	87
84	88	# keep these synced with test-suite/save-logs.sh

524	528	$(HIDE){ \
525	529	echo $(call log_intro,$<); \
526	530	true "extract effective user time"; \
527		res=`$(coqc_interactive) "$<" $(call get_coq_prog_args,"$<") 2>&1 \| sed -n -e "s/Finished transaction in .($[0-9]\.[0-9]$u.)/\1/p" \| head -1`; \
	531	res=`$(coqc_interactive) "$<" $(call get_coq_prog_args,"$<") 2>&1 \| sed -n -e "s/Finished .transaction in .($[0-9]\.[0-9]$u.*)/\1/p" \| head -1`; \
528	532	R=$$?; times; \
529	533	if [ $$R != 0 ]; then \
530	534	echo $(log_failure); \
531	535	echo " $<...Error! (should be accepted)" ; \
	536	$(FAIL); \
532	537	elif [ "$$res" = "" ]; then \
533	538	echo $(log_failure); \
534	539	echo " $<...Error! (couldn't find a time measure)"; \
	540	$(FAIL); \
535	541	else \
536	542	true "express effective time in centiseconds"; \
537	543	res=`echo "$$res"00 \| sed -n -e "s/$[0-9]$\.$[0-9][0-9]$./\1\2/p"`; \

627	633	%.vio.log:%.v
628	634	@echo "TEST $<"
629	635	$(HIDE){ \
630		$(coqc) -quick -R vio vio $* 2>&1 && \
	636	$(coqc) -vio -R vio vio $* 2>&1 && \
631	637	$(coqc) -R vio vio -vio2vo $*.vio 2>&1 && \
632	638	$(coqchk) -R vio vio -norec $(subst /,.,$*) 2>&1; \
633	639	if [ $$? = 0 ]; then \

+11

-0

test-suite/bugs/bug_11140.v less more

	0	Axiom T : nat -> Prop.
	1	Axiom f : forall x, T x.
	2	Arguments f & x.
	3
	4	Lemma test : (f (1 + _) : T 2) = f 2.
	5	match goal with
	6	\| \|- (f (1 + 1) = f 2) => idtac
	7	\| \|- (f 2 = f 2) => fail (* Issue 11140 *)
	8	\| \|- _ => fail
	9	end.
	10	Abort.

-0

test-suite/bugs/bug_9490.v less more

	0	Declare Custom Entry with_pattern.
	1	Declare Custom Entry M_branch.
	2	Notation "'with' \| p1 \| .. \| pn 'end'" :=
	3	(cons p1 (.. (cons pn nil) ..))
	4	(in custom with_pattern at level 91, p1 custom M_branch at level 202, pn custom M_branch at level 202).
	5	Notation "'bla'" := I (in custom M_branch at level 202).
	6	Notation "'[use_with' l ]" := (l) (at level 0, l custom with_pattern at level 91).
	7	Check [use_with with \| bla end].
	8	Check [use_with with \| bla \| bla end].

+12

-0

test-suite/bugs/bug_9532.v less more

	0	Declare Custom Entry atom.
	1	Notation "1" := tt (in custom atom).
	2	Notation "atom:( s )" := s (s custom atom).
	3
	4	Declare Custom Entry expr.
	5	Notation "expr:( s )" := s (s custom expr).
	6	Notation "( x , y , .. , z )" := (@cons unit x (@cons unit y .. (@cons unit z (@nil unit)) ..))
	7	(in custom expr at level 0, x custom atom, y custom atom, z custom atom).
	8
	9	Check atom:(1).
	10	Check expr:((1,1)).
	11	Check expr:((1,1,1)).

+35

-0

test-suite/bugs/closed/bug_10298.v less more

	0	Set Implicit Arguments.
	1
	2	Generalizable Variables A.
	3
	4	Parameter val : Type.
	5
	6	Class Enc (A:Type) :=
	7	make_Enc { enc : A -> val }.
	8
	9	Global Instance Enc_dummy : Enc unit.
	10	Admitted.
	11
	12	Definition FORM := forall A (EA:Enc A) (Q:A->Prop), Prop.
	13
	14	Axiom FORM_intro : forall F : FORM, F unit Enc_dummy (fun _ : unit => True).
	15
	16	Definition IDF (F:FORM) : FORM := F.
	17
	18	Parameter ID : forall (G:Prop), G -> G.
	19
	20	Parameter EID : forall A (EA:Enc A) (F:FORM) (Q:A->Prop),
	21	F _ _ Q ->
	22	F _ _ Q.
	23
	24	Lemma bla : forall F,
	25	(forall A (EA:Enc A), IDF F EA (fun (X:A) => True) -> True) ->
	26	True.
	27	Proof.
	28	intros F M.
	29	notypeclasses refine (M _ _ _).
	30	notypeclasses refine (EID _ _ _ _).
	31	eapply (ID _).
	32	Unshelve.
	33	+ apply FORM_intro.
	34	Qed.

+30

-0

test-suite/bugs/closed/bug_10762.v less more

	0
	1	Set Implicit Arguments.
	2
	3	Generalizable Variables A B.
	4	Parameter val: Type.
	5
	6	Class Enc (A:Type) : Type :=
	7	make_Enc { enc : A -> val }.
	8
	9	Hint Mode Enc + : typeclass_instances.
	10
	11	Parameter bar : forall A (EA:Enc A), EA = EA.
	12
	13	Parameter foo : forall (P:Prop),
	14	P ->
	15	P = P ->
	16	True.
	17
	18	Parameter id : forall (P:Prop),
	19	P -> P.
	20
	21	Check enc.
	22
	23	Lemma test : True.
	24	eapply foo; [ eapply bar \| apply id]. apply id.
	25	(* eapply bar introduces an unresolved typeclass evar that is no longer
	26	a candidate after the application (eapply should leave typeclass goals shelved).
	27	We ensure that this happens also _across_ goals in `[ \| ]` and not only at `.`..
	28	*)
	29	Abort.

+10

-0

test-suite/bugs/closed/bug_11321.v less more

	0	Require Import Cyclic63.
	1
	2	Goal False.
	3	Proof.
	4	assert (4294967296 *c 2147483648 = WW 2 0)%int63 as H.
	5	vm_cast_no_check (@eq_refl (zn2z int) (WW 2 0)%int63).
	6	generalize (f_equal (zn2z_to_Z wB to_Z) H).
	7	now rewrite mulc_WW_spec.
	8	Fail Qed.
	9	Abort.

-0

test-suite/bugs/closed/bug_11360.v less more

	0	Section S.
	1	Variable (A:Type).
	2	#[universes(template)]
	3	Inductive bar (d:A) := .
	4	End S.
	5	Check bar nat 0.

-0

test-suite/bugs/closed/bug_11421.v less more

Fail Definition plus1_plus1 : Type@{Set+1} := Type@{Set+1}.

-0

test-suite/coq-makefile/findlib-package-unpacked/Makefile.local less more

CAMLPKGS += -package foo

+10

-0

test-suite/coq-makefile/findlib-package-unpacked/_CoqProject less more

	0	-R src test
	1	-R theories test
	2	-I src
	3
	4	src/test_plugin.mllib
	5	src/test.mlg
	6	src/test.mli
	7	src/test_aux.ml
	8	src/test_aux.mli
	9	theories/test.v

-0

test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/META less more

	0	archive(byte)="foo.cma"
	1	archive(native)="foo.cmxa"
	2	linkopts="-linkall"
	3	requires="str"

+14

-0

test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/Makefile less more

	0	-include ../../Makefile.conf
	1
	2	CO="$(COQMF_OCAMLFIND)" opt
	3	CB="$(COQMF_OCAMLFIND)" ocamlc
	4
	5	all:
	6	$(CO) -c foolib.ml
	7	$(CO) -a foolib.cmx -o foo.cmxa
	8	$(CB) -c foolib.ml
	9	$(CB) -a foolib.cmo -o foo.cma
	10	$(CB) -c foo.mli # empty .mli file, to be understood
	11
	12	clean:
	13	rm -f .cmo .cma .cmx .cmxa .cmi .o *.a

-0

test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/foo.mli less more

(New empty file)

-0

test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/foolib.ml less more

	0	let foo () =
	1	assert(Str.search_forward (Str.regexp "foo") "barfoobar" 0 = 3)

+20

-0

test-suite/coq-makefile/findlib-package-unpacked/run.sh less more

	0	#!/usr/bin/env bash
	1
	2	. ../template/init.sh
	3	mv src/test_plugin.mlpack src/test_plugin.mllib
	4
	5	echo "let () = Foolib.foo ();;" >> src/test_aux.ml
	6	export OCAMLPATH=$OCAMLPATH:$PWD/findlib
	7	if which cygpath 2>/dev/null; then
	8	# the only way I found to pass OCAMLPATH on win is to have it contain
	9	# only one entry
	10	OCAMLPATH=$(cygpath -w "$PWD"/findlib)
	11	export OCAMLPATH
	12	fi
	13	make -C findlib/foo clean
	14	coq_makefile -f _CoqProject -o Makefile
	15	cat Makefile.conf
	16	cat Makefile.local
	17	make -C findlib/foo
	18	make
	19	make byte

-0

test-suite/coq-makefile/timing/precomputed-time-tests/run.sh less more

8	8
9	9	./001-correct-diff-sorting-order/run.sh
10	10	./002-single-file-sorting/run.sh
	11	./003-non-utf8/run.sh

+39

-0

test-suite/coqdoc/bug11353.html.out less more

	0	<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
	1	"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
	2	<html xmlns="http://www.w3.org/1999/xhtml">
	3	<head>
	4	<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
	5	<link href="coqdoc.css" rel="stylesheet" type="text/css" />
	6	<title>Coqdoc.bug11353</title>
	7	</head>
	8
	9	<body>
	10
	11	<div id="page">
	12
	13	<div id="header">
	14	</div>
	15
	16	<div id="main">
	17
	18	<h1 class="libtitle">Library Coqdoc.bug11353</h1>
	19
	20	<div class="code">
	21	<span class="id" title="keyword">Definition</span> <a name="a"><span class="id" title="definition">a</span></a> := 0. #[ <span class="id" title="var">universes</span>( <span class="id" title="var">template</span>) ]<br/>
	22	<span class="id" title="keyword">Inductive</span> <a name="mysum"><span class="id" title="inductive">mysum</span></a> (<span class="id" title="var">A</span> <span class="id" title="var">B</span>:<span class="id" title="keyword">Type</span>) : <span class="id" title="keyword">Type</span> :=<br/>
	23	\| <a name="myinl"><span class="id" title="constructor">myinl</span></a> : <a class="idref" href="Coqdoc.bug11353.html#A"><span class="id" title="variable">A</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#1c93e43e07fbeaeb6a625cb6614beb5d"><span class="id" title="notation">→</span></a> <a class="idref" href="Coqdoc.bug11353.html#mysum"><span class="id" title="inductive">mysum</span></a> <a class="idref" href="Coqdoc.bug11353.html#A"><span class="id" title="variable">A</span></a> <a class="idref" href="Coqdoc.bug11353.html#B"><span class="id" title="variable">B</span></a><br/>
	24	\| <a name="myinr"><span class="id" title="constructor">myinr</span></a> : <a class="idref" href="Coqdoc.bug11353.html#B"><span class="id" title="variable">B</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#1c93e43e07fbeaeb6a625cb6614beb5d"><span class="id" title="notation">→</span></a> <a class="idref" href="Coqdoc.bug11353.html#mysum"><span class="id" title="inductive">mysum</span></a> <a class="idref" href="Coqdoc.bug11353.html#A"><span class="id" title="variable">A</span></a> <a class="idref" href="Coqdoc.bug11353.html#B"><span class="id" title="variable">B</span></a>.<br/>
	25
	26	<br/>
	27	#[<span class="id" title="var">local</span>]<span class="id" title="keyword">Definition</span> <a name="b"><span class="id" title="definition">b</span></a> := 1.<br/>
	28	</div>
	29	</div>
	30
	31	<div id="footer">
	32	<hr/><a href="index.html">Index</a><hr/>This page has been generated by <a href="http://coq.inria.fr/">coqdoc</a>
	33	</div>
	34
	35	</div>
	36
	37	</body>
	38	</html>⏎

+34

-0

test-suite/coqdoc/bug11353.tex.out less more

	0	\documentclass[12pt]{report}
	1	\usepackage[utf8x]{inputenc}
	2
	3	%Warning: tipa declares many non-standard macros used by utf8x to
	4	%interpret utf8 characters but extra packages might have to be added
	5	%such as "textgreek" for Greek letters not already in tipa
	6	%or "stmaryrd" for mathematical symbols.
	7	%Utf8 codes missing a LaTeX interpretation can be defined by using
	8	%\DeclareUnicodeCharacter{code}{interpretation}.
	9	%Use coqdoc's option -p to add new packages or declarations.
	10	\usepackage{tipa}
	11
	12	\usepackage[T1]{fontenc}
	13	\usepackage{fullpage}
	14	\usepackage{coqdoc}
	15	\usepackage{amsmath,amssymb}
	16	\usepackage{url}
	17	\begin{document}
	18	\coqlibrary{Coqdoc.bug11353}{Library }{Coqdoc.bug11353}
	19
	20	\begin{coqdoccode}
	21	\coqdocnoindent
	22	\coqdockw{Definition} \coqdef{Coqdoc.bug11353.a}{a}{\coqdocdefinition{a}} := 0. \#[ \coqdocvar{universes}( \coqdocvar{template}) ]\coqdoceol
	23	\coqdocnoindent
	24	\coqdockw{Inductive} \coqdef{Coqdoc.bug11353.mysum}{mysum}{\coqdocinductive{mysum}} (\coqdocvar{A} \coqdocvar{B}:\coqdockw{Type}) : \coqdockw{Type} :=\coqdoceol
	25	\coqdocindent{1.00em}
	26	\ensuremath{\|} \coqdef{Coqdoc.bug11353.myinl}{myinl}{\coqdocconstructor{myinl}} : \coqdocvariable{A} \coqexternalref{::type scope:x '->' x}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocnotation{\ensuremath{\rightarrow}}} \coqref{Coqdoc.bug11353.mysum}{\coqdocinductive{mysum}} \coqdocvariable{A} \coqdocvariable{B}\coqdoceol
	27	\coqdocindent{1.00em}
	28	\ensuremath{\|} \coqdef{Coqdoc.bug11353.myinr}{myinr}{\coqdocconstructor{myinr}} : \coqdocvariable{B} \coqexternalref{::type scope:x '->' x}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocnotation{\ensuremath{\rightarrow}}} \coqref{Coqdoc.bug11353.mysum}{\coqdocinductive{mysum}} \coqdocvariable{A} \coqdocvariable{B}.\coqdoceol
	29	\coqdocemptyline
	30	\coqdocnoindent
	31	\#[\coqdocvar{local}]\coqdockw{Definition} \coqdef{Coqdoc.bug11353.b}{b}{\coqdocdefinition{b}} := 1.\coqdoceol
	32	\end{coqdoccode}
	33	\end{document}

-0

test-suite/coqdoc/bug11353.v less more

	0	(* -- coq-prog-args: ("-g") -- *)
	1	Definition a := 0. #[ (* templatize *) universes( template) ]
	2	Inductive mysum (A B:Type) : Type :=
	3	\| myinl : A -> mysum A B
	4	\| myinr : B -> mysum A B.
	5
	6	#[local]Definition b := 1.

+11

-0

test-suite/micromega/bug_11191.v less more

	0	Require Import ZArith Lia.
	1
	2	Goal forall p, (0 < Z.pos (p ^ 2))%Z.
	3	intros.
	4	lia.
	5	Qed.
	6
	7	Goal forall p n, (0 < Z.pos (p ^ n))%Z.
	8	intros.
	9	lia.
	10	Qed.

-0

test-suite/micromega/bug_11270.v less more

	0	Require Import Psatz.
	1	Theorem foo : forall a b, 1 <= S (a + a * S b).
	2	Proof.
	3	intros.
	4	lia.
	5	Qed.

-2

test-suite/misc/quick-include.sh less more

0	0	#!/bin/sh
1	1	set -e
2	2
3		$coqc -R misc/quick-include/ QuickInclude -quick misc/quick-include/file1.v
4		$coqc -R misc/quick-include/ QuickInclude -quick misc/quick-include/file2.v
	3	$coqc -R misc/quick-include/ QuickInclude -vio misc/quick-include/file1.v
	4	$coqc -R misc/quick-include/ QuickInclude -vio misc/quick-include/file2.v

+12

-0

test-suite/output/Cases.out less more

165	165	: K -> nat
166	166	The command has indeed failed with message:
167	167	Pattern "S _, _" is redundant in this clause.
	168	stray =
	169	fun N : Tree =>
	170	match N with
	171	\| App (App Node (Node as strayvariable)) _ \|
	172	App (App Node (App Node _ as strayvariable)) _ \|
	173	App (App Node (App (App Node Node) (App _ _) as strayvariable)) _ \|
	174	App (App Node (App (App Node (App _ _)) _ as strayvariable)) _ \|
	175	App (App Node (App (App (App _ _) _) _ as strayvariable)) _ =>
	176	strayvariable
	177	\| _ => Node
	178	end
	179	: Tree -> Tree

+20

-0

test-suite/output/Cases.v less more

221	221
222	222	(* Test redundant clause within a disjunctive pattern *)
223	223	Fail Check fun n m => match n, m with 0, 0 \| _, S _ \| S 0, _ \| S (S _ \| _), _ => false end.
	224
	225	Module Bug11231.
	226
	227	(* Missing dependency in computing if a clause is a default clause *)
	228
	229	Inductive Tree: Set :=
	230	\| Node : Tree
	231	\| App : Tree -> Tree -> Tree
	232	.
	233
	234	Definition stray N :=
	235	match N with
	236	\| App (App Node (App (App Node Node) Node)) _ => Node
	237	\| App (App Node strayvariable) _ => strayvariable
	238	\| _ => Node
	239	end.
	240
	241	Print stray.
	242
	243	End Bug11231.

-1

test-suite/output/ErrorInModule.v less more

0		(* -- mode: coq; coq-prog-args: ("-quick") -- *)
	0	(* -- mode: coq; coq-prog-args: ("-vio") -- *)
1	1	Module M.
2	2	Definition foo := nonexistent.
3	3	End M.

-1

test-suite/output/ErrorInSection.v less more

0		(* -- mode: coq; coq-prog-args: ("-quick") -- *)
	0	(* -- mode: coq; coq-prog-args: ("-vio") -- *)
1	1	Section S.
2	2	Definition foo := nonexistent.
3	3	End S.

-2

test-suite/output/MExtraction.v less more

0	0	(************************************************************************)
1	1	(* * The Coq Proof Assistant / The Coq Development Team *)
2		(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *)
	2	(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *)
3	3	(* <O___,, * (see CREDITS file for the list of authors) *)
4	4	(* \VV/ **************************************************************)
5	5	(* // * This file is distributed under the terms of the *)

55	55	Recursive Extraction
56	56	Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula
57	57	Tauto.abst_form
58		ZMicromega.cnfZ ZMicromega.bound_problem_fr ZMicromega.Zeval_const QMicromega.cnfQ
	58	ZMicromega.cnfZ ZMicromega.Zeval_const QMicromega.cnfQ
59	59	List.map simpl_cone (map_cone indexes)
60	60	denorm Qpower vm_add
61	61	normZ normQ normQ n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find.
	62
62	63	(* Local Variables: *)
63	64	(* coding: utf-8 *)
64	65	(* End: *)

-0

test-suite/output/print_ltac.out less more

	0	Ltac t1 := time "my tactic" idtac
	1	Ltac t2 := let x := string:("my tactic") in
	2	idtac
	3	x
	4	Ltac t3 := idtacstr "my tactic"
	5	Ltac t4 x := match x with
	6	\| ?A => (A, A)
	7	end

+12

-0

test-suite/output/print_ltac.v less more

	0	(* Testing of various things about Print Ltac *)
	1	(* https://github.com/coq/coq/issues/10971 *)
	2	Ltac t1 := time "my tactic" idtac.
	3	Print Ltac t1.
	4	Ltac t2 := let x := string:("my tactic") in idtac x.
	5	Print Ltac t2.
	6	Tactic Notation "idtacstr" string(str) := idtac str.
	7	Ltac t3 := idtacstr "my tactic".
	8	Print Ltac t3.
	9	(* https://github.com/coq/coq/issues/9716 *)
	10	Ltac t4 x := match x with ?A => constr:((A, A)) end.
	11	Print Ltac t4.

+11

-0

test-suite/output/unification.out less more

	0	The command has indeed failed with message:
	1	In environment
	2	x : T
	3	T : Type
	4	a : T
	5	Unable to unify "T" with "?X@{x0:=x; x:=C a}" (cannot instantiate
	6	"?X" because "T" is not in its scope: available arguments are
	7	"x" "C a").
	8	The command has indeed failed with message:
	9	The term "id" has type "ID" while it is expected to have type
	10	"Type -> ?T" (cannot instantiate "?T" because "A" is not in its scope).

+12

-0

test-suite/output/unification.v less more

	0	(* Unification error tests *)
	1
	2	Module A.
	3
	4	(* Check regression of an UNBOUND_REL bug *)
	5	Inductive T := C : forall {A}, A -> T.
	6	Fail Check fun x => match x return ?[X] with C a => a end.
	7
	8	(* Bug #3634 *)
	9	Fail Check (id:Type -> _).
	10
	11	End A.

-5

test-suite/ssr/under.v less more

312	312	End TestGeneric2.
313	313
314	314	Section TestPreOrder.
315		(* inspired by https://github.com/coq/coq/pull/10022#issuecomment-530101950
316		but without needing to do [rewrite UnderE] manually. *)
	315	(* inspired by https://github.com/coq/coq/pull/10022#issuecomment-530101950 *)
317	316
318	317	Require Import Morphisms.
319	318

329	328
330	329	Local Notation "+%N" := addn (at level 0, only parsing).
331	330
332		(** Context lemma (could *)
	331	(** Context lemma *)
333	332	Lemma leq'_big : forall I (F G : I -> nat) (r : seq I),
334	333	(forall i : I, leq' (F i) (G i)) ->
335	334	(leq' (\big[+%N/0%N]_(i <- r) F i) (\big[+%N/0%N]_(i <- r) G i)).

369	368
370	369	under leq'_big => i.
371	370	{
372		(* The "magic" is here: instantiate the evar with the bound "3 + n" *)
373		rewrite lem ?ltn_ord //. over.
	371	rewrite UnderE.
	372
	373	(* instantiate the evar with the bound "3 + n" *)
	374	apply: lem; exact: ltn_ord.
374	375	}
375	376	cbv beta.
376	377

-0

test-suite/success/Notations2.v less more

164	164	Check fun y : nat => # (x,z) ## y & y.
165	165
166	166	End M17.
	167
	168	Module Bug10750.
	169
	170	Notation "#" := 0 (only printing).
	171	Print Visibility.
	172
	173	End Bug10750.

-1

test-suite/success/Omega.v less more

89	89	(* Postponed... problem with goals of the form "(nm=0)%nat -> (nm=0)%Z" *)
90	90	Lemma lem10 : forall n m:nat, le n (plus n (mult n m)).
91	91	Proof.
92		intros; omega with *.
	92	intros; zify; omega.
93	93	Qed.

+20

-20

test-suite/success/OmegaPre.v less more

15	15
16	16	Goal forall a:Z, Z.max a a = a.
17	17	intros.
18		omega with *.
	18	zify; omega.
19	19	Qed.
20	20
21	21	Goal forall a b:Z, Z.max a b = Z.max b a.
22	22	intros.
23		omega with *.
	23	zify; omega.
24	24	Qed.
25	25
26	26	Goal forall a b c:Z, Z.max a (Z.max b c) = Z.max (Z.max a b) c.
27	27	intros.
28		omega with *.
	28	zify; omega.
29	29	Qed.
30	30
31	31	Goal forall a b:Z, Z.max a b + Z.min a b = a + b.
32	32	intros.
33		omega with *.
	33	zify; omega.
34	34	Qed.
35	35
36	36	Goal forall a:Z, (Z.abs a)*(Z.sgn a) = a.
37	37	intros.
38	38	zify.
39		intuition; subst; omega. (* pure multiplication: omega alone can't do it *)
	39	intuition; subst; zify; omega. (* pure multiplication: zify; omega alone can't do it *)
40	40	Qed.
41	41
42	42	Goal forall a:Z, Z.abs a = a -> a >= 0.
43	43	intros.
44		omega with *.
	44	zify; omega.
45	45	Qed.
46	46
47	47	Goal forall a:Z, Z.sgn a = a -> a = 1 \/ a = 0 \/ a = -1.
48	48	intros.
49		omega with *.
	49	zify; omega.
50	50	Qed.
51	51
52	52	(* zify_nat *)
53	53
54	54	Goal forall m: nat, (m<2)%nat -> (0<= m+m <=2)%nat.
55	55	intros.
56		omega with *.
	56	zify; omega.
57	57	Qed.
58	58
59	59	Goal forall m:nat, (m<1)%nat -> (m=0)%nat.
60	60	intros.
61		omega with *.
	61	zify; omega.
62	62	Qed.
63	63
64	64	Goal forall m: nat, (m<=100)%nat -> (0<= m+m <=200)%nat.
65	65	intros.
66		omega with *.
	66	zify; omega.
67	67	Qed.
68	68	(* 2000 instead of 200: works, but quite slow *)
69	69
70	70	Goal forall m: nat, (m*m>=0)%nat.
71	71	intros.
72		omega with *.
	72	zify; omega.
73	73	Qed.
74	74
75	75	(* zify_positive *)
76	76
77	77	Goal forall m: positive, (m<2)%positive -> (2 <= m+m /\ m+m <= 2)%positive.
78	78	intros.
79		omega with *.
	79	zify; omega.
80	80	Qed.
81	81
82	82	Goal forall m:positive, (m<2)%positive -> (m=1)%positive.
83	83	intros.
84		omega with *.
	84	zify; omega.
85	85	Qed.
86	86
87	87	Goal forall m: positive, (m<=1000)%positive -> (2<=m+m/\m+m <=2000)%positive.
88	88	intros.
89		omega with *.
	89	zify; omega.
90	90	Qed.
91	91
92	92	Goal forall m: positive, (m*m>=1)%positive.
93	93	intros.
94		omega with *.
	94	zify; omega.
95	95	Qed.
96	96
97	97	(* zify_N *)
98	98
99	99	Goal forall m:N, (m<2)%N -> (0 <= m+m /\ m+m <= 2)%N.
100	100	intros.
101		omega with *.
	101	zify; omega.
102	102	Qed.
103	103
104	104	Goal forall m:N, (m<1)%N -> (m=0)%N.
105	105	intros.
106		omega with *.
	106	zify; omega.
107	107	Qed.
108	108
109	109	Goal forall m:N, (m<=1000)%N -> (0<=m+m/\m+m <=2000)%N.
110	110	intros.
111		omega with *.
	111	zify; omega.
112	112	Qed.
113	113
114	114	Goal forall m:N, (m*m>=0)%N.
115	115	intros.
116		omega with *.
	116	zify; omega.
117	117	Qed.
118	118
119	119	(* mix of datatypes *)
120	120
121	121	Goal forall p, Z.of_N (N.of_nat (N.to_nat (Npos p))) = Zpos p.
122	122	intros.
123		omega with *.
	123	zify; omega.
124	124	Qed.
125	125
126	126

-4

test-suite/success/RecTutorial.v less more

1209	1209	constructor.
1210	1210	trivial.
1211	1211	Qed.
1212
1213
1214
1215

+10

-0

test-suite/success/cofixtac.v less more

	0	CoInductive stream :=
	1	\| C : content -> stream
	2	with content :=
	3	\| D : nat -> stream -> content.
	4
	5	Lemma one : stream.
	6	cofix c with (d : content).
	7	- constructor. apply d.
	8	- constructor. exact 1. apply c.
	9	Defined.

+13

-0

test-suite/success/custom_entry.v less more

	0	Declare Custom Entry foo.
	1
	2	Print Custom Grammar foo.
	3
	4	Notation "[ e ]" := e (e custom foo at level 0).
	5
	6	Print Custom Grammar foo.
	7
	8	Notation "1" := O (in custom foo at level 0).
	9
	10	Print Custom Grammar foo.
	11
	12	Fail Declare Custom Entry foo.

+31

-0

test-suite/success/specialize.v less more

108	108	match goal with H:_ \|- _ => exact H end.
109	109	Qed.
110	110
	111
	112	(* let ins should be supported int he type of the specialized hypothesis *)
	113	Axiom foo: forall (m1:nat) (m2: nat), let n := 2 * m1 in (m1 = m2 -> False).
	114	Goal False.
	115	pose proof foo as P.
	116	assert (2 = 2) as A by reflexivity.
	117	(* specialize P with (m2:= 2). *)
	118	specialize P with (1 := A).
	119	match type of P with
	120	\| let n := 2 * 2 in False => idtac
	121	\| _ => fail "test failed"
	122	end.
	123	assumption.
	124	Qed.
	125
	126	(* Another more subtle test on letins: they should not interfere with foralls. *)
	127	Goal forall (P: forall a c:nat,
	128	let b := c in
	129	let d := 1 in
	130	forall n : a = d, a = c+1),
	131	True.
	132	intros P.
	133	specialize P with (1:=eq_refl).
	134	match type of P with
	135	\| forall c : nat, let f := c in let d := 1 in 1 = c + 1 => idtac
	136	\| _ => fail "test failed"
	137	end.
	138	constructor.
	139	Qed.
	140
	141
111	142	(* Test specialize as *)
112	143
113	144	Goal (forall x, x=0) -> 1=0.

-1

theories/Logic/Hurkens.v less more

71	71
72	72	- [[Geuvers01]] H. Geuvers, "Inconsistency of Classical Logic in Type
73	73	Theory", 2001, revised 2007
74		(see {{http://www.cs.ru.nl/~herman/PUBS/newnote.ps.gz}}).
	74	(see external link {{http://www.cs.ru.nl/~herman/PUBS/newnote.ps.gz}}).
75	75	*)
76	76
77	77

-0

theories/MSets/MSetEqProperties.v less more

17	17	[equal s s'=true] instead of [Equal s s'], etc. *)
18	18
19	19	Require Import MSetProperties Zerob Sumbool Omega DecidableTypeEx.
	20	Require FSetEqProperties.
20	21
21	22	Module WEqPropertiesOn (Import E:DecidableType)(M:WSetsOn E).
22	23	Module Import MP := WPropertiesOn E M.

-2

theories/QArith/Qreals.v less more

7	7	(* * (see LICENSE file for the text of the license) *)
8	8	(************************************************************************)
9	9
10		Require Export Rbase.
	10	Require Import Rdefinitions Raxioms RIneq.
11	11	Require Export QArith_base.
12	12
13	13	(** Injection of rational numbers into real numbers. *)

47	47	set (Y2 := IZR (Zpos y2)) in *.
48	48	assert ((X1 * Y2)%R = (Y1 * X2)%R).
49	49	unfold X1, X2, Y1, Y2; do 2 rewrite <- mult_IZR.
50		apply IZR_eq; auto.
	50	f_equal; auto.
51	51	clear H.
52	52	field_simplify_eq; auto.
53	53	rewrite H0; ring.

-2

theories/Reals/ArithProp.v less more

7	7	(* * (see LICENSE file for the text of the license) *)
8	8	(************************************************************************)
9	9
10		Require Import Rbase.
	10	Require Import Rdefinitions Raxioms RIneq.
11	11	Require Import Rbasic_fun.
12	12	Require Import Even.
13	13	Require Import Div2.

84	84	assert (H1 := le_INR _ _ H).
85	85	do 2 rewrite mult_INR in H1.
86	86	apply Rmult_le_reg_l with (INR 2).
87		replace (INR 2) with 2; [ prove_sup0 \| reflexivity ].
	87	apply lt_0_INR. apply Nat.lt_0_2.
88	88	assumption.
89	89	Qed.
90	90

+10

-7

theories/Reals/RIneq.v less more

18	18	Require Import Rpow_def.
19	19	Require Import Zpower.
20	20	Require Export ZArithRing.
21		Require Import Lia.
	21	Require Import Ztac.
22	22	Require Export RealField.
23	23
24	24	Local Open Scope Z_scope.

1874	1874	Proof.
1875	1875	intros z1 z2 H; generalize (Rminus_diag_eq (IZR z1) (IZR z2) H);
1876	1876	rewrite (Z_R_minus z1 z2); intro; generalize (eq_IZR_R0 (z1 - z2) H0);
1877		intro; lia.
	1877	apply Zminus_eq.
1878	1878	Qed.
1879	1879
1880	1880	(**********)

1912	1912	Lemma IZR_ge : forall n m:Z, (n >= m)%Z -> IZR n >= IZR m.
1913	1913	Proof.
1914	1914	intros m n H; apply Rnot_lt_ge; red; intro.
1915		generalize (lt_IZR m n H0); intro; lia.
	1915	generalize (lt_IZR m n H0); intro.
	1916	slia H H1.
1916	1917	Qed.
1917	1918
1918	1919	Lemma IZR_le : forall n m:Z, (n <= m)%Z -> IZR n <= IZR m.
1919	1920	Proof.
1920	1921	intros m n H; apply Rnot_gt_le; red; intro.
1921		unfold Rgt in H0; generalize (lt_IZR n m H0); intro; lia.
	1922	unfold Rgt in H0; generalize (lt_IZR n m H0); intro.
	1923	slia H H1.
1922	1924	Qed.
1923	1925
1924	1926	Lemma IZR_lt : forall n m:Z, (n < m)%Z -> IZR n < IZR m.
1925	1927	Proof.
1926	1928	intros m n H; cut (m <= n)%Z.
1927	1929	intro H0; elim (IZR_le m n H0); intro; auto.
1928		generalize (eq_IZR m n H1); intro; exfalso; lia.
1929		lia.
	1930	generalize (eq_IZR m n H1); intro; exfalso.
	1931	slia H H3.
	1932	normZ. slia H H0.
1930	1933	Qed.
1931	1934
1932	1935	Lemma IZR_neq : forall z1 z2:Z, z1 <> z2 -> IZR z1 <> IZR z2.

1953	1956	forall r (n m:Z), r < IZR n <= r + 1 -> r < IZR m <= r + 1 -> n = m.
1954	1957	Proof.
1955	1958	intros r z x [H1 H2] [H3 H4].
1956		cut ((z - x)%Z = 0%Z). lia.
	1959	apply Zminus_eq.
1957	1960	apply one_IZR_lt1.
1958	1961	rewrite <- Z_R_minus; split.
1959	1962	replace (-1) with (r - (r + 1)).

+11

-10

theories/Reals/R_Ifp.v less more

12	12	(* *)
13	13	(**********************************************************)
14	14
15		Require Import Rbase.
16		Require Import Lia.
	15	Require Import Rdefinitions Raxioms RIneq.
	16	Require Import Ztac.
17	17	Local Open Scope R_scope.
18	18
19	19	(*********************************************************)

59	59	apply lt_IZR in H1.
60	60	rewrite <- minus_IZR in H2.
61	61	apply le_IZR in H2.
62		lia.
	62	normZ. slia H2 HZ. slia H1 HZ.
63	63	Qed.
64	64
65	65	(**********)

228	228	rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H.
229	229	rewrite <- (plus_IZR (Int_part r1 - Int_part r2) 1) in H;
230	230	generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2) H0 H);
231		intros; clear H H0; unfold Int_part at 1;
232		lia.
	231	intros; clear H H0; unfold Int_part at 1.
	232	normZ. slia H HZ. slia H0 HZ.
233	233	Qed.
234	234
235	235	(**********)

321	321	generalize (Rlt_le (IZR (Int_part r1 - Int_part r2 - 1)) (r1 - r2) H);
322	322	intro; clear H;
323	323	generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2 - 1) H1 H0);
324		intros; clear H0 H1; unfold Int_part at 1;
325		lia.
	324	intros; clear H0 H1; unfold Int_part at 1.
	325	normZ. slia H HZ. slia H0 HZ.
326	326	Qed.
327	327
328	328	(**********)

436	436	rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H0;
437	437	rewrite <- (plus_IZR (Int_part r1 + Int_part r2 + 1) 1) in H0;
438	438	generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2 + 1) H H0);
439		intro; clear H H0; unfold Int_part at 1; lia.
	439	intro; clear H H0; unfold Int_part at 1.
	440	normZ. slia H HZ. slia H0 HZ.
440	441	Qed.
441	442
442	443	(**********)

497	498	rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H1;
498	499	rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H1;
499	500	generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2) H0 H1);
500		intro; clear H0 H1; unfold Int_part at 1;
501		lia.
	501	intro; clear H0 H1; unfold Int_part at 1.
	502	normZ. slia H HZ. slia H0 HZ.
502	503	Qed.
503	504
504	505	(**********)

-1

theories/Reals/R_sqr.v less more

7	7	(* * (see LICENSE file for the text of the license) *)
8	8	(************************************************************************)
9	9
10		Require Import Rbase.
	10	Require Import Rdefinitions Raxioms RIneq.
11	11	Require Import Rbasic_fun.
12	12	Local Open Scope R_scope.
13	13

-1

theories/Reals/Ranalysis.v less more

23	23	Require Export R_sqrt.
24	24	Require Export Rtrigo_calc.
25	25	Require Export Rgeom.
26		Require Export RList.
27	26	Require Export Sqrt_reg.
28	27	Require Export Ranalysis4.
29	28	Require Export Rpower.

-1

theories/Reals/Ranalysis_reg.v less more

23	23	Require Export R_sqrt.
24	24	Require Export Rtrigo_calc.
25	25	Require Export Rgeom.
26		Require Export RList.
27	26	Require Export Sqrt_reg.
28	27	Require Export Ranalysis4.
29	28	Require Export Rpower.

-1

theories/Reals/Rbasic_fun.v less more

12	12	(* *)
13	13	(*********************************************************)
14	14
15		Require Import Rbase.
	15	Require Import Rdefinitions Raxioms RIneq.
16	16	Require Import R_Ifp.
17	17	Local Open Scope R_scope.
18	18

-8

theories/Reals/Rfunctions.v less more

16	16	(********************************************************)
17	17	Require Export ArithRing.
18	18
19		Require Import Rbase.
	19	Require Import Rdefinitions Raxioms RIneq.
20	20	Require Export Rpow_def.
21	21	Require Export R_Ifp.
22	22	Require Export Rbasic_fun.

24	24	Require Export SplitAbsolu.
25	25	Require Export SplitRmult.
26	26	Require Export ArithProp.
27		Require Import Lia.
28	27	Require Import Zpower.
	28	Require Import Ztac.
29	29	Local Open Scope nat_scope.
30	30	Local Open Scope R_scope.
31	31

121	121	Lemma Rlt_pow_R1 : forall (x:R) (n:nat), 1 < x -> (0 < n)%nat -> 1 < x ^ n.
122	122	Proof.
123	123	intros x n; elim n; simpl; auto with real.
124		intros H' H'0; exfalso; lia.
	124	intros H' H'0; exfalso. apply (Nat.lt_irrefl 0); assumption.
125	125	intros n0; case n0.
126	126	simpl; rewrite Rmult_1_r; auto.
127	127	intros n1 H' H'0 H'1.

261	261	elim (IZN (up (b * / (Rabs x - 1))) H2); intros; exists x0;
262	262	apply
263	263	(Rge_trans (INR x0) (IZR (up (b * / (Rabs x - 1)))) (b * / (Rabs x - 1))).
264		rewrite INR_IZR_INZ; apply IZR_ge; lia.
	264	rewrite INR_IZR_INZ; apply IZR_ge. normZ. slia H3 H5.
265	265	unfold Rge; left; assumption.
266	266	exists 0%nat;
267	267	apply
268	268	(Rge_trans (INR 0) (IZR (up (b * / (Rabs x - 1)))) (b * / (Rabs x - 1))).
269		rewrite INR_IZR_INZ; apply IZR_ge; simpl; lia.
	269	rewrite INR_IZR_INZ; apply IZR_ge; simpl. normZ. slia H2 H3.
270	270	unfold Rge; left; assumption.
271		lia.
	271	apply Z.le_ge_cases.
272	272	Qed.
273	273
274	274	Lemma pow_ne_zero : forall n:nat, n <> 0%nat -> 0 ^ n = 0.

744	744	- now simpl; rewrite Rmult_1_l.
745	745	- now rewrite <- !pow_powerRZ, Rpow_mult_distr.
746	746	- destruct Hmxy as [H\|H].
747		+ assert(m = 0) as -> by now lia.
	747	+ assert(m = 0) as -> by
	748	(destruct n; [assumption\| subst; simpl in H; lia_contr]).
748	749	now rewrite <- Hm, Rmult_1_l.
749	750	+ assert(x0 <> 0)%R by now intros ->; apply H; rewrite Rmult_0_l.
750	751	assert(y0 <> 0)%R by now intros ->; apply H; rewrite Rmult_0_r.

807	808	ring.
808	809	rewrite Rmult_plus_distr_r; rewrite Hrecn; cut ((n + 1)%nat = S n).
809	810	intro H; rewrite H; simpl; ring.
810		lia.
	811	apply Nat.add_1_r.
811	812	Qed.
812	813
813	814	Lemma sum_f_R0_triangle :

-0

theories/Reals/RiemannInt.v less more

14	14	Require Import Rbase.
15	15	Require Import RiemannInt_SF.
16	16	Require Import Max.
	17	Require Import RList.
17	18	Local Open Scope R_scope.
18	19
19	20	Set Implicit Arguments.

-0

theories/Reals/RiemannInt_SF.v less more

11	11	Require Import Rfunctions.
12	12	Require Import Ranalysis_reg.
13	13	Require Import Classical_Prop.
	14	Require Import RList.
14	15	Local Open Scope R_scope.
15	16
16	17	Set Implicit Arguments.

+30

-0

theories/Reals/Rregisternames.v less more

	0	(************************************************************************)
	1	(* * The Coq Proof Assistant / The Coq Development Team *)
	2	(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *)
	3	(* <O___,, * (see CREDITS file for the list of authors) *)
	4	(* \VV/ **************************************************************)
	5	(* // * This file is distributed under the terms of the *)
	6	(* * GNU Lesser General Public License Version 2.1 *)
	7	(* * (see LICENSE file for the text of the license) *)
	8	(************************************************************************)
	9
	10	Require Import Reals.
	11
	12	(*****************************************************************)
	13	(** * Register names in the Reals library used by plugins *)
	14	(*****************************************************************)
	15
	16	Register R as reals.R.type.
	17	Register R0 as reals.R.R0.
	18	Register R1 as reals.R.R1.
	19	Register Rle as reals.R.Rle.
	20	Register Rplus as reals.R.Rplus.
	21	Register Ropp as reals.R.Ropp.
	22	Register Rminus as reals.R.Rminus.
	23	Register Rmult as reals.R.Rmult.
	24	Register Rinv as reals.R.Rinv.
	25	Register Rdiv as reals.R.Rdiv.
	26	Register IZR as reals.R.IZR.
	27	Register Rabs as reals.R.Rabs.
	28	Register sqrt as reals.R.sqrt.
	29	Register powerRZ as reals.R.powerRZ.

-1

theories/Reals/SplitRmult.v less more

10	10	(i Lemma mult_non_zero :(r1,r2:R)``r1<>0`` /\ ``r2<>0`` -> ``r1r2<>0``. i*)
11	11
12	12
13		Require Import Rbase.
	13	Require Import Rdefinitions Raxioms RIneq.
14	14
15	15	Ltac split_Rmult :=
16	16	match goal with

+10

-5

tools/CoqMakefile.in less more

388	388	.PHONY: optfiles
389	389
390	390	# FIXME, see Ralf's bugreport
391		quick: $(VOFILES:.vo=.vio)
	391	# quick is deprecated, now renamed vio
	392	vio: $(VOFILES:.vo=.vio)
	393	.PHONY: vio
	394	quick: vio
	395	$(warning "'make quick' is deprecated, use 'make vio' or consider using 'vos' files")
392	396	.PHONY: quick
393	397
394	398	vio2vo:

396	400	-schedule-vio2vo $(J) $(VOFILES:%.vo=%.vio)
397	401	.PHONY: vio2vo
398	402
	403	# quick2vo is undocumented
399	404	quick2vo:
400		$(HIDE)make -j $(J) quick
	405	$(HIDE)make -j $(J) vio
401	406	$(HIDE)VIOFILES=$$(for vofile in $(VOFILES); do \
402	407	viofile="$$(echo "$$vofile" \| sed "s/\.vo$$/.vio/")"; \
403	408	if [ "$$vofile" -ot "$$viofile" -o ! -e "$$vofile" ]; then printf "$$viofile "; fi; \

631	636
632	637	$(MLLIBFILES:.mllib=.cmxa): %.cmxa: \| %.mllib
633	638	$(SHOW)'CAMLOPT -a -o $@'
634		$(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) -a -o $@ $^
	639	$(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -a -o $@ $^
635	640
636	641
637	642	$(MLPACKFILES:.mlpack=.cmxs): %.cmxs: %.cmxa

676	681	$(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $<
677	682
678	683	$(VFILES:.v=.vio): %.vio: %.v
679		$(SHOW)COQC -quick $<
680		$(HIDE)$(TIMER) $(COQC) -quick $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $<
	684	$(SHOW)COQC -vio $<
	685	$(HIDE)$(TIMER) $(COQC) -vio $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $<
681	686
682	687	$(VFILES:.v=.vos): %.vos: %.v
683	688	$(SHOW)COQC -vos $<

-2

tools/coq_makefile.ml less more

33	33	let usage_coq_makefile () =
34	34	output_string stderr "Usage summary:\
35	35	\n\
36		\ncoq_makefile .... [file.v] ... [file.ml[i4]?] ... [file.ml{lib,pack}]\
	36	\ncoq_makefile .... [file.v] ... [file.ml[ig]?] ... [file.ml{lib,pack}]\
37	37	\n ... [any] ... [-extra[-phony] result dependencies command]\
38	38	\n ... [-I dir] ... [-R physicalpath logicalpath]\
39	39	\n ... [-Q physicalpath logicalpath] ... [VARIABLE = value]\

44	44	\nFull list of options:\
45	45	\n\
46	46	\n[file.v]: Coq file to be compiled\
47		\n[file.ml[i4]?]: Objective Caml file to be compiled\
	47	\n[file.ml[ig]?]: Objective Caml file to be compiled\
48	48	\n[file.ml{lib,pack}]: ocamlbuild-style file that describes a Objective Caml\
49	49	\n library/module\
50	50	\n[any] : subdirectory that should be \"made\" and has a Makefile itself\

-0

tools/coqdoc/cpretty.mll less more

546	546	comment lexbuf
547	547	end else skipped_comment lexbuf in
548	548	if eol then coq_bol lexbuf else coq lexbuf }
	549	\| space* "#[" {
	550	let eol = begin backtrack lexbuf; body_bol lexbuf end
	551	in if eol then coq_bol lexbuf else coq lexbuf }
549	552	\| eof
550	553	{ () }
551	554	\| _

642	645	Output.ident s None;
643	646	let eol = body lexbuf in
644	647	if eol then coq_bol lexbuf else coq lexbuf }
	648	\| "#["
	649	{ ignore(lexeme lexbuf);
	650	Output.char '#'; Output.char '[';
	651	let eol = body lexbuf in
	652	if eol then coq_bol lexbuf else coq lexbuf }
645	653	\| space+ { Output.char ' '; coq lexbuf }
646	654	\| eof
647	655	{ () }

+21

-8

toplevel/ccompile.ml less more

120	120	in
121	121	let long_f_dot_in, long_f_dot_out =
122	122	ensure_exists_with_prefix f_in f_out ext_in ext_out in
	123	let dump_empty_vos () =
	124	(* Produce an empty .vos file, as a way to ensure that a stale .vos can never be loaded *)
	125	let long_f_dot_vos = (chop_extension long_f_dot_out) ^ ".vos" in
	126	create_empty_file long_f_dot_vos in
123	127	match mode with
124	128	\| BuildVo \| BuildVok ->
125	129	let doc, sid = Topfmt.(in_phase ~phase:LoadingPrelude)

144	148	let _doc = Stm.join ~doc:state.doc in
145	149	let wall_clock2 = Unix.gettimeofday () in
146	150	check_pending_proofs ();
147		if mode <> BuildVok (* Don't output proofs in -vok mode *)
148		then Library.save_library_to ~output_native_objects Library.ProofsTodoNone ldir long_f_dot_out (Global.opaque_tables ());
	151	(* In .vo production, dump a complete .vo file.
	152	In .vok production, only dump an empty .vok file. *)
	153	if mode = BuildVo
	154	then Library.save_library_to ~output_native_objects Library.ProofsTodoNone ldir long_f_dot_out (Global.opaque_tables ())
	155	else create_empty_file long_f_dot_out;
149	156	Aux_file.record_in_aux_at "vo_compile_time"
150	157	(Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1));
151	158	Aux_file.stop_aux_file ();
152		(* Produce an empty .vos file and an empty .vok file when producing a .vo in standard mode *)
	159	(* In .vo production, dump an empty .vos file to indicate that the .vo should be loaded,
	160	and dump an empty .vok file to indicate that proofs are ok. *)
153	161	if mode = BuildVo then begin
154		create_empty_file (long_f_dot_out ^ "s");
	162	dump_empty_vos();
155	163	create_empty_file (long_f_dot_out ^ "k");
156	164	end;
157		(* Produce an empty .vok file when in -vok mode *)
158		if mode = BuildVok then create_empty_file (long_f_dot_out);
159	165	Dumpglob.end_dump_glob ()
160	166
161	167	\| BuildVio \| BuildVos ->

185	191	let doc = Stm.finish ~doc:state.doc in
186	192	check_pending_proofs ();
187	193	let create_vos = (mode = BuildVos) in
	194	(* In .vos production, the output .vos file contains compiled statements.
	195	In .vio production, the output .vio file contains compiled statements and suspended proofs. *)
188	196	let () = ignore (Stm.snapshot_vio ~create_vos ~doc ~output_native_objects ldir long_f_dot_out) in
189		Stm.reset_task_queue ()
	197	Stm.reset_task_queue ();
	198	(* In .vio production, dump an empty .vos file to indicate that the .vio should be loaded. *)
	199	if mode = BuildVio then dump_empty_vos()
190	200
191	201	\| Vio2Vo ->
192	202
193	203	let sum, lib, univs, tasks, proofs =
194	204	Library.load_library_todo long_f_dot_in in
195	205	let univs, proofs = Stm.finish_tasks long_f_dot_out univs proofs tasks in
196		Library.save_library_raw long_f_dot_out sum lib univs proofs
	206	Library.save_library_raw long_f_dot_out sum lib univs proofs;
	207	(* Like in direct .vo production, dump an empty .vok file and an empty .vos file. *)
	208	dump_empty_vos();
	209	create_empty_file (long_f_dot_out ^ "k")
197	210
198	211	let compile opts copts ~echo ~f_in ~f_out =
199	212	ignore(CoqworkmgrApi.get 1);

+10

-0

toplevel/coqargs.ml less more

202	202	\| Run -> Queries (default_queries@[q])
203	203	\| Queries queries -> Queries (queries@[q])
204	204	}
	205
	206	let warn_depr_load_ml_object =
	207	CWarnings.create ~name:"deprecated-mlobject" ~category:"deprecated"
	208	(fun () -> Pp.strbrk "The -load-ml-object option is deprecated, see the changelog for more details.")
	209
	210	let warn_depr_ml_load_source =
	211	CWarnings.create ~name:"deprecated-mlsource" ~category:"deprecated"
	212	(fun () -> Pp.strbrk "The -load-ml-source option is deprecated, see the changelog for more details.")
205	213
206	214	let warn_deprecated_inputstate =
207	215	CWarnings.create ~name:"deprecated-inputstate" ~category:"deprecated"

391	399	set_inputstate oval (next ())
392	400
393	401	\|"-load-ml-object" ->
	402	warn_depr_load_ml_object ();
394	403	Mltop.dir_ml_load (next ()); oval
395	404
396	405	\|"-load-ml-source" ->
	406	warn_depr_ml_load_source ();
397	407	Mltop.dir_ml_use (next ()); oval
398	408
399	409	\|"-load-vernac-object" ->

-1

toplevel/coqc.ml less more

24	24	coqc specific options:\
25	25	\n -o f.vo use f.vo as the output file name\
26	26	\n -verbose compile and output the input file\
27		\n -quick quickly compile .v files to .vio files (skip proofs)\
28	27	\n -schedule-vio2vo j f1..fn run up to j instances of Coq to turn each fi.vio\
29	28	\n into fi.vo\
30	29	\n -schedule-vio-checking j f1..fn run up to j instances of Coq to check all\

32	31	\n -vos process statements but ignore opaque proofs, and produce a .vos file\
33	32	\n -vok process the file by loading .vos instead of .vo files for\
34	33	\n dependencies, and produce an empty .vok file on success\
	34	\n -vio process statements and suspend opaque proofs, and produce a .vio file\
35	35	\n\
36	36	\nUndocumented:\
	37	\n -quick (deprecated) alias for -vio\
37	38	\n -vio2vo [see manual]\
38	39	\n -check-vio-tasks [see manual]\
39	40	\n"

-1

toplevel/coqcargs.ml less more

97	97	match opts.compilation_mode with
98	98	\| BuildVo -> { opts with compilation_mode = mode }
99	99	\| mode' when mode <> mode' ->
100		prerr_endline "Options -quick and -vio2vo are exclusive";
	100	prerr_endline "Options -vio and -vio2vo are exclusive";
101	101	exit 1
102	102	\| _ -> opts
103	103

124	124	CWarnings.create ~name:"deprecated-outputstate" ~category:"deprecated"
125	125	(fun () ->
126	126	Pp.strbrk "The outputstate option is deprecated and discouraged.")
	127
	128	let warn_deprecated_quick =
	129	CWarnings.create ~name:"deprecated-quick" ~category:"deprecated"
	130	(fun () ->
	131	Pp.strbrk "The -quick option is renamed -vio. Please consider using the -vos feature instead.")
127	132
128	133	let set_outputstate opts s =
129	134	warn_deprecated_outputstate ();

164	169	\| "-o" ->
165	170	{ oval with compilation_output_name = Some (next ()) }
166	171	\| "-quick" ->
	172	warn_deprecated_quick();
	173	set_compilation_mode oval BuildVio
	174	\| "-vio" ->
167	175	set_compilation_mode oval BuildVio
168	176	\|"-vos" ->
169	177	Flags.load_vos_libraries := true;

+11

-7

toplevel/coqtop.ml less more

154	154	let () = List.iter iter tags in
155	155	flush_all ()
156	156
	157	let init_setup = function
	158	\| None -> Envars.set_coqlib ~fail:(fun msg -> CErrors.user_err Pp.(str msg));
	159	\| Some s -> Envars.set_user_coqlib s
	160
157	161	let print_query opts = function
158	162	\| PrintVersion -> Usage.version ()
159	163	\| PrintMachineReadableVersion -> Usage.machine_readable_version ()
160		\| PrintWhere -> print_endline (Envars.coqlib ())
	164	\| PrintWhere ->
	165	let () = init_setup opts.config.coqlib in
	166	print_endline (Envars.coqlib ())
161	167	\| PrintHelp h -> Usage.print_usage stderr h
162		\| PrintConfig -> Envars.print_config stdout Coq_config.all_src_dirs
	168	\| PrintConfig ->
	169	let () = init_setup opts.config.coqlib in
	170	Envars.print_config stdout Coq_config.all_src_dirs
163	171	\| PrintTags -> print_style_tags opts.config
164	172
165	173	(** GC tweaking *)

186	194	Gc.set { (Gc.get ()) with
187	195	Gc.minor_heap_size = 33554432; (* 4M *)
188	196	Gc.space_overhead = 120}
189
190		let init_setup = function
191		\| None -> Envars.set_coqlib ~fail:(fun msg -> CErrors.user_err Pp.(str msg));
192		\| Some s -> Envars.set_user_coqlib s
193	197
194	198	let init_process () =
195	199	(* Coq's init process, phase 1:

255	259	let init_toplevel custom =
256	260	let () = init_process () in
257	261	let opts, customopts = init_parse custom.parse_extra custom.help custom.opts in
258		let () = init_setup opts.config.coqlib in
259	262	(* Querying or running? *)
260	263	match opts.main with
261	264	\| Queries q -> List.iter (print_query opts) q; exit 0
262	265	\| Run ->
	266	let () = init_setup opts.config.coqlib in
263	267	let customstate = init_execution opts (custom.init customopts) in
264	268	opts, customopts, customstate
265	269

-1

vernac/declareUniv.ml less more

71	71	CErrors.anomaly ~label:"declare_univ_binders" Pp.(str "declare_univ_binders on variable " ++ Id.print id ++ str".")
72	72	\| ConstructRef _ ->
73	73	CErrors.anomaly ~label:"declare_univ_binders"
74		Pp.(str "declare_univ_binders on an constructor reference")
	74	Pp.(str "declare_univ_binders on a constructor reference")
75	75	in
76	76	let univs = Id.Map.fold (fun id univ univs ->
77	77	match Univ.Level.name univ with

+10

-6

vernac/egramcoq.ml less more

246	246	\| TTReference : ('self, qualid) entry
247	247	\| TTBigint : ('self, string) entry
248	248	\| TTConstr : notation_entry * prod_info * 'r target -> ('r, 'r) entry
249		\| TTConstrList : prod_info * string Tok.p list * 'r target -> ('r, 'r list) entry
	249	\| TTConstrList : notation_entry * prod_info * string Tok.p list * 'r target -> ('r, 'r list) entry
250	250	\| TTPattern : int -> ('self, cases_pattern_expr) entry
251	251	\| TTOpenBinderList : ('self, local_binder_expr list) entry
252	252	\| TTClosedBinderList : string Tok.p list -> ('self, local_binder_expr list list) entry

276	276	let sp = "pattern:"^s in
277	277	try (find_custom_entry constr_custom_entry sc, find_custom_entry pattern_custom_entry sp)
278	278	with Not_found -> user_err Pp.(str "Undeclared custom entry: " ++ str s ++ str ".")
	279
	280	let exists_custom_entry s = match find_custom_entry s with
	281	\| _ -> true
	282	\| exception _ -> false
279	283
280	284	let locality_of_custom_entry s = String.Set.mem s !custom_entry_locality
281	285

346	350
347	351	let symbol_of_entry : type s r. _ -> _ -> (s, r) entry -> (s, r) mayrec_symbol = fun assoc from typ -> match typ with
348	352	\| TTConstr (s, p, forpat) -> symbol_of_target s p assoc from forpat
349		\| TTConstrList (typ', [], forpat) ->
350		begin match symbol_of_target InConstrEntry typ' assoc from forpat with
	353	\| TTConstrList (s, typ', [], forpat) ->
	354	begin match symbol_of_target s typ' assoc from forpat with
351	355	\| MayRecNo s -> MayRecNo (Alist1 s)
352	356	\| MayRecMay s -> MayRecMay (Alist1 s) end
353		\| TTConstrList (typ', tkl, forpat) ->
354		begin match symbol_of_target InConstrEntry typ' assoc from forpat with
	357	\| TTConstrList (s, typ', tkl, forpat) ->
	358	begin match symbol_of_target s typ' assoc from forpat with
355	359	\| MayRecNo s -> MayRecNo (Alist1sep (s, make_sep_rules tkl))
356	360	\| MayRecMay s -> MayRecMay (Alist1sep (s, make_sep_rules tkl)) end
357	361	\| TTPattern p -> MayRecNo (Aentryl (Constr.pattern, string_of_int p))

368	372	\| ETProdBigint -> TTAny TTBigint
369	373	\| ETProdConstr (s,p) -> TTAny (TTConstr (s, p, forpat))
370	374	\| ETProdPattern p -> TTAny (TTPattern p)
371		\| ETProdConstrList (p, tkl) -> TTAny (TTConstrList (p, tkl, forpat))
	375	\| ETProdConstrList (s, p, tkl) -> TTAny (TTConstrList (s, p, tkl, forpat))
372	376	\| ETProdBinderList ETBinderOpen -> TTAny TTOpenBinderList
373	377	\| ETProdBinderList (ETBinderClosed tkl) -> TTAny (TTClosedBinderList tkl)
374	378

-0

vernac/egramcoq.mli less more

18	18	(** Add a term notation rule to the parsing system. *)
19	19
20	20	val create_custom_entry : local:bool -> string -> unit
	21
	22	val exists_custom_entry : string -> bool
	23
21	24	val locality_of_custom_entry : string -> bool

-0

vernac/himsg.ml less more

296	296	strbrk " with term " ++ pr_leconstr_env env sigma rhs ++
297	297	strbrk " that would depend on itself"]
298	298	\| NotClean ((evk,args),env,c) ->
	299	let env = make_all_name_different env sigma in
299	300	[str "cannot instantiate " ++ quote (pr_existential_key sigma evk)
300	301	++ strbrk " because " ++ pr_leconstr_env env sigma c ++
301	302	strbrk " is not in its scope" ++

+22

-18

vernac/loadpath.ml less more

137	137	System.where_in_path ~warn loadpath name in
138	138	Some (lpath, file)
139	139	with Not_found -> None in
	140	(* If [!Flags.load_vos_libraries]
	141	and the .vos file exists
	142	and this file is not empty
	143	Then load this library
	144	Else load the most recent between the .vo file and the .vio file,
	145	or if there is only of the two files, take this one,
	146	or raise an error if both are missing. *)
	147	let load_most_recent_of_vo_and_vio () =
	148	match find ".vo", find ".vio" with
	149	\| None, None ->
	150	Error LibNotFound
	151	\| Some res, None \| None, Some res ->
	152	Ok res
	153	\| Some (_, vo), Some (_, vi as resvi)
	154	when Unix.((stat vo).st_mtime < (stat vi).st_mtime) ->
	155	warn_several_object_files (vi, vo);
	156	Ok resvi
	157	\| Some resvo, Some _ ->
	158	Ok resvo
	159	in
140	160	if !Flags.load_vos_libraries then begin
141		(* If the .vos file exists and is not empty, it describes the library.
142		Otherwise, load the .vo file, or fail if is missing. *)
143	161	match find ".vos" with
144	162	\| Some (_, vos as resvos) when (Unix.stat vos).Unix.st_size > 0 -> Ok resvos
145		\| _ ->
146		match find ".vo" with
147		\| None -> Error LibNotFound
148		\| Some resvo -> Ok resvo
149		end else
150		match find ".vo", find ".vio" with
151		\| None, None ->
152		Error LibNotFound
153		\| Some res, None \| None, Some res ->
154		Ok res
155		\| Some (_, vo), Some (_, vi as resvi)
156		when Unix.((stat vo).st_mtime < (stat vi).st_mtime) ->
157		warn_several_object_files (vi, vo);
158		Ok resvi
159		\| Some resvo, Some _ ->
160		Ok resvo
	163	\| _ -> load_most_recent_of_vo_and_vio()
	164	end else load_most_recent_of_vo_and_vio()
161	165
162	166	let locate_absolute_library dir : CUnix.physical_path locate_result =
163	167	(* Search in loadpath *)

+12

-3

vernac/metasyntax.ml less more

610	610	else if Int.equal i (p+n) then
611	611	let hds =
612	612	GramConstrListMark (p+n,true,p) :: hds
613		@ [GramConstrNonTerminal (ETProdConstrList (typ,tkl), Some x)] in
	613	@ [GramConstrNonTerminal (ETProdConstrList (s, typ,tkl), Some x)] in
614	614	distribute hds ll
615	615	else
616	616	distribute (GramConstrListMark (i+1,false,p) :: hds @ [main]) ll @

1679	1679	(**********************************************************************)
1680	1680	(* Declaration of custom entry *)
1681	1681
	1682	let warn_custom_entry =
	1683	CWarnings.create ~name:"custom-entry-overriden" ~category:"parsing"
	1684	(fun s ->
	1685	strbrk "Custom entry " ++ str s ++ strbrk " has been overriden.")
	1686
1682	1687	let load_custom_entry _ _ = ()
1683	1688
1684	1689	let open_custom_entry _ (_,(local,s)) =
1685		Egramcoq.create_custom_entry ~local s
	1690	if Egramcoq.exists_custom_entry s then warn_custom_entry s
	1691	else Egramcoq.create_custom_entry ~local s
1686	1692
1687	1693	let cache_custom_entry o =
1688	1694	load_custom_entry 1 o;

1702	1708	classify_function = classify_custom_entry}
1703	1709
1704	1710	let declare_custom_entry local s =
1705		Lib.add_anonymous_leaf (inCustomEntry (local,s))
	1711	if Egramcoq.exists_custom_entry s then
	1712	user_err Pp.(str "Custom entry " ++ str s ++ str " already exists")
	1713	else
	1714	Lib.add_anonymous_leaf (inCustomEntry (local,s))