diff options
| author |  Enrico Tassi <gareuselesinge@debian.org> | 2015-01-25 14:42:51 +0100 |
|---|---|---|
| committer | Enrico Tassi <gareuselesinge@debian.org> | 2015-01-25 14:42:51 +0100 |
| commit | 7cfc4e5146be5666419451bdd516f1f3f264d24a (patch) | |
| tree | e4197645da03dc3c7cc84e434cc31d0a0cca7056 /test-suite | |
| parent | 420f78b2caeaaddc6fe484565b2d0e49c66888e5 (diff) | |
Imported Upstream version 8.5~beta1+dfsg
Diffstat (limited to 'test-suite')
745 files changed, 26652 insertions, 1230 deletions
diff --git a/test-suite/Makefile b/test-suite/Makefile index ae1562c7..4a3a287c 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -30,15 +30,11 @@ BIN := ../bin/ LIB := .. -ifeq ($(BEST),byte) - coqtop := $(BIN)coqtop.byte -boot -q -batch -I prerequisite - bincoqc := $(BIN)coqc -coqlib $(LIB) -byte -I prerequisite -else - coqtop := $(BIN)coqtop -boot -q -batch -I prerequisite - bincoqc := $(BIN)coqc -coqlib $(LIB) -I prerequisite -endif +coqtop := $(BIN)coqtop -boot -q -batch -R prerequisite TestSuite +bincoqc := $(BIN)coqc -coqlib $(LIB) -R prerequisite TestSuite +bincoqchk := $(BIN)coqchk -coqlib $(LIB) -R prerequisite TestSuite -command := $(coqtop) -top Top -load-vernac-source +command := $(coqtop) -top Top -async-proofs-cache force -load-vernac-source coqc := $(coqtop) -compile coqdep := $(BIN)coqdep -coqlib $(LIB) @@ -46,7 +42,16 @@ SHOW := $(if $(VERBOSE),@true,@echo) HIDE := $(if $(VERBOSE),,@) REDIR := $(if $(VERBOSE),,> /dev/null 2>&1) -bogomips := +# read out an emacs config and look for coq-prog-args; if such exists, return it +get_coq_prog_args_helper = sed -n s'/^.*coq-prog-args:[[:space:]]*(\([^)]*\)).*/\1/p' $(1) +get_coq_prog_args = $(strip $(filter-out "-emacs-U" "-emacs",$(shell $(call get_coq_prog_args_helper,$(1))))) +SINGLE_QUOTE=" +#" # double up on the quotes, in a comment, to appease the emacs syntax highlighter +# wrap the arguments in parens, but only if they exist +get_coq_prog_args_in_parens = $(subst $(SINGLE_QUOTE),,$(if $(call get_coq_prog_args,$(1)), ($(call get_coq_prog_args,$(1))))) + + +bogomips:= ifneq (,$(wildcard /proc/cpuinfo)) sedbogo := -e "s/bogomips.*: \([0-9]*\).*/\1/p" # i386, ppc sedbogo += -e "s/Cpu0Bogo.*: \([0-9]*\).*/\1/p" # sparc @@ -59,6 +64,8 @@ ifeq (,$(bogomips)) endif log_success = "==========> SUCCESS <==========" +log_segfault = "==========> FAILURE <==========" +log_anomaly = "==========> FAILURE <==========" log_failure = "==========> FAILURE <==========" log_intro = "==========> TESTING $(1) <==========" @@ -69,14 +76,13 @@ log_intro = "==========> TESTING $(1) <==========" # Apart so that it can be easily skipped with overriding COMPLEXITY := $(if $(bogomips),complexity) -BUGS := bugs/opened/shouldnotfail bugs/opened/shouldnotsucceed \ - bugs/closed/shouldsucceed bugs/closed/shouldfail +BUGS := bugs/opened bugs/closed VSUBSYSTEMS := prerequisite success failure $(BUGS) output \ - interactive micromega $(COMPLEXITY) modules + interactive micromega $(COMPLEXITY) modules stm # All subsystems -SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide +SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk ####################################################################### # Phony targets @@ -93,11 +99,14 @@ bugs: $(BUGS) clean: rm -f trace lia.cache - $(SHOW) "RM <**/*.stamp> <**/*.vo> <**/*.log>" + $(SHOW) "RM <**/*.stamp> <**/*.vo> <**/*.vio> <**/*.log>" $(HIDE)find . \( \ - -name '*.stamp' -o -name '*.vo' -o -name '*.log' \ + -name '*.stamp' -o -name '*.vo' -o -name '*.vio' -o -name '*.log' \ \) -print0 | xargs -0 rm -f +distclean: clean + $(HIDE)find . -name '*.log' -print0 | xargs -0 rm -f + ####################################################################### # Per-subsystem targets ####################################################################### @@ -113,7 +122,7 @@ $(foreach S,$(VSUBSYSTEMS),$(eval $(call mkstamp,$(S)))) # Summary ####################################################################### -summary_dir = echo $(1); find $(2) -name '*.log' -print0 | xargs -0 -n 1 tail -n1 | sort -g +summary_dir = echo $(1); find $(2) -name '*.log' -print0 | xargs -0 -n 1 tail -n1 | sort .PHONY: summary summary.log @@ -129,7 +138,10 @@ summary: $(call summary_dir, "Miscellaneous tests", misc); \ $(call summary_dir, "Complexity tests", complexity); \ $(call summary_dir, "Module tests", modules); \ + $(call summary_dir, "STM tests", stm); \ $(call summary_dir, "IDE tests", ide); \ + $(call summary_dir, "VI tests", vio); \ + $(call summary_dir, "Coqchk tests", coqchk); \ nb_success=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_success) | wc -l`; \ nb_failure=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_failure) | wc -l`; \ nb_tests=`expr $$nb_success + $$nb_failure`; \ @@ -152,32 +164,21 @@ summary.log: # All files are assumed to have <# of the bug>.v as a name -# Opened bugs that should not succeed (FIXME: there were no such tests -# at the time of writing this Makefile, but the possibility was in the -# original shellscript... so left it here, but untested) -$(addsuffix .log,$(wildcard bugs/opened/shouldnotsucceed/*.v)): %.v.log: %.v - @echo "TEST $<" - $(HIDE){ \ - $(call test_intro,$<); \ - $(command) "$<" 2>&1; R=$$?; times; \ - if [ $$R = 0 ]; then \ - echo $(log_success); \ - echo " $<...still active"; \ - else \ - echo $(log_failure); \ - echo " $<...Error! (bug seems to be closed, please check)"; - fi; - } > "$@" - # Opened bugs that should not fail -$(addsuffix .log,$(wildcard bugs/opened/shouldnotfail/*.v)): %.v.log: %.v - @echo "TEST $<" +$(addsuffix .log,$(wildcard bugs/opened/*.v)): %.v.log: %.v + @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(command) "$<" 2>&1; R=$$?; times; \ - if [ $$R != 0 ]; then \ + $(command) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...still active"; \ + elif [ $$R = 129 ]; then \ + echo $(log_anomaly); \ + echo " $<...still active"; \ + elif [ $$R = 139 ]; then \ + echo $(log_segfault); \ + echo " $<...still active"; \ else \ echo $(log_failure); \ echo " $<...Error! (bug seems to be closed, please check)"; \ @@ -185,11 +186,11 @@ $(addsuffix .log,$(wildcard bugs/opened/shouldnotfail/*.v)): %.v.log: %.v } > "$@" # Closed bugs that should succeed -$(addsuffix .log,$(wildcard bugs/closed/shouldsucceed/*.v)): %.v.log: %.v - @echo "TEST $<" +$(addsuffix .log,$(wildcard bugs/closed/*.v)): %.v.log: %.v + @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(command) "$<" 2>&1; R=$$?; times; \ + $(command) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ @@ -199,30 +200,15 @@ $(addsuffix .log,$(wildcard bugs/closed/shouldsucceed/*.v)): %.v.log: %.v fi; \ } > "$@" -# Closed bugs that should fail -$(addsuffix .log,$(wildcard bugs/closed/shouldfail/*.v)): %.v.log: %.v - @echo "TEST $<" - $(HIDE){ \ - echo $(call log_intro,$<); \ - $(command) "$<" 2>&1; R=$$?; times; \ - if [ $$R != 0 ]; then \ - echo $(log_success); \ - echo " $<...Ok"; \ - else \ - echo $(log_failure); \ - echo " $<...Error! (bug seems to be opened, please check)"; \ - fi; \ - } > "$@" - ####################################################################### # Other generic tests ####################################################################### $(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v - @echo "TEST $<" + @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqc) "$*" 2>&1; R=$$?; times; \ + $(coqc) "$*" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ echo " $<...could not be prepared" ; \ @@ -233,11 +219,28 @@ $(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v } > "$@" $(addsuffix .log,$(wildcard success/*.v micromega/*.v modules/*.v)): %.v.log: %.v - @echo "TEST $<" + @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" + $(HIDE){ \ + opts="$(if $(findstring modules/,$<),-R modules Mods -impredicative-set)"; \ + echo $(call log_intro,$<); \ + $(command) "$<" $(call get_coq_prog_args,"$<") $$opts 2>&1; R=$$?; times; \ + if [ $$R = 0 ]; then \ + echo $(log_success); \ + echo " $<...Ok"; \ + else \ + echo $(log_failure); \ + echo " $<...Error! (should be accepted)"; \ + fi; \ + } > "$@" + +stm: $(wildcard stm/*.v:%.v=%.v.log) +$(addsuffix .log,$(wildcard stm/*.v)): %.v.log: %.v + @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ - opts="$(if $(findstring modules/,$<),-I modules -impredicative-set)"; \ echo $(call log_intro,$<); \ - $(command) "$<" $$opts 2>&1; R=$$?; times; \ + $(coqc) "$*" $(call get_coq_prog_args,"$<") -async-proofs on \ + -async-proofs-private-flags fallback-to-lazy-if-marshal-error=no,fallback-to-lazy-if-slave-dies=no \ + $$opts 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ @@ -248,11 +251,11 @@ $(addsuffix .log,$(wildcard success/*.v micromega/*.v modules/*.v)): %.v.log: %. } > "$@" $(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v - @echo "TEST $<" + @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(command) "$<" 2>&1; R=$$?; times; \ - if [ $$R != 0 ]; then \ + $(command) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ else \ @@ -261,13 +264,14 @@ $(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v fi; \ } > "$@" -$(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v - @echo "TEST $<" +$(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v %.out + @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ tmpoutput=`mktemp /tmp/coqcheck.XXXXXX`; \ - $(command) "$<" 2>&1 \ + $(command) "$<" $(call get_coq_prog_args,"$<") 2>&1 \ | grep -v "Welcome to Coq" \ + | grep -v "\[Loading ML file" \ | grep -v "Skipping rcfile loading" \ > $$tmpoutput; \ diff -u $*.out $$tmpoutput 2>&1; R=$$?; times; \ @@ -282,10 +286,10 @@ $(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v } > "$@" $(addsuffix .log,$(wildcard interactive/*.v)): %.v.log: %.v - @echo "TEST $<" + @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqtop) < "$<" 2>&1; R=$$?; times; \ + $(coqtop) $(call get_coq_prog_args,"$<") < "$<" 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ @@ -300,11 +304,11 @@ $(addsuffix .log,$(wildcard interactive/*.v)): %.v.log: %.v # time is a 6120 bogomips cpu. ifneq (,$(bogomips)) $(addsuffix .log,$(wildcard complexity/*.v)): %.v.log: %.v - @echo "TEST $<" + @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ true "extract effective user time"; \ - res=`$(command) "$<" 2>&1 | sed -n -e "s/Finished transaction in .*(\([0-9]*\.[0-9]*\)u.*)/\1/p" | head -1`; \ + res=`$(command) "$<" $(call get_coq_prog_args,"$<") 2>&1 | sed -n -e "s/Finished transaction in .*(\([0-9]*\.[0-9]*\)u.*)/\1/p" | head -1`; \ R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ @@ -331,10 +335,10 @@ endif # Ideal-features tests $(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v - @echo "TEST $<" + @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(command) "$<" 2>&1; R=$$?; times; \ + $(command) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_success); \ echo " $<...still wished"; \ @@ -346,35 +350,17 @@ $(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v # Additionnal dependencies for module tests $(addsuffix .log,$(wildcard modules/*.v)): %.v.log: modules/Nat.vo modules/plik.vo -%.vo: %.v - $(HIDE)$(coqtop) -compile $* +modules/%.vo: modules/%.v + $(HIDE)$(coqtop) -R modules Mods -compile $(<:.v=) ####################################################################### # Miscellaneous tests ####################################################################### -misc: misc/xml.log misc/deps-order.log misc/universes.log +misc: misc/deps-order.log misc/universes.log -# Test xml compilation -xml: misc/xml.log -misc/xml.log: - @echo "TEST misc/xml" - $(HIDE){ \ - echo $(call log_intro,xml); \ - rm -rf misc/xml; \ - COQ_XML_LIBRARY_ROOT=misc/xml \ - $(bincoqc) -xml misc/berardi_test 2>&1; times; \ - if [ ! -d misc/xml ]; then \ - echo $(log_failure); \ - echo " misc/xml... failed"; \ - else \ - echo $(log_success); \ - echo " misc/xml...apparently ok"; \ - fi; rm -rf misc/xml; \ - } > "$@" - -# Check that both coqdep and coqtop/coqc takes the later -I/-R -# Check that both coqdep and coqtop/coqc supports both -R and -I dir -as lib +# Check that both coqdep and coqtop/coqc supports -R +# Check that both coqdep and coqtop/coqc takes the later -R # See bugs 2242, 2337, 2339 deps-order: misc/deps-order.log misc/deps-order.log: @@ -383,12 +369,12 @@ misc/deps-order.log: echo $(call log_intro,deps-order); \ rm -f misc/deps/*/*.vo; \ tmpoutput=`mktemp /tmp/coqcheck.XXXXXX`; \ - $(coqdep) -I misc/deps/lib -as lib -R misc/deps/client client misc/deps/client/bar.v 2>&1 \ + $(coqdep) -R misc/deps/lib lib -R misc/deps/client client misc/deps/client/bar.v 2>&1 \ | head -n 1 > $$tmpoutput; \ diff -u misc/deps/deps.out $$tmpoutput 2>&1; R=$$?; times; \ - $(bincoqc) -I misc/deps/lib -as lib misc/deps/lib/foo.v 2>&1; \ - $(bincoqc) -I misc/deps/lib -as lib -R misc/deps/client client misc/deps/client/foo.v 2>&1; \ - $(coqtop) -I misc/deps/lib -as lib -R misc/deps/client client -load-vernac-source misc/deps/client/bar.v 2>&1; \ + $(bincoqc) -R misc/deps/lib lib misc/deps/lib/foo.v 2>&1; \ + $(bincoqc) -R misc/deps/lib lib -R misc/deps/client client misc/deps/client/foo.v 2>&1; \ + $(coqtop) -R misc/deps/lib lib -R misc/deps/client client -load-vernac-source misc/deps/client/bar.v 2>&1; \ S=$$?; times; \ if [ $$R = 0 -a $$S = 0 ]; then \ echo $(log_success); \ @@ -406,8 +392,8 @@ universes: misc/universes.log misc/universes.log: misc/universes/all_stdlib.v @echo "TEST misc/universes" $(HIDE){ \ - $(bincoqc) -I misc/universes misc/universes/all_stdlib 2>&1; \ - $(bincoqc) -I misc/universes misc/universes/universes 2>&1; \ + $(bincoqc) -R misc/universes Universes misc/universes/all_stdlib 2>&1; \ + $(bincoqc) -R misc/universes Universes misc/universes/universes 2>&1; \ mv universes.txt misc/universes; \ N=`awk '{print $$3}' misc/universes/universes.txt | sort -u | wc -l`; \ times; \ @@ -432,7 +418,7 @@ ide : $(patsubst %.fake,%.fake.log,$(wildcard ide/*.fake)) @echo "TEST $<" $(HIDE){ \ echo $(call log_intro,$<); \ - $(BIN)fake_ide "$(BIN)coqtop -boot" < $< 2>&1; \ + $(BIN)fake_ide $< "$(BIN)coqtop -boot -async-proofs on" 2>&1; \ if [ $$? = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ @@ -441,3 +427,37 @@ ide : $(patsubst %.fake,%.fake.log,$(wildcard ide/*.fake)) echo " $<...Error!"; \ fi; \ } > "$@" + +vio: $(patsubst %.v,%.vio.log,$(wildcard vio/*.v)) + +%.vio.log:%.v + @echo "TEST $<" + $(HIDE){ \ + $(bincoqc) -quick -R vio vio $* 2>&1 && \ + $(coqtop) -R vio vio -vio2vo $*.vio 2>&1 && \ + $(bincoqchk) -R vio vio -norec $(subst /,.,$*) 2>&1; \ + if [ $$? = 0 ]; then \ + echo $(log_success); \ + echo " $<...Ok"; \ + else \ + echo $(log_failure); \ + echo " $<...Error!"; \ + fi; \ + } > "$@" + +coqchk: $(patsubst %.v,%.chk.log,$(wildcard coqchk/*.v)) + +%.chk.log:%.v + @echo "TEST $<" + $(HIDE){ \ + $(bincoqc) -R coqchk coqchk $* 2>&1 && \ + $(bincoqchk) -R coqchk coqchk -norec $(subst /,.,$*) 2>&1; \ + if [ $$? = 0 ]; then \ + echo $(log_success); \ + echo " $<...Ok"; \ + else \ + echo $(log_failure); \ + echo " $<...Error!"; \ + fi; \ + } > "$@" + diff --git a/test-suite/bench/lists-100.v b/test-suite/bench/lists-100.v index 92e50dba..352c7cea 100644 --- a/test-suite/bench/lists-100.v +++ b/test-suite/bench/lists-100.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/bench/lists_100.v b/test-suite/bench/lists_100.v index 92e50dba..352c7cea 100644 --- a/test-suite/bench/lists_100.v +++ b/test-suite/bench/lists_100.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/bugs/2428.v b/test-suite/bugs/2428.v new file mode 100644 index 00000000..a4f587a5 --- /dev/null +++ b/test-suite/bugs/2428.v @@ -0,0 +1,10 @@ +Axiom P : nat -> Prop. + +Definition myFact := forall x, P x. + +Hint Extern 1 (P _) => progress (unfold myFact in *). + +Lemma test : (True -> myFact) -> P 3. +Proof. + intros. debug eauto. +Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/1100.v b/test-suite/bugs/closed/1100.v index 32c78b4b..32c78b4b 100644 --- a/test-suite/bugs/closed/shouldsucceed/1100.v +++ b/test-suite/bugs/closed/1100.v diff --git a/test-suite/bugs/closed/shouldsucceed/121.v b/test-suite/bugs/closed/121.v index 8c5a3885..8c5a3885 100644 --- a/test-suite/bugs/closed/shouldsucceed/121.v +++ b/test-suite/bugs/closed/121.v diff --git a/test-suite/bugs/closed/shouldsucceed/1243.v b/test-suite/bugs/closed/1243.v index 7d6781db..7d6781db 100644 --- a/test-suite/bugs/closed/shouldsucceed/1243.v +++ b/test-suite/bugs/closed/1243.v diff --git a/test-suite/bugs/closed/shouldsucceed/1302.v b/test-suite/bugs/closed/1302.v index e94dfcfb..e94dfcfb 100644 --- a/test-suite/bugs/closed/shouldsucceed/1302.v +++ b/test-suite/bugs/closed/1302.v diff --git a/test-suite/bugs/closed/shouldsucceed/1322.v b/test-suite/bugs/closed/1322.v index 1ec7d452..1ec7d452 100644 --- a/test-suite/bugs/closed/shouldsucceed/1322.v +++ b/test-suite/bugs/closed/1322.v diff --git a/test-suite/bugs/closed/shouldsucceed/1411.v b/test-suite/bugs/closed/1411.v index a1a7b288..a1a7b288 100644 --- a/test-suite/bugs/closed/shouldsucceed/1411.v +++ b/test-suite/bugs/closed/1411.v diff --git a/test-suite/bugs/closed/shouldsucceed/1414.v b/test-suite/bugs/closed/1414.v index ee9e2504..ee9e2504 100644 --- a/test-suite/bugs/closed/shouldsucceed/1414.v +++ b/test-suite/bugs/closed/1414.v diff --git a/test-suite/bugs/closed/shouldsucceed/1416.v b/test-suite/bugs/closed/1416.v index ee092005..ee092005 100644 --- a/test-suite/bugs/closed/shouldsucceed/1416.v +++ b/test-suite/bugs/closed/1416.v diff --git a/test-suite/bugs/closed/shouldsucceed/1419.v b/test-suite/bugs/closed/1419.v index d021107d..d021107d 100644 --- a/test-suite/bugs/closed/shouldsucceed/1419.v +++ b/test-suite/bugs/closed/1419.v diff --git a/test-suite/bugs/closed/shouldsucceed/1425.v b/test-suite/bugs/closed/1425.v index 6be30174..6be30174 100644 --- a/test-suite/bugs/closed/shouldsucceed/1425.v +++ b/test-suite/bugs/closed/1425.v diff --git a/test-suite/bugs/closed/shouldsucceed/1446.v b/test-suite/bugs/closed/1446.v index 8cb2d653..8cb2d653 100644 --- a/test-suite/bugs/closed/shouldsucceed/1446.v +++ b/test-suite/bugs/closed/1446.v diff --git a/test-suite/bugs/closed/shouldsucceed/1448.v b/test-suite/bugs/closed/1448.v index fe3b4c8b..fe3b4c8b 100644 --- a/test-suite/bugs/closed/shouldsucceed/1448.v +++ b/test-suite/bugs/closed/1448.v diff --git a/test-suite/bugs/closed/shouldsucceed/1477.v b/test-suite/bugs/closed/1477.v index dfc8c328..dfc8c328 100644 --- a/test-suite/bugs/closed/shouldsucceed/1477.v +++ b/test-suite/bugs/closed/1477.v diff --git a/test-suite/bugs/closed/shouldsucceed/1483.v b/test-suite/bugs/closed/1483.v index a3d7f168..a3d7f168 100644 --- a/test-suite/bugs/closed/shouldsucceed/1483.v +++ b/test-suite/bugs/closed/1483.v diff --git a/test-suite/bugs/closed/shouldsucceed/1507.v b/test-suite/bugs/closed/1507.v index f2ab9100..f2ab9100 100644 --- a/test-suite/bugs/closed/shouldsucceed/1507.v +++ b/test-suite/bugs/closed/1507.v diff --git a/test-suite/bugs/closed/shouldsucceed/1568.v b/test-suite/bugs/closed/1568.v index 3609e9c8..3609e9c8 100644 --- a/test-suite/bugs/closed/shouldsucceed/1568.v +++ b/test-suite/bugs/closed/1568.v diff --git a/test-suite/bugs/closed/shouldsucceed/1576.v b/test-suite/bugs/closed/1576.v index 3621f7a1..3621f7a1 100644 --- a/test-suite/bugs/closed/shouldsucceed/1576.v +++ b/test-suite/bugs/closed/1576.v diff --git a/test-suite/bugs/closed/shouldsucceed/1582.v b/test-suite/bugs/closed/1582.v index be5d3dd2..be5d3dd2 100644 --- a/test-suite/bugs/closed/shouldsucceed/1582.v +++ b/test-suite/bugs/closed/1582.v diff --git a/test-suite/bugs/closed/shouldsucceed/1604.v b/test-suite/bugs/closed/1604.v index 22c3df82..22c3df82 100644 --- a/test-suite/bugs/closed/shouldsucceed/1604.v +++ b/test-suite/bugs/closed/1604.v diff --git a/test-suite/bugs/closed/shouldsucceed/1614.v b/test-suite/bugs/closed/1614.v index 6bc165d4..6bc165d4 100644 --- a/test-suite/bugs/closed/shouldsucceed/1614.v +++ b/test-suite/bugs/closed/1614.v diff --git a/test-suite/bugs/closed/shouldsucceed/1618.v b/test-suite/bugs/closed/1618.v index a9b067ce..a9b067ce 100644 --- a/test-suite/bugs/closed/shouldsucceed/1618.v +++ b/test-suite/bugs/closed/1618.v diff --git a/test-suite/bugs/closed/shouldsucceed/1634.v b/test-suite/bugs/closed/1634.v index 0150c250..0150c250 100644 --- a/test-suite/bugs/closed/shouldsucceed/1634.v +++ b/test-suite/bugs/closed/1634.v diff --git a/test-suite/bugs/closed/shouldsucceed/1643.v b/test-suite/bugs/closed/1643.v index 879a65b1..879a65b1 100644 --- a/test-suite/bugs/closed/shouldsucceed/1643.v +++ b/test-suite/bugs/closed/1643.v diff --git a/test-suite/bugs/closed/shouldsucceed/1680.v b/test-suite/bugs/closed/1680.v index 524c7bab..524c7bab 100644 --- a/test-suite/bugs/closed/shouldsucceed/1680.v +++ b/test-suite/bugs/closed/1680.v diff --git a/test-suite/bugs/closed/shouldsucceed/1683.v b/test-suite/bugs/closed/1683.v index 3e99694b..3e99694b 100644 --- a/test-suite/bugs/closed/shouldsucceed/1683.v +++ b/test-suite/bugs/closed/1683.v diff --git a/test-suite/bugs/closed/shouldsucceed/1696.v b/test-suite/bugs/closed/1696.v index 0826428a..0826428a 100644 --- a/test-suite/bugs/closed/shouldsucceed/1696.v +++ b/test-suite/bugs/closed/1696.v diff --git a/test-suite/bugs/closed/shouldfail/1703.v b/test-suite/bugs/closed/1703.v index 6b5198cc..114e3185 100644 --- a/test-suite/bugs/closed/shouldfail/1703.v +++ b/test-suite/bugs/closed/1703.v @@ -4,4 +4,5 @@ Ltac intros_until n := intros until n. Goal forall i j m n : nat, i = 0 /\ j = 0 /\ m = 0 /\ n = 0. intro i. -intros until i. +Fail intros until i. +Abort. diff --git a/test-suite/bugs/closed/shouldsucceed/1704.v b/test-suite/bugs/closed/1704.v index 4b02d5f9..4b02d5f9 100644 --- a/test-suite/bugs/closed/shouldsucceed/1704.v +++ b/test-suite/bugs/closed/1704.v diff --git a/test-suite/bugs/closed/shouldsucceed/1711.v b/test-suite/bugs/closed/1711.v index e16612e3..e16612e3 100644 --- a/test-suite/bugs/closed/shouldsucceed/1711.v +++ b/test-suite/bugs/closed/1711.v diff --git a/test-suite/bugs/closed/shouldsucceed/1718.v b/test-suite/bugs/closed/1718.v index 715fa941..715fa941 100644 --- a/test-suite/bugs/closed/shouldsucceed/1718.v +++ b/test-suite/bugs/closed/1718.v diff --git a/test-suite/bugs/closed/shouldsucceed/1738.v b/test-suite/bugs/closed/1738.v index c2926a2b..c2926a2b 100644 --- a/test-suite/bugs/closed/shouldsucceed/1738.v +++ b/test-suite/bugs/closed/1738.v diff --git a/test-suite/bugs/closed/shouldsucceed/1740.v b/test-suite/bugs/closed/1740.v index ec4a7a6b..ec4a7a6b 100644 --- a/test-suite/bugs/closed/shouldsucceed/1740.v +++ b/test-suite/bugs/closed/1740.v diff --git a/test-suite/bugs/closed/shouldsucceed/1754.v b/test-suite/bugs/closed/1754.v index 06b8dce8..06b8dce8 100644 --- a/test-suite/bugs/closed/shouldsucceed/1754.v +++ b/test-suite/bugs/closed/1754.v diff --git a/test-suite/bugs/closed/shouldsucceed/1773.v b/test-suite/bugs/closed/1773.v index 211af89b..211af89b 100644 --- a/test-suite/bugs/closed/shouldsucceed/1773.v +++ b/test-suite/bugs/closed/1773.v diff --git a/test-suite/bugs/closed/shouldsucceed/1774.v b/test-suite/bugs/closed/1774.v index 4c24b481..4c24b481 100644 --- a/test-suite/bugs/closed/shouldsucceed/1774.v +++ b/test-suite/bugs/closed/1774.v diff --git a/test-suite/bugs/closed/shouldsucceed/1775.v b/test-suite/bugs/closed/1775.v index 932949a3..932949a3 100644 --- a/test-suite/bugs/closed/shouldsucceed/1775.v +++ b/test-suite/bugs/closed/1775.v diff --git a/test-suite/bugs/closed/shouldsucceed/1776.v b/test-suite/bugs/closed/1776.v index 58491f9d..58491f9d 100644 --- a/test-suite/bugs/closed/shouldsucceed/1776.v +++ b/test-suite/bugs/closed/1776.v diff --git a/test-suite/bugs/closed/shouldsucceed/1779.v b/test-suite/bugs/closed/1779.v index 95bb66b9..95bb66b9 100644 --- a/test-suite/bugs/closed/shouldsucceed/1779.v +++ b/test-suite/bugs/closed/1779.v diff --git a/test-suite/bugs/closed/shouldsucceed/1784.v b/test-suite/bugs/closed/1784.v index fb2f0ca9..0b63d7b5 100644 --- a/test-suite/bugs/closed/shouldsucceed/1784.v +++ b/test-suite/bugs/closed/1784.v @@ -92,7 +92,7 @@ Next Obligation. intro H; inversion H; subst. Defined. Next Obligation. intro H1; contradict H. inversion H1; subst. assumption. contradict H0; assumption. Defined. -Next Obligation. +Next Obligation. intro H1; contradict H0. inversion H1; subst. assumption. Defined. Next Obligation. intro H1; contradict H. inversion H1; subst. assumption. Defined. diff --git a/test-suite/bugs/closed/shouldsucceed/1791.v b/test-suite/bugs/closed/1791.v index be0e8ae8..be0e8ae8 100644 --- a/test-suite/bugs/closed/shouldsucceed/1791.v +++ b/test-suite/bugs/closed/1791.v diff --git a/test-suite/bugs/closed/shouldsucceed/1834.v b/test-suite/bugs/closed/1834.v index 947d15f0..884ac01c 100644 --- a/test-suite/bugs/closed/shouldsucceed/1834.v +++ b/test-suite/bugs/closed/1834.v @@ -53,7 +53,7 @@ Definition S1_1 y0 y1 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) := y1 e1. Definition eq_ok1 y0 y1 y2 (E: eq_1 y0 y1) := - match E with exist e0 e1 => S1_1 y0 y1 e0 e1 = y2 end. + match E with exist _ e0 e1 => S1_1 y0 y1 e0 e1 = y2 end. Definition eq_2 y0 y1 y2 := {E1:eq_1 y0 y1 | eq_ok1 y0 y1 y2 E1}. @@ -81,7 +81,7 @@ Definition S2_2 y0 y1 y2 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) y2 e2. Definition eq_ok2 y0 y1 y2 y3 (E: eq_2 y0 y1 y2) : Prop := - match E with exist (exist e0 e1) e2 => + match E with exist _ (exist _ e0 e1) e2 => S2_2 y0 y1 y2 e0 e1 e2 = y3 end. Definition eq_3 y0 y1 y2 y3 := @@ -118,7 +118,7 @@ Definition S3_3 y0 y1 y2 y3 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) y3 e3. Definition eq_ok3 y0 y1 y2 y3 y4 (E: eq_3 y0 y1 y2 y3) : Prop := - match E with exist (exist (exist e0 e1) e2) e3 => + match E with exist _ (exist _ (exist _ e0 e1) e2) e3 => S3_3 y0 y1 y2 y3 e0 e1 e2 e3 = y4 end. Definition eq_4 y0 y1 y2 y3 y4 := @@ -165,7 +165,7 @@ Definition S4_4 y0 y1 y2 y3 y4 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) y4 e4. Definition eq_ok4 y0 y1 y2 y3 y4 y5 (E: eq_4 y0 y1 y2 y3 y4) : Prop := - match E with exist (exist (exist (exist e0 e1) e2) e3) e4 => + match E with exist _ (exist _ (exist _ (exist _ e0 e1) e2) e3) e4 => S4_4 y0 y1 y2 y3 y4 e0 e1 e2 e3 e4 = y5 end. Definition eq_5 y0 y1 y2 y3 y4 y5 := diff --git a/test-suite/bugs/closed/shouldsucceed/1844.v b/test-suite/bugs/closed/1844.v index 17eeb352..17eeb352 100644 --- a/test-suite/bugs/closed/shouldsucceed/1844.v +++ b/test-suite/bugs/closed/1844.v diff --git a/test-suite/bugs/closed/shouldsucceed/1865.v b/test-suite/bugs/closed/1865.v index 17c19989..17c19989 100644 --- a/test-suite/bugs/closed/shouldsucceed/1865.v +++ b/test-suite/bugs/closed/1865.v diff --git a/test-suite/bugs/closed/shouldsucceed/1891.v b/test-suite/bugs/closed/1891.v index 2d90a2f1..68581117 100644 --- a/test-suite/bugs/closed/shouldsucceed/1891.v +++ b/test-suite/bugs/closed/1891.v @@ -7,7 +7,7 @@ Lemma L (x: T unit): (unit -> T unit) -> unit. Proof. - refine (match x return _ with mkT n => fun g => f (g _) end). + refine (match x return _ with mkT _ n => fun g => f (g _) end). trivial. Qed. diff --git a/test-suite/bugs/closed/shouldfail/1898.v b/test-suite/bugs/closed/1898.v index 92490eb9..70461286 100644 --- a/test-suite/bugs/closed/shouldfail/1898.v +++ b/test-suite/bugs/closed/1898.v @@ -2,4 +2,5 @@ Lemma bug_fold_unfold : True. set (h := 1). - fold h in h. + Fail fold h in h. + Abort. diff --git a/test-suite/bugs/closed/shouldsucceed/1900.v b/test-suite/bugs/closed/1900.v index cf03efda..cf03efda 100644 --- a/test-suite/bugs/closed/shouldsucceed/1900.v +++ b/test-suite/bugs/closed/1900.v diff --git a/test-suite/bugs/closed/shouldsucceed/1901.v b/test-suite/bugs/closed/1901.v index 7d86adbf..7d86adbf 100644 --- a/test-suite/bugs/closed/shouldsucceed/1901.v +++ b/test-suite/bugs/closed/1901.v diff --git a/test-suite/bugs/closed/shouldsucceed/1905.v b/test-suite/bugs/closed/1905.v index 8c81d751..8c81d751 100644 --- a/test-suite/bugs/closed/shouldsucceed/1905.v +++ b/test-suite/bugs/closed/1905.v diff --git a/test-suite/bugs/closed/shouldsucceed/1907.v b/test-suite/bugs/closed/1907.v index 55fc8231..55fc8231 100644 --- a/test-suite/bugs/closed/shouldsucceed/1907.v +++ b/test-suite/bugs/closed/1907.v diff --git a/test-suite/bugs/closed/shouldsucceed/1912.v b/test-suite/bugs/closed/1912.v index 987a5417..987a5417 100644 --- a/test-suite/bugs/closed/shouldsucceed/1912.v +++ b/test-suite/bugs/closed/1912.v diff --git a/test-suite/bugs/closed/1915.v b/test-suite/bugs/closed/1915.v new file mode 100644 index 00000000..7e62437d --- /dev/null +++ b/test-suite/bugs/closed/1915.v @@ -0,0 +1,6 @@ + +Require Import Setoid. + +Fail Goal forall x, impl True (x = 0) -> x = 0 -> False. +(*intros x H E. +rewrite H in E.*)
\ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/1918.v b/test-suite/bugs/closed/1918.v index 9d92fe12..9d92fe12 100644 --- a/test-suite/bugs/closed/shouldsucceed/1918.v +++ b/test-suite/bugs/closed/1918.v diff --git a/test-suite/bugs/closed/shouldsucceed/1925.v b/test-suite/bugs/closed/1925.v index 4caee1c3..4caee1c3 100644 --- a/test-suite/bugs/closed/shouldsucceed/1925.v +++ b/test-suite/bugs/closed/1925.v diff --git a/test-suite/bugs/closed/shouldsucceed/1931.v b/test-suite/bugs/closed/1931.v index 930ace1d..930ace1d 100644 --- a/test-suite/bugs/closed/shouldsucceed/1931.v +++ b/test-suite/bugs/closed/1931.v diff --git a/test-suite/bugs/closed/shouldsucceed/1935.v b/test-suite/bugs/closed/1935.v index d5837619..d5837619 100644 --- a/test-suite/bugs/closed/shouldsucceed/1935.v +++ b/test-suite/bugs/closed/1935.v diff --git a/test-suite/bugs/closed/shouldsucceed/1939.v b/test-suite/bugs/closed/1939.v index 5e61529b..5e61529b 100644 --- a/test-suite/bugs/closed/shouldsucceed/1939.v +++ b/test-suite/bugs/closed/1939.v diff --git a/test-suite/bugs/closed/shouldsucceed/1944.v b/test-suite/bugs/closed/1944.v index ee2918c6..ee2918c6 100644 --- a/test-suite/bugs/closed/shouldsucceed/1944.v +++ b/test-suite/bugs/closed/1944.v diff --git a/test-suite/bugs/closed/shouldsucceed/1951.v b/test-suite/bugs/closed/1951.v index 12c0ef9b..7558b0b8 100644 --- a/test-suite/bugs/closed/shouldsucceed/1951.v +++ b/test-suite/bugs/closed/1951.v @@ -5,11 +5,11 @@ Set Printing Universes. Inductive enc (A:Type (*1*)) (* : Type.1 *) := C : A -> enc A. -Definition id (X:Type(*5*)) (x:X) := x. +Definition id (X:Type(*4*)) (x:X) := x. -Lemma test : let S := Type(*6 : 7*) in enc S -> S. +Lemma test : let S := Type(*5 : 6*) in enc S -> S. simpl; intros. -apply enc. +refine (enc _). apply id. apply Prop. Defined. @@ -26,7 +26,7 @@ b : (list a) -> a. (* i don't know if this *) Inductive sg : Type := Sg. (* single *) Definition ipl2 (P : a -> Type) := (* in Prop, that means P is true forall *) -fold_right (fun x => prod (P x)) sg. (* the elements of a given list *) + fold_right (fun x => fun A => prod (P x) A) sg. (* the elements of a given list *) Definition ind : forall S : a -> Type, @@ -55,7 +55,7 @@ Defined. Lemma k' : a -> Type. (* same lemma but with our bug *) intro;pattern H;apply ind;intros. - apply prod. + refine (prod _ _). induction ls. exact sg. exact sg. diff --git a/test-suite/bugs/closed/shouldsucceed/1962.v b/test-suite/bugs/closed/1962.v index a6b0fee5..a6b0fee5 100644 --- a/test-suite/bugs/closed/shouldsucceed/1962.v +++ b/test-suite/bugs/closed/1962.v diff --git a/test-suite/bugs/closed/shouldsucceed/1963.v b/test-suite/bugs/closed/1963.v index 11e2ee44..11e2ee44 100644 --- a/test-suite/bugs/closed/shouldsucceed/1963.v +++ b/test-suite/bugs/closed/1963.v diff --git a/test-suite/bugs/closed/shouldsucceed/1977.v b/test-suite/bugs/closed/1977.v index 28715040..28715040 100644 --- a/test-suite/bugs/closed/shouldsucceed/1977.v +++ b/test-suite/bugs/closed/1977.v diff --git a/test-suite/bugs/closed/shouldsucceed/1981.v b/test-suite/bugs/closed/1981.v index 99952682..99952682 100644 --- a/test-suite/bugs/closed/shouldsucceed/1981.v +++ b/test-suite/bugs/closed/1981.v diff --git a/test-suite/bugs/closed/shouldsucceed/2001.v b/test-suite/bugs/closed/2001.v index d0b3bf17..d0b3bf17 100644 --- a/test-suite/bugs/closed/shouldsucceed/2001.v +++ b/test-suite/bugs/closed/2001.v diff --git a/test-suite/bugs/closed/shouldfail/2006.v b/test-suite/bugs/closed/2006.v index 91a16f95..d353d0e2 100644 --- a/test-suite/bugs/closed/shouldfail/2006.v +++ b/test-suite/bugs/closed/2006.v @@ -1,7 +1,7 @@ (* Take the type constraint on Record into account *) Definition Type1 := Type. -Record R : Type1 := { p:Type1 }. (* was accepted before trunk revision 11619 *) +Fail Record R : Type1 := { p:Type1 }. (* was accepted before trunk revision 11619 *) (* Remarks: diff --git a/test-suite/bugs/closed/shouldsucceed/2017.v b/test-suite/bugs/closed/2017.v index df666148..df666148 100644 --- a/test-suite/bugs/closed/shouldsucceed/2017.v +++ b/test-suite/bugs/closed/2017.v diff --git a/test-suite/bugs/closed/shouldsucceed/2021.v b/test-suite/bugs/closed/2021.v index e598e5ae..e598e5ae 100644 --- a/test-suite/bugs/closed/shouldsucceed/2021.v +++ b/test-suite/bugs/closed/2021.v diff --git a/test-suite/bugs/closed/shouldsucceed/2027.v b/test-suite/bugs/closed/2027.v index fb53c6ef..fb53c6ef 100644 --- a/test-suite/bugs/closed/shouldsucceed/2027.v +++ b/test-suite/bugs/closed/2027.v diff --git a/test-suite/bugs/closed/shouldsucceed/2083.v b/test-suite/bugs/closed/2083.v index a6ce4de0..5f17f7af 100644 --- a/test-suite/bugs/closed/shouldsucceed/2083.v +++ b/test-suite/bugs/closed/2083.v @@ -15,7 +15,7 @@ Program Fixpoint check_n (n : nat) (P : { i | i < n } -> bool) (p : nat) Require Import Omega. -Solve Obligations using program_simpl ; auto with *; try omega. +Solve Obligations with program_simpl ; auto with *; try omega. Next Obligation. apply H. simpl. omega. diff --git a/test-suite/bugs/closed/shouldsucceed/2089.v b/test-suite/bugs/closed/2089.v index aebccc94..aebccc94 100644 --- a/test-suite/bugs/closed/shouldsucceed/2089.v +++ b/test-suite/bugs/closed/2089.v diff --git a/test-suite/bugs/closed/shouldsucceed/2095.v b/test-suite/bugs/closed/2095.v index 28ea99df..28ea99df 100644 --- a/test-suite/bugs/closed/shouldsucceed/2095.v +++ b/test-suite/bugs/closed/2095.v diff --git a/test-suite/bugs/closed/shouldsucceed/2108.v b/test-suite/bugs/closed/2108.v index cad8baa9..cad8baa9 100644 --- a/test-suite/bugs/closed/shouldsucceed/2108.v +++ b/test-suite/bugs/closed/2108.v diff --git a/test-suite/bugs/closed/shouldsucceed/2117.v b/test-suite/bugs/closed/2117.v index 6377a8b7..6377a8b7 100644 --- a/test-suite/bugs/closed/shouldsucceed/2117.v +++ b/test-suite/bugs/closed/2117.v diff --git a/test-suite/bugs/closed/shouldsucceed/2123.v b/test-suite/bugs/closed/2123.v index 422a2c12..422a2c12 100644 --- a/test-suite/bugs/closed/shouldsucceed/2123.v +++ b/test-suite/bugs/closed/2123.v diff --git a/test-suite/bugs/closed/shouldsucceed/2127.v b/test-suite/bugs/closed/2127.v index 142ada26..142ada26 100644 --- a/test-suite/bugs/closed/shouldsucceed/2127.v +++ b/test-suite/bugs/closed/2127.v diff --git a/test-suite/bugs/closed/shouldsucceed/2135.v b/test-suite/bugs/closed/2135.v index 61882176..61882176 100644 --- a/test-suite/bugs/closed/shouldsucceed/2135.v +++ b/test-suite/bugs/closed/2135.v diff --git a/test-suite/bugs/closed/shouldsucceed/2136.v b/test-suite/bugs/closed/2136.v index d2b926f3..d2b926f3 100644 --- a/test-suite/bugs/closed/shouldsucceed/2136.v +++ b/test-suite/bugs/closed/2136.v diff --git a/test-suite/bugs/closed/shouldsucceed/2137.v b/test-suite/bugs/closed/2137.v index 6c2023ab..6c2023ab 100644 --- a/test-suite/bugs/closed/shouldsucceed/2137.v +++ b/test-suite/bugs/closed/2137.v diff --git a/test-suite/bugs/closed/shouldsucceed/2139.v b/test-suite/bugs/closed/2139.v index a7f35508..a7f35508 100644 --- a/test-suite/bugs/closed/shouldsucceed/2139.v +++ b/test-suite/bugs/closed/2139.v diff --git a/test-suite/bugs/closed/shouldsucceed/2141.v b/test-suite/bugs/closed/2141.v index 941ae530..941ae530 100644 --- a/test-suite/bugs/closed/shouldsucceed/2141.v +++ b/test-suite/bugs/closed/2141.v diff --git a/test-suite/bugs/closed/shouldsucceed/2145.v b/test-suite/bugs/closed/2145.v index 4dc0de74..4dc0de74 100644 --- a/test-suite/bugs/closed/shouldsucceed/2145.v +++ b/test-suite/bugs/closed/2145.v diff --git a/test-suite/bugs/closed/2149.v b/test-suite/bugs/closed/2149.v new file mode 100644 index 00000000..38c5f36a --- /dev/null +++ b/test-suite/bugs/closed/2149.v @@ -0,0 +1,7 @@ +Lemma Foo : forall x y : nat, y = x -> y = x. +Proof. +intros x y. +rename x into y, y into x. +trivial. +Qed. + diff --git a/test-suite/bugs/closed/2164.v b/test-suite/bugs/closed/2164.v new file mode 100644 index 00000000..6adb3577 --- /dev/null +++ b/test-suite/bugs/closed/2164.v @@ -0,0 +1,334 @@ +(* Check that "inversion as" manages names as expected *) +Inductive type: Set + := | int: type + | pointer: type -> type. +Print type. + +Parameter value_set + : type -> Set. + +Parameter string : Set. + +Parameter Z : Set. + +Inductive lvalue (t: type): Set + := | var: string -> lvalue t (* name of the variable *) + | lvalue_loc: Z -> lvalue t (* address of the variable *) + | deref_l: lvalue (pointer t) -> lvalue t (* deref an lvalue ptr *) + | deref_r: rvalue (pointer t) -> lvalue t (* deref an rvalue ptr *) +with rvalue (t: type): Set + := | value_of: lvalue t -> rvalue t (* variable as value *) + | mk_rvalue: value_set t -> rvalue t. (* literal value *) +Print lvalue. + +Inductive statement: Set + := | void_stat: statement + | var_loc: (* to be destucted at end of scope *) + forall (t: type) (n: string) (loc: Z), statement + | var_ref: (* not to be destructed *) + forall (t: type) (n: string) (loc: Z), statement + | var_def: (* var def as typed in code *) + forall (t:type) (n: string) (val: rvalue t), statement + | assign: + forall (t: type) (var: lvalue t) (val: rvalue t), statement + | group: + forall (l: list statement), statement + | fun_def: + forall (s: string) (l: list statement), statement + | param_decl: + forall (t: type) (n: string), statement + | delete: + forall a: Z, statement. + +Inductive expr: Set +:= | statement_to_expr: statement -> expr + | lvalue_to_expr: forall t: type, lvalue t -> expr + | rvalue_to_expr: forall t: type, rvalue t -> expr. + +Inductive executable_prim_expr: expr -> Set +:= +(* statements *) + | var_def_primitive: + forall (t: type) (n: string) (loc: Z), + executable_prim_expr + (statement_to_expr + (var_def t n + (value_of t (lvalue_loc t loc)))) + | assign_primitive: + forall (t: type) (loc1 loc2: Z), + executable_prim_expr + (statement_to_expr + (assign t (lvalue_loc t loc1) + (value_of t (lvalue_loc t loc2)))) +(* rvalue *) + | mk_rvalue_primitive: + forall (t: type) (v: value_set t), + executable_prim_expr + (rvalue_to_expr t (mk_rvalue t v)) +(* lvalue *) + (* var *) + | var_primitive: + forall (t: type) (n: string), + executable_prim_expr (lvalue_to_expr t (var t n)) + (* deref_l *) + | deref_l_primitive: + forall (t: type) (loc: Z), + executable_prim_expr + (lvalue_to_expr t + (deref_l t (lvalue_loc (pointer t) loc))) + (* deref_r *) + | deref_r_primitive: + forall (t: type) (loc: Z), + executable_prim_expr + (lvalue_to_expr t + (deref_r t + (value_of (pointer t) + (lvalue_loc (pointer t) loc)))). + +Inductive executable_sub_expr: expr -> Set +:= | executable_sub_expr_prim: + forall e: expr, + executable_prim_expr e -> + executable_sub_expr e +(* statements *) + | var_def_sub_rvalue: + forall (t: type) (n: string) (rv: rvalue t), + executable_sub_expr (rvalue_to_expr t rv) -> + executable_sub_expr (statement_to_expr (var_def t n rv)) + | assign_sub_lvalue: + forall (t: type) (lv: lvalue t) (rv: rvalue t), + executable_sub_expr (lvalue_to_expr t lv) -> + executable_sub_expr (statement_to_expr (assign t lv rv)) + | assign_sub_rvalue: + forall (t: type) (lv: lvalue t) (rv: rvalue t), + executable_sub_expr (rvalue_to_expr t rv) -> + executable_sub_expr (statement_to_expr (assign t lv rv)) +(* rvalue *) + | value_of_sub_lvalue: + forall (t: type) (lv: lvalue t), + executable_sub_expr (lvalue_to_expr t lv) -> + executable_sub_expr (rvalue_to_expr t (value_of t lv)) +(* lvalue *) + | deref_l_sub_lvalue: + forall (t: type) (lv: lvalue (pointer t)), + executable_sub_expr (lvalue_to_expr (pointer t) lv) -> + executable_sub_expr (lvalue_to_expr t (deref_l t lv)) + | deref_r_sub_rvalue: + forall (t: type) (rv: rvalue (pointer t)), + executable_sub_expr (rvalue_to_expr (pointer t) rv) -> + executable_sub_expr (lvalue_to_expr t (deref_r t rv)). + +Inductive expr_kind: Set +:= | statement_kind: expr_kind + | lvalue_kind: type -> expr_kind + | rvalue_kind: type -> expr_kind. + +Definition expr_to_kind: expr -> expr_kind. +intro e. +destruct e. +exact statement_kind. +exact (lvalue_kind t). +exact (rvalue_kind t). +Defined. + +Inductive def_sub_expr_subs: + forall e: expr, + forall ee: executable_sub_expr e, + forall ee': expr, + forall e': expr, + Prop +:= | def_sub_expr_subs_prim: + forall e: expr, + forall p: executable_prim_expr e, + forall ee': expr, + expr_to_kind e = expr_to_kind ee' -> + def_sub_expr_subs e (executable_sub_expr_prim e p) ee' ee' + | def_sub_expr_subs_var_def_sub_rvalue: + forall (t: type) (n: string), + forall rv rv': rvalue t, + forall ee': expr, + forall se_rv: executable_sub_expr (rvalue_to_expr t rv), + def_sub_expr_subs (rvalue_to_expr t rv) se_rv ee' + (rvalue_to_expr t rv') -> + def_sub_expr_subs + (statement_to_expr (var_def t n rv)) + (var_def_sub_rvalue t n rv se_rv) + ee' + (statement_to_expr (var_def t n rv')) + | def_sub_expr_subs_assign_sub_lvalue: + forall t: type, + forall lv lv': lvalue t, + forall rv: rvalue t, + forall ee': expr, + forall se_lv: executable_sub_expr (lvalue_to_expr t lv), + def_sub_expr_subs (lvalue_to_expr t lv) se_lv ee' + (lvalue_to_expr t lv') -> + def_sub_expr_subs + (statement_to_expr (assign t lv rv)) + (assign_sub_lvalue t lv rv se_lv) + ee' + (statement_to_expr (assign t lv' rv)) + | def_sub_expr_subs_assign_sub_rvalue: + forall t: type, + forall lv: lvalue t, + forall rv rv': rvalue t, + forall ee': expr, + forall se_rv: executable_sub_expr (rvalue_to_expr t rv), + def_sub_expr_subs (rvalue_to_expr t rv) se_rv ee' + (rvalue_to_expr t rv') -> + def_sub_expr_subs + (statement_to_expr (assign t lv rv)) + (assign_sub_rvalue t lv rv se_rv) + ee' + (statement_to_expr (assign t lv rv')) + | def_sub_expr_subs_value_of_sub_lvalue: + forall t: type, + forall lv lv': lvalue t, + forall ee': expr, + forall se_lv: executable_sub_expr (lvalue_to_expr t lv), + def_sub_expr_subs (lvalue_to_expr t lv) se_lv ee' + (lvalue_to_expr t lv') -> + def_sub_expr_subs + (rvalue_to_expr t (value_of t lv)) + (value_of_sub_lvalue t lv se_lv) + ee' + (rvalue_to_expr t (value_of t lv')) + | def_sub_expr_subs_deref_l_sub_lvalue: + forall t: type, + forall lv lv': lvalue (pointer t), + forall ee': expr, + forall se_lv: executable_sub_expr (lvalue_to_expr (pointer t) lv), + def_sub_expr_subs (lvalue_to_expr (pointer t) lv) se_lv ee' + (lvalue_to_expr (pointer t) lv') -> + def_sub_expr_subs + (lvalue_to_expr t (deref_l t lv)) + (deref_l_sub_lvalue t lv se_lv) + ee' + (lvalue_to_expr t (deref_l t lv')) + | def_sub_expr_subs_deref_r_sub_rvalue: + forall t: type, + forall rv rv': rvalue (pointer t), + forall ee': expr, + forall se_rv: executable_sub_expr (rvalue_to_expr (pointer t) rv), + def_sub_expr_subs (rvalue_to_expr (pointer t) rv) se_rv ee' + (rvalue_to_expr (pointer t) rv') -> + def_sub_expr_subs + (lvalue_to_expr t (deref_r t rv)) + (deref_r_sub_rvalue t rv se_rv) + ee' + (lvalue_to_expr t (deref_r t rv')). + +Lemma type_dec: forall t t': type, {t = t'} + {t <> t'}. +Proof. +intros t. +induction t as [|t IH]. +destruct t'. +tauto. +right. +discriminate. +destruct t'. +right. +discriminate. +destruct (IH t') as [H|H]. +left. +f_equal. +tauto. +right. +injection. +tauto. +Qed. +Check type_dec. + +Definition sigT_get_proof: + forall T: Type, + forall eq_dec_T: forall t t': T, {t = t'} + {~ t = t'}, + forall P: T -> Type, + forall t: T, + P t -> + sigT P -> + P t. +intros T eq_dec_T P t H1 H2. +destruct H2 as [t' H2]. +destruct (eq_dec_T t t') as [H3|H3]. +rewrite H3. +exact H2. +exact H1. +Defined. + +Axiom sigT_get_proof_existT_same: + forall T: Type, + forall eq_dec_T: forall t t': T, {t = t'} + {~ t = t'}, + forall P: T -> Type, + forall t: T, + forall H1 H2: P t, + sigT_get_proof T eq_dec_T P t H1 (existT P t H2) = H2. + +Theorem existT_injective: + forall T, + (forall t1 t2: T, { t1 = t2 } + { t1 <> t2 }) -> + forall P: T -> Type, + forall t: T, + forall pt1 pt2: P t, + existT P t pt1 = existT P t pt2 -> + pt1 = pt2. +Proof. +intros T T_dec P t pt1 pt2 H1. +pose (H2 := f_equal (sigT_get_proof T T_dec P t pt1) H1). +repeat rewrite sigT_get_proof_existT_same in H2. +assumption. +Qed. + +Ltac decide_equality_sub dec x x' H := + destruct (dec x x') as [H|H]; + [subst x'; try tauto|try(right; injection; tauto; fail)]. + +Axiom value_set_dec: + forall t: type, + forall v v': value_set t, + {v = v'} + {v <> v'}. + +Theorem lvalue_dec: + forall (t: type) (l l': lvalue t), {l = l'} + {l <> l'} +with rvalue_dec: + forall (t: type) (r r': rvalue t), {r = r'} + {r <> r'}. +Admitted. + +Theorem sub_expr_subs_same_kind: + forall e: expr, + forall ee: executable_sub_expr e, + forall ee': expr, + forall e': expr, + def_sub_expr_subs e ee ee' e' -> + expr_to_kind e = expr_to_kind e'. +Proof. +intros e ee ee' e' H1. +case H1; try (intros; tauto; fail). +Qed. + +Theorem def_sub_expr_subs_assign_sub_lvalue_inversion: + forall t: type, + forall lv: lvalue t, + forall rv: rvalue t, + forall ee' e': expr, + forall ee_sub: executable_sub_expr (lvalue_to_expr t lv), + def_sub_expr_subs (statement_to_expr (assign t lv rv)) + (assign_sub_lvalue t lv rv ee_sub) ee' e' -> + { lv': lvalue t + | def_sub_expr_subs (lvalue_to_expr t lv) ee_sub ee' + (lvalue_to_expr t lv') + & e' = statement_to_expr (assign t lv' rv) }. +Proof. +intros t lv rv ee' [s'|t' lv''|t' rv''] ee_sub H1; + try discriminate (sub_expr_subs_same_kind _ _ _ _ H1). +destruct s' as [| | | |t' lv'' rv''| | | |]; + try(assert (H2: False); [inversion H1|elim H2]; fail). +destruct (type_dec t t') as [H2|H2]; + [|assert (H3: False); + [|elim H3; fail]]. +2: inversion H1 as [];tauto. +subst t'. +exists lv''. + inversion H1 as + [| |t' lv''' lv'''' rv''' ee'' ee_sub' H2 (H3_1,H3_2,H3_3) (H4_1,H4_2,H4_3,H4_4,H4_5) H5 (H6_1,H6_2)| | | |]. +(* Check that all names are the given ones: *) +clear t' lv''' lv'''' rv''' ee'' ee_sub' H2 H3_1 H3_2 H3_3 H4_1 H4_2 H4_3 H4_4 H4_5 H5 H6_1 H6_2. diff --git a/test-suite/bugs/closed/shouldsucceed/2181.v b/test-suite/bugs/closed/2181.v index 62820d86..62820d86 100644 --- a/test-suite/bugs/closed/shouldsucceed/2181.v +++ b/test-suite/bugs/closed/2181.v diff --git a/test-suite/bugs/closed/shouldsucceed/2193.v b/test-suite/bugs/closed/2193.v index fe258867..fe258867 100644 --- a/test-suite/bugs/closed/shouldsucceed/2193.v +++ b/test-suite/bugs/closed/2193.v diff --git a/test-suite/bugs/closed/shouldsucceed/2230.v b/test-suite/bugs/closed/2230.v index 5076fb2b..5076fb2b 100644 --- a/test-suite/bugs/closed/shouldsucceed/2230.v +++ b/test-suite/bugs/closed/2230.v diff --git a/test-suite/bugs/closed/shouldsucceed/2231.v b/test-suite/bugs/closed/2231.v index 03e2c9bb..03e2c9bb 100644 --- a/test-suite/bugs/closed/shouldsucceed/2231.v +++ b/test-suite/bugs/closed/2231.v diff --git a/test-suite/bugs/closed/shouldsucceed/2244.v b/test-suite/bugs/closed/2244.v index d499e515..d499e515 100644 --- a/test-suite/bugs/closed/shouldsucceed/2244.v +++ b/test-suite/bugs/closed/2244.v diff --git a/test-suite/bugs/closed/2250.v b/test-suite/bugs/closed/2250.v new file mode 100644 index 00000000..565d7b68 --- /dev/null +++ b/test-suite/bugs/closed/2250.v @@ -0,0 +1,3 @@ +Check prod: Prop -> Prop -> Prop. +(* (fun A B : Prop => (A * B)%type):Prop -> Prop -> Prop + : Prop -> Prop -> Prop *) diff --git a/test-suite/bugs/closed/shouldfail/2251.v b/test-suite/bugs/closed/2251.v index 642717f4..d0fa3f2b 100644 --- a/test-suite/bugs/closed/shouldfail/2251.v +++ b/test-suite/bugs/closed/2251.v @@ -2,4 +2,5 @@ Lemma evar_rewrite : (forall a : nat, a = 0 -> True) -> True. intros; eapply H. (* goal is ?30 = nil *) -rewrite plus_n_Sm. +Fail rewrite plus_n_Sm. +Abort. diff --git a/test-suite/bugs/closed/shouldsucceed/2255.v b/test-suite/bugs/closed/2255.v index bf80ff66..bf80ff66 100644 --- a/test-suite/bugs/closed/shouldsucceed/2255.v +++ b/test-suite/bugs/closed/2255.v diff --git a/test-suite/bugs/closed/shouldsucceed/2262.v b/test-suite/bugs/closed/2262.v index b61f18b8..b61f18b8 100644 --- a/test-suite/bugs/closed/shouldsucceed/2262.v +++ b/test-suite/bugs/closed/2262.v diff --git a/test-suite/bugs/closed/shouldsucceed/2281.v b/test-suite/bugs/closed/2281.v index 40948d90..40948d90 100644 --- a/test-suite/bugs/closed/shouldsucceed/2281.v +++ b/test-suite/bugs/closed/2281.v diff --git a/test-suite/bugs/closed/shouldsucceed/2295.v b/test-suite/bugs/closed/2295.v index f5ca28dc..f5ca28dc 100644 --- a/test-suite/bugs/closed/shouldsucceed/2295.v +++ b/test-suite/bugs/closed/2295.v diff --git a/test-suite/bugs/closed/shouldsucceed/2299.v b/test-suite/bugs/closed/2299.v index c0552ca7..c0552ca7 100644 --- a/test-suite/bugs/closed/shouldsucceed/2299.v +++ b/test-suite/bugs/closed/2299.v diff --git a/test-suite/bugs/closed/shouldsucceed/2300.v b/test-suite/bugs/closed/2300.v index 4e587cbb..4e587cbb 100644 --- a/test-suite/bugs/closed/shouldsucceed/2300.v +++ b/test-suite/bugs/closed/2300.v diff --git a/test-suite/bugs/closed/shouldsucceed/2303.v b/test-suite/bugs/closed/2303.v index e614b9b5..e614b9b5 100644 --- a/test-suite/bugs/closed/shouldsucceed/2303.v +++ b/test-suite/bugs/closed/2303.v diff --git a/test-suite/bugs/closed/shouldsucceed/2304.v b/test-suite/bugs/closed/2304.v index 1ac2702b..1ac2702b 100644 --- a/test-suite/bugs/closed/shouldsucceed/2304.v +++ b/test-suite/bugs/closed/2304.v diff --git a/test-suite/bugs/closed/shouldsucceed/2307.v b/test-suite/bugs/closed/2307.v index 7c049495..7c049495 100644 --- a/test-suite/bugs/closed/shouldsucceed/2307.v +++ b/test-suite/bugs/closed/2307.v diff --git a/test-suite/bugs/opened/shouldnotfail/2310.v b/test-suite/bugs/closed/2310.v index 8d1a5149..0be859ed 100644 --- a/test-suite/bugs/opened/shouldnotfail/2310.v +++ b/test-suite/bugs/closed/2310.v @@ -14,4 +14,4 @@ Definition replace a (y:Nest (prod a a)) : a = a -> Nest a. (P:=\a.Nest (prod a a) and P:=\_.Nest (prod a a)) and refine should either leave P as subgoal or choose itself one solution *) -intros. refine (Cons (cast H _ y)). +intros. refine (Cons (cast H _ y)).
\ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2320.v b/test-suite/bugs/closed/2320.v index facb9ecf..facb9ecf 100644 --- a/test-suite/bugs/closed/shouldsucceed/2320.v +++ b/test-suite/bugs/closed/2320.v diff --git a/test-suite/bugs/closed/shouldsucceed/2342.v b/test-suite/bugs/closed/2342.v index 094e5466..6613b285 100644 --- a/test-suite/bugs/closed/shouldsucceed/2342.v +++ b/test-suite/bugs/closed/2342.v @@ -4,5 +4,5 @@ Parameter A : Set. Parameter B : A -> Set. Parameter F : Set -> Prop. -Check (F (forall x, B x)). +Check (F (forall x, B x)). diff --git a/test-suite/bugs/closed/shouldsucceed/2347.v b/test-suite/bugs/closed/2347.v index e433f158..e433f158 100644 --- a/test-suite/bugs/closed/shouldsucceed/2347.v +++ b/test-suite/bugs/closed/2347.v diff --git a/test-suite/bugs/closed/shouldsucceed/2350.v b/test-suite/bugs/closed/2350.v index e91f22e2..e91f22e2 100644 --- a/test-suite/bugs/closed/shouldsucceed/2350.v +++ b/test-suite/bugs/closed/2350.v diff --git a/test-suite/bugs/closed/shouldsucceed/2353.v b/test-suite/bugs/closed/2353.v index b5c45c28..baae9a6e 100644 --- a/test-suite/bugs/closed/shouldsucceed/2353.v +++ b/test-suite/bugs/closed/2353.v @@ -4,9 +4,9 @@ Inductive term n := app (l : list term n). Definition term_list := fix term_size n (t : term n) (acc : nat) {struct t} : nat := match t with - | app l => + | app _ l => (fix term_list_size n (l : list term n) (acc : nat) {struct l} : nat := match l with - | cons t q => term_list_size (S n) q (term_size n t acc) + | cons _ _ t q => term_list_size (S n) q (term_size n t acc) end) n l (S acc) end. diff --git a/test-suite/bugs/closed/shouldsucceed/2360.v b/test-suite/bugs/closed/2360.v index 4ae97c97..4ae97c97 100644 --- a/test-suite/bugs/closed/shouldsucceed/2360.v +++ b/test-suite/bugs/closed/2360.v diff --git a/test-suite/bugs/closed/shouldsucceed/2362.v b/test-suite/bugs/closed/2362.v index febb9c7b..febb9c7b 100644 --- a/test-suite/bugs/closed/shouldsucceed/2362.v +++ b/test-suite/bugs/closed/2362.v diff --git a/test-suite/bugs/closed/shouldsucceed/2375.v b/test-suite/bugs/closed/2375.v index c17c426c..c17c426c 100644 --- a/test-suite/bugs/closed/shouldsucceed/2375.v +++ b/test-suite/bugs/closed/2375.v diff --git a/test-suite/bugs/closed/shouldsucceed/2378.v b/test-suite/bugs/closed/2378.v index 7deec64d..35c69db2 100644 --- a/test-suite/bugs/closed/shouldsucceed/2378.v +++ b/test-suite/bugs/closed/2378.v @@ -66,9 +66,9 @@ Implicit Arguments lpSat. Fixpoint LPTransfo Pred1 Pred2 p2lp (f: LP Pred1): LP Pred2 := match f with - LPPred p => p2lp p - | LPAnd f1 f2 => LPAnd _ (LPTransfo Pred1 Pred2 p2lp f1) (LPTransfo Pred1 Pred2 p2lp f2) - | LPNot f1 => LPNot _ (LPTransfo Pred1 Pred2 p2lp f1) + LPPred _ p => p2lp p + | LPAnd _ f1 f2 => LPAnd _ (LPTransfo Pred1 Pred2 p2lp f1) (LPTransfo Pred1 Pred2 p2lp f2) + | LPNot _ f1 => LPNot _ (LPTransfo Pred1 Pred2 p2lp f1) end. Implicit Arguments LPTransfo. @@ -503,6 +503,9 @@ Qed. Require Export Coq.Logic.FunctionalExtensionality. Print PLanguage. + +Unset Standard Proposition Elimination Names. + Program Definition PTransfo l1 l2 (tr: Transformation l1 l2) (h: isSharedTransfo l1 l2 tr): Transformation (PLanguage l1) (PLanguage l2) := mkTransformation (PLanguage l1) (PLanguage l2) diff --git a/test-suite/bugs/closed/shouldsucceed/2388.v b/test-suite/bugs/closed/2388.v index c7926711..c7926711 100644 --- a/test-suite/bugs/closed/shouldsucceed/2388.v +++ b/test-suite/bugs/closed/2388.v diff --git a/test-suite/bugs/closed/shouldsucceed/2393.v b/test-suite/bugs/closed/2393.v index fb4f9261..fb4f9261 100644 --- a/test-suite/bugs/closed/shouldsucceed/2393.v +++ b/test-suite/bugs/closed/2393.v diff --git a/test-suite/bugs/closed/shouldsucceed/2404.v b/test-suite/bugs/closed/2404.v index fe8eba54..8ac696e9 100644 --- a/test-suite/bugs/closed/shouldsucceed/2404.v +++ b/test-suite/bugs/closed/2404.v @@ -37,8 +37,8 @@ Definition Rweak : forall a b : bWorld, Type := RstarInv bwweak. Fixpoint exportRweak {a b} (aRWb : Rweak a b) (y : bName b) : option (bName a) := match aRWb,y with - | starReflS a, y' => Some y' - | starTransS i j k jWk jRWi, y' => + | starReflS _ a, y' => Some y' + | starTransS jWk jRWi, y' => match (bexportw jWk y) with | Some x => exportRweak jRWi x | None => None diff --git a/test-suite/bugs/closed/2406.v b/test-suite/bugs/closed/2406.v new file mode 100644 index 00000000..1bd66ffc --- /dev/null +++ b/test-suite/bugs/closed/2406.v @@ -0,0 +1,6 @@ +(* Check correct handling of unsupported notations *) +Notation "''" := (fun x => x) (at level 20). + +(* This fails with a syntax error but it is not catched by Fail +Fail Definition crash_the_rooster f := . +*) diff --git a/test-suite/bugs/closed/2447.v b/test-suite/bugs/closed/2447.v new file mode 100644 index 00000000..fdeb69fc --- /dev/null +++ b/test-suite/bugs/closed/2447.v @@ -0,0 +1,7 @@ +Record t := {x : bool; y : bool; z : bool}. + +Goal forall x1 x2 y z, + {| x := x1; y := y; z := z |} = {| x := x2; y := y; z := z |} -> x1 = x2. +Proof. +intros; congruence. (* was doing stack overflow *) +Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/2456.v b/test-suite/bugs/closed/2456.v index 56f046c4..56f046c4 100644 --- a/test-suite/bugs/closed/shouldsucceed/2456.v +++ b/test-suite/bugs/closed/2456.v diff --git a/test-suite/bugs/closed/shouldsucceed/2464.v b/test-suite/bugs/closed/2464.v index af708587..af708587 100644 --- a/test-suite/bugs/closed/shouldsucceed/2464.v +++ b/test-suite/bugs/closed/2464.v diff --git a/test-suite/bugs/closed/shouldsucceed/2467.v b/test-suite/bugs/closed/2467.v index ad17814a..ad17814a 100644 --- a/test-suite/bugs/closed/shouldsucceed/2467.v +++ b/test-suite/bugs/closed/2467.v diff --git a/test-suite/bugs/closed/shouldsucceed/2473.v b/test-suite/bugs/closed/2473.v index 4c302512..4c302512 100644 --- a/test-suite/bugs/closed/shouldsucceed/2473.v +++ b/test-suite/bugs/closed/2473.v diff --git a/test-suite/bugs/closed/shouldfail/2586.v b/test-suite/bugs/closed/2586.v index 6111a641..7e02e7f1 100644 --- a/test-suite/bugs/closed/shouldfail/2586.v +++ b/test-suite/bugs/closed/2586.v @@ -2,4 +2,5 @@ Require Import Setoid SetoidClass Program. Goal forall `(Setoid nat) x y, x == y -> S x == S y. intros. - clsubst H0.
\ No newline at end of file + Fail clsubst H0. + Abort.
\ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2603.v b/test-suite/bugs/closed/2603.v index 371bfdc5..371bfdc5 100644 --- a/test-suite/bugs/closed/shouldsucceed/2603.v +++ b/test-suite/bugs/closed/2603.v diff --git a/test-suite/bugs/closed/shouldsucceed/2608.v b/test-suite/bugs/closed/2608.v index a4c95ff9..a4c95ff9 100644 --- a/test-suite/bugs/closed/shouldsucceed/2608.v +++ b/test-suite/bugs/closed/2608.v diff --git a/test-suite/bugs/closed/shouldsucceed/2613.v b/test-suite/bugs/closed/2613.v index 4f0470b1..4f0470b1 100644 --- a/test-suite/bugs/closed/shouldsucceed/2613.v +++ b/test-suite/bugs/closed/2613.v diff --git a/test-suite/bugs/closed/shouldsucceed/2615.v b/test-suite/bugs/closed/2615.v index 54e1a07c..dde6a6a5 100644 --- a/test-suite/bugs/closed/shouldsucceed/2615.v +++ b/test-suite/bugs/closed/2615.v @@ -12,3 +12,5 @@ Fail induction 1. refine (fun p => match p with _ => _ end). Undo. refine (fun p => match p with foo_intro _ _ => _ end). +admit. +Qed.
\ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2616.v b/test-suite/bugs/closed/2616.v index 8758e32d..8758e32d 100644 --- a/test-suite/bugs/closed/shouldsucceed/2616.v +++ b/test-suite/bugs/closed/2616.v diff --git a/test-suite/bugs/closed/shouldsucceed/2629.v b/test-suite/bugs/closed/2629.v index 759cd3dd..759cd3dd 100644 --- a/test-suite/bugs/closed/shouldsucceed/2629.v +++ b/test-suite/bugs/closed/2629.v diff --git a/test-suite/bugs/closed/shouldsucceed/2640.v b/test-suite/bugs/closed/2640.v index da0cc68a..da0cc68a 100644 --- a/test-suite/bugs/closed/shouldsucceed/2640.v +++ b/test-suite/bugs/closed/2640.v diff --git a/test-suite/bugs/closed/2667.v b/test-suite/bugs/closed/2667.v new file mode 100644 index 00000000..0631e535 --- /dev/null +++ b/test-suite/bugs/closed/2667.v @@ -0,0 +1,11 @@ +(* Check that extra arguments to Arguments Scope do not disturb use of *) +(* scopes in constructors *) + +Inductive stmt : Type := Sskip: stmt | Scall : nat -> stmt. +Bind Scope Cminor with stmt. + +(* extra argument is ok because of possible coercion to funclass *) +Arguments Scope Scall [_ Cminor ]. + +(* extra argument is ok because of possible coercion to funclass *) +Fixpoint f (c: stmt) : Prop := match c with Scall _ => False | _ => False end. diff --git a/test-suite/bugs/closed/shouldsucceed/2668.v b/test-suite/bugs/closed/2668.v index 74c8fa34..74c8fa34 100644 --- a/test-suite/bugs/closed/shouldsucceed/2668.v +++ b/test-suite/bugs/closed/2668.v diff --git a/test-suite/bugs/closed/2670.v b/test-suite/bugs/closed/2670.v new file mode 100644 index 00000000..c401420e --- /dev/null +++ b/test-suite/bugs/closed/2670.v @@ -0,0 +1,21 @@ +(* Check that problems with several solutions are solved in 8.4 as in 8.2 and 8.3 *) + +Inductive Fin: nat -> Set := +| first k : Fin (S k) +| succ k: Fin k -> Fin (S k). + +Lemma match_sym_eq_eq: forall (n1 n2: nat)(f: Fin n1)(e: n1 = n2), +f = match sym_eq e in (_ = l) return (Fin l) with refl_equal => + match e in (_ = l) return (Fin l) with refl_equal => f end end. +Proof. + intros n1 n2 f e. + (* Next line has a dependent and a non dependent solution *) + (* 8.2 and 8.3 used to choose the dependent one which is the one to make *) + (* the goal progress *) + refine (match e return _ with refl_equal => _ end). + reflexivity. + Undo 2. + (* Next line similarly has a dependent and a non dependent solution *) + refine (match e with refl_equal => _ end). + reflexivity. +Qed. diff --git a/test-suite/bugs/closed/2680.v b/test-suite/bugs/closed/2680.v new file mode 100644 index 00000000..0f573a28 --- /dev/null +++ b/test-suite/bugs/closed/2680.v @@ -0,0 +1,17 @@ +(* Tauto bug initially due to wrong test for binary connective *) + +Parameter A B : Type. + +Axiom P : A -> B -> Prop. + +Inductive IP (a : A) (b: B) : Prop := +| IP_def : P a b -> IP a b. + + +Goal forall (a : A) (b : B), IP a b -> ~ IP a b -> False. +Proof. + intros. + tauto. +Qed. + + diff --git a/test-suite/bugs/closed/2713.v b/test-suite/bugs/closed/2713.v new file mode 100644 index 00000000..b5fc74bf --- /dev/null +++ b/test-suite/bugs/closed/2713.v @@ -0,0 +1,17 @@ +Set Implicit Arguments. + +Definition pred_le A (P Q : A->Prop) := + forall x, P x -> Q x. + +Lemma pred_le_refl : forall A (P:A->Prop), + pred_le P P. +Proof. unfold pred_le. auto. Qed. + +Hint Resolve pred_le_refl. + +Lemma test : + forall (P1 P2:nat->Prop), + (forall Q, pred_le (fun a => P1 a /\ P2 a) Q -> True) -> + True. +Proof. intros. eapply H. eauto. (* used to work *) + apply pred_le_refl. Qed. diff --git a/test-suite/bugs/closed/2729.v b/test-suite/bugs/closed/2729.v new file mode 100644 index 00000000..7929b881 --- /dev/null +++ b/test-suite/bugs/closed/2729.v @@ -0,0 +1,115 @@ +(* This bug report actually revealed two bugs in the reconstruction of + a term with "match" in the vm *) + +(* A simplified form of the first problem *) + +(* Reconstruction of terms normalized with vm when a constructor has *) +(* let-ins arguments *) + +Record A : Type := C { a := 0 : nat; b : a=a }. +Goal forall d:A, match d with C a b => b end = match d with C a b => b end. +intro. +vm_compute. +(* Now check that it is well-typed *) +match goal with |- ?c = _ => first [let x := type of c in idtac | fail 2] end. +Abort. + +(* A simplified form of the second problem *) + +Parameter P : nat -> Type. + +Inductive box A := Box : A -> box A. + +Axiom com : {m : nat & box (P m) }. + +Lemma L : + (let (w, s) as com' return (com' = com -> Prop) := com in + let (s0) as s0 + return (existT (fun m : nat => box (P m)) w s0 = com -> Prop) := s in + fun _ : existT (fun m : nat => box (P m)) w (Box (P w) s0) = com => + True) eq_refl. +Proof. +vm_compute. +(* Now check that it is well-typed (the "P w" used to be turned into "P s") *) +match goal with |- ?c => first [let x := type of c in idtac | fail 2] end. +Abort. + +(* Then the original report *) + +Require Import Equality. + +Parameter NameSet : Set. +Parameter SignedName : Set. +Parameter SignedName_compare : forall (x y : SignedName), comparison. +Parameter pu_type : NameSet -> NameSet -> Type. +Parameter pu_nameOf : forall {from to : NameSet}, pu_type from to -> SignedName. +Parameter commute : forall {from mid1 mid2 to : NameSet}, + pu_type from mid1 -> pu_type mid1 to + -> pu_type from mid2 -> pu_type mid2 to -> Prop. + +Program Definition castPatchFrom {from from' to : NameSet} + (HeqFrom : from = from') + (p : pu_type from to) + : pu_type from' to + := p. + +Class PatchUniverse : Type := mkPatchUniverse { + + commutable : forall {from mid1 to : NameSet}, + pu_type from mid1 -> pu_type mid1 to -> Prop + := fun {from mid1 to : NameSet} + (p : pu_type from mid1) (q : pu_type mid1 to) => + exists mid2 : NameSet, + exists q' : pu_type from mid2, + exists p' : pu_type mid2 to, + commute p q q' p'; + + commutable_dec : forall {from mid to : NameSet} + (p : pu_type from mid) + (q : pu_type mid to), + {mid2 : NameSet & + { q' : pu_type from mid2 & + { p' : pu_type mid2 to & + commute p q q' p' }}} + + {~(commutable p q)} +}. + +Inductive SequenceBase (pu : PatchUniverse) + : NameSet -> NameSet -> Type + := Nil : forall {cxt : NameSet}, + SequenceBase pu cxt cxt + | Cons : forall {from mid to : NameSet} + (p : pu_type from mid) + (qs : SequenceBase pu mid to), + SequenceBase pu from to. +Implicit Arguments Nil [pu cxt]. +Implicit Arguments Cons [pu from mid to]. + +Program Fixpoint insertBase {pu : PatchUniverse} + {from mid to : NameSet} + (p : pu_type from mid) + (qs : SequenceBase pu mid to) + : SequenceBase pu from to + := match qs with + | Nil => Cons p Nil + | Cons q qs' => + match SignedName_compare (pu_nameOf p) (pu_nameOf q) with + | Lt => Cons p qs + | _ => match commutable_dec p (castPatchFrom _ q) with + | inleft (existT _ _ (existT _ q' (existT _ p' _))) => Cons q' +(insertBase p' qs') + | inright _ => Cons p qs + end + end + end. + +Lemma insertBaseConsLt {pu : PatchUniverse} + {o op opq opqr : NameSet} + (p : pu_type o op) + (q : pu_type op opq) + (rs : SequenceBase pu opq opqr) + (p_Lt_q : SignedName_compare (pu_nameOf p) (pu_nameOf q) += Lt) + : insertBase p (Cons q rs) = Cons p (Cons q rs). +Proof. +vm_compute. diff --git a/test-suite/bugs/closed/shouldsucceed/2732.v b/test-suite/bugs/closed/2732.v index f22a8ccc..f22a8ccc 100644 --- a/test-suite/bugs/closed/shouldsucceed/2732.v +++ b/test-suite/bugs/closed/2732.v diff --git a/test-suite/bugs/closed/shouldsucceed/2733.v b/test-suite/bugs/closed/2733.v index fd7bd3bd..832de4f9 100644 --- a/test-suite/bugs/closed/shouldsucceed/2733.v +++ b/test-suite/bugs/closed/2733.v @@ -1,3 +1,5 @@ +Unset Asymmetric Patterns. + Definition goodid : forall {A} (x: A), A := fun A x => x. Definition wrongid : forall A (x: A), A := fun {A} x => x. @@ -17,9 +19,9 @@ end. Fixpoint app (P : forall {k k'}, alt_list k k' -> alt_list k k') {t1 t2} (l : alt_list t1 t2) {struct l}: forall {t3}, alt_list t2 t3 -> alt_list t1 t3 := match l with - | nil _ => fun _ l2 => P l2 - | Ncons _ n l1 => fun _ l2 => Ncons n (app (@P) l1 l2) - | Bcons _ b l1 => fun _ l2 => Bcons b (app (@P) l1 l2) + | nil => fun _ l2 => P l2 + | Ncons n l1 => fun _ l2 => Ncons n (app (@P) l1 l2) + | Bcons b l1 => fun _ l2 => Bcons b (app (@P) l1 l2) end. Check (fun {t t'} (l: alt_list t t') => diff --git a/test-suite/bugs/closed/shouldsucceed/2734.v b/test-suite/bugs/closed/2734.v index 826361be..826361be 100644 --- a/test-suite/bugs/closed/shouldsucceed/2734.v +++ b/test-suite/bugs/closed/2734.v diff --git a/test-suite/bugs/closed/shouldsucceed/2750.v b/test-suite/bugs/closed/2750.v index fc580f10..fc580f10 100644 --- a/test-suite/bugs/closed/shouldsucceed/2750.v +++ b/test-suite/bugs/closed/2750.v diff --git a/test-suite/bugs/closed/2810.v b/test-suite/bugs/closed/2810.v new file mode 100644 index 00000000..a66078c6 --- /dev/null +++ b/test-suite/bugs/closed/2810.v @@ -0,0 +1,10 @@ +Section foo. + Variable A : Type. + Let B := A. + + Hint Unfold B. + + Goal False. + clear B. autounfold with core. + Abort. +End foo. diff --git a/test-suite/bugs/closed/shouldsucceed/2817.v b/test-suite/bugs/closed/2817.v index 08dff992..08dff992 100644 --- a/test-suite/bugs/closed/shouldsucceed/2817.v +++ b/test-suite/bugs/closed/2817.v diff --git a/test-suite/bugs/closed/2818.v b/test-suite/bugs/closed/2818.v new file mode 100644 index 00000000..010855cf --- /dev/null +++ b/test-suite/bugs/closed/2818.v @@ -0,0 +1,11 @@ +Module M. + +Local Ltac t := exact I. +Ltac u := t. + +End M. + +Goal True. +Proof. +M.u. +Qed. diff --git a/test-suite/bugs/closed/2828.v b/test-suite/bugs/closed/2828.v new file mode 100644 index 00000000..0b8abace --- /dev/null +++ b/test-suite/bugs/closed/2828.v @@ -0,0 +1,4 @@ +Parameter A B : Type. +Coercion POL (p : prod A B) := fst p. +Goal forall x : prod A B, A. + intro x. Fail exact x. diff --git a/test-suite/bugs/closed/2830.v b/test-suite/bugs/closed/2830.v new file mode 100644 index 00000000..b72c821d --- /dev/null +++ b/test-suite/bugs/closed/2830.v @@ -0,0 +1,226 @@ +(* Bug report #2830 (evar defined twice) covers different bugs *) + +(* 1- This was submitted by qb.h.agws *) + +Module A. + +Set Implicit Arguments. + +Inductive Bit := O | I. + +Inductive BitString: nat -> Set := +| bit: Bit -> BitString 0 +| bitStr: forall n: nat, Bit -> BitString n -> BitString (S n). + +Definition BitOr (a b: Bit) := + match a, b with + | O, O => O + | _, _ => I + end. + +(* Should fail with an error; used to failed in 8.4 and trunk with + anomaly Evd.define: cannot define an evar twice *) + +Fail Fixpoint StringOr (n m: nat) (a: BitString n) (b: BitString m) := + match a with + | bit a' => + match b with + | bit b' => bit (BitOr a' b') + | bitStr b' bT => bitStr b' (StringOr (bit a') bT) + end + | bitStr a' aT => + match b with + | bit b' => bitStr a' (StringOr aT (bit b')) + | bitStr b' bT => bitStr (BitOr a' b') (StringOr aT bT) + end + end. + +End A. + +(* 2- This was submitted by Andrew Appel *) + +Module B. + +Require Import Program Relations. + +Record ageable_facts (A:Type) (level: A -> nat) (age1:A -> option A) := +{ af_unage : forall x x' y', level x' = level y' -> age1 x = Some x' -> exists y, age1 y = Some y' +; af_level1 : forall x, age1 x = None <-> level x = 0 +; af_level2 : forall x y, age1 x = Some y -> level x = S (level y) +}. + +Implicit Arguments af_unage [[A] [level] [age1]]. +Implicit Arguments af_level1 [[A] [level] [age1]]. +Implicit Arguments af_level2 [[A] [level] [age1]]. + +Class ageable (A:Type) := mkAgeable +{ level : A -> nat +; age1 : A -> option A +; age_facts : ageable_facts A level age1 +}. +Definition age {A} `{ageable A} (x y:A) := age1 x = Some y. +Definition necR {A} `{ageable A} : relation A := clos_refl_trans A age. +Delimit Scope pred with pred. +Local Open Scope pred. + +Definition hereditary {A} (R:A->A->Prop) (p:A->Prop) := + forall a a':A, R a a' -> p a -> p a'. + +Definition pred (A:Type) {AG:ageable A} := + { p:A -> Prop | hereditary age p }. + +Bind Scope pred with pred. + +Definition app_pred {A} `{ageable A} (p:pred A) : A -> Prop := proj1_sig p. +Definition pred_hereditary `{ageable} (p:pred A) := proj2_sig p. +Coercion app_pred : pred >-> Funclass. +Global Opaque pred. + +Definition derives {A} `{ageable A} (P Q:pred A) := forall a:A, P a -> Q a. +Implicit Arguments derives. + +Program Definition andp {A} `{ageable A} (P Q:pred A) : pred A := + fun a:A => P a /\ Q a. +Next Obligation. + intros; intro; intuition; apply pred_hereditary with a; auto. +Qed. + +Program Definition imp {A} `{ageable A} (P Q:pred A) : pred A := + fun a:A => forall a':A, necR a a' -> P a' -> Q a'. +Next Obligation. + intros; intro; intuition. + apply H1; auto. + apply rt_trans with a'; auto. + apply rt_step; auto. +Qed. + +Program Definition allp {A} `{ageable A} {B: Type} (f: B -> pred A) : pred A + := fun a => forall b, f b a. +Next Obligation. + intros; intro; intuition. + apply pred_hereditary with a; auto. + apply H1. +Qed. + +Notation "P '<-->' Q" := (andp (imp P Q) (imp Q P)) (at level 57, no associativity) : pred. +Notation "P '|--' Q" := (derives P Q) (at level 80, no associativity). +Notation "'All' x ':' T ',' P " := (allp (fun x:T => P%pred)) (at level 65, x at level 99) : pred. + +Lemma forall_pred_ext {A} `{agA : ageable A}: forall B P Q, + (All x : B, (P x <--> Q x)) |-- (All x : B, P x) <--> (All x: B, Q x). +Abort. + +End B. + +(* 3. *) + +(* This was submitted by Anthony Cowley *) + +Require Import Coq.Classes.Morphisms. +Require Import Setoid. + +Module C. + +Reserved Notation "a ~> b" (at level 70, right associativity). +Reserved Notation "a ≈ b" (at level 54). +Generalizable All Variables. + +Class Category (Object:Type) (Hom:Object -> Object -> Type) := { + hom := Hom where "a ~> b" := (hom a b) : category_scope + ; ob := Object + ; id : forall a, hom a a + ; comp : forall c b a, hom b c -> hom a b -> hom a c + where "g ∘ f" := (comp _ _ _ g f) : category_scope + ; eqv : forall a b, hom a b -> hom a b -> Prop + where "f ≈ g" := (eqv _ _ f g) : category_scope + ; eqv_equivalence : forall a b, Equivalence (eqv a b) + ; comp_respects : forall a b c, + Proper (eqv b c ==> eqv a b ==> eqv a c) (comp c b a) + ; left_identity : forall `(f:a ~> b), id b ∘ f ≈ f + ; right_identity : forall `(f:a ~> b), f ∘ id a ≈ f + ; associativity : forall `(f:a~>b) `(g:b~>c) `(h:c~>d), + h ∘ (g ∘ f) ≈ (h ∘ g) ∘ f +}. +Notation "a ~> b" := (@hom _ _ _ a b) : category_scope. +Notation "g ∘ f" := (@comp _ _ _ _ _ _ g f) : category_scope. +Notation "a ≈ b" := (@eqv _ _ _ _ _ a b) : category_scope. +Notation "a ~{ C }~> b" := (@hom _ _ C a b) (at level 100) : category_scope. +Coercion ob : Category >-> Sortclass. + +Open Scope category_scope. + +Add Parametric Relation `(C:Category Ob Hom) (a b : Ob) : (hom a b) (eqv a b) + reflexivity proved by (@Equivalence_Reflexive _ _ (eqv_equivalence a b)) + symmetry proved by (@Equivalence_Symmetric _ _ (eqv_equivalence a b)) + transitivity proved by (@Equivalence_Transitive _ _ (eqv_equivalence a b)) + as parametric_relation_eqv. + +Add Parametric Morphism `(C:Category Ob Hom) (c b a : Ob) : (comp c b a) + with signature (eqv _ _ ==> eqv _ _ ==> eqv _ _) as parametric_morphism_comp. + intros x y Heq x' y'. apply comp_respects. exact Heq. + Defined. + +Class Functor `(C:Category) `(D:Category) (im : C -> D) := { + functor_im := im + ; fmap : forall {a b}, `(a ~> b) -> im a ~> im b + ; fmap_respects : forall a b (f f' : a ~> b), f ≈ f' -> fmap f ≈ fmap f' + ; fmap_preserves_id : forall a, fmap (id a) ≈ id (im a) + ; fmap_preserves_comp : forall `(f:a~>b) `(g:b~>c), + fmap g ∘ fmap f ≈ fmap (g ∘ f) +}. +Coercion functor_im : Functor >-> Funclass. +Implicit Arguments fmap [Object Hom C Object0 Hom0 D im a b]. + +Add Parametric Morphism `(C:Category) `(D:Category) + (Im:C->D) (F:Functor C D Im) (a b:C) : (@fmap _ _ C _ _ D Im F a b) + with signature (@eqv C _ C a b ==> @eqv D _ D (Im a) (Im b)) + as parametric_morphism_fmap. +intros. apply fmap_respects. assumption. Qed. + +(* HERE IS THE PROBLEMATIC INSTANCE. If we change this to a regular Definition, + then the problem goes away. *) +Instance functor_comp `{C:Category} `{D:Category} `{E:Category} + {Gim} (G:Functor D E Gim) {Fim} (F:Functor C D Fim) + : Functor C E (Basics.compose Gim Fim). +intros. apply Build_Functor with (fmap := fun a b f => fmap G (fmap F f)). +abstract (intros; rewrite H; reflexivity). +abstract (intros; repeat (rewrite fmap_preserves_id); reflexivity). +abstract (intros; repeat (rewrite fmap_preserves_comp); reflexivity). +Defined. + +Definition skel {A:Type} : relation A := @eq A. +Instance skel_equiv A : Equivalence (@skel A). +Admitted. + +Import FunctionalExtensionality. +Instance set_cat : Category Type (fun A B => A -> B) := { + id := fun A => fun x => x + ; comp c b a f g := fun x => f (g x) + ; eqv := fun A B => @skel (A -> B) +}. +intros. compute. symmetry. apply eta_expansion. +intros. compute. symmetry. apply eta_expansion. +intros. compute. reflexivity. Defined. + +(* The [list] type constructor is a Functor. *) + +Import List. + +Definition setList (A:set_cat) := list A. +Instance list_functor : Functor set_cat set_cat setList. +apply Build_Functor with (fmap := @map). +intros. rewrite H. reflexivity. +intros; simpl; apply functional_extensionality. + induction x; [auto|simpl]. rewrite IHx. reflexivity. +intros; simpl; apply functional_extensionality. + induction x; [auto|simpl]. rewrite IHx. reflexivity. +Defined. + +Local Notation "[ a , .. , b ]" := (a :: .. (b :: nil) ..) : list_scope. +Definition setFmap {Fim} {F:Functor set_cat set_cat Fim} `(f:A~>B) (xs:Fim A) := fmap F f xs. + +(* We want to infer the [Functor] instance based on the value's + structure, but the [functor_comp] instance throws things awry. *) +Eval cbv in setFmap (fun x => x * 3) [67,8]. + +End C. diff --git a/test-suite/bugs/closed/2834.v b/test-suite/bugs/closed/2834.v new file mode 100644 index 00000000..6015c53b --- /dev/null +++ b/test-suite/bugs/closed/2834.v @@ -0,0 +1,4 @@ +(* Testing typing of subst *) + +Lemma eqType2Set (a b : Set) (H : @eq Type a b) : @eq Set a b. +Fail subst. diff --git a/test-suite/bugs/closed/shouldsucceed/2836.v b/test-suite/bugs/closed/2836.v index a948b75e..a948b75e 100644 --- a/test-suite/bugs/closed/shouldsucceed/2836.v +++ b/test-suite/bugs/closed/2836.v diff --git a/test-suite/bugs/closed/shouldsucceed/2837.v b/test-suite/bugs/closed/2837.v index 5d984463..5d984463 100644 --- a/test-suite/bugs/closed/shouldsucceed/2837.v +++ b/test-suite/bugs/closed/2837.v diff --git a/test-suite/bugs/closed/2839.v b/test-suite/bugs/closed/2839.v new file mode 100644 index 00000000..e396fe06 --- /dev/null +++ b/test-suite/bugs/closed/2839.v @@ -0,0 +1,10 @@ +(* Check a case where ltac typing error should result in error, not anomaly *) + +Goal forall (H : forall x : nat, x = x), False. +intro. +Fail + let H := + match goal with + | [ H : appcontext G [@eq _ _] |- _ ] => let H' := context G[@plus 2] in H' + end + in pose H. diff --git a/test-suite/bugs/closed/2846.v b/test-suite/bugs/closed/2846.v new file mode 100644 index 00000000..8d6d348a --- /dev/null +++ b/test-suite/bugs/closed/2846.v @@ -0,0 +1,3 @@ +Variable R : Type. + +Fail Inductive I : R := c : R. diff --git a/test-suite/bugs/closed/2848.v b/test-suite/bugs/closed/2848.v new file mode 100644 index 00000000..de137d39 --- /dev/null +++ b/test-suite/bugs/closed/2848.v @@ -0,0 +1,9 @@ +Require Import Setoid. + +Parameter value' : Type. +Parameter equiv' : value' -> value' -> Prop. + +Add Parametric Relation : _ equiv' + reflexivity proved by (Equivalence.equiv_reflexive _) + transitivity proved by (Equivalence.equiv_transitive _) + as apply_equiv'_rel. diff --git a/test-suite/bugs/closed/2850.v b/test-suite/bugs/closed/2850.v new file mode 100644 index 00000000..64a93aeb --- /dev/null +++ b/test-suite/bugs/closed/2850.v @@ -0,0 +1,2 @@ +Definition id {A} (x : A) := x. +Fail Compute id. diff --git a/test-suite/bugs/closed/2854.v b/test-suite/bugs/closed/2854.v new file mode 100644 index 00000000..14aee17f --- /dev/null +++ b/test-suite/bugs/closed/2854.v @@ -0,0 +1,7 @@ +Section foo. + Let foo := Type. + Definition bar : foo -> foo := @id _. + Goal False. + subst foo. + Fail pose bar as f. + (* simpl in f. *) diff --git a/test-suite/bugs/closed/2876.v b/test-suite/bugs/closed/2876.v new file mode 100644 index 00000000..a66ee6b3 --- /dev/null +++ b/test-suite/bugs/closed/2876.v @@ -0,0 +1,11 @@ +Lemma test_bug : forall (R:nat->nat->Prop) n m m' (P: Prop), + P -> + (P -> R n m) -> + (P -> R n m') -> + (forall u, R n u -> u = u -> True) -> + True. +Proof. + intros * HP H1 H2 H3. eapply H3. + eauto. (* H1 is used, but H2 should be used since it is the last hypothesis *) + auto. +Qed. diff --git a/test-suite/bugs/closed/2883.v b/test-suite/bugs/closed/2883.v new file mode 100644 index 00000000..5a5d90a4 --- /dev/null +++ b/test-suite/bugs/closed/2883.v @@ -0,0 +1,34 @@ +Require Import List. +Require Import Coq.Program.Equality. + +Inductive star {genv state : Type} + (step : genv -> state -> state -> Prop) + (ge : genv) : state -> state -> Prop := + | star_refl : forall s : state, star step ge s s + | star_step : + forall (s1 : state) (s2 : state) + (s3 : state), + step ge s1 s2 -> + star step ge s2 s3 -> + star step ge s1 s3. + +Parameter genv expr env mem : Type. +Definition genv' := genv. +Inductive state : Type := + | State : expr -> env -> mem -> state. +Parameter step : genv' -> state -> state -> Prop. + +Section Test. + +Variable ge : genv'. + +Lemma compat_eval_steps: + forall a b e a' b', + star step ge (State a e b) (State a' e b') -> + True. +Proof. + intros. dependent induction H. + trivial. + eapply IHstar; eauto. + replace s2 with (State a' e b') by admit. eauto. +Qed. (* Oups *) diff --git a/test-suite/bugs/closed/2900.v b/test-suite/bugs/closed/2900.v new file mode 100644 index 00000000..8f4264e9 --- /dev/null +++ b/test-suite/bugs/closed/2900.v @@ -0,0 +1,28 @@ +(* Was raising stack overflow in 8.4 and assertion failed in future 8.5 *) +Set Implicit Arguments. + +Require Import List. +Require Import Coq.Program.Equality. + +(** Reflexive-transitive closure ( R* ) *) + +Inductive rtclosure (A : Type) (R : A-> A->Prop) : A->A->Prop := + | rtclosure_refl : forall x, + rtclosure R x x + | rtclosure_step : forall y x z, + R x y -> rtclosure R y z -> rtclosure R x z. + (* bug goes away if rtclosure_step is commented out *) + +(** The closure of the trivial binary relation [eq] *) + +Definition tr (A:Type) := rtclosure (@eq A). + +(** The bug *) + +Lemma bug : forall A B (l t:list A) (r s:list B), + length l = length r -> + tr (combine l r) (combine t s) -> tr l t. +Proof. + intros * E Hp. + (* bug goes away if [revert E] is called explicitly *) + dependent induction Hp. diff --git a/test-suite/bugs/closed/2920.v b/test-suite/bugs/closed/2920.v new file mode 100644 index 00000000..13548b9e --- /dev/null +++ b/test-suite/bugs/closed/2920.v @@ -0,0 +1,2 @@ +Fail Definition my_f_equal {A B : Type} (f : A -> B) (a a' : A) (p : a = a') : f a = f a' := + eq_ind _ _ (fun a' => f a = f a') _ _ p. diff --git a/test-suite/bugs/closed/2923.v b/test-suite/bugs/closed/2923.v new file mode 100644 index 00000000..8a0003a3 --- /dev/null +++ b/test-suite/bugs/closed/2923.v @@ -0,0 +1,12 @@ +Module Type SIGNATURE1. + Inductive IndType: Set := + | AConstructor. +End SIGNATURE1. + +Module Type SIGNATURE2. + Declare Module M1: SIGNATURE1. +End SIGNATURE2. + +Module M2 (Module M1_: SIGNATURE1) : SIGNATURE2. + Module M1 := M1_. +End M2. diff --git a/test-suite/bugs/closed/shouldsucceed/2928.v b/test-suite/bugs/closed/2928.v index 21e92ae2..21e92ae2 100644 --- a/test-suite/bugs/closed/shouldsucceed/2928.v +++ b/test-suite/bugs/closed/2928.v diff --git a/test-suite/bugs/closed/2930.v b/test-suite/bugs/closed/2930.v new file mode 100644 index 00000000..0994b6fb --- /dev/null +++ b/test-suite/bugs/closed/2930.v @@ -0,0 +1,12 @@ +(* Checking that let-in's hiding evars are expanded when enforcing + "occur-check" *) + +Require Import List. + +Definition foo x y := +let xy := (x, y) in +let bar xys := + match xys with + | nil => xy :: nil + | xy' :: xys' => xy' :: xys' + end in bar (nil : list (nat * nat)). diff --git a/test-suite/bugs/closed/2945.v b/test-suite/bugs/closed/2945.v new file mode 100644 index 00000000..59b57c07 --- /dev/null +++ b/test-suite/bugs/closed/2945.v @@ -0,0 +1,5 @@ +Notation "f1 =1 f2 :> A" := (f1 = (f2 : A)) + (at level 70, f2 at next level, A at level 90) : fun_scope. + +Notation "e :? pf" := (eq_rect _ (fun X : _ => X) e _ pf) + (no associativity, at level 90). diff --git a/test-suite/bugs/closed/2966.v b/test-suite/bugs/closed/2966.v new file mode 100644 index 00000000..debada85 --- /dev/null +++ b/test-suite/bugs/closed/2966.v @@ -0,0 +1,79 @@ +(** Non-termination and state monad with extraction *) +Require Import List. + +Set Implicit Arguments. +Set Asymmetric Patterns. + +Module MemSig. + Definition t: Type := list Type. + + Definition Nth (sig: t) (n: nat) := + nth n sig unit. +End MemSig. + +(** A memory of type [Mem.t s] is the union of cells whose type is specified + by [s]. *) +Module Mem. + Inductive t: MemSig.t -> Type := + | Nil: t nil + | Cons: forall (T: Type), option T -> forall (sig: MemSig.t), t sig -> + t (T :: sig). +End Mem. + +Module Ref. + Inductive t (sig: MemSig.t) (T: Type): Type := + | Input: t sig T. + + Definition Read (sig: MemSig.t) (T: Type) (ref: t sig T) (s: Mem.t sig) + : option T := + match ref with + | Input => None + end. +End Ref. + +Module Monad. + Definition t (sig: MemSig.t) (A: Type) := + Mem.t sig -> option A * Mem.t sig. + + Definition Return (sig: MemSig.t) (A: Type) (x: A): t sig A := + fun s => + (Some x, s). + + Definition Bind (sig: MemSig.t) (A B: Type) (x: t sig A) (f: A -> t sig B) + : t sig B := + fun s => + match x s with + | (Some x', s') => f x' s' + | (None, s') => (None, s') + end. + + Definition Select (T: Type) (f g: unit -> T): T := + f tt. + + (** Read in a reference. *) + Definition Read (sig: MemSig.t) (T: Type) (ref: Ref.t sig T) + : t sig T := + fun s => + match Ref.Read ref s with + | None => (None, s) + | Some x => (Some x, s) + end. +End Monad. + +Import Monad. + +Definition pop (sig: MemSig.t) (T: Type) (trace: Ref.t sig (list T)) + : Monad.t sig T := + Bind (Read trace) (fun _ s => (None, s)). + +Definition sig: MemSig.t := (list nat: Type) :: nil. + +Definition trace: Ref.t sig (list nat). +Admitted. + +Definition Gre (sig: MemSig.t) (trace: _) + (f: bool -> bool): Monad.t sig nat := + Select (fun _ => pop trace) (fun _ => Return 0). + +Definition Arg := + Gre trace (fun _ => false). diff --git a/test-suite/bugs/closed/2969.v b/test-suite/bugs/closed/2969.v new file mode 100644 index 00000000..ff75a1f3 --- /dev/null +++ b/test-suite/bugs/closed/2969.v @@ -0,0 +1,25 @@ +(* Check that Goal.V82.byps and Goal.V82.env are consistent *) + +(* This is a shorten variant of the initial bug which raised anomaly *) + +Goal forall x : nat, (forall z, (exists y:nat, z = y) -> True) -> True. +evar nat. +intros x H. +apply (H n). +unfold n. clear n. +eexists. +reflexivity. +Grab Existential Variables. +admit. + +(* Alternative variant which failed but without raising anomaly *) + +Goal forall x : nat, True. +evar nat. +intro x. +evar nat. +assert (H := eq_refl : n0 = n). +clearbody n n0. +exact I. +Grab Existential Variables. +admit. diff --git a/test-suite/bugs/closed/2981.v b/test-suite/bugs/closed/2981.v new file mode 100644 index 00000000..1facd9b7 --- /dev/null +++ b/test-suite/bugs/closed/2981.v @@ -0,0 +1,15 @@ +Check let TTT := Type in (fun (a b : @sigT TTT (fun A : TTT => A)) + (f : @projT1 TTT (fun A : TTT => A) a -> + @projT1 TTT (fun A : TTT => A) b) => + @eq_refl + (@projT1 TTT (fun A : TTT => A) a -> + @projT1 TTT (fun A : TTT => A) b) + (fun x : @projT1 TTT (fun A : TTT => A) a => f x)) : + forall (a b : @sigT TTT (fun A : TTT => A)) + (f : @projT1 TTT (fun A : TTT => A) a -> + @projT1 TTT (fun A : TTT => A) b), + @eq + (@projT1 TTT (fun A : TTT => A) a -> + @projT1 TTT (fun A : TTT => A) b) + (fun x : @projT1 TTT (fun A : TTT => A) a => f x) f. + diff --git a/test-suite/bugs/closed/shouldsucceed/2983.v b/test-suite/bugs/closed/2983.v index 15598352..15598352 100644 --- a/test-suite/bugs/closed/shouldsucceed/2983.v +++ b/test-suite/bugs/closed/2983.v diff --git a/test-suite/bugs/closed/2990.v b/test-suite/bugs/closed/2990.v new file mode 100644 index 00000000..5f832626 --- /dev/null +++ b/test-suite/bugs/closed/2990.v @@ -0,0 +1,8 @@ +Goal True. +Proof. + evar (pfT : Type). + cut pfT. + subst pfT. + intro pf. + refine ((fun A : Set => pf A) unit). +Abort. diff --git a/test-suite/bugs/closed/2994.v b/test-suite/bugs/closed/2994.v new file mode 100644 index 00000000..457b1893 --- /dev/null +++ b/test-suite/bugs/closed/2994.v @@ -0,0 +1,2 @@ +(* Was an anomaly at some time *) +Fail Class foo : Prop := { bar :> Set }. diff --git a/test-suite/bugs/closed/shouldsucceed/2995.v b/test-suite/bugs/closed/2995.v index ba3acd08..ba3acd08 100644 --- a/test-suite/bugs/closed/shouldsucceed/2995.v +++ b/test-suite/bugs/closed/2995.v diff --git a/test-suite/bugs/closed/2996.v b/test-suite/bugs/closed/2996.v new file mode 100644 index 00000000..440cda61 --- /dev/null +++ b/test-suite/bugs/closed/2996.v @@ -0,0 +1,30 @@ +(* Test on definitions referring to section variables that are not any + longer in the current context *) + +Section x. + + Hypothesis h : forall(n : nat), n < S n. + + Definition f(n m : nat)(less : n < m) : nat := n + m. + + Lemma a : forall(n : nat), f n (S n) (h n) = 1 + 2 * n. + Proof. + (* XXX *) admit. + Qed. + + Lemma b : forall(n : nat), n < 3 + n. + Proof. + clear. + intros n. + Fail assert (H := a n). + Abort. + + Let T := True. + Definition p := I : T. + + Lemma paradox : False. + Proof. + clear. + set (T := False). + Fail pose proof p as H. + Abort. diff --git a/test-suite/bugs/closed/shouldsucceed/3000.v b/test-suite/bugs/closed/3000.v index 27de34ed..27de34ed 100644 --- a/test-suite/bugs/closed/shouldsucceed/3000.v +++ b/test-suite/bugs/closed/3000.v diff --git a/test-suite/bugs/closed/3001.v b/test-suite/bugs/closed/3001.v new file mode 100644 index 00000000..6e565554 --- /dev/null +++ b/test-suite/bugs/closed/3001.v @@ -0,0 +1,21 @@ +Definition my_fun (n:nat) := n. + +Section My_Sec. + Global Arguments my_fun x : rename. +End My_Sec. + +(* The following code suffices to trigger it, on my system: + + Definition my_fun (n:nat) := n. + + Section My_Sec. + Global Arguments my_fun x : rename. + End My_Sec. + +The `Global Arguments` declaration succeeds fine, but the `End My_Sec` fails, with `Anomaly: dirpath_prefix: empty dirpath. Please report.` + +If `Global` is removed, or if no arguments are renamed, then everything works as expected. + +If other declarations go between the `Global Arguments` and the `End My_Sec`, then the other declarations work normally, but the `End My_Sec` still fails. + +Previously reported at https://github.com/HoTT/coq/issues/24 . Occurs in both 8.4 and current trunk. *) diff --git a/test-suite/bugs/closed/shouldsucceed/3004.v b/test-suite/bugs/closed/3004.v index 896b1958..896b1958 100644 --- a/test-suite/bugs/closed/shouldsucceed/3004.v +++ b/test-suite/bugs/closed/3004.v diff --git a/test-suite/bugs/closed/shouldsucceed/3008.v b/test-suite/bugs/closed/3008.v index 3f3a979a..3f3a979a 100644 --- a/test-suite/bugs/closed/shouldsucceed/3008.v +++ b/test-suite/bugs/closed/3008.v diff --git a/test-suite/bugs/closed/3010b.v b/test-suite/bugs/closed/3010b.v new file mode 100644 index 00000000..65fea424 --- /dev/null +++ b/test-suite/bugs/closed/3010b.v @@ -0,0 +1,5 @@ +Definition wtf (n : nat) : nat := + (match n with + 0 => (fun H : n = 0 => 0) + | S n' => (fun H : n = S n' => 0) + end) (eq_refl n). diff --git a/test-suite/bugs/closed/3016.v b/test-suite/bugs/closed/3016.v new file mode 100644 index 00000000..bd4f1dd8 --- /dev/null +++ b/test-suite/bugs/closed/3016.v @@ -0,0 +1,4 @@ +Section foo. + Variable C : Type. + Goal True. + change (eq (A := ?C) ?x ?y) with (eq). diff --git a/test-suite/bugs/closed/3017.v b/test-suite/bugs/closed/3017.v new file mode 100644 index 00000000..63a06bd3 --- /dev/null +++ b/test-suite/bugs/closed/3017.v @@ -0,0 +1,6 @@ +Class A := {}. + Class B {T} `(A) := { B_intro : forall t t' : T, t = t' }. + Lemma foo T (t t' : T) : t = t'. + erewrite @B_intro. + reflexivity. + Abort. diff --git a/test-suite/bugs/closed/3022.v b/test-suite/bugs/closed/3022.v new file mode 100644 index 00000000..dcfe7339 --- /dev/null +++ b/test-suite/bugs/closed/3022.v @@ -0,0 +1,8 @@ +Goal forall (O obj : Type) (f : O -> obj) (x : O) (e : x = x) + (T : obj -> obj -> Type) (m : forall x0 : obj, T x0 x0), + match eq_sym e in (_ = y) return (T (f y) (f x)) with + | eq_refl => m (f x) + end = m (f x). +intros. +try case e. +Abort. diff --git a/test-suite/bugs/closed/3023.v b/test-suite/bugs/closed/3023.v index ed489511..70a1491e 100644 --- a/test-suite/bugs/closed/3023.v +++ b/test-suite/bugs/closed/3023.v @@ -1,5 +1,3 @@ -(* Checking use of eta on Flexible/Rigid and SemiFlexible/Rigid unif problems *) - Set Implicit Arguments. Generalizable All Variables. @@ -14,6 +12,7 @@ Record Category {obj : Type} := Section DiscreteAdjoints. + Let C := {| Morphism := (fun X Y : Type => X -> Y); Identity := (fun X : Type => (fun x : X => x)); @@ -28,4 +27,7 @@ Section DiscreteAdjoints. revert ObjectFunctor. intro ObjectFunctor. simpl in ObjectFunctor. - revert ObjectFunctor. (* Used to failed in 8.4 up to 16 April 2013 *) + revert ObjectFunctor. + Abort. + +End DiscreteAdjoints. diff --git a/test-suite/bugs/closed/3036.v b/test-suite/bugs/closed/3036.v new file mode 100644 index 00000000..451bec9b --- /dev/null +++ b/test-suite/bugs/closed/3036.v @@ -0,0 +1,169 @@ +(* Checking use of retyping in w_unify0 in the presence of unification +problems of the form \x:Meta.Meta = \x:ind.match x with ... end *) + +Require Import List. +Require Import QArith. +Require Import Qcanon. + +Set Implicit Arguments. + +Inductive dynamic : Type := + | Dyn : forall T, T -> dynamic. + +Definition perm := Qc. + +Locate Qle_bool. + +Definition compatibleb (p1 p2 : perm) : bool := +let p1pos := Qle_bool 00 p1 in + let p2pos := Qle_bool 00 p2 in + negb ( + (p1pos && p2pos) + || ((p1pos || p2pos) && (negb (Qle_bool 00 ((p1 + p2)%Qc)))))%Qc. + +Definition compatible (p1 p2 : perm) := compatibleb p1 p2 = true. + +Definition perm_plus (p1 p2 : perm) : option perm := + if compatibleb p1 p2 then Some (p1 + p2) else None. + +Infix "+p" := perm_plus (at level 60, no associativity). + +Axiom axiom_ptr : Set. + +Definition ptr := axiom_ptr. + +Axiom axiom_ptr_eq_dec : forall (a b : ptr), {a = b} + {a <> b}. + +Definition ptr_eq_dec := axiom_ptr_eq_dec. + +Definition hval := (dynamic * perm)%type. + +Definition heap := ptr -> option hval. + +Bind Scope heap_scope with heap. +Delimit Scope heap_scope with heap. +Local Open Scope heap_scope. + +Definition read (h : heap) (p : ptr) : option hval := h p. + +Notation "a # b" := (read a b) (at level 55, no associativity) : heap_scope. + +Definition val (v:hval) := fst v. +Definition frac (v:hval) := snd v. + +Definition hval_plus (v1 v2 : hval) : option hval := + match (frac v1) +p (frac v2) with + | None => None + | Some v1v2 => Some (val v1, v1v2) + end. + +Definition hvalo_plus (v1 v2 : option hval) := + match v1 with + | None => v2 + | Some v1' => + match v2 with + | None => v1 + | Some v2' => (hval_plus v1' v2') + end + end. + +Notation "v1 +o v2" := (hvalo_plus v1 v2) (at level 60, no associativity) : heap_scope. + +Definition join (h1 h2 : heap) : heap := + (fun p => (h1 p) +o (h2 p)). + +Infix "*" := join (at level 40, left associativity) : heap_scope. + +Definition hprop := heap -> Prop. + +Bind Scope hprop_scope with hprop. +Delimit Scope hprop_scope with hprop. + +Definition hprop_cell (p : ptr) T (v : T) (pi:Qc): hprop := fun h => + h#p = Some (Dyn v, pi) /\ forall p', p' <> p -> h#p' = None. + +Notation "p ---> v" := (hprop_cell p v (0%Qc)) (at level 38, no associativity) : hprop_scope. + +Definition empty : heap := fun _ => None. + +Definition hprop_empty : hprop := eq empty. +Notation "'emp'" := hprop_empty : hprop_scope. + +Definition hprop_inj (P : Prop) : hprop := fun h => h = empty /\ P. +Notation "[ P ]" := (hprop_inj P) (at level 0, P at level 200) : hprop_scope. + +Definition hprop_imp (p1 p2 : hprop) : Prop := forall h, p1 h -> p2 h. +Infix "==>" := hprop_imp (right associativity, at level 55). + +Definition hprop_ex T (p : T -> hprop) : hprop := fun h => exists v, p v h. +Notation "'Exists' v :@ T , p" := (hprop_ex (fun v : T => p%hprop)) + (at level 90, T at next level) : hprop_scope. + +Local Open Scope hprop_scope. +Definition disjoint (h1 h2 : heap) : Prop := + forall p, + match h1#p with + | None => True + | Some v1 => match h2#p with + | None => True + | Some v2 => val v1 = val v2 + /\ compatible (frac v1) (frac v2) + end + end. + +Infix "<#>" := disjoint (at level 40, no associativity) : heap_scope. + +Definition split (h h1 h2 : heap) : Prop := h1 <#> h2 /\ h = h1 * h2. + +Notation "h ~> h1 * h2" := (split h h1 h2) (at level 40, h1 at next level, no associativity). + +Definition hprop_sep (p1 p2 : hprop) : hprop := fun h => + exists h1, exists h2, h ~> h1 * h2 + /\ p1 h1 + /\ p2 h2. +Infix "*" := hprop_sep (at level 40, left associativity) : hprop_scope. + +Section Stack. + Variable T : Set. + + Record node : Set := Node { + data : T; + next : option ptr + }. + + Fixpoint listRep (ls : list T) (hd : option ptr) {struct ls} : hprop := + match ls with + | nil => [hd = None] + | h :: t => + match hd with + | None => [False] + | Some hd' => Exists p :@ option ptr, hd' ---> Node h p * listRep t p + end + end%hprop. + + Definition stack := ptr. + + Definition rep q ls := (Exists po :@ option ptr, q ---> po * listRep ls po)%hprop. + + Definition isExistential T (x : T) := True. + + Theorem himp_ex_conc_trivial : forall T p p1 p2, + p ==> p1 * p2 + -> T + -> p ==> hprop_ex (fun _ : T => p1) * p2. + Admitted. + + Goal forall (s : ptr) (x : T) (nd : ptr) (v : unit) (x0 : list T) (v0 : option ptr) + (H0 : isExistential v0), + nd ---> {| data := x; next := v0 |} * (s ---> Some nd * listRep x0 v0) ==> + (Exists po :@ option ptr, + s ---> po * + match po with + | Some hd' => + Exists p :@ option ptr, + hd' ---> {| data := x; next := p |} * listRep x0 p + | None => [False] + end) * emp. + Proof. + intros. + try apply himp_ex_conc_trivial. diff --git a/test-suite/bugs/closed/3037.v b/test-suite/bugs/closed/3037.v new file mode 100644 index 00000000..baa7eff5 --- /dev/null +++ b/test-suite/bugs/closed/3037.v @@ -0,0 +1,11 @@ +(* Anomaly before 4a8950ec7a0d9f2b216e67e69b446c064590a8e9 *) + +Require Import Recdef. + +Function f_R (a: nat) {wf (fun x y: nat => False) a}:Prop:= + match a:nat with + | 0 => True + | (S y') => f_R y' + end. +(* Anomaly: File "plugins/funind/recdef.ml", line 916, characters 13-19: Assertion failed. +Please report. *) diff --git a/test-suite/bugs/closed/3043.v b/test-suite/bugs/closed/3043.v new file mode 100644 index 00000000..654663b4 --- /dev/null +++ b/test-suite/bugs/closed/3043.v @@ -0,0 +1,4 @@ +Goal (fun A (P : A -> Prop) (X : sigT P) => proj1_sig (sig_of_sigT X)) = + (fun A (P : A -> Prop) (X : sigT P) => projT1 X). + reflexivity. +Qed. diff --git a/test-suite/bugs/closed/3045.v b/test-suite/bugs/closed/3045.v new file mode 100644 index 00000000..ef110ad0 --- /dev/null +++ b/test-suite/bugs/closed/3045.v @@ -0,0 +1,34 @@ + +Set Asymmetric Patterns. +Generalizable All Variables. +Set Implicit Arguments. +Set Universe Polymorphism. + +Record SpecializedCategory (obj : Type) := + { + Object :> _ := obj; + Morphism : obj -> obj -> Type; + + Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' + }. + +Arguments Compose {obj} [C s d d'] m1 m2 : rename. + +Inductive ReifiedMorphism : forall objC (C : SpecializedCategory objC), C -> C -> Type := +| ReifiedComposedMorphism : forall objC C s d d', ReifiedMorphism C d d' -> ReifiedMorphism C s d -> @ReifiedMorphism objC C s d'. + +Fixpoint ReifiedMorphismDenote objC C s d (m : @ReifiedMorphism objC C s d) : Morphism C s d := + match m in @ReifiedMorphism objC C s d return Morphism C s d with + | ReifiedComposedMorphism _ _ _ _ _ m1 m2 => Compose (@ReifiedMorphismDenote _ _ _ _ m1) + (@ReifiedMorphismDenote _ _ _ _ m2) + end. + +Fixpoint ReifiedMorphismSimplifyWithProof objC C s d (m : @ReifiedMorphism objC C s d) +: { m' : ReifiedMorphism C s d | ReifiedMorphismDenote m = ReifiedMorphismDenote m' }. +refine match m with + | ReifiedComposedMorphism _ _ s0 d0 d0' m1 m2 => _ + end; clear m. +(* This fails with an error rather than an anomaly, but morally + it should work, if destruct were able to do the good generalization + in advance, before doing the "intros []". *) +Fail destruct (@ReifiedMorphismSimplifyWithProof T s1 d0 d0' m1) as [ [] ? ]. diff --git a/test-suite/bugs/closed/3050.v b/test-suite/bugs/closed/3050.v new file mode 100644 index 00000000..4b187224 --- /dev/null +++ b/test-suite/bugs/closed/3050.v @@ -0,0 +1,7 @@ +Goal forall A B, A * B -> A. +Proof. +intros A B H. +match goal with + | [ H : _ * _ |- _ ] => exact (fst H) +end. +Qed. diff --git a/test-suite/bugs/closed/3054.v b/test-suite/bugs/closed/3054.v new file mode 100644 index 00000000..936e58e1 --- /dev/null +++ b/test-suite/bugs/closed/3054.v @@ -0,0 +1,10 @@ +Section S. + +Let V := Type. + +Goal ~ true = false. +Proof. +congruence. +Qed. + +End S. diff --git a/test-suite/bugs/closed/3062.v b/test-suite/bugs/closed/3062.v new file mode 100644 index 00000000..a7b5fab0 --- /dev/null +++ b/test-suite/bugs/closed/3062.v @@ -0,0 +1,5 @@ +Lemma foo : forall x y:nat, x < y -> False. +Proof. + intros x y H. + induction H as [ |?y ?y ?y]. +Abort. diff --git a/test-suite/bugs/closed/3068.v b/test-suite/bugs/closed/3068.v new file mode 100644 index 00000000..03e5af61 --- /dev/null +++ b/test-suite/bugs/closed/3068.v @@ -0,0 +1,63 @@ +Section Counted_list. + + Variable A : Type. + + Inductive counted_list : nat -> Type := + | counted_nil : counted_list 0 + | counted_cons : forall(n : nat), + A -> counted_list n -> counted_list (S n). + + + Fixpoint counted_def_nth{n : nat}(l : counted_list n) + (i : nat)(def : A) : A := + match i with + | 0 => match l with + | counted_nil => def + | counted_cons _ a _ => a + end + | S i => match l with + | counted_nil => def + | counted_cons _ _ tl => counted_def_nth tl i def + end + end. + + + Lemma counted_list_equal_nth_char : + forall(n : nat)(l1 l2 : counted_list n)(def : A), + (forall(i : nat), counted_def_nth l1 i def = counted_def_nth l2 i def) -> + l1 = l2. + Proof. + admit. + Qed. + +End Counted_list. + +Implicit Arguments counted_def_nth [A n]. + +Section Finite_nat_set. + + Variable set_size : nat. + + Definition fnat_subset : Type := counted_list bool set_size. + + Definition fnat_member(fs : fnat_subset)(n : nat) : Prop := + is_true (counted_def_nth fs n false). + + + Lemma fnat_subset_member_eq : forall(fs1 fs2 : fnat_subset), + fs1 = fs2 <-> + forall(n : nat), fnat_member fs1 n <-> fnat_member fs2 n. + + Proof. + intros fs1 fs2. + split. + intros H n. + subst fs1. + apply iff_refl. + intros H. + eapply counted_list_equal_nth_char. + intros i. + destruct (counted_def_nth fs1 i _ ) eqn:H0. + (* This was not part of the initial bug report; this is to check that + the existential variable kept its name *) + change (true = counted_def_nth fs2 i ?def). diff --git a/test-suite/bugs/closed/3088.v b/test-suite/bugs/closed/3088.v new file mode 100644 index 00000000..3c362510 --- /dev/null +++ b/test-suite/bugs/closed/3088.v @@ -0,0 +1,12 @@ +Inductive R {A} : A -> A -> Type := c : forall x y, R x y. + +Goal forall A (x y : A) P (e : R x y) (f : forall x y, P x y (c x y)), + let g := match e in R x y return P x y e with c x y => f x y end in + True. +Proof. +intros A x y P e f g. +let t := eval red in g in +match t with + (match ?E as e in R x y return @?P x y e with c X Y => @?f X Y end) => idtac P f +end. +Abort. diff --git a/test-suite/bugs/closed/3093.v b/test-suite/bugs/closed/3093.v new file mode 100644 index 00000000..f6b4a03f --- /dev/null +++ b/test-suite/bugs/closed/3093.v @@ -0,0 +1,6 @@ +Require Import FunctionalExtensionality. + +Goal forall y, @f_equal = y. + intro. + apply functional_extensionality_dep. +Abort. diff --git a/test-suite/bugs/closed/3142.v b/test-suite/bugs/closed/3142.v new file mode 100644 index 00000000..988074e2 --- /dev/null +++ b/test-suite/bugs/closed/3142.v @@ -0,0 +1,9 @@ +(* Fixed together with #3262 in 48af6d1418282323b9fff0e789fed9478c064434 *) +(* April 4, 2014 (non-progress in candidates was not detected) *) + +Definition eqbool_dep (P : bool -> Prop) (h1 : P true) (b : bool) (h2 : P b) + : Prop := +(match b (* return P b -> Prop *) with + | true => fun (h : P true) => h1 = h + | false => fun (_ : P false) => False +end (* : P b -> Prop *)) h2. diff --git a/test-suite/bugs/closed/3164.v b/test-suite/bugs/closed/3164.v new file mode 100644 index 00000000..3c9af8d0 --- /dev/null +++ b/test-suite/bugs/closed/3164.v @@ -0,0 +1,49 @@ +(* Before 31a69c4d0fd7b8325187e8da697a9c283594047d, [case] would stack overflow *) +Require Import Arith. + +Section Acc_generator. + Variable A : Type. + Variable R : A -> A -> Prop. + + (* *Lazily* add 2^n - 1 Acc_intro on top of wf. + Needed for fast reductions using Function and Program Fixpoint + and probably using Fix and Fix_F_2 + *) + Fixpoint Acc_intro_generator n (wf : well_founded R) := + match n with + | O => wf + | S n => fun x => Acc_intro x (fun y _ => Acc_intro_generator n (Acc_intro_generator n wf) y) + end. + + +End Acc_generator. + +Definition pred_F : (forall x : nat, + (forall y : nat, y < x -> (fun _ : nat => nat) y) -> + (fun _ : nat => nat) x). +Proof. + intros x. + simpl. + case x. + exact (fun _ => 0). + intros n h. + apply (h n). + constructor. +Defined. + +Definition my_pred := Fix lt_wf (fun _ => nat) pred_F. + + +Lemma my_pred_is_pred : forall x, match my_pred x with | 0 => True | S n => False end. +Proof. + intros x. + case x. +Abort. + +Definition my_pred_bad := Fix (Acc_intro_generator _ _ 100 lt_wf) (fun _ => nat) pred_F. + +Lemma my_pred_is_pred : forall x, match my_pred_bad x with | 0 => True | S n => False end. +Proof. + intros x. + Timeout 2 case x. +Admitted. diff --git a/test-suite/bugs/closed/3188.v b/test-suite/bugs/closed/3188.v new file mode 100644 index 00000000..01176026 --- /dev/null +++ b/test-suite/bugs/closed/3188.v @@ -0,0 +1,22 @@ +(* File reduced by coq-bug-finder from 1656 lines to 221 lines to 26 lines to 7 lines. *) + +Module Long. + Require Import Coq.Classes.RelationClasses. + + Hint Extern 0 => apply reflexivity : typeclass_instances. + Hint Extern 1 => symmetry. + + Lemma foo : exists m' : Type, True. + intuition. (* Anomaly: Uncaught exception Not_found. Please report. *) + Abort. +End Long. + +Module Short. + Require Import Coq.Classes.RelationClasses. + + Hint Extern 0 => apply reflexivity : typeclass_instances. + + Lemma foo : exists m' : Type, True. + try symmetry. (* Anomaly: Uncaught exception Not_found. Please report. *) + Abort. +End Short. diff --git a/test-suite/bugs/closed/3205.v b/test-suite/bugs/closed/3205.v new file mode 100644 index 00000000..5c44f070 --- /dev/null +++ b/test-suite/bugs/closed/3205.v @@ -0,0 +1,26 @@ +Fail Fixpoint F (u : unit) : Prop := + (fun p : {P : Prop & _} => match p with existT _ _ P => P end) + (existT (fun P => False -> P) (F tt) _). +(* Anomaly: A universe comparison can only happen between variables. +Please report. *) + + + +Definition g (x : Prop) := x. + +Definition h (y : Type) := y. + +Definition eq_hf : h = g :> (Prop -> Type) := + @eq_refl (Prop -> Type) g. + +Set Printing All. +Set Printing Universes. +Fail Definition eq_hf : h = g :> (Prop -> Type) := + eq_refl g. +(* Originally an anomaly, now says +Toplevel input, characters 48-57: +Error: +The term "@eq_refl (forall _ : Prop, Prop) g" has type + "@eq (forall _ : Prop, Prop) g g" while it is expected to have type + "@eq (forall _ : Prop, Type (* Top.16 *)) (fun y : Prop => h y) g" +(Universe inconsistency: Cannot enforce Prop = Top.16)). *) diff --git a/test-suite/bugs/closed/3212.v b/test-suite/bugs/closed/3212.v new file mode 100644 index 00000000..53d8dfe3 --- /dev/null +++ b/test-suite/bugs/closed/3212.v @@ -0,0 +1,10 @@ +Lemma H : Prop = Prop. +reflexivity. +Qed. + +Lemma foo : match H in (_ = X) return X with + | eq_refl => True +end. +Proof. +Fail destruct H. +Abort. diff --git a/test-suite/bugs/closed/3217.v b/test-suite/bugs/closed/3217.v new file mode 100644 index 00000000..ec846bf9 --- /dev/null +++ b/test-suite/bugs/closed/3217.v @@ -0,0 +1,36 @@ +(** [Set Implicit Arguments] causes Coq to run out of memory on [Qed] before c3feef4ed5dec126f1144dec91eee9c0f0522a94 *) +Set Implicit Arguments. + +Variable LEM: forall P : Prop, sumbool P (P -> False). + +Definition pmap := option (nat -> option nat). + +Definition pmplus (oha ohb: pmap) : pmap := + match oha, ohb with + | Some ha, Some hb => + if LEM (oha = ohb) then None else None + | _, _ => None + end. + +Definition pmemp: pmap := Some (fun _ => None). + +Lemma foo: + True -> + (pmplus pmemp + (pmplus pmemp + (pmplus pmemp + (pmplus pmemp + (pmplus pmemp + (pmplus pmemp + (pmplus pmemp + (pmplus pmemp + (pmplus pmemp + (pmplus pmemp + (pmplus pmemp + (pmplus pmemp + pmemp)))))))))))) + = + None -> True. +Proof. + auto. +Timeout 2 Qed. diff --git a/test-suite/bugs/closed/3228.v b/test-suite/bugs/closed/3228.v new file mode 100644 index 00000000..5d1a0ff8 --- /dev/null +++ b/test-suite/bugs/closed/3228.v @@ -0,0 +1,7 @@ +(* Check that variables in the context do not take precedence over + ltac variables *) + +Ltac bar x := exact x. +Goal False -> False. + intro x. + Fail bar doesnotexist. diff --git a/test-suite/bugs/closed/3242.v b/test-suite/bugs/closed/3242.v new file mode 100644 index 00000000..805baee1 --- /dev/null +++ b/test-suite/bugs/closed/3242.v @@ -0,0 +1,2 @@ +Inductive Foo (x := Type) := C : Foo -> Foo. + diff --git a/test-suite/bugs/closed/3251.v b/test-suite/bugs/closed/3251.v new file mode 100644 index 00000000..5a7ae200 --- /dev/null +++ b/test-suite/bugs/closed/3251.v @@ -0,0 +1,13 @@ +Goal True. +Ltac foo := idtac. +(* print out happens twice: +foo is defined +foo is defined + +... that's fishy. But E. Tassi tells me that it's expected since "Ltac" generates a side +effect that escapes the proof. In the STM model this means the command is executed twice, +once in the proof branch, and another time in the main branch *) +Undo. +Ltac foo := idtac. +(* Before 5b39c3535f7b3383d89d7b844537244a4e7c0eca, this would print out: *) +(* Anomaly: Backtrack.backto to a state with no vcs_backup. Please report. *) diff --git a/test-suite/bugs/closed/3258.v b/test-suite/bugs/closed/3258.v new file mode 100644 index 00000000..a1390e30 --- /dev/null +++ b/test-suite/bugs/closed/3258.v @@ -0,0 +1,35 @@ +Require Import Coq.Classes.Morphisms Coq.Classes.RelationClasses Coq.Program.Program Coq.Setoids.Setoid. + +Global Set Implicit Arguments. + +Hint Extern 0 => apply reflexivity : typeclass_instances. + +Inductive Comp : Type -> Type := +| Pick : forall A, (A -> Prop) -> Comp A. + +Axiom computes_to : forall A, Comp A -> A -> Prop. + +Axiom refine : forall {A} (old : Comp A) (new : Comp A), Prop. + +Global Instance refine_PreOrder A : PreOrder (@refine A). +Admitted. +Add Parametric Morphism A +: (@Pick A) + with signature + (pointwise_relation _ (flip impl)) + ==> (@refine A) + as refine_flip_impl_Pick. + admit. +Defined. +Definition remove_forall_eq' A x B (P : A -> B -> Prop) : pointwise_relation _ impl (P x) (fun z => forall y : A, y = x -> P y z). + admit. +Defined. +Goal forall A B (x : A) (P : _ -> _ -> Prop), + refine (Pick (fun n : B => forall y, y = x -> P y n)) + (Pick (fun n : B => P x n)). +Proof. + intros. + setoid_rewrite (@remove_forall_eq' _ _ _ _). + Undo. + (* This failed with NotConvertible at some time *) + setoid_rewrite (@remove_forall_eq' _ _ _). diff --git a/test-suite/bugs/closed/3259.v b/test-suite/bugs/closed/3259.v new file mode 100644 index 00000000..0306c686 --- /dev/null +++ b/test-suite/bugs/closed/3259.v @@ -0,0 +1,21 @@ +Goal forall m n, n+n = m+m -> m+m = m+m. +Proof. +intros. +set (k := n+n) in *. +cut (n=m). +intro. +subst n. +admit. +admit. +Qed. + +Goal forall m n, n+n = m+m -> n+n = m+m. +Proof. +intros. +set (k := n+n). +cut (n=m). +intro. +subst n. +admit. +admit. +Qed. diff --git a/test-suite/bugs/closed/3260.v b/test-suite/bugs/closed/3260.v new file mode 100644 index 00000000..9f0231d9 --- /dev/null +++ b/test-suite/bugs/closed/3260.v @@ -0,0 +1,7 @@ +Require Import Setoid. +Goal forall m n, n = m -> n+n = m+m. +intros. +replace n with m at 2. +lazymatch goal with +|- n + m = m + m => idtac +end. diff --git a/test-suite/bugs/closed/3262.v b/test-suite/bugs/closed/3262.v new file mode 100644 index 00000000..70bfde29 --- /dev/null +++ b/test-suite/bugs/closed/3262.v @@ -0,0 +1,78 @@ +(* Not having a [return] clause causes the [refine] at the bottom to stack overflow before f65fa9de8a4c9c12d933188a755b51508bd51921 *) + +Require Import Coq.Lists.List. +Require Import Relations RelationClasses. + +Set Implicit Arguments. +Set Strict Implicit. +Set Asymmetric Patterns. + +Section hlist. + Context {iT : Type}. + Variable F : iT -> Type. + + Inductive hlist : list iT -> Type := + | Hnil : hlist nil + | Hcons : forall l ls, F l -> hlist ls -> hlist (l :: ls). + + Definition hlist_hd {a b} (hl : hlist (a :: b)) : F a := + match hl in hlist x return match x with + | nil => unit + | l :: _ => F l + end with + | Hnil => tt + | Hcons _ _ x _ => x + end. + + Definition hlist_tl {a b} (hl : hlist (a :: b)) : hlist b := + match hl in hlist x return match x with + | nil => unit + | _ :: ls => hlist ls + end with + | Hnil => tt + | Hcons _ _ _ x => x + end. + + Lemma hlist_eta : forall ls (h : hlist ls), + h = match ls as ls return hlist ls -> hlist ls with + | nil => fun _ => Hnil + | a :: b => fun h => Hcons (hlist_hd h) (hlist_tl h) + end h. + Proof. + intros. destruct h; auto. + Qed. + + Variable eqv : forall x, relation (F x). + + Inductive equiv_hlist : forall ls, hlist ls -> hlist ls -> Prop := + | hlist_eqv_nil : equiv_hlist Hnil Hnil + | hlist_eqv_cons : forall l ls x y h1 h2, eqv x y -> equiv_hlist h1 h2 -> + @equiv_hlist (l :: ls) (Hcons x h1) (Hcons y h2). + + Global Instance Reflexive_equiv_hlist (R : forall t, Reflexive (@eqv t)) ls + : Reflexive (@equiv_hlist ls). + Proof. + red. induction x; constructor; auto. reflexivity. + Qed. + + Global Instance Transitive_equiv_hlist (R : forall t, Transitive (@eqv t)) ls + : Transitive (@equiv_hlist ls). + Proof. + red. induction 1. + { intro; assumption. } + { rewrite (hlist_eta z). + Timeout 2 Fail refine + (fun H => + match H in @equiv_hlist ls X Y + return + (* Uncommenting the following gives an immediate error in 8.4pl3; commented out results in a stack overflow *) + match ls (*as ls return hlist ls -> hlist ls -> Type*) with + | nil => fun _ _ : hlist nil => True + | l :: ls => fun (X Y : hlist (l :: ls)) => + equiv_hlist (Hcons x h1) Y + end X Y + with + | hlist_eqv_nil => I + | hlist_eqv_cons l ls x y h1 h2 pf pf' => + _ + end). diff --git a/test-suite/bugs/closed/3264.v b/test-suite/bugs/closed/3264.v new file mode 100644 index 00000000..4eb21890 --- /dev/null +++ b/test-suite/bugs/closed/3264.v @@ -0,0 +1,45 @@ +Module File1. + Module Export DirA. + Module A. + Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + + Arguments idpath {A a} , [A] a. + + Notation "x = y :> A" := (@paths A x y) : type_scope. + Notation "x = y" := (x = y :>_) : type_scope. + End A. + End DirA. +End File1. + +Module File2. + Module Export DirA. + Module B. + Import File1. + Export A. + Lemma foo : forall x y : Type, x = y -> y = x. + Proof. + intros x y H. + rewrite <- H. + constructor. + Qed. + End B. + End DirA. +End File2. + +Module File3. + Module Export DirA. + Module C. + Import File1. + Export A. + Lemma bar : forall x y : Type, x = y -> y = x. + Proof. + intros x y H. + rewrite <- H. + constructor. + Defined. + Definition bar' + := Eval cbv beta iota zeta delta [bar internal_paths_rew] in bar. + End C. + End DirA. +End File3. diff --git a/test-suite/bugs/closed/3265.v b/test-suite/bugs/closed/3265.v new file mode 100644 index 00000000..269c7b74 --- /dev/null +++ b/test-suite/bugs/closed/3265.v @@ -0,0 +1,6 @@ +Require Import Setoid. +Hint Extern 0 => apply reflexivity : typeclass_instances. +Goal forall (B : Type) (P : B -> Prop), exists y : B, P y. + intros. + try reflexivity. (* Anomaly: Uncaught exception Not_found. Please report. *) +Abort. diff --git a/test-suite/bugs/closed/3266.v b/test-suite/bugs/closed/3266.v new file mode 100644 index 00000000..fd4cbff8 --- /dev/null +++ b/test-suite/bugs/closed/3266.v @@ -0,0 +1,3 @@ +Class A := a : nat. +Lemma p : True. +Proof. cut A; [tauto | exact 1]. Qed. diff --git a/test-suite/bugs/closed/3267.v b/test-suite/bugs/closed/3267.v new file mode 100644 index 00000000..5ce1ddf0 --- /dev/null +++ b/test-suite/bugs/closed/3267.v @@ -0,0 +1,36 @@ +Module a. + Local Hint Extern 0 => progress subst. + Goal forall T (x y : T) (P Q : _ -> Prop), x = y -> (P x -> Q x) -> P y -> Q y. + Proof. + intros. + (* this should not fail *) + progress eauto. + Defined. +End a. + +Module b. + Local Hint Extern 0 => progress subst. + Goal forall T (x y : T) (P Q : _ -> Prop), y = x -> (P x -> Q x) -> P y -> Q y. + Proof. + intros. + eauto. + Defined. +End b. + +Module c. + Local Hint Extern 0 => progress subst; eauto. + Goal forall T (x y : T) (P Q : _ -> Prop), x = y -> (P x -> Q x) -> P y -> Q y. + Proof. + intros. + eauto. + Defined. +End c. + +Module d. + Local Hint Extern 0 => progress subst; repeat match goal with H : _ |- _ => revert H end. + Goal forall T (x y : T) (P Q : _ -> Prop), x = y -> (P x -> Q x) -> P y -> Q y. + Proof. + intros. + debug eauto. + Defined. +End d. diff --git a/test-suite/bugs/closed/328.v b/test-suite/bugs/closed/328.v new file mode 100644 index 00000000..52cfbbc4 --- /dev/null +++ b/test-suite/bugs/closed/328.v @@ -0,0 +1,40 @@ +Module Type TITI. +Parameter B:Set. +Parameter x:B. +Inductive A:Set:= +a1:B->A. +Definition f2: A ->B +:= fun (a:A) => +match a with + (a1 b)=>b +end. +Definition f: A -> B:=fun (a:A) => x. +End TITI. + + +Module Type TIT. +Declare Module t:TITI. +End TIT. + +Module Seq(titi:TIT). +Module t:=titi.t. +Inductive toto:t.A->t.B->Set:= +t1:forall (a:t.A), (toto a (t.f a)) +| t2:forall (a:t.A), (toto a (t.f2 a)). +End Seq. + +Module koko(tit:TIT). +Module seq:=Seq tit. +Module t':=tit.t. + +Definition def:forall (a:t'.A), (seq.toto a (t'.f a)). +intro ; constructor 1. +Defined. + +Definition def2: forall (a:t'.A), (seq.toto a (t'.f2 a)). +intro; constructor 2. +(* Toplevel input, characters 0-13 + constructor 2. + ^^^^^^^^^^^^^ +Error: Impossible to unify (seq.toto ?3 (seq.t.f2 ?3)) with + (seq.toto a (t'.f2 a)).*) diff --git a/test-suite/bugs/closed/3281.v b/test-suite/bugs/closed/3281.v new file mode 100644 index 00000000..d340f0ca --- /dev/null +++ b/test-suite/bugs/closed/3281.v @@ -0,0 +1,5 @@ +Fail Lemma foo : @eq _ nat Type. +Fail Lemma foo : @eq Set nat Type. + +Lemma foo : @eq Type nat Type. Admitted. +Lemma foo' : @eq _ Type nat. Admitted. diff --git a/test-suite/bugs/closed/3282.v b/test-suite/bugs/closed/3282.v new file mode 100644 index 00000000..ce7cab1c --- /dev/null +++ b/test-suite/bugs/closed/3282.v @@ -0,0 +1,7 @@ +(* Check let-ins in fix and Fixpoint *) + +Definition foo := fix f (m : nat) (o := true) (n : nat) {struct n} := + match n with 0 => 0 | S n' => f 0 n' end. + +Fixpoint f (m : nat) (o := true) (n : nat) {struct n} := + match n with 0 => 0 | S n' => f 0 n' end. diff --git a/test-suite/bugs/closed/3284.v b/test-suite/bugs/closed/3284.v new file mode 100644 index 00000000..34cd09c6 --- /dev/null +++ b/test-suite/bugs/closed/3284.v @@ -0,0 +1,23 @@ +(* Several bugs: +- wrong env in pose_all_metas_as_evars leading to out of scope instance of evar +- check that metas posed as evars in pose_all_metas_as_evars were + resolved was not done +*) + +Axiom functional_extensionality_dep : + forall {A : Type} {B : A -> Type} (f g : forall x : A, B x), + (forall x : A, f x = g x) -> f = g. + +Goal forall A B C (f g : forall (x : A) (y : B x), C x y), forall x:A, (forall x y, f x y = g x y) -> True. +Proof. + intros A B C f g x H. + Fail apply @functional_extensionality_dep in H. + Fail apply functional_extensionality_dep in H. + eapply functional_extensionality_dep in H. +Abort. + +Goal forall A B C (f g : forall (x : A) (y : B x), C x y), forall x:A, (forall x y, f x y = g x y) -> True. +Proof. + intros A B C f g x H. + specialize (H x). + apply functional_extensionality_dep in H. diff --git a/test-suite/bugs/closed/3285.v b/test-suite/bugs/closed/3285.v new file mode 100644 index 00000000..25162329 --- /dev/null +++ b/test-suite/bugs/closed/3285.v @@ -0,0 +1,7 @@ +Goal True. +Proof. +match goal with + | _ => let x := constr:($(fail)$) in idtac + | _ => idtac +end. +Abort. diff --git a/test-suite/bugs/closed/3286.v b/test-suite/bugs/closed/3286.v new file mode 100644 index 00000000..b08b7ab3 --- /dev/null +++ b/test-suite/bugs/closed/3286.v @@ -0,0 +1,41 @@ +Require Import FunctionalExtensionality. + +Ltac make_apply_under_binders_in lem H := + let tac := make_apply_under_binders_in in + match type of H with + | forall x : ?T, @?P x + => let ret := constr:(fun x' : T => + let Hx := H x' in + $(let ret' := tac lem Hx in + exact ret')$) in + match eval cbv zeta in ret with + | fun x => Some (@?P x) => let P' := (eval cbv zeta in P) in + constr:(Some P') + end + | _ => let ret := constr:($(match goal with + | _ => (let H' := fresh in + pose H as H'; + apply lem in H'; + exact (Some H')) + | _ => exact (@None nat) + end + )$) in + let ret' := (eval cbv beta zeta in ret) in + constr:(ret') + | _ => constr:(@None nat) + end. + +Ltac apply_under_binders_in lem H := + let H' := make_apply_under_binders_in lem H in + let H'0 := match H' with Some ?H'0 => constr:(H'0) end in + let H'' := fresh in + pose proof H'0 as H''; + clear H; + rename H'' into H. + +Goal forall A B C (f g : forall (x : A) (y : B x), C x y), (forall x y, f x y = g x y) -> True. +Proof. + intros A B C f g H. + let lem := constr:(@functional_extensionality_dep) in + apply_under_binders_in lem H. +(* Anomaly: Uncaught exception Not_found(_). Please report. *) diff --git a/test-suite/bugs/closed/3287.v b/test-suite/bugs/closed/3287.v new file mode 100644 index 00000000..7c781312 --- /dev/null +++ b/test-suite/bugs/closed/3287.v @@ -0,0 +1,20 @@ +Module Foo. +(* Definition foo := (I,I). *) +Definition bar := true. +End Foo. + +Recursive Extraction Foo.bar. + +Module Foo'. +Definition foo := (I,I). +Definition bar := true. +End Foo'. + +Recursive Extraction Foo'.bar. + +Module Foo''. +Definition foo := (I,I). +Definition bar := true. +End Foo''. + +Extraction Foo.bar. diff --git a/test-suite/bugs/closed/3289.v b/test-suite/bugs/closed/3289.v new file mode 100644 index 00000000..4542b015 --- /dev/null +++ b/test-suite/bugs/closed/3289.v @@ -0,0 +1,27 @@ +(* File reduced by coq-bug-finder from original input, then from 1829 lines to 37 lines, then from 47 lines to 18 lines *) + +Class Contr_internal (A : Type) := + BuildContr { center : A ; + contr : (forall y : A, True) }. +Class Contr A := Contr_is_contr : Contr_internal A. +Inductive Unit : Set := tt. +Instance contr_unit : Contr Unit | 0 := + let x := {| + center := tt; + contr := fun t : Unit => I + |} in x. (* success *) + +Instance contr_internal_unit' : Contr_internal Unit | 0 := + {| + center := tt; + contr := fun t : Unit => I + |}. + +Instance contr_unit' : Contr Unit | 0 := + {| + center := tt; + contr := fun t : Unit => I + |}. +(* Error: Mismatched contexts while declaring instance: + Expected: (Contr_is_contr : Contr_internal _UNBOUND_REL_1) + Found: tt (fun t : Unit => I) *) diff --git a/test-suite/bugs/closed/329.v b/test-suite/bugs/closed/329.v new file mode 100644 index 00000000..def6ed98 --- /dev/null +++ b/test-suite/bugs/closed/329.v @@ -0,0 +1,100 @@ +Module Sylvain_Boulme. +Module Type Essai. +Parameter T: Type. +Parameter my_eq: T -> T -> Prop. +Parameter my_eq_refl: forall (x:T), (my_eq x x). +Parameter c: T. +End Essai. + +Module Type Essai2. +Declare Module M: Essai. +Parameter c2: M.T. +End Essai2. + +Module Type Essai3. +Declare Module M: Essai. +Parameter c3: M.T. +End Essai3. + +Module Type Lift. +Declare Module Core: Essai. +Declare Module M: Essai. +Parameter lift: Core.T -> M.T. +Parameter lift_prop:forall (x:Core.T), (Core.my_eq x Core.c)->(M.my_eq (lift x) M.c). +End Lift. + +Module I2 (X:Essai) <: Essai2. + Module Core := X. + Module M<:Essai. + Definition T:Type :=Prop. + Definition my_eq:=(@eq Prop). + Definition c:=True. + Lemma my_eq_refl: forall (x:T), (my_eq x x). + Proof. + unfold my_eq; auto. + Qed. + End M. + Definition c2:=False. + Definition lift:=fun (_:Core.T) => M.c. + Definition lift_prop: forall (x:Core.T), (Core.my_eq x Core.c)->(M.my_eq (lift x) M.c). + Proof. + unfold lift, M.my_eq; auto. + Qed. +End I2. + +Module I4(X:Essai3) (L: Lift with Module Core := X.M) <: Essai3 with Module +M:=L.M. + Module M:=L.M. + Definition c3:=(L.lift X.c3). +End I4. + +Module I5(X:Essai3). + Module Toto<: Lift with Module Core := X.M := I2(X.M). + Module E4<: Essai3 with Module M:=Toto.M := I4(X)(Toto). +(* +Le typage de E4 echoue avec le message + Error: Signature components for label my_eq_refl do not match + *) + + Module E3<: Essai3 := I4(X)(Toto). + + Definition zarb: forall (x:Toto.M.T), (Toto.M.my_eq x x) := E3.M.my_eq_refl. +End I5. +End Sylvain_Boulme. + + +Module Jacek. + + Module Type SIG. + End SIG. + Module N. + Definition A:=Set. + End N. + Module Type SIG2. + Declare Module M:SIG. + Parameter B:Type. + End SIG2. + Module F(X:SIG2 with Module M:=N) (Y:SIG2 with Definition B:=X.M.A). + End F. +End Jacek. + + +Module anoun. + Module Type TITI. + Parameter X: Set. + End TITI. + + Module Type Ex. + Declare Module t: TITI. + Parameter X : t.X -> t.X -> Set. + End Ex. + + Module unionEx(X1: Ex) (X2:Ex with Module t :=X1.t): Ex. + Module t:=X1.t. + Definition X :=fun (a b:t.X) => ((X1.X a b)+(X2.X a b))%type. + End unionEx. +End anoun. +(* Le warning qui s'affiche lors de la compilation est le suivant : + TODO:replace module after with! + Est ce qu'il y'a qq1 qui pourrait m'aider à comprendre le probleme?! + Je vous remercie d'avance *) diff --git a/test-suite/bugs/closed/3291.v b/test-suite/bugs/closed/3291.v new file mode 100644 index 00000000..4ea748c0 --- /dev/null +++ b/test-suite/bugs/closed/3291.v @@ -0,0 +1,9 @@ +Require Import Setoid. + +Definition segv : forall x, (x = 0%nat) -> (forall (y : nat), (y < x)%nat -> nat) = forall (y : nat), (y < 0)%nat -> nat. +intros x eq. +assert (H : forall y, (y < x)%nat = (y < 0)%nat). +rewrite -> eq. auto. +Set Typeclasses Debug. +Fail setoid_rewrite <- H. (* The command has indeed failed with message: +=> Stack overflow. *) diff --git a/test-suite/bugs/closed/3294.v b/test-suite/bugs/closed/3294.v new file mode 100644 index 00000000..ed1a0c29 --- /dev/null +++ b/test-suite/bugs/closed/3294.v @@ -0,0 +1,6 @@ +Check (match true return + match eq_refl Type return Type with eq_refl => bool end + with _ => true end). +Check (match true return + match eq_refl Type with eq_refl => bool end + with _ => true end). diff --git a/test-suite/bugs/closed/3297.v b/test-suite/bugs/closed/3297.v new file mode 100644 index 00000000..1cacb97f --- /dev/null +++ b/test-suite/bugs/closed/3297.v @@ -0,0 +1,12 @@ +Goal forall (n : nat) (H := eq_refl : n = n) (H' : n = 0), H = eq_refl. + intros. + subst. (* Toplevel input, characters 15-20: +Error: Abstracting over the term "n" leads to a term +"λ n : nat, H = eq_refl" which is ill-typed. *) + Undo. + revert H. + subst. (* success *) + Undo. + intro. + clearbody H. + subst. (* success *) diff --git a/test-suite/bugs/closed/3300.v b/test-suite/bugs/closed/3300.v new file mode 100644 index 00000000..a28144b9 --- /dev/null +++ b/test-suite/bugs/closed/3300.v @@ -0,0 +1,7 @@ +Set Primitive Projections. +Record Box (T : Type) : Prop := wrap {prop : T}. + +Definition down (x : Type) : Prop := Box x. +Definition up (x : Prop) : Type := x. + +Fail Definition back A : up (down A) -> A := @prop A. diff --git a/test-suite/bugs/closed/3305.v b/test-suite/bugs/closed/3305.v new file mode 100644 index 00000000..f3f21952 --- /dev/null +++ b/test-suite/bugs/closed/3305.v @@ -0,0 +1,13 @@ +Require Export Coq.Classes.RelationClasses. + +Section defs. + Variable A : Type. + Variable lt : A -> A -> Prop. + Context {ltso : StrictOrder lt}. + + Goal forall (a : A), lt a a -> False. + Proof. + intros a H. + contradict (irreflexivity H). + Qed. +End defs. diff --git a/test-suite/bugs/closed/3306.v b/test-suite/bugs/closed/3306.v new file mode 100644 index 00000000..599e8391 --- /dev/null +++ b/test-suite/bugs/closed/3306.v @@ -0,0 +1,12 @@ + +Inductive Foo(A : Type) : Prop := + foo: A -> Foo A. + +Arguments foo [A] _. + +Scheme Foo_elim := Induction for Foo Sort Prop. + +Goal forall (fn : Foo nat), { x: nat | foo x = fn }. +intro fn. +Fail induction fn as [n] using Foo_elim. (* should fail in a non-Prop context *) +Admitted. diff --git a/test-suite/bugs/closed/3309.v b/test-suite/bugs/closed/3309.v new file mode 100644 index 00000000..fcebdec7 --- /dev/null +++ b/test-suite/bugs/closed/3309.v @@ -0,0 +1,326 @@ +(* -*- coq-prog-args: ("-emacs" "-impredicative-set") -*- *) +(* File reduced by coq-bug-finder from original input, then from 5968 lines to 11933 lines, then from 11239 lines to 11231 lines, then from 10365 lines to 446 lines, then from 456 lines to 379 lines, then from 391 lines to 373 lines, then from 369 lines to 351 lines, then from 350 lines to 340 lines, then from 348 lines to 320 lines, then from 328 lines to 302 lines *) +Set Universe Polymorphism. +Record sigT' {A} (P : A -> Type) := existT' { projT1' : A; projT2' : P projT1' }. +Notation "{ x : A &' P }" := (sigT' (A := A) (fun x => P)) : type_scope. +Arguments existT' {A} P _ _. +Axiom admit : forall {T}, T. +Notation paths := identity . + +Unset Automatic Introduction. + +Definition UU := Set. + +Definition dirprod ( X Y : UU ) := sigT' ( fun x : X => Y ) . +Definition dirprodpair { X Y : UU } := existT' ( fun x : X => Y ) . + +Definition ddualand { X Y P : UU } (xp : ( X -> P ) -> P ) ( yp : ( Y -> P ) -> P ) : ( dirprod X Y -> P ) -> P. +Proof. + intros X Y P xp yp X0 . + set ( int1 := fun ypp : ( ( Y -> P ) -> P ) => fun x : X => yp ( fun y : Y => X0 ( dirprodpair x y) ) ) . + apply ( xp ( int1 yp ) ) . +Defined . +Definition weq ( X Y : UU ) : UU . +intros; exact ( sigT' (fun f:X->Y => admit) ). +Defined. +Definition pr1weq ( X Y : UU):= @projT1' _ _ : weq X Y -> (X -> Y). +Coercion pr1weq : weq >-> Funclass. + +Definition invweq { X Y : UU } ( w : weq X Y ) : weq Y X . +admit. +Defined. + +Definition hProp := sigT' (fun X : Type => admit). + +Definition hProppair ( X : UU ) ( is : admit ) : hProp@{i j Set k}. +intros; exact (existT' (fun X : UU => admit ) X is ). +Defined. +Definition hProptoType := @projT1' _ _ : hProp -> Type . +Coercion hProptoType: hProp >-> Sortclass. + +Definition ishinh_UU ( X : UU ) : UU := forall P: Set, ( ( X -> P ) -> P ). + +Definition ishinh ( X : UU ) : hProp := hProppair ( ishinh_UU X ) admit. + +Definition hinhfun { X Y : UU } ( f : X -> Y ) : ishinh_UU X -> ishinh_UU Y. +intros X Y f; exact ( fun isx : ishinh X => fun P : _ => fun yp : Y -> P => isx P ( fun x : X => yp ( f x ) ) ). +Defined. + +Definition hinhuniv { X : UU } { P : hProp } ( f : X -> P ) ( wit : ishinh_UU X ) : P. +intros; exact ( wit P f ). +Defined. + +Definition hinhand { X Y : UU } ( inx1 : ishinh_UU X ) ( iny1 : ishinh_UU Y) : ishinh ( dirprod X Y ). +intros; exact ( fun P:_ => ddualand (inx1 P) (iny1 P)) . +Defined. + +Definition UU' := Type. +Definition hSet:= sigT' (fun X : UU' => admit) . +Definition hSetpair := existT' (fun X : UU' => admit). +Definition pr1hSet:= @projT1' UU (fun X : UU' => admit) : hSet -> Type. +Coercion pr1hSet: hSet >-> Sortclass. + +Definition hPropset : hSet := existT' _ hProp admit . + +Definition hsubtypes ( X : UU ) : Type. +intros; exact (X -> hProp ). +Defined. +Definition carrier { X : UU } ( A : hsubtypes X ) : Type. +intros; exact (sigT' A). +Defined. +Coercion carrier : hsubtypes >-> Sortclass. + +Definition subtypesdirprod { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) : hsubtypes ( dirprod X Y ). +admit. +Defined. + +Lemma weqsubtypesdirprod { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) : weq ( subtypesdirprod A B ) ( dirprod A B ) . + admit. +Defined. + +Lemma ishinhsubtypesdirprod { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) ( isa : ishinh A ) ( isb : ishinh B ) : ishinh ( subtypesdirprod A B ) . +Proof . + intros . + apply ( hinhfun ( invweq ( weqsubtypesdirprod A B ) ) ) . + apply hinhand . + apply isa . + apply isb . +Defined . + +Definition hrel ( X : UU ) : Type. +intros; exact ( X -> X -> hProp). +Defined. + +Definition iseqrel { X : UU } ( R : hrel X ) : Type. +admit. +Defined. + +Definition eqrel ( X : UU ) : Type. +intros; exact ( sigT' ( fun R : hrel X => iseqrel R ) ). +Defined. +Definition pr1eqrel ( X : UU ) : eqrel X -> ( X -> ( X -> hProp ) ) := @projT1' _ _ . +Coercion pr1eqrel : eqrel >-> Funclass . + +Definition hreldirprod { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) : hrel ( dirprod X Y ) . +admit. +Defined. +Set Printing Universes. +Print hProp. +Print ishinh_UU. +Print hProppair. +Definition iseqclass { X : UU } ( R : hrel X ) ( A : hsubtypes X ) : Type. +intros; exact ( dirprod ( ishinh ( carrier A ) ) ( dirprod ( forall x1 x2 : X , R x1 x2 -> A x1 -> A x2 ) ( forall x1 x2 : X, A x1 -> A x2 -> R x1 x2 ) )) . +Defined. +Definition iseqclassconstr { X : UU } ( R : hrel X ) { A : hsubtypes X } ( ax0 : ishinh ( carrier A ) ) ( ax1 : forall x1 x2 : X , R x1 x2 -> A x1 -> A x2 ) ( ax2 : forall x1 x2 : X, A x1 -> A x2 -> R x1 x2 ) : iseqclass R A. +intros. hnf. apply dirprodpair. exact ax0. apply dirprodpair. exact ax1. exact ax2. +Defined. + +Definition eqax0 { X : UU } { R : hrel X } { A : hsubtypes X } : iseqclass R A -> ishinh ( carrier A ) . +intros X R A; exact ( fun is : iseqclass R A => projT1' _ is ). +Defined. + +Lemma iseqclassdirprod { X Y : UU } { R : hrel X } { Q : hrel Y } { A : hsubtypes X } { B : hsubtypes Y } ( isa : iseqclass R A ) ( isb : iseqclass Q B ) : iseqclass ( hreldirprod R Q ) ( subtypesdirprod A B ) . +Proof . + intros . + set ( XY := dirprod X Y ) . + set ( AB := subtypesdirprod A B ) . + set ( RQ := hreldirprod R Q ) . + set ( ax0 := ishinhsubtypesdirprod A B ( eqax0 isa ) admit ) . + apply ( iseqclassconstr _ ax0 admit admit ) . +Defined . + +Definition image { X Y : UU } ( f : X -> Y ) : Type. +intros; exact ( sigT' ( fun y : Y => admit ) ). +Defined. +Definition pr1image { X Y : UU } ( f : X -> Y ) : image f -> Y. +intros X Y f; exact ( @projT1' _ ( fun y : Y => admit ) ). +Defined. + +Definition prtoimage { X Y : UU } (f : X -> Y) : X -> image f. + admit. +Defined. + +Definition setquot { X : UU } ( R : hrel X ) : Type. +intros; exact ( sigT' ( fun A : _ => iseqclass R A ) ). +Defined. +Definition setquotpair { X : UU } ( R : hrel X ) ( A : hsubtypes X ) ( is : iseqclass R A ) : setquot R. +intros; exact (existT' _ A is ). +Defined. +Definition pr1setquot { X : UU } ( R : hrel X ) : setquot R -> ( hsubtypes X ). +intros X R. +exact ( @projT1' _ ( fun A : _ => iseqclass R A ) ). +Defined. +Coercion pr1setquot : setquot >-> hsubtypes . + +Definition setquotinset { X : UU } ( R : hrel X ) : hSet. +intros; exact ( hSetpair (setquot R) admit) . +Defined. + +Definition dirprodtosetquot { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) (cd : dirprod ( setquot RX ) ( setquot RY ) ) : setquot ( hreldirprod RX RY ). +intros; exact ( setquotpair _ _ ( iseqclassdirprod ( projT2' _ ( projT1' _ cd ) ) ( projT2' _ ( projT2' _ cd ) ) ) ). +Defined. + +Definition iscomprelfun2 { X Y : UU } ( R : hrel X ) ( f : X -> X -> Y ) := forall x x' x0 x0' : X , R x x' -> R x0 x0' -> paths ( f x x0 ) ( f x' x0' ) . + +Definition binop ( X : UU ) : Type. +intros; exact ( X -> X -> X ). +Defined. + +Definition setwithbinop : Type. +exact (sigT' ( fun X : hSet => binop X ) ). +Defined. +Definition pr1setwithbinop : setwithbinop -> hSet@{j k Set l}. +unfold setwithbinop. +exact ( @projT1' _ ( fun X : hSet@{j k Set l} => binop@{Set} X ) ). +Defined. +Coercion pr1setwithbinop : setwithbinop >-> hSet . + +Definition op { X : setwithbinop } : binop X. +intros; exact ( projT2' _ X ). +Defined. + +Definition subsetswithbinop { X : setwithbinop } : Type. +admit. +Defined. + +Definition carrierofasubsetwithbinop { X : setwithbinop } ( A : @subsetswithbinop X ) : setwithbinop . +admit. +Defined. + +Coercion carrierofasubsetwithbinop : subsetswithbinop >-> setwithbinop . + +Definition binopeqrel { X : setwithbinop } : Type. +intros; exact (sigT' ( fun R : eqrel X => admit ) ). +Defined. +Definition binopeqrelpair { X : setwithbinop } := existT' ( fun R : eqrel X => admit ). +Definition pr1binopeqrel ( X : setwithbinop ) : @binopeqrel X -> eqrel X. +intros X; exact ( @projT1' _ ( fun R : eqrel X => admit ) ) . +Defined. +Coercion pr1binopeqrel : binopeqrel >-> eqrel . + +Definition setwithbinopdirprod ( X Y : setwithbinop ) : setwithbinop . +admit. +Defined. + +Definition monoid : Type. +exact ( sigT' ( fun X : setwithbinop => admit ) ). +Defined. +Definition monoidpair := existT' ( fun X : setwithbinop => admit ) . +Definition pr1monoid : monoid -> setwithbinop := @projT1' _ _ . +Coercion pr1monoid : monoid >-> setwithbinop . + +Notation "x + y" := ( op x y ) : addmonoid_scope . + +Definition submonoids { X : monoid } : Type. +admit. +Defined. + +Definition submonoidstosubsetswithbinop ( X : monoid ) : @submonoids X -> @subsetswithbinop X. +admit. +Defined. +Coercion submonoidstosubsetswithbinop : submonoids >-> subsetswithbinop . + +Definition abmonoid : Type. +exact (sigT' ( fun X : setwithbinop => admit ) ). +Defined. + +Definition abmonoidtomonoid : abmonoid -> monoid. +exact (fun X : _ => monoidpair ( projT1' _ X ) admit ). +Defined. +Coercion abmonoidtomonoid : abmonoid >-> monoid . + +Definition subabmonoids { X : abmonoid } := @submonoids X . + +Definition carrierofsubabmonoid { X : abmonoid } ( A : @subabmonoids X ) : abmonoid . +Proof . + intros . + unfold subabmonoids in A . + split with A . + admit. +Defined . + +Coercion carrierofsubabmonoid : subabmonoids >-> abmonoid . + +Definition abmonoiddirprod ( X Y : abmonoid ) : abmonoid . +Proof . + intros . + split with ( setwithbinopdirprod X Y ) . + admit. +Defined . + +Open Scope addmonoid_scope . + +Definition eqrelabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : eqrel ( setwithbinopdirprod X A ). +admit. +Defined. + +Definition binopeqrelabmonoidfrac ( X : abmonoid ) ( A : @subabmonoids X ) : @binopeqrel ( abmonoiddirprod X A ). +intros; exact ( @binopeqrelpair ( setwithbinopdirprod X A ) ( eqrelabmonoidfrac X A ) admit ). +Defined. + +Theorem setquotuniv { X : UU } ( R : hrel X ) ( Y : hSet ) ( f : X -> Y ) ( c : setquot R ) : Y . +Proof. + intros. + apply ( pr1image ( fun x : c => f ( projT1' _ x ) ) ) . + apply ( @hinhuniv ( projT1' _ c ) ( hProppair _ admit ) ( prtoimage ( fun x : c => f ( projT1' _ x ) ) ) ) . + pose ( eqax0 ( projT2' _ c ) ) as h. + simpl in *. + Set Printing Universes. + exact h. +Defined . + +Definition setquotuniv2 { X : UU } ( R : hrel X ) ( Y : hSet ) ( f : X -> X -> Y ) ( is : iscomprelfun2 R f ) ( c c0 : setquot R ) : Y . +Proof. + intros . + set ( RR := hreldirprod R R ) . + apply (setquotuniv RR Y admit). + apply dirprodtosetquot. + apply dirprodpair. + exact c. + exact c0. +Defined . + +Definition setquotfun2 { X Y : UU } ( RX : hrel X ) ( RY : eqrel Y ) ( f : X -> X -> Y ) ( cx cx0 : setquot RX ) : setquot RY . +Proof . + intros . + apply ( setquotuniv2 RX ( setquotinset RY ) admit admit admit admit ) . +Defined . + +Definition quotrel { X : UU } { R : hrel X } : hrel ( setquot R ). +intros; exact ( setquotuniv2 R hPropset admit admit ). +Defined. + +Definition setwithbinopquot { X : setwithbinop } ( R : @binopeqrel X ) : setwithbinop . +Proof . + intros . + split with ( setquotinset R ) . + set ( qtmlt := setquotfun2 R R op ) . + simpl . + unfold binop . + apply qtmlt . +Defined . + +Definition abmonoidquot { X : abmonoid } ( R : @binopeqrel X ) : abmonoid . +Proof . + intros . + split with ( setwithbinopquot R ) . + admit. +Defined . + +Definition abmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : abmonoid. +intros; exact ( @abmonoidquot (abmonoiddirprod X (@carrierofsubabmonoid X A)) ( binopeqrelabmonoidfrac X A ) ). +Defined. + +Definition abmonoidfracrel ( X : abmonoid ) ( A : @submonoids X ) : hrel (@setquot (setwithbinopdirprod X A) (eqrelabmonoidfrac X A)). +intros; exact (@quotrel _ _). +Defined. + +Fail Timeout 1 Axiom ispartlbinopabmonoidfracrel : forall ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( z : abmonoidfrac X A ) , @abmonoidfracrel X A ( ( admit + z ) )admit. + +Definition ispartlbinopabmonoidfracrel_type : Type := + forall ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( z : abmonoidfrac X A ), + @abmonoidfracrel X A ( ( admit + z ) )admit. + +Axiom ispartlbinopabmonoidfracrel : $(let t:= eval unfold ispartlbinopabmonoidfracrel_type in + ispartlbinopabmonoidfracrel_type in exact t)$. + diff --git a/test-suite/bugs/closed/331.v b/test-suite/bugs/closed/331.v new file mode 100644 index 00000000..9ef796fa --- /dev/null +++ b/test-suite/bugs/closed/331.v @@ -0,0 +1,20 @@ +Module Type TIT. + +Inductive X:Set:= + b:X. +End TIT. + + +Module Type TOTO. +Declare Module t:TIT. +Inductive titi:Set:= + a:t.X->titi. +End TOTO. + + +Module toto (ta:TOTO). +Module ti:=ta.t. + +Definition ex1:forall (c d:ti.X), (ta.a d)=(ta.a c) -> d=c. +intros. +injection H. diff --git a/test-suite/bugs/closed/3310.v b/test-suite/bugs/closed/3310.v new file mode 100644 index 00000000..d6c31c6b --- /dev/null +++ b/test-suite/bugs/closed/3310.v @@ -0,0 +1,11 @@ +Set Primitive Projections. +Set Implicit Arguments. + +CoInductive stream A := cons { hd : A; tl : stream A }. + +CoFixpoint id {A} (s : stream A) := cons (hd s) (id (tl s)). + +Lemma id_spec : forall A (s : stream A), id s = s. +Proof. +intros A s. +Fail change (id s) with (cons (hd (id s)) (tl (id s))). diff --git a/test-suite/bugs/closed/3314.v b/test-suite/bugs/closed/3314.v new file mode 100644 index 00000000..64786263 --- /dev/null +++ b/test-suite/bugs/closed/3314.v @@ -0,0 +1,147 @@ +Set Universe Polymorphism. +Definition Lift +: $(let U1 := constr:(Type) in + let U0 := constr:(Type : U1) in + exact (U0 -> U1))$ + := fun T => T. + +Fail Check nat:Prop. (* The command has indeed failed with message: +=> Error: +The term "nat" has type "Set" while it is expected to have type "Prop". *) +Set Printing All. +Set Printing Universes. +Fail Check Lift nat : Prop. (* Lift (* Top.8 Top.9 Top.10 *) nat:Prop + : Prop +(* Top.10 + Top.9 + Top.8 |= Top.10 < Top.9 + Top.9 < Top.8 + Top.9 <= Prop + *) + *) +Fail Eval compute in Lift nat : Prop. +(* = nat + : Prop *) + +Section Hurkens. + + Monomorphic Definition Type2 := Type. + Monomorphic Definition Type1 := Type : Type2. + + (** Assumption of a retract from Type into Prop *) + + Variable down : Type1 -> Prop. + Variable up : Prop -> Type1. + + Hypothesis back : forall A, up (down A) -> A. + + Hypothesis forth : forall A, A -> up (down A). + + Hypothesis backforth : forall (A:Type) (P:A->Type) (a:A), + P (back A (forth A a)) -> P a. + + Hypothesis backforth_r : forall (A:Type) (P:A->Type) (a:A), + P a -> P (back A (forth A a)). + + (** Proof *) + + Definition V : Type1 := forall A:Prop, ((up A -> Prop) -> up A -> Prop) -> up A -> Prop. + Definition U : Type1 := V -> Prop. + + Definition sb (z:V) : V := fun A r a => r (z A r) a. + Definition le (i:U -> Prop) (x:U) : Prop := x (fun A r a => i (fun v => sb v A r a)). + Definition le' (i:up (down U) -> Prop) (x:up (down U)) : Prop := le (fun a:U => i (forth _ a)) (back _ x). + Definition induct (i:U -> Prop) : Type1 := forall x:U, up (le i x) -> up (i x). + Definition WF : U := fun z => down (induct (fun a => z (down U) le' (forth _ a))). + Definition I (x:U) : Prop := + (forall i:U -> Prop, up (le i x) -> up (i (fun v => sb v (down U) le' (forth _ x)))) -> False. + + Lemma Omega : forall i:U -> Prop, induct i -> up (i WF). + Proof. + intros i y. + apply y. + unfold le, WF, induct. + apply forth. + intros x H0. + apply y. + unfold sb, le', le. + compute. + apply backforth_r. + exact H0. + Qed. + + Lemma lemma1 : induct (fun u => down (I u)). + Proof. + unfold induct. + intros x p. + apply forth. + intro q. + generalize (q (fun u => down (I u)) p). + intro r. + apply back in r. + apply r. + intros i j. + unfold le, sb, le', le in j |-. + apply backforth in j. + specialize q with (i := fun y => i (fun v:V => sb v (down U) le' (forth _ y))). + apply q. + exact j. + Qed. + + Lemma lemma2 : (forall i:U -> Prop, induct i -> up (i WF)) -> False. + Proof. + intro x. + generalize (x (fun u => down (I u)) lemma1). + intro r; apply back in r. + apply r. + intros i H0. + apply (x (fun y => i (fun v => sb v (down U) le' (forth _ y)))). + unfold le, WF in H0. + apply back in H0. + exact H0. + Qed. + + Theorem paradox : False. + Proof. + exact (lemma2 Omega). + Qed. + +End Hurkens. + +Definition informative (x : bool) := + match x with + | true => Type + | false => Prop + end. + +Definition depsort (T : Type) (x : bool) : informative x := + match x with + | true => T + | false => True + end. + +(** This definition should fail *) +Definition Box (T : Type1) : Prop := Lift T. + +Definition prop {T : Type1} (t : Box T) : T := t. +Definition wrap {T : Type1} (t : T) : Box T := t. + +Definition down (x : Type1) : Prop := Box x. +Definition up (x : Prop) : Type1 := x. + +Fail Definition back A : up (down A) -> A := @prop A. + +Fail Definition forth (A : Type1) : A -> up (down A) := @wrap A. + +Fail Definition backforth (A:Type1) (P:A->Type) (a:A) : + P (back A (forth A a)) -> P a := fun H => H. + +Fail Definition backforth_r (A:Type1) (P:A->Type) (a:A) : + P a -> P (back A (forth A a)) := fun H => H. + +Theorem pandora : False. + Fail apply (paradox down up back forth backforth backforth_r). + admit. +Qed. + +Print Assumptions pandora. diff --git a/test-suite/bugs/closed/3315.v b/test-suite/bugs/closed/3315.v new file mode 100644 index 00000000..b69097f9 --- /dev/null +++ b/test-suite/bugs/closed/3315.v @@ -0,0 +1,37 @@ +Set Universe Polymorphism. +Set Primitive Projections. +Set Implicit Arguments. +Record sigT {A : Type} (P : A -> Type) := existT { projT1 : A; projT2 : P projT1 }. +Arguments existT {A} _ _ _. +Definition unpack_sigma' {A} {P : A -> Type} (Q : sigT P -> Type) (u : sigT P) : + Q (existT _ (projT1 u) (projT2 u)) -> Q u + := + fun H => + (let (x,p) as u return (Q (existT _ (projT1 u) (projT2 u)) -> Q u) := u in fun x : Q (existT _ _ p) => x) H. (* success *) +Definition unpack_sigma {A} {P : A -> Type} (Q : sigT P -> Type) (u : sigT P) : + Q (existT _ (projT1 u) (projT2 u)) -> Q u + := + fun H => + (let (x,p) as u return (Q (existT _ (projT1 u) (projT2 u)) -> Q u) := u in fun x => x) H. +(* Toplevel input, characters 219-229: +Error: +In environment +A : Type +P : A -> Type +Q : sigT P -> Type +u : sigT P +H : Q {| projT1 := projT1 u; projT2 := projT2 u |} +x : A +p : P x +The term + "fun + x : Q + {| + projT1 := projT1 {| projT1 := x; projT2 := p |}; + projT2 := projT2 {| projT1 := x; projT2 := p |} |} => x" has type + "Q + {| + projT1 := projT1 {| projT1 := x; projT2 := p |}; + projT2 := projT2 {| projT1 := x; projT2 := p |} |} -> +... " +*) diff --git a/test-suite/bugs/closed/3317.v b/test-suite/bugs/closed/3317.v new file mode 100644 index 00000000..8d152894 --- /dev/null +++ b/test-suite/bugs/closed/3317.v @@ -0,0 +1,94 @@ +Set Implicit Arguments. +Module A. + Set Universe Polymorphism. + Set Primitive Projections. + Set Asymmetric Patterns. + Inductive paths {A} (x : A) : A -> Type := idpath : paths x x + where "x = y" := (@paths _ x y) : type_scope. + Record sigT {A : Type} (P : A -> Type) := existT { projT1 : A; projT2 : P projT1 }. + Arguments existT {A} _ _ _. + Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. + Notation "x .1" := (projT1 x) (at level 3). + Notation "x .2" := (projT2 x) (at level 3). + Notation "( x ; y )" := (existT _ x y). + Set Printing All. + Definition path_sigma_uncurried {A : Type} (P : A -> Type) (u v : sigT P) + (pq : sigT (fun p : u.1 = v.1 => transport _ p u.2 = v.2)) + : u = v + := match pq with + | existT p q => + match u, v return (forall p0 : (u.1 = v.1), (transport P p0 u.2 = v.2) -> (u=v)) with + | (x;y), (x';y') => fun p1 (q1 : transport P p1 (existT P x y).2 = (existT P x' y').2) => + match p1 in (_ = x'') return (forall y'', (transport _ p1 y = y'') -> (x;y)=(x'';y'')) with + | idpath => fun y' (q2 : transport _ (@idpath _ _) y = y') => + match q2 in (_ = y'') return (x;y) = (x;y'') with + | idpath => @idpath _ _ + end + end y' q1 + end p q + end. + (* Toplevel input, characters 341-357: +Error: +In environment +A : Type +P : forall _ : A, Type +u : @sigT A P +v : @sigT A P +pq : +@sigT (@paths A (projT1 u) (projT1 v)) + (fun p : @paths A (projT1 u) (projT1 v) => + @paths (P (projT1 v)) (@transport A P (projT1 u) (projT1 v) p (projT2 u)) + (projT2 v)) +p : @paths A (projT1 u) (projT1 v) +q : +@paths (P (projT1 v)) (@transport A P (projT1 u) (projT1 v) p (projT2 u)) + (projT2 v) +x : A +y : P x +x' : A +y' : P x' +p1 : @paths A (projT1 (@existT A P x y)) (projT1 (@existT A P x' y')) +The term "projT2 (@existT A P x y)" has type "P (projT1 (@existT A P x y))" +while it is expected to have type "P (projT1 (@existT A P x y))". + *) +End A. + +Module B. + Set Universe Polymorphism. + Set Primitive Projections. + Set Asymmetric Patterns. + Inductive paths {A} (x : A) : A -> Type := idpath : paths x x + where "x = y" := (@paths _ x y) : type_scope. + Record sigT {A : Type} (P : A -> Type) := existT { projT1 : A; projT2 : P projT1 }. + Arguments existT {A} _ _ _. + Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. + Notation "x .1" := (projT1 x) (at level 3). + Notation "x .2" := (projT2 x) (at level 3). + Notation "( x ; y )" := (existT _ x y). + Set Printing All. + + Definition path_sigma_uncurried {A : Type} (P : A -> Type) (u v : sigT P) + (pq : sigT (fun p : u.1 = v.1 => transport _ p u.2 = v.2)) + : u = v. + Proof. + destruct u as [x y]. + destruct v. (* Toplevel input, characters 0-11: +Error: Illegal application: +The term "transport" of type + "forall (A : Type) (P : forall _ : A, Type) (x y : A) + (_ : @paths A x y) (_ : P x), P y" +cannot be applied to the terms + "A" : "Type" + "P" : "forall _ : A, Type" + "projT1 (@existT A P x y)" : "A" + "projT1 v" : "A" + "p" : "@paths A (projT1 (@existT A P x y)) (projT1 v)" + "projT2 (@existT A P x y)" : "P (projT1 (@existT A P x y))" +The 5th term has type "@paths A (projT1 (@existT A P x y)) (projT1 v)" +which should be coercible to + "@paths A (projT1 (@existT A P x y)) (projT1 v)". + *) + Abort. +End B. diff --git a/test-suite/bugs/closed/3319.v b/test-suite/bugs/closed/3319.v new file mode 100644 index 00000000..bb5853dd --- /dev/null +++ b/test-suite/bugs/closed/3319.v @@ -0,0 +1,25 @@ +(* File reduced by coq-bug-finder from original input, then from 5353 lines to 4545 lines, then from 4513 lines to 4504 lines, then from 4515 lines to 4508 lines, then from 4519 lines to 132 lines, then from 111 lines to 66 lines, then from 68 lines to 35 lines *) +Set Implicit Arguments. +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a + where "x = y" := (@paths _ x y) : type_scope. + +Record PreCategory := { obj :> Type; morphism : obj -> obj -> Type }. +Record NotionOfStructure (X : PreCategory) := + { structure :> X -> Type; + is_structure_homomorphism + : forall x y (f : morphism X x y) (a : structure x) (b : structure y), Type }. + +Section precategory. + Variable X : PreCategory. + Variable P : NotionOfStructure X. + Local Notation object := { x : X & P x }. + Record morphism' (xa yb : object) := {}. + + Lemma issig_morphism xa yb + : { f : morphism X (projT1 xa) (projT1 yb) + & is_structure_homomorphism _ _ _ f (projT2 xa) (projT2 yb) } + = morphism' xa yb. + Proof. + admit. + Defined.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3321.v b/test-suite/bugs/closed/3321.v new file mode 100644 index 00000000..07e3b3cb --- /dev/null +++ b/test-suite/bugs/closed/3321.v @@ -0,0 +1,18 @@ +(* File reduced by coq-bug-finder from original input, then from 5302 lines to 4649 lines, then from 4660 lines to 355 lines, then from 360 lines to 269 lines, then from 269 lines to 175 lines, then from 144 lines to 119 lines, then from 103 lines to 83 lines, then from 86 lines to 36 lines, then from 37 lines to 17 lines *) + +Axiom admit : forall {T}, T. +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { equiv_inv : B -> A ; eisretr : Sect equiv_inv f }. +Record Equiv A B := BuildEquiv { equiv_fun :> A -> B ; equiv_isequiv :> IsEquiv equiv_fun }. +Definition hfiber {A B : Type} (f : A -> B) (y : B) := { x : A & f x = y }. +Definition equiv_path (A B : Type) (p : A = B) : Equiv A B := admit. +Class Univalence := { isequiv_equiv_path :> forall (A B : Type), IsEquiv (equiv_path A B) }. +Definition path_universe `{Univalence} {A B : Type} (f : A -> B) {feq : IsEquiv f} : (A = B) := admit. +Context `{ua:Univalence}. +Variable A:Type. +Goal forall (I : Type) (f : I -> A), + {p : I = {a : A & @hfiber I A f a} & True }. +intros. +clear. +try exists (path_universe admit). (* Toplevel input, characters 15-44: +Anomaly: Uncaught exception Not_found(_). Please report. *) diff --git a/test-suite/bugs/closed/3322.v b/test-suite/bugs/closed/3322.v new file mode 100644 index 00000000..925f22a2 --- /dev/null +++ b/test-suite/bugs/closed/3322.v @@ -0,0 +1,23 @@ +(* File reduced by coq-bug-finder from original input, then from 11971 lines to 11753 lines, then from 7702 lines to 564 lines, then from 571 lines to 61 lines *) +Set Asymmetric Patterns. +Axiom admit : forall {T}, T. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := match p with idpath => u end. +Definition path_sigma_uncurried {A : Type} (P : A -> Type) (u v : sigT P) + (pq : {p : (projT1 u) = (projT1 v) & transport _ p (projT2 u) = (projT2 v)}) +: u = v. +Proof. + destruct pq as [p q], u as [x y], v as [x' y']; simpl in *. + destruct p, q; simpl; reflexivity. +Defined. +Arguments path_sigma_uncurried : simpl never. +Section opposite. + Let opposite_functor_involutive_helper + := @path_sigma_uncurried admit admit (existT _ admit admit) admit (existT _ admit admit). + + Goal True. + Opaque path_sigma_uncurried. + simpl in *. + Transparent path_sigma_uncurried. + (* This command should fail with "Error: Failed to progress.", as it does in 8.4; the simpl never directive should prevent simpl from progressing *) + Fail progress simpl in *. diff --git a/test-suite/bugs/closed/3323.v b/test-suite/bugs/closed/3323.v new file mode 100644 index 00000000..fb5a8a7e --- /dev/null +++ b/test-suite/bugs/closed/3323.v @@ -0,0 +1,77 @@ +(* -*- coq-prog-args: ("-emacs" "-indices-matter") -*- *) +(* File reduced by coq-bug-finder from original input, then from 5302 lines to 4649 lines, then from 4660 lines to 355 lines, then from 360 lines to 269 lines, then from 269 lines to 175 lines, then from 144 lines to 119 lines, then from 297 lines to 117 lines, then from 95 lines to 79 lines, then from 82 lines to 68 lines *) + +Set Universe Polymorphism. +Generalizable All Variables. +Inductive sigT {A:Type} (P:A -> Type) : Type := existT : forall x:A, P x -> sigT P. +Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope. +Definition projT1 {A} {P : A -> Type} (x : sigT P) : A := let (a, _) := x in a. +Definition projT2 {A} {P : A -> Type} (x : sigT P) : P (projT1 x) := let (a, h) return P (projT1 x) := x in h. +Axiom admit : forall {T}, T. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x := match p with idpath => idpath end. +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := match p with idpath => u end. +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { equiv_inv : B -> A ; eisretr : Sect equiv_inv f }. +Record Equiv A B := BuildEquiv { equiv_fun :> A -> B ; equiv_isequiv :> IsEquiv equiv_fun }. +Existing Instance equiv_isequiv. +Global Instance isequiv_inverse `{IsEquiv A B f} : IsEquiv (@equiv_inv _ _ f _) | 10000 := admit. +Definition equiv_path_sigma `(P : A -> Type) (u v : sigT P) +: Equiv {p : projT1 u = projT1 v & transport _ p (projT2 u) = projT2 v} (u = v) := admit. +Definition hfiber {A B : Type} (f : A -> B) (y : B) := { x : A & f x = y }. +Definition path_universe {A B : Type} (f : A -> B) : (A = B) := admit. +Section AssumeFunext. + Let equiv_fibration_replacement_eissect {B C f} + : forall x : {y : B & {x : C & f x = y}}, + existT _ (f (projT1 (projT2 x))) (existT _ (projT1 (projT2 x)) idpath) = x. + admit. + Defined. + Definition equiv_fibration_replacement {B C} (f:C ->B): + Equiv C {y:B & {x:C & f x = y}}. + Proof. + refine (BuildEquiv + _ _ _ + (BuildIsEquiv + C {y:B & {x:C & f x = y}} + (fun c => existT _ (f c) (existT _ c idpath)) + (fun c => projT1 (projT2 c)) + equiv_fibration_replacement_eissect)). + Defined. + Definition equiv_total_paths (A : Type) (P : A-> Type) (x y : sigT P) : + Equiv (x = y) { p : projT1 x = projT1 y & transport P p (projT2 x) = (projT2 y) } + := BuildEquiv _ _ (@equiv_inv _ _ _ (equiv_path_sigma P x y)) _. + Variable A:Type. + Definition Fam A:=sigT (fun I:Type => I->A). + Definition p2f: (A->Type)-> Fam A := fun Q:(A->Type) => existT _ (sigT Q) (@projT1 _ _). + Definition f2p: Fam A -> (A->Type) := fun F => let (I, f) := F in (fun a => (hfiber f a)). + Definition exp {U V:Type}(w:Equiv U V):Equiv (U->A) (V->A). + exists (fun f:(U->A)=> (fun x => (f (@equiv_inv _ _ w _ x)))). + admit. + Defined. + Goal { h : Fam A -> A -> Type & Sect h p2f }. + exists f2p. + intros [I f]. + set (e:=@equiv_total_paths _ _ (@existT Type (fun I0 : Type => I0 -> A) I f) + (existT _ {a : A & hfiber f a} (@projT1 _ _))). + simpl in e. + cut ( {p : I = {a : A & @hfiber I A f a} & + @transport _ (fun I0 : Type => I0 -> A) _ _ p f = @projT1 _ _}). + { intro X. + apply (inverse (@equiv_inv _ _ _ e X)). } + set (w:=@equiv_fibration_replacement A I f). + exists (path_universe w). + assert (forall x, (exp w) f x = projT1 x); [ | admit ]. + intros [a [i p]]. + exact p. + Qed. +(* Toplevel input, characters 15-19: +Error: In pattern-matching on term "x" the branch for constructor +"existT(*Top.256 Top.258*)" has type + "forall (I : Type) (f : I -> A), + existT (fun I0 : Type => I0 -> A) {a : A & hfiber f a} projT1 = + existT (fun I0 : Type => I0 -> A) I f" which should be + "forall (x : Type) (H : x -> A), + p2f (f2p (existT (fun I : Type => I -> A) x H)) = + existT (fun I : Type => I -> A) x H". + *) diff --git a/test-suite/bugs/closed/3324.v b/test-suite/bugs/closed/3324.v new file mode 100644 index 00000000..9cd6e4c2 --- /dev/null +++ b/test-suite/bugs/closed/3324.v @@ -0,0 +1,47 @@ +Module ETassi. + Axiom admit : forall {T}, T. + Class IsHProp (A : Type) : Type := {}. + Class IsHSet (A : Type) : Type := {}. + Record hProp := hp { hproptype :> Type ; isp : IsHProp hproptype}. + Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. + Canonical Structure default_HSet:= fun T P => (@BuildhSet T P). + Global Instance isset_hProp : IsHSet hProp | 0. + + Check (eq_refl _ : setT (default_HSet _ _) = hProp). + Check (eq_refl _ : setT _ = hProp). +End ETassi. + +Module JGross. + (* File reduced by coq-bug-finder from original input, then from 6462 lines to 5760 lines, then from 5761 lines to 181 lines, then from 191 lines to 181 lines, then from 181 lines to 83 lines, then from 87 lines to 27 lines *) + Axiom admit : forall {T}, T. + Class IsHProp (A : Type) : Type := {}. + Class IsHSet (A : Type) : Type := {}. + Inductive Unit : Set := tt. + Record hProp := hp { hproptype :> Type ; isp : IsHProp hproptype}. + Definition Unit_hp:hProp:=(hp Unit admit). + Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. + Canonical Structure default_HSet:= fun T P => (@BuildhSet T P). + Global Instance isset_hProp : IsHSet hProp | 0. + Definition isepi {X Y} `(f:X->Y) := forall Z: hSet, + forall g h: Y -> Z, (fun x => g (f x)) = (fun x => h (f x)) -> g = h. + Lemma isepi_issurj {X Y} (f:X->Y): isepi f -> True. + Proof. + intros epif. + set (g :=fun _:Y => Unit_hp). + pose proof (epif (default_HSet hProp isset_hProp) g). + specialize (epif _ g). + (* Toplevel input, characters 34-35: +Error: +In environment +X : Type +Y : Type +f : X -> Y +epif : isepi f +g := fun _ : Y => Unit_hp : Y -> hProp +H : forall h : Y -> default_HSet hProp isset_hProp, + (fun x : X => g (f x)) = (fun x : X => h (f x)) -> g = h +The term "g" has type "Y -> hProp" while it is expected to have type + "Y -> ?30". + *) + Abort. +End JGross. diff --git a/test-suite/bugs/closed/3325.v b/test-suite/bugs/closed/3325.v new file mode 100644 index 00000000..36c065eb --- /dev/null +++ b/test-suite/bugs/closed/3325.v @@ -0,0 +1,48 @@ +Typeclasses eauto := debug. +Set Printing All. + +Axiom SProp : Set. +Axiom sp : SProp. + +(* If we hardcode valueType := nat, it goes through *) +Class StateIs := { + valueType : Type; + stateIs : valueType -> SProp +}. + +Instance NatStateIs : StateIs := { + valueType := nat; + stateIs := fun _ => sp +}. +Canonical Structure NatStateIs. + +Class LogicOps F := { land: F -> F }. +Instance : LogicOps SProp. Admitted. +Instance : LogicOps Prop. Admitted. + +Parameter (n : nat). +(* If this is a [Definition], the resolution goes through fine. *) +Notation vn := (@stateIs _ n). +Definition vn' := (@stateIs _ n). +Definition GOOD : SProp := + @land _ _ vn'. +(* This doesn't resolve, if PropLogicOps is defined later than SPropLogicOps *) +Definition BAD : SProp := + @land _ _ vn. + + +Class A T := { foo : T -> Prop }. +Instance: A nat. Admitted. +Instance: A Set. Admitted. + +Class B := { U : Type ; b : U }. +Instance bi: B := {| U := nat ; b := 0 |}. +Canonical Structure bi. + +Notation b0N := (@b _ : nat). +Notation b0Ni := (@b bi : nat). +Definition b0D := (@b _ : nat). +Definition GOOD1 := (@foo _ _ b0D). +Definition GOOD2 := (let x := b0N in @foo _ _ x). +Definition GOOD3 := (@foo _ _ b0Ni). +Definition BAD1 := (@foo _ _ b0N). (* Error: The term "b0Ni" has type "nat" while it is expected to have type "Set". *) diff --git a/test-suite/bugs/closed/3326.v b/test-suite/bugs/closed/3326.v new file mode 100644 index 00000000..4d7e9f77 --- /dev/null +++ b/test-suite/bugs/closed/3326.v @@ -0,0 +1,19 @@ +Class ORDER A := Order { + LEQ : A -> A -> bool; + leqRefl: forall x, true = LEQ x x +}. + +Section XXX. + +Variable A:Type. +Variable (O:ORDER A). +Definition aLeqRefl := @leqRefl _ O. + +Lemma OK : forall x, true = LEQ x x. +Proof. + intros. + unfold LEQ. + destruct O. + clear. + Fail apply aLeqRefl. +Abort. diff --git a/test-suite/bugs/closed/3329.v b/test-suite/bugs/closed/3329.v new file mode 100644 index 00000000..f7e368f8 --- /dev/null +++ b/test-suite/bugs/closed/3329.v @@ -0,0 +1,93 @@ +(* File reduced by coq-bug-finder from original input, then from 12095 lines to 869 lines, then from 792 lines to 504 lines, then from 487 lines to 353 lines, then from 258 lines to 174 lines, then from 164 lines to 132 lines, then from 129 lines to 99 lines *) +Set Universe Polymorphism. +Generalizable All Variables. +Axiom admit : forall {T}, T. +Reserved Notation "g 'o' f" (at level 40, left associativity). +Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x). +Notation "g 'o' f" := (compose g f). +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) : Type := forall x:A, f x = g x. +Hint Unfold pointwise_paths : typeclass_instances. +Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g) +: forall x, f x = g x + := fun x => match h with idpath => idpath end. +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { equiv_inv : B -> A }. +Class IsHSet (A : Type) := { _ : False }. +Class Funext := { isequiv_apD10 :> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) }. +Record PreCategory := + { object :> Type; + morphism : object -> object -> Type; + trunc_morphism : forall s d, IsHSet (morphism s d) }. + +Definition trunc_equiv `(f : A -> B) `{IsHSet A} `{IsEquiv A B f} : IsHSet B := admit. +Global Instance trunc_forall `{Funext} `{P : A -> Type} `{forall a, IsHSet (P a)} +: IsHSet (forall a, P a) | 100. +Proof. + generalize dependent P. + intro P. + assert (f : forall a, P a) by admit. + assert (g : forall a, P a) by admit. + pose (@trunc_equiv (forall x : A, @paths (P x) (f x) (g x)) + (@paths (forall x : A, P x) f g) + (@equiv_inv (@paths (forall x : A, P x) f g) + (forall x : A, @paths (P x) (f x) (g x)) + (@apD10 A P f g) (@isequiv_apD10 H A P f g))). + admit. +Defined. +Record Functor (C D : PreCategory) := { object_of :> C -> D }. +Definition identity C : Functor C C := Build_Functor C C admit. +Notation "1" := (identity _) : functor_scope. +Definition functor_category (C D : PreCategory) : PreCategory + := @Build_PreCategory (Functor C D) admit admit. +Notation "C -> D" := (functor_category C D) : category_scope. +Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. +Global Existing Instance iss. +Definition set_cat `{Funext} : PreCategory := + @Build_PreCategory hSet + (fun x y => x -> y) + _. + +Section hom_functor. + Context `{Funext}. + Variable C : PreCategory. + + Local Notation obj_of c'c := + (BuildhSet + (morphism + C + c'c + c'c) + admit). + Let hom_functor_morphism_of s's d'd (hf : morphism C s's d'd) + : morphism set_cat (obj_of s's) (obj_of d'd) + := admit. + + Definition hom_functor : Functor C set_cat := admit. +End hom_functor. +Local Open Scope category_scope. +Local Open Scope functor_scope. +Context `{Funext}. +Variable D : PreCategory. +Set Printing Universes. +Check hom_functor D o 1. +(* Toplevel input, characters 20-44: +Error: Illegal application: +The term "@set_cat" of type "(Funext -> PreCategory)%type" +cannot be applied to the term + "H" : "Funext" +This term has type "Funext" which should be coercible to +"Funext". *) +(* The command has indeed failed with message: +=> Error: Illegal application: +The term "@set_cat@{Top.345 Top.346 Top.331 Top.332 Top.337 Top.338 Top.339}" +of type + "(Funext@{Top.346 Top.346 Top.331 Top.332 Top.346} -> PreCategory@{Top.345 + Top.346})%type" +cannot be applied to the term + "H@{Top.346 Top.330 Top.331 Top.332 Top.333}" + : "Funext@{Top.346 Top.330 Top.331 Top.332 Top.333}" +This term has type "Funext@{Top.346 Top.330 Top.331 Top.332 Top.333}" +which should be coercible to + "Funext@{Top.346 Top.346 Top.331 Top.332 Top.346}". +*) diff --git a/test-suite/bugs/closed/3330.v b/test-suite/bugs/closed/3330.v new file mode 100644 index 00000000..15303cca --- /dev/null +++ b/test-suite/bugs/closed/3330.v @@ -0,0 +1,1110 @@ +(* File reduced by coq-bug-finder from original input, then from 12106 lines to 1070 lines *) +Set Universe Polymorphism. +Definition setleq (A : Type@{i}) (B : Type@{j}) := A : Type@{j}. + +Inductive foo : Type@{l} := bar : foo . +Section MakeEq. + Variables (a : foo@{i}) (b : foo@{j}). + + Let t := $(let ty := type of b in exact ty)$. + Definition make_eq (x:=b) := a : t. +End MakeEq. + +Definition same (x : foo@{i}) (y : foo@{i}) := x. + +Section foo. + + Variables x : foo@{i}. + Variables y : foo@{j}. + + Let AleqB := let foo := make_eq x y in (Type * Type)%type. + + Definition baz := same x y. +End foo. + +Definition baz' := Eval unfold baz in baz@{i j k l}. + +Module Export HoTT_DOT_Overture. +Module Export HoTT. +Module Export Overture. + +Definition relation (A : Type) := A -> A -> Type. +Class Symmetric {A} (R : relation A) := + symmetry : forall x y, R x y -> R y x. + +Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := + fun x => g (f x). + +Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope. + +Open Scope function_scope. + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Arguments idpath {A a} , [A] a. + +Notation "x = y :> A" := (@paths A x y) : type_scope. + +Notation "x = y" := (x = y :>_) : type_scope. + +Delimit Scope path_scope with path. + +Local Open Scope path_scope. + +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := + match p, q with idpath, idpath => idpath end. + +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x + := match p with idpath => idpath end. + +Instance symmetric_paths {A} : Symmetric (@paths A) | 0 := @inverse A. + +Notation "1" := idpath : path_scope. + +Notation "p @ q" := (concat p q) (at level 20) : path_scope. + +Notation "p ^" := (inverse p) (at level 3) : path_scope. + +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. + +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. + +Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) : Type + := forall x:A, f x = g x. + +Hint Unfold pointwise_paths : typeclass_instances. + +Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope. + +Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g) + : f == g + := fun x => match h with idpath => 1 end. + +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := + forall x : A, r (s x) = x. + +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { + equiv_inv : B -> A ; + eisretr : Sect equiv_inv f; + eissect : Sect f equiv_inv; + eisadj : forall x : A, eisretr (f x) = ap f (eissect x) +}. + +Delimit Scope equiv_scope with equiv. + +Local Open Scope equiv_scope. + +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope. + +Class Contr_internal (A : Type) := BuildContr { + center : A ; + contr : (forall y : A, center = y) +}. + +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. + +Fixpoint nat_to_trunc_index (n : nat) : trunc_index + := match n with + | 0 => trunc_S (trunc_S minus_two) + | S n' => trunc_S (nat_to_trunc_index n') + end. + +Coercion nat_to_trunc_index : nat >-> trunc_index. + +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | minus_two => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. + +Class IsTrunc (n : trunc_index) (A : Type) : Type := + Trunc_is_trunc : IsTrunc_internal n A. + +Notation IsHSet := (IsTrunc 0). + +Class Funext := + { isequiv_apD10 :> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) }. + +Definition path_forall `{Funext} {A : Type} {P : A -> Type} (f g : forall x : A, P x) : + f == g -> f = g + := + (@apD10 A P f g)^-1. + +End Overture. + +End HoTT. + +End HoTT_DOT_Overture. + +Module Export HoTT_DOT_categories_DOT_Category_DOT_Core. + +Module Export HoTT. +Module Export categories. +Module Export Category. +Module Export Core. +Set Universe Polymorphism. + +Set Implicit Arguments. +Delimit Scope morphism_scope with morphism. + +Delimit Scope category_scope with category. +Delimit Scope object_scope with object. + +Record PreCategory := + Build_PreCategory' { + object :> Type; + morphism : object -> object -> Type; + + identity : forall x, morphism x x; + compose : forall s d d', + morphism d d' + -> morphism s d + -> morphism s d' + where "f 'o' g" := (compose f g); + + associativity : forall x1 x2 x3 x4 + (m1 : morphism x1 x2) + (m2 : morphism x2 x3) + (m3 : morphism x3 x4), + (m3 o m2) o m1 = m3 o (m2 o m1); + + associativity_sym : forall x1 x2 x3 x4 + (m1 : morphism x1 x2) + (m2 : morphism x2 x3) + (m3 : morphism x3 x4), + m3 o (m2 o m1) = (m3 o m2) o m1; + + left_identity : forall a b (f : morphism a b), identity b o f = f; + right_identity : forall a b (f : morphism a b), f o identity a = f; + + identity_identity : forall x, identity x o identity x = identity x; + + trunc_morphism : forall s d, IsHSet (morphism s d) + }. + +Bind Scope category_scope with PreCategory. + +Arguments identity [!C%category] x%object : rename. +Arguments compose [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename. + +Definition Build_PreCategory + object morphism compose identity + associativity left_identity right_identity + := @Build_PreCategory' + object + morphism + compose + identity + associativity + (fun _ _ _ _ _ _ _ => symmetry _ _ (associativity _ _ _ _ _ _ _)) + left_identity + right_identity + (fun _ => left_identity _ _ _). + +Existing Instance trunc_morphism. + +Hint Resolve @left_identity @right_identity @associativity : category morphism. + +Module Export CategoryCoreNotations. + + Infix "o" := compose : morphism_scope. +End CategoryCoreNotations. +End Core. + +End Category. + +End categories. + +End HoTT. + +End HoTT_DOT_categories_DOT_Category_DOT_Core. + +Module Export HoTT_DOT_types_DOT_Forall. + +Module Export HoTT. +Module Export types. +Module Export Forall. +Generalizable Variables A B f g e n. + +Section AssumeFunext. + +Global Instance trunc_forall `{P : A -> Type} `{forall a, IsTrunc n (P a)} + : IsTrunc n (forall a, P a) | 100. + +admit. +Defined. +End AssumeFunext. + +End Forall. + +End types. + +End HoTT. + +End HoTT_DOT_types_DOT_Forall. + +Module Export HoTT_DOT_types_DOT_Prod. + +Module Export HoTT. +Module Export types. +Module Export Prod. +Local Open Scope path_scope. + +Definition path_prod_uncurried {A B : Type} (z z' : A * B) + (pq : (fst z = fst z') * (snd z = snd z')) + : (z = z') + := match pq with (p,q) => + match z, z' return + (fst z = fst z') -> (snd z = snd z') -> (z = z') with + | (a,b), (a',b') => fun p q => + match p, q with + idpath, idpath => 1 + end + end p q + end. + +Definition path_prod {A B : Type} (z z' : A * B) : + (fst z = fst z') -> (snd z = snd z') -> (z = z') + := fun p q => path_prod_uncurried z z' (p,q). + +Definition path_prod' {A B : Type} {x x' : A} {y y' : B} + : (x = x') -> (y = y') -> ((x,y) = (x',y')) + := fun p q => path_prod (x,y) (x',y') p q. + +End Prod. + +End types. + +End HoTT. + +End HoTT_DOT_types_DOT_Prod. + +Module Export HoTT_DOT_categories_DOT_Functor_DOT_Core. + +Module Export HoTT. +Module Export categories. +Module Export Functor. +Module Export Core. +Set Universe Polymorphism. + +Set Implicit Arguments. +Delimit Scope functor_scope with functor. + +Local Open Scope morphism_scope. + +Section Functor. + + Variable C : PreCategory. + Variable D : PreCategory. + + Record Functor := + { + object_of :> C -> D; + morphism_of : forall s d, morphism C s d + -> morphism D (object_of s) (object_of d); + composition_of : forall s d d' + (m1 : morphism C s d) (m2: morphism C d d'), + morphism_of _ _ (m2 o m1) + = (morphism_of _ _ m2) o (morphism_of _ _ m1); + identity_of : forall x, morphism_of _ _ (identity x) + = identity (object_of x) + }. + +End Functor. +Bind Scope functor_scope with Functor. + +Arguments morphism_of [C%category] [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch. +Module Export FunctorCoreNotations. + + Notation "F '_1' m" := (morphism_of F m) (at level 10, no associativity) : morphism_scope. +End FunctorCoreNotations. +End Core. + +End Functor. + +End categories. + +End HoTT. + +End HoTT_DOT_categories_DOT_Functor_DOT_Core. + +Module Export HoTT_DOT_categories_DOT_Category_DOT_Morphisms. + +Module Export HoTT. +Module Export categories. +Module Export Category. +Module Export Morphisms. +Set Universe Polymorphism. + +Local Open Scope morphism_scope. + +Class IsIsomorphism {C : PreCategory} {s d} (m : morphism C s d) := + { + morphism_inverse : morphism C d s; + left_inverse : morphism_inverse o m = identity _; + right_inverse : m o morphism_inverse = identity _ + }. + +Class Isomorphic {C : PreCategory} s d := + { + morphism_isomorphic :> morphism C s d; + isisomorphism_isomorphic :> IsIsomorphism morphism_isomorphic + }. + +Module Export CategoryMorphismsNotations. + + Infix "<~=~>" := Isomorphic (at level 70, no associativity) : category_scope. + +End CategoryMorphismsNotations. +End Morphisms. + +End Category. + +End categories. + +End HoTT. + +End HoTT_DOT_categories_DOT_Category_DOT_Morphisms. + +Module Export HoTT_DOT_categories_DOT_Category_DOT_Dual. + +Module Export HoTT. +Module Export categories. +Module Export Category. +Module Export Dual. +Set Universe Polymorphism. + +Local Open Scope morphism_scope. + +Section opposite. + + Definition opposite (C : PreCategory) : PreCategory + := @Build_PreCategory' + C + (fun s d => morphism C d s) + (identity (C := C)) + (fun _ _ _ m1 m2 => m2 o m1) + (fun _ _ _ _ _ _ _ => @associativity_sym _ _ _ _ _ _ _ _) + (fun _ _ _ _ _ _ _ => @associativity _ _ _ _ _ _ _ _) + (fun _ _ => @right_identity _ _ _) + (fun _ _ => @left_identity _ _ _) + (@identity_identity C) + _. +End opposite. + +Module Export CategoryDualNotations. + + Notation "C ^op" := (opposite C) (at level 3) : category_scope. +End CategoryDualNotations. +End Dual. + +End Category. + +End categories. + +End HoTT. + +End HoTT_DOT_categories_DOT_Category_DOT_Dual. + +Module Export HoTT_DOT_categories_DOT_Functor_DOT_Composition_DOT_Core. + +Module Export HoTT. +Module Export categories. +Module Export Functor. +Module Export Composition. +Module Export Core. +Set Universe Polymorphism. + +Set Implicit Arguments. +Local Open Scope morphism_scope. + +Section composition. + + Variable C : PreCategory. + Variable D : PreCategory. + Variable E : PreCategory. + Variable G : Functor D E. + Variable F : Functor C D. + + Local Notation c_object_of c := (G (F c)) (only parsing). + + Local Notation c_morphism_of m := (morphism_of G (morphism_of F m)) (only parsing). + + Let compose_composition_of' s d d' + (m1 : morphism C s d) (m2 : morphism C d d') + : c_morphism_of (m2 o m1) = c_morphism_of m2 o c_morphism_of m1. +admit. +Defined. + Definition compose_composition_of s d d' m1 m2 + := Eval cbv beta iota zeta delta + [compose_composition_of'] in + @compose_composition_of' s d d' m1 m2. + Let compose_identity_of' x + : c_morphism_of (identity x) = identity (c_object_of x). + +admit. +Defined. + Definition compose_identity_of x + := Eval cbv beta iota zeta delta + [compose_identity_of'] in + @compose_identity_of' x. + Definition compose : Functor C E + := Build_Functor + C E + (fun c => G (F c)) + (fun _ _ m => morphism_of G (morphism_of F m)) + compose_composition_of + compose_identity_of. + +End composition. +Module Export FunctorCompositionCoreNotations. + + Infix "o" := compose : functor_scope. +End FunctorCompositionCoreNotations. +End Core. + +End Composition. + +End Functor. + +End categories. + +End HoTT. + +End HoTT_DOT_categories_DOT_Functor_DOT_Composition_DOT_Core. + +Module Export HoTT_DOT_categories_DOT_Functor_DOT_Dual. + +Module Export HoTT. +Module Export categories. +Module Export Functor. +Module Export Dual. +Set Universe Polymorphism. + +Set Implicit Arguments. + +Section opposite. + + Variable C : PreCategory. + Variable D : PreCategory. + Definition opposite (F : Functor C D) : Functor C^op D^op + := Build_Functor (C^op) (D^op) + (object_of F) + (fun s d => morphism_of F (s := d) (d := s)) + (fun d' d s m1 m2 => composition_of F s d d' m2 m1) + (identity_of F). + +End opposite. +Module Export FunctorDualNotations. + + Notation "F ^op" := (opposite F) : functor_scope. +End FunctorDualNotations. +End Dual. + +End Functor. + +End categories. + +End HoTT. + +End HoTT_DOT_categories_DOT_Functor_DOT_Dual. + +Module Export HoTT_DOT_categories_DOT_Functor_DOT_Identity. + +Module Export HoTT. +Module Export categories. +Module Export Functor. +Module Export Identity. +Set Universe Polymorphism. + +Section identity. + + Definition identity C : Functor C C + := Build_Functor C C + (fun x => x) + (fun _ _ x => x) + (fun _ _ _ _ _ => idpath) + (fun _ => idpath). +End identity. +Module Export FunctorIdentityNotations. + + Notation "1" := (identity _) : functor_scope. +End FunctorIdentityNotations. +End Identity. + +End Functor. + +End categories. + +End HoTT. + +End HoTT_DOT_categories_DOT_Functor_DOT_Identity. + +Module Export HoTT_DOT_categories_DOT_NaturalTransformation_DOT_Core. + +Module Export HoTT. +Module Export categories. +Module Export NaturalTransformation. +Module Export Core. +Set Universe Polymorphism. + +Set Implicit Arguments. +Local Open Scope morphism_scope. + +Section NaturalTransformation. + + Variable C : PreCategory. + Variable D : PreCategory. + Variables F G : Functor C D. + + Record NaturalTransformation := + Build_NaturalTransformation' { + components_of :> forall c, morphism D (F c) (G c); + commutes : forall s d (m : morphism C s d), + components_of d o F _1 m = G _1 m o components_of s; + + commutes_sym : forall s d (m : C.(morphism) s d), + G _1 m o components_of s = components_of d o F _1 m + }. + +End NaturalTransformation. +End Core. + +End NaturalTransformation. + +End categories. + +End HoTT. + +End HoTT_DOT_categories_DOT_NaturalTransformation_DOT_Core. + +Module Export HoTT_DOT_categories_DOT_NaturalTransformation_DOT_Dual. + +Module Export HoTT. +Module Export categories. +Module Export NaturalTransformation. +Module Export Dual. +Set Universe Polymorphism. + +Section opposite. + + Variable C : PreCategory. + Variable D : PreCategory. + + Definition opposite + (F G : Functor C D) + (T : NaturalTransformation F G) + : NaturalTransformation G^op F^op + := Build_NaturalTransformation' (G^op) (F^op) + (components_of T) + (fun s d => commutes_sym T d s) + (fun s d => commutes T d s). + +End opposite. + +End Dual. + +End NaturalTransformation. + +End categories. + +End HoTT. + +End HoTT_DOT_categories_DOT_NaturalTransformation_DOT_Dual. + +Module Export HoTT_DOT_categories_DOT_Category_DOT_Strict. + +Module Export HoTT. +Module Export categories. +Module Export Category. +Module Export Strict. + +Export Category.Core. +Set Universe Polymorphism. + +End Strict. + +End Category. + +End categories. + +End HoTT. + +End HoTT_DOT_categories_DOT_Category_DOT_Strict. + +Module Export HoTT. +Module Export categories. +Module Export Category. +Module Export Prod. +Set Universe Polymorphism. + +Local Open Scope morphism_scope. + +Section prod. + + Variable C : PreCategory. + Variable D : PreCategory. + Definition prod : PreCategory. + + refine (@Build_PreCategory + (C * D)%type + (fun s d => (morphism C (fst s) (fst d) + * morphism D (snd s) (snd d))%type) + (fun x => (identity (fst x), identity (snd x))) + (fun s d d' m2 m1 => (fst m2 o fst m1, snd m2 o snd m1)) + _ + _ + _ + _); admit. + Defined. +End prod. +Module Export CategoryProdNotations. + + Infix "*" := prod : category_scope. +End CategoryProdNotations. +End Prod. + +End Category. + +End categories. + +End HoTT. + +Module Functor. +Module Export Prod. +Set Universe Polymorphism. + +Set Implicit Arguments. +Local Open Scope morphism_scope. + +Section proj. + + Context {C : PreCategory}. + Context {D : PreCategory}. + Definition fst : Functor (C * D) C + := Build_Functor (C * D) C + (@fst _ _) + (fun _ _ => @fst _ _) + (fun _ _ _ _ _ => idpath) + (fun _ => idpath). + + Definition snd : Functor (C * D) D + := Build_Functor (C * D) D + (@snd _ _) + (fun _ _ => @snd _ _) + (fun _ _ _ _ _ => idpath) + (fun _ => idpath). + +End proj. + +Section prod. + + Variable C : PreCategory. + Variable D : PreCategory. + Variable D' : PreCategory. + Definition prod (F : Functor C D) (F' : Functor C D') + : Functor C (D * D') + := Build_Functor + C (D * D') + (fun c => (F c, F' c)) + (fun s d m => (F _1 m, F' _1 m)) + (fun _ _ _ _ _ => path_prod' (composition_of F _ _ _ _ _) + (composition_of F' _ _ _ _ _)) + (fun _ => path_prod' (identity_of F _) (identity_of F' _)). + +End prod. +Local Infix "*" := prod : functor_scope. + +Section pair. + + Variable C : PreCategory. + Variable D : PreCategory. + Variable C' : PreCategory. + Variable D' : PreCategory. + Variable F : Functor C D. + Variable F' : Functor C' D'. + Definition pair : Functor (C * C') (D * D') + := (F o fst) * (F' o snd). + +End pair. + +Module Export FunctorProdNotations. + + Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : functor_scope. +End FunctorProdNotations. +End Prod. + +End Functor. + +Module Export HoTT_DOT_categories_DOT_NaturalTransformation_DOT_Composition_DOT_Core. + +Module Export HoTT. +Module categories. +Module Export NaturalTransformation. +Module Export Composition. +Module Export Core. +Set Universe Polymorphism. + +Set Implicit Arguments. +Local Open Scope path_scope. + +Local Open Scope morphism_scope. + +Section composition. + + Section compose. + Variable C : PreCategory. + Variable D : PreCategory. + Variables F F' F'' : Functor C D. + Variable T' : NaturalTransformation F' F''. + + Variable T : NaturalTransformation F F'. + Local Notation CO c := (T' c o T c). + + Definition compose_commutes s d (m : morphism C s d) + : CO d o morphism_of F m = morphism_of F'' m o CO s + := (associativity _ _ _ _ _ _ _ _) + @ ap (fun x => _ o x) (commutes T _ _ m) + @ (associativity_sym _ _ _ _ _ _ _ _) + @ ap (fun x => x o _) (commutes T' _ _ m) + @ (associativity _ _ _ _ _ _ _ _). + + Definition compose_commutes_sym s d (m : morphism C s d) + : morphism_of F'' m o CO s = CO d o morphism_of F m + := (associativity_sym _ _ _ _ _ _ _ _) + @ ap (fun x => x o _) (commutes_sym T' _ _ m) + @ (associativity _ _ _ _ _ _ _ _) + @ ap (fun x => _ o x) (commutes_sym T _ _ m) + @ (associativity_sym _ _ _ _ _ _ _ _). + + Definition compose + : NaturalTransformation F F'' + := Build_NaturalTransformation' F F'' + (fun c => CO c) + compose_commutes + compose_commutes_sym. + + End compose. + End composition. +Module Export NaturalTransformationCompositionCoreNotations. + + Infix "o" := compose : natural_transformation_scope. +End NaturalTransformationCompositionCoreNotations. +End Core. + +End Composition. + +End NaturalTransformation. + +End categories. + +Set Universe Polymorphism. + +Section path_natural_transformation. + + Context `{Funext}. + Variable C : PreCategory. + + Variable D : PreCategory. + Variables F G : Functor C D. + + Global Instance trunc_natural_transformation + : IsHSet (NaturalTransformation F G). + +admit. +Defined. + Section path. + + Variables T U : NaturalTransformation F G. + + Lemma path'_natural_transformation + : components_of T = components_of U + -> T = U. + +admit. +Defined. + Lemma path_natural_transformation + : components_of T == components_of U + -> T = U. + + Proof. + intros. + apply path'_natural_transformation. + apply path_forall; assumption. + Qed. + End path. +End path_natural_transformation. + +Ltac path_natural_transformation := + repeat match goal with + | _ => intro + | _ => apply path_natural_transformation; simpl + end. + +Module Export Identity. +Set Universe Polymorphism. + +Set Implicit Arguments. +Local Open Scope morphism_scope. + +Local Open Scope path_scope. +Section identity. + + Variable C : PreCategory. + Variable D : PreCategory. + + Section generalized. + + Variables F G : Functor C D. + Hypothesis HO : object_of F = object_of G. + Hypothesis HM : transport (fun GO => forall s d, + morphism C s d + -> morphism D (GO s) (GO d)) + HO + (morphism_of F) + = morphism_of G. + Local Notation CO c := (transport (fun GO => morphism D (F c) (GO c)) + HO + (identity (F c))). + + Definition generalized_identity_commutes s d (m : morphism C s d) + : CO d o morphism_of F m = morphism_of G m o CO s. + + Proof. + case HM. +case HO. + exact (left_identity _ _ _ _ @ (right_identity _ _ _ _)^). + Defined. + Definition generalized_identity_commutes_sym s d (m : morphism C s d) + : morphism_of G m o CO s = CO d o morphism_of F m. + +admit. +Defined. + Definition generalized_identity + : NaturalTransformation F G + := Build_NaturalTransformation' + F G + (fun c => CO c) + generalized_identity_commutes + generalized_identity_commutes_sym. + + End generalized. + Definition identity (F : Functor C D) + : NaturalTransformation F F + := Eval simpl in @generalized_identity F F 1 1. + +End identity. +Module Export NaturalTransformationIdentityNotations. + + Notation "1" := (identity _) : natural_transformation_scope. +End NaturalTransformationIdentityNotations. +End Identity. + +Module Export Laws. +Import HoTT_DOT_categories_DOT_NaturalTransformation_DOT_Composition_DOT_Core.HoTT.categories. +Set Universe Polymorphism. + +Local Open Scope natural_transformation_scope. +Section natural_transformation_identity. + + Context `{fs : Funext}. + Variable C : PreCategory. + + Variable D : PreCategory. + + Lemma left_identity (F F' : Functor C D) + (T : NaturalTransformation F F') + : 1 o T = T. + + Proof. + path_natural_transformation; auto with morphism. + Qed. + + Lemma right_identity (F F' : Functor C D) + (T : NaturalTransformation F F') + : T o 1 = T. + + Proof. + path_natural_transformation; auto with morphism. + Qed. +End natural_transformation_identity. +Section associativity. + + Section nt. + + Context `{fs : Funext}. + Definition associativity + C D F G H I + (V : @NaturalTransformation C D F G) + (U : @NaturalTransformation C D G H) + (T : @NaturalTransformation C D H I) + : (T o U) o V = T o (U o V). + + Proof. + path_natural_transformation. + apply associativity. + Qed. + End nt. +End associativity. +End Laws. + +Module Export FunctorCategory. +Module Export Core. +Import HoTT_DOT_categories_DOT_NaturalTransformation_DOT_Composition_DOT_Core.HoTT.categories. +Set Universe Polymorphism. + +Section functor_category. + + Context `{Funext}. + Variable C : PreCategory. + + Variable D : PreCategory. + + Definition functor_category : PreCategory + := @Build_PreCategory (Functor C D) + (@NaturalTransformation C D) + (@identity C D) + (@compose C D) + (@associativity _ C D) + (@left_identity _ C D) + (@right_identity _ C D) + _. + +End functor_category. +Module Export FunctorCategoryCoreNotations. + + Notation "C -> D" := (functor_category C D) : category_scope. +End FunctorCategoryCoreNotations. +End Core. + +End FunctorCategory. + +Module Export Morphisms. +Set Universe Polymorphism. + +Set Implicit Arguments. + +Definition NaturalIsomorphism `{Funext} (C D : PreCategory) F G := + @Isomorphic (C -> D) F G. + +Module Export FunctorCategoryMorphismsNotations. + + Infix "<~=~>" := NaturalIsomorphism : natural_transformation_scope. +End FunctorCategoryMorphismsNotations. +End Morphisms. + +Module Export HSet. +Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. + +Global Existing Instance iss. +End HSet. + +Module Export Core. +Set Universe Polymorphism. + +Notation cat_of obj := + (@Build_PreCategory obj + (fun x y => x -> y) + (fun _ x => x) + (fun _ _ _ f g => f o g)%core + (fun _ _ _ _ _ _ _ => idpath) + (fun _ _ _ => idpath) + (fun _ _ _ => idpath) + _). + +Definition set_cat `{Funext} : PreCategory := cat_of hSet. +Set Universe Polymorphism. + +Local Open Scope morphism_scope. + +Section hom_functor. + + Context `{Funext}. + Variable C : PreCategory. + Local Notation obj_of c'c := + (BuildhSet + (morphism + C + (fst (c'c : object (C^op * C))) + (snd (c'c : object (C^op * C)))) + _). + + Let hom_functor_morphism_of s's d'd (hf : morphism (C^op * C) s's d'd) + : morphism set_cat (obj_of s's) (obj_of d'd) + := fun g => snd hf o g o fst hf. + + Definition hom_functor : Functor (C^op * C) set_cat. + + refine (Build_Functor (C^op * C) set_cat + (fun c'c => obj_of c'c) + hom_functor_morphism_of + _ + _); + subst hom_functor_morphism_of; + simpl; admit. + Defined. +End hom_functor. +Set Universe Polymorphism. + +Import Category.Dual Functor.Dual. +Import Category.Prod Functor.Prod. +Import Functor.Composition.Core. +Import Functor.Identity. +Set Universe Polymorphism. + +Local Open Scope functor_scope. +Local Open Scope natural_transformation_scope. +Section Adjunction. + + Context `{Funext}. + Variable C : PreCategory. + Variable D : PreCategory. + Variable F : Functor C D. + Variable G : Functor D C. + + Let Adjunction_Type := + Eval simpl in (hom_functor D) o (F^op, 1) <~=~> (hom_functor C) o (1, G). + + Record AdjunctionHom := + { + mate_of : + @NaturalIsomorphism H + (Prod.prod (Category.Dual.opposite C) D) + (@set_cat H) + (@compose (Prod.prod (Category.Dual.opposite C) D) + (Prod.prod (Category.Dual.opposite D) D) + (@set_cat H) (@hom_functor H D) + (@pair (Category.Dual.opposite C) + (Category.Dual.opposite D) D D + (@opposite C D F) (identity D))) + (@compose (Prod.prod (Category.Dual.opposite C) D) + (Prod.prod (Category.Dual.opposite C) C) + (@set_cat H) (@hom_functor H C) + (@pair (Category.Dual.opposite C) + (Category.Dual.opposite C) D C + (identity (Category.Dual.opposite C)) G)) + }. +End Adjunction. +(* Error: Illegal application: +The term "NaturalIsomorphism" of type + "forall (H : Funext) (C D : PreCategory), + (C -> D)%category -> (C -> D)%category -> Type" +cannot be applied to the terms + "H" : "Funext" + "(C ^op * D)%category" : "PreCategory" + "set_cat" : "PreCategory" + "hom_functor D o (F ^op, 1)" : "Functor (C ^op * D) set_cat" + "hom_functor C o (1, G)" : "Functor (C ^op * D) set_cat" +The 5th term has type "Functor (C ^op * D) set_cat" +which should be coercible to "object (C ^op * D -> set_cat)". +*) +End Core. + +End HoTT. + +End HoTT_DOT_categories_DOT_NaturalTransformation_DOT_Composition_DOT_Core. diff --git a/test-suite/bugs/closed/3331.v b/test-suite/bugs/closed/3331.v new file mode 100644 index 00000000..9cd44bd0 --- /dev/null +++ b/test-suite/bugs/closed/3331.v @@ -0,0 +1,31 @@ +(* File reduced by coq-bug-finder from original input, then from 6303 lines to 66 lines, then from 63 lines to 36 lines *) +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y :> A" := (@paths A x y) : type_scope. +Arguments idpath {A a} , [A] a. +Notation "x = y" := (x = y :>_) : type_scope. +Class Contr_internal (A : Type) := BuildContr { center : A ; contr : (forall y : A, center = y) }. +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | minus_two => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. +Class IsTrunc (n : trunc_index) (A : Type) : Type := Trunc_is_trunc : IsTrunc_internal n A. +Instance istrunc_paths (A : Type) n `{H : IsTrunc (trunc_S n) A} (x y : A) : IsTrunc n (x = y) := H x y. +Notation Contr := (IsTrunc minus_two). +Section groupoid_category. + Variable X : Type. + Context `{H : IsTrunc (trunc_S (trunc_S (trunc_S minus_two))) X}. + Goal X -> True. + intro d. + pose (_ : Contr (idpath = idpath :> (@paths (@paths X d d) idpath idpath))) as H'. (* success *) + clear H'. + compute in H. + change (forall (x y : X) (p q : x = y) (r s : p = q), Contr (r = s)) in H. + assert (H' := H). + set (foo:=_ : Contr (idpath = idpath :> (@paths (@paths X d d) idpath idpath))). (* success *) + clear H' foo. + Set Typeclasses Debug. + pose (_ : Contr (idpath = idpath :> (@paths (@paths X d d) idpath idpath))). +Abort.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3332.v b/test-suite/bugs/closed/3332.v new file mode 100644 index 00000000..d86470cd --- /dev/null +++ b/test-suite/bugs/closed/3332.v @@ -0,0 +1,6 @@ +(* -*- coq-prog-args: ("-emacs" "-time") -*- *) +Definition foo : True. +Proof. +Abort. (* Toplevel input, characters 15-21: +Anomaly: Backtrack.backto to a state with no vcs_backup. Please report. *) +(* Anomaly: VernacAbort not handled by Stm. Please report. *) diff --git a/test-suite/bugs/closed/3336.v b/test-suite/bugs/closed/3336.v new file mode 100644 index 00000000..dc358c60 --- /dev/null +++ b/test-suite/bugs/closed/3336.v @@ -0,0 +1,9 @@ +Require Import Setoid. + +Goal forall x y : Type, x = y -> x = y. +intros x y H. +setoid_rewrite H. +reflexivity. +Defined. +(* Toplevel input, characters 0-16: +Anomaly: Uncaught exception Reduction.NotConvertible(_). Please report. *) diff --git a/test-suite/bugs/closed/3337.v b/test-suite/bugs/closed/3337.v new file mode 100644 index 00000000..cd7891f1 --- /dev/null +++ b/test-suite/bugs/closed/3337.v @@ -0,0 +1,4 @@ +Require Import Setoid. +Goal forall x y : Set, x = y -> x = y. +intros x y H. +rewrite_strat subterms H. diff --git a/test-suite/bugs/closed/3338.v b/test-suite/bugs/closed/3338.v new file mode 100644 index 00000000..076cd5e6 --- /dev/null +++ b/test-suite/bugs/closed/3338.v @@ -0,0 +1,4 @@ +Require Import Setoid. +Goal forall x y : Set, x = y -> y = y. +intros x y H. +rewrite_strat try topdown terms H. diff --git a/test-suite/bugs/closed/3344.v b/test-suite/bugs/closed/3344.v new file mode 100644 index 00000000..8255fd6c --- /dev/null +++ b/test-suite/bugs/closed/3344.v @@ -0,0 +1,58 @@ +(* File reduced by coq-bug-finder from original input, then from 716 lines to 197 lines, then from 206 lines to 162 lines, then from 163 lines to 73 lines *) +Require Import Coq.Sets.Ensembles. +Require Import Coq.Strings.String. +Global Set Implicit Arguments. +Global Set Asymmetric Patterns. +Ltac clearbodies := repeat match goal with | [ H := _ |- _ ] => clearbody H end. + +Inductive Comp : Type -> Type := +| Return : forall A, A -> Comp A +| Bind : forall A B, Comp A -> (A -> Comp B) -> Comp B. +Inductive computes_to : forall A, Comp A -> A -> Prop := +| ReturnComputes : forall A v, @computes_to A (Return v) v +| BindComputes : forall A B comp_a f comp_a_value comp_b_value, + @computes_to A comp_a comp_a_value + -> @computes_to B (f comp_a_value) comp_b_value + -> @computes_to B (Bind comp_a f) comp_b_value. + +Inductive is_computational : forall A, Comp A -> Prop := +| Return_is_computational : forall A (x : A), is_computational (Return x) +| Bind_is_computational : forall A B (cA : Comp A) (f : A -> Comp B), + is_computational cA + -> (forall a, + @computes_to _ cA a -> is_computational (f a)) + -> is_computational (Bind cA f). +Theorem is_computational_inv A (c : Comp A) +: is_computational c + -> match c with + | Return _ _ => True + | Bind _ _ x f => is_computational x + /\ forall v, computes_to x v + -> is_computational (f v) + end. + admit. +Defined. +Fixpoint is_computational_unique_val A (c : Comp A) {struct c} +: is_computational c -> { a | unique (computes_to c) a }. +Proof. + refine match c as c return is_computational c -> { a | unique (computes_to c) a } with + | Return T x => fun _ => exist (unique (computes_to (Return x))) + x + _ + | Bind _ _ x f + => fun H + => let H' := is_computational_inv H in + let xv := @is_computational_unique_val _ _ (proj1 H') in + let fxv := @is_computational_unique_val _ _ (proj2 H' _ (proj1 (proj2_sig xv))) in + exist (unique (computes_to _)) + (proj1_sig fxv) + _ + end; + clearbodies; + clear is_computational_unique_val; + clear; + first [ abstract admit + | abstract admit ]. +(* [Fail] does not catch the anomaly *) +Defined. +(* Anomaly: Uncaught exception Not_found(_). Please report. *) diff --git a/test-suite/bugs/closed/3346.v b/test-suite/bugs/closed/3346.v new file mode 100644 index 00000000..638404f2 --- /dev/null +++ b/test-suite/bugs/closed/3346.v @@ -0,0 +1,4 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) +Monomorphic Inductive paths (A : Type) (a : A) : A -> Type := idpath : paths A a a. +(* This should fail with -indices-matter *) +Fail Check paths nat O O : Prop. diff --git a/test-suite/bugs/closed/3347.v b/test-suite/bugs/closed/3347.v new file mode 100644 index 00000000..37c0d87e --- /dev/null +++ b/test-suite/bugs/closed/3347.v @@ -0,0 +1,39 @@ +(* File reduced by coq-bug-finder from original input, then from 12653 lines to 12453 lines, then from 11673 lines to 681 lines, then from 693 lines to 469 lines, then from 375 lines to 56 lines *) +Set Universe Polymorphism. +Notation Type1 := $(let U := constr:(Type) in let gt := constr:(Set : U) in exact U)$ (only parsing). +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Inductive Unit : Type1 := tt : Unit. +Fail Check Unit : Set. (* [Check Unit : Set] should fail if [Type1] is defined correctly *) +Record PreCategory := { object :> Type ; morphism : object -> object -> Type }. +Record Functor (C D : PreCategory) := { object_of :> C -> D }. +Definition indiscrete_category X : PreCategory := @Build_PreCategory X (fun _ _ => Unit). +Definition from_terminal (C : PreCategory) one (c : C) := Build_Functor one C (fun _ => c). +Local Notation "! x" := (from_terminal _ (indiscrete_category Unit) x) (at level 3). +Record NaturalTransformation {C D} (F G : Functor C D) := + { components_of :> forall c, morphism D (F c) (G c); + commutes : forall c, components_of c = components_of c }. +Definition slice_category_induced_functor_nt (D : PreCategory) s d (m : morphism D s d) +: NaturalTransformation !s !d. +Proof. + exists (fun _ : Unit => m); + simpl; intros; clear; + abstract admit. +Defined. +(* Toplevel input, characters 15-23: +Error: Illegal application: +The term "Build_NaturalTransformation" of type + "forall (C D : PreCategory) (F G : Functor C D) + (components_of : forall c : C, morphism D (F c) (G c)), + (forall c : C, components_of c = components_of c) -> + NaturalTransformation F G" +cannot be applied to the terms + "indiscrete_category Unit" : "PreCategory" + "D" : "PreCategory" + "! s" : "Functor (indiscrete_category Unit) D" + "! d" : "Functor (indiscrete_category Unit) D" + "fun _ : Unit => m" : "Unit -> morphism D s d" + "fun _ : Unit => slice_category_induced_functor_nt_subproof D s d m" + : "forall c : indiscrete_category Unit, m = m" +The 5th term has type "Unit -> morphism D s d" which should be coercible to + "forall c : indiscrete_category Unit, morphism D (! s c) (! d c)". + *) diff --git a/test-suite/bugs/closed/3348.v b/test-suite/bugs/closed/3348.v new file mode 100644 index 00000000..d9ac09d8 --- /dev/null +++ b/test-suite/bugs/closed/3348.v @@ -0,0 +1,6 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) +Set Universe Polymorphism. +Set Printing Universes. +Inductive Empty : Set := . +(* Toplevel input, characters 15-41: +Error: Universe inconsistency. Cannot enforce Prop <= Set). *) diff --git a/test-suite/bugs/closed/shouldsucceed/335.v b/test-suite/bugs/closed/335.v index 166fa7a9..166fa7a9 100644 --- a/test-suite/bugs/closed/shouldsucceed/335.v +++ b/test-suite/bugs/closed/335.v diff --git a/test-suite/bugs/closed/3350.v b/test-suite/bugs/closed/3350.v new file mode 100644 index 00000000..30fdf169 --- /dev/null +++ b/test-suite/bugs/closed/3350.v @@ -0,0 +1,120 @@ +Require Coq.Vectors.Fin. +Require Coq.Vectors.Vector. + +Local Generalizable All Variables. +Set Implicit Arguments. + +Arguments Fin.F1 : clear implicits. + +Lemma fin_0_absurd : notT (Fin.t 0). +Proof. hnf. apply Fin.case0. Qed. + +Axiom admit : forall {A}, A. + +Fixpoint lower {n:nat} (p:Fin.t (S n)) {struct p} : + forall (i:Fin.t (S n)), option (Fin.t n) + := match p in Fin.t (S n1) + return Fin.t (S n1) -> option (Fin.t n1) + with + | @Fin.F1 n1 => + fun (i:Fin.t (S n1)) => + match i in Fin.t (S n2) return option (Fin.t n2) with + | @Fin.F1 n2 => None + | @Fin.FS n2 i2 => Some i2 + end + | @Fin.FS n1 p1 => + fun (i:Fin.t (S n1)) => + match i in Fin.t (S n2) return Fin.t n2 -> option (Fin.t n2) with + | @Fin.F1 n2 => + match n2 as n3 return Fin.t n3 -> option (Fin.t n3) with + | 0 => fun p2 => False_rect _ (fin_0_absurd p2) + | S n3 => fun p2 => Some (Fin.F1 n3) + end + | @Fin.FS n2 i2 => + match n2 as n3 return Fin.t n3 -> Fin.t n3 -> option (Fin.t n3) with + | 0 => fun i3 p3 => False_rect _ (fin_0_absurd p3) + | S n3 => fun (i3 p3:Fin.t (S n3)) => + option_map (@Fin.FS _) admit + end i2 + end p1 + end. + +Lemma lower_ind (P: forall n (p i:Fin.t (S n)), option (Fin.t n) -> Prop) + (c11 : forall n, P n (Fin.F1 n) (Fin.F1 n) None) + (c1S : forall n (i:Fin.t n), P n (Fin.F1 n) (Fin.FS i) (Some i)) + (cS1 : forall n (p:Fin.t (S n)), + P (S n) (Fin.FS p) (Fin.F1 (S n)) (Some (Fin.F1 n))) + (cSSS : forall n (p i:Fin.t (S n)) (i':Fin.t n) + (Elow:lower p i = Some i'), + P n p i (Some i') -> + P (S n) (Fin.FS p) (Fin.FS i) (Some (Fin.FS i'))) + (cSSN : forall n (p i:Fin.t (S n)) + (Elow:lower p i = None), + P n p i None -> + P (S n) (Fin.FS p) (Fin.FS i) None) : + forall n (p i:Fin.t (S n)), P n p i (lower p i). +Proof. + fix 2. intros n p. + refine (match p as p1 in Fin.t (S n1) + return forall (i1:Fin.t (S n1)), P n1 p1 i1 (lower p1 i1) + with + | @Fin.F1 n1 => _ + | @Fin.FS n1 p1 => _ + end); clear n p. + { revert n1. refine (@Fin.caseS _ _ _); cbn; intros. + apply c11. apply c1S. } + { intros i1. revert p1. + pattern n1, i1; refine (@Fin.caseS _ _ _ _ _); + clear n1 i1; + (intros [|n] i; [refine (False_rect _ (fin_0_absurd i)) | cbn ]). + { apply cS1. } + { intros p. pose proof (admit : P n p i (lower p i)) as H. + destruct (lower p i) eqn:E. + { admit; assumption. } + { cbn. apply admit; assumption. } } } +Qed. + +Section squeeze. + Context {A:Type} (x:A). + Notation vec := (Vector.t A). + + Fixpoint squeeze {n} (v:vec n) (i:Fin.t (S n)) {struct i} : vec (S n) := + match i in Fin.t (S _n) return vec _n -> vec (S _n) + with + | @Fin.F1 n' => fun v' => Vector.cons _ x _ v' + | @Fin.FS n' i' => + fun v' => + match n' as _n return vec _n -> Fin.t _n -> vec (S _n) + with + | 0 => fun u i' => False_rect _ (fin_0_absurd i') + | S m => + fun (u:vec (S m)) => + match u in Vector.t _ (S _m) + return Fin.t (S _m) -> vec (S (S _m)) + with + | Vector.nil _ => tt + | Vector.cons _ h _ u' => + fun j' => Vector.cons _ h _ admit (* (squeeze u' j') *) + end + end v' i' + end v. +End squeeze. + +Require Import Program. +Lemma squeeze_nth (A:Type) (x:A) (n:nat) (v:Vector.t A n) p i : + Vector.nth (squeeze x v p) i = match lower p i with + | Some j => Vector.nth v j + | None => x + end. +Proof. + (* alternatively: [functional induction (lower p i) using lower_ind] *) + revert v. pattern n, p, i, (lower p i). + refine (@lower_ind _ _ _ _ _ _ n p i); + intros; cbn; auto. + + (*** Fails here with "Conversion test raised an anomaly" ***) + revert v. + admit. + admit. + admit. +Qed. diff --git a/test-suite/bugs/closed/3352.v b/test-suite/bugs/closed/3352.v new file mode 100644 index 00000000..b57b0a0f --- /dev/null +++ b/test-suite/bugs/closed/3352.v @@ -0,0 +1,34 @@ + +(* +I'm not sure what the general rule should be; intuitively, I want [IsHProp (* Set *) Foo] to mean [IsHProp (* U >= Set *) Foo]. (I think this worked in HoTT/coq, too.) Morally, [IsHProp] has no universe level associated with it distinct from that of its argument, you should never get a universe inconsistency from unifying [IsHProp A] with [IsHProp A]. (The issue is tricker when IsHProp uses [A] elsewhere, as in: +*) + +(* File reduced by coq-bug-finder from original input, then from 7725 lines to 78 lines, then from 51 lines to 13 lines *) +Set Universe Polymorphism. +Inductive Empty : Set := . +Record IsHProp (A : Type) := { foo : True }. +Definition hprop_Empty : IsHProp@{i} Empty := {| foo := I |}. +Goal let U := Type in let gt := Set : U in IsHProp (Empty : U). +simpl. +Set Printing Universes. +exact @hprop_Empty. (* Toplevel input, characters 21-32: +Error: +The term "hprop_Empty" has type "IsHProp (* Set *) Empty" +while it is expected to have type "IsHProp (* Top.17 *) Empty" +(Universe inconsistency: Cannot enforce Top.17 = Set because Set < Top.17)). *) +Defined. + +Module B. +(* -*- coq-prog-args: ("-emacs" "-indices-matter") -*- *) +(* File reduced by coq-bug-finder from original input, then from 7725 lines to 78 lines, then from 51 lines to 13 lines *) +Set Universe Polymorphism. +Inductive paths {A} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Record Contr (A : Type) := { center : A }. +Monomorphic Record IsHProp (A : Type) := { foo : forall x y : A, Contr (x = y) }. +Definition hprop_Empty : IsHProp Empty := {| foo x y := match x : Empty with end |}. +Goal let U := Type in let gt := Set : U in IsHProp (Empty : U). +simpl. +Set Printing Universes. +exact hprop_Empty. +Defined. +End B.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3354.v b/test-suite/bugs/closed/3354.v new file mode 100644 index 00000000..14b66db3 --- /dev/null +++ b/test-suite/bugs/closed/3354.v @@ -0,0 +1,12 @@ +Set Universe Polymorphism. +Notation Type1 := $(let U := constr:(Type) in let gt := constr:(Set : U) in exact U)$ (only parsing). +Inductive Empty : Type1 := . +Fail Check Empty : Set. +(* Toplevel input, characters 15-116: +Error: Conversion test raised an anomaly *) +(* Now we make sure it's not an anomaly *) +Goal True. +Proof. + try exact (let x := Empty : Set in I). + exact I. +Defined. diff --git a/test-suite/bugs/closed/3355.v b/test-suite/bugs/closed/3355.v new file mode 100644 index 00000000..46a57147 --- /dev/null +++ b/test-suite/bugs/closed/3355.v @@ -0,0 +1,6 @@ +Inductive paths {A} (x : A) : A -> Type := idpath : paths x x. +Goal forall A B : Set, @paths Type A B -> @paths Set A B. +Proof. + intros A B H. + Fail exact H. +Abort. diff --git a/test-suite/bugs/closed/3368.v b/test-suite/bugs/closed/3368.v new file mode 100644 index 00000000..1eff1dba --- /dev/null +++ b/test-suite/bugs/closed/3368.v @@ -0,0 +1,16 @@ +(* File reduced by coq-bug-finder from 7411 lines to 2271 lines., then from 889 lines to 119 lines, then from 76 lines to 19 lines *) +Set Universe Polymorphism. +Set Implicit Arguments. +Set Primitive Projections. +Record PreCategory := { object :> Type; morphism : object -> object -> Type }. +Record Functor (C D : PreCategory) := + { object_of :> C -> D; + morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d) }. +Definition opposite (C : PreCategory) : PreCategory := @Build_PreCategory C (fun s d => morphism C d s). +Definition opposite' C D (F : Functor C D) + := Build_Functor (opposite C) (opposite D) + (object_of F) + (fun s d => @morphism_of C D F d s). +(* Toplevel input, characters 15-191: +Anomaly: File "pretyping/reductionops.ml", line 149, characters 4-10: Assertion failed. +Please report. *) diff --git a/test-suite/bugs/closed/3372.v b/test-suite/bugs/closed/3372.v new file mode 100644 index 00000000..91e3df76 --- /dev/null +++ b/test-suite/bugs/closed/3372.v @@ -0,0 +1,7 @@ +Set Universe Polymorphism. +Definition hProp : Type := sigT (fun _ : Type => True). +Goal Type. +Fail exact hProp@{Set}. (* test that it fails, but is not an anomaly *) +try (exact hProp@{Set}; fail 1). (* Toplevel input, characters 15-32: +Anomaly: Uncaught exception Invalid_argument("Array.iter2", _). +Please report. *) diff --git a/test-suite/bugs/closed/3373.v b/test-suite/bugs/closed/3373.v new file mode 100644 index 00000000..5ecf2801 --- /dev/null +++ b/test-suite/bugs/closed/3373.v @@ -0,0 +1,33 @@ +(* File reduced by coq-bug-finder from original input, then from 5968 lines to +11933 lines, then from 11239 lines to 11231 lines, then from 10365 lines to 446 +lines, then from 456 lines to 379 lines, then from 391 lines to 373 lines, then +from 369 lines to 351 lines, then from 350 lines to 340 lines, then from 348 +lines to 320 lines, then from 328 lines to 302 lines, then from 332 lines to 21 +lines *) +Set Universe Polymorphism. +Module short. + Record foo := { bar : Type }. + Coercion baz (x : foo@{Set}) : Set := bar x. + Goal True. + Proof. + Fail pose ({| bar := Set |} : Type). (* check that it fails *) + try pose ({| bar := Set |} : Type). (* Anomaly: apply_coercion_args: mismatch between arguments and coercion. +Please report. *) + Admitted. +End short. + +Module long. + Axiom admit : forall {T}, T. + Definition UU := Set. + Definition UU' := Type. + Definition hSet:= sigT (fun X : UU' => admit) . + Definition pr1hSet:= @projT1 UU (fun X : UU' => admit) : hSet -> Type. + Coercion pr1hSet: hSet >-> Sortclass. + Axiom binop : UU -> Type. + Axiom setwithbinop : Type. + Goal True. + Proof. + Fail pose (( @projT1 _ ( fun X : hSet@{i j k} => binop X ) ) : _ -> hSet). (* check that it fails *) + try pose (( @projT1 _ ( fun X : hSet@{i j k} => binop X ) ) : _ -> hSet). (* check that it's not an anomaly *) + Admitted. +End long. diff --git a/test-suite/bugs/closed/3374.v b/test-suite/bugs/closed/3374.v new file mode 100644 index 00000000..3c67703a --- /dev/null +++ b/test-suite/bugs/closed/3374.v @@ -0,0 +1,51 @@ +(* File reduced by coq-bug-finder from original input, then from 5968 lines to 11933 lines, then from 11239 lines to 11231 lines, then from 10365 lines to 446 lines, then from 456 lines to 379 lines, then from 391 lines to 373 lines, then from 369 lines to 351 lines, then from 350 lines to 340 lines, then from 348 lines to 320 lines, then from 328 lines to 302 lines, then from 331 lines to 59 lines *) + +Set Universe Polymorphism. +Axiom admit : forall {T}, T. +Notation paths := identity . +Definition UU := Set. +Definition dirprod ( X Y : UU ) := sigT ( fun x : X => Y ) . +Definition dirprodpair { X Y : UU } := existT ( fun x : X => Y ) . +Definition hProp := sigT (fun X : Type => admit). +Definition hProptoType := @projT1 _ _ : hProp -> Type . +Coercion hProptoType: hProp >-> Sortclass. +Definition UU' := Type. +Definition hSet:= sigT (fun X : UU' => admit) . +Definition pr1hSet:= @projT1 UU (fun X : UU' => admit) : hSet -> Type. +Coercion pr1hSet: hSet >-> Sortclass. +Axiom hsubtypes : UU -> Type. +Definition hrel ( X : UU ) := X -> X -> hProp. +Axiom hreldirprod : forall { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ), hrel ( dirprod X Y ) . +Axiom iseqclass : forall { X : UU } ( R : hrel X ) ( A : hsubtypes X ), Type. +Definition setquot { X : UU } ( R : hrel X ) : Type := sigT (fun A => iseqclass R A). +Axiom dirprodtosetquot : forall { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) (cd : dirprod ( setquot RX ) ( setquot RY ) ), + setquot ( hreldirprod RX RY ). +Definition iscomprelfun2 { X Y : UU } ( R : hrel X ) ( f : X -> X -> Y ) + := forall x x' x0 x0' : X , R x x' -> R x0 x0' -> paths ( f x x0 ) ( f x' x0' ) . +Axiom setquotuniv : forall { X : UU } ( R : hrel X ) ( Y : hSet ) ( f : X -> Y ) ( c : setquot R ), Y . +Definition setquotuniv2 { X : UU } ( R : hrel X ) ( Y : hSet ) ( f : X -> X -> Y ) ( is : iscomprelfun2 R f ) ( c c0 : setquot R ) +: Y . +Proof. + intros . + set ( RR := hreldirprod R R ) . + apply (setquotuniv RR Y admit). + apply (dirprodtosetquot R R). + apply dirprodpair; [ exact c | exact c0 ]. + Undo. + exact (dirprodpair c c0). +Defined. + (* Toplevel input, characters 39-40: +Error: +In environment +X : UU +R : hrel X +Y : hSet +f : X -> X -> Y +is : iscomprelfun2 R f +c : setquot R +c0 : setquot R +RR := hreldirprod R R : hrel (dirprod X X) +The term "c" has type "setquot R" while it is expected to have type +"?42" (unable to find a well-typed instantiation for +"?42": cannot unify"Type" and "UU"). + *) diff --git a/test-suite/bugs/closed/3375.v b/test-suite/bugs/closed/3375.v new file mode 100644 index 00000000..fe323fcb --- /dev/null +++ b/test-suite/bugs/closed/3375.v @@ -0,0 +1,48 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-impredicative-set") -*- *) +(* File reduced by coq-bug-finder from original input, then from 5968 lines to 11933 lines, then from 11239 lines to 11231 lines, then from 10365 lines to 446 lines, then from 456 lines to 379 lines, then from 391 lines to 373 lines, then from 369 lines to 351 lines, then from 350 lines to 340 lines, then from 348 lines to 320 lines, then from 328 lines to 302 lines, then from 330 lines to 45 lines *) + +Set Universe Polymorphism. +Axiom admit : forall {T}, T. +Definition UU := Set. +Definition dirprod ( X Y : UU ) := sigT ( fun x : X => Y ) . +Definition dirprodpair { X Y : UU } := existT ( fun x : X => Y ) . +Definition hProp := sigT (fun X : Type => admit). +Axiom hProppair : forall ( X : UU ) ( is : admit ), hProp. +Definition hProptoType := @projT1 _ _ : hProp -> Type . +Coercion hProptoType: hProp >-> Sortclass. +Definition ishinh_UU ( X : UU ) : UU := forall P: Set, ( ( X -> P ) -> P ). +Definition ishinh ( X : UU ) : hProp := hProppair ( ishinh_UU X ) admit. +Definition hsubtypes ( X : UU ) : Type := X -> hProp. +Axiom carrier : forall { X : UU } ( A : hsubtypes X ), Type. +Definition hrel ( X : UU ) : Type := X -> X -> hProp. +Set Printing Universes. +Definition iseqclass { X : UU } ( R : hrel X ) ( A : hsubtypes X ) : Type. + intros; exact ( dirprod ( ishinh ( carrier A ) ) ( dirprod ( forall x1 x2 : X , R x1 x2 -> A x1 -> A x2 ) + ( forall x1 x2 : X, A x1 -> A x2 -> R x1 x2 ) )) . +Defined. +Definition iseqclassconstr' { X : UU } ( R : hrel X ) { A : hsubtypes X } ( ax0 : ishinh ( carrier A ) ) + ( ax1 : forall x1 x2 : X , R x1 x2 -> A x1 -> A x2 ) ( ax2 : forall x1 x2 : X, A x1 -> A x2 -> R x1 x2 ) : iseqclass R A. + intros. + apply dirprodpair. { exact ax0. } + apply dirprodpair. { exact ax1. } {exact ax2. } +Defined. +Definition iseqclassconstr { X : UU } ( R : hrel X ) { A : hsubtypes X } ( ax0 : ishinh ( carrier A ) ) + ( ax1 : forall x1 x2 : X , R x1 x2 -> A x1 -> A x2 ) ( ax2 : forall x1 x2 : X, A x1 -> A x2 -> R x1 x2 ) : iseqclass R A. + pose @iseqclassconstr'. + intros. + exact (dirprodpair ax0 (dirprodpair ax1 ax2)). +Defined. +(* Toplevel input, characters 15-23: +Error: Illegal application: +The term "dirprodpair" of type + "forall (X Y : UU) (x : X), (fun _ : X => Y) x -> {_ : X & Y}" +cannot be applied to the terms + "forall x1 x2 : X, R x1 x2 -> A x1 -> A x2" + : "Type@{max(Set, Top.476, Top.479)}" + "forall x1 x2 : X, A x1 -> A x2 -> R x1 x2" + : "Type@{max(Set, Top.476, Top.479)}" + "ax1" : "forall x1 x2 : X, R x1 x2 -> A x1 -> A x2" + "ax2" : "forall x1 x2 : X, A x1 -> A x2 -> R x1 x2" +The 1st term has type "Type@{max(Set, Top.476, Top.479)}" +which should be coercible to "UU". + *) diff --git a/test-suite/bugs/closed/3377.v b/test-suite/bugs/closed/3377.v new file mode 100644 index 00000000..8e9e3933 --- /dev/null +++ b/test-suite/bugs/closed/3377.v @@ -0,0 +1,17 @@ +Set Primitive Projections. +Set Implicit Arguments. +Record prod A B := pair { fst : A; snd : B}. + +Goal fst (@pair Type Type Type Type). +Set Printing All. +match goal with |- ?f ?x => set (foo := f x) end. + +Goal forall x : prod Set Set, x = @pair _ _ (fst x) (snd x). +Proof. + intro x. + lazymatch goal with + | [ |- ?x = @pair _ _ (?f ?x) (?g ?x) ] => pose f + end. + +(* Toplevel input, characters 7-44: +Error: No matching clauses for match. *) diff --git a/test-suite/bugs/closed/3382.v b/test-suite/bugs/closed/3382.v new file mode 100644 index 00000000..1d8e9167 --- /dev/null +++ b/test-suite/bugs/closed/3382.v @@ -0,0 +1,63 @@ +(* File reduced by coq-bug-finder from 9039 lines to 7786 lines, then from 7245 lines to 476 lines, then from 417 lines to 249 lines, then from 171 lines to 127 lines, then from 139 lines to 114 lines, then from 93 lines to 77 lines *) + +Set Implicit Arguments. +Definition admit {T} : T. +Admitted. +Delimit Scope object_scope with object. +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope functor_scope with functor. +Reserved Infix "o" (at level 40, left associativity). +Record PreCategory := + { Object :> Type; + Morphism : Object -> Object -> Type; + Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' where "f 'o' g" := (Compose f g) }. +Bind Scope category_scope with PreCategory. +Infix "o" := (@Compose _ _ _ _) : morphism_scope. +Local Open Scope morphism_scope. +Record Functor (C D : PreCategory) := + { ObjectOf :> C -> D; + MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d); + FCompositionOf : forall s d d' (m1 : C.(Morphism) s d) (m2: C.(Morphism) d d'), + MorphismOf _ _ (m2 o m1) = (MorphismOf _ _ m2) o (MorphismOf _ _ m1) }. +Bind Scope functor_scope with Functor. +Arguments MorphismOf [C%category] [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch. +Definition ComposeFunctors C D E + (G : Functor D E) (F : Functor C D) : Functor C E + := Build_Functor C E (fun c => G (F c)) admit admit. +Infix "o" := ComposeFunctors : functor_scope. +Record NaturalTransformation C D (F G : Functor C D) := + { ComponentsOf :> forall c, D.(Morphism) (F c) (G c); + Commutes : forall s d (m : C.(Morphism) s d), + ComponentsOf d o F.(MorphismOf) m = G.(MorphismOf) m o ComponentsOf s }. +Definition NTComposeT C D (F F' F'' : Functor C D) + (T' : NaturalTransformation F' F'') + (T : NaturalTransformation F F') + (CO := fun c => T' c o T c) +: NaturalTransformation F F''. + exact (Build_NaturalTransformation F F'' + (fun c => T' c o T c) + (admit : forall s d (m : Morphism C s d), CO d o MorphismOf F m = MorphismOf F'' m o CO s)). +Defined. +Definition NTWhiskerR C D E (F F' : Functor D E) (T : NaturalTransformation F F') + (G : Functor C D) + := Build_NaturalTransformation (F o G) (F' o G) (fun c => T (G c)) admit. +Axiom NTWhiskerR_CompositionOf +: forall C D + (F G H : Functor C D) + (T : NaturalTransformation G H) + (T' : NaturalTransformation F G) B (I : Functor B C), + NTComposeT (NTWhiskerR T I) (NTWhiskerR T' I) = NTWhiskerR (NTComposeT T T') I. +Definition FunctorCategory C D : PreCategory + := @Build_PreCategory (Functor C D) + (NaturalTransformation (C := C) (D := D)) + admit. +Notation "[ C , D ]" := (FunctorCategory C D) : category_scope. +Class silly {T} := term : T. +Timeout 1 Fail Definition NTWhiskerR_Functorial (C D E : PreCategory) (G : [C, D]%category) +: [[D, E], [C, E]]%category + := Build_Functor + [C, D] [C, E] + (fun F => _ : silly) + (fun _ _ T => _ : silly) + (fun _ _ _ _ _ => NTWhiskerR_CompositionOf _ _ _). diff --git a/test-suite/bugs/closed/3386.v b/test-suite/bugs/closed/3386.v new file mode 100644 index 00000000..0e236c21 --- /dev/null +++ b/test-suite/bugs/closed/3386.v @@ -0,0 +1,16 @@ +Set Universe Polymorphism. +Set Printing Universes. +Record Cat := { Obj :> Type }. +Definition set_cat := {| Obj := Type |}. +Goal Type@{i} = Type@{j}. +Proof. + (* 1 subgoals +, subgoal 1 (ID 3) + + ============================ + Type@{Top.368} = Type@{Top.370} +(dependent evars:) *) + Fail change Type@{i} with (Obj set_cat@{i}). (* check that it fails *) + try change Type@{i} with (Obj set_cat@{i}). (* check that it's not an anomaly *) +(* Anomaly: Uncaught exception Invalid_argument("Array.iter2", _). +Please report. *) diff --git a/test-suite/bugs/closed/3387.v b/test-suite/bugs/closed/3387.v new file mode 100644 index 00000000..ae212caa --- /dev/null +++ b/test-suite/bugs/closed/3387.v @@ -0,0 +1,21 @@ +Set Universe Polymorphism. +Set Printing Universes. +Record Cat := { Obj :> Type }. +Definition set_cat := {| Obj := Type |}. +Goal Type@{i} = Type@{j}. +Proof. + (* 1 subgoals +, subgoal 1 (ID 3) + + ============================ + Type@{Top.368} = Type@{Top.370} +(dependent evars:) *) + let x := constr:(Type) in + let y := constr:(Obj set_cat) in + unify x y. (* success *) + let x := constr:(Type) in + let y := constr:(Obj set_cat) in + first [ unify x y | fail 2 "no unify" ]; + change x with y at -1. (* Error: Not convertible. *) + reflexivity. +Defined.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3388.v b/test-suite/bugs/closed/3388.v new file mode 100644 index 00000000..78262804 --- /dev/null +++ b/test-suite/bugs/closed/3388.v @@ -0,0 +1,57 @@ +Inductive test : bool -> bool -> Type := +| test00 : test false false +| test01 : test false true +| test10 : test true false +. + +(* This does not work *) +Definition test_a (t : test true false) : test true false := + match t with + | test10 => test10 + end. + +(* The following definition shows that test_a SHOULD work *) +Definition test_a_workaround (t : test true false) : test true false := + match t with + | test10 => test10 + | _ => tt + end. + +(* Surprisingly, this works *) +Definition test_b (t : test false true) : test false true := + match t with + | test01 => test01 + end. + + +(* This, too, works *) +Definition test_c x (t : test false x) : test false x := + match t with + | test00 => test00 + | test01 => test01 + end. + +Inductive test2 : bool -> bool -> Type := +| test201 : test2 false true +| test210 : test2 true false +| test211 : test2 true true +. + +(* Now this works *) +Definition test2_a (t : test2 true false) : test2 true false := + match t with + | test210 => test210 + end. + +(* Accordingly, this now fails *) +Definition test2_b (t : test2 false true) : test2 false true := + match t with + | test201 => test201 + end. + + +(* This, too, fails *) +Definition test2_c x (t : test2 false x) : test2 false x := + match t with + | test201 => test201 + end. diff --git a/test-suite/bugs/closed/3390.v b/test-suite/bugs/closed/3390.v new file mode 100644 index 00000000..eb3c4f4b --- /dev/null +++ b/test-suite/bugs/closed/3390.v @@ -0,0 +1,9 @@ +Tactic Notation "basicapply" open_constr(R) "using" tactic3(tac) "sideconditions" tactic0(tacfin) := idtac. +Tactic Notation "basicapply" open_constr(R) := basicapply R using (fun Hlem => idtac) sideconditions (autounfold with spred; idtac). +(* segfault in coqtop *) + + +Tactic Notation "basicapply" tactic0(tacfin) := idtac. + +Goal True. +basicapply subst. diff --git a/test-suite/bugs/closed/3392.v b/test-suite/bugs/closed/3392.v new file mode 100644 index 00000000..29ee1487 --- /dev/null +++ b/test-suite/bugs/closed/3392.v @@ -0,0 +1,40 @@ +(* File reduced by coq-bug-finder from original input, then from 12105 lines to 142 lines, then from 83 lines to 57 lines *) +Generalizable All Variables. +Axiom admit : forall {T}, T. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := match p with idpath => u end. +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing). +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p with idpath => idpath end. +Definition apD {A:Type} {B:A->Type} (f:forall a:A, B a) {x y:A} (p:x=y): transport _ p (f x) = f y := admit. +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { + equiv_inv : B -> A ; + eisretr : Sect equiv_inv f; + eissect : Sect f equiv_inv; + eisadj : forall x : A, eisretr (f x) = ap f (eissect x) }. +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3). +Axiom path_forall : forall {A : Type} {P : A -> Type} (f g : forall x : A, P x), (forall x, f x = g x) -> f = g. +Axiom isequiv_adjointify : forall {A B} (f : A -> B) (g : B -> A) (isretr : Sect g f) (issect : Sect f g), IsEquiv f. +Definition functor_forall `{P : A -> Type} `{Q : B -> Type} (f0 : B -> A) (f1 : forall b:B, P (f0 b) -> Q b) +: (forall a:A, P a) -> (forall b:B, Q b) := (fun g b => f1 _ (g (f0 b))). +Goal forall `{P : A -> Type} `{Q : B -> Type} `{IsEquiv B A f} `{forall b, @IsEquiv (P (f b)) (Q b) (g b)}, + IsEquiv (functor_forall f g). +Proof. + intros. + refine (isequiv_adjointify (functor_forall f g) + (functor_forall (f^-1) + (fun (x:A) (y:Q (f^-1 x)) => @eisretr _ _ f _ x # (g (f^-1 x))^-1 y + )) _ _); + intros h. + - abstract ( + apply path_forall; intros b; unfold functor_forall; + rewrite eisadj; + admit + ). + - abstract ( + apply path_forall; intros a; unfold functor_forall; + rewrite eissect; + apply apD + ). +Defined. diff --git a/test-suite/bugs/closed/3393.v b/test-suite/bugs/closed/3393.v new file mode 100644 index 00000000..ec25e682 --- /dev/null +++ b/test-suite/bugs/closed/3393.v @@ -0,0 +1,152 @@ +(* -*- coq-prog-args: ("-emacs" "-indices-matter") -*- *) +(* File reduced by coq-bug-finder from original input, then from 8760 lines to 7519 lines, then from 7050 lines to 909 lines, then from 846 lines to 578 lines, then from 497 lines to 392 lines, then from 365 lines to 322 lines, then from 252 lines to 205 lines, then from 215 lines to 204 lines, then from 210 lines to 182 lines, then from 175 lines to 157 lines *) +Set Universe Polymorphism. +Axiom admit : forall {T}, T. +Set Implicit Arguments. +Generalizable All Variables. +Reserved Notation "g 'o' f" (at level 40, left associativity). +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "a = b" := (@paths _ a b) : type_scope. +Arguments idpath {A a} , [A] a. +Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g) : forall x, f x = g x := fun x => match h with idpath => idpath end. +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { equiv_inv : B -> A }. +Delimit Scope equiv_scope with equiv. +Local Open Scope equiv_scope. +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope. +Class Funext := { isequiv_apD10 :> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) }. +Definition path_forall `{Funext} {A : Type} {P : A -> Type} (f g : forall x : A, P x) : (forall x, f x = g x) -> f = g := (@apD10 A P f g)^-1. +Record PreCategory := + { object :> Type; + morphism : object -> object -> Type; + compose : forall s d d', morphism d d' -> morphism s d -> morphism s d' where "f 'o' g" := (compose f g); + associativity : forall x1 x2 x3 x4 (m1 : morphism x1 x2) (m2 : morphism x2 x3) (m3 : morphism x3 x4), (m3 o m2) o m1 = m3 o (m2 o m1) + }. +Bind Scope category_scope with PreCategory. +Bind Scope morphism_scope with morphism. +Infix "o" := (@compose _ _ _ _) : morphism_scope. +Delimit Scope functor_scope with functor. +Record Functor (C D : PreCategory) := + { object_of :> C -> D; + morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d) }. +Bind Scope functor_scope with Functor. +Notation "F '_1' m" := (@morphism_of _ _ F _ _ m) (at level 10, no associativity) : morphism_scope. +Class IsIsomorphism {C : PreCategory} {s d} (m : morphism C s d) := { morphism_inverse : morphism C d s }. +Local Notation "m ^-1" := (morphism_inverse (m := m)) : morphism_scope. +Class Isomorphic {C : PreCategory} s d := + { morphism_isomorphic :> morphism C s d; + isisomorphism_isomorphic :> IsIsomorphism morphism_isomorphic }. +Coercion morphism_isomorphic : Isomorphic >-> morphism. +Definition isisomorphism_inverse `(@IsIsomorphism C x y m) : IsIsomorphism m^-1 := {| morphism_inverse := m |}. + +Global Instance isisomorphism_compose `(@IsIsomorphism C y z m0) `(@IsIsomorphism C x y m1) : IsIsomorphism (m0 o m1). +Admitted. +Infix "<~=~>" := Isomorphic (at level 70, no associativity) : category_scope. +Definition composef C D E (G : Functor D E) (F : Functor C D) : Functor C E + := Build_Functor + C E + (fun c => G (F c)) + (fun _ _ m => @morphism_of _ _ G _ _ (@morphism_of _ _ F _ _ m)). +Infix "o" := composef : functor_scope. +Delimit Scope natural_transformation_scope with natural_transformation. + +Local Open Scope morphism_scope. +Record NaturalTransformation C D (F G : Functor C D) := + { components_of :> forall c, morphism D (F c) (G c); + commutes : forall s d (m : morphism C s d), components_of d o F _1 m = G _1 m o components_of s }. + +Definition composet C D (F F' F'' : Functor C D) (T' : NaturalTransformation F' F'') (T : NaturalTransformation F F') +: NaturalTransformation F F'' + := Build_NaturalTransformation F F'' (fun c => T' c o T c) admit. +Infix "o" := composet : natural_transformation_scope. +Section path_natural_transformation. + Context `{Funext}. + Variable C : PreCategory. + Variable D : PreCategory. + Variables F G : Functor C D. + Section path. + Variables T U : NaturalTransformation F G. + Lemma path'_natural_transformation + : components_of T = components_of U + -> T = U. + admit. + Defined. + Lemma path_natural_transformation + : (forall x, components_of T x = components_of U x) + -> T = U. + Proof. + intros. + apply path'_natural_transformation. + apply path_forall; assumption. + Qed. + End path. +End path_natural_transformation. +Ltac path_natural_transformation := + repeat match goal with + | _ => intro + | _ => apply path_natural_transformation; simpl + end. + +Local Open Scope natural_transformation_scope. +Definition associativityt `{fs : Funext} + C D F G H I + (V : @NaturalTransformation C D F G) + (U : @NaturalTransformation C D G H) + (T : @NaturalTransformation C D H I) +: (T o U) o V = T o (U o V). +Proof. + path_natural_transformation. + apply associativity. +Qed. +Definition functor_category `{Funext} (C D : PreCategory) : PreCategory + := @Build_PreCategory (Functor C D) (@NaturalTransformation C D) (@composet C D) (@associativityt _ C D). +Notation "C -> D" := (functor_category C D) : category_scope. +Definition NaturalIsomorphism `{Funext} (C D : PreCategory) F G := @Isomorphic (C -> D) F G. +Infix "<~=~>" := NaturalIsomorphism : natural_transformation_scope. +Global Instance isisomorphism_compose' `{Funext} + `(T' : @NaturalTransformation C D F' F'') + `(T : @NaturalTransformation C D F F') + `{@IsIsomorphism (C -> D) F' F'' T'} + `{@IsIsomorphism (C -> D) F F' T} +: @IsIsomorphism (C -> D) F F'' (T' o T)%natural_transformation + := @isisomorphism_compose (C -> D) _ _ T' _ _ T _. +Section lemmas. + Context `{Funext}. + Variable C : PreCategory. + Variable F : C -> PreCategory. + Context + {w y z} + {f : Functor (F w) (F z)} {f0 : Functor (F w) (F y)} + {f2 : Functor (F y) (F z)} + {f5 : Functor (F w) (F z)} + {n2 : f <~=~> (f2 o f0)%functor}. + Lemma p_composition_of_coherent_iso_for_rewrite__isisomorphism_helper' XX + : @IsIsomorphism + (F w -> F z) f5 f + (n2 ^-1 o XX)%natural_transformation. + Proof. + eapply isisomorphism_compose'. + eapply isisomorphism_inverse. (* Toplevel input, characters 22-43: +Error: +In environment +H : Funext +C : PreCategory +F : C -> PreCategory +w : C +y : C +z : C +f : Functor (F w) (F z) +f0 : Functor (F w) (F y) +f2 : Functor (F y) (F z) +f5 : Functor (F w) (F z) +n2 : f <~=~> (f2 o f0)%functor +XX : NaturalTransformation f5 (f2 o f0) +Unable to unify + "{| + object := Functor (F w) (F z); + morphism := NaturalTransformation (D:=F z); + compose := composet (D:=F z); + associativity := associativityt (D:=F z) |}" with + "{| + object := Functor (F w) (F z); + morphism := NaturalTransformation (D:=F z); + compose := composet (D:=F z); + associativity := associativityt (D:=F z) |}". *) diff --git a/test-suite/bugs/closed/3402.v b/test-suite/bugs/closed/3402.v new file mode 100644 index 00000000..ed47ec82 --- /dev/null +++ b/test-suite/bugs/closed/3402.v @@ -0,0 +1,7 @@ +Set Primitive Projections. +Record prod A B := pair { fst : A ; snd : B }. +Goal forall A B (p : prod A B), p = let (x, y) := p in pair A B x y. +Proof. + intros A B p. + exact eq_refl. +Qed.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3408.v b/test-suite/bugs/closed/3408.v new file mode 100644 index 00000000..b12b8c1a --- /dev/null +++ b/test-suite/bugs/closed/3408.v @@ -0,0 +1,163 @@ +Require Import BinPos. + +Inductive expr : Type := + Var : nat -> expr +| App : expr -> expr -> expr +| Abs : unit -> expr -> expr. + +Inductive expr_acc +: expr -> expr -> Prop := + acc_App_l : forall f a : expr, + expr_acc f (App f a) +| acc_App_r : forall f a : expr, + expr_acc a (App f a) +| acc_Abs : forall (t : unit) (e : expr), + expr_acc e (Abs t e). + +Theorem wf_expr_acc : well_founded expr_acc. +Proof. + red. + refine (fix rec a : Acc expr_acc a := + match a as a return Acc expr_acc a with + | Var v => Acc_intro _ (fun y (_H : expr_acc y (Var v)) => + match _H in expr_acc z Z + return match Z return Prop with + | Var _ => Acc _ y + | _ => True + end + with + | acc_App_l _ _ => I + | _ => I + end) + | App f x => Acc_intro _ (fun y (pf : expr_acc y (App f x)) => + match pf in expr_acc z Z + return match Z return Prop with + | App a b => f = a -> x = b -> Acc expr_acc z + | _ => True + end + with + | acc_App_l f' x' => fun pf _ => match pf in _ = z return + Acc expr_acc z + with + | eq_refl => rec f + end + | acc_App_r f' x' => fun _ pf => match pf in _ = z return + Acc expr_acc z + with + | eq_refl => rec x + end + | _ => I + end eq_refl eq_refl) + | Abs t e => Acc_intro _ (fun y (pf : expr_acc y (Abs t e)) => + match pf in expr_acc z Z + return match Z return Prop with + | Abs a b => e = b -> Acc expr_acc z + | _ => True + end + with + | acc_Abs f x => fun pf => match pf in _ = z return + Acc expr_acc z + with + | eq_refl => rec e + end + | _ => I + end eq_refl) + end). +Defined. + +Theorem wf_expr_acc_delay : well_founded expr_acc. +Proof. + red. + refine (fix rec a : Acc expr_acc a := + match a as a return Acc expr_acc a with + | Var v => Acc_intro _ (fun y (_H : expr_acc y (Var v)) => + match _H in expr_acc z Z + return match Z return Prop with + | Var _ => Acc _ y + | _ => True + end + with + | acc_App_l _ _ => I + | _ => I + end) + | App f x => Acc_intro _ (fun y (pf : expr_acc y (App f x)) => + match pf in expr_acc z Z + return match Z return Prop with + | App a b => (unit -> Acc expr_acc a) -> (unit -> Acc expr_acc b) -> Acc expr_acc z + | _ => True + end + with + | acc_App_l f' x' => fun pf _ => pf tt + | acc_App_r f' x' => fun _ pf => pf tt + | _ => I + end (fun _ => rec f) (fun _ => rec x)) + | Abs t e => Acc_intro _ (fun y (pf : expr_acc y (Abs t e)) => + match pf in expr_acc z Z + return match Z return Prop with + | Abs a b => (unit -> Acc expr_acc b) -> Acc expr_acc z + | _ => True + end + with + | acc_Abs f x => fun pf => pf tt + | _ => I + end (fun _ => rec e)) + end); + try solve [ inversion _H ]. +Defined. + +Fixpoint build_large (n : nat) : expr := + match n with + | 0 => Var 0 + | S n => + let e := build_large n in + App e e + end. + +Section guard. + Context {A : Type} {R : A -> A -> Prop}. + + Fixpoint guard (n : nat) (wfR : well_founded R) : well_founded R := + match n with + | 0 => wfR + | S n0 => + fun x : A => + Acc_intro x + (fun (y : A) (_ : R y x) => guard n0 (guard n0 wfR) y) + end. +End guard. + + +Definition sizeF_delay : expr -> positive. +refine + (@Fix expr (expr_acc) + (wf_expr_acc_delay) + (fun _ => positive) + (fun e => + match e as e return (forall l, expr_acc l e -> positive) -> positive with + | Var _ => fun _ => 1 + | App l r => fun rec => @rec l _ + @rec r _ + | Abs _ e => fun rec => 1 + @rec e _ + end%positive)). +eapply acc_App_l. +eapply acc_App_r. +eapply acc_Abs. +Defined. + +Definition sizeF_guard : expr -> positive. +refine + (@Fix expr (expr_acc) + (guard 5 wf_expr_acc) + (fun _ => positive) + (fun e => + match e as e return (forall l, expr_acc l e -> positive) -> positive with + | Var _ => fun _ => 1 + | App l r => fun rec => @rec l _ + @rec r _ + | Abs _ e => fun rec => 1 + @rec e _ + end%positive)). +eapply acc_App_l. +eapply acc_App_r. +eapply acc_Abs. +Defined. + +Time Eval native_compute in sizeF_delay (build_large 2). +Time Eval native_compute in sizeF_guard (build_large 2). diff --git a/test-suite/bugs/closed/3416.v b/test-suite/bugs/closed/3416.v new file mode 100644 index 00000000..5cfb8f1f --- /dev/null +++ b/test-suite/bugs/closed/3416.v @@ -0,0 +1,12 @@ +Inductive list A := Node : node A -> list A +with node A := Nil | Cons : A -> list A -> node A. + +Fixpoint app {A} (l1 l2 : list A) {struct l1} : list A +with app_node {A} (n1 : node A) (l2 : list A) {struct n1} : node A. +Proof. ++ destruct l1 as [n]; constructor. + exact (app_node _ n l2). ++ destruct n1 as [|x l1]. + - destruct l2 as [n2]; exact n2. + - exact (Cons _ x (app _ l1 l2)). +Qed. diff --git a/test-suite/bugs/closed/3417.v b/test-suite/bugs/closed/3417.v new file mode 100644 index 00000000..9d7c6f01 --- /dev/null +++ b/test-suite/bugs/closed/3417.v @@ -0,0 +1,7 @@ +Require Setoid. + +Goal forall {T}(a b : T), b=a -> {c | c=b}. +Proof. +intros T a b H. +try setoid_rewrite H. +Abort. diff --git a/test-suite/bugs/closed/3422.v b/test-suite/bugs/closed/3422.v new file mode 100644 index 00000000..d984f623 --- /dev/null +++ b/test-suite/bugs/closed/3422.v @@ -0,0 +1,208 @@ +Generalizable All Variables. +Set Implicit Arguments. +Set Universe Polymorphism. +Axiom admit : forall {T}, T. +Reserved Infix "o" (at level 40, left associativity). +Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A }. +Record Equiv A B := { equiv_fun :> A -> B ; equiv_isequiv :> IsEquiv equiv_fun }. +Existing Instance equiv_isequiv. +Delimit Scope equiv_scope with equiv. +Local Open Scope equiv_scope. +Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope. +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope. +Axiom IsHSet : Type -> Type. +Existing Class IsHSet. +Definition trunc_equiv' `(f : A <~> B) `{IsHSet A} : IsHSet B := admit. +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope object_scope with object. +Record PreCategory := + { object :> Type; + morphism : object -> object -> Type; + + compose : forall s d d', + morphism d d' + -> morphism s d + -> morphism s d' + where "f 'o' g" := (compose f g); + + trunc_morphism : forall s d, IsHSet (morphism s d) }. + +Bind Scope category_scope with PreCategory. +Infix "o" := (@compose _ _ _ _) : morphism_scope. + +Delimit Scope functor_scope with functor. + +Record Functor (C D : PreCategory) := + { + object_of :> C -> D; + morphism_of : forall s d, morphism C s d + -> morphism D (object_of s) (object_of d) + }. + +Bind Scope functor_scope with Functor. +Arguments morphism_of [C%category] [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch. +Notation "F '_1' m" := (morphism_of F m) (at level 10, no associativity) : morphism_scope. +Local Open Scope morphism_scope. + +Class IsIsomorphism {C : PreCategory} {s d} (m : morphism C s d) := { morphism_inverse : morphism C d s }. + +Local Notation "m ^-1" := (morphism_inverse (m := m)) : morphism_scope. + +Class Isomorphic {C : PreCategory} s d := + { + morphism_isomorphic :> morphism C s d; + isisomorphism_isomorphic :> IsIsomorphism morphism_isomorphic + }. + +Coercion morphism_isomorphic : Isomorphic >-> morphism. + +Local Infix "<~=~>" := Isomorphic (at level 70, no associativity) : category_scope. + +Definition isisomorphism_inverse `(@IsIsomorphism C x y m) : IsIsomorphism m^-1 := {| morphism_inverse := m |}. + +Global Instance isisomorphism_compose `(@IsIsomorphism C y z m0) `(@IsIsomorphism C x y m1) +: IsIsomorphism (m0 o m1). +admit. +Defined. + +Section composition. + Variable C : PreCategory. + Variable D : PreCategory. + Variable E : PreCategory. + Variable G : Functor D E. + Variable F : Functor C D. + + Definition composeF : Functor C E + := Build_Functor + C E + (fun c => G (F c)) + (fun _ _ m => morphism_of G (morphism_of F m)). +End composition. +Infix "o" := composeF : functor_scope. + +Delimit Scope natural_transformation_scope with natural_transformation. +Record NaturalTransformation C D (F G : Functor C D) := { components_of :> forall c, morphism D (F c) (G c) }. + +Section compose. + Variable C : PreCategory. + Variable D : PreCategory. + Variables F F' F'' : Functor C D. + + Variable T' : NaturalTransformation F' F''. + Variable T : NaturalTransformation F F'. + + Local Notation CO c := (T' c o T c). + + Definition composeT + : NaturalTransformation F F'' := Build_NaturalTransformation F F'' (fun c => CO c). + +End compose. + +Section whisker. + Variable C : PreCategory. + Variable D : PreCategory. + Variable E : PreCategory. + + Section L. + Variable F : Functor D E. + Variables G G' : Functor C D. + Variable T : NaturalTransformation G G'. + + Local Notation CO c := (morphism_of F (T c)). + + Definition whisker_l + := Build_NaturalTransformation + (F o G) (F o G') + (fun c => CO c). + + End L. + + Section R. + Variables F F' : Functor D E. + Variable T : NaturalTransformation F F'. + Variable G : Functor C D. + + Local Notation CO c := (T (G c)). + + Definition whisker_r + := Build_NaturalTransformation + (F o G) (F' o G) + (fun c => CO c). + End R. +End whisker. +Infix "o" := composeT : natural_transformation_scope. +Infix "oL" := whisker_l (at level 40, left associativity) : natural_transformation_scope. +Infix "oR" := whisker_r (at level 40, left associativity) : natural_transformation_scope. + +Section path_natural_transformation. + + Variable C : PreCategory. + Variable D : PreCategory. + Variables F G : Functor C D. + + Lemma equiv_sig_natural_transformation + : { CO : forall x, morphism D (F x) (G x) + | forall s d (m : morphism C s d), + CO d o F _1 m = G _1 m o CO s } + <~> NaturalTransformation F G. + admit. + Defined. + + Global Instance trunc_natural_transformation + : IsHSet (NaturalTransformation F G). + Proof. + eapply trunc_equiv'; [ exact equiv_sig_natural_transformation | ]. + admit. + Qed. + +End path_natural_transformation. +Definition functor_category (C D : PreCategory) : PreCategory + := @Build_PreCategory (Functor C D) (@NaturalTransformation C D) (@composeT C D) _. + +Notation "C -> D" := (functor_category C D) : category_scope. + +Definition NaturalIsomorphism (C D : PreCategory) F G := @Isomorphic (C -> D) F G. + +Coercion natural_transformation_of_natural_isomorphism C D F G (T : @NaturalIsomorphism C D F G) : NaturalTransformation F G + := T : morphism _ _ _. +Local Infix "<~=~>" := NaturalIsomorphism : natural_transformation_scope. +Global Instance isisomorphism_compose' + `(T' : @NaturalTransformation C D F' F'') + `(T : @NaturalTransformation C D F F') + `{@IsIsomorphism (C -> D) F' F'' T'} + `{@IsIsomorphism (C -> D) F F' T} +: @IsIsomorphism (C -> D) F F'' (T' o T)%natural_transformation + := @isisomorphism_compose (C -> D) _ _ T' _ _ T _. + +Section lemmas. + Local Open Scope natural_transformation_scope. + + Variable C : PreCategory. + Variable F : C -> PreCategory. + Context + {w x y z} + {f : Functor (F w) (F z)} {f0 : Functor (F w) (F y)} + {f1 : Functor (F x) (F y)} {f2 : Functor (F y) (F z)} + {f3 : Functor (F w) (F x)} {f4 : Functor (F x) (F z)} + {f5 : Functor (F w) (F z)} {n : f5 <~=~> (f4 o f3)%functor} + {n0 : f4 <~=~> (f2 o f1)%functor} {n1 : f0 <~=~> (f1 o f3)%functor} + {n2 : f <~=~> (f2 o f0)%functor}. + + Lemma p_composition_of_coherent_iso_for_rewrite__isisomorphism_helper' + : @IsIsomorphism + (_ -> _) _ _ + (n2 ^-1 o (f2 oL n1 ^-1 o (admit o (n0 oR f3 o n))))%natural_transformation. + Proof. + eapply isisomorphism_compose'; + [ eapply isisomorphism_inverse + | eapply isisomorphism_compose'; + [ admit + | eapply isisomorphism_compose'; + [ admit | + eapply isisomorphism_compose'; [ admit | ]]]]. + Set Printing All. Set Printing Universes. + apply @isisomorphism_isomorphic. + Qed. + +End lemmas. diff --git a/test-suite/bugs/closed/3424.v b/test-suite/bugs/closed/3424.v new file mode 100644 index 00000000..f9b2c386 --- /dev/null +++ b/test-suite/bugs/closed/3424.v @@ -0,0 +1,23 @@ +Set Universe Polymorphism. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Class Contr_internal (A : Type) := BuildContr { center : A ; contr : (forall y : A, center = y) }. +Inductive trunc_index : Type := minus_two | trunc_S (x : trunc_index). +Bind Scope trunc_scope with trunc_index. +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | minus_two => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. +Notation minus_one:=(trunc_S minus_two). +Notation "0" := (trunc_S minus_one) : trunc_scope. +Class IsTrunc (n : trunc_index) (A : Type) : Type := Trunc_is_trunc : IsTrunc_internal n A. +Notation IsHProp := (IsTrunc minus_one). +Notation IsHSet := (IsTrunc 0). +Goal forall (A : Type) (a b : A) (H' : IsHSet A), { x : Type & IsHProp x }. +Proof. +intros. +eexists. +(* exact (H' a b). *) +(* Undo. *) +apply (H' a b). +Qed. diff --git a/test-suite/bugs/closed/3427.v b/test-suite/bugs/closed/3427.v new file mode 100644 index 00000000..8483a4ec --- /dev/null +++ b/test-suite/bugs/closed/3427.v @@ -0,0 +1,195 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) +(* File reduced by coq-bug-finder from original input, then from 0 lines to 7171 lines, then from 7184 lines to 558 lines, then from 556 lines to 209 lines *) +Generalizable All Variables. +Set Universe Polymorphism. +Notation Type0 := Set. +Notation idmap := (fun x => x). +Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x). +Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope. +Open Scope function_scope. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Delimit Scope path_scope with path. +Local Open Scope path_scope. +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := match p, q with idpath, idpath => idpath end. +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x := match p with idpath => idpath end. +Notation "1" := idpath : path_scope. +Notation "p @ q" := (concat p q) (at level 20) : path_scope. +Notation "p ^" := (inverse p) (at level 3) : path_scope. +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := match p with idpath => u end. +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing) : path_scope. +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p with idpath => idpath end. +Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) := forall x:A, f x = g x. +Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope. +Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g) : forall x, f x = g x := fun x => match h with idpath => idpath end. +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { + equiv_inv : B -> A ; + eisretr : Sect equiv_inv f; + eissect : Sect f equiv_inv; + eisadj : forall x : A, eisretr (f x) = ap f (eissect x) + }. +Record Equiv A B := BuildEquiv { + equiv_fun :> A -> B ; + equiv_isequiv :> IsEquiv equiv_fun + }. + +Delimit Scope equiv_scope with equiv. + +Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope. + +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope. + +Class Contr_internal (A : Type) := BuildContr { + center : A ; + contr : (forall y : A, center = y) + }. + +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. + +Fixpoint nat_to_trunc_index (n : nat) : trunc_index + := match n with + | 0 => trunc_S (trunc_S minus_two) + | S n' => trunc_S (nat_to_trunc_index n') + end. + +Coercion nat_to_trunc_index : nat >-> trunc_index. + +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | minus_two => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. + +Notation minus_one:=(trunc_S minus_two). + +Class IsTrunc (n : trunc_index) (A : Type) : Type := + Trunc_is_trunc : IsTrunc_internal n A. + +Notation Contr := (IsTrunc minus_two). +Notation IsHProp := (IsTrunc minus_one). +Notation IsHSet := (IsTrunc 0). + +Class Funext := + { isequiv_apD10 :> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) }. + +Definition concat_pV {A : Type} {x y : A} (p : x = y) : + p @ p^ = 1 + := + match p with idpath => 1 end. + +Definition concat_Vp {A : Type} {x y : A} (p : x = y) : + p^ @ p = 1 + := + match p with idpath => 1 end. + +Definition transport_pp {A : Type} (P : A -> Type) {x y z : A} (p : x = y) (q : y = z) (u : P x) : + p @ q # u = q # p # u := + match q with idpath => + match p with idpath => 1 end + end. + +Definition transport2 {A : Type} (P : A -> Type) {x y : A} {p q : x = y} + (r : p = q) (z : P x) +: p # z = q # z + := ap (fun p' => p' # z) r. + +Inductive Unit : Type0 := + tt : Unit. + +Instance contr_unit : Contr Unit | 0 := let x := {| + center := tt; + contr := fun t : Unit => match t with tt => 1 end + |} in x. + +Instance trunc_succ `{IsTrunc n A} : IsTrunc (trunc_S n) A | 1000. +admit. +Defined. + +Record hProp := hp { hproptype :> Type ; isp : IsHProp hproptype}. +Definition Unit_hp:hProp:=(hp Unit _). + +Global Instance isequiv_ap_hproptype `{Funext} X Y : IsEquiv (@ap _ _ hproptype X Y). +admit. +Defined. + +Definition path_hprop `{Funext} X Y := (@ap _ _ hproptype X Y)^-1%equiv. + +Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. +Local Open Scope equiv_scope. + +Instance isequiv_path {A B : Type} (p : A = B) +: IsEquiv (transport (fun X:Type => X) p) | 0 + := BuildIsEquiv _ _ _ (transport (fun X:Type => X) p^) + (fun b => ((transport_pp idmap p^ p b)^ @ transport2 idmap (concat_Vp p) b)) + (fun a => ((transport_pp idmap p p^ a)^ @ transport2 idmap (concat_pV p) a)) + (fun a => match p in _ = C return + (transport_pp idmap p^ p (transport idmap p a))^ @ + transport2 idmap (concat_Vp p) (transport idmap p a) = + ap (transport idmap p) ((transport_pp idmap p p^ a) ^ @ + transport2 idmap (concat_pV p) a) with idpath => 1 end). + +Definition equiv_path (A B : Type) (p : A = B) : A <~> B + := BuildEquiv _ _ (transport (fun X:Type => X) p) _. + +Class Univalence := { + isequiv_equiv_path :> forall (A B : Type), IsEquiv (equiv_path A B) + }. + +Section Univalence. + Context `{Univalence}. + + Definition path_universe_uncurried {A B : Type} (f : A <~> B) : A = B + := (equiv_path A B)^-1 f. +End Univalence. + +Local Inductive minus1Trunc (A :Type) : Type := + min1 : A -> minus1Trunc A. + +Instance minus1Trunc_is_prop {A : Type} : IsHProp (minus1Trunc A) | 0. +admit. +Defined. + +Definition hexists {X} (P:X->Type):Type:= minus1Trunc (sigT P). + +Section AssumingUA. + + Definition isepi {X Y} `(f:X->Y) := forall Z: hSet, + forall g h: Y -> Z, g o f = h o f -> g = h. + Context {X Y : hSet} (f : X -> Y) (Hisepi : isepi f). + + Goal forall (X Y : hSet) (f : forall _ : setT X, setT Y), + let fib := + fun y : setT Y => + hp (@hexists (setT X) (fun x : setT X => @paths (setT Y) (f x) y)) + (@minus1Trunc_is_prop + (@sigT (setT X) (fun x : setT X => @paths (setT Y) (f x) y))) in + forall (x : setT X) (_ : Univalence) (_ : Funext), + @paths hProp (fib (f x)) Unit_hp. + intros. + + apply path_hprop. + simpl. + Set Printing Universes. + Set Printing All. + refine (path_universe_uncurried _). + Undo. + apply path_universe_uncurried. (* Toplevel input, characters 21-44: +Error: Refiner was given an argument + "@path_universe_uncurried (* Top.425 Top.426 Top.427 Top.428 Top.429 *) X1 + (@hexists (* Top.405 Top.404 Set Set *) (setT (* Top.405 *) X0) + (fun x0 : setT (* Top.405 *) X0 => + @paths (* Top.404 *) (setT (* Top.404 *) Y0) (f0 x0) (f0 x))) Unit + ?63" of type + "@paths (* Top.428 *) Type (* Top.425 *) + (@hexists (* Top.405 Top.404 Set Set *) (setT (* Top.405 *) X0) + (fun x0 : setT (* Top.405 *) X0 => + @paths (* Top.404 *) (setT (* Top.404 *) Y0) (f0 x0) (f0 x))) Unit" +instead of + "@paths (* Top.413 *) Type (* Set *) + (@hexists (* Top.405 Top.404 Set Set *) (setT (* Top.405 *) X0) + (fun x0 : setT (* Top.405 *) X0 => + @paths (* Top.404 *) (setT (* Top.404 *) Y0) (f0 x0) (f0 x))) Unit". + *) diff --git a/test-suite/bugs/closed/3428.v b/test-suite/bugs/closed/3428.v new file mode 100644 index 00000000..3eb75e43 --- /dev/null +++ b/test-suite/bugs/closed/3428.v @@ -0,0 +1,35 @@ +(* File reduced by coq-bug-finder from original input, then from 2809 lines to 39 lines *) +Set Primitive Projections. +Set Implicit Arguments. +Module Export foo. + Record prod (A B : Type) := pair { fst : A ; snd : B }. +End foo. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p with idpath => idpath end. +Axiom path_prod : forall {A B : Type} (z z' : prod A B), (fst z = fst z') -> (snd z = snd z') -> (z = z'). +Notation fst := (@fst _ _). +Notation snd := (@snd _ _). +Definition ap_fst_path_prod {A B : Type} {z z' : prod A B} (p : @paths A (fst z) (fst z')) (q : snd z = snd z') +: ap fst (path_prod z z' p q) = p. +Abort. + +Notation fstp x := (x.(foo.fst)). +Notation fstap x := (foo.fst x). + +Definition ap_fst_path_prod' {A B : Type} {z z' : prod A B} (p : @paths A (fst z) (fst z')) (q : snd z = snd z') +: ap (fun x => fstap x) (path_prod z z' p q) = p. + +Abort. + +(* Toplevel input, characters 137-138: +Error: +In environment +A : Type +B : Type +z : prod A B +z' : prod A B +p : @paths A (foo.fst ?11 ?14 z) (foo.fst ?26 ?29 z') +q : @paths ?54 (foo.snd ?42 ?45 z) (foo.snd ?57 ?60 z') +The term "p" has type "@paths A (foo.fst ?11 ?14 z) (foo.fst ?26 ?29 z')" +while it is expected to have type "@paths A (foo.fst z) (foo.fst z')". *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/3439.v b/test-suite/bugs/closed/3439.v new file mode 100644 index 00000000..bba6140f --- /dev/null +++ b/test-suite/bugs/closed/3439.v @@ -0,0 +1,43 @@ +(* File reduced by coq-bug-finder from original input, then from 3154 lines to 149 lines, then from 89 lines to 55 lines, then from 44 lines to 20 lines *) +Set Primitive Projections. +Generalizable All Variables. +Axiom IsHSet : Type -> Type. +Existing Class IsHSet. +Record PreCategory := { object :> Type }. +Notation IsStrictCategory C := (IsHSet (object C)). +Instance trunc_prod `{IsHSet A} `{IsHSet B} : IsHSet (A * B) | 100. +admit. +Defined. +Typeclasses Transparent object. +Definition prod (C D : PreCategory) : PreCategory := Build_PreCategory (Datatypes.prod C D). +Global Instance isstrict_category_product `{IsStrictCategory C, IsStrictCategory D} : IsStrictCategory (prod C D). +Proof. + typeclasses eauto. +Defined. + + +Set Typeclasses Debug. +(* File reduced by coq-bug-finder from original input, then from 7425 lines to 154 lines, then from 116 lines to 20 lines *) +Class Contr (A : Type) := { center : A }. +Instance contr_unit : Contr unit | 0 := {| center := tt |}. +Module non_prim. + Unset Primitive Projections. + Record PreCategory := { object :> Type }. + Lemma foo : Contr (object (@Build_PreCategory unit)). + Proof. + solve [ simpl; typeclasses eauto ] || fail "goal not solved". + Undo. + solve [ typeclasses eauto ]. + Defined. +End non_prim. + +Module prim. + Set Primitive Projections. + Record PreCategory := { object :> Type }. + Lemma foo : Contr (object (@Build_PreCategory unit)). + Proof. + solve [ simpl; typeclasses eauto ] || fail "goal not solved". + Undo. + solve [ typeclasses eauto ]. (* Error: No applicable tactic. *) + Defined. +End prim.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3453.v b/test-suite/bugs/closed/3453.v new file mode 100644 index 00000000..4ee9b400 --- /dev/null +++ b/test-suite/bugs/closed/3453.v @@ -0,0 +1,10 @@ +Set Primitive Projections. +Record Foo := { bar : Set }. +Class Baz (F : Foo) := { qux : F.(bar) }. +Coercion qux : Baz >-> bar. + +Definition f : Foo := {| bar := nat |}. +Canonical Structure f. +Check (fun b : Baz f => b : _.(bar)). + +(* Error: Found target class bar instead of bar. *) diff --git a/test-suite/bugs/closed/3454.v b/test-suite/bugs/closed/3454.v new file mode 100644 index 00000000..ca4d2380 --- /dev/null +++ b/test-suite/bugs/closed/3454.v @@ -0,0 +1,63 @@ +Set Primitive Projections. +Set Implicit Arguments. + +Record prod {A} {B}:= pair { fst : A ; snd : B }. +Notation " A * B " := (@prod A B) : type_scope. +Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }. +Notation pr1 := (@projT1 _ _). +Arguments prod : clear implicits. + +Check (@projT1 _ (fun x : nat => x = x)). +Check (fun s : @sigT nat (fun x : nat => x = x) => s.(projT1)). + +Record rimpl {b : bool} {n : nat} := { foo : forall {x : nat}, x = n }. + +Check (fun r : @rimpl true 0 => r.(foo) (x:=0)). +Check (fun r : @rimpl true 0 => @foo true 0 r 0). +Check (fun r : @rimpl true 0 => foo r (x:=0)). +Check (fun r : @rimpl true 0 => @foo _ _ r 0). +Check (fun r : @rimpl true 0 => r.(@foo _ _)). +Check (fun r : @rimpl true 0 => r.(foo)). + +Notation "{ x : T & P }" := (@sigT T P). +Notation "{ x : A & P }" := (sigT (A:=A) (fun x => P)) : type_scope. +(* Notation "{ x : T * U & P }" := (@sigT (T * U) P). *) + +Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x). +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Class IsEquiv {A B : Type} (f : A -> B) := {}. + +Local Instance isequiv_tgt_compose A B +: @IsEquiv (A -> {xy : B * B & fst xy = snd xy}) + (A -> B) + (@compose A {xy : B * B & fst xy = snd xy} B + (@compose {xy : B * B & fst xy = snd xy} _ B (@snd B B) pr1)). +(* Toplevel input, characters 220-223: *) +(* Error: Cannot infer this placeholder. *) + +Local Instance isequiv_tgt_compose' A B +: @IsEquiv (A -> {xy : B * B & fst xy = snd xy}) + (A -> B) + (@compose A {xy : B * B & fst xy = snd xy} B (@compose {xy : B * B & fst xy = snd xy} _ B (@snd _ _) pr1)). +(* Toplevel input, characters 221-232: *) +(* Error: *) +(* In environment *) +(* A : Type *) +(* B : Type *) +(* The term "pr1" has type "sigT ?30 -> ?29" while it is expected to have type *) +(* "{xy : B * B & fst xy = snd xy} -> ?27 * B". *) + +Local Instance isequiv_tgt_compose'' A B +: @IsEquiv (A -> {xy : B * B & fst xy = snd xy}) + (A -> B) + (@compose A {xy : B * B & fst xy = snd xy} B (@compose {xy : B * B & fst xy = snd xy} _ B (@snd _ _) + (fun s => s.(projT1)))). +(* Toplevel input, characters 15-241: +Error: +Cannot infer an internal placeholder of type "Type" in environment: + +A : Type +B : Type +x : ?32 +. *) diff --git a/test-suite/bugs/closed/3469.v b/test-suite/bugs/closed/3469.v new file mode 100644 index 00000000..b09edc65 --- /dev/null +++ b/test-suite/bugs/closed/3469.v @@ -0,0 +1,29 @@ +(* File reduced by coq-bug-finder from original input, then from 538 lines to 31 lines *) +Open Scope type_scope. +Global Set Primitive Projections. +Set Implicit Arguments. +Record sig (A : Type) (P : A -> Type) := exist { proj1_sig : A ; proj2_sig : P proj1_sig }. +Notation sigT := sig (only parsing). +Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope. +Notation projT1 := proj1_sig (only parsing). +Notation projT2 := proj2_sig (only parsing). +Variables X : Type. +Variable R : X -> X -> Type. +Lemma dependent_choice : + (forall x:X, {y : _ & R x y}) -> + forall x0, {f : nat -> X & (f O = x0) * (forall n, R (f n) (f (S n)))}. +Proof. + intros H x0. + set (f:=fix f n := match n with O => x0 | S n' => projT1 (H (f n')) end). + exists f. + split. + reflexivity. + induction n; simpl in *. + clear. + apply (proj2_sig (H x0)). + Undo. + apply @proj2_sig. + + +(* Toplevel input, characters 21-31: +Error: Found no subterm matching "proj1_sig ?206" in the current *) diff --git a/test-suite/bugs/closed/3477.v b/test-suite/bugs/closed/3477.v new file mode 100644 index 00000000..e9414864 --- /dev/null +++ b/test-suite/bugs/closed/3477.v @@ -0,0 +1,9 @@ +Set Primitive Projections. +Set Implicit Arguments. +Record prod A B := pair { fst : A ; snd : B }. +Goal forall A B : Set, True. +Proof. + intros A B. + evar (a : prod A B); evar (f : (prod A B -> Set)). + let a' := (eval unfold a in a) in + set(foo:=eq_refl : a' = (@pair _ _ (fst a') (snd a'))).
\ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/348.v b/test-suite/bugs/closed/348.v index 28cc5cb1..28cc5cb1 100644 --- a/test-suite/bugs/closed/shouldsucceed/348.v +++ b/test-suite/bugs/closed/348.v diff --git a/test-suite/bugs/closed/3480.v b/test-suite/bugs/closed/3480.v new file mode 100644 index 00000000..99ac2efa --- /dev/null +++ b/test-suite/bugs/closed/3480.v @@ -0,0 +1,47 @@ +Set Primitive Projections. +Axiom admit : forall {T}, T. +Notation "( x ; y )" := (existT _ x y) : fibration_scope. +Open Scope fibration_scope. +Notation "x .1" := (projT1 x) (at level 3) : fibration_scope. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Set Implicit Arguments. +Delimit Scope category_scope with category. +Record PreCategory := { object :> Type ; morphism : object -> object -> Type }. +Local Open Scope category_scope. +Class IsIsomorphism {C : PreCategory} {s d} (m : morphism C s d) := { morphism_inverse : morphism C d s }. +Class Isomorphic {C : PreCategory} s d := { morphism_isomorphic :> @morphism C s d ; isisomorphism_isomorphic :> IsIsomorphism morphism_isomorphic }. +Coercion morphism_isomorphic : Isomorphic >-> morphism. +Local Infix "<~=~>" := Isomorphic (at level 70, no associativity) : category_scope. +Definition idtoiso (C : PreCategory) (x y : C) (H : x = y) : Isomorphic x y := admit. +Record NotionOfStructure (X : PreCategory) := { structure :> X -> Type }. +Record Smorphism (X : PreCategory) (P : NotionOfStructure X) (xa yb : { x : X & P x }) := { f : morphism X xa.1 yb.1 }. +Definition precategory_of_structures X (P : NotionOfStructure X) : PreCategory. +Proof. + refine (@Build_PreCategory _ (@Smorphism _ P)). +Defined. +Section sip. + Variable X : PreCategory. + Variable P : NotionOfStructure X. + + Let StrX := @precategory_of_structures X P. + + Definition sip_isotoid (xa yb : StrX) (f : xa <~=~> yb) : xa = yb. + admit. + Defined. + + Lemma structure_identity_principle_helper (xa yb : StrX) + (x : xa <~=~> yb) : Smorphism P xa yb. + Proof. + refine ((idtoiso (precategory_of_structures P) (sip_isotoid x) : @morphism _ _ _) : morphism _ _ _). +(* Toplevel input, characters 24-95: +Error: +In environment +X : PreCategory +P : NotionOfStructure X +StrX := precategory_of_structures P : PreCategory +xa : object StrX +yb : object StrX +x : xa <~=~> yb +The term "morphism_isomorphic:@morphism (precategory_of_structures P) xa yb" +has type "@morphism (precategory_of_structures P) xa yb" +while it is expected to have type "morphism ?40 ?41 ?42". *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/3481.v b/test-suite/bugs/closed/3481.v new file mode 100644 index 00000000..89d476dc --- /dev/null +++ b/test-suite/bugs/closed/3481.v @@ -0,0 +1,70 @@ + +Set Implicit Arguments. + +Require Import Logic. +Module NonPrim. +Local Set Record Elimination Schemes. +Record prodwithlet (A B : Type) : Type := + pair' { fst : A; fst' := fst; snd : B }. + +Definition letreclet (p : prodwithlet nat nat) := + let (x, x', y) := p in x + y. + +Definition pletreclet (p : prodwithlet nat nat) := + let 'pair' x x' y := p in x + y + x'. + +Definition pletreclet2 (p : prodwithlet nat nat) := + let 'pair' x y := p in x + y. + +Check (pair 0 0). +End NonPrim. + +Global Set Universe Polymorphism. +Global Set Asymmetric Patterns. +Local Set Record Elimination Schemes. +Local Set Primitive Projections. + +Record prod (A B : Type) : Type := + pair { fst : A; snd : B }. + +Print prod_rect. + +(* What I really want: *) +Definition prod_rect' A B (P : prod A B -> Type) (u : forall (fst : A) (snd : B), P (pair fst snd)) + (p : prod A B) : P p + := u (fst p) (snd p). + +Definition conv : @prod_rect = @prod_rect'. +Proof. reflexivity. Defined. + +Definition imposs := + (fun A B P f (p : prod A B) => match p as p0 return P p0 with + | {| fst := x ; snd := x0 |} => f x x0 + end). + +Definition letrec (p : prod nat nat) := + let (x, y) := p in x + y. +Eval compute in letrec (pair 1 5). + +Goal forall p : prod nat nat, letrec p = fst p + snd p. +Proof. + reflexivity. + Undo. + intros p. + case p. simpl. unfold letrec. simpl. reflexivity. +Defined. + +Eval compute in conv. (* = eq_refl + : prod_rect = prod_rect' *) + +Check eq_refl : @prod_rect = @prod_rect'. (* Toplevel input, characters 6-13: +Error: +The term "eq_refl" has type "prod_rect = prod_rect" +while it is expected to have type "prod_rect = prod_rect'" +(cannot unify "prod_rect" and "prod_rect'"). *) + +Record sigma (A : Type) (B : A -> Type) : Type := + dpair { pi1 : A ; pi2 : B pi1 }. + + + diff --git a/test-suite/bugs/closed/3482.v b/test-suite/bugs/closed/3482.v new file mode 100644 index 00000000..34a5e73d --- /dev/null +++ b/test-suite/bugs/closed/3482.v @@ -0,0 +1,11 @@ +Set Primitive Projections. +Class Foo (F : False) := { foo : True }. +Arguments foo F {Foo}. +Print Implicit foo. (* foo : forall F : False, Foo F -> True + +Argument Foo is implicit and maximally inserted *) +Check foo _. (* Toplevel input, characters 6-11: +Error: Illegal application (Non-functional construction): +The expression "foo" of type "True" +cannot be applied to the term + "?36" : "?35" *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/3483.v b/test-suite/bugs/closed/3483.v new file mode 100644 index 00000000..2cc66186 --- /dev/null +++ b/test-suite/bugs/closed/3483.v @@ -0,0 +1,5 @@ +(* Check proper failing when using notation of non-constructors in + pattern-bmatching *) + +Fail Definition nonsense ( x : False ) := match x with y + 2 => 0 end. + diff --git a/test-suite/bugs/closed/3484.v b/test-suite/bugs/closed/3484.v new file mode 100644 index 00000000..6c40a426 --- /dev/null +++ b/test-suite/bugs/closed/3484.v @@ -0,0 +1,30 @@ +(* File reduced by coq-bug-finder from original input, then from 14259 lines to 305 lines, then from 237 lines to 120 lines, then from 100 lines to 30 lines *) +Set Primitive Projections. +Set Implicit Arguments. +Record sigT (A : Type) (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }. +Notation "{ x : A & P }" := (@sigT A (fun x : A => P)) : type_scope. +Notation pr1 := (@projT1 _ _). +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p with idpath => idpath end. +Goal forall (T : Type) (H : { g : T & g = g }) (x : T), projT1 H = projT1 (existT (fun g : T => g = g) x idpath). +Proof. + intros. + let y := match goal with |- projT1 ?x = projT1 ?y => constr:(y) end in + apply (@ap _ _ pr1 _ y). + Undo. + Unset Printing Notations. + apply (ap pr1). + Undo. + refine (ap pr1 _). +admit. +Defined. + +(* Toplevel input, characters 22-28: +Error: +In environment +T : Type +H : sigT T (fun g : T => paths g g) +x : T +Unable to unify "paths (@projT1 ?24 ?23 ?25) (@projT1 ?24 ?23 ?26)" with + "paths (projT1 H) (projT1 {| projT1 := x; projT2 := idpath |})". *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/3485.v b/test-suite/bugs/closed/3485.v new file mode 100644 index 00000000..ede6b3cb --- /dev/null +++ b/test-suite/bugs/closed/3485.v @@ -0,0 +1,133 @@ +Set Universe Polymorphism. +Set Primitive Projections. +Reserved Infix "o" (at level 40, left associativity). +Definition relation (A : Type) := A -> A -> Type. +Class Transitive {A} (R : relation A) := transitivity : forall x y z, R x y -> R y z -> R x z. +Tactic Notation "etransitivity" open_constr(y) := + let R := match goal with |- ?R ?x ?z => constr:(R) end in + let x := match goal with |- ?R ?x ?z => constr:(x) end in + let z := match goal with |- ?R ?x ?z => constr:(z) end in + refine (@transitivity _ R _ x y z _ _). +Tactic Notation "etransitivity" := etransitivity _. +Notation "( x ; y )" := (existT _ x y) : fibration_scope. +Open Scope fibration_scope. +Notation "x .1" := (projT1 x) (at level 3) : fibration_scope. +Notation "x .2" := (projT2 x) (at level 3) : fibration_scope. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := match p, q with idpath, idpath => idpath end. +Instance transitive_paths {A} : Transitive (@paths A) | 0 := @concat A. +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := match p with idpath => u end. +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. +Class Contr_internal (A : Type) := { center : A ; contr : (forall y : A, center = y) }. +Generalizable Variables X A B C f g n. +Definition projT1_path `{P : A -> Type} {u v : sigT P} (p : u = v) : u.1 = v.1 := ap (@projT1 _ _) p. +Notation "p ..1" := (projT1_path p) (at level 3) : fibration_scope. +Ltac simpl_do_clear tac term := + let H := fresh in + assert (H := term); + simpl in H |- *; + tac H; + clear H. +Set Implicit Arguments. +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope object_scope with object. +Record PreCategory := + { object :> Type; + morphism : object -> object -> Type; + + identity : forall x, morphism x x; + compose : forall s d d', + morphism d d' + -> morphism s d + -> morphism s d' + where "f 'o' g" := (compose f g); + + left_identity : forall a b (f : morphism a b), identity b o f = f; + right_identity : forall a b (f : morphism a b), f o identity a = f }. +Arguments identity {C%category} / x%object : rename. +Arguments compose {C%category} / {s d d'}%object (m1 m2)%morphism : rename. +Infix "o" := compose : morphism_scope. +Notation "1" := (identity _) : morphism_scope. +Delimit Scope functor_scope with functor. +Local Open Scope morphism_scope. +Record Functor (C D : PreCategory) := + { object_of :> C -> D; + morphism_of : forall s d, morphism C s d + -> morphism D (object_of s) (object_of d); + identity_of : forall x, morphism_of _ _ (identity x) + = identity (object_of x) }. +Bind Scope functor_scope with Functor. +Arguments morphism_of [C%category] [D%category] F%functor / [s%object d%object] m%morphism : rename. +Notation "F '_1' m" := (morphism_of F m) (at level 10, no associativity) : morphism_scope. +Section composition. + Variable C : PreCategory. + Variable D : PreCategory. + Variable E : PreCategory. + Variable G : Functor D E. + Variable F : Functor C D. + + Local Notation c_object_of c := (G (F c)) (only parsing). + Local Notation c_morphism_of m := (morphism_of G (morphism_of F m)) (only parsing). + + Definition compose_identity_of x + : c_morphism_of (identity x) = identity (c_object_of x) + := transport (@paths _ _) + (identity_of G _) + (ap (@morphism_of _ _ G _ _) (identity_of F x)). + + Definition composeF : Functor C E + := Build_Functor + C E + (fun c => G (F c)) + (fun _ _ m => morphism_of G (morphism_of F m)) + compose_identity_of. +End composition. +Infix "o" := composeF : functor_scope. + +Definition identityF C : Functor C C + := Build_Functor C C + (fun x => x) + (fun _ _ x => x) + (fun _ => idpath). +Notation "1" := (identityF _) : functor_scope. + +Record NaturalTransformation C D (F G : Functor C D) := { components_of :> forall c, morphism D (F c) (G c) }. + +Section unit. + Variable C : PreCategory. + Variable D : PreCategory. + Variable F : Functor C D. + Variable G : Functor D C. + + Definition AdjunctionUnit := + { T : NaturalTransformation 1 (G o F) + & forall (c : C) (d : D) (f : morphism C c (G d)), + Contr_internal { g : morphism D (F c) d & G _1 g o T c = f } + }. +End unit. +Variable C : PreCategory. +Variable D : PreCategory. +Variable F : Functor C D. +Variable G : Functor D C. + +Definition zig__of__adjunction_unit + (A : AdjunctionUnit F G) + (Y : C) + (eta := A.1) + (eps := fun X => (@center _ (A.2 (G X) X 1)).1) +: G _1 (eps (F Y) o F _1 (eta Y)) o eta Y = eta Y + -> eps (F Y) o F _1 (eta Y) = 1. +Proof. + intros. + etransitivity; [ symmetry | ]; + simpl_do_clear + ltac:(fun H => apply H) + (fun y H => (@contr _ (A.2 _ _ (A.1 Y)) (y; H))..1); + try assumption. + simpl. + rewrite ?@identity_of, ?@left_identity, ?@right_identity; + reflexivity. +Qed. diff --git a/test-suite/bugs/closed/3487.v b/test-suite/bugs/closed/3487.v new file mode 100644 index 00000000..03c60a8b --- /dev/null +++ b/test-suite/bugs/closed/3487.v @@ -0,0 +1,8 @@ +Notation bar := $(exact I)$. +Notation foo := bar (only parsing). +Class baz := { x : False }. +Instance: baz. +Admitted. +Definition baz0 := ((_ : baz) = (_ : baz)). +Definition foo1 := (foo = foo). +Definition baz1 := prod ((_ : baz) = (_ : baz)) (foo = foo). diff --git a/test-suite/bugs/closed/3505.v b/test-suite/bugs/closed/3505.v new file mode 100644 index 00000000..2695bc79 --- /dev/null +++ b/test-suite/bugs/closed/3505.v @@ -0,0 +1,44 @@ +(* File reduced by coq-bug-finder from original input, then from 7421 lines to 6082 lines, then from 5860 lines to 5369 lines, then from 5300 lines to 165 lines, then from 111 lines to 38 lines *) +Set Implicit Arguments. +Record PreCategory := + { object :> Type; + morphism : object -> object -> Type; + identity : forall x, morphism x x }. +Bind Scope category_scope with PreCategory. +Local Notation "1" := (identity _ _) : morphism_scope. +Local Open Scope morphism_scope. +Definition prod (C D : PreCategory) : PreCategory + := @Build_PreCategory + (C * D)%type + (fun s d => (morphism C (fst s) (fst d) * morphism D (snd s) (snd d))%type) + (fun x => (identity _ (fst x), identity _ (snd x))). +Local Infix "*" := prod : category_scope. +Module NonPrim. + Record Functor (C D : PreCategory) := + { object_of :> C -> D; + morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d); + identity_of : forall x, morphism_of _ _ (identity _ x) = identity _ (object_of x) }. + Notation "F '_1' m" := (morphism_of F _ _ m) (at level 10, no associativity) : morphism_scope. + Goal forall C1 C2 D (F : Functor (C1 * C2) D) x, F _1 (1, 1) = identity _ (F x). + Proof. + intros. + rewrite identity_of. + reflexivity. + Qed. +End NonPrim. +Module Prim. + Set Primitive Projections. + Record Functor (C D : PreCategory) := + { object_of :> C -> D; + morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d); + identity_of : forall x, morphism_of _ _ (identity _ x) = identity _ (object_of x) }. + Notation "F '_1' m" := (morphism_of F _ _ m) (at level 10, no associativity) : morphism_scope. + Goal forall C1 C2 D (F : Functor (C1 * C2) D) x, F _1 (1, 1) = identity _ (F x). + Proof. + intros. + rewrite identity_of. (* Toplevel input, characters 0-20: +Error: +Found no subterm matching "morphism_of ?192 ?193 ?193 (identity ?190 ?193)" in the current goal. *) + reflexivity. + Qed. +End Prim. diff --git a/test-suite/bugs/closed/3520.v b/test-suite/bugs/closed/3520.v new file mode 100644 index 00000000..c981207e --- /dev/null +++ b/test-suite/bugs/closed/3520.v @@ -0,0 +1,12 @@ +Set Primitive Projections. + +Record foo (A : Type) := + { bar : Type ; baz := Set; bad : baz = bar }. + +Set Record Elimination Schemes. + +Record notprim : Prop := + { irrel : True; relevant : nat }. + + + diff --git a/test-suite/bugs/closed/3531.v b/test-suite/bugs/closed/3531.v new file mode 100644 index 00000000..fd080a6b --- /dev/null +++ b/test-suite/bugs/closed/3531.v @@ -0,0 +1,53 @@ +(* File reduced by coq-bug-finder from original input, then from 270 lines to +198 lines, then from 178 lines to 82 lines, then from 88 lines to 59 lines *) +(* coqc version trunk (August 2014) compiled on Aug 19 2014 14:40:15 with OCaml +4.01.0 + coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk +(56ece74efc25af1b0e09265f3c7fcf74323abcaf) *) +Require Import Coq.Lists.List. +Set Implicit Arguments. +Definition mem := nat -> option nat. +Definition pred := mem -> Prop. +Delimit Scope pred_scope with pred. +Definition exis A (p : A -> pred) : pred := fun m => exists x, p x m. +Notation "'exists' x .. y , p" := (exis (fun x => .. (exis (fun y => p)) ..)) : +pred_scope. +Definition emp : pred := fun m => forall a, m a = None. +Definition lift_empty (P : Prop) : pred := fun m => P /\ forall a, m a = None. +Notation "[[ P ]]" := (lift_empty P) : pred_scope. +Definition pimpl (p q : pred) := forall m, p m -> q m. +Notation "p ==> q" := (pimpl p%pred q%pred) (right associativity, at level 90). +Definition piff (p q : pred) : Prop := (p ==> q) /\ (q ==> p). +Notation "p <==> q" := (piff p%pred q%pred) (at level 90). +Parameter sep_star : pred -> pred -> pred. +Infix "*" := sep_star : pred_scope. +Definition memis (m : mem) : pred := eq m. +Definition mptsto (m : mem) (a : nat) (v : nat) := m a = Some v. +Notation "m @ a |-> v" := (mptsto m a v) (a at level 34, at level 35). +Lemma piff_trans: forall a b c, (a <==> b) -> (b <==> c) -> (a <==> c). +Admitted. +Lemma piff_refl: forall a, (a <==> a). +Admitted. +Definition stars (ps : list pred) := fold_left sep_star ps emp. +Lemma flatten_exists: forall T PT p ps P, + (forall (a:T), (p a <==> exists (x:PT), stars (ps a x) * [[P a x]])) + -> (exists (a:T), p a) <==> + (exists (x:(T*PT)), stars (ps (fst x) (snd x)) * [[P (fst x) (snd x)]]). +Admitted. +Goal forall b, (exists e1 e2 e3, + (exists (m : mem) (v : nat) (F : pred), b) + <==> (exists x : e1, stars (e2 x) * [[e3 x]])). + intros. + Set Printing Universes. + Show Universes. + do 3 eapply ex_intro. + eapply piff_trans; [ apply flatten_exists | apply piff_refl ]; intros. + eapply piff_trans; [ apply flatten_exists | apply piff_refl ]; intros. + eapply piff_trans; [ apply flatten_exists | apply piff_refl ]; intros. + assert (H : False) by (clear; admit); destruct H. + Grab Existential Variables. + admit. + admit. + admit. + Show Universes. +Time Qed.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3537.v b/test-suite/bugs/closed/3537.v new file mode 100644 index 00000000..158642f0 --- /dev/null +++ b/test-suite/bugs/closed/3537.v @@ -0,0 +1,12 @@ +(* Another instance of bug #3262, on looping in unification *) + +Inductive bool := true | false. + +Inductive RBT2 : forall a:bool, Type := + Full2 : forall (a b c n:bool), + forall H:RBT2 n, RBT2 n. + +Definition balance4 color p q r := + match color, p, q, r with + | _,_,_,_ => Full2 color p q r + end. diff --git a/test-suite/bugs/closed/3539.v b/test-suite/bugs/closed/3539.v new file mode 100644 index 00000000..c862965d --- /dev/null +++ b/test-suite/bugs/closed/3539.v @@ -0,0 +1,66 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter" "-no-native-compiler") -*- *) +(* File reduced by coq-bug-finder from original input, then from 11678 lines to 11330 lines, then from 10721 lines to 9544 lines, then from 9549 lines to 794 lines, then from 810 lines to 785 lines, then from 628 lines to 246 lines, then from 220 lines to 89 lines, then from 80 lines to 47 lines *) +(* coqc version trunk (August 2014) compiled on Aug 22 2014 4:17:28 with OCaml 4.01.0 + coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (a67cc6941434124465f20b14a1256f2ede31a60e) *) + +Set Implicit Arguments. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := match p with idpath => u end. +Local Set Primitive Projections. +Record prod (A B : Type) := pair { fst : A ; snd : B }. +Notation "x * y" := (prod x y) : type_scope. +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. +Axiom path_prod : forall {A B : Type} (z z' : A * B), (fst z = fst z') -> (snd z = snd z') -> (z = z'). +Axiom transport_path_prod : forall A B (P : A * B -> Type) (x y : A * B) (HA : fst x = fst y) (HB : snd x = snd y) Px, + transport P (path_prod _ _ HA HB) Px + = transport (fun x => P (x, snd y)) HA (transport (fun y => P (fst x, y)) HB Px). +Goal forall (T0 : Type) (snd1 snd0 f : T0) (p : @paths T0 f snd0) + (f0 : T0) (p1 : @paths T0 f0 snd1) (T1 : Type) + (fst1 fst0 : T1) (p0 : @paths T1 fst0 fst0) (p2 : @paths T1 fst1 fst1) + (T : Type) (x2 : T) (T2 : Type) (T3 : forall (_ : T2) (_ : T2), Type) + (x' : forall (_ : T1) (_ : T), T2) (m : T3 (x' fst1 x2) (x' fst0 x2)), + @paths (T3 (x' fst1 x2) (x' fst0 x2)) + (@transport (prod T1 T0) + (fun x : prod T1 T0 => + T3 (x' fst1 x2) (x' (fst x) x2)) + (@pair T1 T0 fst0 f) (@pair T1 T0 fst0 snd0) + (@path_prod T1 T0 (@pair T1 T0 fst0 f) + (@pair T1 T0 fst0 snd0) p0 p) + (@transport (prod T1 T0) + (fun x : prod T1 T0 => + T3 (x' (fst x) x2) (x' fst0 x2)) + (@pair T1 T0 fst1 f0) (@pair T1 T0 fst1 snd1) + (@path_prod T1 T0 (@pair T1 T0 fst1 f0) + (@pair T1 T0 fst1 snd1) p2 p1) m)) m. + intros. + match goal with + | [ |- context[transport ?P (path_prod ?x ?y ?HA ?HB) ?Px] ] + => rewrite (transport_path_prod P x y HA HB Px) + end || fail "bad". + Undo. + Set Printing All. + rewrite transport_path_prod. (* Toplevel input, characters 15-43: +Error: +In environment +T0 : Type +snd1 : T0 +snd0 : T0 +f : T0 +p : @paths T0 f snd0 +f0 : T0 +p1 : @paths T0 f0 snd1 +T1 : Type +fst1 : T1 +fst0 : T1 +p0 : @paths T1 fst0 fst0 +p2 : @paths T1 fst1 fst1 +T : Type +x2 : T +T2 : Type +T3 : forall (_ : T2) (_ : T2), Type +x' : forall (_ : T1) (_ : T), T2 +m : T3 (x' fst1 x2) (x' fst0 x2) +Unable to unify "?25 (@pair ?23 ?24 (fst ?27) (snd ?27))" with +"?25 ?27". + *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/3542.v b/test-suite/bugs/closed/3542.v new file mode 100644 index 00000000..b6837a0c --- /dev/null +++ b/test-suite/bugs/closed/3542.v @@ -0,0 +1,6 @@ +Section foo. + Context {A:Type} {B : A -> Type}. + Context (f : forall x, B x). + Goal True. + pose (r := fun k => existT (fun g => forall x, f x = g x) + (fun x => projT1 (k x)) (fun x => projT2 (k x))). diff --git a/test-suite/bugs/closed/3546.v b/test-suite/bugs/closed/3546.v new file mode 100644 index 00000000..55d718bd --- /dev/null +++ b/test-suite/bugs/closed/3546.v @@ -0,0 +1,17 @@ +Set Primitive Projections. +Record prod A B := pair { fst : A ; snd : B }. +Arguments pair {_ _} _ _. +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. +Definition ap11 {A B} {f g:A->B} (h:f=g) {x y:A} (p:x=y) : f x = g y. +Admitted. +Goal forall x y z w : Set, (x, y) = (z, w). +Proof. + intros. + apply ap11. (* Toplevel input, characters 21-25: +Error: In environment +x : Set +y : Set +z : Set +w : Set +Unable to unify "?31 ?191 = ?32 ?192" with "(x, y) = (z, w)". + *) diff --git a/test-suite/bugs/closed/3559.v b/test-suite/bugs/closed/3559.v new file mode 100644 index 00000000..50645090 --- /dev/null +++ b/test-suite/bugs/closed/3559.v @@ -0,0 +1,86 @@ +(* File reduced by coq-bug-finder from original input, then from 8657 lines to +4731 lines, then from 4174 lines to 192 lines, then from 161 lines to 55 lines, +then from 51 lines to 37 lines, then from 43 lines to 30 lines *) +(* coqc version trunk (August 2014) compiled on Aug 31 2014 10:12:32 with OCaml +4.01.0 + coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk +(437b91a3ffd7327975a129b95b24d3f66ad7f3e4) *) +Require Import Coq.Init.Notations. +Set Universe Polymorphism. +Generalizable All Variables. +Record prod A B := pair { fst : A ; snd : B }. +Arguments pair {_ _} _ _. +Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). +Reserved Notation "x <-> y" (at level 95, no associativity). +Reserved Notation "x = y" (at level 70, no associativity). +Notation "A -> B" := (forall (_ : A), B) : type_scope. +Open Scope type_scope. + +Definition iff A B := prod (A -> B) (B -> A). +Infix "<->" := iff : type_scope. +Inductive paths {A : Type@{i}} (a : A) : A -> Type@{i} := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Class Contr_internal (A : Type) := { center : A ; contr : (forall y : A, center += y) }. +Inductive trunc_index : Type := minus_two | trunc_S (_ : trunc_index). +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type@{i}) : Type@{i} := + match n with + | minus_two => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. +Notation minus_one:=(trunc_S minus_two). +Class IsTrunc (n : trunc_index) (A : Type) : Type := Trunc_is_trunc : +IsTrunc_internal n A. +Instance istrunc_paths (A : Type) n `{H : IsTrunc (trunc_S n) A} (x y : A) : +IsTrunc n (x = y) := H x y. + +Axiom cheat : forall {A}, A. + +Lemma paths_lift (A : Type@{i}) (x y : A) (p : x = y) : paths@{j} x y. +Proof. + destruct p. apply idpath. +Defined. + +Lemma paths_change (A : Type@{i}) (x y : A) : paths@{j} x y = paths@{i} x y. +Proof. (* require Univalence *) + apply cheat. +Defined. + +Lemma IsTrunc_lift (n : trunc_index) : + forall (A : Type@{i}), IsTrunc_internal@{i} n A -> IsTrunc_internal@{j} n A. +Proof. + induction n; simpl; intros. + destruct X. exists center0. intros. apply (paths_lift _ _ _ (contr0 y)). + + rewrite paths_change. + apply IHn, X. +Defined. + +Notation IsHProp := (IsTrunc minus_one). +(* Record hProp := hp { hproptype :> Type ; isp : IsTrunc minus_one hproptype}. *) +(* Make the truncation proof polymorphic, i.e., available at any level greater or equal + to the carrier type level j *) +Record hProp := hp { hproptype :> Type@{j} ; isp : IsTrunc minus_one hproptype}. +Axiom path_iff_hprop_uncurried : forall `{IsHProp A, IsHProp B}, (A <-> B) -> A += B. +Inductive V : Type@{U'} := | set {A : Type@{U}} (f : A -> V) : V. +Axiom is0trunc_V : IsTrunc (trunc_S (trunc_S minus_two)) V. +Axiom bisimulation : V@{U' U} -> V@{U' U} -> hProp@{U'}. +Axiom bisimulation_refl : forall (v : V), bisimulation v v. +Axiom bisimulation_eq : forall (u v : V), bisimulation u v -> u = v. +Notation "u ~~ v" := (bisimulation u v) (at level 30). +Lemma bisimulation_equals_id : forall u v : V@{i j}, (u = v) = (u ~~ v). +Proof. + intros u v. + refine (@path_iff_hprop_uncurried _ _ _ _ _). +(* path_iff_hprop_uncurried : *) +(* forall A : Type@{Top.74}, *) +(* IsHProp A -> forall B : Type@{Top.74}, IsHProp B -> A <-> B -> A = B *) +(* (* Top.74 *) +(* Top.78 |= Top.74 < Top.78 *) +(* *) *) + + Show Universes. + exact (isp _). + split; intros. destruct X. apply bisimulation_refl. + apply bisimulation_eq, X. +Defined. diff --git a/test-suite/bugs/closed/3561.v b/test-suite/bugs/closed/3561.v new file mode 100644 index 00000000..b4dfd17f --- /dev/null +++ b/test-suite/bugs/closed/3561.v @@ -0,0 +1,23 @@ +(* File reduced by coq-bug-finder from original input, then from 6343 lines to 2362 lines, then from 2115 lines to 303 lines, then from 321 lines to 90 lines, then from 95 lines to 41 lines *) +(* coqc version trunk (August 2014) compiled on Aug 31 2014 10:12:32 with OCaml 4.01.0 + coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (437b91a3ffd7327975a129b95b24d3f66ad7f3e4) *) +Set Primitive Projections. +Set Implicit Arguments. +Record prod (A B : Type) := pair { fst : A ; snd : B }. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y. +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing). +Lemma ap_transport {A} {P Q : A -> Type} {x y : A} (p : x = y) (f : forall x, P x -> Q x) (z : P x) : + f y (p # z) = (p # (f x z)). +Proof. admit. +Defined. +Lemma foo A B (f : A * B -> A) : f = f. +Admitted. +Goal forall (H0 H2 : Type) x p, + @transport (prod H0 H2) + (fun GO : prod H0 H2 => x (fst GO)) = p. + intros. + match goal with + | [ |- context[x (?f _)] ] => set(foo':=f) + end.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3562.v b/test-suite/bugs/closed/3562.v new file mode 100644 index 00000000..1a1410a3 --- /dev/null +++ b/test-suite/bugs/closed/3562.v @@ -0,0 +1,6 @@ +(* Should not be an anomaly as it was at some time in + September/October 2014 but some "Disjunctive/conjunctive + introduction pattern expected" error *) + +Theorem t: True. +Fail destruct 0 as x. diff --git a/test-suite/bugs/closed/3563.v b/test-suite/bugs/closed/3563.v new file mode 100644 index 00000000..67972166 --- /dev/null +++ b/test-suite/bugs/closed/3563.v @@ -0,0 +1,38 @@ +(* File reduced by coq-bug-finder from original input, then from 11716 lines to 11295 lines, then from 10518 lines to 21 lines, then \ +from 37 lines to 21 lines *) +(* coqc version trunk (August 2014) compiled on Aug 31 2014 10:12:32 with OCaml 4.01.0 + coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (437b91a3ffd7327975a129b95b24d3f66ad7f3e4) *) +Set Primitive Projections. +Record prod A B := pair { fst : A ; snd : B }. +Arguments pair {A B} _ _. +Arguments fst {A B} _ / . +Arguments snd {A B} _ / . +Notation "x * y" := (prod x y) : type_scope. +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. +Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y. +Goal forall (H H0 H1 : Type) (H2 : H1) (H3 : H1 -> H * H0) + (H4 : (fun c : H1 => (fst (H3 c), snd (H3 c))%core) = + H3) (H5 : H -> Type) (H6 H7 : H5 (fst (H3 H2))), + transport (fun y : H1 -> H * H0 => H5 (fst (y H2))) H4 H6 = H7. + intros. + match goal with + | [ |- appcontext ctx [transport (fun y => (?g (@fst ?C ?h (y H2)))) H4 H6] ] + => set(foo:=h); idtac + end. + match goal with + | [ |- appcontext ctx [transport (fun y => (?g (fst (y H2))))] ] + => idtac + end. +Abort. +Goal forall (H H0 H1 : Type) (H2 : H1) (H3 : H1 -> (H1 -> H) * H0) + (H4 : (fun c : H1 => (fst (H3 c), snd (H3 c))%core) = + H3) (H5 : H -> Type) (H6 H7 : H5 (fst (H3 H2) H2)), + transport (fun y : H1 -> (H1 -> H) * H0 => H5 (fst (y H2) H2)) H4 H6 = H7. + intros. + match goal with + | [ |- appcontext ctx [transport (fun y => (?g (@fst ?C ?D (y H2) ?X)))] ] + => set(foo:=X) + end. +(* Anomaly: Uncaught exception Not_found(_). Please report. *) + +(* Anomaly: Uncaught exception Not_found(_). Please report. *) diff --git a/test-suite/bugs/closed/3566.v b/test-suite/bugs/closed/3566.v new file mode 100644 index 00000000..b2aa8c3c --- /dev/null +++ b/test-suite/bugs/closed/3566.v @@ -0,0 +1,22 @@ +Notation idmap := (fun x => x). +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. +Delimit Scope path_scope with path. +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := match p, q with idpath, idpath => idpath end. +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x := match p with idpath => idpath end. +Notation "p @ q" := (concat p q) (at level 20) : path_scope. +Notation "p ^" := (inverse p) (at level 3, format "p '^'") : path_scope. +Class IsEquiv {A B : Type} (f : A -> B) := {}. +Axiom path_universe : forall {A B : Type} (f : A -> B) {feq : IsEquiv f}, (A = B). + +Definition Lift : Type@{i} -> Type@{j} + := Eval hnf in let lt := Type@{i} : Type@{j} in fun T => T. + +Definition lift {T} : T -> Lift T := fun x => x. + +Goal forall x y : Type, x = y. + intros. + pose proof ((fun H0 : idmap _ => (@path_universe _ _ (@lift x) (H0 x) @ + (@path_universe _ _ (@lift x) (H0 x))^)))%path as H''. diff --git a/test-suite/bugs/closed/3567.v b/test-suite/bugs/closed/3567.v new file mode 100644 index 00000000..cb16b3ae --- /dev/null +++ b/test-suite/bugs/closed/3567.v @@ -0,0 +1,68 @@ + +(* File reduced by coq-bug-finder from original input, then from 2901 lines to 69 lines, then from 80 lines to 63 lines *) +(* coqc version trunk (September 2014) compiled on Sep 2 2014 2:7:1 with OCaml 4.01.0 + coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (3c5daf4e23ee20f0788c0deab688af452e83ccf0) *) + +Set Primitive Projections. +Set Implicit Arguments. +Record prod (A B : Type) := pair { fst : A ; snd : B }. +Arguments fst {A B} _ / . +Arguments snd {A B} _ / . +Add Printing Let prod. +Notation "x * y" := (prod x y) : type_scope. +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. +Unset Implicit Arguments. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p with idpath => idpath end. +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. +Class IsEquiv {A B : Type} (f : A -> B) := + { equiv_inv : B -> A ; + eisretr : Sect equiv_inv f; + eissect : Sect f equiv_inv; + eisadj : forall x : A, eisretr (f x) = ap f (eissect x) }. +Definition path_prod_uncurried {A B : Type} (z z' : A * B) (pq : (fst z = fst z') * (snd z = snd z')) +: (z = z') + := match fst pq in (_ = z'1), snd pq in (_ = z'2) return z = (z'1, z'2) with + | idpath, idpath => idpath + end. +Definition path_prod {A B : Type} (z z' : A * B) : + (fst z = fst z') -> (snd z = snd z') -> (z = z') + := fun p q => path_prod_uncurried z z' (p,q). +Definition path_prod' {A B : Type} {x x' : A} {y y' : B} +: (x = x') -> (y = y') -> ((x,y) = (x',y')) + := fun p q => path_prod (x,y) (x',y') p q. +Axiom ap_fst_path_prod : forall {A B : Type} {z z' : A * B} + (p : fst z = fst z') (q : snd z = snd z'), + ap fst (path_prod _ _ p q) = p. +Axiom ap_snd_path_prod : forall {A B : Type} {z z' : A * B} + (p : fst z = fst z') (q : snd z = snd z'), + ap snd (path_prod _ _ p q) = q. +Axiom eta_path_prod : forall {A B : Type} {z z' : A * B} (p : z = z'), + path_prod _ _(ap fst p) (ap snd p) = p. +Definition isequiv_path_prod {A B : Type} {z z' : A * B} : IsEquiv (path_prod_uncurried z z'). +Proof. + refine (Build_IsEquiv + _ _ _ + (fun r => (ap fst r, ap snd r)) + eta_path_prod + (fun pq => match pq with + | (p,q) => path_prod' + (ap_fst_path_prod p q) (ap_snd_path_prod p q) + end) _). + destruct z as [x y], z' as [x' y']. simpl. +(* Toplevel input, characters 15-50: +Error: Abstracting over the term "z" leads to a term +fun z0 : A * B => +forall x : (fst z0 = fst z') * (snd z0 = snd z'), +eta_path_prod (path_prod_uncurried z0 z' x) = +ap (path_prod_uncurried z0 z') + (let (p, q) as pq + return + ((ap (fst) (path_prod_uncurried z0 z' pq), + ap (snd) (path_prod_uncurried z0 z' pq)) = pq) := x in + path_prod' (ap_fst_path_prod p q) (ap_snd_path_prod p q)) +which is ill-typed. +Reason is: Pattern-matching expression on an object of inductive type prod +has invalid information. + *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/3584.v b/test-suite/bugs/closed/3584.v new file mode 100644 index 00000000..3d4660b4 --- /dev/null +++ b/test-suite/bugs/closed/3584.v @@ -0,0 +1,16 @@ +Set Primitive Projections. +Set Implicit Arguments. +Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }. +Definition eta_sigma {A} {P : A -> Type} (u : sigT P) + : existT _ (projT1 u) (projT2 u) = u + := match u with existT _ x y => eq_refl end. (* Toplevel input, characters 0-139: +Error: Pattern-matching expression on an object of inductive type sigT +has invalid information. *) +Definition sum_of_sigT A B (x : sigT (fun b : bool => if b then A else B)) +: A + B + := match x with + | existT _ true a => inl a + | existT _ false b => inr b + end. (* Toplevel input, characters 0-182: +Error: Pattern-matching expression on an object of inductive type sigT +has invalid information. *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/3593.v b/test-suite/bugs/closed/3593.v new file mode 100644 index 00000000..25f9db6b --- /dev/null +++ b/test-suite/bugs/closed/3593.v @@ -0,0 +1,10 @@ +Set Universe Polymorphism. +Set Printing All. +Set Implicit Arguments. +Record prod A B := pair { fst : A ; snd : B }. +Goal forall x : prod Set Set, let f := @fst _ in f _ x = @fst _ _ x. +simpl; intros. + constr_eq (@fst Set Set x) (fst (A := Set) (B := Set) x). + Fail progress change (@fst Set Set x) with (fst (A := Set) (B := Set) x). + reflexivity. +Qed. diff --git a/test-suite/bugs/closed/3594.v b/test-suite/bugs/closed/3594.v new file mode 100644 index 00000000..d1aae7b4 --- /dev/null +++ b/test-suite/bugs/closed/3594.v @@ -0,0 +1,51 @@ +(* File reduced by coq-bug-finder from original input, then from 8752 lines to 735 lines, then from 735 lines to 310 lines, then from 228 lines to 105 lines, then from 98 lines to 41 lines *) +(* coqc version trunk (September 2014) compiled on Sep 6 2014 6:15:6 with OCaml 4.01.0 + coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (3ea6d6888105edd5139ae0a4d8f8ecdb586aff6c) *) +Notation idmap := (fun x => x). +Axiom path_forall : forall {A : Type} {P : A -> Type} (f g : forall x : A, P x), (forall x, f x = g x) -> f = g. +Local Set Primitive Projections. +Record PreCategory := { object :> Type ; morphism : object -> object -> Type }. +Bind Scope category_scope with PreCategory. +Set Implicit Arguments. +Delimit Scope functor_scope with functor. +Record Functor (C D : PreCategory) := {}. +Definition opposite (C : PreCategory) : PreCategory := @Build_PreCategory C (fun s d => morphism C d s). +Notation "C ^op" := (opposite C) (at level 3, format "C '^op'") : category_scope. +Definition oppositeF C D (F : Functor C D) : Functor C^op D^op := Build_Functor (C^op) (D^op). +Local Notation "F ^op" := (oppositeF F) (at level 3, format "F ^op") : functor_scope. +Axiom oppositeF_involutive : forall C D (F : Functor C D), ((F^op)^op)%functor = F. +Local Open Scope functor_scope. +Goal forall C D : PreCategory, + (fun c : Functor C^op D^op => (c^op)^op) = idmap. + intros. + exact (path_forall (fun F : Functor C^op D^op => (F^op)^op) _ (@oppositeF_involutive _ _)). + Undo. + Unset Printing Notations. + Set Debug Unification. +(* Check (eq_refl : Build_PreCategory (opposite D).(object) *) +(* (fun s d : (opposite D).(object) => *) +(* (opposite D).(morphism) d s) = *) +(* @Build_PreCategory D (fun s d => morphism D d s)). *) +(* opposite D). *) + exact (path_forall (fun F => (F^op)^op) _ (@oppositeF_involutive _ _)). +Qed. + (* Toplevel input, characters 22-101: +Error: +In environment +C : PreCategory +D : PreCategory +The term + "path_forall + (fun F : Functor (opposite C) (opposite D) => oppositeF (oppositeF F)) + (fun F : Functor (opposite C) (opposite D) => F) + (oppositeF_involutive (D:=opposite D))" has type + "eq (fun F : Functor (opposite C) (opposite D) => oppositeF (oppositeF F)) + (fun F : Functor (opposite C) (opposite D) => F)" +while it is expected to have type + "eq (fun c : Functor (opposite C) (opposite D) => oppositeF (oppositeF c)) + (fun x : Functor (opposite C) (opposite D) => x)" +(cannot unify "{| + object := opposite D; + morphism := fun s d : opposite D => morphism (opposite D) d s |}" +and "opposite D"). + *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/3596.v b/test-suite/bugs/closed/3596.v new file mode 100644 index 00000000..d6c1c949 --- /dev/null +++ b/test-suite/bugs/closed/3596.v @@ -0,0 +1,18 @@ +Set Implicit Arguments. +Record foo := { fx : nat }. +Set Primitive Projections. +Record bar := { bx : nat }. +Definition Foo (f : foo) : f = f. + destruct f as [fx]; destruct fx; admit. +Defined. +Definition Bar (b : bar) : b = b. + destruct b as [fx]; destruct fx; admit. +Defined. +Goal forall f b, Bar b = Bar b -> Foo f = Foo f. + intros f b. + destruct f, b. + simpl. + Fail progress unfold Bar. (* success *) + Fail progress unfold Foo. (* failed to progress *) + reflexivity. +Qed.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3616.v b/test-suite/bugs/closed/3616.v new file mode 100644 index 00000000..68870026 --- /dev/null +++ b/test-suite/bugs/closed/3616.v @@ -0,0 +1,3 @@ +(* Was failing from April 2014 to September 2014 because of injection *) +Goal forall P e es t, (e :: es = existT P tt t :: es)%list -> True. +inversion 1. diff --git a/test-suite/bugs/closed/3618.v b/test-suite/bugs/closed/3618.v new file mode 100644 index 00000000..dc560ad5 --- /dev/null +++ b/test-suite/bugs/closed/3618.v @@ -0,0 +1,103 @@ +Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x). +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a. +Notation "x = y" := (@paths _ x y) : type_scope. +Definition concat {A} {x y z : A} : x = y -> y = z -> x = z. Admitted. +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x. Admitted. +Notation "p @ q" := (concat p q) (at level 20). +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y. Admitted. +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y. Admitted. + +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { + equiv_inv : B -> A ; + eisretr : forall x, f (equiv_inv x) = x; + eissect : forall x, equiv_inv (f x) = x +}. + +Class Contr_internal (A : Type). + +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. + +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | minus_two => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. + +Class IsTrunc (n : trunc_index) (A : Type) : Type := + Trunc_is_trunc : IsTrunc_internal n A. +Definition istrunc_paths (A : Type) n `{H : IsTrunc (trunc_S n) A} (x y : A) +: IsTrunc n (x = y). +Admitted. + +Hint Extern 4 (IsTrunc _ (_ = _)) => eapply @istrunc_paths : typeclass_instances. + +Class Funext. + +Instance isequiv_compose A B C f g `{IsEquiv A B f} `{IsEquiv B C g} + : IsEquiv (compose g f) | 1000. +Admitted. + +Section IsEquivHomotopic. + Context (A B : Type) `(f : A -> B) `(g : A -> B) `{IsEquiv A B f} (h : forall x:A, f x = g x). + Let sect := (fun b:B => inverse (h (@equiv_inv _ _ f _ b)) @ @eisretr _ _ f _ b). + Let retr := (fun a:A => inverse (ap (@equiv_inv _ _ f _) (h a)) @ @eissect _ _ f _ a). + Global Instance isequiv_homotopic : IsEquiv g | 10000 + := ( BuildIsEquiv _ _ g (@equiv_inv _ _ f _) sect retr). +End IsEquivHomotopic. + +Instance trunc_succ A n `{IsTrunc n A} : IsTrunc (trunc_S n) A | 1000. Admitted. + +Global Instance trunc_forall A n `{P : A -> Type} `{forall a, IsTrunc n (P a)} + : IsTrunc n (forall a, P a) | 100. +Admitted. + +Instance trunc_prod A B n `{IsTrunc n A} `{IsTrunc n B} : IsTrunc n (A * B) | 100. +Admitted. + +Global Instance trunc_arrow n {A B : Type} `{IsTrunc n B} : IsTrunc n (A -> B) | 100. +Admitted. + +Instance isequiv_pr1_contr {A} {P : A -> Type} `{forall a, IsTrunc minus_two (P a)} +: IsEquiv (@projT1 A P) | 100. +Admitted. + +Instance trunc_sigma n A `{P : A -> Type} `{IsTrunc n A} `{forall a, IsTrunc n (P a)} +: IsTrunc n (sigT P) | 100. +Admitted. + +Global Instance trunc_trunc `{Funext} A m n : IsTrunc (trunc_S n) (IsTrunc m A) | 0. +Admitted. + +Definition BiInv {A B} (f : A -> B) : Type +:= ( {g : B -> A & forall x, g (f x) = x} * {h : B -> A & forall x, f (h x) = x}). + +Global Instance isprop_biinv {A B} (f : A -> B) : IsTrunc (trunc_S minus_two) (BiInv f) | 0. +Admitted. + +Instance isequiv_path {A B : Type} (p : A = B) +: IsEquiv (transport (fun X:Type => X) p) | 0. +Admitted. + +Class ReflectiveSubuniverse_internal := + { inO_internal : Type -> Type ; + O : Type -> Type ; + O_unit : forall T, T -> O T }. + +Class ReflectiveSubuniverse := + ReflectiveSubuniverse_wrap : Funext -> ReflectiveSubuniverse_internal. +Global Existing Instance ReflectiveSubuniverse_wrap. + +Class inO {fs : Funext} {subU : ReflectiveSubuniverse} (T : Type) := + isequiv_inO : inO_internal T. + +Global Instance hprop_inO {fs : Funext} {subU : ReflectiveSubuniverse} (T : Type) : IsTrunc (trunc_S minus_two) (inO T) . +Admitted. + +(* To avoid looping class resolution *) +Hint Mode IsEquiv - - + : typeclass_instances. + +Fail Definition equiv_O_rectnd {fs : Funext} {subU : ReflectiveSubuniverse} + (P Q : Type) {Q_inO : inO_internal Q} +: IsEquiv (fun f : O P -> P => compose f (O_unit P)) := _.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3623.v b/test-suite/bugs/closed/3623.v new file mode 100644 index 00000000..202b9001 --- /dev/null +++ b/test-suite/bugs/closed/3623.v @@ -0,0 +1,4 @@ +Require Import List. +Goal (1 :: 2 :: nil) ++ (3::nil) = (1::2::3::nil). +change (@app nat (?a :: ?b) ?c) with (a :: @app nat b c). +Abort. diff --git a/test-suite/bugs/closed/3624.v b/test-suite/bugs/closed/3624.v new file mode 100644 index 00000000..a05d5eb2 --- /dev/null +++ b/test-suite/bugs/closed/3624.v @@ -0,0 +1,11 @@ +Set Implicit Arguments. +Module NonPrim. + Class foo (m : Set) := { pf : m = m }. + Notation pf' m := (pf (m := m)). +End NonPrim. + +Module Prim. + Set Primitive Projections. + Class foo (m : Set) := { pf : m = m }. + Notation pf' m := (pf (m:=m)). (* Wrong argument name: m. *) +End Prim.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3625.v b/test-suite/bugs/closed/3625.v new file mode 100644 index 00000000..3d30b62f --- /dev/null +++ b/test-suite/bugs/closed/3625.v @@ -0,0 +1,11 @@ +Set Implicit Arguments. +Set Primitive Projections. +Record prod A B := pair { fst : A ; snd : B }. + +Goal forall x y : prod Set Set, x.(@fst _ _) = y.(@fst _ _). + intros. + refine (f_equal _ _). + Undo. + apply f_equal. + admit. +Qed. diff --git a/test-suite/bugs/closed/3628.v b/test-suite/bugs/closed/3628.v new file mode 100644 index 00000000..4001cf7c --- /dev/null +++ b/test-suite/bugs/closed/3628.v @@ -0,0 +1,9 @@ +Module NonPrim. + Class AClass := { x : Set }. + Arguments x {AClass}. +End NonPrim. +Module Prim. + Set Primitive Projections. + Class AClass := { x : Set }. + Arguments x {AClass}. +End Prim. diff --git a/test-suite/bugs/closed/3633.v b/test-suite/bugs/closed/3633.v new file mode 100644 index 00000000..6a952377 --- /dev/null +++ b/test-suite/bugs/closed/3633.v @@ -0,0 +1,10 @@ +Set Typeclasses Strict Resolution. +Class Contr (A : Type) := { center : A }. +Definition foo {A} `{Contr A} : A. +Proof. + apply center. + Undo. + (* Ensure the constraints are solved independently, otherwise a frozen ?A + makes a search for Contr ?A fail when finishing to apply (fun x => x) *) + apply (fun x => x), center. +Qed.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3637.v b/test-suite/bugs/closed/3637.v new file mode 100644 index 00000000..868f45c8 --- /dev/null +++ b/test-suite/bugs/closed/3637.v @@ -0,0 +1,11 @@ + +Set Implicit Arguments. +Set Primitive Projections. +Record prod A B := pair { fst : A ; snd : B }. +Goal forall x y : prod Set Set, fst x = fst y. + intros. + lazymatch goal with + | [ |- context[@fst ?A ?B] ] => pose (@fst A B) as fst'; + progress change (@fst Set Set) with fst' +end. +Abort. diff --git a/test-suite/bugs/closed/3638.v b/test-suite/bugs/closed/3638.v new file mode 100644 index 00000000..70144174 --- /dev/null +++ b/test-suite/bugs/closed/3638.v @@ -0,0 +1,25 @@ +(* File reduced by coq-bug-finder from original input, then from 7593 lines to 243 lines, then from 256 lines to 102 lines, then from 104 lines to 28 lines *) +(* coqc version trunk (September 2014) compiled on Sep 17 2014 0:22:30 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (d34e1eed232c84590ddb80d70db9f7f7cf13584a) *) +Set Primitive Projections. +Set Implicit Arguments. +Record prod (A B : Type) := pair { fst : A ; snd : B }. +Notation "x * y" := (prod x y) : type_scope. +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. +Class UnitSubuniverse := { O : Type -> Type ; O_unit : forall T, T -> O T }. +Class ReflectiveSubuniverse := { rsubu_usubu : UnitSubuniverse ; O_rectnd : forall {P Q : Type} (f : P -> Q), O P -> Q }. +Global Existing Instance rsubu_usubu. +Context {subU : ReflectiveSubuniverse}. +Goal forall (A B : Type) (x : O A * O B) (x0 : B), + { g : _ & O_rectnd (fun z : A * B => (O_unit (fst z), O_unit (snd z))) + (O_rectnd (fun a : A => O_unit (a, x0)) (fst x)) = + g x0 }. + eexists. + Show Existentials. Set Printing Existential Instances. + match goal with + | [ |- context[?e] ] => is_evar e; let e' := fresh "e'" in set (e' := e) + end. + + +(* Toplevel input, characters 15-114: +Anomaly: Bad recursive type. Please report. *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/3640.v b/test-suite/bugs/closed/3640.v new file mode 100644 index 00000000..bdbfbb15 --- /dev/null +++ b/test-suite/bugs/closed/3640.v @@ -0,0 +1,31 @@ +(* File reduced by coq-bug-finder from original input, then from 14990 lines to 70 lines, then from 44 lines to 29 lines *) +(* coqc version trunk (September 2014) compiled on Sep 17 2014 0:22:30 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (d34e1eed232c84590ddb80d70db9f7f7cf13584a) *) +Set Primitive Projections. +Set Implicit Arguments. +Record sigT {A} P := existT { pr1 : A ; pr2 : P pr1 }. +Notation "{ x : A & P }" := (sigT (A := A) (fun x : A => P)) : type_scope. +Notation "x .1" := (pr1 x) (at level 3, format "x '.1'"). +Notation "x .2" := (pr2 x) (at level 3, format "x '.2'"). +Record Equiv A B := { equiv_fun :> A -> B }. +Notation "A <~> B" := (Equiv A B) (at level 85). +Inductive Bool : Type := true | false. +Definition negb (b : Bool) := if b then false else true. +Axiom eval_bool_isequiv : forall (f : Bool -> Bool), f false = negb (f true). +Lemma bool_map_equiv_not_idmap (f : { f : Bool <~> Bool & ~(forall x, f x = x) }) +: forall b, ~(f.1 b = b). +Proof. + intro b. + intro H''. + apply f.2. + intro b'. + pose proof (eval_bool_isequiv f.1) as H. + destruct b', b. + Fail match type of H with + | _ = negb (f.1 true) => fail 1 "no f.1 true" + end. (* Error: No matching clauses for match. *) + destruct (f.1 true). + simpl in *. + Fail match type of H with + | _ = negb ?T => unify T (f.1 true); fail 1 "still has f.1 true" + end. (* Error: Tactic failure: still has f.1 true. *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/3641.v b/test-suite/bugs/closed/3641.v new file mode 100644 index 00000000..f47f64ea --- /dev/null +++ b/test-suite/bugs/closed/3641.v @@ -0,0 +1,21 @@ +(* File reduced by coq-bug-finder from original input, then from 7593 lines to 243 lines, then from 256 lines to 102 lines, then from\ + 104 lines to 28 lines *) +(* coqc version trunk (September 2014) compiled on Sep 17 2014 0:22:30 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (d34e1eed232c84590ddb80d70db9f7f7cf13584a) *) +Set Implicit Arguments. +Record prod (A B : Type) := pair { fst : A ; snd : B }. +Notation "x * y" := (prod x y) : type_scope. +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. +Class UnitSubuniverse := { O : Type -> Type ; O_unit : forall T, T -> O T }. +Class ReflectiveSubuniverse := { rsubu_usubu : UnitSubuniverse ; O_rectnd : forall {P Q : Type} (f : P -> Q), O P -> Q }. +Global Existing Instance rsubu_usubu. +Context {subU : ReflectiveSubuniverse}. +Goal forall (A B : Type) (x : O A * O B) (x0 : B), + { g : _ & O_rectnd (fun z : A * B => (O_unit (fst z), O_unit (snd z))) + (O_rectnd (fun a : A => O_unit (a, x0)) (fst x)) = + g x0 }. + eexists. + match goal with + | [ |- context[?e] ] => is_evar e; let e' := fresh "e'" in pose (e' := e) + end. + Fail change ?g with e'. (* Stack overflow *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/3647.v b/test-suite/bugs/closed/3647.v new file mode 100644 index 00000000..cd542c8a --- /dev/null +++ b/test-suite/bugs/closed/3647.v @@ -0,0 +1,652 @@ +Require Coq.Setoids.Setoid. + +Axiom BITS : nat -> Set. +Definition n7 := 7. +Definition n15 := 15. +Definition n31 := 31. +Notation n8 := (S n7). +Notation n16 := (S n15). +Notation n32 := (S n31). +Inductive OpSize := OpSize1 | OpSize2 | OpSize4 . +Definition VWORD s := BITS (match s with OpSize1 => n8 | OpSize2 => n16 | OpSize4 => n32 end). +Definition BYTE := VWORD OpSize1. +Definition WORD := VWORD OpSize2. +Definition DWORD := VWORD OpSize4. +Ltac subst_body := + repeat match goal with + | [ H := _ |- _ ] => subst H + end. +Import Coq.Setoids.Setoid. +Class Equiv (A : Type) := equiv : relation A. +Infix "===" := equiv (at level 70, no associativity). +Class type (A : Type) {e : Equiv A} := eq_equiv : Equivalence equiv. +Definition setoid_resp {T T'} (f : T -> T') `{e : type T} `{e' : type T'} := forall x y, x === y -> f x === f y. +Record morphism T T' `{e : type T} `{e' : type T'} := + mkMorph { + morph :> T -> T'; + morph_resp : setoid_resp morph}. +Implicit Arguments mkMorph [T T' e e0 e' e1]. +Infix "-s>" := morphism (at level 45, right associativity). +Section Morphisms. + Context {S T U V} `{eS : type S} `{eT : type T} `{eU : type U} `{eV : type V}. + Global Instance morph_equiv : Equiv (S -s> T). + admit. + Defined. + + Global Instance morph_type : type (S -s> T). + admit. + Defined. + + Program Definition mcomp (f: T -s> U) (g: S -s> T) : (S -s> U) := + mkMorph (fun x => f (g x)) _. + Next Obligation. + admit. + Defined. + +End Morphisms. + +Infix "<<" := mcomp (at level 35). + +Section MorphConsts. + Context {S T U V} `{eS : type S} `{eT : type T} `{eU : type U} `{eV : type V}. + + Definition lift2s (f : S -> T -> U) p q : (S -s> T -s> U) := + mkMorph (fun x => mkMorph (f x) (p x)) q. + +End MorphConsts. +Instance Equiv_PropP : Equiv Prop. +admit. +Defined. + +Section SetoidProducts. + Context {A B : Type} `{eA : type A} `{eB : type B}. + Global Instance Equiv_prod : Equiv (A * B). + admit. + Defined. + + Global Instance type_prod : type (A * B). + admit. + Defined. + + Program Definition mfst : (A * B) -s> A := + mkMorph (fun p => fst p) _. + Next Obligation. + admit. + Defined. + + Program Definition msnd : (A * B) -s> B := + mkMorph (fun p => snd p) _. + Next Obligation. + admit. + Defined. + + Context {C} `{eC : type C}. + + Program Definition mprod (f: C -s> A) (g: C -s> B) : C -s> (A * B) := + mkMorph (fun c => (f c, g c)) _. + Next Obligation. + admit. + Defined. + +End SetoidProducts. + +Section IndexedProducts. + + Record ttyp := {carr :> Type; eqc : Equiv carr; eqok : type carr}. + Global Instance ttyp_proj_eq {A : ttyp} : Equiv A. + admit. + Defined. + Global Instance ttyp_proj_prop {A : ttyp} : type A. + admit. + Defined. + Context {I : Type} {P : I -> ttyp}. + + Global Program Instance Equiv_prodI : Equiv (forall i, P i) := + fun p p' : forall i, P i => (forall i : I, @equiv _ (eqc _) (p i) (p' i)). + + Global Instance type_prodI : type (forall i, P i). + admit. + Defined. + + Program Definition mprojI (i : I) : (forall i, P i) -s> P i := + mkMorph (fun X => X i) _. + Next Obligation. + admit. + Defined. + + Context {C : Type} `{eC : type C}. + + Program Definition mprodI (f : forall i, C -s> P i) : C -s> (forall i, P i) := + mkMorph (fun c i => f i c) _. + Next Obligation. + admit. + Defined. + +End IndexedProducts. + +Section Exponentials. + + Context {A B C D} `{eA : type A} `{eB : type B} `{eC : type C} `{eD : type D}. + + Program Definition comps : (B -s> C) -s> (A -s> B) -s> A -s> C := + lift2s (fun f g => f << g) _ _. + Next Obligation. + admit. + Defined. + Next Obligation. + admit. + Defined. + + Program Definition muncurry (f : A -s> B -s> C) : A * B -s> C := + mkMorph (fun p => f (fst p) (snd p)) _. + Next Obligation. + admit. + Defined. + + Program Definition mcurry (f : A * B -s> C) : A -s> B -s> C := + lift2s (fun a b => f (a, b)) _ _. + Next Obligation. + admit. + Defined. + Next Obligation. + admit. + Defined. + + Program Definition meval : (B -s> A) * B -s> A := + mkMorph (fun p => fst p (snd p)) _. + Next Obligation. + admit. + Defined. + + Program Definition mid : A -s> A := mkMorph (fun x => x) _. + Next Obligation. + admit. + Defined. + + Program Definition mconst (b : B) : A -s> B := mkMorph (fun _ => b) _. + Next Obligation. + admit. + Defined. + +End Exponentials. + +Inductive empty : Set := . +Instance empty_Equiv : Equiv empty. +admit. +Defined. +Instance empty_type : type empty. +admit. +Defined. + +Section Initials. + Context {A} `{eA : type A}. + + Program Definition mzero_init : empty -s> A := mkMorph (fun x => match x with end) _. + Next Obligation. + admit. + Defined. + +End Initials. + +Section Subsetoid. + + Context {A} `{eA : type A} {P : A -> Prop}. + Global Instance subset_Equiv : Equiv {a : A | P a}. + admit. + Defined. + Global Instance subset_type : type {a : A | P a}. + admit. + Defined. + + Program Definition mforget : {a : A | P a} -s> A := + mkMorph (fun x => x) _. + Next Obligation. + admit. + Defined. + + Context {B} `{eB : type B}. + Program Definition minherit (f : B -s> A) (HB : forall b, P (f b)) : B -s> {a : A | P a} := + mkMorph (fun b => exist P (f b) (HB b)) _. + Next Obligation. + admit. + Defined. + +End Subsetoid. + +Section Option. + + Context {A} `{eA : type A}. + Global Instance option_Equiv : Equiv (option A). + admit. + Defined. + + Global Instance option_type : type (option A). + admit. + Defined. + +End Option. + +Section OptDefs. + Context {A B} `{eA : type A} `{eB : type B}. + + Program Definition msome : A -s> option A := mkMorph (fun a => Some a) _. + Next Obligation. + admit. + Defined. + + Program Definition moptionbind (f : A -s> option B) : option A -s> option B := + mkMorph (fun oa => match oa with None => None | Some a => f a end) _. + Next Obligation. + admit. + Defined. + +End OptDefs. + +Generalizable Variables Frm. + +Class ILogicOps Frm := { + lentails: relation Frm; + ltrue: Frm; + lfalse: Frm; + limpl: Frm -> Frm -> Frm; + land: Frm -> Frm -> Frm; + lor: Frm -> Frm -> Frm; + lforall: forall {T}, (T -> Frm) -> Frm; + lexists: forall {T}, (T -> Frm) -> Frm + }. + +Infix "|--" := lentails (at level 79, no associativity). +Infix "//\\" := land (at level 75, right associativity). +Infix "\\//" := lor (at level 76, right associativity). +Infix "-->>" := limpl (at level 77, right associativity). +Notation "'Forall' x .. y , p" := + (lforall (fun x => .. (lforall (fun y => p)) .. )) (at level 78, x binder, y binder, right associativity). +Notation "'Exists' x .. y , p" := + (lexists (fun x => .. (lexists (fun y => p)) .. )) (at level 78, x binder, y binder, right associativity). + +Class ILogic Frm {ILOps: ILogicOps Frm} := { + lentailsPre:> PreOrder lentails; + ltrueR: forall C, C |-- ltrue; + lfalseL: forall C, lfalse |-- C; + lforallL: forall T x (P: T -> Frm) C, P x |-- C -> lforall P |-- C; + lforallR: forall T (P: T -> Frm) C, (forall x, C |-- P x) -> C |-- lforall P; + lexistsL: forall T (P: T -> Frm) C, (forall x, P x |-- C) -> lexists P |-- C; + lexistsR: forall T x (P: T -> Frm) C, C |-- P x -> C |-- lexists P; + landL1: forall P Q C, P |-- C -> P //\\ Q |-- C; + landL2: forall P Q C, Q |-- C -> P //\\ Q |-- C; + lorR1: forall P Q C, C |-- P -> C |-- P \\// Q; + lorR2: forall P Q C, C |-- Q -> C |-- P \\// Q; + landR: forall P Q C, C |-- P -> C |-- Q -> C |-- P //\\ Q; + lorL: forall P Q C, P |-- C -> Q |-- C -> P \\// Q |-- C; + landAdj: forall P Q C, C |-- (P -->> Q) -> C //\\ P |-- Q; + limplAdj: forall P Q C, C //\\ P |-- Q -> C |-- (P -->> Q) + }. +Hint Extern 0 (?x |-- ?x) => reflexivity. + +Section ILogicExtra. + Context `{IL: ILogic Frm}. + Definition lpropand (p: Prop) Q := Exists _: p, Q. + Definition lpropimpl (p: Prop) Q := Forall _: p, Q. + +End ILogicExtra. + +Infix "/\\" := lpropand (at level 75, right associativity). +Infix "->>" := lpropimpl (at level 77, right associativity). + +Section ILogic_Fun. + Context (T: Type) `{TType: type T}. + Context `{IL: ILogic Frm}. + + Record ILFunFrm := mkILFunFrm { + ILFunFrm_pred :> T -> Frm; + ILFunFrm_closed: forall t t': T, t === t' -> + ILFunFrm_pred t |-- ILFunFrm_pred t' + }. + + Notation "'mk'" := @mkILFunFrm. + + Program Definition ILFun_Ops : ILogicOps ILFunFrm := {| + lentails P Q := forall t:T, P t |-- Q t; + ltrue := mk (fun t => ltrue) _; + lfalse := mk (fun t => lfalse) _; + limpl P Q := mk (fun t => P t -->> Q t) _; + land P Q := mk (fun t => P t //\\ Q t) _; + lor P Q := mk (fun t => P t \\// Q t) _; + lforall A P := mk (fun t => Forall a, P a t) _; + lexists A P := mk (fun t => Exists a, P a t) _ + |}. + Next Obligation. + admit. + Defined. + Next Obligation. + admit. + Defined. + Next Obligation. + admit. + Defined. + Next Obligation. + admit. + Defined. + Next Obligation. + admit. + Defined. + +End ILogic_Fun. + +Implicit Arguments ILFunFrm [[ILOps] [e]]. +Implicit Arguments mkILFunFrm [T Frm ILOps]. + +Program Definition ILFun_eq {T R} {ILOps: ILogicOps R} {ILogic: ILogic R} (P : T -> R) : + @ILFunFrm T _ R ILOps := + @mkILFunFrm T eq R ILOps P _. +Next Obligation. + admit. +Defined. + +Instance ILogicOps_Prop : ILogicOps Prop | 2 := {| + lentails P Q := (P : Prop) -> Q; + ltrue := True; + lfalse := False; + limpl P Q := P -> Q; + land P Q := P /\ Q; + lor P Q := P \/ Q; + lforall T F := forall x:T, F x; + lexists T F := exists x:T, F x + |}. + +Instance ILogic_Prop : ILogic Prop. +admit. +Defined. + +Section FunEq. + Context A `{eT: type A}. + + Global Instance FunEquiv {T} : Equiv (T -> A) := { + equiv P Q := forall a, P a === Q a + }. +End FunEq. + +Section SepAlgSect. + Class SepAlgOps T `{eT : type T}:= { + sa_unit : T; + + sa_mul : T -> T -> T -> Prop + }. + + Class SepAlg T `{SAOps: SepAlgOps T} : Type := { + sa_mul_eqL a b c d : sa_mul a b c -> c === d -> sa_mul a b d; + sa_mul_eqR a b c d : sa_mul a b c -> sa_mul a b d -> c === d; + sa_mon a b c : a === b -> sa_mul a c === sa_mul b c; + sa_mulC a b : sa_mul a b === sa_mul b a; + sa_mulA a b c : forall bc abc, sa_mul a bc abc -> sa_mul b c bc -> + exists ac, sa_mul b ac abc /\ sa_mul a c ac; + sa_unitI a : sa_mul a sa_unit a + }. + +End SepAlgSect. + +Section BILogic. + + Class BILOperators (A : Type) := { + empSP : A; + sepSP : A -> A -> A; + wandSP : A -> A -> A + }. + +End BILogic. + +Notation "a '**' b" := (sepSP a b) + (at level 75, right associativity). + +Section BISepAlg. + Context {A} `{sa : SepAlg A}. + Context {B} `{IL: ILogic B}. + + Program Instance SABIOps: BILOperators (ILFunFrm A B) := { + empSP := mkILFunFrm e (fun x => sa_unit === x /\\ ltrue) _; + sepSP P Q := mkILFunFrm e (fun x => Exists x1, Exists x2, sa_mul x1 x2 x /\\ + P x1 //\\ Q x2) _; + wandSP P Q := mkILFunFrm e (fun x => Forall x1, Forall x2, sa_mul x x1 x2 ->> + P x1 -->> Q x2) _ + }. + Next Obligation. + admit. + Defined. + Next Obligation. + admit. + Defined. + Next Obligation. + admit. + Defined. + +End BISepAlg. + +Set Implicit Arguments. + +Definition Chan := WORD. +Definition Data := BYTE. + +Inductive Action := +| Out (c:Chan) (d:Data) +| In (c:Chan) (d:Data). + +Definition Actions := list Action. + +Instance ActionsEquiv : Equiv Actions := { + equiv a1 a2 := a1 = a2 + }. + +Definition OPred := ILFunFrm Actions Prop. +Definition mkOPred (P : Actions -> Prop) : OPred. + admit. +Defined. + +Definition eq_opred s := mkOPred (fun s' => s === s'). +Definition empOP : OPred. + exact (eq_opred nil). +Defined. +Definition catOP (P Q: OPred) : OPred. + admit. +Defined. + +Class IsPointed (T : Type) := point : T. + +Generalizable All Variables. + +Notation IsPointed_OPred P := (IsPointed (exists x : Actions, (P : OPred) x)). + +Record PointedOPred := mkPointedOPred { + OPred_pred :> OPred; + OPred_inhabited: IsPointed_OPred OPred_pred + }. + +Existing Instance OPred_inhabited. + +Canonical Structure default_PointedOPred O `{IsPointed_OPred O} : PointedOPred + := {| OPred_pred := O ; OPred_inhabited := _ |}. +Instance IsPointed_eq_opred x : IsPointed_OPred (eq_opred x). +admit. +Defined. +Instance IsPointed_catOP `{IsPointed_OPred P, IsPointed_OPred Q} : IsPointed_OPred (catOP P Q). +admit. +Defined. + +Definition Flag := BITS 5. +Definition OF: Flag. + admit. +Defined. + +Inductive FlagVal := mkFlag (b: bool) | FlagUnspecified. +Coercion mkFlag : bool >-> FlagVal. +Inductive NonSPReg := EAX | EBX | ECX | EDX | ESI | EDI | EBP. + +Inductive Reg := nonSPReg (r: NonSPReg) | ESP. + +Inductive AnyReg := regToAnyReg (r: Reg) | EIP. + +Inductive BYTEReg := AL|BL|CL|DL|AH|BH|CH|DH. + +Inductive WORDReg := mkWordReg (r:Reg). +Definition PState : Type. +admit. +Defined. + +Instance PStateEquiv : Equiv PState. +admit. +Defined. + +Instance PStateType : type PState. +admit. +Defined. + +Instance PStateSepAlgOps: SepAlgOps PState. +admit. +Defined. +Definition SPred : Type. +exact (ILFunFrm PState Prop). +Defined. + +Local Existing Instance ILFun_Ops. +Local Existing Instance SABIOps. +Axiom BYTEregIs : BYTEReg -> BYTE -> SPred. + +Inductive RegOrFlag := +| RegOrFlagDWORD :> AnyReg -> RegOrFlag +| RegOrFlagWORD :> WORDReg -> RegOrFlag +| RegOrFlagBYTE :> BYTEReg -> RegOrFlag +| RegOrFlagF :> Flag -> RegOrFlag. + +Definition RegOrFlag_target rf := + match rf with + | RegOrFlagDWORD _ => DWORD + | RegOrFlagWORD _ => WORD + | RegOrFlagBYTE _ => BYTE + | RegOrFlagF _ => FlagVal + end. + +Inductive Condition := +| CC_O | CC_B | CC_Z | CC_BE | CC_S | CC_P | CC_L | CC_LE. + +Section ILSpecSect. + + Axiom spec : Type. + Global Instance ILOps: ILogicOps spec | 2. + admit. + Defined. + +End ILSpecSect. + +Axiom parameterized_basic : forall {T_OPred} {proj : T_OPred -> OPred} {T} (P : SPred) (c : T) (O : OPred) (Q : SPred), spec. +Global Notation loopy_basic := (@parameterized_basic PointedOPred OPred_pred _). + +Axiom program : Type. + +Axiom ConditionIs : forall (cc : Condition) (cv : RegOrFlag_target OF), SPred. + +Axiom foldl : forall {T R}, (R -> T -> R) -> R -> list T -> R. +Axiom nth : forall {T}, T -> list T -> nat -> T. +Axiom while : forall (ptest: program) + (cond: Condition) (value: bool) + (pbody: program), program. + +Lemma while_rule_ind {quantT} + {ptest} {cond : Condition} {value : bool} {pbody} + {S} + {transition_body : quantT -> quantT} + {P : quantT -> SPred} {Otest : quantT -> OPred} {Obody : quantT -> OPred} {O : quantT -> PointedOPred} + {O_after_test : quantT -> PointedOPred} + {I_state : quantT -> bool -> SPred} + {I_logic : quantT -> bool -> bool} + {Q : quantT -> SPred} + (Htest : S |-- (Forall (x : quantT), + (loopy_basic (P x) + ptest + (Otest x) + (Exists b, I_logic x b = true /\\ I_state x b ** ConditionIs cond b)))) + (Hbody : S |-- (Forall (x : quantT), + (loopy_basic (I_logic x value = true /\\ I_state x value ** ConditionIs cond value) + pbody + (Obody x) + (P (transition_body x))))) + (H_after_test : forall x, catOP (Otest x) (O_after_test x) |-- O x) + (H_body_after_test : forall x, I_logic x value = true -> catOP (Obody x) (O (transition_body x)) |-- O_after_test x) + (H_empty : forall x, I_logic x (negb value) = true -> empOP |-- O_after_test x) + (Q_correct : forall x, I_logic x (negb value) = true /\\ I_state x (negb value) ** ConditionIs cond (negb value) |-- Q x) + (Q_safe : forall x, I_logic x value = true -> Q (transition_body x) |-- Q x) +: S |-- (Forall (x : quantT), + loopy_basic (P x) + (while ptest cond value pbody) + (O x) + (Q x)). +admit. +Defined. +Axiom behead : forall {T}, list T -> list T. +Axiom all : forall {T}, (T -> bool) -> list T -> bool. +Axiom all_behead : forall {T} (xs : list T) P, all P xs = true -> all P (behead xs) = true. +Instance IsPointed_foldlOP A B C f g (init : A * B) `{IsPointed_OPred (g init)} + `{forall a acc, IsPointed_OPred (g acc) -> IsPointed_OPred (g (f acc a))} + (ls : list C) +: IsPointed_OPred (g (foldl f init ls)). +admit. +Defined. +Goal forall (ptest : program) (cond : Condition) (value : bool) + (pbody : program) (T ioT : Type) (P : T -> SPred) + (I : T -> bool -> SPred) (accumulate : T -> ioT -> T) + (Otest Obody : T -> ioT -> PointedOPred) + (coq_test__is_finished : ioT -> bool) (S : spec) + (al : BYTE), + (forall (initial : T) (xs : list ioT) (x : ioT), + all (fun t : ioT => negb (coq_test__is_finished t)) xs = true -> + coq_test__is_finished x = true -> + S + |-- loopy_basic (P initial ** BYTEregIs AL al) ptest + (Otest initial (nth x xs 0)) + (I initial + (match coq_test__is_finished (nth x xs 0) with true => negb value | false => value end) ** + ConditionIs cond + (match coq_test__is_finished (nth x xs 0) with true => negb value | false => value end))) -> + (forall (initial : T) (xs : list ioT) (x : ioT), + all (fun t : ioT => negb (coq_test__is_finished t)) xs = true -> + xs <> nil -> + coq_test__is_finished x = true -> + S + |-- loopy_basic (I initial value ** ConditionIs cond value) pbody + (Obody initial (nth x xs 0)) + (P (accumulate initial (nth x xs 0)) ** BYTEregIs AL al)) -> + forall x : ioT, + coq_test__is_finished x = true -> + S + |-- Forall ixsp : {init_xs : T * list ioT & + all (fun t : ioT => negb (coq_test__is_finished t)) + (snd init_xs) = true}, + loopy_basic (P (fst (projT1 ixsp)) ** BYTEregIs AL al) + (while ptest cond value pbody) + (catOP + (snd + (foldl + (fun (xy : T * OPred) (v : ioT) => + (accumulate (fst xy) v, + catOP (catOP (Otest (fst xy) v) (Obody (fst xy) v)) + (snd xy))) (fst (projT1 ixsp), empOP) + (snd (projT1 ixsp)))) + (Otest (foldl accumulate (fst (projT1 ixsp)) (snd (projT1 ixsp))) + x)) + (I (foldl accumulate (fst (projT1 ixsp)) (snd (projT1 ixsp))) + (negb value) ** ConditionIs cond (negb value)). + intros. + eapply @while_rule_ind + with (I_logic := fun ixsp b => match (match (coq_test__is_finished (nth x (snd (projT1 ixsp)) 0)) with true => negb value | false => value end), b with true, true => true | false, false => true | _, _ => false end) + (Otest := fun ixsp => Otest (fst (projT1 ixsp)) (nth x (snd (projT1 ixsp)) 0)) + (Obody := fun ixsp => Obody (fst (projT1 ixsp)) (nth x (snd (projT1 ixsp)) 0)) + (I_state := fun ixsp => I (fst (projT1 ixsp))) + (transition_body := fun ixsp => let initial := fst (projT1 ixsp) in + let xs := snd (projT1 ixsp) in + existT _ (accumulate initial (nth x xs 0), behead xs) _) + (O_after_test := fun ixsp => let initial := fst (projT1 ixsp) in + let xs := snd (projT1 ixsp) in + match xs with | nil => default_PointedOPred empOP | _ => Obody initial (nth x xs 0) end); + simpl projT1; simpl projT2; simpl fst; simpl snd; clear; let H := fresh in assert (H : False) by (clear; admit); destruct H. + + Grab Existential Variables. + subst_body; simpl. + refine (all_behead (projT2 _)). diff --git a/test-suite/bugs/closed/3648.v b/test-suite/bugs/closed/3648.v new file mode 100644 index 00000000..ba6006ed --- /dev/null +++ b/test-suite/bugs/closed/3648.v @@ -0,0 +1,83 @@ +(* File reduced by coq-bug-finder from original input, then from 8808 lines to 424 lines, then from 432 lines to 196 lines, then from\ + 145 lines to 82 lines *) +(* coqc version trunk (September 2014) compiled on Sep 18 2014 21:0:5 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (07e4438bd758c2ced8caf09a6961ccd77d84e42b) *) + +Reserved Infix "o" (at level 40, left associativity). +Global Set Primitive Projections. + +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope object_scope with object. + +Record PreCategory := + { object :> Type; + morphism : object -> object -> Type; + + identity : forall x, morphism x x; + compose : forall s d d', + morphism d d' + -> morphism s d + -> morphism s d' + where "f 'o' g" := (compose f g) + }. +Arguments identity {!C%category} / x%object : rename. + +Infix "o" := (@compose _ _ _ _) : morphism_scope. + +Local Open Scope morphism_scope. +Definition prodC (C D : PreCategory) : PreCategory. + refine (@Build_PreCategory + (C * D)%type + (fun s d => (morphism C (fst s) (fst d) + * morphism D (snd s) (snd d))%type) + (fun x => (identity (fst x), identity (snd x))) + (fun s d d' m2 m1 => (fst m2 o fst m1, snd m2 o snd m1))). +Defined. + +Local Infix "*" := prodC : category_scope. + +Delimit Scope functor_scope with functor. + +Record Functor (C D : PreCategory) := + { + object_of :> C -> D; + morphism_of : forall s d, morphism C s d + -> morphism D (object_of s) (object_of d); + identity_of : forall x, morphism_of _ _ (identity x) + = identity (object_of x) + }. +Arguments morphism_of [C%category] [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch. +Notation "F '_1' m" := (morphism_of F m) (at level 10, no associativity) : morphism_scope. +Axiom cheat : forall {A}, A. +Record NaturalTransformation C D (F G : Functor C D) := { components_of :> forall c, morphism D (F c) (G c) }. +Definition functor_category (C D : PreCategory) : PreCategory. + exact (@Build_PreCategory (Functor C D) + (@NaturalTransformation C D) cheat cheat). +Defined. + +Local Notation "C -> D" := (functor_category C D) : category_scope. +Variable C1 : PreCategory. +Variable C2 : PreCategory. +Variable D : PreCategory. + +Definition functor_object_of +: (C1 -> (C2 -> D))%category -> (C1 * C2 -> D)%category. +Proof. + intro F; hnf in F |- *. + refine (Build_Functor + (prodC C1 C2) D + (fun c1c2 => F (fst c1c2) (snd c1c2)) + (fun s d m => F (fst d) _1 (snd m) o (@morphism_of _ _ F _ _ (fst m)) (snd s)) + _). + intros. + rewrite identity_of. + cbn. + rewrite (identity_of _ _ F (fst x)). + Undo. +(* Toplevel input, characters 20-55: +Error: +Found no subterm matching "F _1 (identity (fst x))" in the current goal. *) + rewrite identity_of. (* Toplevel input, characters 15-34: +Error: +Found no subterm matching "morphism_of ?202 (identity ?203)" in the current goal. *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/3652.v b/test-suite/bugs/closed/3652.v new file mode 100644 index 00000000..86e06137 --- /dev/null +++ b/test-suite/bugs/closed/3652.v @@ -0,0 +1,101 @@ +Require Setoid. +Require ZArith. +Import ZArith. + +Inductive Erasable(A : Set) : Prop := + erasable: A -> Erasable A. + +Arguments erasable [A] _. + +Hint Constructors Erasable. + +Scheme Erasable_elim := Induction for Erasable Sort Prop. + +Notation "## T" := (Erasable T) (at level 1, format "## T") : Erasable_scope. +Notation "# x" := (erasable x) (at level 1, format "# x") : Erasable_scope. +Open Scope Erasable_scope. + +Axiom Erasable_inj : forall {A : Set}{a b : A}, #a=#b -> a=b. + +Lemma Erasable_rw : forall (A: Set)(a b : A), (#a=#b) <-> (a=b). +Proof. + intros A a b. + split. + - apply Erasable_inj. + - congruence. +Qed. + +Open Scope Z_scope. +Opaque Z.mul. + +Infix "^" := Zpower_nat : Z_scope. + +Notation "f ; v <- x" := (let (v) := x in f) + (at level 199, left associativity) : Erasable_scope. +Notation "f ; < v" := (f ; v <- v) + (at level 199, left associativity) : Erasable_scope. +Notation "f |# v <- x" := (#f ; v <- x) + (at level 199, left associativity) : Erasable_scope. +Notation "f |# < v" := (#f ; < v) + (at level 199, left associativity) : Erasable_scope. + +Ltac name_evars id := + repeat match goal with |- context[?V] => + is_evar V; let H := fresh id in set (H:=V) in * end. + +Lemma Twoto0 : 2^0 = 1. +Proof. compute. reflexivity. Qed. + +Ltac ring_simplify' := rewrite ?Twoto0; ring_simplify. + +Definition mp2a1s(x : Z)(n : nat) := x * 2^n + (2^n-1). + +Hint Unfold mp2a1s. + +Definition zotval(n1s : nat)(is2 : bool)(next_value : Z) : Z := + 2 * mp2a1s next_value n1s + if is2 then 2 else 0. + +Inductive zot'(eis2 : ##bool)(value : ##Z) : Set := +| Zot'(is2 : bool) + (iseq : eis2=#is2) + {next_is2 : ##bool} + (ok : is2=true -> next_is2=#false) + {next_value : ##Z} + (n1s : nat) + (veq : value = (zotval n1s is2 next_value |#<next_value)) + (next : zot' next_is2 next_value) + : zot' eis2 value. + +Definition de2{eis2 value}(z : zot' eis2 value) : zot' #false value. +Proof. + case z. + intros is2 iseq next_is2 ok next_value n1s veq next. + subst. + destruct is2. + 2:trivial. + clear z. + specialize (ok eq_refl). subst. + destruct n1s. + - refine (Zot' _ _ _ _ _ _ _ _). + all:shelve_unifiable. + reflexivity. + discriminate. + name_evars e. + case_eq next_value. intros next_valueU next_valueEU. + case_eq e. intros eU eEU. + f_equal. + unfold zotval. + unfold mp2a1s. + ring_simplify'. + replace 2 with (2*1) at 2 7 by omega. + rewrite <-?Z.mul_assoc. + rewrite <-?Z.mul_add_distr_l. + rewrite <-Z.mul_sub_distr_l. + rewrite Z.mul_cancel_l by omega. + replace 1 with (2-1) at 1 by omega. + rewrite Z.add_sub_assoc. + rewrite Z.sub_cancel_r. + Unshelve. + all:case_eq next. +Abort. + diff --git a/test-suite/bugs/closed/3653.v b/test-suite/bugs/closed/3653.v new file mode 100644 index 00000000..947b3601 --- /dev/null +++ b/test-suite/bugs/closed/3653.v @@ -0,0 +1,12 @@ +Require Setoid. + +Variables P Q : forall {T : Set}, T -> Prop. + +Lemma rule{T : Set}{x : T} : Q x <-> P x. admit. Qed. + +Goal forall (T : Set)(x : T), Q x <-> P x. +Proof. +intros T x. +setoid_rewrite rule. +reflexivity. +Qed. diff --git a/test-suite/bugs/closed/3654.v b/test-suite/bugs/closed/3654.v new file mode 100644 index 00000000..15277235 --- /dev/null +++ b/test-suite/bugs/closed/3654.v @@ -0,0 +1,7 @@ +Tactic Notation "mysimpl" "in" ne_hyp_list(hyps) := simpl in hyps. + +Goal 0+0=0->0+0=0->0=0. +intros H1 H2. +mysimpl in H1 H2. +match goal with H:0=0 |- _ => exact H end. +Qed. diff --git a/test-suite/bugs/closed/3656.v b/test-suite/bugs/closed/3656.v new file mode 100644 index 00000000..cbd773d0 --- /dev/null +++ b/test-suite/bugs/closed/3656.v @@ -0,0 +1,53 @@ +Module A. + Set Primitive Projections. + Record hSet : Type := BuildhSet { setT : Type; iss : True }. + Ltac head_hnf_under_binders x := + match eval hnf in x with + | ?f _ => head_hnf_under_binders f + | (fun y => ?f y) => head_hnf_under_binders f + | ?y => y + end. +Goal forall s : hSet, True. +intros. +let x := head_hnf_under_binders setT in pose x. + +set (foo := eq_refl (@setT )). generalize foo. simpl. cbn. +Abort. +End A. + +Module A'. +Set Universe Polymorphism. + Set Primitive Projections. +Record hSet (A : Type) : Type := BuildhSet { setT : Type; iss : True }. +Ltac head_hnf_under_binders x := + match eval compute in x with + | ?f _ => head_hnf_under_binders f + | (fun y => ?f y) => head_hnf_under_binders f + | ?y => y + end. +Goal forall s : @hSet nat, True. +intros. +let x := head_hnf_under_binders setT in pose x. + +set (foo := eq_refl (@setT nat)). generalize foo. simpl. cbn. +Abort. +End A'. + +Set Primitive Projections. +Record hSet : Type := BuildhSet { setT : Type; iss : True }. +Ltac head_hnf_under_binders x := + match eval hnf in x with + | ?f _ => head_hnf_under_binders f + | (fun y => ?f y) => head_hnf_under_binders f + | ?y => y + end. +Goal setT = setT. + progress unfold setT. (* should not succeed *) + match goal with + | |- (fun h => setT h) = (fun h => setT h) => fail 1 "should not eta-expand" + | _ => idtac + end. (* should not fail *) +Abort. + +Goal forall h, setT h = setT h. +Proof. intro. progress unfold setT. diff --git a/test-suite/bugs/closed/3657.v b/test-suite/bugs/closed/3657.v new file mode 100644 index 00000000..778fdab1 --- /dev/null +++ b/test-suite/bugs/closed/3657.v @@ -0,0 +1,12 @@ +(* Check typing of replaced objects in change - even though the failure + was already a proper error message (but with a helpless content) *) + +Class foo {A} {a : A} := { bar := a; baz : bar = bar }. +Arguments bar {_} _ {_}. +Instance: forall A a, @foo A a. +intros; constructor. +abstract reflexivity. +Defined. +Goal @bar _ Set _ = (@bar _ (fun _ : Set => Set) _) nat. +Proof. + Fail change (bar (fun _ : Set => Set)) with (bar Set). diff --git a/test-suite/bugs/closed/3658.v b/test-suite/bugs/closed/3658.v new file mode 100644 index 00000000..b1158b9a --- /dev/null +++ b/test-suite/bugs/closed/3658.v @@ -0,0 +1,74 @@ +(* File reduced by coq-bug-finder from original input, then from 12178 lines to 457 lines, then from 500 lines to 147 lines, then from 175 lines to 56 lines *) +(* coqc version trunk (September 2014) compiled on Sep 21 2014 16:34:4 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (eaf864354c3fda9ddc1f03f0b1c7807b6fd44322) *) + +Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y. +Axiom ap : forall {A B:Type} (f:A -> B) {x y:A} (p:x = y), f x = f y. +Module NonPrim. + Class Contr_internal (A : Type) := { center : A ; contr : (forall y : A, center = y) }. + Arguments center A {_} / . + Inductive trunc_index : Type := minus_two | trunc_S (_ : trunc_index). + Notation "-2" := minus_two (at level 0). + Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | -2 => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. + Class IsTrunc (n : trunc_index) (A : Type) : Type := Trunc_is_trunc : IsTrunc_internal n A. + Notation Contr := (IsTrunc -2). + Hint Extern 0 => progress change Contr_internal with Contr in * : typeclass_instances. + Goal forall (H : Type) (H0 : H -> H -> Type) (H1 : Type) + (H2 : Contr H1) (H3 : H1) (H4 : H1 -> H) + (H5 : H0 (H4 (center H1)) (H4 H3)) + (H6 : H0 (H4 (center H1)) (H4 (center H1))), + transport (fun y : H => H0 (H4 (center H1)) y) (ap H4 (contr H3)) H6 = H5. + intros. + match goal with + | [ |- context[contr (center _)] ] => fail 1 "bad" + | _ => idtac + end. + match goal with + | [ H : _ |- _ ] => destruct (contr H) + end. + match goal with + | [ |- context[contr (center ?x)] ] => fail 1 "bad" x + | _ => idtac + end. + admit. + Defined. +End NonPrim. + +Module Prim. + Set Primitive Projections. + Class Contr_internal (A : Type) := { center : A ; contr : (forall y : A, center = y) }. + Arguments center A {_} / . + Inductive trunc_index : Type := minus_two | trunc_S (_ : trunc_index). + Notation "-2" := minus_two (at level 0). + Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | -2 => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. + Class IsTrunc (n : trunc_index) (A : Type) : Type := Trunc_is_trunc : IsTrunc_internal n A. + Notation Contr := (IsTrunc -2). + Hint Extern 0 => progress change Contr_internal with Contr in * : typeclass_instances. + Goal forall (H : Type) (H0 : H -> H -> Type) (H1 : Type) + (H2 : Contr H1) (H3 : H1) (H4 : H1 -> H) + (H5 : H0 (H4 (center H1)) (H4 H3)) + (H6 : H0 (H4 (center H1)) (H4 (center H1))), + transport (fun y : H => H0 (H4 (center H1)) y) (ap H4 (contr H3)) H6 = H5. + intros. + match goal with + | [ |- context[contr (center _)] ] => fail 1 "bad" + | _ => idtac + end. + match goal with + | [ H : _ |- _ ] => destruct (contr H) + end. + match goal with + | [ |- context[contr (center ?x)] ] => fail 1 "bad" x + | _ => idtac + end. (* Error: Tactic failure: bad H1. *) + admit. + Defined. +End Prim.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3660.v b/test-suite/bugs/closed/3660.v new file mode 100644 index 00000000..ed8964ce --- /dev/null +++ b/test-suite/bugs/closed/3660.v @@ -0,0 +1,27 @@ +Generalizable All Variables. +Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x). +Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope. +Open Scope function_scope. +Axiom ap : forall {A B:Type} (f:A -> B) {x y:A} (p:x = y), f x = f y. +Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A }. +Record Equiv A B := { equiv_fun :> A -> B ; equiv_isequiv :> IsEquiv equiv_fun }. +Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope. +Axiom IsHSet : Type -> Type. +Instance isequiv_compose `{IsEquiv A B f} `{IsEquiv B C g} : IsEquiv (compose g f) | 1000. +admit. +Defined. +Set Primitive Projections. +Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. +Canonical Structure default_HSet:= fun T P => (@BuildhSet T P). +Global Instance isequiv_ap_setT X Y : IsEquiv (@ap _ _ setT X Y). +admit. +Defined. +Local Open Scope equiv_scope. +Axiom equiv_path : forall (A B : Type) (p : A = B), A <~> B. + +Goal forall (C D : hSet), IsEquiv (fun x : C = D => (equiv_path C D (ap setT x))). + intros. + change (IsEquiv (equiv_path C D o @ap _ _ setT C D)). + apply @isequiv_compose; [ | admit ]. + Set Typeclasses Debug. + typeclasses eauto. diff --git a/test-suite/bugs/closed/3661.v b/test-suite/bugs/closed/3661.v new file mode 100644 index 00000000..fdca49bc --- /dev/null +++ b/test-suite/bugs/closed/3661.v @@ -0,0 +1,88 @@ +(* File reduced by coq-bug-finder from original input, then from 11218 lines to 438 lines, then from 434 lines to 202 lines, then from 140 lines to 94 lines *) +(* coqc version trunk (September 2014) compiled on Sep 25 2014 2:53:46 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (bec7e0914f4a7144cd4efa8ffaccc9f72dbdb790) *) +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a. +Set Implicit Arguments. +Delimit Scope morphism_scope with morphism. +Record PreCategory := { object :> Type ; morphism : object -> object -> Type }. +Bind Scope category_scope with PreCategory. +Local Open Scope morphism_scope. +Record Functor (C D : PreCategory) := + { object_of :> C -> D; + morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d) }. +Set Primitive Projections. +Class IsIsomorphism {C : PreCategory} {s d} (m : morphism C s d) := { morphism_inverse : morphism C d s }. +Record NaturalTransformation C D (F G : Functor C D) := { components_of :> forall c, morphism D (F c) (G c) }. +Unset Primitive Projections. +Class Isomorphic {C : PreCategory} s d := + { morphism_isomorphic :> morphism C s d; + isisomorphism_isomorphic :> IsIsomorphism morphism_isomorphic }. +Arguments morphism_inverse {C s d} m {_} / . +Local Notation "m ^-1" := (morphism_inverse m) (at level 3, format "m '^-1'") : morphism_scope. +Definition functor_category (C D : PreCategory) : PreCategory. + exact (@Build_PreCategory (Functor C D) + (@NaturalTransformation C D)). +Defined. +Local Notation "C -> D" := (functor_category C D) : category_scope. +Generalizable All Variables. +Definition isisomorphism_components_of `{@IsIsomorphism (C -> D) F G T} x : IsIsomorphism (T x). +Proof. + constructor. + exact (T^-1 x). +Defined. +Hint Immediate isisomorphism_components_of : typeclass_instances. +Goal forall (x3 x9 : PreCategory) (x12 f0 : Functor x9 x3) + (x35 : @Isomorphic (@functor_category x9 x3) f0 x12) + (x37 : object x9) + (H3 : morphism x3 (@object_of x9 x3 f0 x37) + (@object_of x9 x3 f0 x37)) + (x34 : @Isomorphic (@functor_category x9 x3) x12 f0) + (m : morphism x3 (x12 x37) (f0 x37) -> + morphism x3 (f0 x37) (x12 x37) -> + morphism x3 (f0 x37) (f0 x37)), + @paths + (morphism x3 (@object_of x9 x3 f0 x37) (@object_of x9 x3 f0 x37)) + H3 + (m + (@components_of x9 x3 x12 f0 + (@morphism_inverse (@functor_category x9 x3) f0 x12 + (@morphism_isomorphic (@functor_category x9 x3) f0 x12 x35) + (@isisomorphism_isomorphic (@functor_category x9 x3) f0 x12 + x35)) x37) + (@components_of x9 x3 f0 x12 + (@morphism_inverse (@functor_category x9 x3) x12 f0 + (@morphism_isomorphic (@functor_category x9 x3) x12 f0 x34) + (@isisomorphism_isomorphic (@functor_category x9 x3) x12 f0 + x34)) x37)). + Unset Printing All. + intros. + match goal with + | [ |- context[components_of ?T^-1 ?x] ] + => progress let T1 := constr:(T^-1 x) in + let T2 := constr:((T x)^-1) in + change T1 with T2 || fail 1 "too early" + end. + + Undo. + + match goal with + | [ |- context[components_of ?T^-1 ?x] ] + => progress let T1 := constr:(T^-1 x) in + change T1 with ((T x)^-1) || fail 1 "too early 2" + end. + + Undo. + + match goal with + | [ |- context[components_of ?T^-1 ?x] ] + => progress let T2 := constr:((T x)^-1) in + change (T^-1 x) with T2 + end. (* not convertible *) + +(* + + (@components_of x9 x3 x12 f0 + (@morphism_inverse _ _ _ + (@morphism_isomorphic (functor_category x9 x3) f0 x12 x35) _) x37) + +*)
\ No newline at end of file diff --git a/test-suite/bugs/closed/3662.v b/test-suite/bugs/closed/3662.v new file mode 100644 index 00000000..bd53389b --- /dev/null +++ b/test-suite/bugs/closed/3662.v @@ -0,0 +1,47 @@ +Set Primitive Projections. +Set Implicit Arguments. +Set Record Elimination Schemes. +Record prod A B := pair { fst : A ; snd : B }. +Definition f : Set -> Type := fun x => x. + +Goal (fst (pair (fun x => x + 1) nat) 0) = 0. +compute. +Undo. +cbv. +Undo. +Opaque fst. +cbn. +Transparent fst. +cbn. +Undo. +simpl. +Undo. +Abort. + +Goal f (fst (pair nat nat)) = nat. +compute. + match goal with + | [ |- fst ?x = nat ] => fail 1 "compute failed" + | [ |- nat = nat ] => idtac + end. + reflexivity. +Defined. + +Goal fst (pair nat nat) = nat. + unfold fst. + match goal with + | [ |- fst ?x = nat ] => fail 1 "compute failed" + | [ |- nat = nat ] => idtac + end. + reflexivity. +Defined. + +Lemma eta A B : forall x : prod A B, x = pair (fst x) (snd x). reflexivity. Qed. + +Goal forall x : prod nat nat, fst x = 0. + intros. unfold fst. + Fail match goal with + | [ |- fst ?x = 0 ] => idtac + end. +Abort. + diff --git a/test-suite/bugs/closed/3664.v b/test-suite/bugs/closed/3664.v new file mode 100644 index 00000000..41de74ff --- /dev/null +++ b/test-suite/bugs/closed/3664.v @@ -0,0 +1,23 @@ +Module NonPrim. + Unset Primitive Projections. + Record c := { d : Set }. + Definition a x := d x. + Goal forall x, a x. + intro x. + Fail progress simpl. (* [progress simpl] fails correctly *) + Fail progress cbn. (* [progress cbn] fails correctly *) + admit. + Defined. +End NonPrim. + +Module Prim. + Set Primitive Projections. + Record c := { d : Set }. + Definition a x := d x. + Goal forall x, a x. + intro x. + Fail progress simpl. (* [progress simpl] fails correctly *) + Fail progress cbn. (* [cbn] succeeds incorrectly, giving [d x] *) + admit. + Defined. +End Prim.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3665.v b/test-suite/bugs/closed/3665.v new file mode 100644 index 00000000..f6a13596 --- /dev/null +++ b/test-suite/bugs/closed/3665.v @@ -0,0 +1,33 @@ +(* File reduced by coq-bug-finder from original input, then from 5449 lines to 44 lines *) +(* coqc version trunk (September 2014) compiled on Sep 25 2014 2:53:46 with OCaml 4.01.0 + coqtop version trunk (September 2014) *) +Set Primitive Projections. + +Axiom IsHSet : Type -> Type. +Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. + +Module withdefault. +Canonical Structure default_HSet := fun T P => (@BuildhSet T P). +Goal forall (z : hSet) (T0 : Type -> Type), + (forall (A : Type) (P : T0 A -> Type) (aa : T0 A), P aa) -> + forall x0 : setT z, Set. + clear; intros z T H. + Set Debug Unification. + Fail refine (H _ _). (* Timeout! *) +Abort. +End withdefault. + +Module withnondefault. +Variable T0 : Type -> Type. +Variable T0hset: forall A, IsHSet (T0 A). + +Canonical Structure nondefault_HSet := fun A =>(@BuildhSet (T0 A) (T0hset A)). +Canonical Structure default_HSet := fun A P =>(@BuildhSet A P). +Goal forall (z : hSet) (T0 : Type -> Type), + (forall (A : Type) (P : T0 A -> Type) (aa : T0 A), P aa) -> + forall x0 : setT z, Set. + clear; intros z T H. + Set Debug Unification. + Fail refine (H _ _). (* Timeout! *) +Abort. +End withnondefault. diff --git a/test-suite/bugs/closed/3666.v b/test-suite/bugs/closed/3666.v new file mode 100644 index 00000000..a5b0e934 --- /dev/null +++ b/test-suite/bugs/closed/3666.v @@ -0,0 +1,50 @@ +(* File reduced by coq-bug-finder from original input, then from 11542 lines to 325 lines, then from 347 lines to 56 lines, then from 58 lines to 15 lines *) +(* coqc version trunk (September 2014) compiled on Sep 25 2014 2:53:46 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (bec7e0914f4a7144cd4efa8ffaccc9f72dbdb790) *) + +Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y. +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing). +Inductive V : Type@{U'} := | set {A : Type@{U}} (f : A -> V) : V. +Module NonPrim. + Record hProp := hp { hproptype :> Type ; isp : Set}. + Goal forall (A B : Type) (H_f : A -> V -> hProp) (H_g : B -> V -> hProp) + (C : Type) (h : C -> V) (b : B) (a : A) (c : C), + H_f a (h c) -> H_f a (h c) = H_g b (h c) -> H_g b (h c). + intros A B H_f H_g C h b a c H3 H'. + exact (@transport hProp (fun x => x) _ _ H' H3). + Undo. + Set Debug Unification. + exact (H' # H3). + Defined. +End NonPrim. + +Module Prim. + Set Primitive Projections. + Set Universe Polymorphism. + Record hProp := hp { hproptype :> Type ; isp : Set}. + Goal forall (A B : Type) (H_f : A -> V -> hProp) (H_g : B -> V -> hProp) + (C : Type) (h : C -> V) (b : B) (a : A) (c : C), + H_f a (h c) -> H_f a (h c) = H_g b (h c) -> H_g b (h c). + intros A B H_f H_g C h b a c H3 H'. + exact (@transport hProp (fun x => x) _ _ H' H3). + Undo. + Set Debug Unification. + exact (H' # H3). + (* Toplevel input, characters 7-14: +Error: +In environment +A : Type +B : Type +H_f : A -> V -> hProp +H_g : B -> V -> hProp +C : Type +h : C -> V +b : B +a : A +c : C +H3 : H_f a (h c) +H' : H_f a (h c) = H_g b (h c) +Unable to unify "hproptype (H_f a (h c))" with "?T (H_f a (h c))". + *) + Defined. +End Prim.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3667.v b/test-suite/bugs/closed/3667.v new file mode 100644 index 00000000..d2fc4d9b --- /dev/null +++ b/test-suite/bugs/closed/3667.v @@ -0,0 +1,25 @@ + +Set Primitive Projections. +Axiom ap10 : forall {A B} {f g:A->B} (h:f=g) x, f x = g x. +Axiom IsHSet : Type -> Type. +Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. +Canonical Structure default_HSet:= fun T P => (@BuildhSet T P). +Record PreCategory := { object :> Type ; morphism : object -> object -> Type }. +Record Functor (C D : PreCategory) := + { object_of :> C -> D; + morphism_of : forall s d, morphism C s d + -> morphism D (object_of s) (object_of d) }. +Set Implicit Arguments. +Record NaturalTransformation C D (F G : Functor C D) := + { components_of :> forall c, morphism D (F c) (G c); + commutes : forall s d (m : morphism C s d), components_of s = components_of s }. +Definition set_cat : PreCategory. + exact ((@Build_PreCategory hSet + (fun x y => x -> y))). +Defined. +Goal forall (A : PreCategory) (F : Functor A set_cat) + (a : A) (x : F a) (nt :NaturalTransformation F F), x = x. + intros. + pose (fun c d m => ap10 (commutes nt c d m)). + + diff --git a/test-suite/bugs/closed/3668.v b/test-suite/bugs/closed/3668.v new file mode 100644 index 00000000..547159b9 --- /dev/null +++ b/test-suite/bugs/closed/3668.v @@ -0,0 +1,53 @@ +(* File reduced by coq-bug-finder from original input, then from 6329 lines to 110 lines, then from 115 lines to 88 lines, then from 93 lines to 72 lines *) +(* coqc version trunk (September 2014) compiled on Sep 25 2014 2:53:46 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (bec7e0914f4a7144cd4efa8ffaccc9f72dbdb790) *) + +Notation "( x ; y )" := (existT _ x y). +Notation "x .1" := (projT1 x) (at level 3, format "x '.1'"). +Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A }. +Record Equiv A B := { equiv_fun :> A -> B ; equiv_isequiv :> IsEquiv equiv_fun }. +Notation "A <~> B" := (Equiv A B) (at level 85). +Axiom IsHProp : Type -> Type. +Inductive Bool := true | false. +Definition negb (b : Bool) := if b then false else true. +Hypothesis LEM : forall A : Type, IsHProp A -> A + (A -> False). +Axiom cheat : forall {A},A. +Module NonPrim. + Class Contr (A : Type) := { center : A ; contr : (forall y : A, center = y) }. + Definition Book_6_9 : forall X, X -> X. + Proof. + intro X. + pose proof (@LEM (Contr { f : X <~> X & ~(forall x, f x = x) }) cheat) as contrXEquiv. + destruct contrXEquiv as [[f H]|H]; [ exact f.1 | exact (fun x => x) ]. + Defined. + Lemma Book_6_9_not_id b : Book_6_9 Bool b = negb b. + Proof. + unfold Book_6_9. + destruct (@LEM (Contr { f : Bool <~> Bool & ~(forall x, f x = x) }) _) as [[f H']|H']. + match goal with + | [ |- equiv_fun Bool Bool f.1 b = negb b ] => idtac + | [ |- equiv_fun Bool Bool center.1 b = negb b ] => fail 1 "bad" + end. + all:admit. + Defined. +End NonPrim. +Module Prim. + Set Primitive Projections. + Class Contr (A : Type) := { center : A ; contr : (forall y : A, center = y) }. + Definition Book_6_9 : forall X, X -> X. + Proof. + intro X. + pose proof (@LEM (Contr { f : X <~> X & ~(forall x, f x = x) }) cheat) as contrXEquiv. + destruct contrXEquiv as [[f H]|H]; [ exact (f.1) | exact (fun x => x) ]. + Defined. + Lemma Book_6_9_not_id b : Book_6_9 Bool b = negb b. + Proof. + unfold Book_6_9. + destruct (@LEM (Contr { f : Bool <~> Bool & ~(forall x, f x = x) }) _) as [[f H']|H']. + match goal with + | [ |- equiv_fun Bool Bool f.1 b = negb b ] => idtac + | [ |- equiv_fun Bool Bool center.1 b = negb b ] => fail 1 "bad" + end. (* Tactic failure: bad *) + all:admit. + Defined. +End Prim.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3670.v b/test-suite/bugs/closed/3670.v new file mode 100644 index 00000000..c0f03261 --- /dev/null +++ b/test-suite/bugs/closed/3670.v @@ -0,0 +1,23 @@ +Set Universe Polymorphism. +Module Type FOO. + Parameter f : Type -> Type. + Parameter h : forall T, f T. +End FOO. + +Module Type BAR. + Include FOO. +End BAR. + +Module Type BAZ. + Include FOO. +End BAZ. + +Module BAR_FROM_BAZ (baz : BAZ) <: BAR. + + Definition f : Type -> Type. + Proof. exact baz.f. Defined. + + Definition h : forall T, f T. + Admitted. + +Fail End BAR_FROM_BAZ. diff --git a/test-suite/bugs/closed/3672.v b/test-suite/bugs/closed/3672.v new file mode 100644 index 00000000..283be495 --- /dev/null +++ b/test-suite/bugs/closed/3672.v @@ -0,0 +1,27 @@ +Set Primitive Projections. (* No failures without this option. *) + +Record AT := +{ atype :> Type +; coerce : atype -> Type +}. +Coercion coerce : atype >-> Sortclass. + +Record Ar C (A:AT) := { ar : forall (X Y : C), A }. + +Definition t := forall C A a X, coerce _ (ar C A a X X). +Definition t' := forall C A a X, ar C A a X X. + +(* The command has indeed failed with message: +=> Error: The term "ar C A a X X" has type "atype A" which is not a (co-)inductive type. +*) + +Record Ar2 C (A:AT) := +{ ar2 : forall (X Y : C), A +; id2 : forall X, coerce _ (ar2 X X) }. + +Record Ar3 C (A:AT) := +{ ar3 : forall (X Y : C), A +; id3 : forall X, ar3 X X }. +(* The command has indeed failed with message: +=> Anomaly: Bad recursive type. Please report. +*)
\ No newline at end of file diff --git a/test-suite/bugs/closed/3675.v b/test-suite/bugs/closed/3675.v new file mode 100644 index 00000000..93227ab8 --- /dev/null +++ b/test-suite/bugs/closed/3675.v @@ -0,0 +1,20 @@ +Set Primitive Projections. +Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x). +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := match p, q with idpath, idpath => idpath end. +Notation "p @ q" := (concat p q) (at level 20) : path_scope. +Axiom ap : forall {A B:Type} (f:A -> B) {x y:A} (p:x = y), f x = f y. +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. +Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A ; eisretr : forall x, f (equiv_inv x) = x }. +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : equiv_scope. +Local Open Scope path_scope. +Local Open Scope equiv_scope. +Generalizable Variables A B C f g. +Lemma isequiv_compose `{IsEquiv A B f} `{IsEquiv B C g} +: IsEquiv (compose g f). +Proof. + refine (Build_IsEquiv A C + (compose g f) + (compose f^-1 g^-1) _). + exact (fun c => ap g (@eisretr _ _ f _ (g^-1 c)) @ (@eisretr _ _ g _ c)). diff --git a/test-suite/bugs/closed/3682.v b/test-suite/bugs/closed/3682.v new file mode 100644 index 00000000..b8c5b4d5 --- /dev/null +++ b/test-suite/bugs/closed/3682.v @@ -0,0 +1,5 @@ +Class Foo. +Definition bar `{Foo} (x : Set) := Set. +Instance: Foo. +Definition bar1 := bar nat. +Definition bar2 := bar $(admit)$. diff --git a/test-suite/bugs/closed/3684.v b/test-suite/bugs/closed/3684.v new file mode 100644 index 00000000..94ce4a60 --- /dev/null +++ b/test-suite/bugs/closed/3684.v @@ -0,0 +1,4 @@ +Definition foo : Set. +Proof. + refine ($(abstract admit)$). +Qed. diff --git a/test-suite/bugs/closed/3686.v b/test-suite/bugs/closed/3686.v new file mode 100644 index 00000000..ee6b334b --- /dev/null +++ b/test-suite/bugs/closed/3686.v @@ -0,0 +1,62 @@ +Set Universe Polymorphism. +Set Implicit Arguments. +Record PreCategory := { object :> Type ; morphism : object -> object -> Type }. +Bind Scope category_scope with PreCategory. +Record Functor (C D : PreCategory) := + { object_of :> C -> D; + morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d); + identity_of : forall s m, morphism_of s s m = morphism_of s s m }. +Definition sub_pre_cat (P : PreCategory -> Type) : PreCategory. +Proof. + exact (@Build_PreCategory PreCategory Functor). +Defined. +Definition opposite (C : PreCategory) : PreCategory. +Proof. + exact (@Build_PreCategory C (fun s d => morphism C d s)). +Defined. +Local Notation "C ^op" := (opposite C) (at level 3, format "C '^op'") : category_scope. +Definition prod (C D : PreCategory) : PreCategory. +Proof. + refine (@Build_PreCategory + (C * D)%type + (fun s d => (morphism C (fst s) (fst d) * morphism D (snd s) (snd d))%type)). +Defined. +Local Infix "*" := prod : category_scope. +Axiom functor_category : PreCategory -> PreCategory -> PreCategory. +Local Notation "C -> D" := (functor_category C D) : category_scope. +Module Export PointwiseCore. + Definition pointwise + (C C' : PreCategory) + (F : Functor C' C) + (D D' : PreCategory) + (G : Functor D D') + : Functor (C -> D) (C' -> D'). + Proof. + refine (Build_Functor + (C -> D) (C' -> D') + _ + _ + _); + abstract admit. + Defined. +End PointwiseCore. +Axiom Pidentity_of : forall (C D : PreCategory) (F : Functor C C) (G : Functor D D), pointwise F G = pointwise F G. +Local Open Scope category_scope. +Definition functor_uncurried (P : PreCategory -> Type) + (has_functor_categories : forall C D : @sub_pre_cat P, P (C -> D)) +: object (((@sub_pre_cat P)^op * (@sub_pre_cat P)) -> (@sub_pre_cat P)). +Proof. + pose (let object_of := (fun CD => (((fst CD) -> (snd CD)))) + in Build_Functor + ((@sub_pre_cat P)^op * (@sub_pre_cat P)) (@sub_pre_cat P) + object_of + (fun CD C'D' FG => pointwise (fst FG) (snd FG)) + (fun _ _ => Pidentity_of _ _)) || fail "early". + Include PointwiseCore. + pose (let object_of := (fun CD => (((fst CD) -> (snd CD)))) + in Build_Functor + ((@sub_pre_cat P)^op * (@sub_pre_cat P)) (@sub_pre_cat P) + object_of + (fun CD C'D' FG => pointwise (fst FG) (snd FG)) + (fun _ _ => Pidentity_of _ _)). +Abort. diff --git a/test-suite/bugs/closed/3692.v b/test-suite/bugs/closed/3692.v new file mode 100644 index 00000000..72973a8d --- /dev/null +++ b/test-suite/bugs/closed/3692.v @@ -0,0 +1,26 @@ +Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). +Reserved Notation "x = y" (at level 70, no associativity). +Reserved Notation "x * y" (at level 40, left associativity). +Delimit Scope core_scope with core. +Open Scope core_scope. +Notation "A -> B" := (forall (_ : A), B) : type_scope. +Global Set Primitive Projections. +Global Set Implicit Arguments. +Record prod (A B : Type) := pair { fst : A ; snd : B }. +Notation "x * y" := (prod x y) : type_scope. +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. +Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A ; eisretr : Sect equiv_inv f }. +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'"). +Generalizable Variables X A B f g n. +Axiom path_prod' : forall {A B : Type} {x x' : A} {y y' : B}, (x = x') -> (y = y') -> ((x,y) = (x',y')). +Definition functor_prod {A A' B B' : Type} (f:A->A') (g:B->B') +: A * B -> A' * B'. + exact (fun z => (f (fst z), g (snd z))). +Defined. +Definition isequiv_functor_prod `{IsEquiv A A' f} `{IsEquiv B B' g} +: IsEquiv (functor_prod f g) + := @Build_IsEquiv + _ _ (functor_prod f g) (functor_prod f^-1 g^-1) + (fun z => path_prod' (@eisretr _ _ f _ (fst z)) (@eisretr _ _ g _ (snd z))). diff --git a/test-suite/bugs/closed/3698.v b/test-suite/bugs/closed/3698.v new file mode 100644 index 00000000..3c53d243 --- /dev/null +++ b/test-suite/bugs/closed/3698.v @@ -0,0 +1,25 @@ +(* File reduced by coq-bug-finder from original input, then from 5479 lines to 4682 lines, then from 4214 lines to 86 lines, then from 60 lines to 25 lines *) +(* coqc version trunk (October 2014) compiled on Oct 1 2014 18:13:54 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (68846802a7be637ec805a5e374655a426b5723a5) *) +Set Primitive Projections. +Notation "( x ; y )" := (existT _ x y) : fibration_scope. +Open Scope fibration_scope. +Notation pr1 := projT1. +Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope. +Axiom ap : forall {A B:Type} (f:A -> B) {x y:A} (p:x = y), f x = f y. +Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A }. +Record Equiv A B := { equiv_fun :> A -> B ; equiv_isequiv :> IsEquiv equiv_fun }. +Global Existing Instance equiv_isequiv. +Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope. +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : equiv_scope. +Axiom IsHSet : Type -> Type. +Local Open Scope equiv_scope. +Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. +Canonical Structure default_HSet:= fun T P => (@BuildhSet T P). +Axiom issig_hSet: (sigT IsHSet) <~> hSet. +Definition isequiv_ap_setT X Y : IsEquiv (@ap _ _ setT X Y). +Proof. + assert (H'' : forall g : X = Y -> (issig_hSet^-1 X).1 = (issig_hSet^-1 Y).1, + g = g -> IsEquiv g) by admit. + Eval compute in (@projT1 Type IsHSet (@equiv_inv _ _ _ (equiv_isequiv _ _ issig_hSet) X)). + Fail apply H''. (* stack overflow *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/3699.v b/test-suite/bugs/closed/3699.v new file mode 100644 index 00000000..99b3d79e --- /dev/null +++ b/test-suite/bugs/closed/3699.v @@ -0,0 +1,162 @@ +(* File reduced by coq-bug-finder from original input, then from 9593 lines to 104 lines, then from 187 lines to 103 lines, then from 113 lines to 90 lines *) +(* coqc version trunk (October 2014) compiled on Oct 1 2014 18:13:54 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (68846802a7be637ec805a5e374655a426b5723a5) *) +Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y. +Inductive trunc_index := minus_two | trunc_S (_ : trunc_index). +Axiom IsTrunc : trunc_index -> Type -> Type. +Existing Class IsTrunc. +Axiom Contr : Type -> Type. +Inductive Trunc (n : trunc_index) (A :Type) : Type := tr : A -> Trunc n A. +Module NonPrim. + Unset Primitive Projections. + Set Implicit Arguments. + Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }. + Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope. + Unset Implicit Arguments. + Notation "( x ; y )" := (existT _ x y) : fibration_scope. + Open Scope fibration_scope. + Notation pr1 := projT1. + Notation pr2 := projT2. + Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope. + Notation "x .2" := (pr2 x) (at level 3, format "x '.2'") : fibration_scope. + Definition hfiber {A B : Type} (f : A -> B) (y : B) := { x : A & f x = y }. + Class IsConnected (n : trunc_index) (A : Type) := isconnected_contr_trunc :> Contr (Trunc n A). + Axiom isconnected_elim : forall {n} {A} `{IsConnected n A} + (C : Type) `{IsTrunc n C} (f : A -> C), + { c:C & forall a:A, f a = c }. + Class IsConnMap (n : trunc_index) {A B : Type} (f : A -> B) + := isconnected_hfiber_conn_map :> forall b:B, IsConnected n (hfiber f b). + Definition conn_map_elim {n : trunc_index} + {A B : Type} (f : A -> B) `{IsConnMap n _ _ f} + (P : B -> Type) {HP : forall b:B, IsTrunc n (P b)} + (d : forall a:A, P (f a)) + : forall b:B, P b. + Proof. + intros b. + refine (pr1 (isconnected_elim _ _)). + 2:exact b. + intro x. + exact (transport P x.2 (d x.1)). + Defined. + + Definition conn_map_elim' {n : trunc_index} + {A B : Type} (f : A -> B) `{IsConnMap n _ _ f} + (P : B -> Type) {HP : forall b:B, IsTrunc n (P b)} + (d : forall a:A, P (f a)) + : forall b:B, P b. + Proof. + intros b. + refine (pr1 (isconnected_elim _ _)). + 2:exact b. + intros [a p]. + exact (transport P p (d a)). + Defined. + + Definition conn_map_comp {n : trunc_index} + {A B : Type} (f : A -> B) `{IsConnMap n _ _ f} + (P : B -> Type) {HP : forall b:B, IsTrunc n (P b)} + (d : forall a:A, P (f a)) + : forall a:A, conn_map_elim f P d (f a) = d a /\ conn_map_elim' f P d (f a) = d a. + Proof. + intros a. + unfold conn_map_elim, conn_map_elim'. + Set Printing Coercions. + set (fibermap := fun a0p : hfiber f (f a) + => let (a0, p) := a0p in transport P p (d a0)). + Set Printing Implicit. + let G := match goal with |- ?G => constr:G end in + first [ match goal with + | [ |- (@isconnected_elim n (@hfiber A B f (f a)) + (@isconnected_hfiber_conn_map n A B f H (f a)) + (P (f a)) (HP (f a)) + (fun x : @hfiber A B f (f a) => + @transport B P (f x.1) (f a) x.2 (d x.1))).1 = + d a /\ _ ] => idtac + end + | fail 1 "projection names should be folded, [let] should generate unfolded projections, goal:" G ]; + first [ match goal with + | [ |- _ /\ (@isconnected_elim n (@hfiber A B f (f a)) + (@isconnected_hfiber_conn_map n A B f H (f a)) + (P (f a)) (HP (f a)) fibermap).1 = d a ] => idtac + end + | fail 1 "destruct should generate unfolded projections, as should [let], goal:" G ]. + admit. + Defined. +End NonPrim. + +Module Prim. + Set Primitive Projections. + Set Implicit Arguments. + Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }. + Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope. + Unset Implicit Arguments. + Notation "( x ; y )" := (existT _ x y) : fibration_scope. + Open Scope fibration_scope. + Notation pr1 := projT1. + Notation pr2 := projT2. + Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope. + Notation "x .2" := (pr2 x) (at level 3, format "x '.2'") : fibration_scope. + Definition hfiber {A B : Type} (f : A -> B) (y : B) := { x : A & f x = y }. + Class IsConnected (n : trunc_index) (A : Type) := isconnected_contr_trunc :> Contr (Trunc n A). + Axiom isconnected_elim : forall {n} {A} `{IsConnected n A} + (C : Type) `{IsTrunc n C} (f : A -> C), + { c:C & forall a:A, f a = c }. + Class IsConnMap (n : trunc_index) {A B : Type} (f : A -> B) + := isconnected_hfiber_conn_map :> forall b:B, IsConnected n (hfiber f b). + Definition conn_map_elim {n : trunc_index} + {A B : Type} (f : A -> B) `{IsConnMap n _ _ f} + (P : B -> Type) {HP : forall b:B, IsTrunc n (P b)} + (d : forall a:A, P (f a)) + : forall b:B, P b. + Proof. + intros b. + refine (pr1 (isconnected_elim _ _)). + 2:exact b. + intro x. + exact (transport P x.2 (d x.1)). + Defined. + + Definition conn_map_elim' {n : trunc_index} + {A B : Type} (f : A -> B) `{IsConnMap n _ _ f} + (P : B -> Type) {HP : forall b:B, IsTrunc n (P b)} + (d : forall a:A, P (f a)) + : forall b:B, P b. + Proof. + intros b. + refine (pr1 (isconnected_elim _ _)). + 2:exact b. + intros [a p]. + exact (transport P p (d a)). + Defined. + + Definition conn_map_comp {n : trunc_index} + {A B : Type} (f : A -> B) `{IsConnMap n _ _ f} + (P : B -> Type) {HP : forall b:B, IsTrunc n (P b)} + (d : forall a:A, P (f a)) + : forall a:A, conn_map_elim f P d (f a) = d a /\ conn_map_elim' f P d (f a) = d a. + Proof. + intros a. + unfold conn_map_elim, conn_map_elim'. + Set Printing Coercions. + set (fibermap := fun a0p : hfiber f (f a) + => let (a0, p) := a0p in transport P p (d a0)). + Set Printing Implicit. + let G := match goal with |- ?G => constr:G end in + first [ match goal with + | [ |- (@isconnected_elim n (@hfiber A B f (f a)) + (@isconnected_hfiber_conn_map n A B f H (f a)) + (P (f a)) (HP (f a)) + (fun x : @hfiber A B f (f a) => + @transport B P (f x.1) (f a) x.2 (d x.1))).1 = + d a /\ _ ] => idtac + end + | fail 1 "projection names should be folded, [let] should generate unfolded projections, goal:" G ]; + first [ match goal with + | [ |- _ /\ (@isconnected_elim n (@hfiber A B f (f a)) + (@isconnected_hfiber_conn_map n A B f H (f a)) + (P (f a)) (HP (f a)) fibermap).1 = d a ] => idtac + end + | fail 1 "destruct should generate unfolded projections, as should [let], goal:" G ]. + admit. + Defined. +End Prim.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3700.v b/test-suite/bugs/closed/3700.v new file mode 100644 index 00000000..4e226524 --- /dev/null +++ b/test-suite/bugs/closed/3700.v @@ -0,0 +1,84 @@ + +Set Implicit Arguments. +Module NonPrim. + Unset Primitive Projections. + Record prod A B := pair { fst : A ; snd : B }. +End NonPrim. +Module Prim. + Set Primitive Projections. + Record prod A B := pair { fst : A ; snd : B }. +End Prim. +Goal (forall x : NonPrim.prod Set Set, let (a, b) := x in a = a) +/\ (forall x : Prim.prod Set Set, let (a, b) := x in a = a). + Show. (* (forall x : NonPrim.prod Set Set, let (a, _) := x in a = a) /\ + (forall x : Prim.prod Set Set, + let a := Prim.fst x in let b := Prim.snd x in a = a) *) + Set Printing All. + Show. (* and + (forall x : NonPrim.prod Set Set, + match x return Prop with + | NonPrim.pair a _ => @eq Set a a + end) + (forall x : Prim.prod Set Set, + let a := @Prim.fst Set Set x in + let b := @Prim.snd Set Set x in @eq Set a a) *) + Unset Printing All. +Abort. +Goal (forall x : NonPrim.prod Set Set, match x with NonPrim.pair a b => a = a end) +/\ (forall x : Prim.prod Set Set, match x with Prim.pair a b => a = a end). + Show. (* (forall x : NonPrim.prod Set Set, + match x with + | {| NonPrim.fst := a |} => a = a + end) /\ (forall x : Prim.prod Set Set, Prim.fst x = Prim.fst x) *) + (** Wrong: [match] should generate unfolded things *) + Set Printing All. + Show. (* and + (forall x : NonPrim.prod Set Set, + match x return Prop with + | NonPrim.pair a _ => @eq Set a a + end) + (forall x : Prim.prod Set Set, + @eq Set (@Prim.fst Set Set x) (@Prim.fst Set Set x)) *) + Unset Printing All. +Abort. +Goal (forall x : NonPrim.prod Set Set, let (a, b) := x in a = a /\ b = b) +/\ (forall x : Prim.prod Set Set, let (a, b) := x in a = a /\ b = b). + Show. (* (forall x : NonPrim.prod Set Set, let (a, b) := x in a = a /\ b = b) /\ + (forall x : Prim.prod Set Set, + let a := Prim.fst x in let b := Prim.snd x in a = a /\ b = b) *) + (** Understandably different, maybe, but should still be unfolded *) + Set Printing All. + Show. (* and + (forall x : NonPrim.prod Set Set, + match x return Prop with + | NonPrim.pair a b => and (@eq Set a a) (@eq Set b b) + end) + (forall x : Prim.prod Set Set, + let a := @Prim.fst Set Set x in + let b := @Prim.snd Set Set x in and (@eq Set a a) (@eq Set b b)) *) + Unset Printing All. +Abort. +Goal (forall x : NonPrim.prod Set Set, match x with NonPrim.pair a b => a = a /\ b = b end) +/\ (forall x : Prim.prod Set Set, match x with Prim.pair a b => a = a /\ b = b end). + Show. (* (forall x : NonPrim.prod Set Set, + match x with + | {| NonPrim.fst := a; NonPrim.snd := b |} => a = a /\ b = b + end) /\ + (forall x : Prim.prod Set Set, + Prim.fst x = Prim.fst x /\ Prim.snd x = Prim.snd x) *) + Set Printing All. + Show. + + set(foo:=forall x : Prim.prod Set Set, match x return Set with + | Prim.pair fst _ => fst + end). + (* and + (forall x : NonPrim.prod Set Set, + match x return Prop with + | NonPrim.pair a b => and (@eq Set a a) (@eq Set b b) + end) + (forall x : Prim.prod Set Set, + and (@eq Set (@Prim.fst Set Set x) (@Prim.fst Set Set x)) + (@eq Set (@Prim.snd Set Set x) (@Prim.snd Set Set x))) *) + Unset Printing All. +Abort.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3709.v b/test-suite/bugs/closed/3709.v new file mode 100644 index 00000000..7f01be7a --- /dev/null +++ b/test-suite/bugs/closed/3709.v @@ -0,0 +1,23 @@ +Module NonPrim. + Unset Primitive Projections. + Record hProp := hp { hproptype :> Type }. + Goal forall (h : (Type -> hProp) -> (Type -> hProp)) k f, + (forall y, h y = y) -> + h (fun b : Type => {| hproptype := f b |}) = k. + Proof. + intros h k f H. + etransitivity. + apply H. + admit. + Defined. +End NonPrim. +Module Prim. + Set Primitive Projections. + Record hProp := hp { hproptype :> Type }. + Goal forall (h : (Type -> hProp) -> (Type -> hProp)) k f, + (forall y, h y = y) -> + h (fun b : Type => {| hproptype := f b |}) = k. + Proof. + intros h k f H. + etransitivity. + apply H. diff --git a/test-suite/bugs/closed/3710.v b/test-suite/bugs/closed/3710.v new file mode 100644 index 00000000..b9e2798d --- /dev/null +++ b/test-suite/bugs/closed/3710.v @@ -0,0 +1,48 @@ +(* File reduced by coq-bug-finder from original input, then from 13477 lines to 1457 lines, then from 1553 lines to 1586 lines, then \ +from 1574 lines to 823 lines, then from 837 lines to 802 lines, then from 793 lines to 657 lines, then from 661 lines to 233 lines, t\ +hen from 142 lines to 65 lines *) +(* coqc version trunk (October 2014) compiled on Oct 8 2014 13:38:17 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (335cf2860bfd9e714d14228d75a52fd2c88db386) *) +Set Universe Polymorphism. +Set Primitive Projections. +Set Implicit Arguments. +Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }. +Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope. +Definition relation (A : Type) := A -> A -> Type. +Class Reflexive {A} (R : relation A) := reflexivity : forall x : A, R x x. +Notation "( x ; y )" := (existT _ x y). +Notation "x .1" := (projT1 x) (at level 3, format "x '.1'"). +Reserved Infix "o" (at level 40, left associativity). +Delimit Scope category_scope with category. +Record PreCategory := + { object :> Type; + morphism : object -> object -> Type; + compose : forall s d d', morphism d d' -> morphism s d -> morphism s d' }. +Delimit Scope functor_scope with functor. +Record Functor (C D : PreCategory) := { object_of :> C -> D }. +Local Open Scope category_scope. +Class Isomorphic {C : PreCategory} (s d : C) := {}. +Axiom composeF : forall C D E (G : Functor D E) (F : Functor C D), Functor C E. +Infix "o" := composeF : functor_scope. +Local Open Scope functor_scope. +Definition sub_pre_cat {P : PreCategory -> Type} : PreCategory. + exact (@Build_PreCategory + { C : PreCategory & P C } + (fun C D => Functor C.1 D.1) + (fun _ _ _ F G => F o G)). +Defined. +Record NaturalTransformation C D (F G : Functor C D) := { components_of :> forall c, morphism D (F c) (G c) }. +Axiom composeT : forall C D (F F' F'' : Functor C D) (T' : NaturalTransformation F' F'') (T : NaturalTransformation F F'), + NaturalTransformation F F''. +Definition functor_category (C D : PreCategory) : PreCategory. + exact (@Build_PreCategory (Functor C D) + (@NaturalTransformation C D) + (@composeT C D)). +Defined. +Local Notation "C -> D" := (functor_category C D) : category_scope. +Definition NaturalIsomorphism (C D : PreCategory) F G : Type := @Isomorphic (C -> D) F G. +Context `{P : PreCategory -> Type}. +Local Notation cat := (@sub_pre_cat P). +Goal forall (s d d' : cat) (m1 : morphism cat d d') (m2 : morphism cat s d), + NaturalIsomorphism (m1 o m2) (m1 o m2)%functor. +Fail exact (fun _ _ _ _ _ => reflexivity _). diff --git a/test-suite/bugs/closed/3723.v b/test-suite/bugs/closed/3723.v new file mode 100644 index 00000000..d0b77c45 --- /dev/null +++ b/test-suite/bugs/closed/3723.v @@ -0,0 +1,6 @@ +(* Bugs #3787 and #3723 on reinitializing camlp5 levels *) + +Definition a := True. +Reserved Notation "-- x" (at level 50, x at level 20). +Reserved Notation "--- x" (at level 20). +Reset a. diff --git a/test-suite/bugs/closed/3782.v b/test-suite/bugs/closed/3782.v new file mode 100644 index 00000000..08d456fc --- /dev/null +++ b/test-suite/bugs/closed/3782.v @@ -0,0 +1,63 @@ +(* File reduced by coq-bug-finder from original input, then from 2674 lines to 136 lines, then from 115 lines to 61 lines *) +(* coqc version trunk (October 2014) compiled on Oct 28 2014 14:33:38 with OCaml 4.01.0 + coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-trunk,(no branch) (53bfe9cf58a3c40e6eb7120d25c1633a9cea3126) *) +Class IsEquiv {A B : Type} (f : A -> B) := {}. +Record Equiv A B := { equiv_fun : A -> B ; equiv_isequiv : IsEquiv equiv_fun }. +Arguments equiv_fun {A B} _ _. +Record PreCategory := { object :> Type ; morphism : object -> object -> Type }. +Set Printing Coercions. +Set Printing Implicit. +Module NonPrim. + Unset Primitive Projections. + Record TruncType (n : nat) := { trunctype_type :> Type }. + Canonical Structure default_TruncType := fun n T => (@Build_TruncType n T). + Goal (forall (s d : TruncType 0) (m : trunctype_type 0 s -> trunctype_type 0 d), + @IsEquiv (trunctype_type 0 s) (trunctype_type 0 d) m -> Type) -> + forall (T T0 : Type) (m : T0 -> T), @IsEquiv T0 T m -> True. + intros isiso_isequiv' mc md e e'. + (pose (@isiso_isequiv' + _ _ + (e + : (Build_TruncType 0 md) -> + (Build_TruncType 0 mc)) + e') as i || fail "too early"); clear i. + pose (@isiso_isequiv' + _ _ _ + e'). + admit. + Defined. +End NonPrim. +Module Prim. + Set Primitive Projections. + Record TruncType (n : nat) := { trunctype_type :> Type }. + Canonical Structure default_TruncType := fun n T => (@Build_TruncType n T). + Goal (forall (s d : TruncType 0) (m : trunctype_type 0 s -> trunctype_type 0 d), + @IsEquiv (trunctype_type 0 s) (trunctype_type 0 d) m -> Type) -> + forall (T T0 : Type) (m : T0 -> T), @IsEquiv T0 T m -> True. + intros isiso_isequiv' mc md e e'. + (pose (@isiso_isequiv' + _ _ + (e + : (Build_TruncType 0 md) -> + (Build_TruncType 0 mc)) + e') as i || fail "too early"); clear i. + Set Printing Existential Instances. + Set Debug Unification. + pose (@isiso_isequiv' + _ _ _ + e'). (* Toplevel input, characters 48-50: +Error: +In environment +isiso_isequiv' : forall (s d : TruncType 0) + (m : trunctype_type 0 s -> trunctype_type 0 d), + @IsEquiv (trunctype_type 0 s) (trunctype_type 0 d) m -> Type +mc : Type +md : Type +e : md -> mc +e' : @IsEquiv md mc e +The term "e'" has type "@IsEquiv md mc e" while it is expected to have type + "@IsEquiv (trunctype_type 0 ?t) (trunctype_type 0 ?t0) ?t1". + *) + admit. + Defined. +End Prim.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3788.v b/test-suite/bugs/closed/3788.v new file mode 100644 index 00000000..2c5b9cb0 --- /dev/null +++ b/test-suite/bugs/closed/3788.v @@ -0,0 +1,6 @@ +Set Implicit Arguments. +Global Set Primitive Projections. +Record Functor (C D : Type) := { object_of :> forall _ : C, D }. +Axiom path_functor_uncurried : forall C D (F G : Functor C D) (_ : sigT (fun HO : object_of F = object_of G => Set)), F = G. +Fail Lemma path_functor_uncurried_snd C D F G HO HM +: (@path_functor_uncurried C D F G (existT _ HO HM)) = HM. diff --git a/test-suite/bugs/closed/3792.v b/test-suite/bugs/closed/3792.v new file mode 100644 index 00000000..39057b9c --- /dev/null +++ b/test-suite/bugs/closed/3792.v @@ -0,0 +1,4 @@ +Fail Definition pull_if_dep +: forall {A} (P : bool -> Type) (a : A true) (a' : A false) + (b : bool), + P (if b as b return A b then a else a'). diff --git a/test-suite/bugs/closed/shouldsucceed/38.v b/test-suite/bugs/closed/38.v index 4fc8d7c9..4fc8d7c9 100644 --- a/test-suite/bugs/closed/shouldsucceed/38.v +++ b/test-suite/bugs/closed/38.v diff --git a/test-suite/bugs/closed/3804.v b/test-suite/bugs/closed/3804.v new file mode 100644 index 00000000..da9290cb --- /dev/null +++ b/test-suite/bugs/closed/3804.v @@ -0,0 +1,12 @@ +Set Universe Polymorphism. +Module Foo. + Definition T : sigT (fun x => x). + Proof. + exists Set. + abstract exact nat. + Defined. +End Foo. +Module Bar. + Include Foo. +End Bar. +Definition foo := eq_refl : Foo.T = Bar.T. diff --git a/test-suite/bugs/closed/3821.v b/test-suite/bugs/closed/3821.v new file mode 100644 index 00000000..8da4f736 --- /dev/null +++ b/test-suite/bugs/closed/3821.v @@ -0,0 +1,2 @@ +Inductive quotient {A : Type@{i}} {B : Type@{j}} : Type@{max(i, j)} := . + diff --git a/test-suite/bugs/closed/3828.v b/test-suite/bugs/closed/3828.v new file mode 100644 index 00000000..ae11c6c9 --- /dev/null +++ b/test-suite/bugs/closed/3828.v @@ -0,0 +1,2 @@ +Goal 0 = 0. +Fail pose ?Goal. diff --git a/test-suite/bugs/closed/3848.v b/test-suite/bugs/closed/3848.v new file mode 100644 index 00000000..b66aecca --- /dev/null +++ b/test-suite/bugs/closed/3848.v @@ -0,0 +1,21 @@ +Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y. +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing). +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. +Class IsEquiv {A B} (f : A -> B) := { equiv_inv : B -> A ; eisretr : Sect equiv_inv f }. +Arguments eisretr {A B} f {_} _. +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'"). +Generalizable Variables A B f g e n. +Definition functor_forall `{P : A -> Type} `{Q : B -> Type} + (f0 : B -> A) (f1 : forall b:B, P (f0 b) -> Q b) +: (forall a:A, P a) -> (forall b:B, Q b). + admit. +Defined. + +Lemma isequiv_functor_forall `{P : A -> Type} `{Q : B -> Type} + `{IsEquiv B A f} `{forall b, @IsEquiv (P (f b)) (Q b) (g b)} +: (forall b : B, Q b) -> forall a : A, P a. +Proof. + refine (functor_forall + (f^-1) + (fun (x:A) (y:Q (f^-1 x)) => eisretr f x # (g (f^-1 x))^-1 y)). +Defined. (* Error: Attempt to save an incomplete proof *) diff --git a/test-suite/bugs/closed/3854.v b/test-suite/bugs/closed/3854.v new file mode 100644 index 00000000..f8329cdd --- /dev/null +++ b/test-suite/bugs/closed/3854.v @@ -0,0 +1,21 @@ +Definition relation (A : Type) := A -> A -> Type. +Class Reflexive {A} (R : relation A) := reflexivity : forall x : A, R x x. +Axiom IsHProp : Type -> Type. +Existing Class IsHProp. +Inductive Empty : Set := . +Notation "~ x" := (x -> Empty) : type_scope. +Record hProp := BuildhProp { type :> Type ; trunc : IsHProp type }. +Arguments BuildhProp _ {_}. +Canonical Structure default_hProp := fun T P => (@BuildhProp T P). +Generalizable Variables A B f g e n. +Axiom trunc_forall : forall `{P : A -> Type}, IsHProp (forall a, P a). +Existing Instance trunc_forall. +Inductive V : Type := | set {A : Type} (f : A -> V) : V. +Axiom mem : V -> V -> hProp. +Axiom mem_induction +: forall (C : V -> hProp), (forall v, (forall x, mem x v -> C x) -> C v) -> forall v, C v. +Definition irreflexive_mem : forall x, (fun x y => ~ mem x y) x x. +Proof. + pose (fun x => BuildhProp (~ mem x x)). + refine (mem_induction (fun x => BuildhProp (~ mem x x)) _); simpl in *. + admit. diff --git a/test-suite/bugs/closed/3892.v b/test-suite/bugs/closed/3892.v new file mode 100644 index 00000000..833722ba --- /dev/null +++ b/test-suite/bugs/closed/3892.v @@ -0,0 +1,8 @@ +(* Check that notation variables do not capture names hidden behind + another notation. *) +Notation "A <-> B" := ((A -> B) * (B -> A))%type : type_scope. +Notation compose := (fun g f x => g (f x)). +Notation "g 'o' f" := (compose g f) (at level 40, left associativity). +Definition iff_compose {A B C : Type} (g : B <-> C) (f : A <-> B) : A <-> C := + (fst g o fst f , snd f o snd g). +(* Used to fail with: This expression should be a name. *) diff --git a/test-suite/bugs/closed/3895.v b/test-suite/bugs/closed/3895.v new file mode 100644 index 00000000..8659ca2c --- /dev/null +++ b/test-suite/bugs/closed/3895.v @@ -0,0 +1,22 @@ +Notation pr1 := (@projT1 _ _). +Notation compose := (fun g' f' x => g' (f' x)). +Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : +function_scope. +Open Scope function_scope. +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p +with eq_refl => eq_refl end. +Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) := forall x:A, +f x = g x. +Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : +type_scope. +Theorem Univalence_implies_FunextNondep (A B : Type) +: forall f g : A -> B, f == g -> f = g. +Proof. + intros f g p. + pose (d := fun x : A => existT (fun xy => fst xy = snd xy) (f x, f x) +(eq_refl (f x))). + pose (e := fun x : A => existT (fun xy => fst xy = snd xy) (f x, g x) (p x)). + change f with ((snd o pr1) o d). + change g with ((snd o pr1) o e). + apply (ap (fun g => snd o pr1 o g)). +(* Used to raise a not Found due to a "typo" in solve_evar_evar *) diff --git a/test-suite/bugs/closed/3896.v b/test-suite/bugs/closed/3896.v new file mode 100644 index 00000000..b433922a --- /dev/null +++ b/test-suite/bugs/closed/3896.v @@ -0,0 +1,4 @@ +Goal True. +pose proof 0 as n. +Fail apply pair in n. +(* Used to be an anomaly for a while *) diff --git a/test-suite/bugs/closed/3899.v b/test-suite/bugs/closed/3899.v new file mode 100644 index 00000000..e83166aa --- /dev/null +++ b/test-suite/bugs/closed/3899.v @@ -0,0 +1,11 @@ +Set Primitive Projections. +Record unit : Set := tt {}. +Fail Check fun x : unit => eq_refl : tt = x. +Fail Check fun x : unit => eq_refl : x = tt. +Fail Check fun x y : unit => (eq_refl : x = tt) : x = y. +Fail Check fun x y : unit => eq_refl : x = y. + +Record ok : Set := tt' { a : unit }. + +Record nonprim : Prop := { undef : unit }. +Record prim : Prop := { def : True }.
\ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/545.v b/test-suite/bugs/closed/545.v index 926af7dd..926af7dd 100644 --- a/test-suite/bugs/closed/shouldsucceed/545.v +++ b/test-suite/bugs/closed/545.v diff --git a/test-suite/bugs/closed/shouldsucceed/808_2411.v b/test-suite/bugs/closed/808_2411.v index 1c13e745..1c13e745 100644 --- a/test-suite/bugs/closed/shouldsucceed/808_2411.v +++ b/test-suite/bugs/closed/808_2411.v diff --git a/test-suite/bugs/closed/shouldsucceed/846.v b/test-suite/bugs/closed/846.v index ee5ec1fa..ee5ec1fa 100644 --- a/test-suite/bugs/closed/shouldsucceed/846.v +++ b/test-suite/bugs/closed/846.v diff --git a/test-suite/bugs/closed/shouldsucceed/931.v b/test-suite/bugs/closed/931.v index 21f15e72..e86b3be6 100644 --- a/test-suite/bugs/closed/shouldsucceed/931.v +++ b/test-suite/bugs/closed/931.v @@ -2,6 +2,6 @@ Parameter P : forall n : nat, n=n -> Prop. Goal Prop. refine (P _ _). - instantiate (1:=0). + 2:instantiate (1:=0). trivial. Qed. diff --git a/test-suite/bugs/closed/HoTT_coq_001.v b/test-suite/bugs/closed/HoTT_coq_001.v new file mode 100644 index 00000000..bf1d024b --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_001.v @@ -0,0 +1,5 @@ +Record Foo : Set := + { + A' : nat; + A : Prop := (A' = 0) + }. (* Anomaly: Uncaught exception Reduction.NotConvertible. Please report. *) diff --git a/test-suite/bugs/closed/HoTT_coq_002.v b/test-suite/bugs/closed/HoTT_coq_002.v new file mode 100644 index 00000000..ba69f6b1 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_002.v @@ -0,0 +1,33 @@ +Set Implicit Arguments. + +Generalizable All Variables. + +Parameter SpecializedCategory : Type -> Type. +Parameter Object : forall obj, SpecializedCategory obj -> Type. + +Section SpecializedFunctor. + (* Variable objC : Type. *) + Context `(C : SpecializedCategory objC). + + Polymorphic Record SpecializedFunctor := { + ObjectOf' : objC -> Type; + ObjectC : Object C + }. +End SpecializedFunctor. + +Section FunctorInterface. + Variable objC : Type. + Variable C : SpecializedCategory objC. + Variable F : SpecializedFunctor C. + + Set Printing All. + Set Printing Universes. + Check @ObjectOf' objC C F. (* Toplevel input, characters 24-25: +Error: +In environment +objC : Type (* Top.515 *) +C : SpecializedCategory objC +F : @SpecializedFunctor (* Top.516 *) objC C +The term "F" has type "@SpecializedFunctor (* Top.516 *) objC C" + while it is expected to have type + "@SpecializedFunctor (* Top.519 Top.520 *) objC C". *) diff --git a/test-suite/bugs/closed/HoTT_coq_006.v b/test-suite/bugs/closed/HoTT_coq_006.v new file mode 100644 index 00000000..c7943b84 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_006.v @@ -0,0 +1,99 @@ +Module FirstIssue. + Set Implicit Arguments. + + Record Cat (obj : Type) := {}. + + Record Functor objC (C : Cat objC) objD (D : Cat objD) := + { + ObjectOf' : objC -> objD + }. + + Definition TypeCat : Cat Type. constructor. Defined. + Definition PropCat : Cat Prop. constructor. Defined. + + Definition FunctorFrom_Type2Prop objC (C : Cat objC) (F : Functor TypeCat C) : Functor PropCat C. + Set Printing All. + Set Printing Universes. + Check F. (* F : @Functor Type (* Top.1201 *) TypeCat objC C *) + exact (Build_Functor PropCat C (ObjectOf' F)). + Show Proof. (* (fun (objC : Type (* Top.1194 *)) (C : Cat objC) + (F : @Functor Prop TypeCat objC C) => + @Build_Functor Prop PropCat objC C + (@ObjectOf' Prop TypeCat objC C F)) *) + Defined. + (* Error: Illegal application (Type Error): +The term "Functor" of type + "forall (objC : Type (* Top.1194 *)) (_ : Cat objC) + (objD : Type (* Top.1194 *)) (_ : Cat objD), + Type (* Top.1194 *)" +cannot be applied to the terms + "Prop" : "Type (* (Set)+1 *)" + "TypeCat" : "Cat Type (* Top.1201 *)" + "objC" : "Type (* Top.1194 *)" + "C" : "Cat objC" +The 2nd term has type "Cat Type (* Top.1201 *)" +which should be coercible to "Cat Prop". *) +End FirstIssue. + +Module SecondIssue. + Set Implicit Arguments. + + Set Printing Universes. + + Polymorphic Record Cat (obj : Type) := + { + Object :> _ := obj; + Morphism' : obj -> obj -> Type + }. + + Polymorphic Record Functor objC (C : Cat objC) objD (D : Cat objD) := + { + ObjectOf' : objC -> objD; + MorphismOf' : forall s d, C.(Morphism') s d -> D.(Morphism') (ObjectOf' s) (ObjectOf' d) + }. + + Definition SetCat : Cat Set := @Build_Cat Set (fun x y => x -> y). + Definition PropCat : Cat Prop := @Build_Cat Prop (fun x y => x -> y). + + Set Printing All. + + Definition FunctorFrom_Set2Prop objC (C : Cat objC) (F : Functor SetCat C) : Functor PropCat C. + exact (Build_Functor PropCat C + (ObjectOf' F) + (MorphismOf' F) + ). + Defined. (* Error: Illegal application (Type Error): +The term "Build_Functor (* Top.748 Prop Top.808 Top.809 *)" of type + "forall (objC : Type (* Top.748 *)) (C : Cat (* Top.748 Prop *) objC) + (objD : Type (* Top.808 *)) (D : Cat (* Top.808 Top.809 *) objD) + (ObjectOf' : forall _ : objC, objD) + (_ : forall (s d : objC) (_ : @Morphism' (* Top.748 Prop *) objC C s d), + @Morphism' (* Top.808 Top.809 *) objD D (ObjectOf' s) (ObjectOf' d)), + @Functor (* Top.748 Prop Top.808 Top.809 *) objC C objD D" +cannot be applied to the terms + "Prop" : "Type (* (Set)+1 *)" + "PropCat" : "Cat (* Top.748 Prop *) Prop" + "objC" : "Type (* Top.808 *)" + "C" : "Cat (* Top.808 Top.809 *) objC" + "fun x : Prop => + @ObjectOf' (* Top.744 Prop Top.808 Top.809 *) Set SetCat objC C F x" + : "forall _ : Prop, objC" + "@MorphismOf' (* Top.744 Prop Top.808 Top.809 *) Set SetCat objC C F" + : "forall (s d : Set) (_ : @Morphism' (* Top.744 Prop *) Set SetCat s d), + @Morphism' (* Top.808 Top.809 *) objC C + (@ObjectOf' (* Top.744 Prop Top.808 Top.809 *) Set SetCat objC C F s) + (@ObjectOf' (* Top.744 Prop Top.808 Top.809 *) Set SetCat objC C F d)" +The 6th term has type + "forall (s d : Set) (_ : @Morphism' (* Top.744 Prop *) Set SetCat s d), + @Morphism' (* Top.808 Top.809 *) objC C + (@ObjectOf' (* Top.744 Prop Top.808 Top.809 *) Set SetCat objC C F s) + (@ObjectOf' (* Top.744 Prop Top.808 Top.809 *) Set SetCat objC C F d)" +which should be coercible to + "forall (s d : Prop) (_ : @Morphism' (* Top.748 Prop *) Prop PropCat s d), + @Morphism' (* Top.808 Top.809 *) objC C + ((fun x : Prop => + @ObjectOf' (* Top.744 Prop Top.808 Top.809 *) Set SetCat objC C F x) s) + ((fun x : Prop => + @ObjectOf' (* Top.744 Prop Top.808 Top.809 *) Set SetCat objC C F x) d)". + *) +End SecondIssue. diff --git a/test-suite/bugs/closed/HoTT_coq_007.v b/test-suite/bugs/closed/HoTT_coq_007.v new file mode 100644 index 00000000..8592c729 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_007.v @@ -0,0 +1,112 @@ +Module Comment1. + Set Implicit Arguments. + + Polymorphic Record Category (obj : Type) := + { + Morphism : obj -> obj -> Type; + Identity : forall o, Morphism o o + }. + + Polymorphic Record Functor objC (C :Category objC) objD (D : Category objD) := + { + ObjectOf :> objC -> objD; + MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d); + FIdentityOf : forall o, MorphismOf _ _ (C.(Identity) o) = D.(Identity) (ObjectOf o) + }. + + Create HintDb functor discriminated. + + Hint Rewrite @FIdentityOf : functor. + + Polymorphic Definition ComposeFunctors objC C objD D objE E (G : @Functor objD D objE E) (F : @Functor objC C objD D) : Functor C E. + refine {| ObjectOf := (fun c => G (F c)); + MorphismOf := (fun _ _ m => G.(MorphismOf) _ _ (F.(MorphismOf) _ _ m)) + |}; + intros; autorewrite with functor; reflexivity. + Defined. + + Definition Cat0 : Category@{i j} Empty_set. + refine {| + Morphism := fun s d : Empty_set => s = d; + Identity := fun o : Empty_set => eq_refl + |}; + admit. + Defined. + + Set Printing All. + Set Printing Universes. + + Lemma foo objC (C : @Category objC) (C0 : Category (Functor Cat0 C)) (x : Functor Cat0 Cat0) + : forall (y : Functor C0 Cat0) z, (ComposeFunctors y z = x). + intro. intro. + unfold ComposeFunctors. + Abort. +End Comment1. + +Module Comment2. + Set Implicit Arguments. + + Polymorphic Record Category (obj : Type) := + { + Morphism : obj -> obj -> Type; + + Identity : forall o, Morphism o o; + Compose : forall s d d2, Morphism d d2 -> Morphism s d -> Morphism s d2; + + LeftIdentity : forall a b (f : Morphism a b), Compose (Identity b) f = f + }. + + Polymorphic Record Functor objC (C : Category objC) objD (D : Category objD) := + { + ObjectOf : objC -> objD; + MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d) + }. + + Create HintDb morphism discriminated. + + Polymorphic Hint Resolve @LeftIdentity : morphism. + + Polymorphic Definition ProductCategory objC (C : Category objC) objD (D : Category objD) : @Category (objC * objD)%type. + refine {| + Morphism := (fun s d => (C.(Morphism) (fst s) (fst d) * D.(Morphism) (snd s) (snd d))%type); + Identity := (fun o => (Identity _ (fst o), Identity _ (snd o))); + Compose := (fun (s d d2 : (objC * objD)%type) m2 m1 => (C.(Compose) _ _ _ (fst m2) (fst m1), D.(Compose) _ _ _ (snd m2) (snd m1))) + |}; + intros; apply injective_projections; simpl; auto with morphism. (* Replacing [auto with morphism] with [apply @LeftIdentity] removes the error *) + Defined. + + Polymorphic Definition Cat0 : Category Empty_set. + refine {| + Morphism := fun s d : Empty_set => s = d; + Identity := fun o : Empty_set => eq_refl; + Compose := fun s d d2 m0 m1 => eq_trans m1 m0 + |}; + admit. + Defined. + + Set Printing All. + Set Printing Universes. + Polymorphic Definition ProductLaw0Functor (objC : Type) (C : Category objC) : Functor (ProductCategory C Cat0) Cat0. + refine (Build_Functor (ProductCategory C Cat0) Cat0 _ _). (* Toplevel input, characters 15-71: +Error: Refiner was given an argument + "prod (* Top.2289 Top.2289 *) objC Empty_set" of type +"Type (* Top.2289 *)" instead of "Set". *) + Abort. + Polymorphic Definition ProductLaw0Functor (objC : Type) (C : Category objC) : Functor (ProductCategory C Cat0) Cat0. + econstructor. (* Toplevel input, characters 0-12: +Error: No applicable tactic. + *) + Abort. +End Comment2. + + +Module Comment3. + Polymorphic Lemma foo {obj : Type} : 1 = 1. + trivial. + Qed. + + Polymorphic Hint Resolve foo. (* success *) + Polymorphic Hint Rewrite @foo. (* Success *) + Polymorphic Hint Resolve @foo. (* Error: @foo is a term and cannot be made a polymorphic hint, only global references can be polymorphic hints. *) + Fail Polymorphic Hint Rewrite foo. (* Error: Cannot infer the implicit parameter obj of foo. *) +End Comment3. diff --git a/test-suite/bugs/closed/HoTT_coq_010.v b/test-suite/bugs/closed/HoTT_coq_010.v new file mode 100644 index 00000000..42b1244f --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_010.v @@ -0,0 +1,3 @@ +SearchAbout and. +(* Anomaly: Mismatched instance and context when building universe substitution. +Please report. *) diff --git a/test-suite/bugs/closed/HoTT_coq_012.v b/test-suite/bugs/closed/HoTT_coq_012.v new file mode 100644 index 00000000..a3c697f8 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_012.v @@ -0,0 +1,4 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) + +Definition UU := Type. +Inductive toto (B : UU) : UU := c (x : B). diff --git a/test-suite/bugs/closed/HoTT_coq_013.v b/test-suite/bugs/closed/HoTT_coq_013.v new file mode 100644 index 00000000..13962d5b --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_013.v @@ -0,0 +1,24 @@ +Set Implicit Arguments. +Generalizable All Variables. + +Polymorphic Variant Category (obj : Type) :=. + + Polymorphic Variant Functor objC (C : Category objC) objD (D : Category objD) :=. + + Polymorphic Definition ComposeFunctors objC C objD D objE E (G : @Functor objD D objE E) (F : @Functor objC C objD D) : Functor C E. +Admitted. + +Polymorphic Definition ProductCategory objC (C : Category objC) objD (D : Category objD) : @Category (objC * objD)%type. +Admitted. + +Polymorphic Definition Cat0 : Category Empty_set. +Admitted. + +Set Printing Universes. + +Lemma ProductLaw0 objC (C : Category objC) (F : Functor (ProductCategory C Cat0) Cat0) (G : Functor Cat0 (ProductCategory C Cat0)) x y : + ComposeFunctors F G = x /\ + ComposeFunctors G F = y. +Proof. + split. (* Error: Refiner was given an argument "(objC * 0)%type" of type "Type" instead of "Set". *) +Abort. diff --git a/test-suite/bugs/closed/HoTT_coq_014.v b/test-suite/bugs/closed/HoTT_coq_014.v new file mode 100644 index 00000000..63548a64 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_014.v @@ -0,0 +1,200 @@ +Set Implicit Arguments. +Generalizable All Variables. +Set Universe Polymorphism. + +Polymorphic Record SpecializedCategory (obj : Type) := Build_SpecializedCategory' { + Object :> _ := obj; + Morphism' : obj -> obj -> Type; + + Identity' : forall o, Morphism' o o; + Compose' : forall s d d', Morphism' d d' -> Morphism' s d -> Morphism' s d' +}. + +Polymorphic Definition Morphism obj (C : @SpecializedCategory obj) : forall s d : C, _ := Eval cbv beta delta [Morphism'] in C.(Morphism'). + +(* eh, I'm not terribly happy. meh. *) +Polymorphic Definition SmallSpecializedCategory (obj : Set) (*mor : obj -> obj -> Set*) := SpecializedCategory@{Set Set} obj. +Polymorphic Identity Coercion SmallSpecializedCategory_LocallySmallSpecializedCategory_Id : SmallSpecializedCategory >-> SpecializedCategory. + +Polymorphic Record Category := { + CObject : Type; + + UnderlyingCategory :> @SpecializedCategory CObject +}. + +Polymorphic Definition GeneralizeCategory `(C : @SpecializedCategory obj) : Category. + refine {| CObject := C.(Object) |}; auto. +Defined. + +Polymorphic Coercion GeneralizeCategory : SpecializedCategory >-> Category. + + + +Section SpecializedFunctor. + Set Universe Polymorphism. + Context `(C : @SpecializedCategory objC). + Context `(D : @SpecializedCategory objD). + Unset Universe Polymorphism. + + Polymorphic Record SpecializedFunctor := { + ObjectOf' : objC -> objD; + MorphismOf' : forall s d, C.(Morphism') s d -> D.(Morphism') (ObjectOf' s) (ObjectOf' d); + FCompositionOf' : forall s d d' (m1 : C.(Morphism') s d) (m2: C.(Morphism') d d'), + MorphismOf' _ _ (C.(Compose') _ _ _ m2 m1) = D.(Compose') _ _ _ (MorphismOf' _ _ m2) (MorphismOf' _ _ m1); + FIdentityOf' : forall o, MorphismOf' _ _ (C.(Identity') o) = D.(Identity') (ObjectOf' o) + }. +End SpecializedFunctor. + +Global Polymorphic Coercion ObjectOf' : SpecializedFunctor >-> Funclass. +Set Universe Polymorphism. +Section Functor. + Variable C D : Category. + + Polymorphic Definition Functor := SpecializedFunctor C D. +End Functor. +Unset Universe Polymorphism. + +Polymorphic Identity Coercion Functor_SpecializedFunctor_Id : Functor >-> SpecializedFunctor. +Polymorphic Definition GeneralizeFunctor objC C objD D (F : @SpecializedFunctor objC C objD D) : Functor C D := F. +Polymorphic Coercion GeneralizeFunctor : SpecializedFunctor >-> Functor. + +Arguments SpecializedFunctor {objC} C {objD} D. + + +Polymorphic Record SmallCategory := { + SObject : Set; + + SUnderlyingCategory :> @SmallSpecializedCategory SObject +}. + +Polymorphic Definition GeneralizeSmallCategory `(C : @SmallSpecializedCategory obj) : SmallCategory. + refine {| SObject := obj |}; destruct C; econstructor; eassumption. +Defined. + +Polymorphic Coercion GeneralizeSmallCategory : SmallSpecializedCategory >-> SmallCategory. + +Bind Scope category_scope with SmallCategory. + + +Polymorphic Definition TypeCat : @SpecializedCategory Type := (@Build_SpecializedCategory' Type + (fun s d => s -> d) + (fun _ => (fun x => x)) + (fun _ _ _ f g => (fun x => f (g x)))). +(*Unset Universe Polymorphism.*) +Polymorphic Definition FunctorCategory objC (C : @SpecializedCategory objC) objD (D : @SpecializedCategory objD) : + @SpecializedCategory (SpecializedFunctor C D). +Admitted. + +Polymorphic Definition DiscreteCategory (O : Type) : @SpecializedCategory O. +Admitted. + +Polymorphic Definition ComputableCategory (I : Type) (Index2Object : I -> Type) (Index2Cat : forall i : I, @SpecializedCategory (@Index2Object i)) : + @SpecializedCategory I. +Admitted. + +Polymorphic Definition is_unique (A : Type) (x : A) := forall x' : A, x' = x. + +Polymorphic Definition InitialObject obj {C : SpecializedCategory obj} (o : C) := + forall o', { m : C.(Morphism) o o' | is_unique m }. + +Polymorphic Definition SmallCat := ComputableCategory _ SUnderlyingCategory. + +Lemma InitialCategory_Initial : InitialObject (C := SmallCat) (DiscreteCategory Empty_set : SmallSpecializedCategory _). + admit. +Qed. + +Set Universe Polymorphism. +Section GraphObj. + Context `(C : @SpecializedCategory objC). + + Inductive GraphIndex := GraphIndexSource | GraphIndexTarget. + + Definition GraphIndex_Morphism (a b : GraphIndex) : Set := + match (a, b) with + | (GraphIndexSource, GraphIndexSource) => unit + | (GraphIndexTarget, GraphIndexTarget) => unit + | (GraphIndexTarget, GraphIndexSource) => Empty_set + | (GraphIndexSource, GraphIndexTarget) => GraphIndex + end. + + Global Arguments GraphIndex_Morphism a b /. + + Definition GraphIndex_Compose s d d' (m1 : GraphIndex_Morphism d d') (m2 : GraphIndex_Morphism s d) : + GraphIndex_Morphism s d'. + Admitted. + + Definition GraphIndexingCategory : @SpecializedCategory GraphIndex. + refine {| + Morphism' := GraphIndex_Morphism; + Identity' := (fun x => match x with GraphIndexSource => tt | GraphIndexTarget => tt end); + Compose' := GraphIndex_Compose + |}; + admit. + Defined. + + Definition UnderlyingGraph_ObjectOf x := + match x with + | GraphIndexSource => { sd : objC * objC & C.(Morphism) (fst sd) (snd sd) } + | GraphIndexTarget => objC + end. + + Global Arguments UnderlyingGraph_ObjectOf x /. + + Definition UnderlyingGraph_MorphismOf s d (m : Morphism GraphIndexingCategory s d) : + UnderlyingGraph_ObjectOf s -> UnderlyingGraph_ObjectOf d. + Admitted. + + Definition UnderlyingGraph : SpecializedFunctor GraphIndexingCategory TypeCat. + Proof. + match goal with + | [ |- SpecializedFunctor ?C ?D ] => + refine (Build_SpecializedFunctor C D + UnderlyingGraph_ObjectOf + UnderlyingGraph_MorphismOf + _ + _ + ) + end; + admit. + Defined. +End GraphObj. + +Set Printing Universes. +Set Printing All. + +Print Coercions. + +Section test. + +Fail Polymorphic Definition UnderlyingGraphFunctor_MorphismOf' (C D : SmallCategory) (F : SpecializedFunctor C D) : + Morphism (FunctorCategory TypeCat GraphIndexingCategory) + (@UnderlyingGraph (SObject C) + (SmallSpecializedCategory_LocallySmallSpecializedCategory_Id (SUnderlyingCategory C))) + (UnderlyingGraph D). + (* Toplevel input, characters 216-249: +Error: +In environment +C : SmallCategory (* Top.594 *) +D : SmallCategory (* Top.595 *) +F : +@SpecializedFunctor (* Top.25 Set Top.25 Set *) (SObject (* Top.25 *) C) + (SUnderlyingCategory (* Top.25 *) C) (SObject (* Top.25 *) D) + (SUnderlyingCategory (* Top.25 *) D) +The term + "SUnderlyingCategory (* Top.25 *) C + :SpecializedCategory (* Top.25 Set *) (SObject (* Top.25 *) C)" has type + "SpecializedCategory (* Top.618 Top.619 *) (SObject (* Top.25 *) C)" +while it is expected to have type + "SpecializedCategory (* Top.224 Top.225 *) (SObject (* Top.617 *) C)" +(Universe inconsistency: Cannot enforce Set = Top.225)). + *) +Fail Admitted. + +Fail Polymorphic Definition UnderlyingGraphFunctor_MorphismOf (C D : SmallCategory) (F : SpecializedFunctor C D) : + Morphism (FunctorCategory TypeCat GraphIndexingCategory) (UnderlyingGraph C) (UnderlyingGraph D). (* Anomaly: apply_coercion. Please report.*) +Fail Admitted. + +Polymorphic Definition UnderlyingGraphFunctor_MorphismOf (C D : SmallCategory) (F : SpecializedFunctor C D) : + Morphism (FunctorCategory GraphIndexingCategory TypeCat) (UnderlyingGraph C) (UnderlyingGraph D). (* Anomaly: apply_coercion. Please report.*) +Proof. +Admitted.
\ No newline at end of file diff --git a/test-suite/bugs/closed/HoTT_coq_016.v b/test-suite/bugs/closed/HoTT_coq_016.v new file mode 100644 index 00000000..4f12cf1a --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_016.v @@ -0,0 +1,15 @@ +Set Printing Universes. +Local Close Scope nat_scope. +Check (fun ab : Prop * Prop => (fst ab : Prop) * (snd ab : Prop)). +(* fun ab : Prop * Prop => +(fst (* Top.5817 Top.5818 *) ab:Prop) * (snd (* Top.5817 Top.5818 *) ab:Prop) + : Prop * Prop -> Prop *) +Check (fun ab : Prop * Prop => (fst ab : Prop) * (snd ab : Prop) : Prop). +(* Toplevel input, characters 51-84: +Error: In environment +ab : Prop * Prop +The term + "(fst (* Top.5833 Top.5834 *) ab:Prop) * + (snd (* Top.5833 Top.5834 *) ab:Prop)" has type + "Type (* max(Top.5829, Top.5830) *)" while it is expected to have type + "Prop". *) diff --git a/test-suite/bugs/closed/HoTT_coq_020.v b/test-suite/bugs/closed/HoTT_coq_020.v new file mode 100644 index 00000000..b16c1df2 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_020.v @@ -0,0 +1,95 @@ +Set Implicit Arguments. + +Generalizable All Variables. + +Set Asymmetric Patterns. + +Polymorphic Record Category (obj : Type) := + Build_Category { + Object :> _ := obj; + Morphism : obj -> obj -> Type; + + Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' + }. + +Polymorphic Record Functor objC (C : Category objC) objD (D : Category objD) := + { ObjectOf :> objC -> objD }. + +Polymorphic Record NaturalTransformation objC C objD D (F G : Functor (objC := objC) C (objD := objD) D) := + { ComponentsOf' :> forall c, D.(Morphism) (F.(ObjectOf) c) (G.(ObjectOf) c); + Commutes' : forall s d (m : C.(Morphism) s d), ComponentsOf' s = ComponentsOf' s }. + +Ltac present_obj from to := + match goal with + | [ _ : appcontext[from ?obj ?C] |- _ ] => progress change (from obj C) with (to obj C) in * + | [ |- appcontext[from ?obj ?C] ] => progress change (from obj C) with (to obj C) in * + end. + +Section NaturalTransformationComposition. + Set Universe Polymorphism. + Context `(C : @Category objC). + Context `(D : @Category objD). + Context `(E : @Category objE). + Variables F F' F'' : Functor C D. + Unset Universe Polymorphism. + + Polymorphic Definition NTComposeT (T' : NaturalTransformation F' F'') (T : NaturalTransformation F F') : + NaturalTransformation F F''. + exists (fun c => Compose _ _ _ _ (T' c) (T c)). + repeat progress present_obj @Morphism @Morphism. (* removing this line makes the error go away *) + intros. (* removing this line makes the error go away *) + admit. + Defined. +End NaturalTransformationComposition. + + +Polymorphic Definition FunctorCategory objC (C : Category objC) objD (D : Category objD) : + @Category (Functor C D) + := @Build_Category (Functor C D) + (NaturalTransformation (C := C) (D := D)) + (NTComposeT (C := C) (D := D)). + +Polymorphic Definition Cat0 : Category Empty_set + := @Build_Category Empty_set + (@eq _) + (fun x => match x return _ with end). + +Polymorphic Definition FunctorFrom0 objC (C : Category objC) : Functor Cat0 C + := Build_Functor Cat0 C (fun x => match x with end). + +Section Law0. + Variable objC : Type. + Variable C : Category objC. + + Set Printing All. + Set Printing Universes. + Set Printing Existential Instances. + + Polymorphic Definition ExponentialLaw0Functor_Inverse_ObjectOf' : Object (@FunctorCategory Empty_set Cat0 objC C). + (* In environment +objC : Type (* Top.154 *) +C : Category (* Top.155 Top.154 *) objC +The term "objC" has type "Type (* Top.154 *)" +while it is expected to have type "Type (* Top.184 *)" +(Universe inconsistency: Cannot enforce Top.154 <= Set)). *) + Admitted. + + Polymorphic Definition ExponentialLaw0Functor_Inverse_ObjectOf : Object (FunctorCategory Cat0 C). + hnf. + refine (@FunctorFrom0 _ _). + + (* Toplevel input, characters 23-40: +Error: +In environment +objC : Type (* Top.61069 *) +C : Category (* Top.61069 Top.61071 *) objC +The term + "@FunctorFrom0 (* Top.61077 Top.61078 *) ?69 (* [objC, C] *) + ?70 (* [objC, C] *)" has type + "@Functor (* Set Prop Top.61077 Top.61078 *) Empty_set Cat0 + ?69 (* [objC, C] *) ?70 (* [objC, C] *)" + while it is expected to have type + "@Functor (* Set Prop Set Prop *) Empty_set Cat0 objC C". +*) + Defined. +End Law0. diff --git a/test-suite/bugs/closed/HoTT_coq_023.v b/test-suite/bugs/closed/HoTT_coq_023.v new file mode 100644 index 00000000..b52140de --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_023.v @@ -0,0 +1,12 @@ +Set Universe Polymorphism. + +Record Type_Over (X : Type) +:= { Domain :> Type; + proj : Domain -> X }. + +Definition Self_Over (X : Type) + := {| Domain := X; proj := (fun x => x) |}. + +Canonical Structure Self_Over. (* fails with Anomaly: Mismatched instance and context when building universe substitution. Please report. for polymorphic structures *) +(* if monomorphic, Warning: No global reference exists for projection + valuefun x : _UNBOUND_REL_1 => x in instance Self_Over of proj, ignoring it. *) diff --git a/test-suite/bugs/closed/HoTT_coq_025.v b/test-suite/bugs/closed/HoTT_coq_025.v new file mode 100644 index 00000000..b81b454d --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_025.v @@ -0,0 +1,29 @@ +Module monomorphic. + Class Inhabited (A : Type) : Prop := populate { _ : A }. + Arguments populate {_} _. + + Instance prod_inhabited {A B : Type} (iA : Inhabited A) + (iB : Inhabited B) : Inhabited (A * B) := + match iA, iB with + | populate x, populate y => populate (x,y) + end. + (* Error: In environment +A : Type +B : Type +iA : Inhabited A +iB : Inhabited B +The term "(A * B)%type" has type "Type" while it is expected to have type +"Prop". *) +End monomorphic. + +Module polymorphic. + Set Universe Polymorphism. + Class Inhabited (A : Type) : Prop := populate { _ : A }. + Arguments populate {_} _. + + Instance prod_inhabited {A B : Type} (iA : Inhabited A) + (iB : Inhabited B) : Inhabited (A * B) := + match iA, iB with + | populate x, populate y => populate (x,y) + end. +End polymorphic. diff --git a/test-suite/bugs/closed/HoTT_coq_027.v b/test-suite/bugs/closed/HoTT_coq_027.v new file mode 100644 index 00000000..27834cc4 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_027.v @@ -0,0 +1,94 @@ +Set Implicit Arguments. +Generalizable All Variables. +Set Asymmetric Patterns. +Set Universe Polymorphism. + +Record Category (obj : Type) := { Morphism : obj -> obj -> Type }. + +Record Functor `(C : Category objC) `(D : Category objD) := + { ObjectOf :> objC -> objD; + MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d) }. + +Definition TypeCat : @Category Type := @Build_Category Type (fun s d => s -> d). +Definition SetCat : @Category Set := @Build_Category Set (fun s d => s -> d). + +Definition FunctorToSet `(C : @Category objC) := Functor C SetCat. +Definition FunctorToType `(C : @Category objC) := Functor C TypeCat. + +(* Removing the following line, as well as the [Definition] and [Identity Coercion] immediately following it, makes the file go through *) +Identity Coercion FunctorToType_Id : FunctorToType >-> Functor. + +Set Printing Universes. +Definition FunctorTo_Set2Type `(C : @Category objC) (F : FunctorToSet C) +: FunctorToType C. + refine (@Build_Functor _ C _ TypeCat + (fun x => F.(ObjectOf) x) + (fun s d m => F.(MorphismOf) _ _ m)). +(* ??? Toplevel input, characters 8-148: +Error: +In environment +objC : Type{Top.100} +C : Category@{Top.100 Top.101} objC +F : FunctorToSet@{Top.100 Top.101 Top.99} C +The term + "{| + ObjectOf := fun x : objC => F x; + MorphismOf := fun (s d : objC) (m : Morphism@{Top.100 Top.101} C s d) => + MorphismOf@{Top.100 Top.101 Top.99 Set} F s d m |}" has type + "Functor@{Top.104 Top.105 Top.106 Top.107} C TypeCat@{Top.108 Top.109 + Top.110}" while it is expected to have type + "FunctorToType@{Top.100 Top.101 Top.102 Top.103} C" +(Universe inconsistency: Cannot enforce Set = Top.103)). + *) +Defined. (* Toplevel input, characters 0-8: +Error: +The term + "fun (objC : Type) (C : Category objC) (F : FunctorToSet C) => + {| + ObjectOf := fun x : objC => F x; + MorphismOf := fun (s d : objC) (m : Morphism C s d) => MorphismOf F s d m |}" +has type + "forall (objC : Type) (C : Category objC), + FunctorToSet C -> Functor C TypeCat" while it is expected to have type + "forall (objC : Type) (C : Category objC), FunctorToSet C -> FunctorToType C". + *) + +Coercion FunctorTo_Set2Type : FunctorToSet >-> FunctorToType. + +Record GrothendieckPair `(C : @Category objC) (F : Functor C TypeCat) := + { GrothendieckC : objC; + GrothendieckX : F GrothendieckC }. + +Record SetGrothendieckPair `(C : @Category objC) (F' : Functor C SetCat) := + { SetGrothendieckC : objC; + SetGrothendieckX : F' SetGrothendieckC }. + +Section SetGrothendieckCoercion. + Context `(C : @Category objC). + Variable F : Functor C SetCat. + Let F' := (F : FunctorToSet _) : FunctorToType _. (* The command has indeed failed with message: +=> Anomaly: apply_coercion_args: mismatch between arguments and coercion. +Please report. *) + + Set Printing Universes. + Definition SetGrothendieck2Grothendieck (G : SetGrothendieckPair F) : GrothendieckPair F' + := {| GrothendieckC := G.(SetGrothendieckC); GrothendieckX := G.(SetGrothendieckX) : F' _ |}. + (* Toplevel input, characters 0-187: +Error: Illegal application: +The term "ObjectOf (* Top.8375 Top.8376 Top.8379 Set *)" of type + "forall (objC : Type (* Top.8375 *)) + (C : Category (* Top.8375 Top.8376 *) objC) (objD : Type (* Top.8379 *)) + (D : Category (* Top.8379 Set *) objD), + Functor (* Top.8375 Top.8376 Top.8379 Set *) C D -> objC -> objD" +cannot be applied to the terms + "objC" : "Type (* Top.8375 *)" + "C" : "Category (* Top.8375 Top.8376 *) objC" + "Type (* Set *)" : "Type (* Set+1 *)" + "TypeCat (* Top.8379 Set *)" : "Category (* Top.8379 Set *) Set" + "F'" : "FunctorToType (* Top.8375 Top.8376 Top.8379 Set *) C" + "SetGrothendieckC (* Top.8375 Top.8376 Top.8379 *) G" : "objC" +The 5th term has type "FunctorToType (* Top.8375 Top.8376 Top.8379 Set *) C" +which should be coercible to + "Functor (* Top.8375 Top.8376 Top.8379 Set *) C TypeCat (* Top.8379 Set *)". + *) +End SetGrothendieckCoercion. diff --git a/test-suite/bugs/closed/HoTT_coq_028.v b/test-suite/bugs/closed/HoTT_coq_028.v new file mode 100644 index 00000000..b0324140 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_028.v @@ -0,0 +1,14 @@ +Goal forall (O obj : Type) (f : O -> obj) (x : O) (e : x = x) + (T : obj -> obj -> Type) (m : forall x0 : obj, T x0 x0), + match eq_sym e in (_ = y) return (T (f y) (f x)) with + | eq_refl => m (f x) + end = m (f x). +intros. +try case e. +(* Toplevel input, characters 19-25: +Error: Cannot instantiate metavariable P of type +"forall a : O, x = a -> Prop" with abstraction +"fun (x : O) (e : x = x) => + match eq_sym e in (_ = y) return (T (f y) (f x)) with + | eq_refl => m (f x) + end = m (f x)" of incompatible type "forall x : O, x = x -> Prop". *) diff --git a/test-suite/bugs/closed/HoTT_coq_029.v b/test-suite/bugs/closed/HoTT_coq_029.v new file mode 100644 index 00000000..4fd54b56 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_029.v @@ -0,0 +1,335 @@ +Module FirstComment. + Set Implicit Arguments. + Generalizable All Variables. + Set Asymmetric Patterns. + Set Universe Polymorphism. + + Reserved Notation "x # y" (at level 40, left associativity). + Reserved Notation "x #m y" (at level 40, left associativity). + + Delimit Scope object_scope with object. + Delimit Scope morphism_scope with morphism. + Delimit Scope category_scope with category. + + Record Category (obj : Type) := + { + Object :> _ := obj; + Morphism : obj -> obj -> Type; + + Identity : forall x, Morphism x x; + Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' + }. + + Bind Scope object_scope with Object. + Bind Scope morphism_scope with Morphism. + + Arguments Object {obj%type} C%category / : rename. + Arguments Morphism {obj%type} !C%category s d : rename. (* , simpl nomatch. *) + Arguments Identity {obj%type} [!C%category] x%object : rename. + Arguments Compose {obj%type} [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename. + + Bind Scope category_scope with Category. + + Record Functor + `(C : @Category objC) + `(D : @Category objD) + := { + ObjectOf :> objC -> objD; + MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d) + }. + + Record NaturalTransformation + `(C : @Category objC) + `(D : @Category objD) + (F G : Functor C D) + := { + ComponentsOf :> forall c, D.(Morphism) (F c) (G c) + }. + + Definition ProductCategory + `(C : @Category objC) + `(D : @Category objD) + : @Category (objC * objD)%type. + refine (@Build_Category _ + (fun s d => (C.(Morphism) (fst s) (fst d) * D.(Morphism) (snd s) (snd d))%type) + (fun o => (Identity (fst o), Identity (snd o))) + (fun s d d' m2 m1 => (Compose (fst m2) (fst m1), Compose (snd m2) (snd m1)))). + + Defined. + + Infix "*" := ProductCategory : category_scope. + + Record IsomorphismOf `{C : @Category objC} {s d} (m : C.(Morphism) s d) := + { + IsomorphismOf_Morphism :> C.(Morphism) s d := m; + Inverse : C.(Morphism) d s + }. + + Record NaturalIsomorphism + `(C : @Category objC) + `(D : @Category objD) + (F G : Functor C D) + := { + NaturalIsomorphism_Transformation :> NaturalTransformation F G; + NaturalIsomorphism_Isomorphism : forall x : objC, IsomorphismOf (NaturalIsomorphism_Transformation x) + }. + + Section PreMonoidalCategory. + Context `(C : @Category objC). + + Variable TensorProduct : Functor (C * C) C. + + Let src {C : @Category objC} {s d} (_ : Morphism C s d) := s. + Let dst {C : @Category objC} {s d} (_ : Morphism C s d) := d. + + Local Notation "A # B" := (TensorProduct (A, B)). + Local Notation "A #m B" := (TensorProduct.(MorphismOf) ((@src _ _ _ A, @src _ _ _ B)) ((@dst _ _ _ A, @dst _ _ _ B)) (A, B)%morphism). + + Let TriMonoidalProductL_ObjectOf (abc : C * C * C) : C := + (fst (fst abc) # snd (fst abc)) # snd abc. + + Let TriMonoidalProductR_ObjectOf (abc : C * C * C) : C := + fst (fst abc) # (snd (fst abc) # snd abc). + + Let TriMonoidalProductL_MorphismOf (s d : C * C * C) (m : Morphism (C * C * C) s d) : + Morphism C (TriMonoidalProductL_ObjectOf s) (TriMonoidalProductL_ObjectOf d). + Admitted. + + Let TriMonoidalProductR_MorphismOf (s d : C * C * C) (m : Morphism (C * C * C) s d) : + Morphism C (TriMonoidalProductR_ObjectOf s) (TriMonoidalProductR_ObjectOf d). + Admitted. + + Definition TriMonoidalProductL : Functor (C * C * C) C. + refine (Build_Functor (C * C * C) C + TriMonoidalProductL_ObjectOf + TriMonoidalProductL_MorphismOf). + Defined. + + Definition TriMonoidalProductR : Functor (C * C * C) C. + refine (Build_Functor (C * C * C) C + TriMonoidalProductR_ObjectOf + TriMonoidalProductR_MorphismOf). + Defined. + + Variable Associator : NaturalIsomorphism TriMonoidalProductL TriMonoidalProductR. + + Section AssociatorCoherenceCondition. + Variables a b c d : C. + + (* going from top-left *) + Let AssociatorCoherenceConditionT0 : Morphism C (((a # b) # c) # d) ((a # (b # c)) # d) + := Associator (a, b, c) #m Identity (C := C) d. + Let AssociatorCoherenceConditionT1 : Morphism C ((a # (b # c)) # d) (a # ((b # c) # d)) + := Associator (a, b # c, d). + Let AssociatorCoherenceConditionT2 : Morphism C (a # ((b # c) # d)) (a # (b # (c # d))) + := Identity (C := C) a #m Associator (b, c, d). + Let AssociatorCoherenceConditionB0 : Morphism C (((a # b) # c) # d) ((a # b) # (c # d)) + := Associator (a # b, c, d). + Let AssociatorCoherenceConditionB1 : Morphism C ((a # b) # (c # d)) (a # (b # (c # d))) + := Associator (a, b, c # d). + + Definition AssociatorCoherenceCondition' := + Compose AssociatorCoherenceConditionT2 (Compose AssociatorCoherenceConditionT1 AssociatorCoherenceConditionT0) + = Compose AssociatorCoherenceConditionB1 AssociatorCoherenceConditionB0. + End AssociatorCoherenceCondition. + + Definition AssociatorCoherenceCondition := Eval unfold AssociatorCoherenceCondition' in + forall a b c d : C, AssociatorCoherenceCondition' a b c d. + End PreMonoidalCategory. + + Section MonoidalCategory. + Variable objC : Type. + + Let AssociatorCoherenceCondition' := Eval unfold AssociatorCoherenceCondition in @AssociatorCoherenceCondition. + + Record MonoidalCategory := + { + MonoidalUnderlyingCategory :> @Category objC; + TensorProduct : Functor (MonoidalUnderlyingCategory * MonoidalUnderlyingCategory) MonoidalUnderlyingCategory; + IdentityObject : objC; + Associator : NaturalIsomorphism (TriMonoidalProductL TensorProduct) (TriMonoidalProductR TensorProduct); + AssociatorCoherent : AssociatorCoherenceCondition' Associator + }. + End MonoidalCategory. + + Section EnrichedCategory. + Context `(M : @MonoidalCategory objM). + Let x : M := IdentityObject M. + (* Anomaly: apply_coercion_args: mismatch between arguments and coercion. Please report. *) + End EnrichedCategory. +End FirstComment. + +Module SecondComment. + Set Implicit Arguments. + Set Universe Polymorphism. + Generalizable All Variables. + + Record prod (A B : Type) := pair { fst : A; snd : B }. + Arguments fst {A B} _. + Arguments snd {A B} _. + Infix "*" := prod : type_scope. + Notation " ( x , y ) " := (@pair _ _ x y). + Record Category (obj : Type) := + Build_Category { + Object :> _ := obj; + Morphism : obj -> obj -> Type; + + Identity : forall x, Morphism x x; + Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' + }. + + Arguments Identity {obj%type} [!C] x : rename. + Arguments Compose {obj%type} [!C s d d'] m1 m2 : rename. + + Record > Category' := + { + LSObject : Type; + + LSUnderlyingCategory :> @Category LSObject + }. + + Section Functor. + Context `(C : @Category objC). + Context `(D : @Category objD). + + + Record Functor := + { + ObjectOf :> objC -> objD; + MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d) + }. + End Functor. + + Arguments MorphismOf {objC%type} [C] {objD%type} [D] F [s d] m : rename, simpl nomatch. + + Section FunctorComposition. + Context `(C : @Category objC). + Context `(D : @Category objD). + Context `(E : @Category objE). + + Definition ComposeFunctors (G : Functor D E) (F : Functor C D) : Functor C E. + Admitted. + End FunctorComposition. + + Section IdentityFunctor. + Context `(C : @Category objC). + + + Definition IdentityFunctor : Functor C C. + refine {| ObjectOf := (fun x => x); + MorphismOf := (fun _ _ x => x) + |}. + Defined. + End IdentityFunctor. + + Section ProductCategory. + Context `(C : @Category objC). + Context `(D : @Category objD). + + Definition ProductCategory : @Category (objC * objD)%type. + refine (@Build_Category _ + (fun s d => (C.(Morphism) (fst s) (fst d) * D.(Morphism) (snd s) (snd d))%type) + (fun o => (Identity (fst o), Identity (snd o))) + (fun s d d' m2 m1 => (Compose (fst m2) (fst m1), Compose (snd m2) (snd m1)))). + Defined. + End ProductCategory. + + Definition OppositeCategory `(C : @Category objC) : Category objC := + @Build_Category objC + (fun s d => Morphism C d s) + (Identity (C := C)) + (fun _ _ _ m1 m2 => Compose m2 m1). + + Parameter FunctorCategory : forall `(C : @Category objC) `(D : @Category objD), @Category (Functor C D). + + Parameter TerminalCategory : Category unit. + + Section ComputableCategory. + Variable I : Type. + Variable Index2Object : I -> Type. + Variable Index2Cat : forall i : I, @Category (@Index2Object i). + + Local Coercion Index2Cat : I >-> Category. + + Definition ComputableCategory : @Category I. + refine (@Build_Category _ + (fun C D : I => Functor C D) + (fun o : I => IdentityFunctor o) + (fun C D E : I => ComposeFunctors (C := C) (D := D) (E := E))). + Defined. + End ComputableCategory. + + Section SmallCat. + Definition LocallySmallCat := ComputableCategory _ LSUnderlyingCategory. + End SmallCat. + + Section CommaCategory. + Context `(A : @Category objA). + Context `(B : @Category objB). + Context `(C : @Category objC). + Variable S : Functor A C. + Variable T : Functor B C. + + Record CommaCategory_Object := { CommaCategory_Object_Member :> { ab : objA * objB & C.(Morphism) (S (fst ab)) (T (snd ab)) } }. + + Let SortPolymorphic_Helper (A T : Type) (Build_T : A -> T) := A. + + Definition CommaCategory_ObjectT := Eval hnf in SortPolymorphic_Helper Build_CommaCategory_Object. + Definition Build_CommaCategory_Object' (mem : CommaCategory_ObjectT) := Build_CommaCategory_Object mem. + Global Coercion Build_CommaCategory_Object' : CommaCategory_ObjectT >-> CommaCategory_Object. + + Definition CommaCategory : @Category CommaCategory_Object. + Admitted. + End CommaCategory. + + Definition SliceCategory_Functor `(C : @Category objC) (a : C) : Functor TerminalCategory C + := {| ObjectOf := (fun _ => a); + MorphismOf := (fun _ _ _ => Identity a) + |}. + + Definition SliceCategoryOver + : forall (objC : Type) (C : Category objC) (a : C), + Category + (CommaCategory_Object (IdentityFunctor C) + (SliceCategory_Functor C a)). + admit. + Defined. + + Section CommaCategoryProjectionFunctor. + Context `(A : Category objA). + Context `(B : Category objB). + Context `(C : Category objC). + + Variable S : (OppositeCategory (FunctorCategory A C)). + Variable T : (FunctorCategory B C). + + Definition CommaCategoryProjection : Functor (CommaCategory S T) (ProductCategory A B). + Admitted. + + Definition CommaCategoryProjectionFunctor_ObjectOf + : @SliceCategoryOver _ LocallySmallCat (ProductCategory A B) + := + existT _ + ((CommaCategory S T) : Category', tt) + (CommaCategoryProjection) : + CommaCategory_ObjectT (IdentityFunctor _) + (SliceCategory_Functor LocallySmallCat + (ProductCategory A B)). + (* Anomaly: apply_coercion_args: mismatch between arguments and coercion. Please report. *) + (* Toplevel input, characters 110-142: +Error: +In environment +objA : Type +A : Category objA +objB : Type +B : Category objB +objC : Type +C : Category objC +S : OppositeCategory (FunctorCategory A C) +T : FunctorCategory B C +The term "ProductCategory A B:Category (objA * objB)" has type + "Category (objA * objB)" while it is expected to have type + "Object LocallySmallCat". + *) + End CommaCategoryProjectionFunctor. +End SecondComment. diff --git a/test-suite/bugs/closed/HoTT_coq_030.v b/test-suite/bugs/closed/HoTT_coq_030.v new file mode 100644 index 00000000..fa5ee25c --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_030.v @@ -0,0 +1,241 @@ +Set Implicit Arguments. +Generalizable All Variables. +Set Asymmetric Patterns. +Set Universe Polymorphism. + +Delimit Scope object_scope with object. +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope functor_scope with functor. + +Local Open Scope category_scope. + +Record SpecializedCategory (obj : Type) := + { + Object :> _ := obj; + Morphism : obj -> obj -> Type; + + Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' + }. + +Bind Scope category_scope with SpecializedCategory. +Bind Scope object_scope with Object. +Bind Scope morphism_scope with Morphism. + +Arguments Object {obj%type} C%category / : rename. +Arguments Morphism {obj%type} !C%category s d : rename. (* , simpl nomatch. *) +Arguments Compose {obj%type} [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename. + +Record Category := { + CObject : Type; + + UnderlyingCategory :> @SpecializedCategory CObject +}. + +Definition GeneralizeCategory `(C : @SpecializedCategory obj) : Category. + refine {| CObject := C.(Object) |}; auto. (* Changing this [auto] to [assumption] removes the universe inconsistency. *) +Defined. + +Coercion GeneralizeCategory : SpecializedCategory >-> Category. + +Record SpecializedFunctor + `(C : @SpecializedCategory objC) + `(D : @SpecializedCategory objD) + := { + ObjectOf :> objC -> objD; + MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d) + }. + +Section Functor. + Context (C D : Category). + + Definition Functor := SpecializedFunctor C D. +End Functor. + +Bind Scope functor_scope with SpecializedFunctor. +Bind Scope functor_scope with Functor. + +Arguments SpecializedFunctor {objC} C {objD} D. +Arguments Functor C D. +Arguments ObjectOf {objC%type C%category objD%type D%category} F%functor c%object : rename, simpl nomatch. +Arguments MorphismOf {objC%type} [C%category] {objD%type} [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch. + +Section FunctorComposition. + Context `(B : @SpecializedCategory objB). + Context `(C : @SpecializedCategory objC). + Context `(D : @SpecializedCategory objD). + Context `(E : @SpecializedCategory objE). + + Definition ComposeFunctors (G : SpecializedFunctor D E) (F : SpecializedFunctor C D) : SpecializedFunctor C E + := Build_SpecializedFunctor C E + (fun c => G (F c)) + (fun _ _ m => G.(MorphismOf) (F.(MorphismOf) m)). +End FunctorComposition. + +Record SpecializedNaturalTransformation + `{C : @SpecializedCategory objC} + `{D : @SpecializedCategory objD} + (F G : SpecializedFunctor C D) + := { + ComponentsOf :> forall c, D.(Morphism) (F c) (G c) + }. + +Definition ProductCategory + `(C : @SpecializedCategory objC) + `(D : @SpecializedCategory objD) +: @SpecializedCategory (objC * objD)%type + := @Build_SpecializedCategory _ + (fun s d => (C.(Morphism) (fst s) (fst d) * D.(Morphism) (snd s) (snd d))%type) + (fun s d d' m2 m1 => (Compose (fst m2) (fst m1), Compose (snd m2) (snd m1))). + +Infix "*" := ProductCategory : category_scope. + +Section ProductCategoryFunctors. + Context `{C : @SpecializedCategory objC}. + Context `{D : @SpecializedCategory objD}. + + Definition fst_Functor : SpecializedFunctor (C * D) C + := Build_SpecializedFunctor (C * D) C + (@fst _ _) + (fun _ _ => @fst _ _). + + Definition snd_Functor : SpecializedFunctor (C * D) D + := Build_SpecializedFunctor (C * D) D + (@snd _ _) + (fun _ _ => @snd _ _). +End ProductCategoryFunctors. + + +Definition OppositeCategory `(C : @SpecializedCategory objC) : @SpecializedCategory objC := + @Build_SpecializedCategory objC + (fun s d => Morphism C d s) + (fun _ _ _ m1 m2 => Compose m2 m1). + +Section OppositeFunctor. + Context `(C : @SpecializedCategory objC). + Context `(D : @SpecializedCategory objD). + Variable F : SpecializedFunctor C D. + Let COp := OppositeCategory C. + Let DOp := OppositeCategory D. + + Definition OppositeFunctor : SpecializedFunctor COp DOp + := Build_SpecializedFunctor COp DOp + (fun c : COp => F c : DOp) + (fun (s d : COp) (m : C.(Morphism) d s) => MorphismOf F (s := d) (d := s) m). +End OppositeFunctor. + +Section FunctorProduct. + Context `(C : @SpecializedCategory objC). + Context `(D : @SpecializedCategory objD). + Context `(D' : @SpecializedCategory objD'). + + Definition FunctorProduct (F : Functor C D) (F' : Functor C D') : SpecializedFunctor C (D * D'). + match goal with + | [ |- SpecializedFunctor ?C0 ?D0 ] => + refine (Build_SpecializedFunctor + C0 D0 + (fun c => (F c, F' c)) + (fun s d m => (MorphismOf F m, MorphismOf F' m))) + end. + Defined. +End FunctorProduct. + +Section FunctorProduct'. + Context `(C : @SpecializedCategory objC). + Context `(D : @SpecializedCategory objD). + Context `(C' : @SpecializedCategory objC'). + Context `(D' : @SpecializedCategory objD'). + Variable F : Functor C D. + Variable F' : Functor C' D'. + + Definition FunctorProduct' : SpecializedFunctor (C * C') (D * D') + := FunctorProduct (ComposeFunctors F fst_Functor) (ComposeFunctors F' snd_Functor). +End FunctorProduct'. + +(** XXX TODO(jgross): Change this to [FunctorProduct]. *) +Infix "*" := FunctorProduct' : functor_scope. + +Definition TypeCat : @SpecializedCategory Type := + (@Build_SpecializedCategory Type + (fun s d => s -> d) + (fun _ _ _ f g => (fun x => f (g x)))). + +Section HomFunctor. + Context `(C : @SpecializedCategory objC). + Let COp := OppositeCategory C. + + Definition CovariantHomFunctor (A : COp) : SpecializedFunctor C TypeCat + := Build_SpecializedFunctor C TypeCat + (fun X : C => C.(Morphism) A X : TypeCat) + (fun X Y f => (fun g : C.(Morphism) A X => Compose f g)). + + Definition hom_functor_object_of (c'c : COp * C) := C.(Morphism) (fst c'c) (snd c'c) : TypeCat. + + Definition hom_functor_morphism_of (s's : (COp * C)%type) (d'd : (COp * C)%type) (hf : (COp * C).(Morphism) s's d'd) : + TypeCat.(Morphism) (hom_functor_object_of s's) (hom_functor_object_of d'd). + unfold hom_functor_object_of in *. + destruct s's as [ s' s ], d'd as [ d' d ]. + destruct hf as [ h f ]. + intro g. + exact (Compose f (Compose g h)). + Defined. + + Definition HomFunctor : SpecializedFunctor (COp * C) TypeCat + := Build_SpecializedFunctor (COp * C) TypeCat + (fun c'c : COp * C => C.(Morphism) (fst c'c) (snd c'c) : TypeCat) + (fun X Y (hf : (COp * C).(Morphism) X Y) => hom_functor_morphism_of hf). +End HomFunctor. + +Section FullFaithful. + Context `(C : @SpecializedCategory objC). + Context `(D : @SpecializedCategory objD). + Variable F : SpecializedFunctor C D. + Let COp := OppositeCategory C. + Let DOp := OppositeCategory D. + Let FOp := OppositeFunctor F. + + Definition InducedHomNaturalTransformation : + SpecializedNaturalTransformation (HomFunctor C) (ComposeFunctors (HomFunctor D) (FOp * F)) + := (Build_SpecializedNaturalTransformation (HomFunctor C) (ComposeFunctors (HomFunctor D) (FOp * F)) + (fun sd : (COp * C) => + MorphismOf F (s := _) (d := _))). +End FullFaithful. + +Definition FunctorCategory + `(C : @SpecializedCategory objC) + `(D : @SpecializedCategory objD) +: @SpecializedCategory (SpecializedFunctor C D). + refine (@Build_SpecializedCategory _ + (SpecializedNaturalTransformation (C := C) (D := D)) + _); + admit. +Defined. + +Notation "C ^ D" := (FunctorCategory D C) : category_scope. + +Section Yoneda. + Context `(C : @SpecializedCategory objC). + Let COp := OppositeCategory C. + + Section Yoneda. + Let Yoneda_NT s d (f : COp.(Morphism) s d) : SpecializedNaturalTransformation (CovariantHomFunctor C s) (CovariantHomFunctor C d) + := Build_SpecializedNaturalTransformation + (CovariantHomFunctor C s) + (CovariantHomFunctor C d) + (fun c : C => (fun m : C.(Morphism) _ _ => Compose m f)). + + Definition Yoneda : SpecializedFunctor COp (TypeCat ^ C) + := Build_SpecializedFunctor COp (TypeCat ^ C) + (fun c : COp => CovariantHomFunctor C c : TypeCat ^ C) + (fun s d (f : Morphism COp s d) => Yoneda_NT s d f). + End Yoneda. +End Yoneda. + +Section FullyFaithful. + Context `(C : @SpecializedCategory objC). + + Set Printing Universes. + Check InducedHomNaturalTransformation (Yoneda C). + (* Error: Universe inconsistency (cannot enforce Top.865 = Top.851 because +Top.851 < Top.869 <= Top.864 <= Top.865). *) +End FullyFaithful. diff --git a/test-suite/bugs/closed/HoTT_coq_032.v b/test-suite/bugs/closed/HoTT_coq_032.v new file mode 100644 index 00000000..3f5d7b02 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_032.v @@ -0,0 +1,22 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-xml") -*- *) +Set Implicit Arguments. +Generalizable All Variables. +Set Asymmetric Patterns. +Set Universe Polymorphism. + +Delimit Scope object_scope with object. +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope functor_scope with functor. + +Local Open Scope category_scope. + +Record SpecializedCategory (obj : Type) := + { + Object :> _ := obj; + Morphism : obj -> obj -> Type; + + Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' + }. +(* Anomaly: Mismatched instance and context when building universe substitution. +Please report. *) diff --git a/test-suite/bugs/closed/HoTT_coq_034.v b/test-suite/bugs/closed/HoTT_coq_034.v new file mode 100644 index 00000000..8d5201f6 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_034.v @@ -0,0 +1,23 @@ +Module Short. + Set Universe Polymorphism. + Inductive relevant (A : Type) (B : Type) : Prop := . + Section foo. + Variables A B : Type. + Definition foo := prod (relevant A B) A. + End foo. + + Section bar. + Variable A : Type. + Variable B : Type. + Definition bar := prod (relevant A B) A. + End bar. + + Set Printing Universes. + Check bar nat Set : Set. (* success *) + Check foo nat Set : Set. (* Toplevel input, characters 6-17: +Error: +The term "foo (* Top.303 Top.304 *) nat Set" has type +"Type (* Top.304 *)" while it is expected to have type +"Set" (Universe inconsistency: Cannot enforce Top.304 = Set because Set +< Top.304)). *) +End Short. diff --git a/test-suite/bugs/closed/HoTT_coq_035.v b/test-suite/bugs/closed/HoTT_coq_035.v new file mode 100644 index 00000000..4ad2fc02 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_035.v @@ -0,0 +1,19 @@ +Fail Check Prop : Prop. (* Prop:Prop + : Prop *) +Fail Check Set : Prop. (* Set:Prop + : Prop *) +Fail Check ((bool -> Prop) : Prop). (* bool -> Prop:Prop + : Prop *) +Axiom proof_irrelevance : forall (P : Prop) (p1 p2 : P), p1 = p2. +Check ((True : Prop) : Set). (* (True:Prop):Set + : Set *) +Goal (forall (v : Type) (f1 f0 : v -> Prop), + @eq (v -> Prop) f0 f1). +intros. +Fail apply proof_irrelevance. +admit. +Defined. (* Unnamed_thm is defined *) +Set Printing Universes. +Check ((True : Prop) : Set). (* Toplevel input, characters 0-28: +Error: Universe inconsistency (cannot enforce Prop <= Set because Set +< Prop). *) diff --git a/test-suite/bugs/closed/HoTT_coq_036.v b/test-suite/bugs/closed/HoTT_coq_036.v new file mode 100644 index 00000000..4c3e078a --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_036.v @@ -0,0 +1,135 @@ +Module Version1. + Set Implicit Arguments. + Set Universe Polymorphism. + Generalizable All Variables. + + Record SpecializedCategory (obj : Type) := + { + Object :> _ := obj + }. + + Record > Category := + { + CObject : Type; + UnderlyingCategory :> @SpecializedCategory CObject + }. + + Record SpecializedFunctor `(C : @SpecializedCategory objC) `(D : @SpecializedCategory objD) := + { + ObjectOf :> objC -> objD + }. + + Definition Functor (C D : Category) := SpecializedFunctor C D. + + Parameter TerminalCategory : SpecializedCategory unit. + + Definition focus A (_ : A) := True. + + Definition CommaCategory_Object (A : Category) (S : Functor TerminalCategory A) : Type. + assert (Hf : focus ((S tt) = (S tt))) by constructor. + let C1 := constr:(CObject) in + let C2 := constr:(fun C => @Object (CObject C) C) in + unify C1 C2; idtac C1 C2. Show Universes. + progress change @CObject with (fun C => @Object (CObject C) C) in *. + simpl in *. + match type of Hf with + | focus ?V => exact V + end. + Defined. + + Definition Build_SliceCategory (A : Category) (F : Functor TerminalCategory A) := @Build_SpecializedCategory (CommaCategory_Object F). + Parameter SetCat : @SpecializedCategory Set. + + Set Printing Universes. + Check (fun (A : Category) (F : Functor TerminalCategory A) => @Build_SpecializedCategory (CommaCategory_Object F)) SetCat. + (* (fun (A : Category (* Top.68 *)) + (F : Functor (* Set Top.68 *) TerminalCategory A) => + {| |}) SetCat (* Top.68 *) + : forall + F : Functor (* Set Top.68 *) TerminalCategory SetCat (* Top.68 *), + let Object := CommaCategory_Object (* Top.68 Top.69 Top.68 *) F in + SpecializedCategory (* Top.69 *) + (CommaCategory_Object (* Top.68 Top.69 Top.68 *) F) *) + Check @Build_SliceCategory SetCat. (* Toplevel input, characters 0-34: +Error: Universe inconsistency (cannot enforce Top.51 <= Set because Set +< Top.51). *) +End Version1. + +Module Version2. + Set Implicit Arguments. + Set Universe Polymorphism. + + Record SpecializedCategory (obj : Type) := + { + Object : _ := obj + }. + + Record > Category := + { + CObject : Type; + UnderlyingCategory :> @SpecializedCategory CObject + }. + + Parameter TerminalCategory : SpecializedCategory unit. + + Definition focus A (_ : A) := True. + Parameter ObjectOf' : forall (objC : Type) (C : SpecializedCategory objC) + (objD : Type) (D : SpecializedCategory objD), Prop. + Definition CommaCategory_Object (A : Category) : Type. + assert (Hf : focus (@ObjectOf' _ (@Build_Category unit TerminalCategory) _ A)) by constructor. + progress change CObject with (fun C => @Object (CObject C) C) in *; + simpl in *. + match type of Hf with + | focus ?V => exact V + end. + Defined. + + Definition Build_SliceCategory := @CommaCategory_Object. + Parameter SetCat : @SpecializedCategory Set. + + Set Printing Universes. + Check @Build_SliceCategory SetCat. +End Version2. + +Module OtherBug. + Set Implicit Arguments. + Set Universe Polymorphism. + + Record SpecializedCategory (obj : Type) := + { + Object : _ := obj + }. + + Record > Category := + { + CObject : Type; + UnderlyingCategory :> @SpecializedCategory CObject + }. + + Parameter TerminalCategory : SpecializedCategory unit. + + Definition focus A (_ : A) := True. + + Parameter ObjectOf' : forall (objC : Type) (C : SpecializedCategory objC) + (objD : Type) (D : SpecializedCategory objD), Prop. + Definition CommaCategory_Object (A : Category@{i}) : Type. + assert (Hf : focus (@ObjectOf' _ (@Build_Category unit TerminalCategory) _ A)) by constructor. + progress change CObject with (fun C => @Object (CObject C) C) in *; + simpl in *. + match type of Hf with + | focus ?V => exact V + end. + Defined. + + Parameter SetCat : @SpecializedCategory Set. + + Set Printing Universes. + Definition Build_SliceCategory := @CommaCategory_Object. + Check @CommaCategory_Object SetCat. + (* CommaCategory_Object (* Top.43 Top.44 Top.43 *) SetCat (* Top.43 *) + : Type (* Top.44 *) *) + Check @Build_SliceCategory SetCat. + (* Toplevel input, characters 0-34: +Error: Universe inconsistency (cannot enforce Top.36 <= Set because Set +< Top.36). *) +End OtherBug. diff --git a/test-suite/bugs/closed/HoTT_coq_037.v b/test-suite/bugs/closed/HoTT_coq_037.v new file mode 100644 index 00000000..66476414 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_037.v @@ -0,0 +1,16 @@ +Set Printing Universes. + +Fixpoint CardinalityRepresentative (n : nat) : Set := + match n with + | O => Empty_set + | S n' => sum (CardinalityRepresentative n') unit + end. +(* Toplevel input, characters 104-143: +Error: +In environment +CardinalityRepresentative : nat -> Set +n : nat +n' : nat +The term "(CardinalityRepresentative n' + unit)%type" has type + "Type (* max(Top.73, Top.74) *)" while it is expected to have type +"Set". *) diff --git a/test-suite/bugs/closed/HoTT_coq_041.v b/test-suite/bugs/closed/HoTT_coq_041.v new file mode 100644 index 00000000..79933bb8 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_041.v @@ -0,0 +1,18 @@ +Set Printing All. +Definition foo (s d : Prop) + : ((s : Set) -> (d : Set)) = ((s : Prop) -> (d : Prop)) + := eq_refl. (* succeeds *) +Definition bar (s d : Prop) + : ((fun x : Set => x) s -> (fun x : Set => x) d) = ((fun x : Prop => x) s -> (fun x : Prop => x) d) + := eq_refl. (* Toplevel input, characters 131-138: +Error: +In environment +s : Prop +d : Prop +The term + "@eq_refl Set (forall _ : (fun x : Set => x) s, (fun x : Set => x) d)" +has type "@eq Set (forall _ : s, d) (forall _ : s, d)" +while it is expected to have type + "@eq Set (forall _ : s, d) (forall _ : s, d)" +(cannot unify "forall _ : (fun x : Set => x) s, (fun x : Set => x) d" and +"forall _ : (fun x : Prop => x) s, (fun x : Prop => x) d"). *) diff --git a/test-suite/bugs/closed/HoTT_coq_042.v b/test-suite/bugs/closed/HoTT_coq_042.v new file mode 100644 index 00000000..6b206a2f --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_042.v @@ -0,0 +1,27 @@ +Set Implicit Arguments. +Set Universe Polymorphism. +Generalizable All Variables. + +Record Category (obj : Type) := { Morphism : obj -> obj -> Type }. + +Definition SetCat : @Category Set := @Build_Category Set (fun s d => s -> d). + +Record Foo := { foo : forall A (f : Morphism SetCat A A), True }. + +Local Notation PartialBuild_Foo pf := (@Build_Foo (fun A f => pf A f)). + +Set Printing Universes. +Let SetCatFoo' : Foo. + let pf := fresh in + let pfT := fresh in + evar (pfT : Prop); + cut pfT; + [ subst pfT; intro pf; + let t := constr:(PartialBuild_Foo pf) in + let t' := (eval simpl in t) in + exact t' + | ]. + admit. +(* Toplevel input, characters 15-20: +Error: Universe inconsistency (cannot enforce Set <= Prop). + *) diff --git a/test-suite/bugs/closed/HoTT_coq_043.v b/test-suite/bugs/closed/HoTT_coq_043.v new file mode 100644 index 00000000..5257a032 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_043.v @@ -0,0 +1,15 @@ +Require Import Classes.RelationClasses List Setoid. + +Definition RowType := list Type. + +Inductive RowTypeDecidable (P : forall T, relation T) `(forall T, Equivalence (P T)) +: RowType -> Type := +| RTDecNil : RowTypeDecidable P _ nil +| RTDecCons : forall T Ts, (forall t0 t1 : T, + {P T t0 t1} + {~P T t0 t1}) + -> RowTypeDecidable P _ Ts + -> RowTypeDecidable P _ (T :: Ts). +(* Toplevel input, characters 15-378: +Error: +Last occurrence of "RowTypeDecidable" must have "H" as 2nd argument in + "RowTypeDecidable P (fun T : Type => H T) nil". *) diff --git a/test-suite/bugs/closed/HoTT_coq_044.v b/test-suite/bugs/closed/HoTT_coq_044.v new file mode 100644 index 00000000..c824f53b --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_044.v @@ -0,0 +1,35 @@ +Require Import Classes.RelationClasses List Setoid. + +Definition eqT (T : Type) := @eq T. + +Set Universe Polymorphism. + +Definition RowType := list Type. + + +Inductive Row : RowType -> Type := +| RNil : Row nil +| RCons : forall T Ts, T -> Row Ts -> Row (T :: Ts). + +Inductive RowTypeDecidable (P : forall T, relation T) `(H : forall T, Equivalence (P T)) +: RowType -> Type := +| RTDecNil : RowTypeDecidable P H nil +| RTDecCons : forall T Ts, (forall t0 t1 : T, + {P T t0 t1} + {~P T t0 t1}) + -> RowTypeDecidable P H Ts + -> RowTypeDecidable P H (T :: Ts). + + +Set Printing Universes. + +Fixpoint Row_eq (Ts : RowType) +: RowTypeDecidable (@eqT) _ Ts -> forall r1 r2 : Row Ts, {@eq (Row Ts) r1 r2} + {r1 <> r2}. +(* Toplevel input, characters 81-87: +Error: +In environment +Ts : RowType (* Top.53 Coq.Init.Logic.8 *) +r1 : Row (* Top.54 Top.55 *) Ts +r2 : Row (* Top.56 Top.57 *) Ts +The term "Row (* Coq.Init.Logic.8 Top.59 *) Ts" has type + "Type (* max(Top.58+1, Top.59) *)" while it is expected to have type + "Type (* Coq.Init.Logic.8 *)" (Universe inconsistency). *) diff --git a/test-suite/bugs/closed/HoTT_coq_045.v b/test-suite/bugs/closed/HoTT_coq_045.v new file mode 100644 index 00000000..00588ffb --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_045.v @@ -0,0 +1,53 @@ +Set Implicit Arguments. +Set Universe Polymorphism. +Generalizable All Variables. + +Record SpecializedCategory (obj : Type) := + { + Object :> _ := obj + }. + +Record > Category := + { + CObject : Type; + UnderlyingCategory :> @SpecializedCategory CObject + }. + +Record SpecializedFunctor `(C : @SpecializedCategory objC) `(D : @SpecializedCategory objD) := + { + ObjectOf :> objC -> objD + }. + +Definition Functor (C D : Category) := SpecializedFunctor C D. + +Parameter TerminalCategory : SpecializedCategory unit. + +Definition focus A (_ : A) := True. + +Definition CommaCategory_Object (A : Category) (S : Functor TerminalCategory A) : Type. + assert (Hf : focus ((S tt) = (S tt))) by constructor. + let C1 := constr:(CObject) in + let C2 := constr:(fun C => @Object (CObject C) C) in + unify C1 C2. + progress change CObject with (fun C => @Object (CObject C) C) in *. + simpl in *. + let V := match type of Hf with + | focus ?V => constr:(V) + end + in exact V. +(* Toplevel input, characters 89-96: +Error: Illegal application: +The term "ObjectOf" of type + "forall (objC : Set) (C : SpecializedCategory objC) + (objD : Type) (D : SpecializedCategory objD), + SpecializedFunctor C D -> objC -> objD" +cannot be applied to the terms + "Object TerminalCategory" : "Type" + "TerminalCategory" : "SpecializedCategory unit" + "Object A" : "Type" + "UnderlyingCategory A" : "SpecializedCategory (CObject A)" + "S" : "Functor TerminalCategory A" + "tt" : "unit" +The 1st term has type "Type" which should be coercible to +"Set". *) +Defined. diff --git a/test-suite/bugs/closed/HoTT_coq_047.v b/test-suite/bugs/closed/HoTT_coq_047.v new file mode 100644 index 00000000..29496be5 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_047.v @@ -0,0 +1,46 @@ +Inductive nCk : nat -> nat -> Type := + |zz : nCk 0 0 + | incl { m n : nat } : nCk m n -> nCk (S m) (S n) + | excl { m n : nat } : nCk m n -> nCk (S m) n. + +Definition nCkComp { l m n : nat } : + nCk l m -> nCk m n -> nCk l n. +Proof. + intro. + revert n. + induction H. + auto. +(* ( incl w ) o zz -> contradiction *) + intros. + remember (S n) as sn. + destruct H0. + discriminate Heqsn. + apply incl. + apply IHnCk. + injection Heqsn. + intro. + rewrite <- H1. + auto. + apply excl. + apply IHnCk. + injection Heqsn. + intro. rewrite <- H1. + auto. + intros. + apply excl. + apply IHnCk. + auto. +Defined. + +Lemma nCkEq { k l m n : nat } ( cs : nCk k l ) (ct : nCk l m) (cr : nCk m n ): + nCkComp cs (nCkComp ct cr) = nCkComp (nCkComp cs ct) cr. +Proof. + revert m n ct cr. + induction cs. + intros. simpl. auto. + intros. + destruct n. + destruct m0. + destruct n0. + destruct cr. +(* Anomaly: Evar ?nnn was not declared. Please report. *) diff --git a/test-suite/bugs/closed/HoTT_coq_048.v b/test-suite/bugs/closed/HoTT_coq_048.v new file mode 100644 index 00000000..831bb3fc --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_048.v @@ -0,0 +1,7 @@ +(** This is not the issue of https://github.com/HoTT/coq/issues/48, but was mentioned there. *) +Record Foo := + { + foo := 1; + bar : foo = foo + }. +(* Anomaly: lookup_projection: constant is not a projection. Please report. *) diff --git a/test-suite/bugs/closed/HoTT_coq_049.v b/test-suite/bugs/closed/HoTT_coq_049.v new file mode 100644 index 00000000..906ec329 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_049.v @@ -0,0 +1,6 @@ +Require Import FunctionalExtensionality. + +Goal forall y, @f_equal = y. +intro. +apply functional_extensionality_dep. +(* Error: Ill-typed evar instance in HoTT/coq, Anomaly: Uncaught exception Reductionops.NotASort(_). Please report. before that. *) diff --git a/test-suite/bugs/closed/HoTT_coq_050.v b/test-suite/bugs/closed/HoTT_coq_050.v new file mode 100644 index 00000000..ce9b6b29 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_050.v @@ -0,0 +1,33 @@ +Set Implicit Arguments. +Generalizable All Variables. +Set Asymmetric Patterns. +Set Universe Polymorphism. +Set Printing Universes. + +Set Printing All. + +Record PreCategory := + { + Object :> Type; + Morphism : Object -> Object -> Type + }. + +Inductive paths A (x : A) : A -> Type := idpath : @paths A x x. +Inductive Unit : Prop := tt. (* Changing this to [Set] fixes things *) +Inductive Bool : Set := true | false. + +Definition DiscreteCategory X : PreCategory + := @Build_PreCategory X + (@paths X). + +Definition IndiscreteCategory X : PreCategory + := @Build_PreCategory X + (fun _ _ => Unit). + +Check (IndiscreteCategory Unit). +Check (DiscreteCategory Bool). +Definition NatCategory (n : nat) := + match n with + | 0 => IndiscreteCategory Unit + | _ => DiscreteCategory Bool + end. (* Error: Universe inconsistency (cannot enforce Set <= Prop). *) diff --git a/test-suite/bugs/closed/HoTT_coq_052.v b/test-suite/bugs/closed/HoTT_coq_052.v new file mode 100644 index 00000000..62bb9fa1 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_052.v @@ -0,0 +1,22 @@ +Goal Type = Type. + Fail match goal with |- ?x = ?x => idtac end. +Abort. + +Goal Prop. + Fail match goal with |- Type => idtac end. +Abort. + +Goal Prop = Set. + (* This should fail *) + Fail match goal with |- ?x = ?x => idtac x end. +Abort. + +Goal Type = Prop. + (* This should fail *) + Fail match goal with |- ?x = ?x => idtac end. +Abort. + +Goal Type = Set. + (* This should fail *) + Fail match goal with |- ?x = ?x => idtac end. +Abort. diff --git a/test-suite/bugs/closed/HoTT_coq_053.v b/test-suite/bugs/closed/HoTT_coq_053.v new file mode 100644 index 00000000..a14fb6aa --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_053.v @@ -0,0 +1,50 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) +Set Printing Universes. +Set Implicit Arguments. +Generalizable All Variables. +Set Asymmetric Patterns. +Set Universe Polymorphism. + +Inductive Unit : Type := + tt : Unit. + +Inductive Bool : Type := + | true : Bool + | false : Bool. + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Record PreCategory := + { + Object :> Type; + Morphism : Object -> Object -> Type + }. + +Definition DiscreteCategory X : PreCategory + := @Build_PreCategory X + (@paths X). + +Definition IndiscreteCategory X : PreCategory + := @Build_PreCategory X + (fun _ _ => Unit). + +Definition NatCategory (n : nat) := + match n with + | 0 => IndiscreteCategory Unit + | _ => DiscreteCategory Bool + end. +(* Error: Universe inconsistency (cannot enforce Set <= Prop).*) + +Definition NatCategory' (n : nat) := + match n with + | 0 => (fun X => @Build_PreCategory X + (fun _ _ => Unit : Prop)) Unit + | _ => DiscreteCategory Bool + end. + +Definition NatCategory'' (n : nat) := + match n with + | 0 => IndiscreteCategory Unit + | _ => DiscreteCategory Bool + end. diff --git a/test-suite/bugs/closed/HoTT_coq_054.v b/test-suite/bugs/closed/HoTT_coq_054.v new file mode 100644 index 00000000..c6879659 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_054.v @@ -0,0 +1,94 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs") -*- *) +Inductive Empty : Prop := . + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. + +Arguments idpath {A a} , [A] a. + +Definition idmap {A : Type} : A -> A := fun x => x. + +Definition path_sum {A B : Type} (z z' : A + B) + (pq : match z, z' with + | inl z0, inl z'0 => z0 = z'0 + | inr z0, inr z'0 => z0 = z'0 + | _, _ => Empty + end) +: z = z'. + destruct z, z', pq; exact idpath. +Defined. + +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. + +Theorem ex2_8 {A B A' B' : Type} (g : A -> A') (h : B -> B') (x y : A + B) + (* Fortunately, this unifies properly *) + (pq : match (x, y) with (inl x', inl y') => x' = y' | (inr x', inr y') => x' = y' | _ => Empty end) : + let f z := match z with inl z' => inl (g z') | inr z' => inr (h z') end in + ap f (path_sum x y pq) = path_sum (f x) (f y) + (* Coq appears to require *ALL* of the annotations *) + ((match x as x return match (x, y) with + (inl x', inl y') => x' = y' + | (inr x', inr y') => x' = y' + | _ => Empty + end -> match (f x, f y) with + | (inl x', inl y') => x' = y' + | (inr x', inr y') => x' = y' + | _ => Empty end with + | inl x' => match y as y return match y with + inl y' => x' = y' + | _ => Empty + end -> match f y with + | inl y' => g x' = y' + | _ => Empty end with + | inl y' => ap g + | inr y' => idmap + end + | inr x' => match y as y return match y return Prop with + inr y' => x' = y' + | _ => Empty + end -> match f y return Prop with + | inr y' => h x' = y' + | _ => Empty end with + | inl y' => idmap + | inr y' => ap h + end + end) pq). + destruct x; destruct y; destruct pq; reflexivity. +Qed. +(* Toplevel input, characters 1367-1374: +Error: +In environment +A : Type +B : Type +A' : Type +B' : Type +g : A -> A' +h : B -> B' +x : A + B +y : A + B +pq : +match x with +| inl x' => match y with + | inl y' => x' = y' + | inr _ => Empty + end +| inr x' => match y with + | inl _ => Empty + | inr y' => x' = y' + end +end +f := +fun z : A + B => +match z with +| inl z' => inl (g z') +| inr z' => inr (h z') +end : A + B -> A' + B' +x' : B +y0 : A + B +y' : B +The term "x' = y'" has type "Type" while it is expected to have type +"Prop" (Universe inconsistency). *) diff --git a/test-suite/bugs/closed/HoTT_coq_055.v b/test-suite/bugs/closed/HoTT_coq_055.v new file mode 100644 index 00000000..92d70ad1 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_055.v @@ -0,0 +1,53 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) +Set Universe Polymorphism. + +Inductive Empty : Prop := . + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. +Arguments idpath {A a} , [A] a. + +Definition idmap {A : Type} : A -> A := fun x => x. + +Definition path_sum {A B : Type} (z z' : A + B) + (pq : match z, z' with + | inl z0, inl z'0 => z0 = z'0 + | inr z0, inr z'0 => z0 = z'0 + | _, _ => Empty + end) +: z = z'. + + admit. +Defined. +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. + +Theorem ex2_8 {A B A' B' : Type} (g : A -> A') (h : B -> B') (x y : A + B) + + (pq : match (x, y) with (inl x', inl y') => x' = y' | (inr x', inr y') => x' = y' | _ => Empty end) : + let f z := match z with inl z' => inl (g z') | inr z' => inr (h z') end in + ap f (path_sum x y pq) = path_sum (f x) (f y) + ((match x as x return match (x, y) with + (inl x', inl y') => x' = y' + | (inr x', inr y') => x' = y' + | _ => Empty + end -> match (f x, f y) with + | (inl x', inl y') => x' = y' + | (inr x', inr y') => x' = y' + | _ => Empty end with + | inl x' => match y with + | inl y' => ap g + | inr y' => idmap + end + | inr x' => match y with + | inl y' => idmap + | inr y' => ap h + end + end) pq). + +Admitted. +(* Toplevel input, characters 20-29: +Error: Matching on term "f y" of type "A' + B'" expects 2 branches. *) diff --git a/test-suite/bugs/closed/HoTT_coq_056.v b/test-suite/bugs/closed/HoTT_coq_056.v new file mode 100644 index 00000000..6e65320d --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_056.v @@ -0,0 +1,156 @@ +(* File reduced by coq-bug-finder from 10455 lines to 8350 lines, then from 7790 lines to 710 lines, then from 7790 lines to 710 lines, then from 566 lines to 340 lines, then from 191 lines to 171 lines, then from 191 lines to 171 lines. *) + +Set Implicit Arguments. +Set Universe Polymorphism. +Definition admit {T} : T. +Admitted. +Reserved Notation "x ≅ y" (at level 70, no associativity). +Reserved Notation "i ^op" (at level 3). +Reserved Infix "∘" (at level 40, left associativity). +Reserved Notation "F ⟨ x ⟩" (at level 10, no associativity, x at level 10). +Reserved Notation "F ⟨ x , y ⟩" (at level 10, no associativity, x at level 10, y at level 10). +Reserved Notation "F ⟨ ─ ⟩" (at level 10, no associativity). +Reserved Notation "F ⟨ x , ─ ⟩" (at level 10, no associativity, x at level 10). +Reserved Notation "F ⟨ ─ , y ⟩" (at level 10, no associativity, y at level 10). +Delimit Scope object_scope with object. +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope functor_scope with functor. +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. +Delimit Scope path_scope with path. +Local Open Scope path_scope. + +Record PreCategory := + Build_PreCategory' { + Object :> Type; + Morphism : Object -> Object -> Type + }. + +Bind Scope category_scope with PreCategory. + +Definition Build_PreCategory + Object Morphism + := @Build_PreCategory' Object + Morphism. + +Record Functor (C D : PreCategory) := + { + ObjectOf :> C -> D; + MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d) + }. +Arguments MorphismOf [C%category] [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch. +Class Isomorphic {C : PreCategory} (s d : C) := {}. +Definition ComposeFunctors C D E (G : Functor D E) (F : Functor C D) : Functor C E + := Build_Functor C E + (fun c => G (F c)) + (fun _ _ m => G.(MorphismOf) (F.(MorphismOf) m)). + +Infix "∘" := ComposeFunctors : functor_scope. + +Definition IdentityFunctor C : Functor C C + := Build_Functor C C + (fun x => x) + (fun _ _ x => x). + +Notation "─" := (IdentityFunctor _) : functor_scope. +Record NaturalTransformation C D (F G : Functor C D) := + Build_NaturalTransformation' { }. + +Definition OppositeCategory (C : PreCategory) : PreCategory + := @Build_PreCategory' C + (fun s d => Morphism C d s). + +Notation "C ^op" := (OppositeCategory C) : category_scope. + +Definition ProductCategory (C D : PreCategory) : PreCategory + := @Build_PreCategory (C * D)%type + (fun s d => (C.(Morphism) (fst s) (fst d) * D.(Morphism) (snd s) (snd d))%type). + +Infix "*" := ProductCategory : category_scope. + +Definition OppositeFunctor C D (F : Functor C D) : Functor (C ^op) (D ^op) + := Build_Functor (C ^op) (D ^op) + (ObjectOf F) + (fun s d => MorphismOf F (s := d) (d := s)). +Notation "F ^op" := (OppositeFunctor F) : functor_scope. + +Definition FunctorProduct' C D C' D' (F : Functor C D) (F' : Functor C' D') : Functor (C * C') (D * D') + := admit. + +Global Class FunctorApplicationInterpretable + {C D} (F : Functor C D) + {argsT : Type} (args : argsT) + {T : Type} (rtn : T) + := {}. +Definition FunctorApplicationOf {C D} F {argsT} args {T} {rtn} + `{@FunctorApplicationInterpretable C D F argsT args T rtn} + := rtn. + +Global Arguments FunctorApplicationOf / {C} {D} F {argsT} args {T} {rtn} {_}. + +Global Instance FunctorApplicationDash C D (F : Functor C D) +: FunctorApplicationInterpretable F (IdentityFunctor C) F | 0. +Global Instance FunctorApplicationFunctorFunctor' A B C C' D (F : Functor (A * B) D) (G : Functor C A) (H : Functor C' B) +: FunctorApplicationInterpretable F (G, H) (F ∘ (FunctorProduct' G H))%functor | 100. + +Notation "F ⟨ x ⟩" := (FunctorApplicationOf F%functor x%functor) : functor_scope. + +Notation "F ⟨ x , y ⟩" := (FunctorApplicationOf F%functor (x%functor , y%functor)) : functor_scope. + +Notation "F ⟨ ─ ⟩" := (F ⟨ ( ─ ) ⟩)%functor : functor_scope. + +Notation "F ⟨ x , ─ ⟩" := (F ⟨ x , ( ─ ) ⟩)%functor : functor_scope. + +Notation "F ⟨ ─ , y ⟩" := (F ⟨ ( ─ ) , y ⟩)%functor : functor_scope. + +Definition FunctorCategory (C D : PreCategory) : PreCategory + := @Build_PreCategory (Functor C D) + (NaturalTransformation (C := C) (D := D)). + +Notation "[ C , D ]" := (FunctorCategory C D) : category_scope. + +Definition SetCat : PreCategory := @Build_PreCategory Type (fun x y => x -> y). + +Definition HomFunctor C : Functor (C^op * C) SetCat. +admit. +Defined. +Definition NaturalIsomorphism (C D : PreCategory) F G := @Isomorphic [C, D] F G. +Infix "≅" := NaturalIsomorphism : natural_transformation_scope. + +Local Open Scope functor_scope. +Local Open Scope natural_transformation_scope. + +Section Adjunction. + Variable C : PreCategory. + Variable D : PreCategory. + + Variable F : Functor C D. + Variable G : Functor D C. + Let Adjunction_Type := Eval simpl in HomFunctor D ⟨ F^op ⟨ ─ ⟩ , ─ ⟩ ≅ HomFunctor C ⟨ ─ , G ⟨ ─ ⟩ ⟩. + Record Adjunction := { AMateOf : Adjunction_Type }. +End Adjunction. + +Section AdjunctionEquivalences. + Variable C : PreCategory. + Variable D : PreCategory. + + Variable F : Functor C D. + Variable G : Functor D C. + Variable A : Adjunction F G. + Set Printing All. + Definition foo := @AMateOf C D F G A. +(* File "./HoTT_coq_56.v", line 145, characters 37-38: +Error: +In environment +C : PreCategory +D : PreCategory +F : Functor C D +G : Functor D C +A : @Adjunction C D F G +The term "A" has type "@Adjunction C D F G" while it is expected to have type + "@Adjunction C D F G". *) +End AdjunctionEquivalences. diff --git a/test-suite/bugs/closed/HoTT_coq_057.v b/test-suite/bugs/closed/HoTT_coq_057.v new file mode 100644 index 00000000..e72ce0c5 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_057.v @@ -0,0 +1,33 @@ +Require Export Coq.Lists.List. + +Polymorphic Fixpoint LIn (A : Type) (a:A) (l:list A) : Type := + match l with + | nil => False + | b :: m => (b = a) + LIn A a m + end. + +Polymorphic Inductive NTerm : Type := +| cterm : NTerm +| oterm : list NTerm -> NTerm. + +Polymorphic Fixpoint dummy {A B} (x : list (A * B)) : list (A * B) := + match x with + | nil => nil + | (_, _) :: _ => nil + end. + +Lemma foo : + forall v t sub vars, + LIn (nat * NTerm) (v, t) (dummy sub) + -> + ( + LIn (nat * NTerm) (v, t) sub + * + notT (LIn nat v vars) + ). +Proof. + induction sub; simpl; intros. + destruct H. + Set Printing Universes. + try (apply IHsub in X). (* Toplevel input, characters 5-21: +Error: Universe inconsistency (cannot enforce Top.47 = Set). *) diff --git a/test-suite/bugs/closed/HoTT_coq_058.v b/test-suite/bugs/closed/HoTT_coq_058.v new file mode 100644 index 00000000..9ce7dba9 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_058.v @@ -0,0 +1,140 @@ +(* File reduced by coq-bug-finder from 10044 lines to 493 lines, then from 425 lines to 160 lines. *) +Set Universe Polymorphism. +Notation idmap := (fun x => x). +Notation "( x ; y )" := (existT _ x y) : fibration_scope. +Open Scope fibration_scope. +Notation "x .1" := (projT1 x) (at level 3) : fibration_scope. +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. +Delimit Scope path_scope with path. +Local Open Scope path_scope. + +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. + +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. + +Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g) +: forall x, f x = g x + := fun x => match h with idpath => idpath end. + +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { equiv_inv : B -> A }. + +Delimit Scope equiv_scope with equiv. +Local Open Scope equiv_scope. + +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope. + +Class Funext := { isequiv_apD10 :> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) }. + +Definition path_forall `{Funext} {A : Type} {P : A -> Type} (f g : forall x : A, P x) : + (forall x, f x = g x) -> f = g + := (@apD10 A P f g)^-1. + +Inductive Unit : Set := + tt : Unit. + +Definition path_prod_uncurried {A B : Type} (z z' : A * B) + (pq : (fst z = fst z') * (snd z = snd z')) +: (z = z') + := match pq with (p,q) => + match z, z' return + (fst z = fst z') -> (snd z = snd z') -> (z = z') with + | (a,b), (a',b') => fun p q => + match p, q with + idpath, idpath => idpath + end + end p q + end. + +Definition path_prod {A B : Type} (z z' : A * B) : + (fst z = fst z') -> (snd z = snd z') -> (z = z') + := fun p q => path_prod_uncurried z z' (p,q). + +Definition path_prod' {A B : Type} {x x' : A} {y y' : B} +: (x = x') -> (y = y') -> ((x,y) = (x',y')) + := fun p q => path_prod (x,y) (x',y') p q. + +Lemma path_forall_recr_beta `{Funext} A B x0 P f g e Px +: @transport (forall a : A, B a) + (fun f => P f (f x0)) + f + g + (@path_forall _ _ _ _ _ e) + Px + = @transport ((forall a, B a) * B x0)%type + (fun x => P (fst x) (snd x)) + (f, f x0) + (g, g x0) + (path_prod' (@path_forall _ _ _ _ _ e) (e x0)) + Px. + + admit. +Defined. +Definition transport_path_prod'_beta' A B P (x x' : A) (y y' : B) (HA : x = x') (HB : y = y') (Px : P x y) +: @transport (A * B) (fun xy => P (fst xy) (snd xy)) (x, y) (x', y') (@path_prod' A B x x' y y' HA HB) Px + = @transport A (fun x => P x y') x x' HA + (@transport B (fun y => P x y) y y' HB Px). + admit. +Defined. +Goal forall (T : Type) (T0 : T -> T -> Type) + (Pmor : forall s d : T, T0 s d -> Type) (x x0 : T) + (x1 : T0 x x0) (p : Pmor x x0 x1) (H : Funext), + transport + (fun x2 : {_ : T & Unit} -> {_ : T & Unit} => + { x1 : _ & Pmor (x2 (x; tt)) .1 (x2 (x0; tt)) .1 x1}) + (path_forall (fun c : {_ : T & Unit} => (c .1; tt)) idmap + (fun x2 : {_ : T & Unit} => + let (x3, y) as s return ((s .1; tt) = s) := x2 in + match y as y0 return ((x3; tt) = (x3; y0)) with + | tt => idpath + end)) (x1; p) = (x1; p). +intros. +let F := match goal with |- appcontext[@transport _ (fun x0 => @?F x0) _ _ (@path_forall ?H ?X ?T ?f ?g ?e)] => constr:(F) end in +let H := match goal with |- appcontext[@transport _ (fun x0 => @?F x0) _ _ (@path_forall ?H ?X ?T ?f ?g ?e)] => constr:(H) end in +let X := match goal with |- appcontext[@transport _ (fun x0 => @?F x0) _ _ (@path_forall ?H ?X ?T ?f ?g ?e)] => constr:(X) end in +let T := match goal with |- appcontext[@transport _ (fun x0 => @?F x0) _ _ (@path_forall ?H ?X ?T ?f ?g ?e)] => constr:(T) end in +let t0 := fresh "t0" in +let t1 := fresh "t1" in +let T1 := lazymatch type of F with (?T -> _) -> _ => constr:(T) end in + evar (t1 : T1); + let T0 := lazymatch type of F with (forall a : ?A, @?B a) -> ?C => constr:((forall a : A, B a) -> B t1 -> C) end in + evar (t0 : T0); + + let dummy := fresh in + assert (dummy : forall x0, F x0 = t0 x0 (x0 t1)); + [ let x0 := fresh in + intro x0; + simpl in *; + let GL0 := lazymatch goal with |- ?GL0 = _ => constr:(GL0) end in + let GL0' := fresh in + let GL1' := fresh in + set (GL0' := GL0); + + let arg := match GL0 with appcontext[x0 ?arg] => constr:(arg) end in + assert (t1 = arg) by (subst t1; reflexivity); subst t1; + pattern (x0 arg) in GL0'; + match goal with + | [ GL0'' := ?GR _ |- _ ] => constr_eq GL0' GL0''; + pose GR as GL1' + end; + + pattern x0 in GL1'; + match goal with + | [ GL1'' := ?GR _ |- _ ] => constr_eq GL1' GL1''; + assert (t0 = GR) + end; + subst t0; [ reflexivity | reflexivity ] + | clear dummy ]; + let p := fresh in + pose (@path_forall_recr_beta H X T t1 t0) as p; + simpl in *; + rewrite p; + subst t0 t1 p. + rewrite transport_path_prod'_beta'. + (* Anomaly: Uncaught exception Invalid_argument("to_constraints: non-trivial algebraic constraint between universes", _). +Please report. *) diff --git a/test-suite/bugs/closed/HoTT_coq_059.v b/test-suite/bugs/closed/HoTT_coq_059.v new file mode 100644 index 00000000..9c7e394d --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_059.v @@ -0,0 +1,17 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) +Set Universe Polymorphism. + +Inductive eq {A} (x : A) : A -> Type := eq_refl : eq x x. +Notation "a = b" := (eq a b) : type_scope. + +Section foo. + Class Funext := { path_forall :> forall A P (f g : forall x : A, P x), (forall x, f x = g x) -> f = g }. + Context `{Funext, Funext}. + + Set Printing Universes. + + (** Typeclass resolution should pick up the different instances of Funext automatically *) + Definition foo := (@path_forall _ _ _ (@path_forall _ Set)). + (* Toplevel input, characters 0-60: +Error: Universe inconsistency (cannot enforce Top.24 <= Top.23 because Top.23 +< Top.22 <= Top.24). *) diff --git a/test-suite/bugs/closed/HoTT_coq_061.v b/test-suite/bugs/closed/HoTT_coq_061.v new file mode 100644 index 00000000..26c1f963 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_061.v @@ -0,0 +1,132 @@ +(* There are some problems in materialize_evar with local definitions, + as CO below; this is not completely sorted out yet, but at least + it fails in a smooth way at the time of today [HH] *) + +(* File reduced by coq-bug-finder from 9039 lines to 7786 lines, then + from 7245 lines to 476 lines, then from 417 lines to 249 lines, + then from 171 lines to 127 lines. *) + +Set Implicit Arguments. +Set Universe Polymorphism. +Definition admit {T} : T. +Admitted. +Delimit Scope object_scope with object. +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope functor_scope with functor. +Delimit Scope natural_transformation_scope with natural_transformation. +Reserved Infix "o" (at level 40, left associativity). +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Arguments idpath {A a} , [A] a. +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x + := match p with idpath => idpath end. + +Record PreCategory := + { + Object :> Type; + Morphism : Object -> Object -> Type; + + Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' where "f 'o' g" := (Compose f g) + }. +Bind Scope category_scope with PreCategory. + +Arguments Compose [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename. + +Infix "o" := Compose : morphism_scope. +Local Open Scope morphism_scope. + +Record Functor (C D : PreCategory) := + { + ObjectOf :> C -> D; + MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d); + FCompositionOf : forall s d d' (m1 : C.(Morphism) s d) (m2: C.(Morphism) d d'), + MorphismOf _ _ (m2 o m1) = (MorphismOf _ _ m2) o (MorphismOf _ _ m1) + }. + +Bind Scope functor_scope with Functor. + +Arguments MorphismOf [C%category] [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch. + +Definition ComposeFunctors C D E + (G : Functor D E) (F : Functor C D) : Functor C E + := Build_Functor C E + (fun c => G (F c)) + admit + admit. + +Infix "o" := ComposeFunctors : functor_scope. + +Record NaturalTransformation C D (F G : Functor C D) := + { + ComponentsOf :> forall c, D.(Morphism) (F c) (G c); + Commutes : forall s d (m : C.(Morphism) s d), + ComponentsOf d o F.(MorphismOf) m = G.(MorphismOf) m o ComponentsOf s + }. + +Generalizable All Variables. + +Section NTComposeT. + + Variable C : PreCategory. + Variable D : PreCategory. + + Variables F F' F'' : Functor C D. + + Variable T' : NaturalTransformation F' F''. + Variable T : NaturalTransformation F F'. + Let CO := fun c => T' c o T c. + Definition NTComposeT_Commutes s d (m : Morphism C s d) + : CO d o MorphismOf F m = MorphismOf F'' m o CO s. + + admit. + Defined. + Definition NTComposeT + : NaturalTransformation F F'' + := Build_NaturalTransformation F F'' + (fun c => T' c o T c) + NTComposeT_Commutes. +End NTComposeT. +Definition NTWhiskerR C D E (F F' : Functor D E) (T : NaturalTransformation F F') + (G : Functor C D) + := Build_NaturalTransformation (F o G) (F' o G) + (fun c => T (G c)) + admit. +Global Class NTC_Composable A B (a : A) (b : B) (T : Type) (term : T) := {}. + +Definition NTC_Composable_term `{@NTC_Composable A B a b T term} := term. +Notation "T 'o' U" + := (@NTC_Composable_term _ _ T%natural_transformation U%natural_transformation _ _ _) + : natural_transformation_scope. + +Local Open Scope natural_transformation_scope. + +Lemma NTWhiskerR_CompositionOf C D + (F G H : Functor C D) + (T : NaturalTransformation G H) + (T' : NaturalTransformation F G) B (I : Functor B C) +: NTWhiskerR (NTComposeT T T') I = NTComposeT (NTWhiskerR T I) (NTWhiskerR T' I). + + admit. +Defined. +Definition FunctorCategory C D : PreCategory + := @Build_PreCategory (Functor C D) + (NaturalTransformation (C := C) (D := D)) + admit. + +Notation "[ C , D ]" := (FunctorCategory C D) : category_scope. + +Variable C : PreCategory. +Variable D : PreCategory. +Variable E : PreCategory. +Fail Definition NTWhiskerR_Functorial (G : [C, D]%category) +: [[D, E], [C, E]]%category + := Build_Functor + [C, D] [C, E] + (fun F => F o G) + (fun _ _ T => T o G) + (fun _ _ _ _ _ => inverse (NTWhiskerR_CompositionOf _ _ _)). +(* Anomaly: Uncaught exception Not_found(_). Please report. *) diff --git a/test-suite/bugs/closed/HoTT_coq_062.v b/test-suite/bugs/closed/HoTT_coq_062.v new file mode 100644 index 00000000..db895316 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_062.v @@ -0,0 +1,106 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) +(* File reduced by coq-bug-finder from 5012 lines to 4659 lines, then from 4220 lines to 501 lines, then from 513 lines to 495 lines, then from 513 lines to 495 lines, then from 412 lines to 79 lines, then from 412 lines to 79 lines. *) +Set Universe Polymorphism. +Definition admit {T} : T. +Admitted. +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Arguments idpath {A a} , [A] a. +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. + +Delimit Scope path_scope with path. +Local Open Scope path_scope. + +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. + +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing) : path_scope. + +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. + +Definition apD {A:Type} {B:A->Type} (f:forall a:A, B a) {x y:A} (p:x=y): + p # (f x) = f y + := + match p with idpath => idpath end. + +Class IsEquiv {A B : Type} (f : A -> B) := + BuildIsEquiv { + equiv_inv : B -> A + }. + +Record Equiv A B := + BuildEquiv { + equiv_fun :> A -> B ; + equiv_isequiv :> IsEquiv equiv_fun + }. + +Existing Instance equiv_isequiv. + +Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope. + +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope. + +Inductive Bool : Type := true | false. + +Local Open Scope equiv_scope. +Definition equiv_path (A B : Type) (p : A = B) : A <~> B + := BuildEquiv _ _ (transport (fun X:Type => X) p) admit. + +Class Univalence := + isequiv_equiv_path :> forall (A B : Type), IsEquiv (equiv_path A B) . + +Section Univalence. + Context `{Univalence}. + Definition path_universe_uncurried {A B : Type} (f : A <~> B) : A = B + := (equiv_path A B)^-1 f. + + Definition path_universe {A B : Type} (f : A -> B) {feq : IsEquiv f} : (A = B) + := path_universe_uncurried (BuildEquiv _ _ f feq). +End Univalence. + +Definition e : Equiv@{i j} Bool Bool. + admit. +Defined. + +Definition p `{Univalence} : @paths Type Bool Bool := path_universe e. + +Theorem thm `{Univalence} : (forall A, ((A -> False) -> False) -> A) -> False. + intro f. + Set Printing Universes. + Set Printing All. + Show Universes. + pose proof (apD f p). + pose proof (apD f (path_universe e)). + admit. +Defined. (* ??? Toplevel input, characters 0-37: +Error: +Unable to satisfy the following constraints: +In environment: +H : Univalence@{Top.144 Top.145 Top.146 Top.147 Top.148} +f : forall (A : Type{Top.150}) (_ : forall _ : forall _ : A, False, False), A + +?57 : "@IsEquiv@{Top.150 Top.145} Bool Bool (equiv_fun@{Set Set} Bool Bool e)" *) +(* Toplevel input, characters 18-19: +Error: +In environment +H : Univalence (* Top.148 Top.149 Top.150 Top.151 *) +f : forall (A : Type (* Top.153 *)) + (_ : forall _ : forall _ : A, False, False), A +X : @paths (* Top.155 *) + ((fun A : Type (* Top.153 *) => + forall _ : forall _ : forall _ : A, False, False, A) Bool) + (@transport (* Top.154 Top.155 *) Type (* Top.153 *) + (fun A : Type (* Top.153 *) => + forall _ : forall _ : forall _ : A, False, False, A) Bool Bool + (@path_universe (* Top.148 Top.150 Top.151 Top.159 Top.153 Top.154 + Top.149 Top.153 *) H Bool Bool + (equiv_fun (* Top.153 Top.153 *) Bool Bool e (* Top.153 *)) + (equiv_isequiv (* Top.153 Top.153 *) Bool Bool e (* Top.153 *))) + (f Bool)) (f Bool) +The term "@p (* Top.148 Top.172 Top.151 Top.150 Top.149 *) H" has type + "@paths (* Top.171 *) Set Bool Bool" while it is expected to have type + "@paths (* Top.169 *) Type (* Top.153 *) ?62 ?63" +(Universe inconsistency: Cannot enforce Set = Top.153)). *) diff --git a/test-suite/bugs/closed/HoTT_coq_063.v b/test-suite/bugs/closed/HoTT_coq_063.v new file mode 100644 index 00000000..777f6483 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_063.v @@ -0,0 +1,34 @@ +Set Universe Polymorphism. +Module A. + Inductive paths A (x : A) : A -> Type := idpath : paths A x x. + + Notation "x = y" := (paths _ x y). + + Inductive IsTrunc : nat -> Type -> Type := + | BuildContr : forall A (center : A) (contr : forall y, center = y), IsTrunc 0 A + | trunc_S : forall A n, (forall x y : A, IsTrunc n (x = y)) -> IsTrunc (S n) A. + + Existing Class IsTrunc. + + + Instance is_trunc_unit : IsTrunc 0 unit. + Proof. apply BuildContr with (center:=tt). now intros []. Defined. + + Check (_ : IsTrunc 0 unit). +End A. + +Module B. + Fixpoint IsTrunc (n : nat) (A : Type) : Type := + match n with + | O => True + | S _ => False + end. + + Existing Class IsTrunc. + + Instance is_trunc_unit : IsTrunc 0 unit. + Proof. exact I. Defined. + + Check (_ : IsTrunc 0 unit). + Fail Definition foo := (_ : IsTrunc 1 unit). +End B. diff --git a/test-suite/bugs/closed/HoTT_coq_064.v b/test-suite/bugs/closed/HoTT_coq_064.v new file mode 100644 index 00000000..5f0a541b --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_064.v @@ -0,0 +1,190 @@ +(* File reduced by coq-bug-finder from 279 lines to 219 lines. *) + +Set Implicit Arguments. +Set Universe Polymorphism. +Definition admit {T} : T. +Admitted. +Module Export Overture. + Reserved Notation "g 'o' f" (at level 40, left associativity). + + Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + + Arguments idpath {A a} , [A] a. + + Notation "x = y :> A" := (@paths A x y) : type_scope. + + Notation "x = y" := (x = y :>_) : type_scope. + + Delimit Scope path_scope with path. + + Local Open Scope path_scope. + + Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. + + Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g) + : forall x, f x = g x + := fun x => match h with idpath => idpath end. + + Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { equiv_inv : B -> A }. + + Delimit Scope equiv_scope with equiv. + Local Open Scope equiv_scope. + + Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope. + + Class Funext. + Axiom isequiv_apD10 : `{Funext} -> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) . + Existing Instance isequiv_apD10. + + Definition path_forall `{Funext} {A : Type} {P : A -> Type} (f g : forall x : A, P x) : + (forall x, f x = g x) -> f = g + := + (@apD10 A P f g)^-1. + +End Overture. + +Module Export Core. + + Set Implicit Arguments. + Delimit Scope morphism_scope with morphism. + Delimit Scope category_scope with category. + Delimit Scope object_scope with object. + + Record PreCategory := + { + object :> Type; + morphism : object -> object -> Type; + + compose : forall s d d', + morphism d d' + -> morphism s d + -> morphism s d' + where "f 'o' g" := (compose f g); + + associativity : forall x1 x2 x3 x4 + (m1 : morphism x1 x2) + (m2 : morphism x2 x3) + (m3 : morphism x3 x4), + (m3 o m2) o m1 = m3 o (m2 o m1) + }. + Bind Scope category_scope with PreCategory. + Arguments compose [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename. + + Infix "o" := compose : morphism_scope. + +End Core. + +Local Open Scope morphism_scope. +Record Functor (C D : PreCategory) := + { + object_of :> C -> D; + morphism_of : forall s d, morphism C s d + -> morphism D (object_of s) (object_of d) + }. + +Inductive Unit : Set := + tt : Unit. + +Definition indiscrete_category (X : Type) : PreCategory + := @Build_PreCategory X + (fun _ _ => Unit) + (fun _ _ _ _ _ => tt) + (fun _ _ _ _ _ _ _ => idpath). + + +Record NaturalTransformation C D (F G : Functor C D) := { components_of :> forall c, morphism D (F c) (G c) }. +Section path_natural_transformation. + Context `{Funext}. + Variable C : PreCategory. + Variable D : PreCategory. + Variables F G : Functor C D. + + Section path. + Variables T U : NaturalTransformation F G. + Lemma path'_natural_transformation + : components_of T = components_of U + -> T = U. + admit. + Defined. + Lemma path_natural_transformation + : (forall x, T x = U x) + -> T = U. + Proof. + intros. + apply path'_natural_transformation. + apply path_forall; assumption. + Qed. + End path. +End path_natural_transformation. +Ltac path_natural_transformation := + repeat match goal with + | _ => intro + | _ => apply path_natural_transformation; simpl + end. +Definition comma_category A B C (S : Functor A C) (T : Functor B C) +: PreCategory. + admit. +Defined. +Definition compose C D (F F' F'' : Functor C D) + (T' : NaturalTransformation F' F'') (T : NaturalTransformation F F') +: NaturalTransformation F F'' + := Build_NaturalTransformation F F'' + (fun c => T' c o T c). + +Infix "o" := compose : natural_transformation_scope. + +Local Open Scope natural_transformation_scope. + +Definition associativity `{fs : Funext} + C D F G H I + (V : @NaturalTransformation C D F G) + (U : @NaturalTransformation C D G H) + (T : @NaturalTransformation C D H I) +: (T o U) o V = T o (U o V). +Proof. + path_natural_transformation. + + apply associativity. +Qed. +Definition functor_category `{Funext} (C D : PreCategory) : PreCategory + := @Build_PreCategory (Functor C D) + (@NaturalTransformation C D) + (@compose C D) + (@associativity _ C D). + +Notation "C -> D" := (functor_category C D) : category_scope. + +Definition compose_functor `{Funext} (C D E : PreCategory) : object ((C -> D) -> ((D -> E) -> (C -> E))). + admit. + +Defined. + +Definition pullback_along `{Funext} (C C' D : PreCategory) (p : Functor C C') +: object ((C' -> D) -> (C -> D)) + := Eval hnf in compose_functor _ _ _ p. + +Definition IsColimit `{Funext} C D (F : Functor D C) + (x : object + (@comma_category (indiscrete_category Unit) + (@functor_category H (indiscrete_category Unit) C) + (@functor_category H D C) + admit + (@pullback_along H D (indiscrete_category Unit) C + admit))) : Type + := admit. + +Generalizable All Variables. +Axiom fs : Funext. + +Section bar. + + Variable D : PreCategory. + + Context `(has_colimits + : forall F : Functor D C, + @IsColimit _ C D F (colimits F)). +(* Error: Unsatisfied constraints: Top.3773 <= Set + (maybe a bugged tactic). *) +End bar. diff --git a/test-suite/bugs/closed/HoTT_coq_067.v b/test-suite/bugs/closed/HoTT_coq_067.v new file mode 100644 index 00000000..ad32a60c --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_067.v @@ -0,0 +1,28 @@ +Set Universe Polymorphism. +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Goal forall (A : Type) (P : forall _ : A, Type) (x0 : A) + (p : P x0) (q : @paths (@sigT A P) (@existT A P x0 p) (@existT A P x0 p)), + @paths (@paths (@sigT A P) (@existT A P x0 p) (@existT A P x0 p)) + (@idpath (@sigT A P) (@existT A P x0 p)) + (@idpath (@sigT A P) (@existT A P x0 p)). + intros. + induction q. + admit. +Qed. +(** Error: Illegal application: +The term "paths_rect" of type + "forall (A : Type) (a : A) (P : forall a0 : A, paths a a0 -> Type), + P a (idpath a) -> forall (y : A) (p : paths a y), P y p" +cannot be applied to the terms + "{x : _ & P x}" : "Type" + "s" : "{x : _ & P x}" + "fun (a : {x : _ & P x}) (_ : paths s a) => paths (idpath a) (idpath a)" + : "forall a : {x : _ & P x}, paths s a -> Type" + "match proof_admitted return (paths (idpath s) (idpath s)) with + end" : "paths (idpath s) (idpath s)" + "s" : "{x : _ & P x}" + "q" : "paths (existT P x0 p) (existT P x0 p)" +The 3rd term has type "forall a : {x : _ & P x}, paths s a -> Type" +which should be coercible to "forall a : {x : _ & P x}, paths s a -> Type". *) diff --git a/test-suite/bugs/closed/HoTT_coq_068.v b/test-suite/bugs/closed/HoTT_coq_068.v new file mode 100644 index 00000000..f1cdcbf2 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_068.v @@ -0,0 +1,61 @@ +Generalizable All Variables. + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. + +Module success. + Axiom bar : nat -> Type -> Type. + + Definition foo (n : nat) (A : Type) : Type := + match n with + | O => A + | S n' => forall x y : A, bar n' (x = y) + end. + + Definition foo_succ n A : foo (S n) A. + Admitted. + + Goal forall n (X Y : Type) (y : X) (x : X), bar n (x = y). + intros. + apply (foo_succ _ _). + Defined. +End success. + +Module failure. + Fixpoint bar (n : nat) (A : Type) : Type := + match n with + | O => A + | S n' => forall x y : A, bar n' (x = y) + end. + + Definition foo_succ n A : bar (S n) A. + Admitted. + + Goal forall n (X Y : Type) (y : X) (x : X), bar n (x = y). + intros. + apply foo_succ. + (* Toplevel input, characters 22-34: +Error: In environment +n : nat +X : Type +Y : Type +y : X +x : X +Unable to unify + "forall x0 y0 : ?16, + (fix bar (n : nat) (A : Type) {struct n} : Type := + match n with + | 0 => A + | S n' => forall x y : A, bar n' (x = y) + end) ?15 (x0 = y0)" with + "(fix bar (n : nat) (A : Type) {struct n} : Type := + match n with + | 0 => A + | S n' => forall x y : A, bar n' (x = y) + end) n (x = y)". +*) + Defined. +End failure. diff --git a/test-suite/bugs/closed/HoTT_coq_071.v b/test-suite/bugs/closed/HoTT_coq_071.v new file mode 100644 index 00000000..b5a5ec1b --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_071.v @@ -0,0 +1,9 @@ +Set Universe Polymorphism. +Definition foo : True. + abstract exact I. +Defined. +Eval hnf in foo. (* Should not be [I] *) +Goal True. +Proof. + Fail unify foo I. +Abort. diff --git a/test-suite/bugs/closed/HoTT_coq_074.v b/test-suite/bugs/closed/HoTT_coq_074.v new file mode 100644 index 00000000..370c7d40 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_074.v @@ -0,0 +1,10 @@ +Monomorphic Definition U1 := Type. +Monomorphic Definition U2 := Type. + +Set Printing Universes. +Definition foo : True. +let t1 := type of U1 in +let t2 := type of U2 in +idtac t1 t2; +pose (t1 : t2). exact I. +Defined. diff --git a/test-suite/bugs/closed/HoTT_coq_077.v b/test-suite/bugs/closed/HoTT_coq_077.v new file mode 100644 index 00000000..db3b60ed --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_077.v @@ -0,0 +1,39 @@ +Set Implicit Arguments. + +Require Import Logic. + +Set Asymmetric Patterns. +Set Record Elimination Schemes. +Set Primitive Projections. + +Record prod (A B : Type) : Type := + pair { fst : A; snd : B }. + +Print prod_rect. +(** prod_rect = +fun (A B : Type) (P : prod A B -> Type) + (f : forall (fst : A) (snd : B), P {| fst := fst; snd := snd |}) + (p : prod A B) => +match p as p0 return (P p0) with +| {| fst := x; snd := x0 |} => f x x0 +end + : forall (A B : Type) (P : prod A B -> Type), + (forall (fst : A) (snd : B), P {| fst := fst; snd := snd |}) -> + forall p : prod A B, P p + +Arguments A, B are implicit +Argument scopes are [type_scope type_scope _ _ _] + *) + +(* What I really want: *) +Definition prod_rect' A B (P : prod A B -> Type) (u : forall (fst : A) (snd : B), P (pair fst snd)) + (p : prod A B) : P p + := u (fst p) (snd p). + +Notation typeof x := ($(let T := type of x in exact T)$) (only parsing). + +(* Check for eta *) +Check eq_refl : typeof (@prod_rect) = typeof (@prod_rect'). + +(* Check for the recursion principle I want *) +Check eq_refl : @prod_rect = @prod_rect'. diff --git a/test-suite/bugs/closed/HoTT_coq_078.v b/test-suite/bugs/closed/HoTT_coq_078.v new file mode 100644 index 00000000..54cb68b0 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_078.v @@ -0,0 +1,43 @@ +Set Implicit Arguments. +Require Import Logic. + +(*Global Set Universe Polymorphism.*) +Global Set Asymmetric Patterns. +Local Set Primitive Projections. + +Local Open Scope type_scope. + +Record prod (A B : Type) : Type := + pair { fst : A; snd : B }. + +Arguments pair {A B} _ _. + +Notation "x * y" := (prod x y) : type_scope. +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. + +Generalizable Variables X A B f g n. + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Arguments idpath {A a} , [A] a. + +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. + +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. + +Definition transport_prod' {A : Type} {P Q : A -> Type} {a a' : A} (p : a = a') + (z : P a * Q a) + : transport (fun a => P a * Q a) p z = (transport _ p (fst z), transport _ p (snd z)) + := match p as p' return transport (fun a0 => P a0 * Q a0) p' z = (transport P p' (fst z), transport Q p' (snd z)) with + | idpath => idpath + end. (* success *) + +Definition transport_prod {A : Type} {P Q : A -> Type} {a a' : A} (p : a = a') + (z : P a * Q a) + : transport (fun a => P a * Q a) p z = (transport _ p (fst z), transport _ p (snd z)) + := match p with + | idpath => idpath + end. diff --git a/test-suite/bugs/closed/HoTT_coq_079.v b/test-suite/bugs/closed/HoTT_coq_079.v new file mode 100644 index 00000000..e70de9ca --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_079.v @@ -0,0 +1,16 @@ +Set Primitive Projections. +Set Implicit Arguments. +Set Universe Polymorphism. + +Inductive paths A (x : A) : A -> Type := idpath : paths x x. + +Notation "x = y :> A" := (@paths A x y). +Notation "x = y" := (x = y :> _). + +Record foo := { x : Type; H : x = x }. + +Create HintDb bar discriminated. +Hint Resolve H : bar. +Goal forall y : foo, @x y = @x y. +intro y. +progress auto with bar. (* failed to progress *) diff --git a/test-suite/bugs/closed/HoTT_coq_080.v b/test-suite/bugs/closed/HoTT_coq_080.v new file mode 100644 index 00000000..6b07c304 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_080.v @@ -0,0 +1,27 @@ +Set Primitive Projections. +Set Implicit Arguments. +Set Universe Polymorphism. +Set Asymmetric Patterns. +Set Printing Projections. +Inductive sum A B := inl : A -> sum A B | inr : B -> sum A B. +Inductive Empty :=. + +Record category := + { ob :> Type; + hom : ob -> ob -> Type + }. + +Definition sum_category (C D : category) : category := + {| + ob := sum (ob C) (ob D); + hom x y := match x, y with + | inl x, inl y => @hom C x y + | inr x, inr y => @hom D x y + | _, _ => Empty + end |}. + +Goal forall C D (x y : ob (sum_category C D)), Type. +intros C D x y. +hnf in x, y. +exact (hom (sum_category _ _) x y). +Defined.
\ No newline at end of file diff --git a/test-suite/bugs/closed/HoTT_coq_081.v b/test-suite/bugs/closed/HoTT_coq_081.v new file mode 100644 index 00000000..ac27dea7 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_081.v @@ -0,0 +1,16 @@ +Set Primitive Projections. +Set Implicit Arguments. +Set Universe Polymorphism. + +Record category (A : Type) := + { ob :> Type; + hom : ob -> ob -> Type + }. + +Record foo { A: Type } := { C : category A; x : ob C; y :> hom _ x x }. +Definition comp A (C : category A) (x : C) (f : hom _ x x) := f. + +Definition bar A (f : @foo A) := @comp _ _ _ f. + +(* Toplevel input, characters 0-42: +Error: Cannot find the target class. *) diff --git a/test-suite/bugs/closed/HoTT_coq_082.v b/test-suite/bugs/closed/HoTT_coq_082.v new file mode 100644 index 00000000..ccba22ca --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_082.v @@ -0,0 +1,19 @@ +Set Implicit Arguments. +Set Universe Polymorphism. + +Record category := + { ob : Type }. + +Existing Class category. (* +Toplevel input, characters 0-24: +Anomaly: Mismatched instance and context when building universe substitution. +Please report. *) + +Record category' := + { ob' : Type; + hom' : ob' -> ob' -> Type }. + +Existing Class category'. (* +Toplevel input, characters 0-24: +Anomaly: Mismatched instance and context when building universe substitution. +Please report. *) diff --git a/test-suite/bugs/closed/HoTT_coq_083.v b/test-suite/bugs/closed/HoTT_coq_083.v new file mode 100644 index 00000000..494b25c7 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_083.v @@ -0,0 +1,29 @@ +Set Primitive Projections. +Set Implicit Arguments. +Set Universe Polymorphism. + +Record category := + { ob : Type }. + +Goal forall C, ob C -> ob C. +intros. +generalize dependent (ob C). +(* 1 subgoals, subgoal 1 (ID 7) + + C : category + ============================ + forall T : Type, T -> T +(dependent evars:) *) +intros T t. +Undo 2. +generalize dependent (@ob C). +(* 1 subgoals, subgoal 1 (ID 6) + + C : category + X : ob C + ============================ + Type -> ob C +(dependent evars:) *) +intros T t. +(* Toplevel input, characters 9-10: +Error: No product even after head-reduction. *) diff --git a/test-suite/bugs/closed/HoTT_coq_084.v b/test-suite/bugs/closed/HoTT_coq_084.v new file mode 100644 index 00000000..d007e4e2 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_084.v @@ -0,0 +1,49 @@ +Set Implicit Arguments. +Set Universe Polymorphism. + +Module success. + Unset Primitive Projections. + + Record group := + { carrier : Type; + id : carrier }. + + Notation "1" := (id _) : g_scope. + + Delimit Scope g_scope with g. + Bind Scope g_scope with carrier. + + Section foo. + Variable g : group. + Variable comp : carrier g -> carrier g -> carrier g. + + Check comp 1 1. + End foo. +End success. + +Module failure. + Set Primitive Projections. + + Record group := + { carrier : Type; + id : carrier }. + + Notation "1" := (id _) : g_scope. + + Delimit Scope g_scope with g. + Bind Scope g_scope with carrier. + + Section foo. + Variable g : group. + Variable comp : carrier g -> carrier g -> carrier g. + + Check comp 1 1. + (* Toplevel input, characters 11-12: +Error: +In environment +g : group +comp : carrier g -> carrier g -> carrier g +The term "1" has type "nat" while it is expected to have type "carrier g". + *) + End foo. +End failure. diff --git a/test-suite/bugs/closed/HoTT_coq_085.v b/test-suite/bugs/closed/HoTT_coq_085.v new file mode 100644 index 00000000..041c6799 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_085.v @@ -0,0 +1,74 @@ +Set Implicit Arguments. +Set Universe Polymorphism. + +Module success. + Unset Primitive Projections. + + Record category := + { ob : Type; + hom : ob -> ob -> Type; + comp : forall x y z, hom y z -> hom x y -> hom x z }. + + Delimit Scope hom_scope with hom. + Bind Scope hom_scope with hom. + Arguments hom : clear implicits. + Arguments comp _ _ _ _ _%hom _%hom : clear implicits. + + Notation "f 'o' g" := (comp _ _ _ _ f g) (at level 40, left associativity) : hom_scope. + + Record functor (C D : category) := + { ob_of : ob C -> ob D; + hom_of : forall x y, hom C x y -> hom D (ob_of x) (ob_of y) }. + + Delimit Scope functor_scope with functor. + Bind Scope functor_scope with functor. + + Arguments hom_of _ _ _%functor _ _ _%hom. + + Notation "F '_1' m" := (hom_of F _ _ m) (at level 10, no associativity) : hom_scope. + + Axiom f_comp : forall C D E, functor D E -> functor C D -> functor C E. + Notation "f 'o' g" := (@f_comp _ _ _ f g) (at level 40, left associativity) : functor_scope. + + Check ((_ o _) _1 _)%hom. (* ((?16 o ?17) _1 ?20)%hom + : hom ?15 (ob_of (?16 o ?17) ?18) (ob_of (?16 o ?17) ?19) *) +End success. + +Module failure. + Set Primitive Projections. + + Record category := + { ob : Type; + hom : ob -> ob -> Type; + comp : forall x y z, hom y z -> hom x y -> hom x z }. + + Delimit Scope hom_scope with hom. + Bind Scope hom_scope with hom. + Arguments hom : clear implicits. + Arguments comp _ _ _ _ _%hom _%hom : clear implicits. + + Notation "f 'o' g" := (comp _ _ _ _ f g) (at level 40, left associativity) : hom_scope. + + Record functor (C D : category) := + { ob_of : ob C -> ob D; + hom_of : forall x y, hom C x y -> hom D (ob_of x) (ob_of y) }. + + Delimit Scope functor_scope with functor. + Bind Scope functor_scope with functor. + + Arguments hom_of _ _ _%functor _ _ _%hom. + + Notation "F '_1' m" := (hom_of F _ _ m) (at level 10, no associativity) : hom_scope. + Notation "F '_2' m" := (hom_of F%functor _ _ m) (at level 10, no associativity) : hom_scope. + + Axiom f_comp : forall C D E, functor D E -> functor C D -> functor C E. + Notation "f 'o' g" := (@f_comp _ _ _ f g) (at level 40, left associativity) : functor_scope. + + Check ((_ o _) _2 _)%hom. (* ((?14 o ?15)%functor _1 ?18)%hom + : hom ?13 (ob_of (?14 o ?15)%functor ?16) + (ob_of (?14 o ?15)%functor ?17) *) + Check ((_ o _) _1 _)%hom. (* Toplevel input, characters 7-19: +Error: +The term "(?23 o ?24)%hom" has type "hom ?19 ?20 ?22" +while it is expected to have type "functor ?25 ?26". *) +End failure. diff --git a/test-suite/bugs/closed/HoTT_coq_087.v b/test-suite/bugs/closed/HoTT_coq_087.v new file mode 100644 index 00000000..265310b1 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_087.v @@ -0,0 +1,14 @@ +Structure type : Type := Pack { ob : Type }. +Polymorphic Record category := { foo : Type }. +Definition FuncComp := Pack category. +Axiom C : category. + +Check (C : ob FuncComp). (* OK *) + +Canonical Structure FuncComp. + +Check (C : ob FuncComp). +(* Toplevel input, characters 15-39: +Error: +The term "C" has type "category" while it is expected to have type + "ob FuncComp". *) diff --git a/test-suite/bugs/closed/HoTT_coq_088.v b/test-suite/bugs/closed/HoTT_coq_088.v new file mode 100644 index 00000000..b3e1df57 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_088.v @@ -0,0 +1,78 @@ +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Arguments idpath {A a} , [A] a. + +Arguments paths_ind [A] a P f y p. +Arguments paths_rec [A] a P f y p. +Arguments paths_rect [A] a P f y p. + +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. + +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := + forall x : A, r (s x) = x. + +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. + +(** A typeclass that includes the data making [f] into an adjoint equivalence. *) +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { + equiv_inv : B -> A ; + eisretr : Sect equiv_inv f; + eissect : Sect f equiv_inv; + eisadj : forall x : A, eisretr (f x) = ap f (eissect x) +}. + +Record Equiv A B := BuildEquiv { + equiv_fun :> A -> B ; + equiv_isequiv :> IsEquiv equiv_fun +}. + + +Definition equiv_path (A B : Type) (p : A = B) : Equiv A B. +Admitted. + +Class Univalence := { + isequiv_equiv_path :> forall (A B : Type), IsEquiv (equiv_path A B) +}. + +Definition ua_downward_closed `{Univalence} : Univalence. + constructor. + intros A B. + destruct H as [H]. + generalize (fun A B => @eisretr _ _ _ (H (A : Type) (B : Type))). + generalize (fun A B => @eissect _ _ _ (H (A : Type) (B : Type))). + let g := match goal with |- _ -> _ -> ?g => constr:(g) end in + let U0 := match goal with |- (forall (A : ?U0) (B : ?U1), Sect (@?f A B) _) -> (forall (A : ?U2) (B : ?U3), Sect _ (@?f' A B)) -> ?g => constr:(U0) end in + let U1 := match goal with |- (forall (A : ?U0) (B : ?U1), Sect (@?f A B) _) -> (forall (A : ?U2) (B : ?U3), Sect _ (@?f' A B)) -> ?g => constr:(U1) end in + let U2 := match goal with |- (forall (A : ?U0) (B : ?U1), Sect (@?f A B) _) -> (forall (A : ?U2) (B : ?U3), Sect _ (@?f' A B)) -> ?g => constr:(U2) end in + let U3 := match goal with |- (forall (A : ?U0) (B : ?U1), Sect (@?f A B) _) -> (forall (A : ?U2) (B : ?U3), Sect _ (@?f' A B)) -> ?g => constr:(U3) end in + let f0 := match goal with |- (forall (A : ?U0) (B : ?U1), Sect (@?f A B) _) -> (forall (A : ?U2) (B : ?U3), Sect _ (@?f' A B)) -> ?g => constr:(f) end in + let f' := match goal with |- (forall (A : ?U0) (B : ?U1), Sect (@?f A B) _) -> (forall (A : ?U2) (B : ?U3), Sect _ (@?f' A B)) -> ?g => constr:(f') end in + change ((forall (A : U0) (B : U1), Sect (f0 A B) ((fun (A : U0) (B : U1) => @equiv_inv _ _ _ (H A B)) A B)) + -> (forall (A : U2) (B : U3), Sect ((fun (A : U0) (B : U1) => @equiv_inv _ _ _ (H A B)) A B) (f' A B)) + -> g); + generalize (fun (A : U0) (B : U1) => @equiv_inv _ _ _ (H A B)); + clear H; + simpl; + intros fi sect retr. + pose proof fi as fi'. + Set Printing All. + change (forall (A : Type) (B : Type) (_ : Equiv A B), @paths Type A B) in fi'. + (*refine (@isequiv_adjointify + _ _ + _ _ + _ + _); + admit. + Grab Existential Variables.*) + admit. + (*destruct p.*) + (*specialize (H (A' : Type)).*) +Defined. +(* Error: Unsatisfied constraints: +Top.62 < Top.61 +Top.64 <= Top.62 +Top.63 <= Top.62 + (maybe a bugged tactic).*) diff --git a/test-suite/bugs/closed/HoTT_coq_089.v b/test-suite/bugs/closed/HoTT_coq_089.v new file mode 100644 index 00000000..2da4aff6 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_089.v @@ -0,0 +1,44 @@ +Set Implicit Arguments. +Set Universe Polymorphism. +Set Printing Universes. + +Inductive type_paths (A : Type) : Type -> Prop + := idtypepath : type_paths A A. +Monomorphic Definition comp_type_paths := Eval compute in type_paths@{Type Type}. +Check comp_type_paths. +(* comp_type_paths + : Type (* Top.12 *) -> Type (* Top.12 *) -> Prop *) +(* This is terrible. *) + +Inductive type_paths' (A : Type) : Type -> Prop + := idtypepath' : type_paths' A A + | other_type_path : False -> forall B : Type, type_paths' A B. +Monomorphic Definition comp_type_paths' := Eval compute in type_paths'. +Check comp_type_paths'. +(* comp_type_paths' + : Type (* Top.24 *) -> Type (* Top.23 *) -> Prop *) +(* Ok, then ... *) + +(** Fail if it's [U0 -> U0 -> _], but not on [U0 -> U1 -> _]. *) +Goal Type. +Proof. + match type of comp_type_paths' with + | ?U0 -> ?U1 -> ?R + => exact (@comp_type_paths' nat U0) + end. +Defined. + +Goal Type. +Proof. + match type of comp_type_paths with + | ?U0 -> ?U1 -> ?R + => exact (@comp_type_paths nat U0) + end. + (* Toplevel input, characters 110-112: +Error: +The term "Type (* Top.51 *)" has type "Type (* Top.51+1 *)" +while it is expected to have type "Type (* Top.51 *)" +(Universe inconsistency: Cannot enforce Top.51 < Top.51 because Top.51 += Top.51)). *) + +Defined. diff --git a/test-suite/bugs/closed/HoTT_coq_090.v b/test-suite/bugs/closed/HoTT_coq_090.v new file mode 100644 index 00000000..5c704147 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_090.v @@ -0,0 +1,187 @@ +(** I'm not sure if this tests what I want it to test... *) +Set Implicit Arguments. +Set Universe Polymorphism. + +Notation idmap := (fun x => x). + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Arguments idpath {A a} , [A] a. + +Arguments paths_ind [A] a P f y p. +Arguments paths_rec [A] a P f y p. +Arguments paths_rect [A] a P f y p. + +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. + +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := + forall x : A, r (s x) = x. + +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. + +(** A typeclass that includes the data making [f] into an adjoint equivalence. *) +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { + equiv_inv : B -> A ; + eisretr : Sect equiv_inv f; + eissect : Sect f equiv_inv; + eisadj : forall x : A, eisretr (f x) = ap f (eissect x) +}. + +Arguments eisretr {A B} f {_} _. +Arguments eissect {A B} f {_} _. +Arguments eisadj {A B} f {_} _. + + +Record Equiv A B := BuildEquiv { + equiv_fun :> A -> B ; + equiv_isequiv :> IsEquiv equiv_fun +}. + +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := + match p, q with idpath, idpath => idpath end. + +(** See above for the meaning of [simpl nomatch]. *) +Arguments concat {A x y z} p q : simpl nomatch. + +(** The inverse of a path. *) +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x + := match p with idpath => idpath end. + +(** Declaring this as [simpl nomatch] prevents the tactic [simpl] from expanding it out into [match] statements. We only want [inverse] to simplify when applied to an identity path. *) +Arguments inverse {A x y} p : simpl nomatch. + +(** Note that you can use the built-in Coq tactics [reflexivity] and [transitivity] when working with paths, but not [symmetry], because it is too smart for its own good. Instead, you can write [apply symmetry] or [eapply symmetry]. *) + +(** The identity path. *) +Notation "1" := idpath : path_scope. + +(** The composition of two paths. *) +Notation "p @ q" := (concat p q) (at level 20) : path_scope. + +(** The inverse of a path. *) +Notation "p ^" := (inverse p) (at level 3) : path_scope. + +(** An alternative notation which puts each path on its own line. Useful as a temporary device during proofs of equalities between very long composites; to turn it on inside a section, say [Open Scope long_path_scope]. *) +Notation "p @' q" := (concat p q) (at level 21, left associativity, + format "'[v' p '/' '@'' q ']'") : long_path_scope. + + +(** An important instance of [paths_rect] is that given any dependent type, one can _transport_ elements of instances of the type along equalities in the base. + + [transport P p u] transports [u : P x] to [P y] along [p : x = y]. *) +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. + +(** See above for the meaning of [simpl nomatch]. *) +Arguments transport {A} P {x y} p%path_scope u : simpl nomatch. + + + +Instance isequiv_path {A B : Type} (p : A = B) + : IsEquiv (transport (fun X:Type => X) p) | 0. +Proof. + refine (@BuildIsEquiv _ _ _ (transport (fun X:Type => X) p^) _ _ _); + admit. +Defined. + +Definition equiv_path (A B : Type) (p : A = B) : Equiv A B + := @BuildEquiv _ _ (transport (fun X:Type => X) p) _. + +Arguments equiv_path : clear implicits. + +Definition equiv_adjointify A B (f : A -> B) (g : B -> A) (r : Sect g f) (s : Sect f g) : Equiv A B. +Proof. + refine (@BuildEquiv A B f (@BuildIsEquiv A B f g r s _)). + admit. +Defined. + + +Set Printing Universes. + +Definition lift_id_type : Type. +Proof. + let U0 := constr:(Type) in + let U1 := constr:(Type) in + let unif := constr:(U0 : U1) in + exact (forall (A : Type) (B : Type), @paths U0 A B -> @paths U1 A B). +Defined. + +Definition lower_id_type : Type. +Proof. + let U0 := constr:(Type) in + let U1 := constr:(Type) in + let unif := constr:(U0 : U1) in + exact ((forall (A : Type) (B : Type), IsEquiv (equiv_path (A : U0) (B : U0))) + -> forall (A : Type) (B : Type), @paths U1 A B -> @paths U0 A B). +Defined. + +Definition lift_id : lift_id_type := + fun A B p => match p in @paths _ _ B return @paths Type (A : Type) (B : Type) with + | idpath => idpath + end. + +Definition lower_id : lower_id_type. +Proof. + intros ua A B p. + specialize (ua A B). + apply (@equiv_inv _ _ (equiv_path A B) _). + simpl. + pose (f := transport idmap p : A -> B). + pose (g := transport idmap p^ : B -> A). + refine (@equiv_adjointify + _ _ + f g + _ _); + subst f g; unfold transport, inverse; + clear ua; + [ intro x + | exact match p as p in (_ = B) return + (forall x : (A : Type), + @paths (* Top.904 *) + A + match + match + p in (paths _ a) + return (@paths (* Top.906 *) Type (* Top.900 *) a A) + with + | idpath => @idpath (* Top.906 *) Type (* Top.900 *) A + end in (paths _ a) return a + with + | idpath => match p in (paths _ a) return a with + | idpath => x + end + end x) + with + | idpath => fun _ => idpath + end ]. + + - pose proof (match p as p in (_ = B) return + (forall x : (B : Type), + match p in (_ = a) return (a : Type) with + | idpath => + match + match p in (_ = a) return (@paths Type (a : Type) (A : Type)) with + | idpath => idpath + end in (_ = a) return (a : Type) + with + | idpath => x + end + end = x) + with + | idpath => fun _ => idpath + end x) as p'. + admit. +Defined. +(* Error: Illegal application: +The term "paths (* Top.96 *)" of type + "forall A : Type (* Top.96 *), A -> A -> Type (* Top.96 *)" +cannot be applied to the terms + "Type (* Top.100 *)" : "Type (* Top.100+1 *)" + "a" : "Type (* Top.60 *)" + "A" : "Type (* Top.57 *)" +The 2nd term has type "Type (* Top.60 *)" which should be coercible to + "Type (* Top.100 *)". + *) diff --git a/test-suite/bugs/closed/HoTT_coq_091.v b/test-suite/bugs/closed/HoTT_coq_091.v new file mode 100644 index 00000000..1e4497e7 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_091.v @@ -0,0 +1,191 @@ +Set Implicit Arguments. + +Set Printing Universes. + +Set Asymmetric Patterns. + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Arguments idpath {A a} , [A] a. + +Arguments paths_ind [A] a P f y p. +Arguments paths_rec [A] a P f y p. +Arguments paths_rect [A] a P f y p. + +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. + +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. + +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. +Arguments ap {A B} f {x y} p : simpl nomatch. + +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := + forall x : A, r (s x) = x. + +(** A typeclass that includes the data making [f] into an adjoint equivalence. *) +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { + equiv_inv : B -> A ; + eisretr : Sect equiv_inv f; + eissect : Sect f equiv_inv; + eisadj : forall x : A, eisretr (f x) = ap f (eissect x) +}. + +Arguments eisretr {A B} f {_} _. +Arguments eissect {A B} f {_} _. +Arguments eisadj {A B} f {_} _. + + +Inductive type_eq (A : Type) : Type -> Type := +| type_eq_refl : type_eq A A +| type_eq_impossible : False -> forall B : Type, type_eq A B. + +Definition type_eq_sym {A B} (p : type_eq A B) : type_eq B A + := match p in (type_eq _ B) return (type_eq B A) with + | type_eq_refl => type_eq_refl _ + | type_eq_impossible f B => type_eq_impossible _ f A + end. + +Definition type_eq_sym_type_eq_sym {A B} (p : type_eq A B) : type_eq_sym (type_eq_sym p) = p + := match p as p return type_eq_sym (type_eq_sym p) = p with + | type_eq_refl => idpath + | type_eq_impossible f _ => idpath + end. + +Module Type LiftT. + Section local. + Let type_cast_up_type : Type. + Proof. + let U0 := constr:(Type) in + let U1 := constr:(Type) in + let unif := constr:(U0 : U1) in + exact (forall T : U0, { T' : U1 & type_eq T' T }). + Defined. + + Axiom type_cast_up : type_cast_up_type. + End local. + + Definition Lift (T : Type) := projT1 (type_cast_up T). + Definition lift {T} : T -> Lift T + := match projT2 (type_cast_up T) in (type_eq _ T') return T' -> Lift T with + | type_eq_refl => fun x => x + | type_eq_impossible bad _ => match bad with end + end. + Section equiv. + Definition lower' {T} : Lift T -> T + := match projT2 (type_cast_up T) in (type_eq _ T') return Lift T -> T' with + | type_eq_refl => fun x => x + | type_eq_impossible bad _ => match bad with end + end. + Definition lift_lower {T} (x : Lift T) : lift (lower' x) = x. + Proof. + unfold lower', lift. + destruct (projT2 (type_cast_up T)) as [|[]]. + reflexivity. + Defined. + Definition lower_lift {T} (x : T) : lower' (lift x) = x. + Proof. + unfold lower', lift, Lift in *. + destruct (type_cast_up T) as [T' p]; simpl. + let y := match goal with |- ?y => constr:(y) end in + let P := match (eval pattern p in y) with ?f p => constr:(f) end in + apply (@transport _ P _ _ (type_eq_sym_type_eq_sym p)); simpl in *. + generalize (type_eq_sym p); intro p'; clear p. + destruct p' as [|[]]; simpl. + reflexivity. + Defined. + + Global Instance isequiv_lift A : IsEquiv (@lift A). + Proof. + refine (@BuildIsEquiv + _ _ + lift lower' + lift_lower + lower_lift + _). + compute. + intro x. + destruct (type_cast_up A) as [T' p]. + let y := match goal with |- ?y => constr:(y) end in + let P := match (eval pattern p in y) with ?f p => constr:(f) end in + apply (@transport _ P _ _ (type_eq_sym_type_eq_sym p)); simpl in *. + generalize (type_eq_sym p); intro p'; clear p. + destruct p' as [|[]]; simpl. + reflexivity. + Defined. + End equiv. + Definition lower {A} := (@equiv_inv _ _ (@lift A) _). +End LiftT. + +Module Lift : LiftT. + Section local. + Let type_cast_up_type : Type. + Proof. + let U0 := constr:(Type) in + let U1 := constr:(Type) in + let unif := constr:(U0 : U1) in + exact (forall T : U0, { T' : U1 & type_eq T' T }). + Defined. + + Definition type_cast_up : type_cast_up_type + := fun T => existT (fun T' => type_eq T' T) T (type_eq_refl _). + End local. + + Definition Lift (T : Type) := projT1 (type_cast_up T). + Definition lift {T} : T -> Lift T + := match projT2 (type_cast_up T) in (type_eq _ T') return T' -> Lift T with + | type_eq_refl => fun x => x + | type_eq_impossible bad _ => match bad with end + end. + Section equiv. + Definition lower' {T} : Lift T -> T + := match projT2 (type_cast_up T) in (type_eq _ T') return Lift T -> T' with + | type_eq_refl => fun x => x + | type_eq_impossible bad _ => match bad with end + end. + Definition lift_lower {T} (x : Lift T) : lift (lower' x) = x. + Proof. + unfold lower', lift. + destruct (projT2 (type_cast_up T)) as [|[]]. + reflexivity. + Defined. + Definition lower_lift {T} (x : T) : lower' (lift x) = x. + Proof. + unfold lower', lift, Lift in *. + destruct (type_cast_up T) as [T' p]; simpl. + let y := match goal with |- ?y => constr:(y) end in + let P := match (eval pattern p in y) with ?f p => constr:(f) end in + apply (@transport _ P _ _ (type_eq_sym_type_eq_sym p)); simpl in *. + generalize (type_eq_sym p); intro p'; clear p. + destruct p' as [|[]]; simpl. + reflexivity. + Defined. + + + Global Instance isequiv_lift A : IsEquiv (@lift A). + Proof. + refine (@BuildIsEquiv + _ _ + lift lower' + lift_lower + lower_lift + _). + compute. + intro x. + destruct (type_cast_up A) as [T' p]. + let y := match goal with |- ?y => constr:(y) end in + let P := match (eval pattern p in y) with ?f p => constr:(f) end in + apply (@transport _ P _ _ (type_eq_sym_type_eq_sym p)); simpl in *. + generalize (type_eq_sym p); intro p'; clear p. + destruct p' as [|[]]; simpl. + reflexivity. + Defined. + End equiv. + Definition lower {A} := (@equiv_inv _ _ (@lift A) _). +End Lift. +(* Toplevel input, characters 15-24: +Anomaly: Invalid argument: enforce_eq_instances called with instances of different lengths. +Please report. *) diff --git a/test-suite/bugs/closed/HoTT_coq_093.v b/test-suite/bugs/closed/HoTT_coq_093.v new file mode 100644 index 00000000..38943ab3 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_093.v @@ -0,0 +1,27 @@ +(** It would be nice if we had more lax constraint checking of inductive types, and had variance annotations on their universes *) +Set Printing All. +Set Printing Implicit. +Set Printing Universes. +Set Universe Polymorphism. + +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a. +Arguments idpath {A a} , [A] a. + +Notation "x = y" := (@paths _ x y) : type_scope. + +Section lift. + Let lift_type : Type. + Proof. + let U0 := constr:(Type) in + let U1 := constr:(Type) in + let unif := constr:(U0 : U1) in + exact (U0 -> U1). + Defined. + + Definition Lift (A : Type@{i}) : Type@{j} := A. +End lift. + +Goal forall (A : Type@{i}) (x y : A), @paths@{i} A x y -> @paths@{j} A x y. +intros A x y p. +compute in *. destruct p. exact idpath. +Defined. diff --git a/test-suite/bugs/closed/HoTT_coq_094.v b/test-suite/bugs/closed/HoTT_coq_094.v new file mode 100644 index 00000000..13e0605d --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_094.v @@ -0,0 +1,9 @@ +Record PreCategory := Build_PreCategory' { object :> Type }. +Class Foo (X : Type) := {}. +Class Bar := {}. +Definition functor_category `{Bar} (C D : PreCategory) `{Foo (object D)} : PreCategory. +Admitted. +Fail Definition functor_object_of `{Bar} (C1 C2 D : PreCategory) `{Foo (object D)} +: functor_category C1 (functor_category C2 D) -> True. +(** Anomaly: File "toplevel/himsg.ml", line ..., characters ...: Assertion failed. +Please report. *) diff --git a/test-suite/bugs/closed/HoTT_coq_097.v b/test-suite/bugs/closed/HoTT_coq_097.v new file mode 100644 index 00000000..38e8007b --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_097.v @@ -0,0 +1,5 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) +Set Universe Polymorphism. +Set Printing Universes. +Inductive Empty : Set := . +(* Error: Universe inconsistency. Cannot enforce Prop <= Set). *) diff --git a/test-suite/bugs/closed/HoTT_coq_098.v b/test-suite/bugs/closed/HoTT_coq_098.v new file mode 100644 index 00000000..fc99daab --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_098.v @@ -0,0 +1,63 @@ +Set Implicit Arguments. +Generalizable All Variables. + +Polymorphic Record SpecializedCategory (obj : Type) := Build_SpecializedCategory' { + Object :> _ := obj; + Morphism' : obj -> obj -> Type; + + Identity' : forall o, Morphism' o o; + Compose' : forall s d d', Morphism' d d' -> Morphism' s d -> Morphism' s d' +}. + +Polymorphic Definition TypeCat : @SpecializedCategory Type + := (@Build_SpecializedCategory' Type + (fun s d => s -> d) + (fun _ => (fun x => x)) + (fun _ _ _ f g => (fun x => f (g x)))). + +Inductive GraphIndex := GraphIndexSource | GraphIndexTarget. +Polymorphic Definition GraphIndexingCategory : @SpecializedCategory GraphIndex. +Admitted. + +Module success. + Section SpecializedFunctor. + Set Universe Polymorphism. + Context `(C : @SpecializedCategory objC). + Context `(D : @SpecializedCategory objD). + Unset Universe Polymorphism. + + Polymorphic Record SpecializedFunctor + := { + ObjectOf' : objC -> objD; + MorphismOf' : forall s d, C.(Morphism') s d -> D.(Morphism') (ObjectOf' s) (ObjectOf' d) + }. + End SpecializedFunctor. + + Polymorphic Definition UnderlyingGraph : SpecializedFunctor GraphIndexingCategory TypeCat. + Admitted. +End success. + +Module success2. + Section SpecializedFunctor. + Polymorphic Context `(C : @SpecializedCategory objC). + Polymorphic Context `(D : @SpecializedCategory objD). + + Polymorphic Record SpecializedFunctor + := { + ObjectOf' : objC -> objD; + MorphismOf' : forall s d, C.(Morphism') s d -> D.(Morphism') (ObjectOf' s) (ObjectOf' d) + }. + End SpecializedFunctor. + + Set Printing Universes. + Polymorphic Definition UnderlyingGraph : SpecializedFunctor GraphIndexingCategory TypeCat. + (* Toplevel input, characters 73-94: +Error: +The term "GraphIndexingCategory (* Top.563 *)" has type + "SpecializedCategory (* Top.563 Set *) GraphIndex" +while it is expected to have type + "SpecializedCategory (* Top.550 Top.551 *) ?7" +(Universe inconsistency: Cannot enforce Set = Top.551)). *) + admit. + Defined. +End success2. diff --git a/test-suite/bugs/closed/HoTT_coq_099.v b/test-suite/bugs/closed/HoTT_coq_099.v new file mode 100644 index 00000000..9b6ace82 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_099.v @@ -0,0 +1,61 @@ +(* File reduced by coq-bug-finder from 138 lines to 78 lines. *) +Set Implicit Arguments. +Generalizable All Variables. +Set Universe Polymorphism. +Delimit Scope object_scope with object. +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Record Category (obj : Type) := + { + Object :> _ := obj; + Morphism : obj -> obj -> Type; + + Identity : forall x, Morphism x x; + Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' + }. + +Arguments Identity {obj%type} [!C%category] x%object : rename. +Arguments Compose {obj%type} [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename. +Bind Scope category_scope with Category. + +Record Functor `(C : @Category objC) `(D : @Category objD) + := { ObjectOf :> objC -> objD; + MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d) }. + +Record NaturalTransformation `(C : @Category objC) `(D : @Category objD) (F G : Functor C D) + := { ComponentsOf :> forall c, D.(Morphism) (F c) (G c) }. + +Definition ProductCategory `(C : @Category objC) `(D : @Category objD) +: @Category (objC * objD)%type + := @Build_Category _ + (fun s d => (C.(Morphism) (fst s) (fst d) * D.(Morphism) (snd s) (snd d))%type) + (fun o => (Identity (fst o), Identity (snd o))) + (fun s d d' m2 m1 => (Compose (fst m2) (fst m1), Compose (snd m2) (snd m1))). + +Infix "*" := ProductCategory : category_scope. + +Record IsomorphismOf `{C : @Category objC} {s d} (m : C.(Morphism) s d) := + { IsomorphismOf_Morphism :> C.(Morphism) s d := m; + Inverse : C.(Morphism) d s }. + +Record NaturalIsomorphism `(C : @Category objC) `(D : @Category objD) (F G : Functor C D) + := { NaturalIsomorphism_Transformation :> NaturalTransformation F G; + NaturalIsomorphism_Isomorphism : forall x : objC, IsomorphismOf (NaturalIsomorphism_Transformation x) }. + +Section PreMonoidalCategory. + Context `(C : @Category objC). + Definition TriMonoidalProductL : Functor (C * C * C) C. + admit. + Defined. + Definition TriMonoidalProductR : Functor (C * C * C) C. + admit. + Defined. (** Replacing [admit. Defined.] with [Admitted.] satisfies the constraints *) + Variable Associator : NaturalIsomorphism TriMonoidalProductL TriMonoidalProductR. + (* Toplevel input, characters 15-96: +Error: Unsatisfied constraints: +Coq.Init.Datatypes.28 <= Coq.Init.Datatypes.29 +Top.168 <= Coq.Init.Datatypes.29 +Top.168 <= Coq.Init.Datatypes.28 +Top.169 <= Coq.Init.Datatypes.29 +Top.169 <= Coq.Init.Datatypes.28 + (maybe a bugged tactic). *) diff --git a/test-suite/bugs/closed/HoTT_coq_100.v b/test-suite/bugs/closed/HoTT_coq_100.v new file mode 100644 index 00000000..c39b7093 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_100.v @@ -0,0 +1,151 @@ +(* File reduced by coq-bug-finder from 335 lines to 115 lines. *) +Set Implicit Arguments. +Set Universe Polymorphism. +Generalizable All Variables. +Record Category (obj : Type) := + Build_Category { + Object :> _ := obj; + Morphism : obj -> obj -> Type; + + Identity : forall x, Morphism x x; + Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' + }. + +Arguments Identity {obj%type} [!C] x : rename. + +Arguments Compose {obj%type} [!C s d d'] m1 m2 : rename. +Record > Category' := + { + LSObject : Type; + + LSUnderlyingCategory :> @Category LSObject + }. + +Section Functor. + + Context `(C : @Category objC). + Context `(D : @Category objD). + Record Functor := + { + ObjectOf :> objC -> objD; + MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d) + }. + +End Functor. +Section FunctorComposition. + + Context `(C : @Category objC). + Context `(D : @Category objD). + Context `(E : @Category objE). + Definition ComposeFunctors (G : Functor D E) (F : Functor C D) : Functor C E. + + Admitted. +End FunctorComposition. +Section IdentityFunctor. + + Context `(C : @Category objC). + Definition IdentityFunctor : Functor C C. + + admit. + Defined. +End IdentityFunctor. +Section ProductCategory. + + Context `(C : @Category objC). + Context `(D : @Category objD). + Definition ProductCategory : @Category (objC * objD)%type. + + refine (@Build_Category _ + (fun s d => (C.(Morphism) (fst s) (fst d) * D.(Morphism) (snd s) (snd d))%type) + (fun o => (Identity (fst o), Identity (snd o))) + (fun s d d' m2 m1 => (Compose (fst m2) (fst m1), Compose (snd m2) (snd m1)))). + Defined. +End ProductCategory. +Parameter TerminalCategory : Category unit. + +Section ComputableCategory. + + Variable I : Type. + Variable Index2Object : I -> Type. + Variable Index2Cat : forall i : I, @Category (@Index2Object i). + Local Coercion Index2Cat : I >-> Category. + + Definition ComputableCategory : @Category I. + + refine (@Build_Category _ + (fun C D : I => Functor C D) + (fun o : I => IdentityFunctor o) + (fun C D E : I => ComposeFunctors (C := C) (D := D) (E := E))). + Defined. +End ComputableCategory. +Definition LocallySmallCat := ComputableCategory _ LSUnderlyingCategory. +Section CommaCategory. + + Context `(A : @Category objA). + Context `(B : @Category objB). + Context `(C : @Category objC). + Variable S : Functor A C. + Variable T : Functor B C. + Record CommaCategory_Object := { CommaCategory_Object_Member :> { ab : objA * objB & C.(Morphism) (S (fst ab)) (T (snd ab)) } }. + +End CommaCategory. +Definition SliceCategory_Functor `(C : @Category objC) (a : C) : Functor TerminalCategory C + := {| ObjectOf := (fun _ => a); + MorphismOf := (fun _ _ _ => Identity a) + |}. + +Definition SliceCategoryOver +: forall (objC : Type) (C : Category objC) (a : C), + Category + (CommaCategory_Object (IdentityFunctor C) + (SliceCategory_Functor C a)). + + admit. +Defined. +Section CommaCategoryProjectionFunctor. + + Context `(A : Category objA). + Context `(B : Category objB). + Let X : LocallySmallCat. + + Proof. + hnf. + pose (@SliceCategoryOver _ LocallySmallCat). + exact (ProductCategory A B). + Set Printing Universes. + Defined. +(* Error: Illegal application: +The term + "CommaCategory_Object (* Top.306 Top.307 Top.305 Top.300 Top.305 Top.306 *)" +of type + "forall (objA : Type (* Top.305 *)) + (A : Category (* Top.306 Top.305 *) objA) (objB : Type (* Top.307 *)) + (B : Category (* Top.300 Top.307 *) objB) (objC : Type (* Top.305 *)) + (C : Category (* Top.306 Top.305 *) objC), + Functor (* Top.306 Top.305 Top.305 Top.306 *) A C -> + Functor (* Top.300 Top.307 Top.305 Top.306 *) B C -> + Type (* max(Top.307, Top.305, Top.306) *)" +cannot be applied to the terms + "Category' (* Top.312 Top.311 *)" : "Type (* max(Top.311+1, Top.312+1) *)" + "LocallySmallCat (* Top.309 Top.310 Top.311 Top.312 Top.313 Top.314 Top.306 Top.316 Top.305 *)" + : "Category (* Top.306 Top.305 *) Category' (* Top.312 Top.311 *)" + "unit" : "Set" + "TerminalCategory (* Top.300 *)" : "Category (* Top.300 Set *) unit" + "Category' (* Top.312 Top.311 *)" : "Type (* max(Top.311+1, Top.312+1) *)" + "LocallySmallCat (* Top.309 Top.310 Top.311 Top.312 Top.313 Top.314 Top.306 Top.316 Top.305 *)" + : "Category (* Top.306 Top.305 *) Category' (* Top.312 Top.311 *)" + "IdentityFunctor (* Top.299 Top.302 Top.301 Top.305 Top.306 *) + LocallySmallCat (* Top.309 Top.310 Top.311 Top.312 Top.313 Top.314 + Top.306 Top.316 Top.305 *)" + : "Functor (* Top.306 Top.305 Top.305 Top.306 *) LocallySmallCat + (* Top.309 Top.310 Top.311 Top.312 Top.313 Top.314 Top.306 Top.316 + Top.305 *) LocallySmallCat (* Top.309 Top.310 Top.311 Top.312 Top.313 + Top.314 Top.306 Top.316 Top.305 *)" + "SliceCategory_Functor (* Top.305 Top.306 Top.307 Top.300 *) LocallySmallCat + (* Top.309 Top.310 Top.311 Top.312 Top.313 Top.314 Top.306 Top.316 + Top.305 *) a" + : "Functor (* Top.300 Top.307 Top.305 Top.306 *) TerminalCategory + (* Top.300 *) LocallySmallCat (* Top.309 Top.310 Top.311 Top.312 + Top.313 Top.314 Top.306 Top.316 Top.305 *)" +The 4th term has type "Category (* Top.300 Set *) unit" +which should be coercible to "Category (* Top.300 Top.307 *) unit". *) diff --git a/test-suite/bugs/closed/HoTT_coq_101.v b/test-suite/bugs/closed/HoTT_coq_101.v new file mode 100644 index 00000000..9c89a6ab --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_101.v @@ -0,0 +1,77 @@ +Set Universe Polymorphism. +Set Implicit Arguments. +Generalizable All Variables. + +Record SpecializedCategory (obj : Type) := + { + Object :> _ := obj; + Morphism : obj -> obj -> Type + }. + + +Record > Category := + { + CObject : Type; + + UnderlyingCategory :> @SpecializedCategory CObject + }. + +Record SpecializedFunctor `(C : @SpecializedCategory objC) `(D : @SpecializedCategory objD) := + { + ObjectOf :> objC -> objD; + MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d) + }. + +(* Replacing this with [Definition Functor (C D : Category) := +SpecializedFunctor C D.] gets rid of the universe inconsistency. *) +Section Functor. + Variable C D : Category. + + Definition Functor := SpecializedFunctor C D. +End Functor. + +Record SpecializedNaturalTransformation `(C : @SpecializedCategory objC) `(D : @SpecializedCategory objD) (F G : SpecializedFunctor C D) := + { + ComponentsOf :> forall c, D.(Morphism) (F c) (G c) + }. + +Definition FunctorProduct' `(F : Functor C D) : SpecializedFunctor C D. +admit. +Defined. + +Definition TypeCat : @SpecializedCategory Type. + admit. +Defined. + + +Definition CovariantHomFunctor `(C : @SpecializedCategory objC) : SpecializedFunctor C TypeCat. + refine (Build_SpecializedFunctor C TypeCat + (fun X : C => C.(Morphism) X X) + _ + ); admit. +Defined. + +Definition FunctorCategory `(C : @SpecializedCategory objC) `(D : @SpecializedCategory objD) : @SpecializedCategory (SpecializedFunctor C D). + refine (@Build_SpecializedCategory _ + (SpecializedNaturalTransformation (C := C) (D := D))). +Defined. + +Definition Yoneda `(C : @SpecializedCategory objC) : SpecializedFunctor C (FunctorCategory C TypeCat). + match goal with + | [ |- SpecializedFunctor ?C0 ?D0 ] => + refine (Build_SpecializedFunctor C0 D0 + (fun c => CovariantHomFunctor C) + _ + ) + end; + admit. +Defined. + +Section FullyFaithful. + Context `(C : @SpecializedCategory objC). + Let TypeCatC := FunctorCategory C TypeCat. + Let YC := (Yoneda C). + Set Printing Universes. + Check @FunctorProduct' C TypeCatC YC. (* Toplevel input, characters 0-37: +Error: Universe inconsistency. Cannot enforce Top.187 = Top.186 because +Top.186 <= Top.189 < Top.191 <= Top.187). *) diff --git a/test-suite/bugs/closed/HoTT_coq_102.v b/test-suite/bugs/closed/HoTT_coq_102.v new file mode 100644 index 00000000..71becfd2 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_102.v @@ -0,0 +1,29 @@ +(* File reduced by coq-bug-finder from 64 lines to 30 lines. *) +Set Implicit Arguments. +Set Universe Polymorphism. +Generalizable All Variables. +Record SpecializedCategory (obj : Type) := { Object :> _ := obj }. + +Record > Category := + { CObject : Type; + UnderlyingCategory :> @SpecializedCategory CObject }. + +Record SpecializedFunctor `(C : @SpecializedCategory objC) `(D : @SpecializedCategory objD) := + { ObjectOf :> objC -> objD }. + +Definition Functor (C D : Category) := SpecializedFunctor C D. + +Parameter TerminalCategory : SpecializedCategory unit. + +Definition focus A (_ : A) := True. + +Definition CommaCategory_Object (A : Category) (S : Functor TerminalCategory A) : Type. + assert (Hf : focus ((S tt) = (S tt))) by constructor. + let C1 := constr:(CObject) in + let C2 := constr:(fun C => @Object (CObject C) C) in + let check := constr:(eq_refl : C1 = C2) in + unify C1 C2. + progress change CObject with (fun C => @Object (CObject C) C) in *. + (* not convertible *) + admit. +Defined. diff --git a/test-suite/bugs/closed/HoTT_coq_103.v b/test-suite/bugs/closed/HoTT_coq_103.v new file mode 100644 index 00000000..7ecf7671 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_103.v @@ -0,0 +1,4 @@ +Fail Check (nat : Type) : Set. +(* Error: +The term "nat:Type" has type "Type" while it is expected to have type +"Set" (Universe inconsistency). *) diff --git a/test-suite/bugs/closed/HoTT_coq_104.v b/test-suite/bugs/closed/HoTT_coq_104.v new file mode 100644 index 00000000..5bb7fa8c --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_104.v @@ -0,0 +1,13 @@ +Set Implicit Arguments. + +Require Import Logic. + +Global Set Universe Polymorphism. +Global Set Asymmetric Patterns. +Local Set Record Elimination Schemes. +Local Set Primitive Projections. + +Record prod (A B : Type) : Type := + pair { fst : A; snd : B }. + +Check fun x : prod Set Set => eq_refl : x = pair (fst x) (snd x). diff --git a/test-suite/bugs/closed/HoTT_coq_105.v b/test-suite/bugs/closed/HoTT_coq_105.v new file mode 100644 index 00000000..86001d26 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_105.v @@ -0,0 +1,32 @@ +Set Primitive Projections. +Set Implicit Arguments. +Set Universe Polymorphism. +Set Asymmetric Patterns. + +Inductive sum A B := inl : A -> sum A B | inr : B -> sum A B. +Inductive Empty :=. + +Record category := + { ob :> Type; + hom : ob -> ob -> Type + }. +Set Printing All. +Definition sum_category (C D : category) : category := + {| + ob := sum (ob C) (ob D); + hom x y := match x, y with + | inl x, inl y => @hom _ x y (* Toplevel input, characters 177-178: +Error: +In environment +C : category +D : category +x : sum (ob C) (ob D) +y : sum (ob C) (ob D) +x0 : ob C +y0 : ob C +The term "x0" has type "ob C" while it is expected to have type +"ob ?6" (unable to find a well-typed instantiation for +"?6": cannot unify"Type" and "category"). *) + | inr x, inr y => @hom _ x y + | _, _ => Empty + end |}. diff --git a/test-suite/bugs/closed/HoTT_coq_107.v b/test-suite/bugs/closed/HoTT_coq_107.v new file mode 100644 index 00000000..c3a83627 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_107.v @@ -0,0 +1,106 @@ +(* -*- mode: coq; coq-prog-args: ("-nois" "-emacs") -*- *) +(* File reduced by coq-bug-finder from 4897 lines to 2605 lines, then from 2297 lines to 236 lines, then from 239 lines to 137 lines, then from 118 lines to 67 lines, then from 520 lines to 76 lines. *) +(** Note: The bug here is the same as the #113, that is, HoTT_coq_113.v *) +Require Import Coq.Init.Logic. +Global Set Universe Polymorphism. +Global Set Asymmetric Patterns. +Set Implicit Arguments. + +Inductive sigT (A:Type) (P:A -> Type) : Type := + existT : forall x:A, P x -> sigT P. + +Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope. + +Generalizable All Variables. +Definition admit {T} : T. +Admitted. +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. +Class Contr_internal (A : Type) := + BuildContr { + center : A ; + contr : (forall y : A, center = y) + }. + +Arguments center A {_}. + +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. + +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | minus_two => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. + +Class IsTrunc (n : trunc_index) (A : Type) : Type := + Trunc_is_trunc : IsTrunc_internal n A. + +Notation Contr := (IsTrunc minus_two). + +Hint Extern 0 => progress change Contr_internal with Contr in * : typeclass_instances. + +Definition path_contr `{Contr A} (x y : A) : x = y + := admit. + +Definition path_sigma' {A : Type} (P : A -> Type) {x x' : A} {y : P x} {y' : P x'} + (p : x = x') (q : transport _ p y = y') +: existT _ x y = existT _ x' y' + := admit. +Instance trunc_sigma `{P : A -> Type} + `{IsTrunc n A} `{forall a, IsTrunc n (P a)} +: IsTrunc n (sigT P) | 100. + +Proof. + generalize dependent A. + induction n; [ | admit ]; simpl; intros A P ac Pc. + (exists (existT _ (center A) (center (P (center A))))). + intros [a ?]. + refine (path_sigma' P (contr a) (path_contr _ _)). +Defined. +Inductive Bool : Set := true | false. +Definition trunc_sum' n A B `{IsTrunc n Bool, IsTrunc n A, IsTrunc n B} +: (IsTrunc n { b : Bool & if b then A else B }). +Proof. + Set Printing All. + Set Printing Universes. + refine (@trunc_sigma Bool (fun b => if b then A else B) n _ _). + (* Toplevel input, characters 23-76: +Error: +In environment +n : trunc_index +A : Type (* Top.193 *) +B : Type (* Top.194 *) +H : IsTrunc (* Set *) n Bool +H0 : IsTrunc (* Top.193 *) n A +H1 : IsTrunc (* Top.194 *) n B +The term + "@trunc_sigma (* Top.198 Top.199 Top.200 Top.201 *) Bool + (fun b : Bool => + match b return Type (* Top.199 *) with + | true => A + | false => B + end) n ?49 ?50" has type + "IsTrunc (* Top.200 *) n + (@sig (* Top.199 Top.199 *) Bool + (fun b : Bool => + match b return Type (* Top.199 *) with + | true => A + | false => B + end))" while it is expected to have type + "IsTrunc (* Top.195 *) n + (@sig (* Set Top.197 *) Bool + (fun b : Bool => + match b return Type (* Top.197 *) with + | true => A + | false => B + end))" (Universe inconsistency: Cannot enforce Top.197 = Set)). + *) + admit. +Defined. diff --git a/test-suite/bugs/closed/HoTT_coq_108.v b/test-suite/bugs/closed/HoTT_coq_108.v new file mode 100644 index 00000000..cc304802 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_108.v @@ -0,0 +1,127 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) +(* NOTE: This bug is only triggered with -load-vernac-source / in interactive mode. *) +(* File reduced by coq-bug-finder from 139 lines to 124 lines. *) +Set Universe Polymorphism. +Reserved Notation "g 'o' f" (at level 40, left associativity). +Generalizable All Variables. +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. + +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. + +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. + +Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g) +: forall x, f x = g x + := fun x => match h with idpath => idpath end. + +Definition ap11 {A B} {f g:A->B} (h:f=g) {x y:A} (p:x=y) : f x = g y. + admit. +Defined. +Class IsEquiv {A B : Type} (f : A -> B) := {}. +Class Contr_internal (A : Type) := BuildContr { + center : A ; + contr : (forall y : A, center = y) + }. + +Arguments center A {_}. + +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. + +Fixpoint nat_to_trunc_index (n : nat) : trunc_index + := match n with + | 0 => trunc_S (trunc_S minus_two) + | S n' => trunc_S (nat_to_trunc_index n') + end. + +Coercion nat_to_trunc_index : nat >-> trunc_index. + +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | minus_two => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. +Class IsTrunc (n : trunc_index) (A : Type) : Type := + Trunc_is_trunc : IsTrunc_internal n A. + +Instance istrunc_paths (A : Type) n `{H : IsTrunc (trunc_S n) A} (x y : A) +: IsTrunc n (x = y) + := H x y. + +Notation Contr := (IsTrunc minus_two). + +Notation IsHSet := (IsTrunc 0). + +Class Funext := + { isequiv_apD10 :> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) }. +Global Instance contr_forall `{Funext} `{P : A -> Type} `{forall a, Contr (P a)} +: Contr (forall a, P a) | 100. +admit. +Defined. +Hint Extern 0 => progress change Contr_internal with Contr in * : typeclass_instances. +Global Instance trunc_forall `{Funext} `{P : A -> Type} `{forall a, IsTrunc n (P a)} +: IsTrunc n (forall a, P a) | 100. +Proof. + generalize dependent P. + induction n as [ | n' IH]; [ | admit ]; simpl; intros P ?. + exact _. +Defined. +Set Implicit Arguments. + +Record PreCategory := + { object :> Type; + morphism : object -> object -> Type; + identity : forall x, morphism x x; + compose : forall s d d', morphism d d' -> morphism s d -> morphism s d'; + trunc_morphism : forall s d, IsHSet (morphism s d) }. + +Existing Instance trunc_morphism. +Infix "o" := (@compose _ _ _ _) : morphism_scope. +Local Open Scope morphism_scope. + +Record Functor (C D : PreCategory) := + { object_of :> C -> D; + morphism_of : forall s d, morphism C s d + -> morphism D (object_of s) (object_of d); + composition_of : forall s d d' + (m1 : morphism C s d) (m2: morphism C d d'), + morphism_of _ _ (m2 o m1) + = (morphism_of _ _ m2) o (morphism_of _ _ m1); + identity_of : forall x, morphism_of _ _ (@identity _ x) + = @identity _ (object_of x) }. + +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := + forall x : A, r (s x) = x. + +Section path_functor. + Context `{Funext}. + Variable C : PreCategory. + Variable D : PreCategory. + Local Notation path_functor'_T F G + := { HO : object_of F = object_of G + | transport (fun GO => forall s d, morphism C s d -> morphism D (GO s) (GO d)) + HO + (morphism_of F) + = morphism_of G } + (only parsing). + Definition path_functor'_sig (F G : Functor C D) : path_functor'_T F G -> F = G. + Proof. + intros [H' H'']. + destruct F, G; simpl in *. + induction H'. (* while destruct H' works *) destruct H''. + apply ap11; [ apply ap | ]; + apply center; abstract exact _. + Set Printing Universes. + (* Fail Defined.*) + (* The command has indeed failed with message: +=> Error: path_functor'_sig_subproof already exists. *) + Defined. +(* Anomaly: Backtrack.backto 55: a state with no vcs_backup. Please report. *) +End path_functor. diff --git a/test-suite/bugs/closed/HoTT_coq_110.v b/test-suite/bugs/closed/HoTT_coq_110.v new file mode 100644 index 00000000..5ec40dbc --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_110.v @@ -0,0 +1,23 @@ +Module X. + Inductive paths A (x : A) : A -> Type := idpath : paths A x x. + Notation "x = y" := (@paths _ x y) : type_scope. + + Axioms A B : Type. + Axiom P : A = B. + Definition foo : A = B. + abstract (rewrite <- P; reflexivity). + (* Error: internal_paths_rew already exists. *) + Defined. (* Anomaly: Uncaught exception Not_found(_). Please report. *) +End X. + +Module Y. + Inductive paths A (x : A) : A -> Type := idpath : paths A x x. + Notation "x = y" := (@paths _ x y) : type_scope. + + Axioms A B : Type. + Axiom P : A = B. + Definition foo : (A = B) * (A = B). + split; abstract (rewrite <- P; reflexivity). + (* Error: internal_paths_rew already exists. *) + Defined. (* Anomaly: Uncaught exception Not_found(_). Please report. *) +End Y. diff --git a/test-suite/bugs/closed/HoTT_coq_111.v b/test-suite/bugs/closed/HoTT_coq_111.v new file mode 100644 index 00000000..3b43f31d --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_111.v @@ -0,0 +1,24 @@ + +Module X. + (*Set Universe Polymorphism.*) + Inductive paths A (x : A) : forall _ : A, Type := idpath : paths A x x. + Notation "x = y" := (@paths _ x y) (at level 70, no associativity) : type_scope. + + Axioms A B : Type. + Axiom P : A = B. + Definition foo : A = B. + abstract (rewrite <- P; reflexivity). + Defined. +End X. + +Module Y. + (*Set Universe Polymorphism.*) + Inductive paths A (x : A) : forall _ : A, Type := idpath : paths A x x. + Notation "x = y" := (@paths _ x y) (at level 70, no associativity) : type_scope. + + Axioms A B : Type. + Axiom P : A = B. + Definition foo : (A = B) * (A = B). + split; abstract (rewrite <- P; reflexivity). + Defined. +End Y. diff --git a/test-suite/bugs/closed/HoTT_coq_112.v b/test-suite/bugs/closed/HoTT_coq_112.v new file mode 100644 index 00000000..150f2ecc --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_112.v @@ -0,0 +1,75 @@ +(* File reduced by coq-bug-finder from 4464 lines to 4137 lines, then from 3683 lines to 118 lines, then from 124 lines to 75 lines. *) +Set Universe Polymorphism. +Definition admit {T} : T. +Admitted. +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. + +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. + +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. + +Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g) + : forall x, f x = g x + := fun x => match h with idpath => idpath end. + +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { + equiv_inv : B -> A ; + eisretr : forall x, f (equiv_inv x) = x +}. + +Arguments eisretr {A B} f {_} _. + +Record Equiv A B := BuildEquiv { + equiv_fun :> A -> B ; + equiv_isequiv :> IsEquiv equiv_fun +}. + +Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope. +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope. +Local Open Scope equiv_scope. + +Instance isequiv_path {A B : Type} (p : A = B) + : IsEquiv (transport (fun X:Type => X) p) | 0 + := admit. +Definition equiv_path (A B : Type) (p : A = B) : A <~> B + := BuildEquiv _ _ (transport (fun X:Type => X) p) _. + +Class Univalence := { + isequiv_equiv_path :> forall (A B : Type), IsEquiv (equiv_path A B) +}. + +Section Univalence. + Context `{Univalence}. + + Definition path_universe_uncurried {A B : Type} (f : A <~> B) : A = B + := (equiv_path A B)^-1 f. + + Definition path_universe {A B : Type} (f : A -> B) {feq : IsEquiv f} : (A = B) + := path_universe_uncurried (BuildEquiv _ _ f feq). + + Set Printing Universes. + Definition transport_path_universe {A B : Type} (f : A -> B) {feq : IsEquiv f} (z : A) + : transport (fun X:Type => X) (path_universe f) z = f z + := apD10 (ap (equiv_fun A B) (eisretr (equiv_path A B) (BuildEquiv _ _ f feq))) z. + (* Toplevel input, characters 0-231: +Error: Illegal application: +The term "isequiv_equiv_path (* Top.1003 Top.1003 Top.1001 Top.997 *)" +of type + "Univalence (* Top.1003 Top.1003 Top.1001 Top.997 *) -> + forall (A : Type (* Top.1003 *)) (B : Type (* Top.997 *)), + IsEquiv (* Top.1003 Top.1001 *) + (equiv_path (* Top.997 Top.1003 Top.1001 Top.1003 *) A B)" +cannot be applied to the terms + "H" : "Univalence (* Top.934 Top.935 Top.936 Top.937 *)" + "A" : "Type (* Top.996 *)" + "B" : "Type (* Top.997 *)" +The 1st term has type "Univalence (* Top.934 Top.935 Top.936 Top.937 *)" +which should be coercible to + "Univalence (* Top.1003 Top.1003 Top.1001 Top.997 *)". + *) diff --git a/test-suite/bugs/closed/HoTT_coq_113.v b/test-suite/bugs/closed/HoTT_coq_113.v new file mode 100644 index 00000000..3ef531bc --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_113.v @@ -0,0 +1,19 @@ +(* File reduced by coq-bug-finder from original input, then from 3329 lines to 153 lines, then from 118 lines to 49 lines, then from 55 lines to 38 lines, then from 46 lines to 16 lines *) + +Generalizable All Variables. +Set Universe Polymorphism. +Class Foo (A : Type) := {}. +Definition Baz := Foo. +Definition Bar {A B} `{Foo A, Foo B} : True. +Proof. + Set Printing Universes. + (* [change] should give fresh universes for each [Foo] *) + change Foo with Baz in *. + admit. +Defined. +Definition foo := @Bar nat. +Check @foo Set. +(* Toplevel input, characters 26-29: +Error: +The term "Set" has type "Type (* Set+1 *)" while it is expected to have type + "Set" (Universe inconsistency: Cannot enforce Set < Set because Set = Set)). *) diff --git a/test-suite/bugs/closed/HoTT_coq_114.v b/test-suite/bugs/closed/HoTT_coq_114.v new file mode 100644 index 00000000..34112833 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_114.v @@ -0,0 +1 @@ +Inductive test : $(let U := type of Type in exact U)$ := t. diff --git a/test-suite/bugs/closed/HoTT_coq_115.v b/test-suite/bugs/closed/HoTT_coq_115.v new file mode 100644 index 00000000..c1e133ee --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_115.v @@ -0,0 +1 @@ +Inductive T : let U := Type in U := t. (* Anomaly: not an arity. Please report. *) diff --git a/test-suite/bugs/closed/HoTT_coq_116.v b/test-suite/bugs/closed/HoTT_coq_116.v new file mode 100644 index 00000000..d408557d --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_116.v @@ -0,0 +1,13 @@ +Set Universe Polymorphism. +Section foo. + Let U := Type. + Let U' : Type. + Proof. + let U' := constr:(Type) in + let U_le_U' := constr:(fun x : U => (x : U')) in + exact U'. + Defined. + Inductive t : U' := . +End foo. +(* Toplevel input, characters 15-23: +Error: No such section variable or assumption: U'. *) diff --git a/test-suite/bugs/closed/HoTT_coq_117.v b/test-suite/bugs/closed/HoTT_coq_117.v new file mode 100644 index 00000000..5fbcfef4 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_117.v @@ -0,0 +1,25 @@ +(* File reduced by coq-bug-finder from original input, then from 1461 lines to 81 lines, then from 84 lines to 40 lines, then from 50 lines to 24 lines *) + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. +Class Contr_internal (A : Type) := BuildContr { + center : A ; + contr : (forall y : A, center = y) +}. +Class Funext := {}. + +Definition path_forall `{Funext} {A : Type} {P : A -> Type} (f g : forall x : A, P x) : + (forall x, f x = g x) -> f = g. + +Admitted. + +Inductive Empty : Set := . +Instance contr_from_Empty {_ : Funext} (A : Type) : + Contr_internal (Empty -> A) := + BuildContr _ + (Empty_rect (fun _ => A)) + (fun f => path_forall _ f (fun x => Empty_rect _ x)). +(* Toplevel input, characters 15-220: +Anomaly: unknown meta ?190. Please report. *) diff --git a/test-suite/bugs/closed/HoTT_coq_118.v b/test-suite/bugs/closed/HoTT_coq_118.v new file mode 100644 index 00000000..14ad0e49 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_118.v @@ -0,0 +1,35 @@ +(* File reduced by coq-bug-finder from original input, then from 5631 lines to 557 lines, then from 526 lines to 181 lines, then from 189 lines to 154 lines, then from 153 lines to 107 lines, then from 97 lines to 56 lines, then from 50 lines to 37 lines *) +Generalizable All Variables. +Set Universe Polymorphism. +Definition admit {T} : T. +Admitted. +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y" := (@paths _ x y) : type_scope. +Class Contr_internal (A : Type) := BuildContr { center : A }. +Arguments center A {_}. +Instance contr_paths_contr `{Contr_internal A} (x y : A) : Contr_internal (x = y) := admit. +Inductive Unit : Set := tt. +Instance contr_unit : Contr_internal Unit | 0 := admit. +Record PreCategory := { morphism : Type }. +Class IsIsomorphism {C : PreCategory} (m : morphism C) := { left_inverse : m = m }. +Definition indiscrete_category : PreCategory := @Build_PreCategory Unit. +Goal forall (X : Type) (_ : forall x y : X, Contr_internal (@paths X x y)) (s : X), + @IsIsomorphism indiscrete_category tt -> True. +Proof. + intros X H s [p]. + simpl in *. + assert (idpath = p). + clear. + assert (H : forall p : tt = tt, idpath = p) by (intro; exact (center _)). + clear H. + exact (center _). + (* Toplevel input, characters 15-32: +Error: +Unable to satisfy the following constraints: +In environment: +p : tt = tt + +?46 : "Contr_internal (idpath = p)" + *) diff --git a/test-suite/bugs/closed/HoTT_coq_121.v b/test-suite/bugs/closed/HoTT_coq_121.v new file mode 100644 index 00000000..cce288cf --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_121.v @@ -0,0 +1,18 @@ +(* File reduced by coq-bug-finder from original input, then from 8249 lines to 907 lines, then from 843 lines to 357 lines, then from 351 lines to 260 lines, then from 208 lines to 162 lines, then from 167 lines to 154 lines, then from 146 lines to 72 lines, then from 82 lines to 70 lines, then from 79 lines to 49 lines, then from 59 lines to 16 lines *) + +Set Universe Polymorphism. +Generalizable All Variables. +Record hSet := BuildhSet {setT:> Type}. +Axiom minus1Trunc : Type -> Type. +Definition hexists {X} (P:X->Type):Type:= minus1Trunc (sigT P). +Definition issurj {X Y} (f:X->Y) := forall y:Y, hexists (fun x => (f x) = y). +Lemma isepi_issurj {X Y} (f:X->Y): issurj f. +Proof. + intros y. + admit. +Defined. (* Toplevel input, characters 15-23: +Error: Unsatisfied constraints: +Top.38 <= Coq.Init.Specif.7 +Top.43 <= Top.38 +Top.43 <= Coq.Init.Specif.8 + (maybe a bugged tactic). *) diff --git a/test-suite/bugs/closed/HoTT_coq_122.v b/test-suite/bugs/closed/HoTT_coq_122.v new file mode 100644 index 00000000..1ba8e5c3 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_122.v @@ -0,0 +1,25 @@ +(* File reduced by coq-bug-finder from original input, then from 669 lines to 79 lines, then from 89 lines to 44 lines *) +Set Primitive Projections. +Reserved Notation "g 'o' f" (at level 40, left associativity). +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Notation "x = y" := (@paths _ x y) : type_scope. + +Set Implicit Arguments. + +Record PreCategory := + Build_PreCategory' { + object :> Type; + morphism : object -> object -> Type; + + identity : forall x, morphism x x; + compose : forall s d d', + morphism d d' + -> morphism s d + -> morphism s d' + where "f 'o' g" := (compose f g); + + left_identity : forall a b (f : morphism a b), identity b o f = f + }. + +Hint Rewrite @left_identity. (* stack overflow *) diff --git a/test-suite/bugs/closed/HoTT_coq_123.v b/test-suite/bugs/closed/HoTT_coq_123.v new file mode 100644 index 00000000..994dff63 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_123.v @@ -0,0 +1,171 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") *) +(* File reduced by coq-bug-finder from original input, then from 4988 lines to 856 lines, then from 648 lines to 398 lines, then from 401 lines to 332 lines, then from 287 lines to 250 lines, then from 257 lines to 241 lines, then from 223 lines to 175 lines *) +Set Universe Polymorphism. +Set Asymmetric Patterns. +Reserved Notation "g 'o' f" (at level 40, left associativity). +Generalizable All Variables. +Definition admit {T} : T. +Admitted. +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y" := (@paths _ x y) : type_scope. +Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) : Type + := forall x:A, f x = g x. +Hint Unfold pointwise_paths : typeclass_instances. +Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope. +Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g) +: forall x, f x = g x + := fun x => match h with idpath => idpath end. + +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { equiv_inv : B -> A }. + +Record Equiv A B := BuildEquiv { equiv_fun :> A -> B ; equiv_isequiv :> IsEquiv equiv_fun }. +Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope. + +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope. +Class Contr_internal (A : Type) := {}. +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. + +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | minus_two => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. + +Class IsTrunc (n : trunc_index) (A : Type) : Type := + Trunc_is_trunc : IsTrunc_internal n A. + +Instance istrunc_paths (A : Type) n `{H : IsTrunc (trunc_S n) A} (x y : A) +: IsTrunc n (x = y) + := H x y. + +Notation IsHSet := (IsTrunc minus_two). + +Class Funext := + { isequiv_apD10 :> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) }. + +Local Open Scope equiv_scope. + +Global Instance isequiv_inverse `{IsEquiv A B f} : IsEquiv f^-1 | 10000 + := BuildIsEquiv B A f^-1 f. +Instance trunc_succ `{IsTrunc n A} : IsTrunc (trunc_S n) A | 1000. + +admit. + +Defined. +Definition trunc_equiv `(f : A -> B) + `{IsTrunc n A} `{IsEquiv A B f} +: IsTrunc n B. + admit. +Defined. +Definition trunc_equiv' `(f : A <~> B) `{IsTrunc n A} +: IsTrunc n B + := admit. +Set Implicit Arguments. +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope object_scope with object. +Record PreCategory := + Build_PreCategory { + object :> Type; + morphism : object -> object -> Type; + + identity : forall x, morphism x x; + compose : forall s d d', + morphism d d' + -> morphism s d + -> morphism s d' + where "f 'o' g" := (compose f g); + + associativity : forall x1 x2 x3 x4 + (m1 : morphism x1 x2) + (m2 : morphism x2 x3) + (m3 : morphism x3 x4), + (m3 o m2) o m1 = m3 o (m2 o m1); + + left_identity : forall a b (f : morphism a b), identity b o f = f; + right_identity : forall a b (f : morphism a b), f o identity a = f; + + trunc_morphism : forall s d, IsHSet (morphism s d) + }. +Existing Instance trunc_morphism. + +Infix "o" := (@compose _ _ _ _) : morphism_scope. +Delimit Scope functor_scope with functor. + +Local Open Scope morphism_scope. +Record Functor (C D : PreCategory) := + { + object_of :> C -> D; + morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d) + }. + +Global Instance trunc_forall `{Funext} `{P : A -> Type} `{forall a, IsTrunc n (P a)} +: IsTrunc n (forall a, P a) | 100. +Proof. + generalize dependent P. + induction n as [ | n' IH]; (simpl; intros P ?). + - admit. + - pose (fun f g => trunc_equiv (@apD10 A P f g) ^-1); admit. +Defined. +Instance trunc_sigma `{P : A -> Type} + `{IsTrunc n A} `{forall a, IsTrunc n (P a)} +: IsTrunc n (sigT P) | 100. +admit. +Defined. +Record NaturalTransformation C D (F G : Functor C D) := + Build_NaturalTransformation' { + components_of :> forall c, morphism D (F c) (G c) + }. +Section path_natural_transformation. + Context `{Funext}. + Variable C : PreCategory. + Variable D : PreCategory. + Variables F G : Functor C D. + Lemma equiv_sig_natural_transformation + : { CO : forall x, morphism D (F x) (G x) + & forall s d (m : morphism C s d), + CO d o morphism_of F _ _ m = morphism_of G _ _ m o CO s } + <~> NaturalTransformation F G. + + admit. + Defined. + Global Instance trunc_natural_transformation + : IsHSet (NaturalTransformation F G). + Proof. + eapply trunc_equiv'; [ exact equiv_sig_natural_transformation | ]. + typeclasses eauto. + Qed. + Lemma path_natural_transformation (T U : NaturalTransformation F G) + : components_of T == components_of U + -> T = U. + admit. + Defined. +End path_natural_transformation. +Ltac path_natural_transformation := + repeat match goal with + | _ => intro + | _ => apply path_natural_transformation; simpl + end. + +Section FunctorSectionCategory. + Context `{Funext}. + Variable C : PreCategory. + Variable D : PreCategory. + + Definition category_of_sections : PreCategory. + Proof. + refine (@Build_PreCategory + (Functor D C) + (fun F G => NaturalTransformation F G) + admit + admit + _ + _ + _ + _); + abstract (path_natural_transformation; admit). + Defined. (* Stack overflow *) diff --git a/test-suite/bugs/closed/HoTT_coq_124.v b/test-suite/bugs/closed/HoTT_coq_124.v new file mode 100644 index 00000000..e6e90ada --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_124.v @@ -0,0 +1,29 @@ +Set Implicit Arguments. +Set Primitive Projections. + +Polymorphic Inductive eqp A (x : A) : A -> Type := eqp_refl : eqp x x. +Monomorphic Inductive eqm A (x : A) : A -> Type := eqm_refl : eqm x x. + +Polymorphic Record prodp (A B : Type) : Type := pairp { fstp : A; sndp : B }. +Monomorphic Record prodm (A B : Type) : Type := pairm { fstm : A; sndm : B }. + +Check eqm_refl _ : eqm (fun x : prodm Set Set => pairm (fstm x) (sndm x)) (fun x => x). (* success *) +Check eqp_refl _ : eqp (fun x : prodm Set Set => pairm (fstm x) (sndm x)) (fun x => x). (* success *) +Check eqm_refl _ : eqm (fun x : prodp Set Set => pairp (fstp x) (sndp x)) (fun x => x). (* Error: +The term + "eqm_refl (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |})" +has type + "eqm (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |}) + (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |})" +while it is expected to have type + "eqm (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |}) + (fun x : prodp Set Set => x)". *) +Check eqp_refl _ : eqp (fun x : prodp Set Set => pairp (fstp x) (sndp x)) (fun x => x). (* Error: +The term + "eqp_refl (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |})" +has type + "eqp (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |}) + (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |})" +while it is expected to have type + "eqp (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |}) + (fun x : prodp Set Set => x)". *) diff --git a/test-suite/bugs/closed/shouldfail/1915.v b/test-suite/bugs/closed/shouldfail/1915.v deleted file mode 100644 index a96a482c..00000000 --- a/test-suite/bugs/closed/shouldfail/1915.v +++ /dev/null @@ -1,6 +0,0 @@ - -Require Import Setoid. - -Goal forall x, impl True (x = 0) -> x = 0 -> False. -intros x H E. -rewrite H in E.
\ No newline at end of file diff --git a/test-suite/bugs/closed/shouldfail/2406.v b/test-suite/bugs/closed/shouldfail/2406.v deleted file mode 100644 index 112ea2bb..00000000 --- a/test-suite/bugs/closed/shouldfail/2406.v +++ /dev/null @@ -1,3 +0,0 @@ -(* Check correct handling of unsupported notations *) -Notation "''" := (fun x => x) (at level 20). -Definition crash_the_rooster f := . diff --git a/test-suite/bugs/closed/shouldsucceed/1041.v b/test-suite/bugs/closed/shouldsucceed/1041.v deleted file mode 100644 index a5de82e0..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1041.v +++ /dev/null @@ -1,13 +0,0 @@ -Goal Prop. - -pose (P:=(fun x y :Prop => y)). -evar (Q: (forall X Y,P X Y -> Prop)) . - -instantiate (1:= fun _ => _ ) in (Value of Q). -instantiate (1:= fun _ => _ ) in (Value of Q). -instantiate (1:= fun _ => _ ) in (Value of Q). - -instantiate (1:=H) in (Value of Q). - -Admitted. - diff --git a/test-suite/bugs/closed/shouldsucceed/1519.v b/test-suite/bugs/closed/shouldsucceed/1519.v deleted file mode 100644 index 66bab241..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1519.v +++ /dev/null @@ -1,14 +0,0 @@ -Section S. - - Variable A:Prop. - Variable W:A. - - Remark T: A -> A. - intro Z. - rename W into Z_. - rename Z into W. - rename Z_ into Z. - exact Z. - Qed. - -End S. diff --git a/test-suite/bugs/opened/shouldnotfail/1338.v-disabled b/test-suite/bugs/opened/1338.v-disabled index f383d534..ab0f9820 100644 --- a/test-suite/bugs/opened/shouldnotfail/1338.v-disabled +++ b/test-suite/bugs/opened/1338.v-disabled @@ -8,5 +8,5 @@ x <> 0 -> x <> 18 -> x <> 19 -> x <> 20 -> False. Proof. intros. - omega. -Qed. + Fail omega. +Abort. diff --git a/test-suite/bugs/opened/shouldnotfail/1501.v b/test-suite/bugs/opened/1501.v index 1845dd1f..b36f21da 100644 --- a/test-suite/bugs/opened/shouldnotfail/1501.v +++ b/test-suite/bugs/opened/1501.v @@ -40,11 +40,13 @@ Parameter Hint Resolve equiv_refl equiv_sym equiv_trans: monad. -Add Relation K equiv - reflexivity proved by (@equiv_refl) - symmetry proved by (@equiv_sym) - transitivity proved by (@equiv_trans) - as equiv_rel. +Instance equiv_rel A: Equivalence (@equiv A). +Proof. + constructor. + intros xa; apply equiv_refl. + intros xa xb; apply equiv_sym. + intros xa xb xc; apply equiv_trans. +Defined. Definition fequiv (A B: Type) (f g: A -> K B) := forall (x:A), (equiv (f x) (g x)). @@ -67,17 +69,17 @@ Proof. unfold fequiv; intros; eapply equiv_trans; auto with monad. Qed. -Add Relation (fun (A B:Type) => A -> K B) fequiv - reflexivity proved by (@fequiv_refl) - symmetry proved by (@fequiv_sym) - transitivity proved by (@fequiv_trans) - as fequiv_rel. +Instance fequiv_re A B: Equivalence (@fequiv A B). +Proof. + constructor. + intros f; apply fequiv_refl. + intros f g; apply fequiv_sym. + intros f g h; apply fequiv_trans. +Defined. -Add Morphism bind - with signature equiv ==> fequiv ==> equiv - as bind_mor. +Instance bind_mor A B: Morphisms.Proper (@equiv _ ==> @fequiv _ _ ==> @equiv _) (@bind A B). Proof. - unfold fequiv; intros; apply bind_compat; auto. + unfold fequiv; intros x y xy_equiv f g fg_equiv; apply bind_compat; auto. Qed. Lemma test: @@ -88,6 +90,7 @@ Lemma test: Proof. intros A B m1 m2 m3 f H1 H2. setoid_rewrite H1. (* this works *) - setoid_rewrite H2. - trivial by equiv_refl. -Qed. + Fail setoid_rewrite H2. +Abort. +(* trivial by equiv_refl. +Qed.*) diff --git a/test-suite/bugs/opened/shouldnotfail/1596.v b/test-suite/bugs/opened/1596.v index de77e35d..7c5dc416 100644 --- a/test-suite/bugs/opened/shouldnotfail/1596.v +++ b/test-suite/bugs/opened/1596.v @@ -1,7 +1,10 @@ - Require Import Relations. Require Import FSets. Require Import Arith. +Require Import Omega. +Unset Standard Proposition Elimination Names. + +Set Keyed Unification. Lemma Bool_elim_bool : forall (b:bool),b=true \/ b=false. destruct b;try tauto. @@ -100,6 +103,16 @@ Definition t := (X.t * Y.t)%type. left;trivial. Defined. + Definition eq_dec : forall (x y: t), { eq x y } + { ~ eq x y}. + Proof. + intros [xa xb] [ya yb]; simpl. + destruct (X.eq_dec xa ya). + destruct (Y.eq_dec xb yb). + + left; now split. + + right. now intros [eqa eqb]. + + right. now intros [eqa eqb]. + Defined. + Hint Immediate eq_sym. Hint Resolve eq_refl eq_trans lt_not_eq lt_trans. End OrderedPair. @@ -158,6 +171,14 @@ GT;simpl;trivial;fail). apply GT;trivial. Defined. + Definition eq_dec : forall (x y: t), { eq x y } + { ~ eq x y}. + Proof. + intros [i] [j]. unfold eq. + destruct (eq_nat_dec i j). + + left. now f_equal. + + right. intros meq; now inversion meq. + Defined. + Hint Immediate eq_sym. Hint Resolve eq_refl eq_trans lt_not_eq lt_trans. End Ord. @@ -235,8 +256,6 @@ n). induction m;simpl;intro. elim (Bool_elim_bool (H.mem (MessageSpi.MNam n,n0) h));intros. apply SynInc;apply H.mem_2;trivial. - - rewrite H in H0. (* !! impossible here !! *) - discriminate H0. + rewrite H in H0. discriminate. (* !! impossible here !! *) Qed. End B.
\ No newline at end of file diff --git a/test-suite/bugs/opened/shouldnotfail/1671.v b/test-suite/bugs/opened/1671.v index d95c2108..b4e653f6 100644 --- a/test-suite/bugs/opened/shouldnotfail/1671.v +++ b/test-suite/bugs/opened/1671.v @@ -6,7 +6,7 @@ CoInductive hdlist : unit -> Type := Variable P : forall bo, hdlist bo -> Prop. Variable all : forall bo l, P bo l. -Definition F (l:hdlist tt) : P tt l := +Fail Definition F (l:hdlist tt) : P tt l := match l in hdlist u return P u l with | cons (cons l') => all tt _ end. diff --git a/test-suite/bugs/opened/1773.v b/test-suite/bugs/opened/1773.v deleted file mode 100644 index 4aabf19c..00000000 --- a/test-suite/bugs/opened/1773.v +++ /dev/null @@ -1,10 +0,0 @@ -Goal forall B C : nat -> nat -> Prop, forall k, C 0 k -> - (exists A, (forall k', C A k' -> B A k') -> B A k). -Proof. - intros B C k H. - econstructor. - intros X. - apply X. - apply H. -Qed. - diff --git a/test-suite/bugs/opened/shouldnotfail/1811.v b/test-suite/bugs/opened/1811.v index 037b7cb2..10c988fc 100644 --- a/test-suite/bugs/opened/shouldnotfail/1811.v +++ b/test-suite/bugs/opened/1811.v @@ -6,4 +6,5 @@ Proof. auto. Qed. Goal forall b1 b2, (negb b1 = b2) -> xorb true b1 = b2. Proof. intros b1 b2. - rewrite neg2xor.
\ No newline at end of file + Fail rewrite neg2xor. +Abort.
\ No newline at end of file diff --git a/test-suite/bugs/opened/2572.v-disabled b/test-suite/bugs/opened/2572.v-disabled new file mode 100644 index 00000000..3f6c6a0d --- /dev/null +++ b/test-suite/bugs/opened/2572.v-disabled @@ -0,0 +1,187 @@ +Require Import List. +Definition is_dec (P:Prop) := {P}+{~P}. +Definition eq_dec (T:Type) := forall (t1 t2:T), is_dec (t1=t2). + +Record Label : Type := mkLabel { + LabElem: Type; + LabProd: LabElem -> LabElem -> option LabElem; + LabBot: LabElem -> Prop; + LabError: LabElem -> Prop +}. + +Definition LProd (L1 L2: Label): Label := {| + LabElem := LabElem L1 * LabElem L2; + LabProd := fun lg ld => let (lg1,lg2) := lg in let (ld1,ld2) := ld in + match LabProd L1 lg1 ld1, LabProd L2 lg2 ld2 with + Some g, Some d => Some (g,d) + | _,_ => None + end; + LabBot l := let (l1,l2) := l in LabBot L1 l1 \/ LabBot L2 l2; + LabError l := let (l1,l2) := l in LabError L1 l1 \/ LabError L2 l2 +|}. + +Definition Lrestrict (L: Label) (S: LabElem L -> bool): Label := {| + LabElem := LabElem L; + LabProd l1 l2 := if andb (S l1) (S l2) then LabProd L l1 l2 else None; + LabBot l := LabBot L l; + LabError l := LabError L l +|}. + +Notation "l1 ^* l2" := (LProd l1 l2) (at level 50). + +Record LTS(L:Type): Type := mkLTS { + State: Type; + Init: State -> Prop; + Next: State -> L -> State -> Prop +}. +Implicit Arguments State. +Implicit Arguments Init. +Implicit Arguments Next. + +Definition sound L (S: LTS (LabElem L)): Prop := + forall s s' l, Next S s l s' -> ~LabError L l. + +Inductive PNext L (S1 S2:LTS (LabElem L)): State S1 * State S2 -> (LabElem L) -> State S1 * State S2 -> Prop := + LNext: forall s1 s2 l1 s'1, Next S1 s1 l1 s'1 -> (forall l2, LabProd L l1 l2 = None) -> + PNext L S1 S2 (s1,s2) l1 (s'1,s2) +| RNext: forall s1 s2 l2 s'2, (forall l1, LabProd L l1 l2 = None) -> Next S2 s2 l2 s'2 -> + PNext L S1 S2 (s1,s2) l2 (s1,s'2) +| SNext: forall s1 s2 l1 l2 l s'1 s'2, Next S1 s1 l1 s'1 -> Next S2 s2 l2 s'2 -> + Some l = LabProd L l1 l2 -> PNext L S1 S2 (s1,s2) l (s'1,s'2). + +Definition Produit (L:Label) (S1 S2: LTS (LabElem L)): LTS (LabElem L) := {| + State := State S1 * State S2; + Init := fun s => let (s1,s2) := s in Init S1 s1 /\ Init S2 s2; + Next :=PNext L S1 S2 +|}. + +Parameter Time: Type. +Parameter teq: forall t1 t2:Time, {t1=t2}+{t1<>t2}. + +Inductive TLabElem(L:Type): Type := + Tdiscrete: L -> TLabElem L +| Tdelay: Time -> TLabElem L +| Tbot: TLabElem L. + +Definition TLabel L: Label := {| + LabElem := TLabElem (LabElem L); + LabProd lt1 lt2 := + match lt1, lt2 with + Tdiscrete l1, Tdiscrete l2 => match (LabProd L l1 l2) with Some l => Some (Tdiscrete (LabElem L) l) | None => None end + | Tdelay t1, Tdelay t2 => if teq t1 t2 then Some (Tdelay (LabElem L) t1) else Some (Tbot (LabElem L)) + | _,_ => None + end; + LabBot lt := match lt with + Tdiscrete l => LabBot L l + | Tbot => True + | _ => False + end; + LabError lt := match lt with + Tdiscrete l => LabError L l + | _ => False + end + |}. + +Parameter Var: Type. +Parameter allv: forall P, (forall (v:Var), is_dec (P v)) -> is_dec (forall v, P v). +Parameter DType: Type. +Parameter Data: DType -> Type. +Parameter vtype: Var -> DType. +Parameter Deq: forall t (d1 d2: Data t), is_dec (d1=d2). + +Inductive Vctr(v:Var): Type := + Wctr: Data (vtype v) -> Vctr v +| Rctr: Data (vtype v) -> Vctr v +| Fctr: Vctr v +| Nctr: Vctr v. + +Definition isCmp v (c1 c2: Vctr v): Prop := + match c1,c2 with + Wctr _, Nctr => True + | Rctr _, Rctr _ => True + | Rctr _, Nctr => True + | Rctr _, Fctr => True + | Nctr, _ => True + | _,_ => False + end. + +Lemma isCmp_dec: forall v (c1 c2: Vctr v), is_dec (isCmp v c1 c2). +intros. +induction c1; induction c2; simpl; intros; try (left; tauto); try (right; tauto). +Qed. + +Definition Vprod v (c1 c2: Vctr v): (isCmp v c1 c2) -> Vctr v := + match c1,c2 return isCmp v c1 c2 -> Vctr v with + | Wctr d, Nctr => fun h => Wctr v d + | Rctr d1, Rctr d2 => fun h => if Deq (vtype v) d1 d2 then Rctr v d1 else Fctr v + | Rctr d1, Nctr => fun h => Rctr v d1 + | Rctr d1, Fctr => fun h => Fctr v + | Fctr, Rctr _ => fun h => Fctr v + | Fctr, Fctr => fun h => Fctr v + | Fctr, Nctr => fun h => Fctr v + | Nctr, c2 => fun h => c2 + | _,_ => fun h => match h with end + end. + +Inductive MLabElem: Type := + Mctr: (forall v, Vctr v) -> MLabElem +| Merr: MLabElem. + +Definition MProd (m1 m2: MLabElem): MLabElem := + match m1,m2 with + Mctr c1, Mctr c2 => match allv (fun v => isCmp v (c1 v) (c2 v)) (fun v => isCmp_dec v (c1 v) (c2 v)) with + left h => Mctr (fun v => Vprod v (c1 v) (c2 v) (h v)) + | _ => Merr + end + | _,_ => Merr + end. + +Definition MLabel: Label := {| + LabElem := MLabElem; + LabProd m1 m2 := Some (MProd m1 m2); + LabBot m := exists c, m = Mctr c /\ exists v, c v = Fctr v; + LabError m := m = Merr +|}. + +Parameter Chan: Type. +Parameter ch_eq: eq_dec Chan. + +Definition CLabel(S: Chan->bool): Label := {| + LabElem := Chan; + LabProd := fun c1 c2 => if ch_eq c1 c2 then if S c1 then Some c1 else None else None; + LabBot := fun _ => False; + LabError := fun _ => False +|}. + +Definition FLabel(S: Chan->bool): Label := + TLabel (CLabel S ^* MLabel ^* MLabel ^* MLabel). + +Definition FTS := LTS (LabElem (FLabel (fun _ => true))). +Check (fun S (T1 T2: FTS) => Produit (FLabel S) T1 T2). +(* +Definition PAR (S: Chan -> bool) (T1 T2: FTS): FTS. +unfold FTS in *; simpl in *. +apply (Produit (FLabel S)). +apply T1. +apply T2. +Defined. + +Definition PAR (S: Chan -> bool) (T1 T2: FTS): FTS := + Produit (FLabel S) T1 T2. +*) +Lemma FTSirrel (S: Chan -> bool): FTS = LTS (LabElem (FLabel S)). +Proof. + unfold FTS. + simpl. + reflexivity. +Qed. + +Definition PAR (S: Chan -> bool) (T1 T2: FTS): FTS. +revert T2; revert T1. +rewrite (FTSirrel S). +apply (Produit (FLabel S)). +Defined. + +Record HTTS: Type := mkHTTS { + +}. diff --git a/test-suite/bugs/opened/2652a.v-disabled b/test-suite/bugs/opened/2652a.v-disabled new file mode 100644 index 00000000..0274037b --- /dev/null +++ b/test-suite/bugs/opened/2652a.v-disabled @@ -0,0 +1,106 @@ +Require Import Strings.String. +Require Import Classes.EquivDec. +Require Import Lists.List. + +Inductive Owner : Type := + | server : Owner + | client : Owner. + +Inductive ClassName : Type := + | className : string -> ClassName. + +Inductive Label : Type := + | label : nat -> Owner -> Label. + +Inductive Var : Type := + | var : string -> Var. + +Inductive FieldName : Type := + | fieldName : string -> Owner -> FieldName. + +Inductive MethodCall : Type := + | methodCall : string -> MethodCall. + +Inductive Exp : Type := + | varExp : Var -> Exp + | fieldReference : Var -> FieldName -> Exp + | methodCallExp : Var -> MethodCall -> list Var -> Exp + | allocation : ClassName -> list Var -> Exp + | cast : ClassName -> Var -> Exp. + +Inductive Stmt : Type := + | assignment : Var -> Exp -> Label -> Stmt + | returnStmt : Var -> Label -> Stmt + | fieldUpdate : Var -> FieldName -> Exp -> Label -> Stmt. + +Inductive Konst : Type := + | konst : ClassName -> (list (ClassName * FieldName)) -> list FieldName -> (list FieldName * FieldName) -> Konst. + +Inductive Method : Type := + | method : ClassName -> MethodCall -> list (ClassName * Var) -> list (ClassName * Var) -> (list Stmt) -> Method. + +Inductive Class : Type := + | class : ClassName -> ClassName -> (list (ClassName * FieldName)) -> (Konst * (list Method)) -> Class. + +Inductive Context : Type := + | context : nat -> Context. + +Inductive HContext : Type := + | heapContext : nat -> HContext. + +Inductive Location := loc : nat -> Location. + +Definition AbsLocation := ((Var * Context) + (FieldName * HContext)) % type. + +Definition CallStack := list (Stmt * Context * Var) % type. + +Inductive TypeState : Type := + | fresh : TypeState + | stale : TypeState. + +Definition Obj := (HContext * (FieldName -> option AbsLocation) * TypeState) % type. + +Definition Store := Location -> option Obj. + +Definition OwnerStore := Owner -> Store. + +Definition AbsStore := AbsLocation -> option (list Obj). + +Definition Stack := list (Var -> option Location). + +Definition Batch := list Location. + +Definition Sigma := (Stmt * Stack * OwnerStore * AbsStore * CallStack * Context * Batch) % type. + +Definition update {A : Type} {B : Type} `{EqDec A} `{EqDec B} (f : A -> B) (k : A) (v : B) : (A -> B) := + fun k' => if equiv_decb k' k then v else f k'. + + +Definition transfer : Label -> OwnerStore -> Batch -> (OwnerStore * Batch) := + fun _ o b => (o,b). + +Parameter succ : Label -> Stmt. + +Parameter owner : Label -> Owner. + +Inductive concreteSingleStep : Sigma -> Sigma -> Prop := + | fieldAssignmentLocal : forall v f_do f o so sigma_so hc m sigma'_so v' l st sigma absSigma cst c b sigma' sigma'' b', + (f_do = fieldName f o) -> so = owner(l) -> sigma_so = sigma(so) -> Some (hc, m, fresh) = sigma_so(st(v)) -> sigma'_so = update sigma_so st(v) (Some (hc, update m f_do st(v'), fresh)) + -> sigma' = update sigma so sigma'_so -> o = so -> (sigma'', b') = transfer l sigma' b -> + concreteSingleStep ((fieldUpdate v f_do (varExp v') l), st, sigma, absSigma, cst, c, b) + (succ(l), st, sigma'', absSigma, cst, c, b'). + + | fieldAssignmentRemote : forall v f_do f o so sigma_so hc m sigma'_so v' l st sigma absSigma cst c b sigma' sigma'' b', + (f_do = fieldName f o) -> so = owner(l) -> sigma_so = sigma(so) -> (hc, m, fresh) = sigma_so(st(v)) -> sigma'_so = update sigma_so st(v) (hc, update m f_do st(v'), fresh) + -> sigma' = update sigma so sigma'_so -> o <> so -> (sigma'', b') = transfer l sigma' (b ++ st(v)) -> + concreteSingleStep ((fieldUpdate v f_o (varExp v') l), st, sigma, absSigma, cst, c, b) + (succ(l), st, sigma'', absSigma, cst, c, b'') + | variableStep : forall v v' l st st' sigma sigma' absSigma cst c b b', + (st' = st ++ (update (fun _ => None) v st(v'))) -> (sigma',b') = transfer l sigma b -> + concreteSingleStep ((assignment v (varExp v') l), st, sigma, absSigma, cst, c, b) (succ(l), st', sigma', absSigma, cst, c, b') + | returnStep : forall v l st sigma absSigma cst c b v_ret s st' sigma' c' b', + (s,c',v_ret) = car(cst) -> st' = cdr(st) ++ update (fun _ => None) v_ret st(v) -> (sigma', b') = transfer l sigma b -> + concreteSingleStep ((returnStmt v l), st, sigma, absSigma, cst, c, b) (s, st', sigma', absSigma, cdr(cst), c', b') + | fieldReferenceStep : forall v v' f_do l st sigma absSigma cst c b so hc m' m st' sigma' absSigma cst c b', + so = owner(l) -> (hc, m', fresh) = sigma(so)(st(v')) -> m' = update m f_do l -> st' = st ++ update (fun _ => None) v l -> (sigma', b') = transfer l sigma b -> + concreteSingleStep ((assignment v (fieldReference v' f_do) l), st, sigma, absSigma, cst, c, b) (s, st', sigma', absSigma, cst, c, b'). diff --git a/test-suite/bugs/opened/2652b.v-disabled b/test-suite/bugs/opened/2652b.v-disabled new file mode 100644 index 00000000..b340436d --- /dev/null +++ b/test-suite/bugs/opened/2652b.v-disabled @@ -0,0 +1,88 @@ +(* This used to show a bug in evarutil. which is fixed in 8.4 *) +Require Import Strings.String. +Require Import Classes.EquivDec. +Require Import Lists.List. + +Inductive Owner : Type := + | server : Owner + | client : Owner. + +Inductive ClassName : Type := + | className : string -> ClassName. + +Inductive Label : Type := + | label : nat -> Owner -> Label. + +Inductive Var : Type := + | var : string -> Var. + +Inductive FieldName : Type := + | fieldName : string -> Owner -> FieldName. + +Inductive MethodCall : Type := + | methodCall : string -> MethodCall. + +Inductive Exp : Type := + | varExp : Var -> Exp + | fieldReference : Var -> FieldName -> Exp + | methodCallExp : Var -> MethodCall -> list Var -> Exp + | allocation : ClassName -> list Var -> Exp + | cast : ClassName -> Var -> Exp. + +Inductive Stmt : Type := + | assignment : Var -> Exp -> Label -> Stmt + | returnStmt : Var -> Label -> Stmt + | fieldUpdate : Var -> FieldName -> Exp -> Label -> Stmt. + +Inductive Konst : Type := + | konst : ClassName -> (list (ClassName * FieldName)) -> list FieldName -> (list FieldName * FieldName) -> Konst. + +Inductive Method : Type := + | method : ClassName -> MethodCall -> list (ClassName * Var) -> list (ClassName * Var) -> (list Stmt) -> Method. + +Inductive Class : Type := + | class : ClassName -> ClassName -> (list (ClassName * FieldName)) -> (Konst * (list Method)) -> Class. + +Inductive Context : Type := + | context : nat -> Context. + +Inductive HContext : Type := + | heapContext : nat -> HContext. + +Inductive Location := loc : nat -> Location. + +Definition AbsLocation := ((Var * Context) + (FieldName * HContext)) % type. + +Definition CallStack := list (Stmt * Context * Var) % type. + +Inductive TypeState : Type := + | fresh : TypeState + | stale : TypeState. + +Definition Obj := (HContext * (FieldName -> option AbsLocation) * TypeState) % type. + +Definition Store := Location -> option Obj. + +Definition OwnerStore := Owner -> Store. + +Definition AbsStore := AbsLocation -> option (list Obj). + +Definition Stack := list (Var -> option Location). + +Definition Batch := list Location. + +Definition Sigma := (Stmt * Stack * OwnerStore * AbsStore * CallStack * Context * Batch) % type. + +Definition update {A : Type} {B : Type} `{EqDec A} `{EqDec B} (f : A -> B) (k : A) (v : B) : (A -> B) := + fun k' => if equiv_decb k' k then v else f k'. + +Parameter succ : Label -> Stmt. + +Inductive concreteSingleStep : Sigma -> Sigma -> Prop := + | fieldAssignmentLocal : forall v f_do f o so sigma_so hc m sigma'_so v' l st sigma absSigma cst c b sigma' sigma'' b', + Some (hc, m, fresh) = sigma_so(st(v)) -> sigma'_so = update sigma_so st(v) (Some (hc, update m f_do st(v'), fresh)) + -> + concreteSingleStep ((fieldUpdate v f_do (varExp v') l), st, sigma, absSigma, cst, c, b) + (succ(l), st, sigma'', absSigma, cst, c, b'). + +. diff --git a/test-suite/bugs/opened/2800.v b/test-suite/bugs/opened/2800.v new file mode 100644 index 00000000..c559ab0c --- /dev/null +++ b/test-suite/bugs/opened/2800.v @@ -0,0 +1,6 @@ +Goal False. + +Fail intuition + match goal with + | |- _ => idtac " foo" + end. diff --git a/test-suite/bugs/opened/2814.v b/test-suite/bugs/opened/2814.v new file mode 100644 index 00000000..a740b438 --- /dev/null +++ b/test-suite/bugs/opened/2814.v @@ -0,0 +1,5 @@ +Require Import Program. + +Goal forall (x : Type) (f g : Type -> Type) (H : f x ~= g x), False. + intros. + Fail induction H. diff --git a/test-suite/bugs/opened/2951.v b/test-suite/bugs/opened/2951.v new file mode 100644 index 00000000..3739247b --- /dev/null +++ b/test-suite/bugs/opened/2951.v @@ -0,0 +1 @@ +Class C (A: Type) : Type := { f: A }. diff --git a/test-suite/bugs/opened/3010.v-disabled b/test-suite/bugs/opened/3010.v-disabled new file mode 100644 index 00000000..f2906bd6 --- /dev/null +++ b/test-suite/bugs/opened/3010.v-disabled @@ -0,0 +1 @@ +Definition em {A R} (k : forall s : sum A _, match s with inl x => R x | inr y => R end) := k (inr (fun x => k (inl x))).
\ No newline at end of file diff --git a/test-suite/bugs/opened/3045.v b/test-suite/bugs/opened/3045.v new file mode 100644 index 00000000..b7f40b4a --- /dev/null +++ b/test-suite/bugs/opened/3045.v @@ -0,0 +1,30 @@ +Set Asymmetric Patterns. +Generalizable All Variables. +Set Implicit Arguments. +Set Universe Polymorphism. + +Record SpecializedCategory (obj : Type) := + { + Object :> _ := obj; + Morphism : obj -> obj -> Type; + + Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' + }. + +Arguments Compose {obj} [C s d d'] m1 m2 : rename. + +Inductive ReifiedMorphism : forall objC (C : SpecializedCategory objC), C -> C -> Type := +| ReifiedComposedMorphism : forall objC C s d d', ReifiedMorphism C d d' -> ReifiedMorphism C s d -> @ReifiedMorphism objC C s d'. + +Fixpoint ReifiedMorphismDenote objC C s d (m : @ReifiedMorphism objC C s d) : Morphism C s d := + match m in @ReifiedMorphism objC C s d return Morphism C s d with + | ReifiedComposedMorphism _ _ _ _ _ m1 m2 => Compose (@ReifiedMorphismDenote _ _ _ _ m1) + (@ReifiedMorphismDenote _ _ _ _ m2) + end. + +Fixpoint ReifiedMorphismSimplifyWithProof objC C s d (m : @ReifiedMorphism objC C s d) +: { m' : ReifiedMorphism C s d | ReifiedMorphismDenote m = ReifiedMorphismDenote m' }. +refine match m with + | ReifiedComposedMorphism _ _ s0 d0 d0' m1 m2 => _ + end; clear m. +Fail destruct (@ReifiedMorphismSimplifyWithProof _ _ _ _ m1) as [ [] ? ]. diff --git a/test-suite/bugs/opened/3071.v b/test-suite/bugs/opened/3071.v new file mode 100644 index 00000000..611ac606 --- /dev/null +++ b/test-suite/bugs/opened/3071.v @@ -0,0 +1,5 @@ +Definition foo := True. + +Section foo. + Global Arguments foo / . +Fail End foo. diff --git a/test-suite/bugs/opened/3092.v b/test-suite/bugs/opened/3092.v new file mode 100644 index 00000000..9db21d15 --- /dev/null +++ b/test-suite/bugs/opened/3092.v @@ -0,0 +1,9 @@ +Fail Fixpoint le_pred (n1 n2 : nat) (H1 : n1 <= n2) : pred n1 <= pred n2 := + match H1 with + | le_n => le_n (pred _) + | le_S _ H2 => + match n2 with + | 0 => fun H3 => H3 + | S _ => le_S _ _ + end (le_pred _ _ H2) + end. diff --git a/test-suite/bugs/opened/3100.v b/test-suite/bugs/opened/3100.v new file mode 100644 index 00000000..6f35a74d --- /dev/null +++ b/test-suite/bugs/opened/3100.v @@ -0,0 +1,9 @@ +Fixpoint F (n : nat) (A : Type) : Type := + match n with + | 0 => True + | S n => forall (x : A), F n (x = x) + end. + +Goal forall A n, (forall (x : A) (e : x = x), F n (e = e)). +intros A n. +Fail change (forall x, F n (x = x)) with (F (S n)). diff --git a/test-suite/bugs/opened/3166.v b/test-suite/bugs/opened/3166.v new file mode 100644 index 00000000..e1c29a95 --- /dev/null +++ b/test-suite/bugs/opened/3166.v @@ -0,0 +1,83 @@ +Set Asymmetric Patterns. + +Section eq. + Let A := { X : Type & X }. + Let B := (fun x : A => projT1 x). + Let T := (fun (a' : A) (b' : B a') => projT2 a' = b'). + Let T' := T. + Let t1T := (fun _ : A => unit). + Let f1 := (fun x (_ : t1T x) => projT2 x). + Let t1 := (fun x (y : t1T x) => @eq_refl (projT1 x) (projT2 x)). + Let t1T' := t1T. + Let f1' := f1. + Let t1' := t1. + + Theorem eq_matches_commute + a' b' (t' : T a' b') + (rta : forall b'', T' a' b'' -> A) + (rtb : forall b'' t'', B (rta b'' t'')) + (rt1 : forall y, T _ (rtb (f1' a' y) (@t1' a' y))) + (R : forall (b : B (rta b' t')), T _ b -> Type) + (r1 : forall y, R (f1 _ y) (@t1 _ y)) + : match + match t' as t0' in (@eq _ _ b0') return T (rta b0' t0') (rtb b0' t0') with + | eq_refl => rt1 tt + end + as t0 in (@eq _ _ b0) + return R b0 t0 + with + | eq_refl => r1 tt + end + = + match t' + as t0' in (@eq _ _ b0') + return (forall (R : forall (b : B (rta b0' t0')), T _ b -> Type) + (r1 : forall y, R (f1 _ y) (@t1 _ y)), + R _ (match t0' as t0'0 in (@eq _ _ b0'0) return T (rta b0'0 t0'0) (rtb b0'0 t0'0) with + | eq_refl => rt1 tt + end)) + with + | eq_refl => fun _ r1 => + match rt1 tt with + | eq_refl => r1 tt + end + end R r1. + Proof. + destruct t'; reflexivity. + Defined. + + Theorem eq_match_beta2 + a b (t : T a b) + X + (R : forall b' (t' : T a b'), X b' -> Type) + (r1 : forall y x, R _ (@t1 _ y) x) + x + : match t as t' in (@eq _ _ b') return forall x, R b' t' x with + | eq_refl => r1 tt + end (x b) + = + match t as t' in (@eq _ _ b') return R b' t' (x b') with + | eq_refl => r1 tt (x _) + end. + Proof. + destruct t; reflexivity. + Defined. +End eq. + +Definition typeof {T} (_ : T) := T. + +Eval compute in (eq_sym (eq_sym _)). +Goal forall T (x y : T) (p : x = y), True. + intros. + pose proof + (@eq_matches_commute + (existT (fun T => T) T x) y p + (fun b'' _ => existT (fun T => T) T b'') + (fun _ _ => x) + (fun _ => eq_refl) + (fun x' _ => x' = y) + (fun _ => eq_refl) + ) as H0. + compute in H0. + change (fun (x' : T) (_ : y = x') => x' = y) with ((fun y => fun (x' : T) (_ : y = x') => x' = y) y) in H0. + Fail pose proof (fun k => @eq_trans _ _ _ k H0). diff --git a/test-suite/bugs/opened/3186.v-disabled b/test-suite/bugs/opened/3186.v-disabled new file mode 100644 index 00000000..d0bcb920 --- /dev/null +++ b/test-suite/bugs/opened/3186.v-disabled @@ -0,0 +1,4 @@ +Fixpoint a (_:unit):= +match eq_refl with +|eq_refl => a +end.
\ No newline at end of file diff --git a/test-suite/bugs/opened/3209.v b/test-suite/bugs/opened/3209.v new file mode 100644 index 00000000..3203afa1 --- /dev/null +++ b/test-suite/bugs/opened/3209.v @@ -0,0 +1,17 @@ +Inductive eqT {A} (x : A) : A -> Type := + reflT : eqT x x. +Definition Bi_inv (A B : Type) (f : (A -> B)) := + sigT (fun (g : B -> A) => + sigT (fun (h : B -> A) => + sigT (fun (α : forall b : B, eqT (f (g b)) b) => + forall a : A, eqT (h (f a)) a))). +Definition TEquiv (A B : Type) := sigT (fun (f : A -> B) => Bi_inv _ _ f). + +Axiom UA : forall (A B : Type), TEquiv (TEquiv A B) (eqT A B). +Definition idtoeqv {A B} (e : eqT A B) : TEquiv A B := + sigT_rect (fun _ => TEquiv A B) + (fun (f : TEquiv A B -> eqT A B) H => + sigT_rect (fun _ => TEquiv A B) + (fun g _ => g e) + H) + (UA A B). diff --git a/test-suite/bugs/opened/3230.v b/test-suite/bugs/opened/3230.v new file mode 100644 index 00000000..265310b1 --- /dev/null +++ b/test-suite/bugs/opened/3230.v @@ -0,0 +1,14 @@ +Structure type : Type := Pack { ob : Type }. +Polymorphic Record category := { foo : Type }. +Definition FuncComp := Pack category. +Axiom C : category. + +Check (C : ob FuncComp). (* OK *) + +Canonical Structure FuncComp. + +Check (C : ob FuncComp). +(* Toplevel input, characters 15-39: +Error: +The term "C" has type "category" while it is expected to have type + "ob FuncComp". *) diff --git a/test-suite/bugs/opened/3248.v b/test-suite/bugs/opened/3248.v new file mode 100644 index 00000000..9e7d1eb5 --- /dev/null +++ b/test-suite/bugs/opened/3248.v @@ -0,0 +1,17 @@ +Ltac ret_and_left f := + let tac := ret_and_left in + let T := type of f in + lazymatch eval hnf in T with + | ?T' -> _ => + let ret := constr:(fun x' : T' => $(tac (f x'))$) in + exact ret + | ?T' => exact f + end. + +Goal forall A B : Prop, forall x y : A, True. +Proof. + intros A B x y. + pose (f := fun (x y : A) => conj x y). + pose (a := $(ret_and_left f)$). + Fail unify (a x y) (conj x y). +Abort. diff --git a/test-suite/bugs/opened/3263.v b/test-suite/bugs/opened/3263.v new file mode 100644 index 00000000..6de13f74 --- /dev/null +++ b/test-suite/bugs/opened/3263.v @@ -0,0 +1,231 @@ +(* File reduced by coq-bug-finder from originally 10918 lines, then 3649 lines to 3177 lines, then from 3189 lines to 3164 lines, then from 2653 lines to 2496 lines, 2653 lines, then from 1642 lines to 651 lines, then from 736 lines to 473 lines, then from 433 lines to 275 lines, then from 258 lines to 235 lines. *) +Generalizable All Variables. +Set Implicit Arguments. + +Arguments fst {_ _} _. +Arguments snd {_ _} _. + +Axiom cheat : forall {T}, T. + +Reserved Notation "g 'o' f" (at level 40, left associativity). + +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y" := (paths x y) : type_scope. + +Definition symmetry {A : Type} {x y : A} (p : x = y) : y = x + := match p with idpath => idpath end. + +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope object_scope with object. +Record PreCategory (object : Type) := + Build_PreCategory' { + object :> Type := object; + morphism : object -> object -> Type; + identity : forall x, morphism x x; + compose : forall s d d', + morphism d d' + -> morphism s d + -> morphism s d' + where "f 'o' g" := (compose f g); + associativity : forall x1 x2 x3 x4 + (m1 : morphism x1 x2) + (m2 : morphism x2 x3) + (m3 : morphism x3 x4), + (m3 o m2) o m1 = m3 o (m2 o m1); + associativity_sym : forall x1 x2 x3 x4 + (m1 : morphism x1 x2) + (m2 : morphism x2 x3) + (m3 : morphism x3 x4), + m3 o (m2 o m1) = (m3 o m2) o m1; + left_identity : forall a b (f : morphism a b), identity b o f = f; + right_identity : forall a b (f : morphism a b), f o identity a = f; + identity_identity : forall x, identity x o identity x = identity x + }. +Bind Scope category_scope with PreCategory. +Arguments PreCategory {_}. +Arguments identity {_} [!C%category] x%object : rename. + +Arguments compose {_} [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename. + +Infix "o" := compose : morphism_scope. + +Delimit Scope functor_scope with functor. +Local Open Scope morphism_scope. +Record Functor `(C : @PreCategory objC, D : @PreCategory objD) := + { + object_of :> C -> D; + morphism_of : forall s d, morphism C s d + -> morphism D (object_of s) (object_of d); + composition_of : forall s d d' + (m1 : morphism C s d) (m2: morphism C d d'), + morphism_of _ _ (m2 o m1) + = (morphism_of _ _ m2) o (morphism_of _ _ m1); + identity_of : forall x, morphism_of _ _ (identity x) + = identity (object_of x) + }. +Bind Scope functor_scope with Functor. + +Arguments morphism_of {_} [C%category] {_} [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch. + +Notation "F '_1' m" := (morphism_of F m) (at level 10, no associativity) : morphism_scope. + +Class IsIsomorphism `{C : @PreCategory objC} {s d} (m : morphism C s d) := + { + morphism_inverse : morphism C d s; + left_inverse : morphism_inverse o m = identity _; + right_inverse : m o morphism_inverse = identity _ + }. + +Definition opposite `(C : @PreCategory objC) : PreCategory + := @Build_PreCategory' + C + (fun s d => morphism C d s) + (identity (C := C)) + (fun _ _ _ m1 m2 => m2 o m1) + (fun _ _ _ _ _ _ _ => @associativity_sym _ _ _ _ _ _ _ _ _) + (fun _ _ _ _ _ _ _ => @associativity _ _ _ _ _ _ _ _ _) + (fun _ _ => @right_identity _ _ _ _) + (fun _ _ => @left_identity _ _ _ _) + (@identity_identity _ C). + +Notation "C ^op" := (opposite C) (at level 3) : category_scope. + +Definition prod `(C : @PreCategory objC, D : @PreCategory objD) : @PreCategory (objC * objD). + refine (@Build_PreCategory' + (C * D)%type + (fun s d => (morphism C (fst s) (fst d) + * morphism D (snd s) (snd d))%type) + (fun x => (identity (fst x), identity (snd x))) + (fun s d d' m2 m1 => (fst m2 o fst m1, snd m2 o snd m1)) + _ + _ + _ + _ + _); admit. +Defined. +Infix "*" := prod : category_scope. + +Definition compose_functor `(C : @PreCategory objC, D : @PreCategory objD, E : @PreCategory objE) (G : Functor D E) (F : Functor C D) : Functor C E + := Build_Functor + C E + (fun c => G (F c)) + (fun _ _ m => morphism_of G (morphism_of F m)) + cheat + cheat. + +Infix "o" := compose_functor : functor_scope. + +Record NaturalTransformation `(C : @PreCategory objC, D : @PreCategory objD) (F G : Functor C D) := + Build_NaturalTransformation' { + components_of :> forall c, morphism D (F c) (G c); + commutes : forall s d (m : morphism C s d), + components_of d o F _1 m = G _1 m o components_of s; + + commutes_sym : forall s d (m : C.(morphism) s d), + G _1 m o components_of s = components_of d o F _1 m + }. +Definition functor_category `(C : @PreCategory objC, D : @PreCategory objD) : PreCategory + := @Build_PreCategory' (Functor C D) + (@NaturalTransformation _ C _ D) + cheat + cheat + cheat + cheat + cheat + cheat + cheat. + +Definition opposite_functor `(F : @Functor objC C objD D) : Functor C^op D^op + := Build_Functor (C^op) (D^op) + (object_of F) + (fun s d => morphism_of F (s := d) (d := s)) + (fun d' d s m1 m2 => composition_of F s d d' m2 m1) + (identity_of F). + +Definition opposite_invL `(F : @Functor objC C^op objD D) : Functor C D^op + := Build_Functor C (D^op) + (object_of F) + (fun s d => morphism_of F (s := d) (d := s)) + (fun d' d s m1 m2 => composition_of F s d d' m2 m1) + (identity_of F). +Notation "F ^op" := (opposite_functor F) : functor_scope. + +Notation "F ^op'L" := (opposite_invL F) (at level 3) : functor_scope. +Definition fst `{C : @PreCategory objC, D : @PreCategory objD} : Functor (C * D) C + := Build_Functor (C * D) C + (@fst _ _) + (fun _ _ => @fst _ _) + (fun _ _ _ _ _ => idpath) + (fun _ => idpath). + +Definition snd `{C : @PreCategory objC, D : @PreCategory objD} : Functor (C * D) D + := Build_Functor (C * D) D + (@snd _ _) + (fun _ _ => @snd _ _) + (fun _ _ _ _ _ => idpath) + (fun _ => idpath). +Definition prod_functor `(F : @Functor objC C objD D, F' : @Functor objC C objD' D') +: Functor C (D * D') + := Build_Functor + C (D * D') + (fun c => (F c, F' c)) + (fun s d m => (F _1 m, F' _1 m))%morphism + cheat + cheat. +Definition pair `(F : @Functor objC C objD D, F' : @Functor objC' C' objD' D') : Functor (C * C') (D * D') + := (prod_functor (F o fst) (F' o snd))%functor. +Notation cat_of obj := + (@Build_PreCategory' obj + (fun x y => forall _ : x, y) + (fun _ x => x) + (fun _ _ _ f g x => f (g x))%core + (fun _ _ _ _ _ _ _ => idpath) + (fun _ _ _ _ _ _ _ => idpath) + (fun _ _ _ => idpath) + (fun _ _ _ => idpath) + (fun _ => idpath)). + +Definition hom_functor `(C : @PreCategory objC) : Functor (C^op * C) (cat_of Type) + := Build_Functor _ _ cheat cheat cheat cheat. + +Definition induced_hom_natural_transformation `(F : @Functor objC C objD D) +: NaturalTransformation (hom_functor C) (hom_functor D o pair F^op F) + := Build_NaturalTransformation' _ _ cheat cheat cheat. + +Class IsFullyFaithful `(F : @Functor objC C objD D) + := is_fully_faithful + : forall x y : C, + IsIsomorphism (induced_hom_natural_transformation F (x, y)). + +Definition coyoneda `(A : @PreCategory objA) : Functor A^op (@functor_category _ A _ (cat_of Type)) + := cheat. + +Definition yoneda `(A : @PreCategory objA) : Functor A (@functor_category _ A^op _ (cat_of Type)) + := (((coyoneda A^op)^op'L)^op'L)%functor. +Definition coyoneda_embedding `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@coyoneda _ A). +Admitted. + +Definition yoneda_embedding_fast `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@yoneda _ A). +Proof. + intros a b. + pose proof (coyoneda_embedding A^op a b) as CYE. + unfold yoneda. + Time let t := (type of CYE) in + let t' := (eval simpl in t) in pose proof ((fun (x : t) => (x : t')) CYE) as CYE'. (* Finished transaction in 0. secs (0.216013u,0.004s) *) + Fail Timeout 1 let t := match goal with |- ?G => constr:(G) end in + let t' := (eval simpl in t) in exact ((fun (x : t') => (x : t)) CYE'). + Time let t := match goal with |- ?G => constr:(G) end in + let t' := (eval simpl in t) in exact ((fun (x : t') => (x : t)) CYE'). (* Finished transaction in 0. secs (0.248016u,0.s) *) +Fail Timeout 2 Defined. +Time Defined. (* Finished transaction in 1. secs (0.432027u,0.s) *) + +Definition yoneda_embedding `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@yoneda _ A). +Proof. + intros a b. + pose proof (coyoneda_embedding A^op a b) as CYE. + unfold yoneda; simpl in *. + Fail Timeout 1 exact CYE. + Time exact CYE. (* Finished transaction in 0. secs (0.012001u,0.s) *) +Fail Timeout 60 Defined. (* Timeout! *) diff --git a/test-suite/bugs/opened/3277.v b/test-suite/bugs/opened/3277.v new file mode 100644 index 00000000..19ed787d --- /dev/null +++ b/test-suite/bugs/opened/3277.v @@ -0,0 +1,7 @@ +Tactic Notation "evarr" open_constr(x) := let y := constr:(x) in exact y. + +Goal True. + evarr _. +Admitted. +Goal True. + Fail exact $(evarr _)$. (* Error: Cannot infer this placeholder. *) diff --git a/test-suite/bugs/opened/3278.v b/test-suite/bugs/opened/3278.v new file mode 100644 index 00000000..ced535af --- /dev/null +++ b/test-suite/bugs/opened/3278.v @@ -0,0 +1,25 @@ +Module a. + Check let x' := _ in + $(exact x')$. + + Notation foo x := (let x' := x in $(exact x')$). + + Fail Check foo _. (* Error: +Cannot infer an internal placeholder of type "Type" in environment: + +x' := ?42 : ?41 +. *) +End a. + +Module b. + Notation foo x := (let x' := x in let y := ($(exact I)$ : True) in I). + Notation bar x := (let x' := x in let y := (I : True) in I). + + Check let x' := _ in $(exact I)$. (* let x' := ?5 in I *) + Check bar _. (* let x' := ?9 in let y := I in I *) + Fail Check foo _. (* Error: +Cannot infer an internal placeholder of type "Type" in environment: + +x' := ?42 : ?41 +. *) +End b. diff --git a/test-suite/bugs/opened/3283.v b/test-suite/bugs/opened/3283.v new file mode 100644 index 00000000..3ab5416e --- /dev/null +++ b/test-suite/bugs/opened/3283.v @@ -0,0 +1,28 @@ +Notation "P |-- Q" := (@eq nat P Q) (at level 80, Q at level 41, no associativity) . +Notation "x &&& y" := (plus x y) (at level 40, left associativity, y at next level) . +Notation "'Ex' x , P " := (plus x P) (at level 65, x at level 99, P at level 80). + +(* Succeed *) +Check _ |-- _ &&& _ -> _. +Check _ |-- _ &&& (Ex _, _ ) -> _. +Check _ |-- (_ &&& Ex _, _ ) -> _. + +(* Why does this fail? *) +Fail Check _ |-- _ &&& Ex _, _ -> _. +(* The command has indeed failed with message: +=> Error: The term "Ex ?17, ?18" has type "nat" +which should be Set, Prop or Type. *) + +(* Just in case something is strange with -> *) +Notation "P ----> Q" := (P -> Q) (right associativity, at level 99, Q at next level). + +(* Succeed *) +Check _ |-- _ &&& _ ----> _. +Check _ |-- _ &&& (Ex _, _ ) ----> _. +Check _ |-- (_ &&& Ex _, _ ) ----> _. + +(* Why does this fail? *) +Fail Check _ |-- _ &&& Ex _, _ ----> _. +(* The command has indeed failed with message: +=> Error: The term "Ex ?31, ?32" has type "nat" +which should be Set, Prop or Type.*) diff --git a/test-suite/bugs/opened/3295.v b/test-suite/bugs/opened/3295.v new file mode 100644 index 00000000..2a156e33 --- /dev/null +++ b/test-suite/bugs/opened/3295.v @@ -0,0 +1,104 @@ +Require Export Morphisms Setoid. + +Class lops := lmk_ops { + car: Type; + weq: relation car +}. + +Implicit Arguments car []. + +Coercion car: lops >-> Sortclass. + +Instance weq_Equivalence `{lops}: Equivalence weq. +Proof. +Admitted. + +Module lset. +Canonical Structure lset_ops A := lmk_ops (list A) (fun h k => True). +End lset. + +Class ops := mk_ops { + ob: Type; + mor: ob -> ob -> lops; + dot: forall n m p, mor n m -> mor m p -> mor n p +}. +Coercion mor: ops >-> Funclass. +Implicit Arguments ob []. + +Instance dot_weq `{ops} n m p: Proper (weq ==> weq ==> weq) (dot n m p). +Proof. +Admitted. + +Section s. + +Import lset. + +Context `{X:lops} {I: Type}. + +Axiom sup : forall (f: I -> X) (J : list I), X. + +Global Instance sup_weq: Proper (pointwise_relation _ weq ==> weq ==> weq) sup. +Proof. +Admitted. + +End s. + +Axiom ord : forall (n : nat), Type. +Axiom seq : forall n, list (ord n). + +Infix "==" := weq (at level 79). +Infix "*" := (dot _ _ _) (left associativity, at level 40). + +Notation "∑_ ( i ∈ l ) f" := (@sup (mor _ _) _ (fun i => f) l) + (at level 41, f at level 41, i, l at level 50). + +Axiom dotxsum : forall `{X : ops} I J n m p (f: I -> X m n) (x: X p m) y, + x * (∑_(i∈ J) f i) == y. + +Definition mx X n m := ord n -> ord m -> X. + +Section bsl. +Context `{X : ops} {u: ob X}. +Notation U := (car (@mor X u u)). + +Lemma toto n m p q (M : mx U n m) N (P : mx U p q) Q i j : ∑_(j0 ∈ seq m) M i j0 * (∑_(j1 ∈ seq p) N j0 j1 * P j1 j) == Q. +Proof. + Fail setoid_rewrite dotxsum. + (* Toplevel input, characters 0-22: +Error: +Tactic failure:setoid rewrite failed: Unable to satisfy the rewriting constraints. +Unable to satisfy the following constraints: +UNDEFINED EVARS: + ?101==[X u n m p q M N P Q i j j0 |- U] (goal evar) + ?106==[X u n m p q M N P Q i j |- relation (X u u)] (internal placeholder) + ?107==[X u n m p q M N P Q i j |- relation (list (ord m))] + (internal placeholder) + ?108==[X u n m p q M N P Q i j (do_subrelation:=do_subrelation) + |- Proper (pointwise_relation (ord m) weq ==> ?107 ==> ?106) sup] + (internal placeholder) + ?109==[X u n m p q M N P Q i j |- ProperProxy ?107 (seq m)] + (internal placeholder) + ?110==[X u n m p q M N P Q i j |- relation (X u u)] (internal placeholder) + ?111==[X u n m p q M N P Q i j (do_subrelation:=do_subrelation) + |- Proper (?106 ==> ?110 ==> Basics.flip Basics.impl) weq] + (internal placeholder) + ?112==[X u n m p q M N P Q i j |- ProperProxy ?110 Q] (internal placeholder)UNIVERSES: + {} |= Top.14 <= Top.37 + Top.25 <= Top.24 + Top.25 <= Top.32 + +ALGEBRAIC UNIVERSES:{} +UNDEFINED UNIVERSES:METAS: + 470[y] := ?101 : car (?99 ?467 ?465) + 469[x] := M i _UNBOUND_REL_1 : car (?99 ?467 ?466) [type is checked] + 468[f] := fun i : ?463 => N _UNBOUND_REL_2 i * P i j : + ?463 -> ?99 ?466 ?465 [type is checked] + 467[p] := u : ob ?99 [type is checked] + 466[m] := u : ob ?99 [type is checked] + 465[n] := u : ob ?99 [type is checked] + 464[J] := seq p : list ?463 [type is checked] + 463[I] := ord p : Type [type is checked] + *) +Abort. + +End bsl. diff --git a/test-suite/bugs/opened/3298.v b/test-suite/bugs/opened/3298.v new file mode 100644 index 00000000..bce7c3f2 --- /dev/null +++ b/test-suite/bugs/opened/3298.v @@ -0,0 +1,23 @@ +Module JGross. + Hint Extern 1 => match goal with |- match ?E with end => case E end. + + Goal forall H : False, match H return Set with end. + Proof. + intros. + Fail solve [ eauto ]. (* No applicable tactic *) + admit. + Qed. +End JGross. + +Section BenDelaware. + Hint Extern 0 => admit. + Goal forall (H : False), id (match H return Set with end). + Proof. + eauto. + Qed. + Goal forall (H : False), match H return Set with end. + Proof. + Fail solve [ eauto ] . + admit. + Qed. +End BenDelaware. diff --git a/test-suite/bugs/opened/3304.v b/test-suite/bugs/opened/3304.v new file mode 100644 index 00000000..529cc737 --- /dev/null +++ b/test-suite/bugs/opened/3304.v @@ -0,0 +1,3 @@ +Fail Notation "( x , y , .. , z )" := $(let r := constr:(prod .. (prod x y) .. z) in r)$. +(* The command has indeed failed with message: +=> Error: Special token .. is for use in the Notation command. *) diff --git a/test-suite/bugs/opened/3311.v b/test-suite/bugs/opened/3311.v new file mode 100644 index 00000000..1c66bc1e --- /dev/null +++ b/test-suite/bugs/opened/3311.v @@ -0,0 +1,10 @@ +Require Import Setoid. +Axiom bar : True = False. +Goal True. + Fail setoid_rewrite bar. (* Toplevel input, characters 15-33: +Error: +Tactic failure:setoid rewrite failed: Unable to satisfy the rewriting constraints. + +Could not find an instance for "subrelation eq (Basics.flip Basics.impl)". +With the following constraints: +?3 : "True" *) diff --git a/test-suite/bugs/opened/3312.v b/test-suite/bugs/opened/3312.v new file mode 100644 index 00000000..749921e2 --- /dev/null +++ b/test-suite/bugs/opened/3312.v @@ -0,0 +1,5 @@ +Require Import Setoid. +Axiom bar : 0 = 1. +Goal 0 = 1. + Fail rewrite_strat bar. (* Toplevel input, characters 15-32: +Error: Tactic failure:setoid rewrite failed: Nothing to rewrite. *) diff --git a/test-suite/bugs/opened/3320.v b/test-suite/bugs/opened/3320.v new file mode 100644 index 00000000..05cf7328 --- /dev/null +++ b/test-suite/bugs/opened/3320.v @@ -0,0 +1,4 @@ +Goal forall x : nat, True. + fix 1. + assumption. +Fail Qed. diff --git a/test-suite/bugs/opened/3326.v b/test-suite/bugs/opened/3326.v new file mode 100644 index 00000000..f73117a2 --- /dev/null +++ b/test-suite/bugs/opened/3326.v @@ -0,0 +1,18 @@ +Class ORDER A := Order { + LEQ : A -> A -> bool; + leqRefl: forall x, true = LEQ x x +}. + +Section XXX. + +Variable A:Type. +Variable (O:ORDER A). +Definition aLeqRefl := @leqRefl _ O. + +Lemma OK : forall x, true = LEQ x x. + intros. + unfold LEQ. + destruct O. + clear. + Fail apply aLeqRefl. (* Toplevel input, characters 15-30: +Anomaly: Uncaught exception Not_found(_). Please report. *) diff --git a/test-suite/bugs/opened/3343.v b/test-suite/bugs/opened/3343.v new file mode 100644 index 00000000..6c5a85f9 --- /dev/null +++ b/test-suite/bugs/opened/3343.v @@ -0,0 +1,46 @@ +(* File reduced by coq-bug-finder from original input, then from 13699 lines to 656 lines, then from 584 lines to 200 lines *) +Set Asymmetric Patterns. +Require Export Coq.Lists.List. +Export List.ListNotations. + +Record CFGV := { Terminal : Type; VarSym : Type }. + +Section Gram. + Context {G : CFGV}. + + Inductive Pattern : (Terminal G) -> Type := + | ptleaf : forall (T : Terminal G), + nat -> Pattern T + with Mixture : list (Terminal G) -> Type := + | mtcons : forall {h: Terminal G} + {tl: list (Terminal G)}, + Pattern h -> Mixture tl -> Mixture (h::tl). + + Variable vc : VarSym G. + + Fixpoint pBVars {gs} (p : Pattern gs) : (list nat) := + match p with + | ptleaf _ _ => [] + end + with mBVars {lgs} (pts : Mixture lgs) : (list nat) := + match pts with + | mtcons _ _ _ tl => mBVars tl + end. + + Lemma mBndngVarsAsNth : + forall mp (m : @Mixture mp), + mBVars m = [2]. + Proof. + intros. + induction m. progress simpl. + Admitted. +End Gram. + +Lemma mBndngVarsAsNth' {G : CFGV} { vc : VarSym G} : + forall mp (m : @Mixture G mp), + mBVars m = [2]. +Proof. + intros. + induction m. + Fail progress simpl. + (* simpl did nothing here, while it does something inside the section; this is probably a bug*) diff --git a/test-suite/bugs/opened/3345.v b/test-suite/bugs/opened/3345.v new file mode 100644 index 00000000..b61174a8 --- /dev/null +++ b/test-suite/bugs/opened/3345.v @@ -0,0 +1,144 @@ +(* File reduced by coq-bug-finder from original input, then from 1972 lines to 136 lines, then from 119 lines to 105 lines *) +Global Set Implicit Arguments. +Require Import Coq.Lists.List Program. +Section IndexBound. + Context {A : Set}. + Class IndexBound (a : A) (Bound : list A) := + { ibound :> nat; + boundi : nth_error Bound ibound = Some a}. + Global Arguments ibound [a Bound] _ . + Global Arguments boundi [a Bound] _. + Record BoundedIndex (Bound : list A) := { bindex :> A; indexb :> IndexBound bindex Bound }. +End IndexBound. +Context {A : Type} {C : Set}. +Variable (projAC : A -> C). +Lemma None_neq_Some +: forall (AnyT AnyT' : Type) (a : AnyT), + None = Some a -> AnyT'. + admit. +Defined. +Program Definition nth_Bounded' + (Bound : list A) + (c : C) + (a_opt : option A) + (nth_n : option_map projAC a_opt = Some c) +: A := match a_opt as x + return (option_map projAC x = Some c) -> A with + | Some a => fun _ => a + | None => fun f : None = Some _ => ! + end nth_n. +Lemma nth_error_map : + forall n As c_opt, + nth_error (map projAC As) n = c_opt + -> option_map projAC (nth_error As n) = c_opt. + admit. +Defined. +Definition nth_Bounded + (Bound : list A) + (idx : BoundedIndex (map projAC Bound)) +: A := nth_Bounded' Bound (nth_error Bound (ibound idx)) + (nth_error_map _ _ (boundi idx)). +Program Definition nth_Bounded_ind2 + (P : forall As, BoundedIndex (map projAC As) + -> BoundedIndex (map projAC As) + -> A -> A -> Prop) +: forall (Bound : list A) + (idx : BoundedIndex (map projAC Bound)) + (idx' : BoundedIndex (map projAC Bound)), + match nth_error Bound (ibound idx), nth_error Bound (ibound idx') with + | Some a, Some a' => P Bound idx idx' a a' + | _, _ => True + end + -> P Bound idx idx' (nth_Bounded _ idx) (nth_Bounded _ idx'):= + fun Bound idx idx' => + match (nth_error Bound (ibound idx)) as e, (nth_error Bound (ibound idx')) as e' + return + (forall (f : option_map _ e = Some (bindex idx)) + (f' : option_map _ e' = Some (bindex idx')), + (match e, e' with + | Some a, Some a' => P Bound idx idx' a a' + | _, _ => True + end) + -> P Bound idx idx' + (match e as e'' return + option_map _ e'' = Some (bindex idx) + -> A + with + | Some a => fun _ => a + | _ => fun f => _ + end f) + (match e' as e'' return + option_map _ e'' = Some (bindex idx') + -> A + with + | Some a => fun _ => a + | _ => fun f => _ + end f')) with + | Some a, Some a' => fun _ _ H => _ + | _, _ => fun f => _ + end (nth_error_map _ _ (boundi idx)) + (nth_error_map _ _ (boundi idx')). + +Lemma nth_Bounded_eq +: forall (Bound : list A) + (idx idx' : BoundedIndex (map projAC Bound)), + ibound idx = ibound idx' + -> nth_Bounded Bound idx = nth_Bounded Bound idx'. +Proof. + intros. + eapply nth_Bounded_ind2 with (idx := idx) (idx' := idx'). + simpl. + (* The [case_eq] should not Fail. More importantly, [Fail case_eq ...] should succeed if [case_eq ...] fails. It doesn't!!! So I resort to [Fail Fail try (case_eq ...)]. *) + Fail Fail try (case_eq (nth_error Bound (ibound idx'))). +(* Toplevel input, characters 15-54: +In nested Ltac calls to "case_eq" and "pattern x at - 1", last call failed. +Error: The abstracted term +"fun e : Exc A => + forall e0 : nth_error Bound (ibound idx') = e, + match + nth_error Bound (ibound idx) as anonymous'0 + return (anonymous'0 = nth_error Bound (ibound idx) -> e = e -> Prop) + with + | Some a => + match + e as anonymous' + return + (Some a = nth_error Bound (ibound idx) -> anonymous' = e -> Prop) + with + | Some a' => + fun (_ : Some a = nth_error Bound (ibound idx)) (_ : Some a' = e) => + a = a' + | None => + fun (_ : Some a = nth_error Bound (ibound idx)) (_ : None = e) => + True + end + | None => fun (_ : None = nth_error Bound (ibound idx)) (_ : e = e) => True + end eq_refl e0" is not well typed. +Illegal application: +The term + "match + nth_error Bound (ibound idx) as anonymous'0 + return (anonymous'0 = nth_error Bound (ibound idx) -> e = e -> Prop) + with + | Some a => + match + e as anonymous' + return + (Some a = nth_error Bound (ibound idx) -> anonymous' = e -> Prop) + with + | Some a' => + fun (_ : Some a = nth_error Bound (ibound idx)) (_ : Some a' = e) => + a = a' + | None => + fun (_ : Some a = nth_error Bound (ibound idx)) (_ : None = e) => + True + end + | None => fun (_ : None = nth_error Bound (ibound idx)) (_ : e = e) => True + end" of type + "nth_error Bound (ibound idx) = nth_error Bound (ibound idx) -> + e = e -> Prop" +cannot be applied to the terms + "eq_refl" : "nth_error Bound (ibound idx) = nth_error Bound (ibound idx)" + "e0" : "nth_error Bound (ibound idx') = e" +The 2nd term has type "nth_error Bound (ibound idx') = e" +which should be coercible to "e = e". *) diff --git a/test-suite/bugs/opened/3357.v b/test-suite/bugs/opened/3357.v new file mode 100644 index 00000000..c4791588 --- /dev/null +++ b/test-suite/bugs/opened/3357.v @@ -0,0 +1,9 @@ +Notation D1 := (forall {T : Type} ( x : T ) , Type). + +Definition DD1 ( A : forall {T : Type} (x : T), Type ) := A 1. +Fail Definition DD1' ( A : D1 ) := A 1. (* Toplevel input, characters 32-33: +Error: In environment +A : forall T : Type, T -> Type +The term "1" has type "nat" while it is expected to have type +"Type". + *) diff --git a/test-suite/bugs/opened/3363.v b/test-suite/bugs/opened/3363.v new file mode 100644 index 00000000..800d8957 --- /dev/null +++ b/test-suite/bugs/opened/3363.v @@ -0,0 +1,26 @@ +(** In this file, either all four [Check]s should fail, or all four should succeed. *) +Module A. + Section HexStrings. + Require Import String. + End HexStrings. + Fail Check string. +End A. + +Module B. + Section HexStrings. + Require String. + Import String. + End HexStrings. + Fail Check string. +End B. + +Section HexStrings. + Require String. + Import String. +End HexStrings. +Fail Check string. + +Section HexStrings'. + Require Import String. +End HexStrings'. +Check string. diff --git a/test-suite/bugs/opened/3370.v b/test-suite/bugs/opened/3370.v new file mode 100644 index 00000000..4964bf96 --- /dev/null +++ b/test-suite/bugs/opened/3370.v @@ -0,0 +1,12 @@ +Require Import String. + +Local Ltac set_strings := + let s := match goal with |- context[String ?s1 ?s2] => constr:(String s1 s2) end in + let H := fresh s in + set (H := s). + +Local Open Scope string_scope. + +Goal "asdf" = "bds". +Fail set_strings. (* Error: Ltac variable s is bound to "asdf" which cannot be coerced to +a fresh identifier. *) diff --git a/test-suite/bugs/opened/3383.v b/test-suite/bugs/opened/3383.v new file mode 100644 index 00000000..9a14641a --- /dev/null +++ b/test-suite/bugs/opened/3383.v @@ -0,0 +1,7 @@ +Goal forall b : bool, match b as b' return if b' then True else True with true => I | false => I end = match b as b' return if b' then True else True with true => I | false => I end. +intro. +Fail lazymatch goal with +| [ |- appcontext[match ?b as b' return @?P b' with true => ?t | false => ?f end] ] + => change (match b as b' return P b with true => t | false => f end) with (@bool_rect P t f) +end. (* Toplevel input, characters 153-154: +Error: The reference P was not found in the current environment. *) diff --git a/test-suite/bugs/opened/3395.v b/test-suite/bugs/opened/3395.v new file mode 100644 index 00000000..ff0dbf97 --- /dev/null +++ b/test-suite/bugs/opened/3395.v @@ -0,0 +1,230 @@ +(* File reduced by coq-bug-finder from originally 10918 lines, then 3649 lines to 3177 lines, then from 3189 lines to 3164 lines, then from 2653 lines to 2496 lines, 2653 lines, then from 1642 lines to 651 lines, then from 736 lines to 473 lines, then from 433 lines to 275 lines, then from 258 lines to 235 lines. *) +Generalizable All Variables. +Set Implicit Arguments. + +Arguments fst {_ _} _. +Arguments snd {_ _} _. + +Axiom cheat : forall {T}, T. + +Reserved Notation "g 'o' f" (at level 40, left associativity). + +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y" := (paths x y) : type_scope. + +Definition symmetry {A : Type} {x y : A} (p : x = y) : y = x + := match p with idpath => idpath end. + +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope object_scope with object. +Record PreCategory (object : Type) := + Build_PreCategory' { + object :> Type := object; + morphism : object -> object -> Type; + identity : forall x, morphism x x; + compose : forall s d d', + morphism d d' + -> morphism s d + -> morphism s d' + where "f 'o' g" := (compose f g); + associativity : forall x1 x2 x3 x4 + (m1 : morphism x1 x2) + (m2 : morphism x2 x3) + (m3 : morphism x3 x4), + (m3 o m2) o m1 = m3 o (m2 o m1); + associativity_sym : forall x1 x2 x3 x4 + (m1 : morphism x1 x2) + (m2 : morphism x2 x3) + (m3 : morphism x3 x4), + m3 o (m2 o m1) = (m3 o m2) o m1; + left_identity : forall a b (f : morphism a b), identity b o f = f; + right_identity : forall a b (f : morphism a b), f o identity a = f; + identity_identity : forall x, identity x o identity x = identity x + }. +Bind Scope category_scope with PreCategory. +Arguments PreCategory {_}. +Arguments identity {_} [!C%category] x%object : rename. + +Arguments compose {_} [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename. + +Infix "o" := compose : morphism_scope. + +Delimit Scope functor_scope with functor. +Local Open Scope morphism_scope. +Record Functor `(C : @PreCategory objC, D : @PreCategory objD) := + { + object_of :> C -> D; + morphism_of : forall s d, morphism C s d + -> morphism D (object_of s) (object_of d); + composition_of : forall s d d' + (m1 : morphism C s d) (m2: morphism C d d'), + morphism_of _ _ (m2 o m1) + = (morphism_of _ _ m2) o (morphism_of _ _ m1); + identity_of : forall x, morphism_of _ _ (identity x) + = identity (object_of x) + }. +Bind Scope functor_scope with Functor. + +Arguments morphism_of {_} [C%category] {_} [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch. + +Notation "F '_1' m" := (morphism_of F m) (at level 10, no associativity) : morphism_scope. + +Class IsIsomorphism `{C : @PreCategory objC} {s d} (m : morphism C s d) := + { + morphism_inverse : morphism C d s; + left_inverse : morphism_inverse o m = identity _; + right_inverse : m o morphism_inverse = identity _ + }. + +Definition opposite `(C : @PreCategory objC) : PreCategory + := @Build_PreCategory' + C + (fun s d => morphism C d s) + (identity (C := C)) + (fun _ _ _ m1 m2 => m2 o m1) + (fun _ _ _ _ _ _ _ => @associativity_sym _ _ _ _ _ _ _ _ _) + (fun _ _ _ _ _ _ _ => @associativity _ _ _ _ _ _ _ _ _) + (fun _ _ => @right_identity _ _ _ _) + (fun _ _ => @left_identity _ _ _ _) + (@identity_identity _ C). + +Notation "C ^op" := (opposite C) (at level 3) : category_scope. + +Definition prod `(C : @PreCategory objC, D : @PreCategory objD) : @PreCategory (objC * objD). + refine (@Build_PreCategory' + (C * D)%type + (fun s d => (morphism C (fst s) (fst d) + * morphism D (snd s) (snd d))%type) + (fun x => (identity (fst x), identity (snd x))) + (fun s d d' m2 m1 => (fst m2 o fst m1, snd m2 o snd m1)) + _ + _ + _ + _ + _); admit. +Defined. +Infix "*" := prod : category_scope. + +Definition compose_functor `(C : @PreCategory objC, D : @PreCategory objD, E : @PreCategory objE) (G : Functor D E) (F : Functor C D) : Functor C E + := Build_Functor + C E + (fun c => G (F c)) + (fun _ _ m => morphism_of G (morphism_of F m)) + cheat + cheat. + +Infix "o" := compose_functor : functor_scope. + +Record NaturalTransformation `(C : @PreCategory objC, D : @PreCategory objD) (F G : Functor C D) := + Build_NaturalTransformation' { + components_of :> forall c, morphism D (F c) (G c); + commutes : forall s d (m : morphism C s d), + components_of d o F _1 m = G _1 m o components_of s; + + commutes_sym : forall s d (m : C.(morphism) s d), + G _1 m o components_of s = components_of d o F _1 m + }. +Definition functor_category `(C : @PreCategory objC, D : @PreCategory objD) : PreCategory + := @Build_PreCategory' (Functor C D) + (@NaturalTransformation _ C _ D) + cheat + cheat + cheat + cheat + cheat + cheat + cheat. + +Definition opposite_functor `(F : @Functor objC C objD D) : Functor C^op D^op + := Build_Functor (C^op) (D^op) + (object_of F) + (fun s d => morphism_of F (s := d) (d := s)) + (fun d' d s m1 m2 => composition_of F s d d' m2 m1) + (identity_of F). + +Definition opposite_invL `(F : @Functor objC C^op objD D) : Functor C D^op + := Build_Functor C (D^op) + (object_of F) + (fun s d => morphism_of F (s := d) (d := s)) + (fun d' d s m1 m2 => composition_of F s d d' m2 m1) + (identity_of F). +Notation "F ^op" := (opposite_functor F) : functor_scope. + +Notation "F ^op'L" := (opposite_invL F) (at level 3) : functor_scope. +Definition fst `{C : @PreCategory objC, D : @PreCategory objD} : Functor (C * D) C + := Build_Functor (C * D) C + (@fst _ _) + (fun _ _ => @fst _ _) + (fun _ _ _ _ _ => idpath) + (fun _ => idpath). + +Definition snd `{C : @PreCategory objC, D : @PreCategory objD} : Functor (C * D) D + := Build_Functor (C * D) D + (@snd _ _) + (fun _ _ => @snd _ _) + (fun _ _ _ _ _ => idpath) + (fun _ => idpath). +Definition prod_functor `(F : @Functor objC C objD D, F' : @Functor objC C objD' D') +: Functor C (D * D') + := Build_Functor + C (D * D') + (fun c => (F c, F' c)) + (fun s d m => (F _1 m, F' _1 m))%morphism + cheat + cheat. +Definition pair `(F : @Functor objC C objD D, F' : @Functor objC' C' objD' D') : Functor (C * C') (D * D') + := (prod_functor (F o fst) (F' o snd))%functor. +Notation cat_of obj := + (@Build_PreCategory' obj + (fun x y => forall _ : x, y) + (fun _ x => x) + (fun _ _ _ f g x => f (g x))%core + (fun _ _ _ _ _ _ _ => idpath) + (fun _ _ _ _ _ _ _ => idpath) + (fun _ _ _ => idpath) + (fun _ _ _ => idpath) + (fun _ => idpath)). + +Definition hom_functor `(C : @PreCategory objC) : Functor (C^op * C) (cat_of Type) + := Build_Functor _ _ cheat cheat cheat cheat. + +Definition induced_hom_natural_transformation `(F : @Functor objC C objD D) +: NaturalTransformation (hom_functor C) (hom_functor D o pair F^op F) + := Build_NaturalTransformation' _ _ cheat cheat cheat. + +Class IsFullyFaithful `(F : @Functor objC C objD D) + := is_fully_faithful + : forall x y : C, + IsIsomorphism (induced_hom_natural_transformation F (x, y)). + +Definition coyoneda `(A : @PreCategory objA) : Functor A^op (@functor_category _ A _ (cat_of Type)) + := cheat. + +Definition yoneda `(A : @PreCategory objA) : Functor A (@functor_category _ A^op _ (cat_of Type)) + := (((coyoneda A^op)^op'L)^op'L)%functor. +Definition coyoneda_embedding `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@coyoneda _ A). +Admitted. + +Definition yoneda_embedding_fast `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@yoneda _ A). +Proof. + intros a b. + pose proof (coyoneda_embedding A^op a b) as CYE. + unfold yoneda. + Time let t := (type of CYE) in + let t' := (eval simpl in t) in pose proof ((fun (x : t) => (x : t')) CYE) as CYE'. (* Finished transaction in 0. secs (0.216013u,0.004s) *) + Fail Timeout 1 let t := match goal with |- ?G => constr:(G) end in + let t' := (eval simpl in t) in exact ((fun (x : t') => (x : t)) CYE'). + Time let t := match goal with |- ?G => constr:(G) end in + let t' := (eval simpl in t) in exact ((fun (x : t') => (x : t)) CYE'). (* Finished transaction in 0. secs (0.248016u,0.s) *) +Fail Timeout 2 Defined. +Time Defined. (* Finished transaction in 1. secs (0.432027u,0.s) *) + +Definition yoneda_embedding `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@yoneda _ A). +Proof. + intros a b. + pose proof (coyoneda_embedding A^op a b) as CYE. + unfold yoneda; simpl in *. + Fail Timeout 1 exact CYE. + Time exact CYE. (* Finished transaction in 0. secs (0.012001u,0.s) *) diff --git a/test-suite/bugs/opened/3410.v b/test-suite/bugs/opened/3410.v new file mode 100644 index 00000000..0d259181 --- /dev/null +++ b/test-suite/bugs/opened/3410.v @@ -0,0 +1 @@ +Fail repeat match goal with H:_ |- _ => setoid_rewrite X in H end. diff --git a/test-suite/bugs/opened/3459.v b/test-suite/bugs/opened/3459.v new file mode 100644 index 00000000..9e6107b3 --- /dev/null +++ b/test-suite/bugs/opened/3459.v @@ -0,0 +1,31 @@ +(* Bad interaction between clear and the typability of ltac constr bindings *) + +(* Original report *) + +Goal 1 = 2. +Proof. +(* This line used to fail with a Not_found up to some point, and then + to produce an ill-typed term *) +match goal with + | [ |- context G[2] ] => let y := constr:(fun x => $(let r := constr:(@eq Set x x) in + clear x; + exact r)$) in + pose y +end. +(* Add extra test for typability (should not fail when bug closed) *) +Fail match goal with P:?c |- _ => try (let x := type of c in idtac) || fail 2 end. +Abort. + +(* Second report raising a Not_found at the time of 21 Oct 2014 *) + +Section F. + +Variable x : nat. + +Goal True. +evar (e : Prop). +assert e. +Fail let r := constr:(eq_refl x) in clear x; exact r. +Abort. + +End F. diff --git a/test-suite/bugs/opened/3461.v b/test-suite/bugs/opened/3461.v new file mode 100644 index 00000000..1b625e6a --- /dev/null +++ b/test-suite/bugs/opened/3461.v @@ -0,0 +1,5 @@ +Lemma foo (b : bool) : + exists x : nat, x = x. +Proof. +eexists. +Fail eexact (eq_refl b). diff --git a/test-suite/bugs/opened/3463.v b/test-suite/bugs/opened/3463.v new file mode 100644 index 00000000..541db37f --- /dev/null +++ b/test-suite/bugs/opened/3463.v @@ -0,0 +1,13 @@ +Tactic Notation "test1" open_constr(t) ident(r):= + pose t. +Tactic Notation "test2" constr(r) open_constr(t):= + pose t. +Tactic Notation "test3" open_constr(t) constr(r):= + pose t. + +Goal True. + test1 (1 + _) nat. + test2 nat (1 + _). + test3 (1 + _) nat. + test3 (1 + _ : nat) nat. + diff --git a/test-suite/bugs/opened/3467.v b/test-suite/bugs/opened/3467.v new file mode 100644 index 00000000..900bfc34 --- /dev/null +++ b/test-suite/bugs/opened/3467.v @@ -0,0 +1,6 @@ +Module foo. + Notation x := $(exact I)$. +End foo. +Module bar. + Fail Include foo. +End bar. diff --git a/test-suite/bugs/opened/3478.v-disabled b/test-suite/bugs/opened/3478.v-disabled new file mode 100644 index 00000000..cc926b21 --- /dev/null +++ b/test-suite/bugs/opened/3478.v-disabled @@ -0,0 +1,8 @@ +Set Primitive Projections. +Record foo := { foom :> Type }. +Canonical Structure default_foo := fun T => {| foom := T |}. +Record bar T := { bar1 : T }. +Goal forall (s : foo) (x : foom s), True. +Proof. + intros. + Timeout 1 pose (x : bar _) as x'.
\ No newline at end of file diff --git a/test-suite/bugs/opened/3490.v b/test-suite/bugs/opened/3490.v new file mode 100644 index 00000000..e7a5caa1 --- /dev/null +++ b/test-suite/bugs/opened/3490.v @@ -0,0 +1,27 @@ +Inductive T : Type := +| Var : nat -> T +| Arr : T -> T -> T. + +Inductive Tele : list T -> Type := +| Tnil : @Tele nil +| Tcons : forall ls, forall (t : @Tele ls) (l : T), @Tele (l :: ls). + +Fail Fixpoint TeleD (ls : list T) (t : Tele ls) {struct t} + : { x : Type & x -> nat -> Type } := + match t return { x : Type & x -> nat -> Type } with + | Tnil => @existT Type (fun x => x -> nat -> Type) unit (fun (_ : unit) (_ : nat) => unit) + | Tcons ls t' l => + let (result, get) := TeleD ls t' in + @existT Type (fun x => x -> nat -> Type) + { v : result & (fix TD (t : T) {struct t} := + match t with + | Var n => + get v n + | Arr a b => TD a -> TD b + end) l } + (fun x n => + match n return Type with + | 0 => projT2 x + | S n => get (projT1 x) n + end) + end. diff --git a/test-suite/bugs/opened/3491.v b/test-suite/bugs/opened/3491.v new file mode 100644 index 00000000..9837b0ec --- /dev/null +++ b/test-suite/bugs/opened/3491.v @@ -0,0 +1,2 @@ +Fail Inductive list (A : Type) (T := A) : Type := + nil : list A | cons : T -> list T -> list A. diff --git a/test-suite/bugs/opened/3509.v b/test-suite/bugs/opened/3509.v new file mode 100644 index 00000000..02e47a8b --- /dev/null +++ b/test-suite/bugs/opened/3509.v @@ -0,0 +1,18 @@ +Lemma match_bool_fn b A B xT xF +: match b as b return forall x : A, B b x with + | true => xT + | false => xF + end + = fun x : A => match b as b return B b x with + | true => xT x + | false => xF x + end. +admit. +Defined. +Lemma match_bool_comm_1 (b : bool) A B (F : forall x : A, B x) t f +: (if b as b return B (if b then t else f) then F t else F f) + = F (if b then t else f). +admit. +Defined. +Hint Rewrite match_bool_fn : matchdb. +Fail Hint Rewrite match_bool_comm_1 : matchdb. diff --git a/test-suite/bugs/opened/3510.v b/test-suite/bugs/opened/3510.v new file mode 100644 index 00000000..25285636 --- /dev/null +++ b/test-suite/bugs/opened/3510.v @@ -0,0 +1,34 @@ +Lemma match_option_fn T (b : option T) A B s n +: match b as b return forall x : A, B b x with + | Some k => s k + | None => n + end + = fun x : A => match b as b return B b x with + | Some k => s k x + | None => n x + end. +admit. +Defined. +Lemma match_option_comm_2 T (p : option T) A B R (f : forall (x : A) (y : B x), R x y) (s1 : T -> A) (s2 : forall x : T, B (s1 x)) n1 n2 +: match p as p return R match p with + | Some k => s1 k + | None => n1 + end + match p as p return B match p with Some k => s1 k | None => n1 end with + | Some k => s2 k + | None => n2 + end with + | Some k => f (s1 k) (s2 k) + | None => f n1 n2 + end + = f match p return A with + | Some k => s1 k + | None => n1 + end + match p as p return B match p with Some k => s1 k | None => n1 end with + | Some k => s2 k + | None => n2 + end. +admit. +Defined. +Fail Hint Rewrite match_option_fn match_option_comm_2 : matchdb. diff --git a/test-suite/bugs/opened/3554.v b/test-suite/bugs/opened/3554.v new file mode 100644 index 00000000..422c5770 --- /dev/null +++ b/test-suite/bugs/opened/3554.v @@ -0,0 +1 @@ +Fail Example foo (f : forall {_ : Type}, Type) : Type. diff --git a/test-suite/bugs/opened/3562.v b/test-suite/bugs/opened/3562.v new file mode 100644 index 00000000..04a1223b --- /dev/null +++ b/test-suite/bugs/opened/3562.v @@ -0,0 +1,2 @@ +Theorem t: True. +Fail destruct 0 as x. diff --git a/test-suite/bugs/opened/3626.v b/test-suite/bugs/opened/3626.v new file mode 100644 index 00000000..46a6c009 --- /dev/null +++ b/test-suite/bugs/opened/3626.v @@ -0,0 +1,7 @@ +Set Implicit Arguments. +Set Primitive Projections. +Record prod A B := pair { fst : A ; snd : B }. + +Fail Goal forall x y : prod Set Set, x.(@fst) = y.(@fst). +(* intros. + apply f_equal. *) diff --git a/test-suite/bugs/opened/3655.v b/test-suite/bugs/opened/3655.v new file mode 100644 index 00000000..841f77fe --- /dev/null +++ b/test-suite/bugs/opened/3655.v @@ -0,0 +1,9 @@ +Ltac bar x := pose x. +Tactic Notation "foo" open_constr(x) := bar x. +Class baz := { baz' : Type }. +Goal True. +(* Original error was an anomaly which is fixed; now, it succeeds but + leaving an evar, while calling pose would not leave an evar, so I + guess it is still a bug in the sense that the semantics of pose is + not preserved *) + foo baz'. diff --git a/test-suite/bugs/opened/3657.v b/test-suite/bugs/opened/3657.v new file mode 100644 index 00000000..6faec076 --- /dev/null +++ b/test-suite/bugs/opened/3657.v @@ -0,0 +1,33 @@ +(* Set Primitive Projections. *) +Class foo {A} {a : A} := { bar := a; baz : bar = bar }. +Arguments bar {_} _ {_}. +Instance: forall A a, @foo A a. +intros; constructor. +abstract reflexivity. +Defined. +Goal @bar _ Set _ = (@bar _ (fun _ : Set => Set) _) nat. +Proof. + Check (bar Set). + Check (bar (fun _ : Set => Set)). + Fail change (bar (fun _ : Set => Set)) with (bar Set). (* Error: Conversion test raised an anomaly *) + +Abort. + + +Module A. +Universes i j. +Constraint i < j. +Variable foo : Type@{i}. +Goal Type@{i}. + Fail let t := constr:(Type@{j}) in + change Type with t. +Abort. + +Goal Type@{j}. + Fail let t := constr:(Type@{i}) in + change Type with t. + let t := constr:(Type@{i}) in + change t. exact foo. +Defined. + +End A. diff --git a/test-suite/bugs/opened/3670.v b/test-suite/bugs/opened/3670.v new file mode 100644 index 00000000..cf5e9b09 --- /dev/null +++ b/test-suite/bugs/opened/3670.v @@ -0,0 +1,19 @@ +Module Type FOO. + Parameters P Q : Type -> Type. +End FOO. + +Module Type BAR. + Declare Module Export foo : FOO. + Parameter f : forall A, P A -> Q A -> A. +End BAR. + +Module Type BAZ. + Declare Module Export foo : FOO. + Parameter g : forall A, P A -> Q A -> A. +End BAZ. + +Module BAR_FROM_BAZ (baz : BAZ) : BAR. + Import baz. + Module foo <: FOO := foo. + Definition f : forall A, P A -> Q A -> A := g. +End BAR_FROM_BAZ. diff --git a/test-suite/bugs/opened/3675.v b/test-suite/bugs/opened/3675.v new file mode 100644 index 00000000..93227ab8 --- /dev/null +++ b/test-suite/bugs/opened/3675.v @@ -0,0 +1,20 @@ +Set Primitive Projections. +Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x). +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := match p, q with idpath, idpath => idpath end. +Notation "p @ q" := (concat p q) (at level 20) : path_scope. +Axiom ap : forall {A B:Type} (f:A -> B) {x y:A} (p:x = y), f x = f y. +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. +Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A ; eisretr : forall x, f (equiv_inv x) = x }. +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : equiv_scope. +Local Open Scope path_scope. +Local Open Scope equiv_scope. +Generalizable Variables A B C f g. +Lemma isequiv_compose `{IsEquiv A B f} `{IsEquiv B C g} +: IsEquiv (compose g f). +Proof. + refine (Build_IsEquiv A C + (compose g f) + (compose f^-1 g^-1) _). + exact (fun c => ap g (@eisretr _ _ f _ (g^-1 c)) @ (@eisretr _ _ g _ c)). diff --git a/test-suite/bugs/opened/3681.v b/test-suite/bugs/opened/3681.v new file mode 100644 index 00000000..194113c6 --- /dev/null +++ b/test-suite/bugs/opened/3681.v @@ -0,0 +1,20 @@ +Module Type FOO. + Parameters P Q : Type -> Type. +End FOO. + +Module Type BAR. + Declare Module Import foo : FOO. + Parameter f : forall A, P A -> Q A -> A. +End BAR. + +Module Type BAZ. + Declare Module Export foo : FOO. + Parameter g : forall A, P A -> Q A -> A. +End BAZ. + +Module BAR_FROM_BAZ (baz : BAZ) : BAR. + Import baz. + Module foo <: FOO := foo. + Import foo. + Definition f : forall A, P A -> Q A -> A := g. +End BAR_FROM_BAZ. diff --git a/test-suite/bugs/opened/3685.v b/test-suite/bugs/opened/3685.v new file mode 100644 index 00000000..d647b5a8 --- /dev/null +++ b/test-suite/bugs/opened/3685.v @@ -0,0 +1,74 @@ +Set Universe Polymorphism. +Class Funext := { }. +Delimit Scope category_scope with category. +Record PreCategory := { object :> Type ; morphism : object -> object -> Type }. +Set Implicit Arguments. +Record Functor (C D : PreCategory) := + { object_of :> C -> D; + morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d); + identity_of : forall s m, morphism_of s s m = morphism_of s s m }. +Definition sub_pre_cat `{Funext} (P : PreCategory -> Type) : PreCategory. +Proof. + exact (@Build_PreCategory PreCategory Functor). +Defined. +Definition opposite (C : PreCategory) : PreCategory. +Proof. + exact (@Build_PreCategory C (fun s d => morphism C d s)). +Defined. +Local Notation "C ^op" := (opposite C) (at level 3, format "C '^op'") : category_scope. +Definition prod (C D : PreCategory) : PreCategory. +Proof. + refine (@Build_PreCategory + (C * D)%type + (fun s d => (morphism C (fst s) (fst d) * morphism D (snd s) (snd d))%type)). +Defined. +Local Infix "*" := prod : category_scope. +Record NaturalTransformation C D (F G : Functor C D) := {}. +Definition functor_category (C D : PreCategory) : PreCategory. +Proof. + exact (@Build_PreCategory (Functor C D) (@NaturalTransformation C D)). +Defined. +Local Notation "C -> D" := (functor_category C D) : category_scope. +Module Export PointwiseCore. + Local Open Scope category_scope. + Definition pointwise + (C C' : PreCategory) + (F : Functor C' C) + (D D' : PreCategory) + (G : Functor D D') + : Functor (C -> D) (C' -> D'). + Proof. + refine (Build_Functor + (C -> D) (C' -> D') + _ + _ + _); + abstract admit. + Defined. +End PointwiseCore. +Axiom Pidentity_of : forall (C D : PreCategory) (F : Functor C C) (G : Functor D D), pointwise F G = pointwise F G. +Local Open Scope category_scope. +Module Success. + Definition functor_uncurried `{Funext} (P : PreCategory -> Type) + (has_functor_categories : forall C D : sub_pre_cat P, P (C -> D)) + : object (((sub_pre_cat P)^op * (sub_pre_cat P)) -> (sub_pre_cat P)) + := Eval cbv zeta in + let object_of := (fun CD => (((fst CD) -> (snd CD)))) + in Build_Functor + ((sub_pre_cat P)^op * (sub_pre_cat P)) (sub_pre_cat P) + object_of + (fun CD C'D' FG => pointwise (fst FG) (snd FG)) + (fun _ _ => @Pidentity_of _ _ _ _). +End Success. +Module Bad. + Include PointwiseCore. + Fail Definition functor_uncurried `{Funext} (P : PreCategory -> Type) + (has_functor_categories : forall C D : sub_pre_cat P, P (C -> D)) + : object (((sub_pre_cat P)^op * (sub_pre_cat P)) -> (sub_pre_cat P)) + := Eval cbv zeta in + let object_of := (fun CD => (((fst CD) -> (snd CD)))) + in Build_Functor + ((sub_pre_cat P)^op * (sub_pre_cat P)) (sub_pre_cat P) + object_of + (fun CD C'D' FG => pointwise (fst FG) (snd FG)) + (fun _ _ => @Pidentity_of _ _ _ _). diff --git a/test-suite/bugs/opened/3753.v b/test-suite/bugs/opened/3753.v new file mode 100644 index 00000000..05d77c83 --- /dev/null +++ b/test-suite/bugs/opened/3753.v @@ -0,0 +1,4 @@ +Axiom foo : Type -> Type. +Axiom bar : forall (T : Type), T -> foo T. +Arguments bar A x : rename. +Fail About bar. diff --git a/test-suite/bugs/opened/3754.v b/test-suite/bugs/opened/3754.v new file mode 100644 index 00000000..c7441882 --- /dev/null +++ b/test-suite/bugs/opened/3754.v @@ -0,0 +1,282 @@ +(* File reduced by coq-bug-finder from original input, then from 9113 lines to 279 lines *) +(* coqc version trunk (October 2014) compiled on Oct 19 2014 18:56:9 with OCaml 3.12.1 + coqtop version trunk (October 2014) *) + +Notation Type0 := Set. + +Notation idmap := (fun x => x). + +Notation "( x ; y )" := (existT _ x y) : fibration_scope. +Open Scope fibration_scope. + +Notation pr1 := projT1. + +Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope. + +Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := + fun x => g (f x). + +Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope. +Open Scope function_scope. + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Arguments idpath {A a} , [A] a. + +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x. +admit. +Defined. + +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := + match p, q with idpath, idpath => idpath end. + +Notation "1" := idpath : path_scope. + +Notation "p @ q" := (concat p q) (at level 20) : path_scope. + +Notation "p ^" := (inverse p) (at level 3, format "p '^'") : path_scope. + +Notation "p @' q" := (concat p q) (at level 21, left associativity, + format "'[v' p '/' '@'' q ']'") : long_path_scope. +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y. +exact (match p with idpath => u end). +Defined. + +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing) : path_scope. +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y. +exact (match p with idpath => idpath end). +Defined. + +Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) + := forall x:A, f x = g x. + +Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope. + +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := + forall x : A, r (s x) = x. + +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { + equiv_inv : B -> A ; + eisretr : Sect equiv_inv f; + eissect : Sect f equiv_inv; + eisadj : forall x : A, eisretr (f x) = ap f (eissect x) +}. + +Arguments eisretr {A B} f {_} _. + +Record Equiv A B := BuildEquiv { + equiv_fun : A -> B ; + equiv_isequiv : IsEquiv equiv_fun +}. + +Coercion equiv_fun : Equiv >-> Funclass. + +Global Existing Instance equiv_isequiv. + +Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope. + +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : equiv_scope. + +Class Contr_internal (A : Type) := BuildContr { + center : A ; + contr : (forall y : A, center = y) +}. + +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. + +Notation "n .+1" := (trunc_S n) (at level 2, left associativity, format "n .+1") : trunc_scope. +Local Open Scope trunc_scope. +Notation "-2" := minus_two (at level 0) : trunc_scope. +Notation "-1" := (-2.+1) (at level 0) : trunc_scope. + +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | -2 => Contr_internal A + | n'.+1 => forall (x y : A), IsTrunc_internal n' (x = y) + end. + +Class IsTrunc (n : trunc_index) (A : Type) : Type := + Trunc_is_trunc : IsTrunc_internal n A. +Notation IsHProp := (IsTrunc -1). + +Monomorphic Axiom dummy_funext_type : Type0. +Monomorphic Class Funext := { dummy_funext_value : dummy_funext_type }. + +Local Open Scope path_scope. + +Definition concat_p1 {A : Type} {x y : A} (p : x = y) : + p @ 1 = p + := + match p with idpath => 1 end. + +Definition concat_1p {A : Type} {x y : A} (p : x = y) : + 1 @ p = p + := + match p with idpath => 1 end. + +Definition concat_p_pp {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) : + p @ (q @ r) = (p @ q) @ r := + match r with idpath => + match q with idpath => + match p with idpath => 1 + end end end. + +Definition concat_pp_p {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) : + (p @ q) @ r = p @ (q @ r) := + match r with idpath => + match q with idpath => + match p with idpath => 1 + end end end. + +Definition moveL_Mp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) : + r^ @ q = p -> q = r @ p. +admit. +Defined. + +Ltac with_rassoc tac := + repeat rewrite concat_pp_p; + tac; + + repeat rewrite concat_p_pp. + +Ltac rewrite_moveL_Mp_p := with_rassoc ltac:(apply moveL_Mp). + +Definition ap_p_pp {A B : Type} (f : A -> B) {w : B} {x y z : A} + (r : w = f x) (p : x = y) (q : y = z) : + r @ (ap f (p @ q)) = (r @ ap f p) @ (ap f q). +admit. +Defined. + +Definition ap_compose {A B C : Type} (f : A -> B) (g : B -> C) {x y : A} (p : x = y) : + ap (g o f) p = ap g (ap f p) + := + match p with idpath => 1 end. + +Definition concat_Ap {A B : Type} {f g : A -> B} (p : forall x, f x = g x) {x y : A} (q : x = y) : + (ap f q) @ (p y) = (p x) @ (ap g q) + := + match q with + | idpath => concat_1p _ @ ((concat_p1 _) ^) + end. + +Definition transportD2 {A : Type} (B C : A -> Type) (D : forall a:A, B a -> C a -> Type) + {x1 x2 : A} (p : x1 = x2) (y : B x1) (z : C x1) (w : D x1 y z) + : D x2 (p # y) (p # z) + := + match p with idpath => w end. +Local Open Scope equiv_scope. + +Definition transport_arrow_toconst {A : Type} {B : A -> Type} {C : Type} + {x1 x2 : A} (p : x1 = x2) (f : B x1 -> C) (y : B x2) + : (transport (fun x => B x -> C) p f) y = f (p^ # y). +admit. +Defined. + +Definition transport_arrow_fromconst {A B : Type} {C : A -> Type} + {x1 x2 : A} (p : x1 = x2) (f : B -> C x1) (y : B) + : (transport (fun x => B -> C x) p f) y = p # (f y). +admit. +Defined. + +Definition ap_transport_arrow_toconst {A : Type} {B : A -> Type} {C : Type} + {x1 x2 : A} (p : x1 = x2) (f : B x1 -> C) {y1 y2 : B x2} (q : y1 = y2) + : ap (transport (fun x => B x -> C) p f) q + @ transport_arrow_toconst p f y2 + = transport_arrow_toconst p f y1 + @ ap (fun y => f (p^ # y)) q. +admit. +Defined. + +Class Univalence. +Definition path_universe {A B : Type} (f : A -> B) {feq : IsEquiv f} : (A = B). +admit. +Defined. +Definition transport_path_universe + {A B : Type} (f : A -> B) {feq : IsEquiv f} (z : A) + : transport (fun X:Type => X) (path_universe f) z = f z. +admit. +Defined. +Definition transport_path_universe_V `{Funext} + {A B : Type} (f : A -> B) {feq : IsEquiv f} (z : B) + : transport (fun X:Type => X) (path_universe f)^ z = f^-1 z. +admit. +Defined. + +Ltac simpl_do_clear tac term := + let H := fresh in + assert (H := term); + simpl in H |- *; + tac H; + clear H. + +Tactic Notation "simpl" "rewrite" constr(term) := simpl_do_clear ltac:(fun H => rewrite H) term. + +Global Instance Univalence_implies_Funext `{Univalence} : Funext. +Admitted. + +Section Factorization. + + Context {class1 class2 : forall (X Y : Type@{i}), (X -> Y) -> Type@{i}} + `{forall (X Y : Type@{i}) (g:X->Y), IsHProp (class1 _ _ g)} + `{forall (X Y : Type@{i}) (g:X->Y), IsHProp (class2 _ _ g)} + {A B : Type@{i}} {f : A -> B}. + + Record Factorization := + { intermediate : Type ; + factor1 : A -> intermediate ; + factor2 : intermediate -> B ; + fact_factors : factor2 o factor1 == f ; + inclass1 : class1 _ _ factor1 ; + inclass2 : class2 _ _ factor2 + }. + + Record PathFactorization {fact fact' : Factorization} := + { path_intermediate : intermediate fact <~> intermediate fact' ; + path_factor1 : path_intermediate o factor1 fact == factor1 fact' ; + path_factor2 : factor2 fact == factor2 fact' o path_intermediate ; + path_fact_factors : forall a, path_factor2 (factor1 fact a) + @ ap (factor2 fact') (path_factor1 a) + @ fact_factors fact' a + = fact_factors fact a + }. + Context `{Univalence} {fact fact' : Factorization} + (pf : @PathFactorization fact fact'). + + Let II := path_intermediate pf. + Let ff1 := path_factor1 pf. + Let ff2 := path_factor2 pf. +Local Definition II' : intermediate fact = intermediate fact'. +admit. +Defined. + + Local Definition fff' (a : A) + : (transportD2 (fun X => A -> X) (fun X => X -> B) + (fun X g h => {_ : forall a : A, h (g a) = f a & + {_ : class1 A X g & class2 X B h}}) + II' (factor1 fact) (factor2 fact) + (fact_factors fact; (inclass1 fact; inclass2 fact))).1 a = + ap (transport (fun X => X -> B) II' (factor2 fact)) + (transport_arrow_fromconst II' (factor1 fact) a + @ transport_path_universe II (factor1 fact a) + @ ff1 a) + @ transport_arrow_toconst II' (factor2 fact) (factor1 fact' a) + @ ap (factor2 fact) (transport_path_universe_V II (factor1 fact' a)) + @ ff2 (II^-1 (factor1 fact' a)) + @ ap (factor2 fact') (eisretr II (factor1 fact' a)) + @ fact_factors fact' a. + Proof. + + Open Scope long_path_scope. + + rewrite (ap_transport_arrow_toconst (B := idmap) (C := B)). + + simpl rewrite (@ap_compose _ _ _ (transport idmap (path_universe II)^) + (factor2 fact)). + rewrite <- ap_p_pp; rewrite_moveL_Mp_p. + Set Debug Tactic Unification. + Fail rewrite (concat_Ap ff2). diff --git a/test-suite/bugs/opened/3786.v b/test-suite/bugs/opened/3786.v new file mode 100644 index 00000000..5a124115 --- /dev/null +++ b/test-suite/bugs/opened/3786.v @@ -0,0 +1,40 @@ +Require Coq.Lists.List. +Require Coq.Sets.Ensembles. +Import Coq.Sets.Ensembles. +Global Set Implicit Arguments. +Delimit Scope comp_scope with comp. +Inductive Comp : Type -> Type := +| Return : forall A, A -> Comp A +| Bind : forall A B, Comp A -> (A -> Comp B) -> Comp B +| Pick : forall A, Ensemble A -> Comp A. +Notation ret := Return. +Notation "x <- y ; z" := (Bind y%comp (fun x => z%comp)) + (at level 81, right associativity, + format "'[v' x <- y ; '/' z ']'") : comp_scope. +Axiom refine : forall {A} (old : Comp A) (new : Comp A), Prop. +Open Scope comp. +Axiom elements : forall {A} (ls : list A), Ensemble A. +Axiom to_list : forall {A} (S : Ensemble A), Comp (list A). +Axiom finite_set_handle_cardinal : refine (ret 0) (ret 0). +Definition sumUniqueSpec (ls : list nat) : Comp nat. + exact (ls' <- to_list (elements ls); + List.fold_right (fun a b' => Bind b' ((fun a b => ret (a + b)) a)) (ret 0) ls'). +Defined. +Axiom admit : forall {T}, T. +Definition sumUniqueImpl (ls : list nat) +: { c : _ | refine (sumUniqueSpec ls) (ret c) }%type. +Proof. + eexists. + match goal with + | [ |- refine ?a ?b ] => let a' := eval hnf in a in refine (_ : refine a' b) + end; + try setoid_rewrite (@finite_set_handle_cardinal). + Undo. + match goal with + | [ |- refine ?a ?b ] => let a' := eval hnf in a in change (refine a' b) + end. + try setoid_rewrite (@finite_set_handle_cardinal). (* Anomaly: Uncaught exception Invalid_argument("decomp_pointwise"). +Please report. *) + instantiate (1 := admit). + admit. +Defined. diff --git a/test-suite/bugs/opened/3788.v b/test-suite/bugs/opened/3788.v new file mode 100644 index 00000000..8e605a00 --- /dev/null +++ b/test-suite/bugs/opened/3788.v @@ -0,0 +1,5 @@ +Set Implicit Arguments. +Global Set Primitive Projections. +Record Functor (C D : Type) := { object_of :> forall _ : C, D }. +Axiom path_functor_uncurried : forall C D (F G : Functor C D) (_ : sigT (fun HO : object_of F = object_of G => Set)), F = G. +Fail Lemma path_functor_uncurried_snd C D F G HO HM : (@path_functor_uncurried C D F G (existT _ HO HM)) = HM. diff --git a/test-suite/bugs/opened/3808.v b/test-suite/bugs/opened/3808.v new file mode 100644 index 00000000..df40ca19 --- /dev/null +++ b/test-suite/bugs/opened/3808.v @@ -0,0 +1,2 @@ +Inductive Foo : (let enforce := (fun x => x) : Type@{j} -> Type@{i} in Type@{i}) + := foo : Foo. diff --git a/test-suite/bugs/opened/3819.v b/test-suite/bugs/opened/3819.v new file mode 100644 index 00000000..7105a658 --- /dev/null +++ b/test-suite/bugs/opened/3819.v @@ -0,0 +1,11 @@ +Set Universe Polymorphism. + +Record Op := { t : Type ; op : t -> t }. + +Canonical Structure OpType : Op := Build_Op Type (fun X => X). + +Lemma test1 (X:Type) : eq (op OpType X) X. +Proof eq_refl. + +Lemma test2 (A:Type) : eq (op _ A) A. +Fail Proof eq_refl. diff --git a/test-suite/bugs/opened/3849.v b/test-suite/bugs/opened/3849.v new file mode 100644 index 00000000..5290054a --- /dev/null +++ b/test-suite/bugs/opened/3849.v @@ -0,0 +1,8 @@ +Tactic Notation "foo" hyp_list(hs) := clear hs. + +Tactic Notation "bar" hyp_list(hs) := foo hs. + +Goal True. +do 5 pose proof 0 as ?n0. +foo n1 n2. +Fail bar n3 n4. diff --git a/test-suite/bugs/opened/shouldnotfail/743.v b/test-suite/bugs/opened/743.v index f1eee6c1..28257014 100644 --- a/test-suite/bugs/opened/shouldnotfail/743.v +++ b/test-suite/bugs/opened/743.v @@ -7,6 +7,6 @@ Qed. Lemma foo' : forall n m : nat, n <= n + n * m. Proof. - intros. omega. -Qed. + intros. Fail omega. +Abort. diff --git a/test-suite/bugs/opened/HoTT_coq_106.v b/test-suite/bugs/opened/HoTT_coq_106.v new file mode 100644 index 00000000..a5664595 --- /dev/null +++ b/test-suite/bugs/opened/HoTT_coq_106.v @@ -0,0 +1,52 @@ +(* File reduced by coq-bug-finder from 520 lines to 9 lines. *) +Set Universe Polymorphism. +Class IsPointed (A : Type) := point : A. + +Generalizable Variables A B f. + +Instance ispointed_forall `{H : forall a : A, IsPointed (B a)} +: IsPointed (forall a, B a) + := fun a => @point (B a) (H a). + +Instance ispointed_sigma `{IsPointed A} `{IsPointed (B (point A))} +: IsPointed (sigT B). +(* Message was at some time: +Toplevel input, characters 20-108: +Error: Unable to satisfy the following constraints: +UNDEFINED EVARS: + ?8==[A H B |- IsPointed (forall x : Type, ?13)] (parameter IsPointed of + @point) + ?12==[A H {B} x |- Type] (parameter A of @point) + ?13==[A H {B} x |- Type] (parameter A of @point) + ?15==[A H {B} x |- Type] (parameter A of @point)UNIVERSES: + {Top.38 Top.30 Top.39 Top.40 Top.29 Top.36 Top.31 Top.35 Top.37 Top.34 Top.32 Top.33} |= Top.30 < Top.29 + Top.30 < Top.36 + Top.32 < Top.34 + Top.38 <= Top.37 + Top.38 <= Top.33 + Top.40 <= Top.38 + Top.40 <= Coq.Init.Specif.7 + Top.40 <= Top.39 + Top.36 <= Top.35 + Top.37 <= Top.35 + Top.34 <= Top.31 + Top.32 <= Top.39 + Top.32 <= Coq.Init.Specif.8 + Top.33 <= Top.31 + +ALGEBRAIC UNIVERSES: + {Top.38 Top.40 Top.29 Top.36 Top.31 Top.37 Top.34 Top.33} +UNDEFINED UNIVERSES: + Top.38 + Top.30 + Top.39 + Top.40 + Top.29 + Top.36 + Top.31 + Top.35 + Top.37 + Top.34 + Top.32 + Top.33CONSTRAINTS:[] [A H B] |- ?13 == ?12 +[] [A H B H0] |- ?12 == ?15 *) diff --git a/test-suite/bugs/opened/HoTT_coq_120.v b/test-suite/bugs/opened/HoTT_coq_120.v new file mode 100644 index 00000000..7847c5e4 --- /dev/null +++ b/test-suite/bugs/opened/HoTT_coq_120.v @@ -0,0 +1,136 @@ +(* File reduced by coq-bug-finder from original input, then from 8249 lines to 907 lines, then from 843 lines to 357 lines, then from 351 lines to 260 lines, then from 208 lines to 162 lines, then from 167 lines to 154 lines *) +Set Universe Polymorphism. +Generalizable All Variables. +Reserved Notation "g 'o' f" (at level 40, left associativity). +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y" := (@paths _ x y) : type_scope. + +Class IsEquiv {A B : Type} (f : A -> B) := {}. + +Class Contr_internal (A : Type) := BuildContr { + center : A ; + contr : (forall y : A, center = y) + }. + +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. + +Fixpoint nat_to_trunc_index (n : nat) : trunc_index + := match n with + | 0 => trunc_S (trunc_S minus_two) + | S n' => trunc_S (nat_to_trunc_index n') + end. + +Coercion nat_to_trunc_index : nat >-> trunc_index. + +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | minus_two => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. + +Notation minus_one:=(trunc_S minus_two). + +Class IsTrunc (n : trunc_index) (A : Type) : Type := Trunc_is_trunc : IsTrunc_internal n A. + +Notation Contr := (IsTrunc minus_two). +Notation IsHProp := (IsTrunc minus_one). +Notation IsHSet := (IsTrunc 0). + +Class Funext := {}. +Inductive Unit : Set := tt. + +Instance contr_unit : Contr Unit | 0 := let x := {| + center := tt; + contr := fun t : Unit => match t with tt => idpath end + |} in x. +Instance trunc_succ `{IsTrunc n A} : IsTrunc (trunc_S n) A | 1000. +admit. +Defined. +Record hProp := hp { hproptype :> Type ; isp : IsHProp hproptype}. +Definition Unit_hp:hProp:=(hp Unit _). +Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. +Canonical Structure default_HSet:= fun T P => (@BuildhSet T P). +Definition ismono {X Y} (f : X -> Y) + := forall Z : hSet, + forall g h : Z -> X, (fun x => f (g x)) = (fun x => f (h x)) -> g = h. + +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope object_scope with object. +Record PreCategory := + Build_PreCategory { + object :> Type; + morphism : object -> object -> Type; + compose : forall s d d', morphism d d' -> morphism s d -> morphism s d' + }. +Arguments compose [!C s d d'] m1 m2 : rename. + +Infix "o" := compose : morphism_scope. +Local Open Scope morphism_scope. + +Class IsEpimorphism {C} {x y} (m : morphism C x y) := + is_epimorphism : forall z (m1 m2 : morphism C y z), + m1 o m = m2 o m + -> m1 = m2. + +Class IsMonomorphism {C} {x y} (m : morphism C x y) := + is_monomorphism : forall z (m1 m2 : morphism C z x), + m o m1 = m o m2 + -> m1 = m2. +Class Univalence := {}. +Global Instance isset_hProp `{Funext} : IsHSet hProp | 0. Admitted. + +Definition set_cat : PreCategory + := @Build_PreCategory hSet + (fun x y => forall _ : x, y)%core + (fun _ _ _ f g x => f (g x))%core. +Local Inductive minus1Trunc (A :Type) : Type := min1 : A -> minus1Trunc A. +Instance minus1Trunc_is_prop {A : Type} : IsHProp (minus1Trunc A) | 0. Admitted. +Definition hexists {X} (P:X->Type):Type:= minus1Trunc (sigT P). +Definition isepi {X Y} `(f:X->Y) := forall Z: hSet, + forall g h: Y -> Z, (fun x => g (f x)) = (fun x => h (f x)) -> g = h. +Definition issurj {X Y} (f:X->Y) := forall y:Y , hexists (fun x => (f x) = y). +Lemma isepi_issurj `{fs:Funext} `{ua:Univalence} `{fs' : Funext} {X Y} (f:X->Y): isepi f -> issurj f. +Proof. + intros epif y. + set (g :=fun _:Y => Unit_hp). + set (h:=(fun y:Y => (hp (hexists (fun _ : Unit => {x:X & y = (f x)})) _ ))). + clear fs'. + hnf in epif. + specialize (epif (BuildhSet hProp _) g h). + admit. +Defined. +Definition isequiv_isepi_ismono `{Univalence, fs0 : Funext} (X Y : hSet) (f : X -> Y) (epif : isepi f) (monof : ismono f) +: IsEquiv f. +Proof. + pose proof (@isepi_issurj _ _ _ _ _ f epif) as surjf. + admit. +Defined. +Section fully_faithful_helpers. + Context `{fs0 : Funext}. + Variables x y : hSet. + Variable m : x -> y. + + Let isequiv_isepi_ismono_helper ua := (@isequiv_isepi_ismono ua fs0 x y m : isepi m -> ismono m -> IsEquiv m). + + Goal True. + Fail set (isequiv_isepimorphism_ismonomorphism + := fun `{Univalence} + (Hepi : IsEpimorphism (m : morphism set_cat x y)) + (Hmono : IsMonomorphism (m : morphism set_cat x y)) + => (@isequiv_isepi_ismono_helper _ Hepi Hmono : @IsEquiv _ _ m)). + admit. + Undo. + Fail set (isequiv_isepimorphism_ismonomorphism' + := fun `{Univalence} + (Hepi : IsEpimorphism (m : morphism set_cat x y)) + (Hmono : IsMonomorphism (m : morphism set_cat x y)) + => ((let _ := @isequiv_isepimorphism_ismonomorphism _ Hepi Hmono in @isequiv_isepi_ismono _ fs0 x y m Hepi Hmono) + : @IsEquiv _ _ m)). + Set Printing Universes. + admit. (* Error: Universe inconsistency (cannot enforce Top.235 <= Set because Set +< Top.235). *) diff --git a/test-suite/check b/test-suite/check index 48a67449..3d14f6bc 100755 --- a/test-suite/check +++ b/test-suite/check @@ -2,10 +2,6 @@ MAKE="${MAKE:=make}" -if [ "$1" = -byte ]; then - export BEST=byte -fi - ${MAKE} clean > /dev/null 2>&1 ${MAKE} all > /dev/null 2>&1 cat summary.log diff --git a/test-suite/complexity/injection.v b/test-suite/complexity/injection.v index 335996c2..08f489d7 100644 --- a/test-suite/complexity/injection.v +++ b/test-suite/complexity/injection.v @@ -72,14 +72,14 @@ Definition own_join (a b c: own) : Prop := match a , b , c with | NO , _ , _ => b=c | _ , NO , _ => a=c - | VAL' sa _ , VAL' sb _, VAL' sc _ => Share.j.(join) sa sb sc - | LK sa pa ha fa, LK sb pb hb fb, LK sc pc hc fc => + | @VAL' sa _, @VAL' sb _, @VAL' sc _ => Share.j.(join) sa sb sc + | @LK sa pa ha fa, @LK sb pb hb fb, @LK sc pc hc fc => Share.j.(join) sa sb sc /\ Share.j.(join) ha hb hc /\ fa=fc /\ fb=fc - | CT sa pa , CT sb pb, CT sc pc => Share.j.(join) sa sb sc - | FUN sa pa fa, FUN sb pb fb, FUN sc pc fc => + | @CT sa pa , @CT sb pb, @CT sc pc => Share.j.(join) sa sb sc + | @FUN sa pa fa, @FUN sb pb fb, @FUN sc pc fc => Share.j.(join) sa sb sc /\ fa=fc /\ fb=fc | _ , _ , _ => False end. diff --git a/test-suite/coqchk/univ.v b/test-suite/coqchk/univ.v new file mode 100644 index 00000000..84a4009d --- /dev/null +++ b/test-suite/coqchk/univ.v @@ -0,0 +1,35 @@ + +Inductive equivalent P Q := Equivalent (P_to_Q : P -> Q) (Q_to_P : Q -> P). + +Inductive equal T (x : T) : T -> Type := Equal : equal T x x. + +(* Arithmetic *) + +Inductive natural := Zero | Add_1_to (n : natural). + +Fixpoint add (m n : natural) : natural := + match m with Zero => n | Add_1_to m_minus_1 => add m_minus_1 (Add_1_to n) end. + +Definition double (n : natural) : natural := add n n. + +Inductive odd (n : natural) := + Odd (half : natural) + (n_odd : equal natural n (Add_1_to (double half))). + +Inductive less_than (m n : natural) := + LessThan (diff : natural) + (m_lt_n : equal natural n (Add_1_to (add m diff))). + +(* Finite subsets *) + +Definition injective_in T R (D : T -> Type) (f : T -> R) := + forall x y, D x -> D y -> equal R (f x) (f y) -> equal T x y. + +Inductive in_image T R (D : T -> Type) (f : T -> R) (a : R) := + InImage (x : T) (x_in_D : D x) (a_is_fx : equal R a (f x)). + +Inductive finite_of_order T (D : T -> Type) (n : natural) := + FiniteOfOrder (rank : T -> natural) + (rank_injective : injective_in T natural D rank) + (rank_onto : + forall i, equivalent (less_than i n) (in_image T natural D rank i)). diff --git a/test-suite/failure/Case1.v b/test-suite/failure/Case1.v index df11ed38..6e76d42d 100644 --- a/test-suite/failure/Case1.v +++ b/test-suite/failure/Case1.v @@ -1,4 +1,4 @@ -Type match 0 with +Fail Type match 0 with | x => 0 | O => 1 end. diff --git a/test-suite/failure/Case10.v b/test-suite/failure/Case10.v index 43cc1e34..661d98cd 100644 --- a/test-suite/failure/Case10.v +++ b/test-suite/failure/Case10.v @@ -1,3 +1,3 @@ -Type (fun x : nat => match x return nat with +Fail Type (fun x : nat => match x return nat with | S x as b => S b end). diff --git a/test-suite/failure/Case11.v b/test-suite/failure/Case11.v index e76d0609..675f79e6 100644 --- a/test-suite/failure/Case11.v +++ b/test-suite/failure/Case11.v @@ -1,3 +1,3 @@ -Type (fun x : nat => match x return nat with +Fail Type (fun x : nat => match x return nat with | S x as b => S b x end). diff --git a/test-suite/failure/Case12.v b/test-suite/failure/Case12.v index cf6c2026..4a77f139 100644 --- a/test-suite/failure/Case12.v +++ b/test-suite/failure/Case12.v @@ -1,5 +1,5 @@ -Type +Fail Type (fun x : nat => match x return nat with | S x as b => match x with diff --git a/test-suite/failure/Case13.v b/test-suite/failure/Case13.v index 994dfd20..5c0aa3e1 100644 --- a/test-suite/failure/Case13.v +++ b/test-suite/failure/Case13.v @@ -1,4 +1,4 @@ -Type +Fail Type (fun x : nat => match x return nat with | S x as b => match x with diff --git a/test-suite/failure/Case14.v b/test-suite/failure/Case14.v index ba0c51a1..29cae764 100644 --- a/test-suite/failure/Case14.v +++ b/test-suite/failure/Case14.v @@ -3,7 +3,7 @@ Inductive List (A : Set) : Set := | Cons : A -> List A -> List A. Definition NIL := Nil nat. -Type match Nil nat return (List nat) with +Fail Type match Nil nat return (List nat) with | NIL => NIL | _ => NIL end. diff --git a/test-suite/failure/Case15.v b/test-suite/failure/Case15.v index 18faaf5c..ec08e614 100644 --- a/test-suite/failure/Case15.v +++ b/test-suite/failure/Case15.v @@ -1,6 +1,6 @@ (* Non exhaustive pattern-matching *) -Check +Fail Check (fun x => match x, x with | O, S (S y) => true diff --git a/test-suite/failure/Case16.v b/test-suite/failure/Case16.v index 3739adae..df15a428 100644 --- a/test-suite/failure/Case16.v +++ b/test-suite/failure/Case16.v @@ -1,6 +1,6 @@ (* Check for redundant clauses *) -Check +Fail Check (fun x => match x, x with | O, S (S y) => true diff --git a/test-suite/failure/Case2.v b/test-suite/failure/Case2.v index 7d81ee81..f8c95b1e 100644 --- a/test-suite/failure/Case2.v +++ b/test-suite/failure/Case2.v @@ -4,7 +4,7 @@ Inductive IFExpr : Set := | Fa : IFExpr | IfE : IFExpr -> IFExpr -> IFExpr -> IFExpr. -Type +Fail Type (fun F : IFExpr => match F return Prop with | IfE (Var _) H I => True diff --git a/test-suite/failure/Case3.v b/test-suite/failure/Case3.v index ca450d5b..eaafd41f 100644 --- a/test-suite/failure/Case3.v +++ b/test-suite/failure/Case3.v @@ -2,7 +2,7 @@ Inductive List (A : Set) : Set := | Nil : List A | Cons : A -> List A -> List A. -Type +Fail Type (fun l : List nat => match l return nat with | Nil nat => 0 diff --git a/test-suite/failure/Case4.v b/test-suite/failure/Case4.v index de63c3f7..4da7ef0c 100644 --- a/test-suite/failure/Case4.v +++ b/test-suite/failure/Case4.v @@ -1,5 +1,5 @@ -Definition Berry (x y z : bool) := +Fail Definition Berry (x y z : bool) := match x, y, z with | true, false, _ => 0 | false, _, true => 1 diff --git a/test-suite/failure/Case5.v b/test-suite/failure/Case5.v index 494443f1..70e5b988 100644 --- a/test-suite/failure/Case5.v +++ b/test-suite/failure/Case5.v @@ -2,6 +2,6 @@ Inductive MS : Set := | X : MS -> MS | Y : MS -> MS. -Type (fun p : MS => match p return nat with +Fail Type (fun p : MS => match p return nat with | X x => 0 end). diff --git a/test-suite/failure/Case6.v b/test-suite/failure/Case6.v index fb8659bf..cb7b7de0 100644 --- a/test-suite/failure/Case6.v +++ b/test-suite/failure/Case6.v @@ -2,7 +2,7 @@ Inductive List (A : Set) : Set := | Nil : List A | Cons : A -> List A -> List A. -Type (match Nil nat return List nat with +Fail Type (match Nil nat return List nat with | NIL => NIL | (CONS _ _) => NIL end). diff --git a/test-suite/failure/Case7.v b/test-suite/failure/Case7.v index 64453481..e1fd7df0 100644 --- a/test-suite/failure/Case7.v +++ b/test-suite/failure/Case7.v @@ -9,7 +9,7 @@ Definition length1 (n : nat) (l : listn n) := | _ => 0 end. -Type +Fail Type (fun (n : nat) (l : listn n) => match n return nat with | O => 0 diff --git a/test-suite/failure/Case8.v b/test-suite/failure/Case8.v index feae29a7..035629fe 100644 --- a/test-suite/failure/Case8.v +++ b/test-suite/failure/Case8.v @@ -2,7 +2,7 @@ Inductive List (A : Set) : Set := | Nil : List A | Cons : A -> List A -> List A. -Type match Nil nat return nat with +Fail Type match Nil nat return nat with | b => b | Cons _ _ _ as d => d end. diff --git a/test-suite/failure/Case9.v b/test-suite/failure/Case9.v index d63c4940..642f85d7 100644 --- a/test-suite/failure/Case9.v +++ b/test-suite/failure/Case9.v @@ -1,8 +1,8 @@ Parameter compare : forall n m : nat, {n < m} + {n = m} + {n > m}. -Type +Fail Type match compare 0 0 return nat with - (* k<i *) | left _ _ (left _ _ _) => 0 - (* k=i *) | left _ _ _ => 0 - (* k>i *) | right _ _ _ => 0 + (* k<i *) | left _ (left _ _) => 0 + (* k=i *) | left _ _ => 0 + (* k>i *) | right _ _ => 0 end. diff --git a/test-suite/failure/ClearBody.v b/test-suite/failure/ClearBody.v index 609d5b3b..e321e59f 100644 --- a/test-suite/failure/ClearBody.v +++ b/test-suite/failure/ClearBody.v @@ -5,4 +5,4 @@ Goal True. set (n := 0) in *. set (I := refl_equal 0) in *. change (n = 0) in (type of I). -clearbody n. +Fail clearbody n. diff --git a/test-suite/failure/ImportedCoercion.v b/test-suite/failure/ImportedCoercion.v index 0a69b851..1cac69f4 100644 --- a/test-suite/failure/ImportedCoercion.v +++ b/test-suite/failure/ImportedCoercion.v @@ -4,4 +4,4 @@ Require Import make_local. (* Local coercion must not be used *) -Check (0 = true). +Fail Check (0 = true). diff --git a/test-suite/failure/Notations.v b/test-suite/failure/Notations.v index 074e176a..83459de3 100644 --- a/test-suite/failure/Notations.v +++ b/test-suite/failure/Notations.v @@ -3,5 +3,5 @@ Notation "! A" := (forall i:nat, A) (at level 60). (* Should fail: no dynamic capture *) -Check ! (i=i). +Fail Check ! (i=i). diff --git a/test-suite/failure/Reordering.v b/test-suite/failure/Reordering.v index 7b36d1c3..e79b2073 100644 --- a/test-suite/failure/Reordering.v +++ b/test-suite/failure/Reordering.v @@ -2,4 +2,4 @@ Goal forall (A:Set) (x:A) (A':=A), True. intros. -change ((fun (_:A') => Set) x) in (type of A). +Fail change ((fun (_:A') => Set) x) in (type of A). diff --git a/test-suite/failure/Sections.v b/test-suite/failure/Sections.v index 9b3b35c1..928e214f 100644 --- a/test-suite/failure/Sections.v +++ b/test-suite/failure/Sections.v @@ -1,4 +1,4 @@ Module A. Section B. -End A. -End A. +Fail End A. +(*End A.*) diff --git a/test-suite/failure/Tauto.v b/test-suite/failure/Tauto.v index 11b40951..749db000 100644 --- a/test-suite/failure/Tauto.v +++ b/test-suite/failure/Tauto.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -17,4 +17,4 @@ (* Fails because Tauto does not perform any Apply *) Goal (forall A : Prop, A \/ ~ A) -> forall x y : nat, x = y \/ x <> y. Proof. - tauto. + Fail tauto. diff --git a/test-suite/failure/Uminus.v b/test-suite/failure/Uminus.v index 3c3bf375..cc31c7ae 100644 --- a/test-suite/failure/Uminus.v +++ b/test-suite/failure/Uminus.v @@ -1,62 +1,21 @@ (* Check that the encoding of system U- fails *) -Inductive prop : Prop := down : Prop -> prop. - -Definition up (p:prop) : Prop := let (A) := p in A. - -Lemma p2p1 : forall A:Prop, up (down A) -> A. -Proof. -exact (fun A x => x). -Qed. +Require Hurkens. -Lemma p2p2 : forall A:Prop, A -> up (down A). -Proof. -exact (fun A x => x). -Qed. - -(** Hurkens' paradox *) - -Definition V := forall A:Prop, ((A -> prop) -> A -> prop) -> A -> prop. -Definition U := V -> prop. -Definition sb (z:V) : V := fun A r a => r (z A r) a. -Definition le (i:U -> prop) (x:U) : prop := - x (fun A r a => i (fun v => sb v A r a)). -Definition induct (i:U -> prop) : Prop := - forall x:U, up (le i x) -> up (i x). -Definition WF : U := fun z => down (induct (z U le)). -Definition I (x:U) : Prop := - (forall i:U -> prop, up (le i x) -> up (i (fun v => sb v U le x))) -> False. +Inductive prop : Prop := down : Prop -> prop. -Lemma Omega : forall i:U -> prop, induct i -> up (i WF). -Proof. -intros i y. -apply y. -unfold le, WF, induct. -intros x H0. -apply y. -exact H0. -Qed. +(* Coq should reject the following access of a Prop buried inside + a prop. *) -Lemma lemma1 : induct (fun u => down (I u)). -Proof. -unfold induct. -intros x p. -intro q. -apply (q (fun u => down (I u)) p). -intro i. -apply q with (i := fun y => i (fun v:V => sb v U le y)). -Qed. +Fail Definition up (p:prop) : Prop := let (A) := p in A. -Lemma lemma2 : (forall i:U -> prop, induct i -> up (i WF)) -> False. -Proof. -intro x. -apply (x (fun u => down (I u)) lemma1). -intros i H0. -apply (x (fun y => i (fun v => sb v U le y))). -apply H0. -Qed. +(* Otherwise, we would have a proof of False via Hurkens' paradox *) -Theorem paradox : False. -Proof. -exact (lemma2 Omega). -Qed. +Fail Definition paradox : False := + Hurkens.NoRetractFromSmallPropositionToProp.paradox + prop + down + up + (fun (A:Prop) (x:up (down A)) => (x:A)) + (fun (A:Prop) (x:A) => (x:up (down A))) + False. diff --git a/test-suite/failure/autorewritein.v b/test-suite/failure/autorewritein.v index dc17742a..191e035b 100644 --- a/test-suite/failure/autorewritein.v +++ b/test-suite/failure/autorewritein.v @@ -9,7 +9,7 @@ Hint Rewrite Ack0 Ack1 Ack2 : base0. Lemma ResAck2 : forall H:(Ack 2 2 = 7 -> False), H=H -> False. Proof. intros. - autorewrite with base0 in * using try (apply H1;reflexivity). + Fail autorewrite with base0 in * using try (apply H1;reflexivity). diff --git a/test-suite/failure/cases.v b/test-suite/failure/cases.v index 18faaf5c..ec08e614 100644 --- a/test-suite/failure/cases.v +++ b/test-suite/failure/cases.v @@ -1,6 +1,6 @@ (* Non exhaustive pattern-matching *) -Check +Fail Check (fun x => match x, x with | O, S (S y) => true diff --git a/test-suite/failure/check.v b/test-suite/failure/check.v index 649fdd2d..a148ebe8 100644 --- a/test-suite/failure/check.v +++ b/test-suite/failure/check.v @@ -1,3 +1,3 @@ Implicit Arguments eq [A]. -Check (bool = true). +Fail Check (bool = true). diff --git a/test-suite/failure/circular_subtyping1.v b/test-suite/failure/circular_subtyping.v index 0b3a8688..ceccd460 100644 --- a/test-suite/failure/circular_subtyping1.v +++ b/test-suite/failure/circular_subtyping.v @@ -1,7 +1,10 @@ (* subtyping verification in presence of pseudo-circularity*) Module Type S. End S. Module Type T. Declare Module M:S. End T. - Module N:S. End N. Module NN <: T. Module M:=N. End NN. -Module P <: T with Module M:=NN := NN. + +Fail Module P <: T with Module M:=NN := NN. + +Module F (X:S) (Y:T with Module M:=X). End F. +Fail Module G := F N N.
\ No newline at end of file diff --git a/test-suite/failure/circular_subtyping2.v b/test-suite/failure/circular_subtyping2.v deleted file mode 100644 index 3bacdc65..00000000 --- a/test-suite/failure/circular_subtyping2.v +++ /dev/null @@ -1,8 +0,0 @@ -(*subtyping verification in presence of pseudo-circularity at functor application *) -Module Type S. End S. -Module Type T. Declare Module M:S. End T. -Module N:S. End N. - -Module F (X:S) (Y:T with Module M:=X). End F. - -Module G := F N N.
\ No newline at end of file diff --git a/test-suite/failure/clash_cons.v b/test-suite/failure/clash_cons.v index 17e56763..8e34ffbd 100644 --- a/test-suite/failure/clash_cons.v +++ b/test-suite/failure/clash_cons.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -11,5 +11,5 @@ Inductive X : Set := cons : X. -Inductive Y : Set := +Fail Inductive Y : Set := cons : Y. diff --git a/test-suite/failure/clashes.v b/test-suite/failure/clashes.v index 207d62b9..1a59ec66 100644 --- a/test-suite/failure/clashes.v +++ b/test-suite/failure/clashes.v @@ -5,5 +5,5 @@ Section S. Variable n : nat. -Inductive P : Set := +Fail Inductive P : Set := n : P. diff --git a/test-suite/failure/cofixpoint.v b/test-suite/failure/cofixpoint.v new file mode 100644 index 00000000..cb39893f --- /dev/null +++ b/test-suite/failure/cofixpoint.v @@ -0,0 +1,15 @@ +(* A bug in the guard checking of nested cofixpoints. *) +(* Posted by Maxime Dénès on coqdev (Apr 9, 2014). *) + +CoInductive CoFalse := . + +CoInductive CoTrue := I. + +Fail CoFixpoint loop : CoFalse := + (cofix f := loop with g := loop for f). + +Fail CoFixpoint loop : CoFalse := + (cofix f := I with g := loop for g). + +Fail CoFixpoint loop : CoFalse := + (cofix f := loop with g := I for f).
\ No newline at end of file diff --git a/test-suite/failure/coqbugs0266.v b/test-suite/failure/coqbugs0266.v index 79eef5c9..cc3f307a 100644 --- a/test-suite/failure/coqbugs0266.v +++ b/test-suite/failure/coqbugs0266.v @@ -4,4 +4,4 @@ Section S. Let a := 0. Definition b := a. Goal b = b. -clear a. +Fail clear a. diff --git a/test-suite/failure/evar1.v b/test-suite/failure/evar1.v index 1a4e42a8..2b6fe765 100644 --- a/test-suite/failure/evar1.v +++ b/test-suite/failure/evar1.v @@ -1,3 +1,3 @@ (* This used to succeed by producing an ill-typed term in v8.2 *) -Lemma u: forall A : Prop, (exist _ A A) = (exist _ A A). +Fail Lemma u: forall A : Prop, (exist _ A A) = (exist _ A A). diff --git a/test-suite/failure/evarclear1.v b/test-suite/failure/evarclear1.v index 2e9fa0f3..60adadef 100644 --- a/test-suite/failure/evarclear1.v +++ b/test-suite/failure/evarclear1.v @@ -6,5 +6,5 @@ eexists. unfold z. clear y z. (* should fail because the evar should no longer be allowed to depend on z *) -instantiate (1:=z). +Fail instantiate (1:=z). diff --git a/test-suite/failure/evarclear2.v b/test-suite/failure/evarclear2.v index e606a06f..0f776811 100644 --- a/test-suite/failure/evarclear2.v +++ b/test-suite/failure/evarclear2.v @@ -6,4 +6,4 @@ eexists. rename y into z. unfold z at 1 2. (* should fail because the evar type depends on z *) -clear z. +Fail clear z. diff --git a/test-suite/failure/evarlemma.v b/test-suite/failure/evarlemma.v index ea753e79..ae40774c 100644 --- a/test-suite/failure/evarlemma.v +++ b/test-suite/failure/evarlemma.v @@ -1,3 +1,3 @@ (* Check success of inference of evars in the context of lemmas *) -Lemma foo x : True. +Fail Lemma foo x : True. diff --git a/test-suite/failure/fixpoint1.v b/test-suite/failure/fixpoint1.v index bea21f33..7b52316e 100644 --- a/test-suite/failure/fixpoint1.v +++ b/test-suite/failure/fixpoint1.v @@ -1,10 +1,10 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -Fixpoint PreParadox (u : unit) : False := PreParadox u. -Definition Paradox := PreParadox tt. +Fail Fixpoint PreParadox (u : unit) : False := PreParadox u. +(*Definition Paradox := PreParadox tt.*) diff --git a/test-suite/failure/fixpoint2.v b/test-suite/failure/fixpoint2.v index d2f02ea1..7f11a99b 100644 --- a/test-suite/failure/fixpoint2.v +++ b/test-suite/failure/fixpoint2.v @@ -3,4 +3,4 @@ Goal nat->nat. fix f 1. intro n; apply f; assumption. -Guarded. +Fail Guarded. diff --git a/test-suite/failure/fixpoint3.v b/test-suite/failure/fixpoint3.v index 42f06916..7d1d3ee6 100644 --- a/test-suite/failure/fixpoint3.v +++ b/test-suite/failure/fixpoint3.v @@ -6,7 +6,7 @@ Inductive I : Prop := Definition i0 := C (fun _ x => x). -Definition Paradox : False := +Fail Definition Paradox : False := (fix ni i : False := match i with | C f => ni (f _ i) diff --git a/test-suite/failure/fixpoint4.v b/test-suite/failure/fixpoint4.v index fd956373..bf6133f1 100644 --- a/test-suite/failure/fixpoint4.v +++ b/test-suite/failure/fixpoint4.v @@ -8,7 +8,7 @@ Inductive IMP : Prop := Definition i0 := (LIMP (fun _ => CIMP (fun _ x => x))). -Definition Paradox : False := +Fail Definition Paradox : False := (fix F y o {struct o} : False := match y with | tt => fun f => diff --git a/test-suite/failure/guard-cofix.v b/test-suite/failure/guard-cofix.v new file mode 100644 index 00000000..64faa0ce --- /dev/null +++ b/test-suite/failure/guard-cofix.v @@ -0,0 +1,43 @@ +(* This script shows, in two different ways, the inconsistency of the +propositional extensionality axiom with the guard condition for cofixpoints. It +is the dual of the problem on fixpoints (cf subterm.v, subterm2.v, +subterm3.v). Posted on Coq-club by Maxime Dénès (02/26/2014). *) + +(* First example *) + +CoInductive CoFalse : Prop := CF : CoFalse -> False -> CoFalse. + +CoInductive Pandora : Prop := C : CoFalse -> Pandora. + +Axiom prop_ext : forall P Q : Prop, (P<->Q) -> P = Q. + +Lemma foo : Pandora = CoFalse. +apply prop_ext. +constructor. +intro x; destruct x; assumption. +exact C. +Qed. + +Fail CoFixpoint loop : CoFalse := +match foo in (_ = T) return T with eq_refl => C loop end. + +Fail Definition ff : False := match loop with CF _ t => t end. + +(* Second example *) + +Inductive omega := Omega : omega -> omega. + +Lemma H : omega = CoFalse. +Proof. +apply prop_ext; constructor. + induction 1; assumption. +destruct 1; destruct H0. +Qed. + +Fail CoFixpoint loop' : CoFalse := + match H in _ = T return T with + eq_refl => + Omega match eq_sym H in _ = T return T with eq_refl => loop' end + end. + +Fail Definition ff' : False := match loop' with CF _ t => t end.
\ No newline at end of file diff --git a/test-suite/failure/guard.v b/test-suite/failure/guard.v index 78a0782a..b3a0a335 100644 --- a/test-suite/failure/guard.v +++ b/test-suite/failure/guard.v @@ -1,16 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - +(* Fixpoint F (n:nat) : False := F (match F n with end). - +*) (* de Bruijn mix-up *) (* If accepted, Eval compute in f 0. loops *) -Definition f := +Fail Definition f := let f (f1 f2:nat->nat) := f1 in let _ := 0 in let _ := 0 in diff --git a/test-suite/failure/illtype1.v b/test-suite/failure/illtype1.v index 5781c96b..7e4c5ac5 100644 --- a/test-suite/failure/illtype1.v +++ b/test-suite/failure/illtype1.v @@ -1,8 +1,8 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -Check (S S). +Fail Check (S S). diff --git a/test-suite/failure/inductive.v b/test-suite/failure/inductive.v new file mode 100644 index 00000000..f3e47bfd --- /dev/null +++ b/test-suite/failure/inductive.v @@ -0,0 +1,27 @@ +(* A check that sort-polymorphic product is not set too low *) + +Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B. +Fail Check (fun (A:Type) (B:Prop) => (prod A B : Prop)). +Fail Check (fun (A:Prop) (B:Type) => (prod A B : Prop)). + +(* Check that the nested inductive types positivity check avoids recursively + non uniform parameters (at least if these parameters break positivity) *) + +Inductive t (A:Type) : Type := c : t (A -> A) -> t A. +Fail Inductive u : Type := d : u | e : t u -> u. + +(* This used to succeed in versions 8.1 to 8.3 *) + +Require Import Logic. +Require Hurkens. +Definition Ti := Type. +Inductive prod2 (X Y:Ti) := pair2 : X -> Y -> prod2 X Y. +Fail Definition B : Prop := let F := prod2 True in F Prop. (* Aie! *) +(*Definition p2b (P:Prop) : B := pair2 True Prop I P. +Definition b2p (b:B) : Prop := match b with pair2 _ P => P end. +Lemma L1 : forall A : Prop, b2p (p2b A) -> A. +Proof (fun A x => x). +Lemma L2 : forall A : Prop, A -> b2p (p2b A). +Proof (fun A x => x). +Check Hurkens.paradox B p2b b2p L1 L2.*) + diff --git a/test-suite/failure/inductive1.v b/test-suite/failure/inductive1.v deleted file mode 100644 index 3b57d919..00000000 --- a/test-suite/failure/inductive1.v +++ /dev/null @@ -1,4 +0,0 @@ -(* A check that sort-polymorphic product is not set too low *) - -Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B. -Check (fun (A:Type) (B:Prop) => (prod A B : Prop)). diff --git a/test-suite/failure/inductive2.v b/test-suite/failure/inductive2.v deleted file mode 100644 index b77474be..00000000 --- a/test-suite/failure/inductive2.v +++ /dev/null @@ -1,4 +0,0 @@ -(* A check that sort-polymorphic product is not set too low *) - -Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B. -Check (fun (A:Prop) (B:Type) => (prod A B : Prop)). diff --git a/test-suite/failure/inductive3.v b/test-suite/failure/inductive3.v deleted file mode 100644 index cf035edf..00000000 --- a/test-suite/failure/inductive3.v +++ /dev/null @@ -1,5 +0,0 @@ -(* Check that the nested inductive types positivity check avoids recursively - non uniform parameters (at least if these parameters break positivity) *) - -Inductive t (A:Type) : Type := c : t (A -> A) -> t A. -Inductive u : Type := d : u | e : t u -> u. diff --git a/test-suite/failure/inductive4.v b/test-suite/failure/inductive4.v deleted file mode 100644 index 6ba36fd2..00000000 --- a/test-suite/failure/inductive4.v +++ /dev/null @@ -1,15 +0,0 @@ -(* This used to succeed in versions 8.1 to 8.3 *) - -Require Import Logic. -Require Hurkens. -Definition Ti := Type. -Inductive prod (X Y:Ti) := pair : X -> Y -> prod X Y. -Definition B : Prop := let F := prod True in F Prop. (* Aie! *) -Definition p2b (P:Prop) : B := pair True Prop I P. -Definition b2p (b:B) : Prop := match b with pair _ P => P end. -Lemma L1 : forall A : Prop, b2p (p2b A) -> A. -Proof (fun A x => x). -Lemma L2 : forall A : Prop, A -> b2p (p2b A). -Proof (fun A x => x). -Check Hurkens.paradox B p2b b2p L1 L2. - diff --git a/test-suite/failure/ltac1.v b/test-suite/failure/ltac1.v index 7b496a75..eef16525 100644 --- a/test-suite/failure/ltac1.v +++ b/test-suite/failure/ltac1.v @@ -4,4 +4,4 @@ Ltac X := match goal with end. Goal True -> True -> True. intros. -X. +Fail X. diff --git a/test-suite/failure/ltac2.v b/test-suite/failure/ltac2.v index 14436e58..d66fb680 100644 --- a/test-suite/failure/ltac2.v +++ b/test-suite/failure/ltac2.v @@ -1,6 +1,6 @@ (* Check that Match arguments are forbidden *) Ltac E x := apply x. Goal True -> True. -E ltac:(match goal with +Fail E ltac:(match goal with | |- _ => intro H end). diff --git a/test-suite/failure/ltac4.v b/test-suite/failure/ltac4.v index 41471275..5b0396d1 100644 --- a/test-suite/failure/ltac4.v +++ b/test-suite/failure/ltac4.v @@ -1,5 +1,6 @@ (* Check static globalisation of tactic names *) (* Proposed by Benjamin (mars 2002) *) Goal forall n : nat, n = n. -induction n; try REflexivity. +induction n. +Fail try REflexivity. diff --git a/test-suite/failure/pattern.v b/test-suite/failure/pattern.v index a24beaa2..216eb254 100644 --- a/test-suite/failure/pattern.v +++ b/test-suite/failure/pattern.v @@ -6,4 +6,4 @@ Variable P : forall m : nat, m = n -> Prop. Goal forall p : n = n, P n p. intro. -pattern n, p. +Fail pattern n, p. diff --git a/test-suite/failure/positivity.v b/test-suite/failure/positivity.v index 1c1080d1..d44bccdf 100644 --- a/test-suite/failure/positivity.v +++ b/test-suite/failure/positivity.v @@ -1,9 +1,9 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -Inductive t : Set := +Fail Inductive t : Set := c : (t -> nat) -> t. diff --git a/test-suite/failure/proofirrelevance.v b/test-suite/failure/proofirrelevance.v index 93e159e8..b62f9b68 100644 --- a/test-suite/failure/proofirrelevance.v +++ b/test-suite/failure/proofirrelevance.v @@ -6,6 +6,9 @@ Inductive bool_in_prop : Type := hide : bool -> bool_in_prop with bool : Type := true : bool | false : bool. Lemma not_proof_irrelevance : ~ forall (P:Prop) (p p':P), p=p'. -intro H; pose proof (H bool_in_prop (hide true) (hide false)); discriminate. -Qed. +intro H. +Fail pose proof (H bool_in_prop (hide true) (hide false)). +Abort. +(*discriminate. +Qed.*) diff --git a/test-suite/failure/prop-set-proof-irrelevance.v b/test-suite/failure/prop-set-proof-irrelevance.v index ad494108..fee33432 100644 --- a/test-suite/failure/prop-set-proof-irrelevance.v +++ b/test-suite/failure/prop-set-proof-irrelevance.v @@ -1,12 +1,12 @@ Require Import ProofIrrelevance. Lemma proof_irrelevance_set : forall (P : Set) (p1 p2 : P), p1 = p2. - exact proof_irrelevance. -Qed. + Fail exact proof_irrelevance. +(*Qed. Lemma paradox : False. assert (H : 0 <> 1) by discriminate. apply H. Fail apply proof_irrelevance. (* inlined version is rejected *) apply proof_irrelevance_set. -Qed. +Qed.*) diff --git a/test-suite/failure/redef.v b/test-suite/failure/redef.v index ef6d01d0..e5db8176 100644 --- a/test-suite/failure/redef.v +++ b/test-suite/failure/redef.v @@ -1,9 +1,9 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) Definition toto := Set. -Definition toto := Set. +Fail Definition toto := Set. diff --git a/test-suite/failure/rewrite_in_goal.v b/test-suite/failure/rewrite_in_goal.v index c11a6237..dedfdf01 100644 --- a/test-suite/failure/rewrite_in_goal.v +++ b/test-suite/failure/rewrite_in_goal.v @@ -1,3 +1,3 @@ Goal forall T1 T2 (H:T1=T2) (f:T1->Prop) (x:T1) , f x -> Type. intros until x. - rewrite H in x. + Fail rewrite H in x. diff --git a/test-suite/failure/rewrite_in_hyp.v b/test-suite/failure/rewrite_in_hyp.v index 613d707c..1eef0fa0 100644 --- a/test-suite/failure/rewrite_in_hyp.v +++ b/test-suite/failure/rewrite_in_hyp.v @@ -1,3 +1,3 @@ Goal forall (T1 T2 : Type) (f:T1 -> Prop) (x:T1) (H:T1=T2), f x -> 0=1. intros T1 T2 f x H fx. - rewrite H in x. + Fail rewrite H in x. diff --git a/test-suite/failure/rewrite_in_hyp2.v b/test-suite/failure/rewrite_in_hyp2.v index 1533966e..112a856e 100644 --- a/test-suite/failure/rewrite_in_hyp2.v +++ b/test-suite/failure/rewrite_in_hyp2.v @@ -5,4 +5,4 @@ Goal forall b, S b = O -> (fun a => 0 = (S a)) b -> True. intros b H H0. - rewrite H in H0. + Fail rewrite H in H0. diff --git a/test-suite/failure/search.v b/test-suite/failure/search.v index 9c35ecfb..a6e6bc48 100644 --- a/test-suite/failure/search.v +++ b/test-suite/failure/search.v @@ -1,9 +1,9 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -SearchPattern (_ = _) outside n_existe_pas. +Fail SearchPattern (_ = _) outside n_existe_pas. diff --git a/test-suite/failure/sortelim.v b/test-suite/failure/sortelim.v new file mode 100644 index 00000000..2b3cf106 --- /dev/null +++ b/test-suite/failure/sortelim.v @@ -0,0 +1,149 @@ +(* This is a proof of false which used to be accepted by Coq (Jan 12, 2014) due +to a DeBruijn index error in the check for allowed elimination sorts. + +Proof by Maxime Dénès, using a proof of Hurkens' paradox by Hugo Herbelin to derive +inconsistency. *) + +(* We start by adapting the proof of Hurkens' paradox by Hugo in +theories/Logic/Hurkens.v, so that instead of requiring a retract +from Type into Prop up to equality, we require it only up to +equivalence. +*) + +Section Hurkens. + +Definition Type2 := Type. +Definition Type1 := Type : Type2. + +(** Assumption of a retract from Type into Prop *) + +Variable down : Type1 -> Prop. +Variable up : Prop -> Type1. + +Hypothesis back : forall A, up (down A) -> A. + +Hypothesis forth : forall A, A -> up (down A). + +Hypothesis backforth : forall (A:Type) (P:A->Type) (a:A), + P (back A (forth A a)) -> P a. + +Hypothesis backforth_r : forall (A:Type) (P:A->Type) (a:A), + P a -> P (back A (forth A a)). + +(** Proof *) + +Definition V : Type1 := forall A:Prop, ((up A -> Prop) -> up A -> Prop) -> up A -> Prop. +Definition U : Type1 := V -> Prop. + +Definition sb (z:V) : V := fun A r a => r (z A r) a. +Definition le (i:U -> Prop) (x:U) : Prop := x (fun A r a => i (fun v => sb v A r a)). +Definition le' (i:up (down U) -> Prop) (x:up (down U)) : Prop := le (fun a:U => i (forth _ a)) (back _ x). +Definition induct (i:U -> Prop) : Type1 := forall x:U, up (le i x) -> up (i x). +Definition WF : U := fun z => down (induct (fun a => z (down U) le' (forth _ a))). +Definition I (x:U) : Prop := + (forall i:U -> Prop, up (le i x) -> up (i (fun v => sb v (down U) le' (forth _ x)))) -> False. + +Lemma Omega : forall i:U -> Prop, induct i -> up (i WF). +Proof. +intros i y. +apply y. +unfold le, WF, induct. +apply forth. +intros x H0. +apply y. +unfold sb, le', le. +compute. +apply backforth_r. +exact H0. +Qed. + +Lemma lemma1 : induct (fun u => down (I u)). +Proof. +unfold induct. +intros x p. +apply forth. +intro q. +generalize (q (fun u => down (I u)) p). +intro r. +apply back in r. +apply r. +intros i j. +unfold le, sb, le', le in j |-. +apply backforth in j. +specialize q with (i := fun y => i (fun v:V => sb v (down U) le' (forth _ y))). +apply q. +exact j. +Qed. + +Lemma lemma2 : (forall i:U -> Prop, induct i -> up (i WF)) -> False. +Proof. +intro x. +generalize (x (fun u => down (I u)) lemma1). +intro r; apply back in r. +apply r. +intros i H0. +apply (x (fun y => i (fun v => sb v (down U) le' (forth _ y)))). +unfold le, WF in H0. +apply back in H0. +exact H0. +Qed. + +Theorem paradox : False. +Proof. +exact (lemma2 Omega). +Qed. + +End Hurkens. + +(* Alright, now we use a DeBruijn index off-by-1 error to build a type +satisfying the hypotheses of the paradox. What is tricky is that the pretyper is +not affected by the bug (only the kernel is). Even worse, since our goal is to +bypass the elimination restriction for types in Prop, we have to devise a way to +feed the kernel with an illegal pattern matching without going through the +pattern matching compiler (which calls the pretyper). The trick is to use the +record machinery, which defines projections, checking if the kernel accepts +it. *) + +Definition informative (x : bool) := + match x with + | true => Type + | false => Prop + end. + +Definition depsort (T : Type) (x : bool) : informative x := + match x with + | true => T + | false => True + end. + +(* The let-bound parameters in the record below trigger the error *) + +Record Box (ff := false) (tt := true) (T : Type) : Prop := + wrap {prop : depsort T tt}. + +Definition down (x : Type) : Prop := Box x. +Definition up (x : Prop) : Type := x. + +Fail Definition back A : up (down A) -> A := prop A. + +(* If the projection has been defined, the following script derives a proof of +false. + +Definition forth A : A -> up (down A) := wrap A. + +Definition backforth (A:Type) (P:A->Type) (a:A) : + P (back A (forth A a)) -> P a := fun H => H. + +Definition backforth_r (A:Type) (P:A->Type) (a:A) : + P a -> P (back A (forth A a)) := fun H => H. + +(* Everything set up, we just check that we built the right context for the +paradox to apply. *) + +Theorem pandora : False. +apply (paradox down up back forth backforth backforth_r). +Qed. + +Print Assumptions pandora. + +*)
\ No newline at end of file diff --git a/test-suite/failure/subterm.v b/test-suite/failure/subterm.v new file mode 100644 index 00000000..3798bc48 --- /dev/null +++ b/test-suite/failure/subterm.v @@ -0,0 +1,45 @@ +Module Foo. + Inductive True2:Prop:= I2: (False->True2)->True2. + + Axiom Heq: (False->True2)=True2. + + Fail Fixpoint con (x:True2) :False := + match x with + I2 f => con (match Heq with @eq_refl _ _ => f end) + end. +End Foo. + +Require Import ClassicalFacts. + +Inductive True1 : Prop := I1 : True1 +with True2 : Prop := I2 : True1 -> True2. + +Section func_unit_discr. + +Hypothesis Heq : True1 = True2. + +Fail Fixpoint contradiction (u : True2) : False := +contradiction ( + match u with + | I2 Tr => + match Heq in (_ = T) return T with + | eq_refl => Tr + end + end). + +End func_unit_discr. + +Require Import Vectors.VectorDef. + +About caseS. +About tl. +Open Scope vector_scope. +Local Notation "[]" := (@nil _). +Local Notation "h :: t" := (@cons _ h _ t) (at level 60, right associativity). +Definition is_nil {A n} (v : t A n) : bool := match v with [] => true | _ => false end. + +Fixpoint id {A n} (v : t A n) : t A n := + match v in t _ n' return t A n' with + | (h :: t) as v' => h :: id (tl v') + |_ => [] + end. diff --git a/test-suite/failure/subterm2.v b/test-suite/failure/subterm2.v new file mode 100644 index 00000000..a420a4d7 --- /dev/null +++ b/test-suite/failure/subterm2.v @@ -0,0 +1,48 @@ +(* An example showing that prop-extensionality is incompatible with + powerful extensions of the guard condition. + Unlike the example in guard2, it is not exploiting the fact that + the elimination of False always produces a subterm. + + Example due to Cristobal Camarero on Coq-Club. + Adapted to nested types by Bruno Barras. + *) + +Axiom prop_ext: forall P Q, (P<->Q)->P=Q. + +Module Unboxed. + +Inductive True2:Prop:= I2: (False->True2)->True2. + +Theorem Heq: (False->True2)=True2. +Proof. +apply prop_ext. split. +- intros. constructor. exact H. +- intros. exact H. +Qed. + +Fail Fixpoint con (x:True2) :False := +match x with +I2 f => con (match Heq in _=T return T with eq_refl => f end) +end. + +End Unboxed. + +(* This boxed example shows that it is not enough to just require + that the return type of the match on Heq is an inductive type + *) +Module Boxed. + +Inductive box (T:Type) := Box (_:T). +Definition unbox {T} (b:box T) : T := let (x) := b in x. + +Inductive True2:Prop:= I2: box(False->True2)->True2. + +Definition Heq: (False->True2) <-> True2 := + conj (fun f => I2 (Box _ f)) (fun x _ => x). + +Fail Fixpoint con (x:True2) :False := +match x with +I2 f => con (unbox(match prop_ext _ _ Heq in _=T return box T with eq_refl => f end)) +end. + +End Boxed. diff --git a/test-suite/failure/subterm3.v b/test-suite/failure/subterm3.v new file mode 100644 index 00000000..2cef6357 --- /dev/null +++ b/test-suite/failure/subterm3.v @@ -0,0 +1,29 @@ +(* An example showing that prop-extensionality is incompatible with + powerful extensions of the guard condition. + This is a variation on the example in subterm2, exploiting + missing typing constraints in the commutative cut subterm rule + (subterm2 is using the same flaw but for the match rule). + + Example due to Cristóbal Camarero on Coq-Club. + *) + +Axiom prop_ext: forall P Q, (P <-> Q) -> P=Q. + +Inductive True2 : Prop := I3 : (False -> True2) -> True2. + +Theorem T3T: True2 = True. +Proof. +apply prop_ext; split; auto. +intros; constructor; apply False_rect. +Qed. + +Theorem T3F_FT3F : (True2 -> False) = ((False -> True2) -> False). +Proof. +rewrite T3T. +apply prop_ext; split; auto. +Qed. + +Fail Fixpoint loop (x : True2) : False := +match x with +I3 f => (match T3F_FT3F in _=T return T with eq_refl=> loop end) f +end. diff --git a/test-suite/failure/subtyping.v b/test-suite/failure/subtyping.v index 127da851..e48c6689 100644 --- a/test-suite/failure/subtyping.v +++ b/test-suite/failure/subtyping.v @@ -18,4 +18,4 @@ Module TT : T. | L0 | L1 : (A -> Prop) -> L. -End TT. +Fail End TT. diff --git a/test-suite/failure/subtyping2.v b/test-suite/failure/subtyping2.v index 48fc2fff..8b2dc1dc 100644 --- a/test-suite/failure/subtyping2.v +++ b/test-suite/failure/subtyping2.v @@ -242,4 +242,4 @@ Defined. with the constraint j >= i in the paradox. *) - Definition Paradox : False := Burali_Forti A0 i0' inj. + Fail Definition Paradox : False := Burali_Forti A0 i0' inj. diff --git a/test-suite/failure/univ_include.v b/test-suite/failure/univ_include.v index 56f04f9d..28a3263d 100644 --- a/test-suite/failure/univ_include.v +++ b/test-suite/failure/univ_include.v @@ -23,8 +23,8 @@ Module Mt. Definition t := T. End Mt. -Module P := G Mt. (* should yield Universe inconsistency *) +Fail Module P := G Mt. (* should yield Universe inconsistency *) (* ... otherwise the following command will show that T has type T! *) -Eval cbv delta [P.elt Mt.t] in P.elt. +(* Eval cbv delta [P.elt Mt.t] in P.elt. *) diff --git a/test-suite/failure/universes-buraliforti-redef.v b/test-suite/failure/universes-buraliforti-redef.v index a8b5b975..e0168158 100644 --- a/test-suite/failure/universes-buraliforti-redef.v +++ b/test-suite/failure/universes-buraliforti-redef.v @@ -230,17 +230,17 @@ End Burali_Forti_Paradox. intros. change match i0 X1 R1, i0 X2 R2 with - | i1 x1 r1, i1 x2 r2 => exists f : _, morphism x1 r1 x2 r2 f + | i1 _ _ x1 r1, i1 _ _ x2 r2 => exists f : _, morphism x1 r1 x2 r2 f end. case H; simpl. exists (fun x : X1 => x). red; trivial. Defined. -(* The following command raises 'Error: Universe Inconsistency'. +(* The following command should raise 'Error: Universe Inconsistency'. To allow large elimination of A0, i0 must not be a large constructor. Hence, the constraint Type_j' < Type_i' is added, which is incompatible with the constraint j >= i in the paradox. *) - Definition Paradox : False := Burali_Forti A0 i0 inj. + Fail Definition Paradox : False := Burali_Forti A0 i0 inj. diff --git a/test-suite/failure/universes-buraliforti.v b/test-suite/failure/universes-buraliforti.v index 7b62a0c5..dba1a794 100644 --- a/test-suite/failure/universes-buraliforti.v +++ b/test-suite/failure/universes-buraliforti.v @@ -234,4 +234,4 @@ Defined. with the constraint j >= i in the paradox. *) - Definition Paradox : False := Burali_Forti A0 i0 inj. + Fail Definition Paradox : False := Burali_Forti A0 i0 inj. diff --git a/test-suite/failure/universes-sections1.v b/test-suite/failure/universes-sections1.v index 6cd04349..3f8e4446 100644 --- a/test-suite/failure/universes-sections1.v +++ b/test-suite/failure/universes-sections1.v @@ -5,4 +5,4 @@ Section A. Definition Type1 : Type2 := Type. End A. -Definition Inconsistency : Type1 := Type2. +Fail Definition Inconsistency : Type1 := Type2. diff --git a/test-suite/failure/universes-sections2.v b/test-suite/failure/universes-sections2.v index 98fdbc0d..34b2a11d 100644 --- a/test-suite/failure/universes-sections2.v +++ b/test-suite/failure/universes-sections2.v @@ -7,4 +7,4 @@ Section A. Definition Type1' := Type1. End A. -Definition Inconsistency : Type1' := Type2. +Fail Definition Inconsistency : Type1' := Type2. diff --git a/test-suite/failure/universes.v b/test-suite/failure/universes.v index 938c29b8..d708b01f 100644 --- a/test-suite/failure/universes.v +++ b/test-suite/failure/universes.v @@ -1,3 +1,3 @@ Definition Type2 := Type. Definition Type1 : Type2 := Type. -Definition Inconsistency : Type1 := Type2. +Fail Definition Inconsistency : Type1 := Type2. diff --git a/test-suite/failure/universes3.v b/test-suite/failure/universes3.v index 8fb414d5..ee7a63c8 100644 --- a/test-suite/failure/universes3.v +++ b/test-suite/failure/universes3.v @@ -17,7 +17,7 @@ Inductive I (B:Type (*6*)) := C : B -> impl Prop (I B). (* We cannot enforce Type1 < Type(6) while we already have Type(6) <= Type(7) < Type3 < Type1 *) -Definition J := I Type1. +Fail Definition J := I Type1. (* Open question: should the type of an inductive be the max of the types of the _arguments_ of its constructors (here B and Prop, diff --git a/test-suite/ide/blocking-futures.fake b/test-suite/ide/blocking-futures.fake new file mode 100644 index 00000000..b63f09bc --- /dev/null +++ b/test-suite/ide/blocking-futures.fake @@ -0,0 +1,16 @@ +# Script simulating a dialog between coqide and coqtop -ideslave +# Run it via fake_ide +# +# Extraction will force the future computation, assert it is blocking +# Example courtesy of Jonathan (jonikelee) +# +ADD { Require Import List. } +ADD { Import ListNotations. } +ADD { Definition myrev{A}(l : list A) : {rl : list A | rl = rev l}. } +ADD { Proof. } +ADD { induction l. } +ADD { eexists; reflexivity. } +ADD { cbn; destruct IHl as [rl' H]; rewrite <-H; eexists; reflexivity. } +ADD { Qed. } +ADD { Extraction myrev. } +GOALS diff --git a/test-suite/ide/undo001.fake b/test-suite/ide/undo001.fake index bbaea7e7..55263615 100644 --- a/test-suite/ide/undo001.fake +++ b/test-suite/ide/undo001.fake @@ -3,8 +3,8 @@ # # Simple backtrack by 1 between two global definitions # -INTERP Definition foo := 0. -INTERP Definition bar := 1. -REWIND 1 -INTERPRAW Check foo. -INTERPRAW Fail Check bar. +ADD here { Definition foo := 0. } +ADD { Definition bar := 1. } +EDIT_AT here +QUERY { Check foo. } +QUERY { Fail Check bar. } diff --git a/test-suite/ide/undo002.fake b/test-suite/ide/undo002.fake index b855b6ea..5284c5d3 100644 --- a/test-suite/ide/undo002.fake +++ b/test-suite/ide/undo002.fake @@ -3,8 +3,8 @@ # # Simple backtrack by 2 before two global definitions # -INTERP Definition foo := 0. -INTERP Definition bar := 1. -REWIND 2 -INTERPRAW Fail Check foo. -INTERPRAW Fail Check bar. +ADD { Definition foo := 0. } +ADD { Definition bar := 1. } +EDIT_AT initial +QUERY { Fail Check foo. } +QUERY { Fail Check bar. } diff --git a/test-suite/ide/undo003.fake b/test-suite/ide/undo003.fake index 4c72e8dc..90757627 100644 --- a/test-suite/ide/undo003.fake +++ b/test-suite/ide/undo003.fake @@ -3,6 +3,6 @@ # # Simple backtrack by 0 should be a no-op # -INTERP Definition foo := 0. -REWIND 0 -INTERPRAW Check foo. +ADD here { Definition foo := 0. } +EDIT_AT here +QUERY { Check foo. } diff --git a/test-suite/ide/undo004.fake b/test-suite/ide/undo004.fake index c2ddfb8c..9029b03e 100644 --- a/test-suite/ide/undo004.fake +++ b/test-suite/ide/undo004.fake @@ -3,12 +3,12 @@ # # Undoing arbitrary commands, as first step # -INTERP Theorem a : O=O. -INTERP Ltac f x := x. -REWIND 1 +ADD here { Theorem a : O=O. } +ADD { Ltac f x := x. } +EDIT_AT here # <replay> -INTERP Ltac f x := x. +ADD { Ltac f x := x. } # <\replay> -INTERP assert True by trivial. -INTERP trivial. -INTERP Qed. +ADD { assert True by trivial. } +ADD { trivial. } +ADD { Qed. } diff --git a/test-suite/ide/undo005.fake b/test-suite/ide/undo005.fake index 525b9f2a..7e31c0b0 100644 --- a/test-suite/ide/undo005.fake +++ b/test-suite/ide/undo005.fake @@ -3,13 +3,13 @@ # # Undoing arbitrary commands, as non-first step # -INTERP Theorem b : O=O. -INTERP assert True by trivial. -INTERP Ltac g x := x. +ADD { Theorem b : O=O. } +ADD here { assert True by trivial. } +ADD { Ltac g x := x. } # <replay> -REWIND 1 +EDIT_AT here # <\replay> -INTERP Ltac g x := x. -INTERP assert True by trivial. -INTERP trivial. -INTERP Qed. +ADD { Ltac g x := x. } +ADD { assert True by trivial. } +ADD { trivial. } +ADD { Qed. } diff --git a/test-suite/ide/undo006.fake b/test-suite/ide/undo006.fake index ed88bef5..cdfdee1b 100644 --- a/test-suite/ide/undo006.fake +++ b/test-suite/ide/undo006.fake @@ -4,11 +4,11 @@ # Undoing declarations, as first step # Was bugged in 8.1 # -INTERP Theorem c : O=O. -INTERP Inductive T : Type := I. -REWIND 1 +ADD here { Theorem c : O=O. } +ADD { Inductive T : Type := I. } +EDIT_AT here # <replay> -INTERP Inductive T : Type := I. +ADD { Inductive T : Type := I. } # <\replay> -INTERP trivial. -INTERP Qed. +ADD { trivial. } +ADD { Qed. } diff --git a/test-suite/ide/undo007.fake b/test-suite/ide/undo007.fake deleted file mode 100644 index 87c06dbb..00000000 --- a/test-suite/ide/undo007.fake +++ /dev/null @@ -1,17 +0,0 @@ -# Script simulating a dialog between coqide and coqtop -ideslave -# Run it via fake_ide -# -# Undoing declarations, as first step -# new in 8.2 -# -INTERP Theorem d : O=O. -INTERP Definition e := O. -INTERP Definition f := O. -REWIND 1 -# <replay> -INTERP Definition f := O. -# <\replay> -INTERP assert True by trivial. -INTERP trivial. -INTERP Qed. -INTERPRAW Check e. diff --git a/test-suite/ide/undo008.fake b/test-suite/ide/undo008.fake index 1c46c1e8..72cab7a3 100644 --- a/test-suite/ide/undo008.fake +++ b/test-suite/ide/undo008.fake @@ -4,15 +4,15 @@ # Undoing declarations, as non-first step # new in 8.2 # -INTERP Theorem h : O=O. -INTERP assert True by trivial. -INTERP Definition i := O. -INTERP Definition j := O. -REWIND 1 +ADD { Theorem h : O=O. } +ADD { assert True by trivial. } +ADD here { Definition i := O. } +ADD { Definition j := O. } +EDIT_AT here # <replay> -INTERP Definition j := O. +ADD { Definition j := O. } # <\replay> -INTERP assert True by trivial. -INTERP trivial. -INTERP Qed. -INTERPRAW Check i. +ADD { assert True by trivial. } +ADD { trivial. } +ADD { Qed. } +QUERY { Check i. } diff --git a/test-suite/ide/undo009.fake b/test-suite/ide/undo009.fake index 47c77d23..76f400ef 100644 --- a/test-suite/ide/undo009.fake +++ b/test-suite/ide/undo009.fake @@ -4,17 +4,18 @@ # Undoing declarations, interleaved with proof steps # new in 8.2 *) # -INTERP Theorem k : O=O. -INTERP assert True by trivial. -INTERP Definition l := O. -INTERP assert True by trivial. -INTERP Definition m := O. -REWIND 3 +ADD { Theorem k : O=O. } +ADD here { assert True by trivial. } +ADD { Definition l := O. } +ADD { assert True by trivial. } +ADD { Definition m := O. } +QUERY { Show. } +EDIT_AT here # <replay> -INTERP Definition l := O. -INTERP assert True by trivial. -INTERP Definition m := O. +ADD { Definition l := O. } +ADD { assert True by trivial. } +ADD { Definition m := O. } # <\replay> -INTERP assert True by trivial. -INTERP trivial. -INTERP Qed. +ADD { assert True by trivial. } +ADD { trivial. } +ADD { Qed. } diff --git a/test-suite/ide/undo010.fake b/test-suite/ide/undo010.fake index 4fe9df98..524416c3 100644 --- a/test-suite/ide/undo010.fake +++ b/test-suite/ide/undo010.fake @@ -4,25 +4,25 @@ # Undoing declarations, interleaved with proof steps and commands *) # new in 8.2 *) # -INTERP Theorem n : O=O. -INTERP assert True by trivial. -INTERP Definition o := O. -INTERP Ltac h x := x. -INTERP assert True by trivial. -INTERP Focus. -INTERP Definition p := O. -REWIND 1 -REWIND 1 -REWIND 1 -REWIND 1 -REWIND 1 +ADD { Theorem n : O=O. } +ADD s2 { assert True by trivial. } +ADD s3 { Definition o := O. } +ADD s4 { Ltac h x := x. } +ADD s5 { assert True by trivial. } +ADD s6 { Focus. } +ADD { Definition p := O. } +EDIT_AT s6 +EDIT_AT s5 +EDIT_AT s4 +EDIT_AT s3 +EDIT_AT s2 # <replay> -INTERP Definition o := O. -INTERP Ltac h x := x. -INTERP assert True by trivial. -INTERP Focus. -INTERP Definition p := O. +ADD { Definition o := O. } +ADD { Ltac h x := x. } +ADD { assert True by trivial. } +ADD { Focus. } +ADD { Definition p := O. } # </replay> -INTERP assert True by trivial. -INTERP trivial. -INTERP Qed. +ADD { assert True by trivial. } +ADD { trivial. } +ADD { Qed. } diff --git a/test-suite/ide/undo011.fake b/test-suite/ide/undo011.fake index cc85a764..0be439b2 100644 --- a/test-suite/ide/undo011.fake +++ b/test-suite/ide/undo011.fake @@ -4,29 +4,31 @@ # Bug 2082 # Broken due to proof engine rewriting # -INTERP Variable A : Prop. -INTERP Variable B : Prop. -INTERP Axiom OR : A \/ B. -INTERP Lemma MyLemma2 : True. -INTERP proof. -INTERP per cases of (A \/ B) by OR. -INTERP suppose A. -INTERP then (1 = 1). -INTERP then H1 : thesis. -INTERP thus thesis by H1. -INTERP suppose B. -REWIND 1 +ADD { Variable A : Prop. } +ADD { Variable B : Prop. } +ADD { Axiom OR : A \/ B. } +ADD { Lemma MyLemma2 : True. } +ADD { proof. } +ADD { per cases of (A \/ B) by OR. } +ADD { suppose A. } +ADD { then (1 = 1). } +ADD there { then H1 : thesis. } +ADD here { thus thesis by H1. } +ADD { suppose B. } +QUERY { Show. } +EDIT_AT here # <replay> -INTERP suppose B. +ADD { suppose B. } # </replay> -REWIND 2 +EDIT_AT there # <replay> -INTERP thus thesis by H1. -INTERP suppose B. +ADD { thus thesis by H1. } +ADD { suppose B. } # </replay> -INTERP then (1 = 1). -INTERP then H2 : thesis. -INTERP thus thesis by H2. -INTERP end cases. -INTERP end proof. -INTERP Qed. +QUERY { Show. } +ADD { then (1 = 1). } +ADD { then H2 : thesis. } +ADD { thus thesis by H2. } +ADD { end cases. } +ADD { end proof. } +ADD { Qed. } diff --git a/test-suite/ide/undo012.fake b/test-suite/ide/undo012.fake index f9b29ca1..b3d1c6d5 100644 --- a/test-suite/ide/undo012.fake +++ b/test-suite/ide/undo012.fake @@ -2,25 +2,25 @@ # Run it via fake_ide # # Test backtracking in presence of nested proofs -# First, undoing the whole # -INTERP Lemma aa : True -> True /\ True. -INTERP intro H. -INTERP split. -INTERP Lemma bb : False -> False. -INTERP intro H. -INTERP apply H. -INTERP Qed. -INTERP apply H. -INTERP Lemma cc : False -> True. -INTERP intro H. -INTERP destruct H. -INTERP Qed. -INTERP apply H. -INTERP Qed. -REWIND 1 -# We should now be just before aa, without opened proofs -INTERPRAW Fail idtac. -INTERPRAW Fail Check aa. -INTERPRAW Fail Check bb. -INTERPRAW Fail Check cc. +ADD { Lemma aa : True -> True /\ True. } +ADD { intro H. } +ADD { split. } +ADD { Lemma bb : False -> False. } +ADD { intro H. } +ADD { apply H. } +ADD { Qed. } +ADD { apply H. } +ADD { Lemma cc : False -> True. } +ADD { intro H. } +ADD { destruct H. } +ADD { Qed. } +QUERY { Show. } +ADD here { apply H. } +ADD { Qed. } +EDIT_AT here +# We should now be just before the Qed. +QUERY { Fail Check aa. } +QUERY { Check bb. } +QUERY { Check cc. } +ADD { Qed. } diff --git a/test-suite/ide/undo013.fake b/test-suite/ide/undo013.fake index 3b1c61e6..f44156aa 100644 --- a/test-suite/ide/undo013.fake +++ b/test-suite/ide/undo013.fake @@ -2,30 +2,26 @@ # Run it via fake_ide # # Test backtracking in presence of nested proofs -# Second, trigger the full undo of an inner proof +# Second, trigger the undo of an inner proof # -INTERP Lemma aa : True -> True /\ True. -INTERP intro H. -INTERP split. -INTERP Lemma bb : False -> False. -INTERP intro H. -INTERP apply H. -INTERP Qed. -INTERP apply H. -INTERP Lemma cc : False -> True. -INTERP intro H. -INTERP destruct H. -INTERP Qed. -INTERP apply H. -REWIND 2 -# We should now be just before "Lemma cc" +ADD { Lemma aa : True -> True /\ True. } +ADD { intro H. } +ADD { split. } +ADD { Lemma bb : False -> False. } +ADD { intro H. } +ADD { apply H. } +ADD { Qed. } +ADD { apply H. } +ADD { Lemma cc : False -> True. } +ADD { intro H. } +ADD here { destruct H. } +ADD { Qed. } +ADD { apply H. } +EDIT_AT here # <replay> -INTERP Lemma cc : False -> True. -INTERP intro H. -INTERP destruct H. -INTERP Qed. -INTERP apply H. +ADD { Qed. } +ADD { apply H. } # </replay> -INTERP Qed. -INTERPRAW Fail idtac. -INTERPRAW Check (aa,bb,cc). +ADD { Qed. } +QUERY { Fail idtac. } +QUERY { Check (aa,bb,cc). } diff --git a/test-suite/ide/undo014.fake b/test-suite/ide/undo014.fake index 5224b504..6d58b061 100644 --- a/test-suite/ide/undo014.fake +++ b/test-suite/ide/undo014.fake @@ -4,23 +4,23 @@ # Test backtracking in presence of nested proofs # Third, undo inside an inner proof # -INTERP Lemma aa : True -> True /\ True. -INTERP intro H. -INTERP split. -INTERP Lemma bb : False -> False. -INTERP intro H. -INTERP apply H. -INTERP Qed. -INTERP apply H. -INTERP Lemma cc : False -> True. -INTERP intro H. -INTERP destruct H. -REWIND 1 +ADD { Lemma aa : True -> True /\ True. } +ADD { intro H. } +ADD { split. } +ADD { Lemma bb : False -> False. } +ADD { intro H. } +ADD { apply H. } +ADD { Qed. } +ADD { apply H. } +ADD { Lemma cc : False -> True. } +ADD here { intro H. } +ADD { destruct H. } +EDIT_AT here # <replay> -INTERP destruct H. +ADD { destruct H. } # </replay> -INTERP Qed. -INTERP apply H. -INTERP Qed. -INTERPRAW Fail idtac. -INTERPRAW Check (aa,bb,cc). +ADD { Qed. } +ADD { apply H. } +ADD { Qed. } +QUERY { Fail idtac. } +QUERY { Check (aa,bb,cc). } diff --git a/test-suite/ide/undo015.fake b/test-suite/ide/undo015.fake index 32e46ec9..ac17985a 100644 --- a/test-suite/ide/undo015.fake +++ b/test-suite/ide/undo015.fake @@ -4,26 +4,26 @@ # Test backtracking in presence of nested proofs # Fourth, undo from an inner proof to a above proof # -INTERP Lemma aa : True -> True /\ True. -INTERP intro H. -INTERP split. -INTERP Lemma bb : False -> False. -INTERP intro H. -INTERP apply H. -INTERP Qed. -INTERP apply H. -INTERP Lemma cc : False -> True. -INTERP intro H. -INTERP destruct H. -REWIND 4 +ADD { Lemma aa : True -> True /\ True. } +ADD { intro H. } +ADD { split. } +ADD { Lemma bb : False -> False. } +ADD { intro H. } +ADD { apply H. } +ADD here { Qed. } +ADD { apply H. } +ADD { Lemma cc : False -> True. } +ADD { intro H. } +ADD { destruct H. } +EDIT_AT here # <replay> -INTERP apply H. -INTERP Lemma cc : False -> True. -INTERP intro H. -INTERP destruct H. +ADD { apply H. } +ADD { Lemma cc : False -> True. } +ADD { intro H. } +ADD { destruct H. } # </replay> -INTERP Qed. -INTERP apply H. -INTERP Qed. -INTERPRAW Fail idtac. -INTERPRAW Check (aa,bb,cc). +ADD { Qed. } +ADD { apply H. } +ADD { Qed. } +QUERY { Fail idtac. } +QUERY { Check (aa,bb,cc). } diff --git a/test-suite/ide/undo016.fake b/test-suite/ide/undo016.fake index 2a6e512c..bdb81ecd 100644 --- a/test-suite/ide/undo016.fake +++ b/test-suite/ide/undo016.fake @@ -4,31 +4,28 @@ # Test backtracking in presence of nested proofs # Fifth, undo from an inner proof to a previous inner proof # -INTERP Lemma aa : True -> True /\ True. -INTERP intro H. -INTERP split. -INTERP Lemma bb : False -> False. -INTERP intro H. -INTERP apply H. -INTERP Qed. -INTERP apply H. -INTERP Lemma cc : False -> True. -INTERP intro H. -INTERP destruct H. -REWIND 6 -# We should be just before "Lemma bb" +ADD { Lemma aa : True -> True /\ True. } +ADD { intro H. } +ADD { split. } +ADD { Lemma bb : False -> False. } +ADD here { intro H. } +ADD { apply H. } +ADD { Qed. } +ADD { apply H. } +ADD { Lemma cc : False -> True. } +ADD { intro H. } +ADD { destruct H. } +EDIT_AT here # <replay> -INTERP Lemma bb : False -> False. -INTERP intro H. -INTERP apply H. -INTERP Qed. -INTERP apply H. -INTERP Lemma cc : False -> True. -INTERP intro H. -INTERP destruct H. +ADD { apply H. } +ADD { Qed. } +ADD { apply H. } +ADD { Lemma cc : False -> True. } +ADD { intro H. } +ADD { destruct H. } # </replay> -INTERP Qed. -INTERP apply H. -INTERP Qed. -INTERPRAW Fail idtac. -INTERPRAW Check (aa,bb,cc). +ADD { Qed. } +ADD { apply H. } +ADD { Qed. } +QUERY { Fail idtac. } +QUERY { Check (aa,bb,cc). } diff --git a/test-suite/ide/undo017.fake b/test-suite/ide/undo017.fake index 232360e9..37423dc7 100644 --- a/test-suite/ide/undo017.fake +++ b/test-suite/ide/undo017.fake @@ -3,11 +3,11 @@ # # bug #2569 : Undoing inside modules # -INTERP Module M. -INTERP Definition x := 0. -INTERP End M. -REWIND 1 +ADD { Module M. } +ADD here { Definition x := 0. } +ADD { End M. } +EDIT_AT here # <replay> -INTERP End M. +ADD { End M. } # </replay> -INTERPRAW Check M.x. +QUERY { Check M.x. } diff --git a/test-suite/ide/undo018.fake b/test-suite/ide/undo018.fake index ef0945ab..11091bfa 100644 --- a/test-suite/ide/undo018.fake +++ b/test-suite/ide/undo018.fake @@ -3,11 +3,11 @@ # # bug #2569 : Undoing inside section # -INTERP Section M. -INTERP Definition x := 0. -INTERP End M. -REWIND 1 +ADD { Section M. } +ADD here { Definition x := 0. } +ADD { End M. } +EDIT_AT here # <replay> -INTERP End M. +ADD { End M. } # </replay> -INTERPRAW Check x. +QUERY { Check x. } diff --git a/test-suite/ide/undo019.fake b/test-suite/ide/undo019.fake index 70e70d7e..5df49ebb 100644 --- a/test-suite/ide/undo019.fake +++ b/test-suite/ide/undo019.fake @@ -3,12 +3,12 @@ # # bug #2569 : Undoing a focused subproof # -INTERP Goal True. -INTERP { -INTERP exact I. -INTERP } -REWIND 1 +ADD { Goal True. } +ADD { \{ } +ADD here { exact I. } +ADD { \} } +EDIT_AT here # <replay> -INTERP } +ADD { \} } # </replay> -INTERP Qed. +ADD { Qed. } diff --git a/test-suite/ide/undo020.fake b/test-suite/ide/undo020.fake new file mode 100644 index 00000000..2adde908 --- /dev/null +++ b/test-suite/ide/undo020.fake @@ -0,0 +1,27 @@ +# Script simulating a dialog between coqide and coqtop -ideslave +# Run it via fake_ide +# +# focusing a broken proof and fixing it + +# first proof +ADD { Lemma a : True. } +ADD { Proof using. } +ADD here { idtac. } +ADD { exact Ix. } +ADD { Qed. } +# second proof +ADD { Lemma b : False. } +ADD { Proof using. } +ADD { admit. } +ADD last { Qed. } +# We join and expect some proof to fail +WAIT +# Going back to the error +EDIT_AT here +# Fixing the proof +ADD { exact I. } +ADD { Qed. } +# we are back at the end +ASSERT TIP last +QUERY { Check a. } +QUERY { Check b. } diff --git a/test-suite/ide/undo021.fake b/test-suite/ide/undo021.fake new file mode 100644 index 00000000..0d83ad25 --- /dev/null +++ b/test-suite/ide/undo021.fake @@ -0,0 +1,29 @@ +# Script simulating a dialog between coqide and coqtop -ideslave +# Run it via fake_ide +# +# jumping between broken proofs + +# first proof +ADD { Lemma a : True. } +ADD { Proof using. } +ADD here { idtac. } +ADD { exact Ix. } +ADD { Qed. } +# second proof +ADD { Lemma b : True. } +ADD here2 { Proof using. } +ADD { exact Ix. } +ADD { Qed. } +# We wait all slaves and expect both proofs to fail +WAIT +# Going back to the error +EDIT_AT here2 +# this is not implemented yet, all after here is erased +EDIT_AT here +# Fixing the proof +ADD { exact I. } +ADD last { Qed. } +ASSERT TIP last +# we are back at the end +QUERY { Check a. } +QUERY { Fail Check b. } diff --git a/test-suite/ide/undo022.fake b/test-suite/ide/undo022.fake new file mode 100644 index 00000000..51d8d106 --- /dev/null +++ b/test-suite/ide/undo022.fake @@ -0,0 +1,41 @@ +# Script simulating a dialog between coqide and coqtop -ideslave +# Run it via fake_ide +# +# jumping between broken proofs + interp error while fixing. +# the error should note make the GUI unfocus the currently focused proof. + +# first proof +ADD { Lemma a : True /\ True. } +ADD { Proof using. } +ADD here { split. } +ADD { exact Ix. } # first error +ADD { exact Ix. } # second error +ADD { Qed. } +# second proof +ADD { Lemma b : True. } +ADD { Proof using. } +ADD { exact I. } +ADD last { Qed. } +# We wait all slaves and expect both proofs to fail +WAIT +# Going back to the error +EDIT_AT here +# Fixing the proof +ADD fix { exact I. } +# showing the goals +GOALS +# re adding the wrong step +ADD { exact Ix. } +# showing the goals (failure) and retracting to the safe state suggested by Coq +FAILGOALS +# we assert we jumped back to the state immediately before the last (erroneous) +# one +ASSERT TIP fix +# finish off the proof +ADD { exact I. } +ADD { Qed. } +# here we unfocus, hence we jump back to the end of the document +ASSERT TIP last +# we are back at the end +QUERY { Check a. } +QUERY { Check b. } diff --git a/test-suite/ideal-features/Apply.v b/test-suite/ideal-features/Apply.v index a4bbfba8..ed46eb22 100644 --- a/test-suite/ideal-features/Apply.v +++ b/test-suite/ideal-features/Apply.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/interactive/ParalITP.v b/test-suite/interactive/ParalITP.v new file mode 100644 index 00000000..a96d4a5c --- /dev/null +++ b/test-suite/interactive/ParalITP.v @@ -0,0 +1,47 @@ +(* Some boilerplate *) +Fixpoint fib n := match n with + | O => 1 + | S m => match m with + | O => 1 + | S o => fib o + fib m end end. + +Ltac sleep n := + try (cut (fib n = S (fib n)); reflexivity). + +(* Tune that depending on your PC *) +Let time := 18. + + +(* Beginning of demo *) + +Section Demo. + +Variable i : True. + +Lemma a : True. +Proof using i. + sleep time. + idtac. + sleep time. + (* Error, jump back to fix it, then Qed again *) + exact (i i). +Qed. + +Lemma b : True. +Proof using i. + sleep time. + idtac. + sleep time. + (* Here we use "a" *) + exact a. +Qed. + +Lemma work_here : True /\ True. +Proof using i. +(* Jump directly here, Coq reacts immediately *) +split. + exact b. (* We can use the lemmas above *) +exact a. +Qed. + +End Demo.
\ No newline at end of file diff --git a/test-suite/interactive/ParalITP_smallproofs.v b/test-suite/interactive/ParalITP_smallproofs.v new file mode 100755 index 00000000..0d75d52a --- /dev/null +++ b/test-suite/interactive/ParalITP_smallproofs.v @@ -0,0 +1,3041 @@ +(* This program is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Lesser General Public License *) +(* as published by the Free Software Foundation; either version 2.1 *) +(* of the License, or (at your option) any later version. *) +(* *) +(* This program is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU General Public License for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public *) +(* License along with this program; if not, write to the Free *) +(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *) +(* 02110-1301 USA *) + + +(** This file includes random facts about Integers (and natural numbers) which are not found in the standard library. Some of the lemma here are not used in the QArith developement but are rather useful. +*) + +Require Export ZArith. +Require Export ZArithRing. + +Tactic Notation "ElimCompare" constr(c) constr(d) := elim_compare c d. + +Ltac Flip := + apply Zgt_lt || apply Zlt_gt || apply Zle_ge || apply Zge_le; assumption. + +Ltac Falsum := + try intro; apply False_ind; + repeat + match goal with + | id1:(~ ?X1) |- ?X2 => + (apply id1; assumption || reflexivity) || clear id1 + end. + + +Ltac Step_l a := + match goal with + | |- (?X1 < ?X2)%Z => replace X1 with a; [ idtac | try ring ] + end. + +Ltac Step_r a := + match goal with + | |- (?X1 < ?X2)%Z => replace X2 with a; [ idtac | try ring ] + end. + +Ltac CaseEq formula := + generalize (refl_equal formula); pattern formula at -1 in |- *; + case formula. + + +Lemma pair_1 : forall (A B : Set) (H : A * B), H = pair (fst H) (snd H). +Proof. + intros. + case H. + intros. + simpl in |- *. + reflexivity. +Qed. + +Lemma pair_2 : + forall (A B : Set) (H1 H2 : A * B), + fst H1 = fst H2 -> snd H1 = snd H2 -> H1 = H2. +Proof. + intros A B H1 H2. + case H1. + case H2. + simpl in |- *. + intros. + rewrite H. + rewrite H0. + reflexivity. +Qed. + + +Section projection. + Variable A : Set. + Variable P : A -> Prop. + + Definition projP1 (H : sig P) := let (x, h) := H in x. + Definition projP2 (H : sig P) := + let (x, h) as H return (P (projP1 H)) := H in h. +End projection. + + +(*###########################################################################*) +(* Declaring some realtions on natural numbers for stepl and stepr tactics. *) +(*###########################################################################*) + +Lemma le_stepl: forall x y z, le x y -> x=z -> le z y. +Proof. + intros x y z H_le H_eq; subst z; trivial. +Qed. + +Lemma le_stepr: forall x y z, le x y -> y=z -> le x z. +Proof. + intros x y z H_le H_eq; subst z; trivial. +Qed. + +Lemma lt_stepl: forall x y z, lt x y -> x=z -> lt z y. +Proof. + intros x y z H_lt H_eq; subst z; trivial. +Qed. + +Lemma lt_stepr: forall x y z, lt x y -> y=z -> lt x z. +Proof. + intros x y z H_lt H_eq; subst z; trivial. +Qed. + +Lemma neq_stepl:forall (x y z:nat), x<>y -> x=z -> z<>y. +Proof. + intros x y z H_lt H_eq; subst; assumption. +Qed. + +Lemma neq_stepr:forall (x y z:nat), x<>y -> y=z -> x<>z. +Proof. + intros x y z H_lt H_eq; subst; assumption. +Qed. + + +Declare Left Step le_stepl. +Declare Right Step le_stepr. +Declare Left Step lt_stepl. +Declare Right Step lt_stepr. +Declare Left Step neq_stepl. +Declare Right Step neq_stepr. + +(*###########################################################################*) +(** Some random facts about natural numbers, positive numbers and integers *) +(*###########################################################################*) + + +Lemma not_O_S : forall n : nat, n <> 0 -> {p : nat | n = S p}. +Proof. + intros [| np] Hn; [ exists 0; apply False_ind; apply Hn | exists np ]; + reflexivity. +Qed. + + +Lemma lt_minus_neq : forall m n : nat, m < n -> n - m <> 0. +Proof. + intros. + omega. +Qed. + +Lemma lt_minus_eq_0 : forall m n : nat, m < n -> m - n = 0. +Proof. + intros. + omega. +Qed. + +Lemma le_plus_Sn_1_SSn : forall n : nat, S n + 1 <= S (S n). +Proof. + intros. + omega. +Qed. + +Lemma le_plus_O_l : forall p q : nat, p + q <= 0 -> p = 0. +Proof. + intros; omega. +Qed. + +Lemma le_plus_O_r : forall p q : nat, p + q <= 0 -> q = 0. +Proof. + intros; omega. +Qed. + +Lemma minus_pred : forall m n : nat, 0 < n -> pred m - pred n = m - n. +Proof. + intros. + omega. +Qed. + + +(*###########################################################################*) +(* Declaring some realtions on integers for stepl and stepr tactics. *) +(*###########################################################################*) + +Lemma Zle_stepl: forall x y z, (x<=y)%Z -> x=z -> (z<=y)%Z. +Proof. + intros x y z H_le H_eq; subst z; trivial. +Qed. + +Lemma Zle_stepr: forall x y z, (x<=y)%Z -> y=z -> (x<=z)%Z. +Proof. + intros x y z H_le H_eq; subst z; trivial. +Qed. + +Lemma Zlt_stepl: forall x y z, (x<y)%Z -> x=z -> (z<y)%Z. +Proof. + intros x y z H_lt H_eq; subst z; trivial. +Qed. + +Lemma Zlt_stepr: forall x y z, (x<y)%Z -> y=z -> (x<z)%Z. +Proof. + intros x y z H_lt H_eq; subst z; trivial. +Qed. + +Lemma Zneq_stepl:forall (x y z:Z), (x<>y)%Z -> x=z -> (z<>y)%Z. +Proof. + intros x y z H_lt H_eq; subst; assumption. +Qed. + +Lemma Zneq_stepr:forall (x y z:Z), (x<>y)%Z -> y=z -> (x<>z)%Z. +Proof. + intros x y z H_lt H_eq; subst; assumption. +Qed. + +Declare Left Step Zle_stepl. +Declare Right Step Zle_stepr. +Declare Left Step Zlt_stepl. +Declare Right Step Zlt_stepr. +Declare Left Step Zneq_stepl. +Declare Right Step Zneq_stepr. + + +(*###########################################################################*) +(** Informative case analysis *) +(*###########################################################################*) + +Lemma Zlt_cotrans : + forall x y : Z, (x < y)%Z -> forall z : Z, {(x < z)%Z} + {(z < y)%Z}. +Proof. + intros. + case (Z_lt_ge_dec x z). + intro. + left. + assumption. + intro. + right. + apply Zle_lt_trans with (m := x). + apply Zge_le. + assumption. + assumption. +Qed. + +Lemma Zlt_cotrans_pos : + forall x y : Z, (0 < x + y)%Z -> {(0 < x)%Z} + {(0 < y)%Z}. +Proof. + intros. + case (Zlt_cotrans 0 (x + y) H x). + intro. + left. + assumption. + intro. + right. + apply Zplus_lt_reg_l with (p := x). + rewrite Zplus_0_r. + assumption. +Qed. + + +Lemma Zlt_cotrans_neg : + forall x y : Z, (x + y < 0)%Z -> {(x < 0)%Z} + {(y < 0)%Z}. +Proof. + intros x y H; case (Zlt_cotrans (x + y) 0 H x); intro Hxy; + [ right; apply Zplus_lt_reg_l with (p := x); rewrite Zplus_0_r | left ]; + assumption. +Qed. + + + +Lemma not_Zeq_inf : forall x y : Z, x <> y -> {(x < y)%Z} + {(y < x)%Z}. +Proof. + intros. + case Z_lt_ge_dec with x y. + intro. + left. + assumption. + intro H0. + generalize (Zge_le _ _ H0). + intro. + case (Z_le_lt_eq_dec _ _ H1). + intro. + right. + assumption. + intro. + apply False_rec. + apply H. + symmetry in |- *. + assumption. +Qed. + +Lemma Z_dec : forall x y : Z, {(x < y)%Z} + {(x > y)%Z} + {x = y}. +Proof. + intros. + case (Z_lt_ge_dec x y). + intro H. + left. + left. + assumption. + intro H. + generalize (Zge_le _ _ H). + intro H0. + case (Z_le_lt_eq_dec y x H0). + intro H1. + left. + right. + apply Zlt_gt. + assumption. + intro. + right. + symmetry in |- *. + assumption. +Qed. + + +Lemma Z_dec' : forall x y : Z, {(x < y)%Z} + {(y < x)%Z} + {x = y}. +Proof. + intros x y. + case (Z_eq_dec x y); intro H; + [ right; assumption | left; apply (not_Zeq_inf _ _ H) ]. +Qed. + +Lemma Z_lt_le_dec : forall x y : Z, {(x < y)%Z} + {(y <= x)%Z}. +Proof. + intros. + case (Z_lt_ge_dec x y). + intro. + left. + assumption. + intro. + right. + apply Zge_le. + assumption. +Qed. + +Lemma Z_le_lt_dec : forall x y : Z, {(x <= y)%Z} + {(y < x)%Z}. +Proof. + intros; case (Z_lt_le_dec y x); [ right | left ]; assumption. +Qed. + +Lemma Z_lt_lt_S_eq_dec : + forall x y : Z, (x < y)%Z -> {(x + 1 < y)%Z} + {(x + 1)%Z = y}. +Proof. + intros. + generalize (Zlt_le_succ _ _ H). + unfold Zsucc in |- *. + apply Z_le_lt_eq_dec. +Qed. + +Lemma quadro_leq_inf : + forall a b c d : Z, + {(c <= a)%Z /\ (d <= b)%Z} + {~ ((c <= a)%Z /\ (d <= b)%Z)}. +Proof. + intros. + case (Z_lt_le_dec a c). + intro z. + right. + intro. + elim H. + intros. + generalize z. + apply Zle_not_lt. + assumption. + intro. + case (Z_lt_le_dec b d). + intro z0. + right. + intro. + elim H. + intros. + generalize z0. + apply Zle_not_lt. + assumption. + intro. + left. + split. + assumption. + assumption. +Qed. + +(*###########################################################################*) +(** General auxiliary lemmata *) +(*###########################################################################*) + +Lemma Zminus_eq : forall x y : Z, (x - y)%Z = 0%Z -> x = y. +Proof. + intros. + apply Zplus_reg_l with (- y)%Z. + rewrite Zplus_opp_l. + unfold Zminus in H. + rewrite Zplus_comm. + assumption. +Qed. + +Lemma Zlt_minus : forall a b : Z, (b < a)%Z -> (0 < a - b)%Z. +Proof. + intros a b. + intros. + apply Zplus_lt_reg_l with b. + unfold Zminus in |- *. + rewrite (Zplus_comm a). + rewrite (Zplus_assoc b (- b)). + rewrite Zplus_opp_r. + simpl in |- *. + rewrite <- Zplus_0_r_reverse. + assumption. +Qed. + + +Lemma Zle_minus : forall a b : Z, (b <= a)%Z -> (0 <= a - b)%Z. +Proof. + intros a b. + intros. + apply Zplus_le_reg_l with b. + unfold Zminus in |- *. + rewrite (Zplus_comm a). + rewrite (Zplus_assoc b (- b)). + rewrite Zplus_opp_r. + simpl in |- *. + rewrite <- Zplus_0_r_reverse. + assumption. +Qed. + +Lemma Zlt_plus_plus : + forall m n p q : Z, (m < n)%Z -> (p < q)%Z -> (m + p < n + q)%Z. +Proof. + intros. + apply Zlt_trans with (m := (n + p)%Z). + rewrite Zplus_comm. + rewrite Zplus_comm with (n := n). + apply Zplus_lt_compat_l. + assumption. + apply Zplus_lt_compat_l. + assumption. +Qed. + +Lemma Zgt_plus_plus : + forall m n p q : Z, (m > n)%Z -> (p > q)%Z -> (m + p > n + q)%Z. + intros. + apply Zgt_trans with (m := (n + p)%Z). + rewrite Zplus_comm. + rewrite Zplus_comm with (n := n). + apply Zplus_gt_compat_l. + assumption. + apply Zplus_gt_compat_l. + assumption. +Qed. + +Lemma Zle_lt_plus_plus : + forall m n p q : Z, (m <= n)%Z -> (p < q)%Z -> (m + p < n + q)%Z. +Proof. + intros. + case (Zle_lt_or_eq m n). + assumption. + intro. + apply Zlt_plus_plus. + assumption. + assumption. + intro. + rewrite H1. + apply Zplus_lt_compat_l. + assumption. +Qed. + +Lemma Zge_gt_plus_plus : + forall m n p q : Z, (m >= n)%Z -> (p > q)%Z -> (m + p > n + q)%Z. +Proof. + intros. + case (Zle_lt_or_eq n m). + apply Zge_le. + assumption. + intro. + apply Zgt_plus_plus. + apply Zlt_gt. + assumption. + assumption. + intro. + rewrite H1. + apply Zplus_gt_compat_l. + assumption. +Qed. + +Lemma Zgt_ge_plus_plus : + forall m n p q : Z, (m > n)%Z -> (p >= q)%Z -> (m + p > n + q)%Z. +Proof. + intros. + rewrite Zplus_comm. + replace (n + q)%Z with (q + n)%Z. + apply Zge_gt_plus_plus. + assumption. + assumption. + apply Zplus_comm. +Qed. + +Lemma Zlt_resp_pos : forall x y : Z, (0 < x)%Z -> (0 < y)%Z -> (0 < x + y)%Z. +Proof. + intros. + rewrite <- Zplus_0_r with 0%Z. + apply Zlt_plus_plus; assumption. +Qed. + + +Lemma Zle_resp_neg : + forall x y : Z, (x <= 0)%Z -> (y <= 0)%Z -> (x + y <= 0)%Z. +Proof. + intros. + rewrite <- Zplus_0_r with 0%Z. + apply Zplus_le_compat; assumption. +Qed. + + +Lemma Zlt_pos_opp : forall x : Z, (0 < x)%Z -> (- x < 0)%Z. +Proof. + intros. + apply Zplus_lt_reg_l with x. + rewrite Zplus_opp_r. + rewrite Zplus_0_r. + assumption. +Qed. + +Lemma Zlt_neg_opp : forall x : Z, (x < 0)%Z -> (0 < - x)%Z. +Proof. + intros. + apply Zplus_lt_reg_l with x. + rewrite Zplus_opp_r. + rewrite Zplus_0_r. + assumption. +Qed. + + +Lemma Zle_neg_opp : forall x : Z, (x <= 0)%Z -> (0 <= - x)%Z. +Proof. + intros. + apply Zplus_le_reg_l with x. + rewrite Zplus_opp_r. + rewrite Zplus_0_r. + assumption. +Qed. + +Lemma Zle_pos_opp : forall x : Z, (0 <= x)%Z -> (- x <= 0)%Z. +Proof. + intros. + apply Zplus_le_reg_l with x. + rewrite Zplus_opp_r. + rewrite Zplus_0_r. + assumption. +Qed. + + +Lemma Zge_opp : forall x y : Z, (x <= y)%Z -> (- x >= - y)%Z. +Proof. + intros. + apply Zle_ge. + apply Zplus_le_reg_l with (p := (x + y)%Z). + ring_simplify (x + y + - y)%Z (x + y + - x)%Z. + assumption. +Qed. + + + +(* Omega can't solve this *) +Lemma Zmult_pos_pos : forall x y : Z, (0 < x)%Z -> (0 < y)%Z -> (0 < x * y)%Z. +Proof. + intros [| px| px] [| py| py] Hx Hy; trivial || constructor. +Qed. + +Lemma Zmult_neg_neg : forall x y : Z, (x < 0)%Z -> (y < 0)%Z -> (0 < x * y)%Z. +Proof. + intros [| px| px] [| py| py] Hx Hy; trivial || constructor. +Qed. + +Lemma Zmult_neg_pos : forall x y : Z, (x < 0)%Z -> (0 < y)%Z -> (x * y < 0)%Z. +Proof. + intros [| px| px] [| py| py] Hx Hy; trivial || constructor. +Qed. + +Lemma Zmult_pos_neg : forall x y : Z, (0 < x)%Z -> (y < 0)%Z -> (x * y < 0)%Z. +Proof. + intros [| px| px] [| py| py] Hx Hy; trivial || constructor. +Qed. + + + +Hint Resolve Zmult_pos_pos Zmult_neg_neg Zmult_neg_pos Zmult_pos_neg: zarith. + + +Lemma Zle_reg_mult_l : + forall x y a : Z, (0 < a)%Z -> (x <= y)%Z -> (a * x <= a * y)%Z. +Proof. + intros. + apply Zplus_le_reg_l with (p := (- a * x)%Z). + ring_simplify (- a * x + a * x)%Z. + replace (- a * x + a * y)%Z with ((y - x) * a)%Z. + apply Zmult_gt_0_le_0_compat. + apply Zlt_gt. + assumption. + unfold Zminus in |- *. + apply Zle_left. + assumption. + ring. +Qed. + +Lemma Zsimpl_plus_l_dep : + forall x y m n : Z, (x + m)%Z = (y + n)%Z -> x = y -> m = n. +Proof. + intros. + apply Zplus_reg_l with x. + rewrite <- H0 in H. + assumption. +Qed. + + +Lemma Zsimpl_plus_r_dep : + forall x y m n : Z, (m + x)%Z = (n + y)%Z -> x = y -> m = n. +Proof. + intros. + apply Zplus_reg_l with x. + rewrite Zplus_comm. + rewrite Zplus_comm with x n. + rewrite <- H0 in H. + assumption. +Qed. + +Lemma Zmult_simpl : + forall n m p q : Z, n = m -> p = q -> (n * p)%Z = (m * q)%Z. +Proof. + intros. + rewrite H. + rewrite H0. + reflexivity. +Qed. + +Lemma Zsimpl_mult_l : + forall n m p : Z, n <> 0%Z -> (n * m)%Z = (n * p)%Z -> m = p. +Proof. + intros. + apply Zplus_reg_l with (n := (- p)%Z). + replace (- p + p)%Z with 0%Z. + apply Zmult_integral_l with (n := n). + assumption. + replace ((- p + m) * n)%Z with (n * m + - (n * p))%Z. + apply Zegal_left. + assumption. + ring. + ring. +Qed. + +Lemma Zlt_reg_mult_l : + forall x y z : Z, (x > 0)%Z -> (y < z)%Z -> (x * y < x * z)%Z. (*QA*) +Proof. + intros. + case (Zcompare_Gt_spec x 0). + unfold Zgt in H. + assumption. + intros. + cut (x = Zpos x0). + intro. + rewrite H2. + unfold Zlt in H0. + unfold Zlt in |- *. + cut ((Zpos x0 * y ?= Zpos x0 * z)%Z = (y ?= z)%Z). + intro. + exact (trans_eq H3 H0). + apply Zcompare_mult_compat. + cut (x = (x + - (0))%Z). + intro. + exact (trans_eq H2 H1). + simpl in |- *. + apply (sym_eq (A:=Z)). + exact (Zplus_0_r x). +Qed. + + +Lemma Zlt_opp : forall x y : Z, (x < y)%Z -> (- x > - y)%Z. (*QA*) +Proof. + intros. + red in |- *. + apply sym_eq. + cut (Datatypes.Gt = (y ?= x)%Z). + intro. + cut ((y ?= x)%Z = (- x ?= - y)%Z). + intro. + exact (trans_eq H0 H1). + exact (Zcompare_opp y x). + apply sym_eq. + exact (Zlt_gt x y H). +Qed. + + +Lemma Zlt_conv_mult_l : + forall x y z : Z, (x < 0)%Z -> (y < z)%Z -> (x * y > x * z)%Z. (*QA*) +Proof. + intros. + cut (- x > 0)%Z. + intro. + cut (- x * y < - x * z)%Z. + intro. + cut (- (- x * y) > - (- x * z))%Z. + intro. + cut (- - (x * y) > - - (x * z))%Z. + intro. + cut ((- - (x * y))%Z = (x * y)%Z). + intro. + rewrite H5 in H4. + cut ((- - (x * z))%Z = (x * z)%Z). + intro. + rewrite H6 in H4. + assumption. + exact (Zopp_involutive (x * z)). + exact (Zopp_involutive (x * y)). + cut ((- (- x * y))%Z = (- - (x * y))%Z). + intro. + rewrite H4 in H3. + cut ((- (- x * z))%Z = (- - (x * z))%Z). + intro. + rewrite H5 in H3. + assumption. + cut ((- x * z)%Z = (- (x * z))%Z). + intro. + exact (f_equal Zopp H5). + exact (Zopp_mult_distr_l_reverse x z). + cut ((- x * y)%Z = (- (x * y))%Z). + intro. + exact (f_equal Zopp H4). + exact (Zopp_mult_distr_l_reverse x y). + exact (Zlt_opp (- x * y) (- x * z) H2). + exact (Zlt_reg_mult_l (- x) y z H1 H0). + exact (Zlt_opp x 0 H). +Qed. + +Lemma Zgt_not_eq : forall x y : Z, (x > y)%Z -> x <> y. (*QA*) +Proof. + intros. + cut (y < x)%Z. + intro. + cut (y <> x). + intro. + red in |- *. + intros. + cut (y = x). + intros. + apply H1. + assumption. + exact (sym_eq H2). + exact (Zorder.Zlt_not_eq y x H0). + exact (Zgt_lt x y H). +Qed. + +Lemma Zmult_resp_nonzero : + forall x y : Z, x <> 0%Z -> y <> 0%Z -> (x * y)%Z <> 0%Z. +Proof. + intros x y Hx Hy Hxy. + apply Hx. + apply Zmult_integral_l with y; assumption. +Qed. + + +Lemma Zopp_app : forall y : Z, y <> 0%Z -> (- y)%Z <> 0%Z. +Proof. + intros. + intro. + apply H. + apply Zplus_reg_l with (- y)%Z. + rewrite Zplus_opp_l. + rewrite H0. + simpl in |- *. + reflexivity. +Qed. + + +Lemma Zle_neq_Zlt : forall a b : Z, (a <= b)%Z -> b <> a -> (a < b)%Z. +Proof. + intros a b H H0. + case (Z_le_lt_eq_dec _ _ H); trivial. + intro; apply False_ind; apply H0; symmetry in |- *; assumption. +Qed. + +Lemma not_Zle_lt : forall x y : Z, ~ (y <= x)%Z -> (x < y)%Z. +Proof. + intros; apply Zgt_lt; apply Znot_le_gt; assumption. +Qed. + +Lemma not_Zlt : forall x y : Z, ~ (y < x)%Z -> (x <= y)%Z. +Proof. + intros x y H1 H2; apply H1; apply Zgt_lt; assumption. +Qed. + + +Lemma Zmult_absorb : + forall x y z : Z, x <> 0%Z -> (x * y)%Z = (x * z)%Z -> y = z. (*QA*) +Proof. + intros. + case (dec_eq y z). + intro. + assumption. + intro. + case (not_Zeq y z). + assumption. + intro. + case (not_Zeq x 0). + assumption. + intro. + apply False_ind. + cut (x * y > x * z)%Z. + intro. + cut ((x * y)%Z <> (x * z)%Z). + intro. + apply H5. + assumption. + exact (Zgt_not_eq (x * y) (x * z) H4). + exact (Zlt_conv_mult_l x y z H3 H2). + intro. + apply False_ind. + cut (x * y < x * z)%Z. + intro. + cut ((x * y)%Z <> (x * z)%Z). + intro. + apply H5. + assumption. + exact (Zorder.Zlt_not_eq (x * y) (x * z) H4). + cut (x > 0)%Z. + intro. + exact (Zlt_reg_mult_l x y z H4 H2). + exact (Zlt_gt 0 x H3). + intro. + apply False_ind. + cut (x * z < x * y)%Z. + intro. + cut ((x * z)%Z <> (x * y)%Z). + intro. + apply H4. + apply (sym_eq (A:=Z)). + assumption. + exact (Zorder.Zlt_not_eq (x * z) (x * y) H3). + apply False_ind. + case (not_Zeq x 0). + assumption. + intro. + cut (x * z > x * y)%Z. + intro. + cut ((x * z)%Z <> (x * y)%Z). + intro. + apply H5. + apply (sym_eq (A:=Z)). + assumption. + exact (Zgt_not_eq (x * z) (x * y) H4). + exact (Zlt_conv_mult_l x z y H3 H2). + intro. + cut (x * z < x * y)%Z. + intro. + cut ((x * z)%Z <> (x * y)%Z). + intro. + apply H5. + apply (sym_eq (A:=Z)). + assumption. + exact (Zorder.Zlt_not_eq (x * z) (x * y) H4). + cut (x > 0)%Z. + intro. + exact (Zlt_reg_mult_l x z y H4 H2). + exact (Zlt_gt 0 x H3). +Qed. + +Lemma Zlt_mult_mult : + forall a b c d : Z, + (0 < a)%Z -> (0 < d)%Z -> (a < b)%Z -> (c < d)%Z -> (a * c < b * d)%Z. +Proof. + intros. + apply Zlt_trans with (a * d)%Z. + apply Zlt_reg_mult_l. + Flip. + assumption. + rewrite Zmult_comm. + rewrite Zmult_comm with b d. + apply Zlt_reg_mult_l. + Flip. + assumption. +Qed. + +Lemma Zgt_mult_conv_absorb_l : + forall a x y : Z, (a < 0)%Z -> (a * x > a * y)%Z -> (x < y)%Z. (*QC*) +Proof. + intros. + case (dec_eq x y). + intro. + apply False_ind. + rewrite H1 in H0. + cut ((a * y)%Z = (a * y)%Z). + change ((a * y)%Z <> (a * y)%Z) in |- *. + apply Zgt_not_eq. + assumption. + trivial. + + intro. + case (not_Zeq x y H1). + trivial. + + intro. + apply False_ind. + cut (a * y > a * x)%Z. + apply Zgt_asym with (m := (a * y)%Z) (n := (a * x)%Z). + assumption. + apply Zlt_conv_mult_l. + assumption. + assumption. +Qed. + +Lemma Zgt_mult_reg_absorb_l : + forall a x y : Z, (a > 0)%Z -> (a * x > a * y)%Z -> (x > y)%Z. (*QC*) +Proof. + intros. + cut (- - a > - - (0))%Z. + intro. + cut (- a < - (0))%Z. + simpl in |- *. + intro. + replace x with (- - x)%Z. + replace y with (- - y)%Z. + apply Zlt_opp. + apply Zgt_mult_conv_absorb_l with (a := (- a)%Z) (x := (- x)%Z). + assumption. + rewrite Zmult_opp_opp. + rewrite Zmult_opp_opp. + assumption. + apply Zopp_involutive. + apply Zopp_involutive. + apply Zgt_lt. + apply Zlt_opp. + apply Zgt_lt. + assumption. + simpl in |- *. + rewrite Zopp_involutive. + assumption. +Qed. + +Lemma Zopp_Zlt : forall x y : Z, (y < x)%Z -> (- x < - y)%Z. +Proof. + intros x y Hyx. + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + constructor. + replace (-1 * - y)%Z with y. + replace (-1 * - x)%Z with x. + Flip. + ring. + ring. +Qed. + + +Lemma Zmin_cancel_Zlt : forall x y : Z, (- x < - y)%Z -> (y < x)%Z. +Proof. + intros. + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + constructor. + replace (-1 * y)%Z with (- y)%Z. + replace (-1 * x)%Z with (- x)%Z. + apply Zlt_gt. + assumption. + ring. + ring. +Qed. + + +Lemma Zmult_cancel_Zle : + forall a x y : Z, (a < 0)%Z -> (a * x <= a * y)%Z -> (y <= x)%Z. +Proof. + intros. + case (Z_le_gt_dec y x). + trivial. + intro. + apply False_ind. + apply (Zlt_irrefl (a * x)). + apply Zle_lt_trans with (m := (a * y)%Z). + assumption. + apply Zgt_lt. + apply Zlt_conv_mult_l. + assumption. + apply Zgt_lt. + assumption. +Qed. + +Lemma Zlt_mult_cancel_l : + forall x y z : Z, (0 < x)%Z -> (x * y < x * z)%Z -> (y < z)%Z. +Proof. + intros. + apply Zgt_lt. + apply Zgt_mult_reg_absorb_l with x. + apply Zlt_gt. + assumption. + apply Zlt_gt. + assumption. +Qed. + + +Lemma Zmin_cancel_Zle : forall x y : Z, (- x <= - y)%Z -> (y <= x)%Z. +Proof. + intros. + apply Zmult_cancel_Zle with (a := (-1)%Z). + constructor. + replace (-1 * y)%Z with (- y)%Z. + replace (-1 * x)%Z with (- x)%Z. + assumption. + ring. + ring. +Qed. + + + +Lemma Zmult_resp_Zle : + forall a x y : Z, (0 < a)%Z -> (a * y <= a * x)%Z -> (y <= x)%Z. +Proof. + intros. + case (Z_le_gt_dec y x). + trivial. + intro. + apply False_ind. + apply (Zlt_irrefl (a * y)). + apply Zle_lt_trans with (m := (a * x)%Z). + assumption. + apply Zlt_reg_mult_l. + apply Zlt_gt. + assumption. + apply Zgt_lt. + assumption. +Qed. + +Lemma Zopp_Zle : forall x y : Z, (y <= x)%Z -> (- x <= - y)%Z. +Proof. + intros. + apply Zmult_cancel_Zle with (a := (-1)%Z). + constructor. + replace (-1 * - y)%Z with y. + replace (-1 * - x)%Z with x. + assumption. + clear y H; ring. + clear x H; ring. +Qed. + + +Lemma Zle_lt_eq_S : forall x y : Z, (x <= y)%Z -> (y < x + 1)%Z -> y = x. +Proof. + intros. + case (Z_le_lt_eq_dec x y H). + intro H1. + apply False_ind. + generalize (Zlt_le_succ x y H1). + intro. + apply (Zlt_not_le y (x + 1) H0). + replace (x + 1)%Z with (Zsucc x). + assumption. + reflexivity. + intro H1. + symmetry in |- *. + assumption. +Qed. + +Lemma Zlt_le_eq_S : + forall x y : Z, (x < y)%Z -> (y <= x + 1)%Z -> y = (x + 1)%Z. +Proof. + intros. + case (Z_le_lt_eq_dec y (x + 1) H0). + intro H1. + apply False_ind. + generalize (Zlt_le_succ x y H). + intro. + apply (Zlt_not_le y (x + 1) H1). + replace (x + 1)%Z with (Zsucc x). + assumption. + reflexivity. + trivial. +Qed. + + +Lemma double_not_equal_zero : + forall c d : Z, ~ (c = 0%Z /\ d = 0%Z) -> c <> d \/ c <> 0%Z. +Proof. + intros. + case (Z_zerop c). + intro. + rewrite e. + left. + apply sym_not_eq. + intro. + apply H; repeat split; assumption. + intro; right; assumption. +Qed. + +Lemma triple_not_equal_zero : + forall a b c : Z, + ~ (a = 0%Z /\ b = 0%Z /\ c = 0%Z) -> a <> 0%Z \/ b <> 0%Z \/ c <> 0%Z. +Proof. + intros a b c H; case (Z_zerop a); intro Ha; + [ case (Z_zerop b); intro Hb; + [ case (Z_zerop c); intro Hc; + [ apply False_ind; apply H; repeat split | right; right ] + | right; left ] + | left ]; assumption. +Qed. + +Lemma mediant_1 : + forall m n m' n' : Z, (m' * n < m * n')%Z -> ((m + m') * n < m * (n + n'))%Z. +Proof. + intros. + rewrite Zmult_plus_distr_r. + rewrite Zmult_plus_distr_l. + apply Zplus_lt_compat_l. + assumption. +Qed. + +Lemma mediant_2 : + forall m n m' n' : Z, + (m' * n < m * n')%Z -> (m' * (n + n') < (m + m') * n')%Z. +Proof. + intros. + rewrite Zmult_plus_distr_l. + rewrite Zmult_plus_distr_r. + apply Zplus_lt_compat_r. + assumption. +Qed. + + +Lemma mediant_3 : + forall a b m n m' n' : Z, + (0 <= a * m + b * n)%Z -> + (0 <= a * m' + b * n')%Z -> (0 <= a * (m + m') + b * (n + n'))%Z. +Proof. + intros. + replace (a * (m + m') + b * (n + n'))%Z with + (a * m + b * n + (a * m' + b * n'))%Z. + apply Zplus_le_0_compat. + assumption. + assumption. + ring. +Qed. + +Lemma fraction_lt_trans : + forall a b c d e f : Z, + (0 < b)%Z -> + (0 < d)%Z -> + (0 < f)%Z -> (a * d < c * b)%Z -> (c * f < e * d)%Z -> (a * f < e * b)%Z. +Proof. + intros. + apply Zgt_lt. + apply Zgt_mult_reg_absorb_l with d. + Flip. + apply Zgt_trans with (c * b * f)%Z. + replace (d * (e * b))%Z with (b * (e * d))%Z. + replace (c * b * f)%Z with (b * (c * f))%Z. + apply Zlt_gt. + apply Zlt_reg_mult_l. + Flip. + assumption. + ring. + ring. + replace (c * b * f)%Z with (f * (c * b))%Z. + replace (d * (a * f))%Z with (f * (a * d))%Z. + apply Zlt_gt. + apply Zlt_reg_mult_l. + Flip. + assumption. + ring. + ring. +Qed. + + +Lemma square_pos : forall a : Z, a <> 0%Z -> (0 < a * a)%Z. +Proof. + intros [| p| p]; intros; [ Falsum | constructor | constructor ]. +Qed. + +Hint Resolve square_pos: zarith. + +(*###########################################################################*) +(** Properties of positive numbers, mapping between Z and nat *) +(*###########################################################################*) + + +Definition Z2positive (z : Z) := + match z with + | Zpos p => p + | Zneg p => p + | Z0 => 1%positive + end. + + +Lemma ZL9 : forall p : positive, Z_of_nat (nat_of_P p) = Zpos p. (*QF*) +Proof. + intro. + cut (exists h : nat, nat_of_P p = S h). + intro. + case H. + intros. + unfold Z_of_nat in |- *. + rewrite H0. + + apply f_equal with (A := positive) (B := Z) (f := Zpos). + cut (P_of_succ_nat (nat_of_P p) = P_of_succ_nat (S x)). + intro. + rewrite P_of_succ_nat_o_nat_of_P_eq_succ in H1. + cut (Ppred (Psucc p) = Ppred (P_of_succ_nat (S x))). + intro. + rewrite Ppred_succ in H2. + simpl in H2. + rewrite Ppred_succ in H2. + apply sym_eq. + assumption. + apply f_equal with (A := positive) (B := positive) (f := Ppred). + assumption. + apply f_equal with (f := P_of_succ_nat). + assumption. + apply ZL4. +Qed. + +Coercion Z_of_nat : nat >-> Z. + +Lemma ZERO_lt_POS : forall p : positive, (0 < Zpos p)%Z. +Proof. + intros. + constructor. +Qed. + + +Lemma POS_neq_ZERO : forall p : positive, Zpos p <> 0%Z. +Proof. + intros. + apply sym_not_eq. + apply Zorder.Zlt_not_eq. + apply ZERO_lt_POS. +Qed. + +Lemma NEG_neq_ZERO : forall p : positive, Zneg p <> 0%Z. +Proof. + intros. + apply Zorder.Zlt_not_eq. + unfold Zlt in |- *. + constructor. +Qed. + + +Lemma POS_resp_eq : forall p0 p1 : positive, Zpos p0 = Zpos p1 -> p0 = p1. +Proof. + intros. + injection H. + trivial. +Qed. + +Lemma nat_nat_pos : forall m n : nat, ((m + 1) * (n + 1) > 0)%Z. (*QF*) +Proof. + intros. + apply Zlt_gt. + cut (Z_of_nat m + 1 > 0)%Z. + intro. + cut (0 < Z_of_nat n + 1)%Z. + intro. + cut ((Z_of_nat m + 1) * 0 < (Z_of_nat m + 1) * (Z_of_nat n + 1))%Z. + rewrite Zmult_0_r. + intro. + assumption. + + apply Zlt_reg_mult_l. + assumption. + assumption. + change (0 < Zsucc (Z_of_nat n))%Z in |- *. + apply Zle_lt_succ. + change (Z_of_nat 0 <= Z_of_nat n)%Z in |- *. + apply Znat.inj_le. + apply le_O_n. + apply Zlt_gt. + change (0 < Zsucc (Z_of_nat m))%Z in |- *. + apply Zle_lt_succ. + change (Z_of_nat 0 <= Z_of_nat m)%Z in |- *. + apply Znat.inj_le. + apply le_O_n. +Qed. + + +Theorem S_predn : forall m : nat, m <> 0 -> S (pred m) = m. (*QF*) +Proof. + intros. + case (O_or_S m). + intro. + case s. + intros. + rewrite <- e. + rewrite <- pred_Sn with (n := x). + trivial. + intro. + apply False_ind. + apply H. + apply sym_eq. + assumption. +Qed. + +Lemma absolu_1 : forall x : Z, Zabs_nat x = 0 -> x = 0%Z. (*QF*) +Proof. + intros. + case (dec_eq x 0). + intro. + assumption. + intro. + apply False_ind. + cut ((x < 0)%Z \/ (x > 0)%Z). + intro. + ElimCompare x 0%Z. + intro. + cut (x = 0%Z). + assumption. + cut ((x ?= 0)%Z = Datatypes.Eq -> x = 0%Z). + intro. + apply H3. + assumption. + apply proj1 with (B := x = 0%Z -> (x ?= 0)%Z = Datatypes.Eq). + change ((x ?= 0)%Z = Datatypes.Eq <-> x = 0%Z) in |- *. + apply Zcompare_Eq_iff_eq. + + (***) + intro. + cut (exists h : nat, Zabs_nat x = S h). + intro. + case H3. + rewrite H. + exact O_S. + + change (x < 0)%Z in H2. + cut (0 > x)%Z. + intro. + cut (exists p : positive, (0 + - x)%Z = Zpos p). + simpl in |- *. + intro. + case H4. + intros. + cut (exists q : positive, x = Zneg q). + intro. + case H6. + intros. + rewrite H7. + unfold Zabs_nat in |- *. + generalize x1. + exact ZL4. + cut (x = (- Zpos x0)%Z). + simpl in |- *. + intro. + exists x0. + assumption. + cut ((- - x)%Z = x). + intro. + rewrite <- H6. + exact (f_equal Zopp H5). + apply Zopp_involutive. + apply Zcompare_Gt_spec. + assumption. + apply Zlt_gt. + assumption. + + (***) + intro. + cut (exists h : nat, Zabs_nat x = S h). + intro. + case H3. + rewrite H. + exact O_S. + + cut (exists p : positive, (x + - (0))%Z = Zpos p). + simpl in |- *. + rewrite Zplus_0_r. + intro. + case H3. + intros. + rewrite H4. + unfold Zabs_nat in |- *. + generalize x0. + exact ZL4. + apply Zcompare_Gt_spec. + assumption. + + (***) + cut ((x < 0)%Z \/ (0 < x)%Z). + intro. + apply + or_ind with (A := (x < 0)%Z) (B := (0 < x)%Z) (P := (x < 0)%Z \/ (x > 0)%Z). + intro. + left. + assumption. + intro. + right. + apply Zlt_gt. + assumption. + assumption. + apply not_Zeq. + assumption. +Qed. + +Lemma absolu_2 : forall x : Z, x <> 0%Z -> Zabs_nat x <> 0. (*QF*) +Proof. + intros. + intro. + apply H. + apply absolu_1. + assumption. +Qed. + + + + +Lemma absolu_inject_nat : forall n : nat, Zabs_nat (Z_of_nat n) = n. +Proof. + simple induction n; simpl in |- *. + reflexivity. + intros. + apply nat_of_P_o_P_of_succ_nat_eq_succ. +Qed. + + +Lemma eq_inj : forall m n : nat, m = n :>Z -> m = n. +Proof. + intros. + generalize (f_equal Zabs_nat H). + intro. + rewrite (absolu_inject_nat m) in H0. + rewrite (absolu_inject_nat n) in H0. + assumption. +Qed. + +Lemma lt_inj : forall m n : nat, (m < n)%Z -> m < n. +Proof. + intros. + omega. +Qed. + +Lemma le_inj : forall m n : nat, (m <= n)%Z -> m <= n. +Proof. + intros. + omega. +Qed. + + +Lemma inject_nat_S_inf : forall x : Z, (0 < x)%Z -> {n : nat | x = S n}. +Proof. + intros [| p| p] Hp; try discriminate Hp. + exists (pred (nat_of_P p)). + rewrite S_predn. + symmetry in |- *; apply ZL9. + clear Hp; + apply sym_not_equal; apply lt_O_neq; apply lt_O_nat_of_P. +Qed. + + + +Lemma le_absolu : + forall x y : Z, + (0 <= x)%Z -> (0 <= y)%Z -> (x <= y)%Z -> Zabs_nat x <= Zabs_nat y. +Proof. + intros [| x| x] [| y| y] Hx Hy Hxy; + apply le_O_n || + (try + match goal with + | id1:(0 <= Zneg _)%Z |- _ => + apply False_ind; apply id1; constructor + | id1:(Zpos _ <= 0)%Z |- _ => + apply False_ind; apply id1; constructor + | id1:(Zpos _ <= Zneg _)%Z |- _ => + apply False_ind; apply id1; constructor + end). + simpl in |- *. + apply le_inj. + do 2 rewrite ZL9. + assumption. +Qed. + +Lemma lt_absolu : + forall x y : Z, + (0 <= x)%Z -> (0 <= y)%Z -> (x < y)%Z -> Zabs_nat x < Zabs_nat y. +Proof. + intros [| x| x] [| y| y] Hx Hy Hxy; inversion Hxy; + try + match goal with + | id1:(0 <= Zneg _)%Z |- _ => + apply False_ind; apply id1; constructor + | id1:(Zpos _ <= 0)%Z |- _ => + apply False_ind; apply id1; constructor + | id1:(Zpos _ <= Zneg _)%Z |- _ => + apply False_ind; apply id1; constructor + end; simpl in |- *; apply lt_inj; repeat rewrite ZL9; + assumption. +Qed. + +Lemma absolu_plus : + forall x y : Z, + (0 <= x)%Z -> (0 <= y)%Z -> Zabs_nat (x + y) = Zabs_nat x + Zabs_nat y. +Proof. + intros [| x| x] [| y| y] Hx Hy; trivial; + try + match goal with + | id1:(0 <= Zneg _)%Z |- _ => + apply False_ind; apply id1; constructor + | id1:(Zpos _ <= 0)%Z |- _ => + apply False_ind; apply id1; constructor + | id1:(Zpos _ <= Zneg _)%Z |- _ => + apply False_ind; apply id1; constructor + end. + rewrite <- BinInt.Zpos_plus_distr. + unfold Zabs_nat in |- *. + apply nat_of_P_plus_morphism. +Qed. + +Lemma pred_absolu : + forall x : Z, (0 < x)%Z -> pred (Zabs_nat x) = Zabs_nat (x - 1). +Proof. + intros x Hx. + generalize (Z_lt_lt_S_eq_dec 0 x Hx); simpl in |- *; intros [H1| H1]; + [ replace (Zabs_nat x) with (Zabs_nat (x - 1 + 1)); + [ idtac | apply f_equal with Z; auto with zarith ]; + rewrite absolu_plus; + [ unfold Zabs_nat at 2, nat_of_P, Piter_op in |- *; omega + | auto with zarith + | intro; discriminate ] + | rewrite <- H1; reflexivity ]. +Qed. + +Definition pred_nat : forall (x : Z) (Hx : (0 < x)%Z), nat. +intros [| px| px] Hx; try abstract (discriminate Hx). +exact (pred (nat_of_P px)). +Defined. + +Lemma pred_nat_equal : + forall (x : Z) (Hx1 Hx2 : (0 < x)%Z), pred_nat x Hx1 = pred_nat x Hx2. +Proof. + intros [| px| px] Hx1 Hx2; try (discriminate Hx1); trivial. +Qed. + +Let pred_nat_unfolded_subproof px : + Pos.to_nat px <> 0. +Proof. +apply sym_not_equal; apply lt_O_neq; apply lt_O_nat_of_P. +Qed. + +Lemma pred_nat_unfolded : + forall (x : Z) (Hx : (0 < x)%Z), x = S (pred_nat x Hx). +Proof. + intros [| px| px] Hx; try discriminate Hx. + unfold pred_nat in |- *. + rewrite S_predn. + symmetry in |- *; apply ZL9. + clear Hx; apply pred_nat_unfolded_subproof. +Qed. + +Lemma absolu_pred_nat : + forall (m : Z) (Hm : (0 < m)%Z), S (pred_nat m Hm) = Zabs_nat m. +Proof. + intros [| px| px] Hx; try discriminate Hx. + unfold pred_nat in |- *. + rewrite S_predn. + reflexivity. + apply pred_nat_unfolded_subproof. +Qed. + +Lemma pred_nat_absolu : + forall (m : Z) (Hm : (0 < m)%Z), pred_nat m Hm = Zabs_nat (m - 1). +Proof. + intros [| px| px] Hx; try discriminate Hx. + unfold pred_nat in |- *. + rewrite <- pred_absolu; reflexivity || assumption. +Qed. + +Lemma minus_pred_nat : + forall (n m : Z) (Hn : (0 < n)%Z) (Hm : (0 < m)%Z) (Hnm : (0 < n - m)%Z), + S (pred_nat n Hn) - S (pred_nat m Hm) = S (pred_nat (n - m) Hnm). +Proof. + intros. + simpl in |- *. + destruct n; try discriminate Hn. + destruct m; try discriminate Hm. + unfold pred_nat at 1 2 in |- *. + rewrite minus_pred; try apply lt_O_nat_of_P. + apply eq_inj. + rewrite <- pred_nat_unfolded. + rewrite Znat.inj_minus1. + repeat rewrite ZL9. + reflexivity. + apply le_inj. + apply Zlt_le_weak. + repeat rewrite ZL9. + apply Zlt_O_minus_lt. + assumption. +Qed. + + +(*###########################################################################*) +(** Properties of Zsgn *) +(*###########################################################################*) + + +Lemma Zsgn_1 : + forall x : Z, {Zsgn x = 0%Z} + {Zsgn x = 1%Z} + {Zsgn x = (-1)%Z}. (*QF*) +Proof. + intros. + case x. + left. + left. + unfold Zsgn in |- *. + reflexivity. + intro. + simpl in |- *. + left. + right. + reflexivity. + intro. + right. + simpl in |- *. + reflexivity. +Qed. + + +Lemma Zsgn_2 : forall x : Z, Zsgn x = 0%Z -> x = 0%Z. (*QF*) +Proof. + intros [| p1| p1]; simpl in |- *; intro H; constructor || discriminate H. +Qed. + + +Lemma Zsgn_3 : forall x : Z, x <> 0%Z -> Zsgn x <> 0%Z. (*QF*) +Proof. + intro. + case x. + intros. + apply False_ind. + apply H. + reflexivity. + intros. + simpl in |- *. + discriminate. + intros. + simpl in |- *. + discriminate. +Qed. + + + + +Theorem Zsgn_4 : forall a : Z, a = (Zsgn a * Zabs_nat a)%Z. (*QF*) +Proof. + intro. + case a. + simpl in |- *. + reflexivity. + intro. + unfold Zsgn in |- *. + unfold Zabs_nat in |- *. + rewrite Zmult_1_l. + symmetry in |- *. + apply ZL9. + intros. + unfold Zsgn in |- *. + unfold Zabs_nat in |- *. + rewrite ZL9. + constructor. +Qed. + + +Theorem Zsgn_5 : + forall a b x y : Z, + x <> 0%Z -> + y <> 0%Z -> + (Zsgn a * x)%Z = (Zsgn b * y)%Z -> (Zsgn a * y)%Z = (Zsgn b * x)%Z. (*QF*) +Proof. + intros a b x y H H0. + case a. + + case b. + simpl in |- *. + trivial. + + intro. + unfold Zsgn in |- *. + intro. + rewrite Zmult_1_l in H1. + simpl in H1. + apply False_ind. + apply H0. + symmetry in |- *. + assumption. + intro. + unfold Zsgn in |- *. + intro. + apply False_ind. + apply H0. + apply Zopp_inj. + simpl in |- *. + transitivity (-1 * y)%Z. + constructor. + transitivity (0 * x)%Z. + symmetry in |- *. + assumption. + simpl in |- *. + reflexivity. + intro. + unfold Zsgn at 1 in |- *. + unfold Zsgn at 2 in |- *. + intro. + transitivity y. + rewrite Zmult_1_l. + reflexivity. + transitivity (Zsgn b * (Zsgn b * y))%Z. + case (Zsgn_1 b). + intro. + case s. + intro. + apply False_ind. + apply H. + rewrite e in H1. + change ((1 * x)%Z = 0%Z) in H1. + rewrite Zmult_1_l in H1. + assumption. + intro. + rewrite e. + rewrite Zmult_1_l. + rewrite Zmult_1_l. + reflexivity. + intro. + rewrite e. + ring. + rewrite Zmult_1_l in H1. + rewrite H1. + reflexivity. + intro. + unfold Zsgn at 1 in |- *. + unfold Zsgn at 2 in |- *. + intro. + transitivity (Zsgn b * (-1 * (Zsgn b * y)))%Z. + case (Zsgn_1 b). + intros. + case s. + intro. + apply False_ind. + apply H. + apply Zopp_inj. + transitivity (-1 * x)%Z. + ring. + unfold Zopp in |- *. + rewrite e in H1. + transitivity (0 * y)%Z. + assumption. + simpl in |- *. + reflexivity. + intro. + rewrite e. + ring. + intro. + rewrite e. + ring. + rewrite <- H1. + ring. +Qed. + +Lemma Zsgn_6 : forall x : Z, x = 0%Z -> Zsgn x = 0%Z. +Proof. + intros. + rewrite H. + simpl in |- *. + reflexivity. +Qed. + + +Lemma Zsgn_7 : forall x : Z, (x > 0)%Z -> Zsgn x = 1%Z. +Proof. + intro. + case x. + intro. + apply False_ind. + apply (Zlt_irrefl 0). + Flip. + intros. + simpl in |- *. + reflexivity. + intros. + apply False_ind. + apply (Zlt_irrefl (Zneg p)). + apply Zlt_trans with 0%Z. + constructor. + Flip. +Qed. + + +Lemma Zsgn_7' : forall x : Z, (0 < x)%Z -> Zsgn x = 1%Z. +Proof. + intros; apply Zsgn_7; Flip. +Qed. + + +Lemma Zsgn_8 : forall x : Z, (x < 0)%Z -> Zsgn x = (-1)%Z. +Proof. + intro. + case x. + intro. + apply False_ind. + apply (Zlt_irrefl 0). + assumption. + intros. + apply False_ind. + apply (Zlt_irrefl 0). + apply Zlt_trans with (Zpos p). + constructor. + assumption. + intros. + simpl in |- *. + reflexivity. +Qed. + +Lemma Zsgn_9 : forall x : Z, Zsgn x = 1%Z -> (0 < x)%Z. +Proof. + intro. + case x. + intro. + apply False_ind. + simpl in H. + discriminate. + intros. + constructor. + intros. + apply False_ind. + discriminate. +Qed. + +Lemma Zsgn_10 : forall x : Z, Zsgn x = (-1)%Z -> (x < 0)%Z. +Proof. + intro. + case x. + intro. + apply False_ind. + discriminate. + intros. + apply False_ind. + discriminate. + intros. + constructor. +Qed. + +Lemma Zsgn_11 : forall x : Z, (Zsgn x < 0)%Z -> (x < 0)%Z. +Proof. + intros. + apply Zsgn_10. + case (Zsgn_1 x). + intro. + apply False_ind. + case s. + intro. + generalize (Zorder.Zlt_not_eq _ _ H). + intro. + apply (H0 e). + intro. + rewrite e in H. + generalize (Zorder.Zlt_not_eq _ _ H). + intro. + discriminate. + trivial. +Qed. + +Lemma Zsgn_12 : forall x : Z, (0 < Zsgn x)%Z -> (0 < x)%Z. +Proof. + intros. + apply Zsgn_9. + case (Zsgn_1 x). + intro. + case s. + intro. + generalize (Zorder.Zlt_not_eq _ _ H). + intro. + generalize (sym_eq e). + intro. + apply False_ind. + apply (H0 H1). + trivial. + intro. + rewrite e in H. + generalize (Zorder.Zlt_not_eq _ _ H). + intro. + apply False_ind. + discriminate. +Qed. + +Lemma Zsgn_13 : forall x : Z, (0 <= Zsgn x)%Z -> (0 <= x)%Z. +Proof. + intros. + case (Z_le_lt_eq_dec 0 (Zsgn x) H). + intro. + apply Zlt_le_weak. + apply Zsgn_12. + assumption. + intro. + assert (x = 0%Z). + apply Zsgn_2. + symmetry in |- *. + assumption. + rewrite H0. + apply Zle_refl. +Qed. + +Lemma Zsgn_14 : forall x : Z, (Zsgn x <= 0)%Z -> (x <= 0)%Z. +Proof. + intros. + case (Z_le_lt_eq_dec (Zsgn x) 0 H). + intro. + apply Zlt_le_weak. + apply Zsgn_11. + assumption. + intro. + assert (x = 0%Z). + apply Zsgn_2. + assumption. + rewrite H0. + apply Zle_refl. +Qed. + +Lemma Zsgn_15 : forall x y : Z, Zsgn (x * y) = (Zsgn x * Zsgn y)%Z. +Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; constructor. +Qed. + +Lemma Zsgn_16 : + forall x y : Z, + Zsgn (x * y) = 1%Z -> {(0 < x)%Z /\ (0 < y)%Z} + {(x < 0)%Z /\ (y < 0)%Z}. +Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + try discriminate H; [ left | right ]; repeat split. +Qed. + +Lemma Zsgn_17 : + forall x y : Z, + Zsgn (x * y) = (-1)%Z -> {(0 < x)%Z /\ (y < 0)%Z} + {(x < 0)%Z /\ (0 < y)%Z}. +Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + try discriminate H; [ left | right ]; repeat split. +Qed. + +Lemma Zsgn_18 : forall x y : Z, Zsgn (x * y) = 0%Z -> {x = 0%Z} + {y = 0%Z}. +Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + try discriminate H; [ left | right | right ]; constructor. +Qed. + + + +Lemma Zsgn_19 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 < x + y)%Z. +Proof. + Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + discriminate H || (constructor || apply Zsgn_12; assumption). +Qed. + +Lemma Zsgn_20 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (x + y < 0)%Z. +Proof. + Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + discriminate H || (constructor || apply Zsgn_11; assumption). +Qed. + + +Lemma Zsgn_21 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 <= x)%Z. +Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intros H H0; + discriminate H || discriminate H0. +Qed. + +Lemma Zsgn_22 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (x <= 0)%Z. +Proof. + Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intros H H0; + discriminate H || discriminate H0. +Qed. + +Lemma Zsgn_23 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 <= y)%Z. +Proof. + intros [[| p2| p2]| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; + intros H H0; discriminate H || discriminate H0. +Qed. + +Lemma Zsgn_24 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (y <= 0)%Z. +Proof. + intros [[| p2| p2]| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; + intros H H0; discriminate H || discriminate H0. +Qed. + +Lemma Zsgn_25 : forall x : Z, Zsgn (- x) = (- Zsgn x)%Z. +Proof. + intros [| p1| p1]; simpl in |- *; reflexivity. +Qed. + + +Lemma Zsgn_26 : forall x : Z, (0 < x)%Z -> (0 < Zsgn x)%Z. +Proof. + intros [| p| p] Hp; trivial. +Qed. + +Lemma Zsgn_27 : forall x : Z, (x < 0)%Z -> (Zsgn x < 0)%Z. +Proof. + intros [| p| p] Hp; trivial. +Qed. + +Hint Resolve Zsgn_1 Zsgn_2 Zsgn_3 Zsgn_4 Zsgn_5 Zsgn_6 Zsgn_7 Zsgn_7' Zsgn_8 + Zsgn_9 Zsgn_10 Zsgn_11 Zsgn_12 Zsgn_13 Zsgn_14 Zsgn_15 Zsgn_16 Zsgn_17 + Zsgn_18 Zsgn_19 Zsgn_20 Zsgn_21 Zsgn_22 Zsgn_23 Zsgn_24 Zsgn_25 Zsgn_26 + Zsgn_27: zarith. + +(*###########################################################################*) +(** Properties of Zabs *) +(*###########################################################################*) + +Lemma Zabs_1 : forall z p : Z, (Zabs z < p)%Z -> (z < p)%Z /\ (- p < z)%Z. +Proof. + intros z p. + case z. + intros. + simpl in H. + split. + assumption. + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + replace (-1)%Z with (Zpred 0). + apply Zlt_pred. + simpl; trivial. + ring_simplify (-1 * - p)%Z (-1 * 0)%Z. + apply Zlt_gt. + assumption. + + intros. + simpl in H. + split. + assumption. + apply Zlt_trans with (m := 0%Z). + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + replace (-1)%Z with (Zpred 0). + apply Zlt_pred. + simpl; trivial. + ring_simplify (-1 * - p)%Z (-1 * 0)%Z. + apply Zlt_gt. + apply Zlt_trans with (m := Zpos p0). + constructor. + assumption. + constructor. + + intros. + simpl in H. + split. + apply Zlt_trans with (m := Zpos p0). + constructor. + assumption. + + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + replace (-1)%Z with (Zpred 0). + apply Zlt_pred. + simpl;trivial. + ring_simplify (-1 * - p)%Z. + replace (-1 * Zneg p0)%Z with (- Zneg p0)%Z. + replace (- Zneg p0)%Z with (Zpos p0). + apply Zlt_gt. + assumption. + symmetry in |- *. + apply Zopp_neg. + rewrite Zopp_mult_distr_l_reverse with (n := 1%Z). + simpl in |- *. + constructor. +Qed. + + +Lemma Zabs_2 : forall z p : Z, (Zabs z > p)%Z -> (z > p)%Z \/ (- p > z)%Z. +Proof. + intros z p. + case z. + intros. + simpl in H. + left. + assumption. + + intros. + simpl in H. + left. + assumption. + + intros. + simpl in H. + right. + apply Zlt_gt. + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + constructor. + ring_simplify (-1 * - p)%Z. + replace (-1 * Zneg p0)%Z with (Zpos p0). + assumption. + reflexivity. +Qed. + +Lemma Zabs_3 : forall z p : Z, (z < p)%Z /\ (- p < z)%Z -> (Zabs z < p)%Z. +Proof. + intros z p. + case z. + intro. + simpl in |- *. + elim H. + intros. + assumption. + + intros. + elim H. + intros. + simpl in |- *. + assumption. + + intros. + elim H. + intros. + simpl in |- *. + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + constructor. + replace (-1 * Zpos p0)%Z with (Zneg p0). + replace (-1 * p)%Z with (- p)%Z. + apply Zlt_gt. + assumption. + ring. + simpl in |- *. + reflexivity. +Qed. + +Lemma Zabs_4 : forall z p : Z, (Zabs z < p)%Z -> (- p < z < p)%Z. +Proof. + intros. + split. + apply proj2 with (A := (z < p)%Z). + apply Zabs_1. + assumption. + apply proj1 with (B := (- p < z)%Z). + apply Zabs_1. + assumption. +Qed. + + +Lemma Zabs_5 : forall z p : Z, (Zabs z <= p)%Z -> (- p <= z <= p)%Z. +Proof. + intros. + split. + replace (- p)%Z with (Zsucc (- Zsucc p)). + apply Zlt_le_succ. + apply proj2 with (A := (z < Zsucc p)%Z). + apply Zabs_1. + apply Zle_lt_succ. + assumption. + unfold Zsucc in |- *. + ring. + apply Zlt_succ_le. + apply proj1 with (B := (- Zsucc p < z)%Z). + apply Zabs_1. + apply Zle_lt_succ. + assumption. +Qed. + +Lemma Zabs_6 : forall z p : Z, (Zabs z <= p)%Z -> (z <= p)%Z. +Proof. + intros. + apply proj2 with (A := (- p <= z)%Z). + apply Zabs_5. + assumption. +Qed. + +Lemma Zabs_7 : forall z p : Z, (Zabs z <= p)%Z -> (- p <= z)%Z. +Proof. + intros. + apply proj1 with (B := (z <= p)%Z). + apply Zabs_5. + assumption. +Qed. + +Lemma Zabs_8 : forall z p : Z, (- p <= z <= p)%Z -> (Zabs z <= p)%Z. +Proof. + intros. + apply Zlt_succ_le. + apply Zabs_3. + elim H. + intros. + split. + apply Zle_lt_succ. + assumption. + apply Zlt_le_trans with (m := (- p)%Z). + apply Zgt_lt. + apply Zlt_opp. + apply Zlt_succ. + assumption. +Qed. + +Lemma Zabs_min : forall z : Z, Zabs z = Zabs (- z). +Proof. + intro. + case z. + simpl in |- *. + reflexivity. + intro. + simpl in |- *. + reflexivity. + intro. + simpl in |- *. + reflexivity. +Qed. + +Lemma Zabs_9 : + forall z p : Z, (0 <= p)%Z -> (p < z)%Z \/ (z < - p)%Z -> (p < Zabs z)%Z. +Proof. + intros. + case H0. + intro. + replace (Zabs z) with z. + assumption. + symmetry in |- *. + apply Zabs_eq. + apply Zlt_le_weak. + apply Zle_lt_trans with (m := p). + assumption. + assumption. + intro. + cut (Zabs z = (- z)%Z). + intro. + rewrite H2. + apply Zmin_cancel_Zlt. + ring_simplify (- - z)%Z. + assumption. + rewrite Zabs_min. + apply Zabs_eq. + apply Zlt_le_weak. + apply Zle_lt_trans with (m := p). + assumption. + apply Zmin_cancel_Zlt. + ring_simplify (- - z)%Z. + assumption. +Qed. + +Lemma Zabs_10 : forall z : Z, (0 <= Zabs z)%Z. +Proof. + intro. + case (Z_zerop z). + intro. + rewrite e. + simpl in |- *. + apply Zle_refl. + intro. + case (not_Zeq z 0 n). + intro. + apply Zlt_le_weak. + apply Zabs_9. + apply Zle_refl. + simpl in |- *. + right. + assumption. + intro. + apply Zlt_le_weak. + apply Zabs_9. + apply Zle_refl. + simpl in |- *. + left. + assumption. +Qed. + +Lemma Zabs_11 : forall z : Z, z <> 0%Z -> (0 < Zabs z)%Z. +Proof. + intros. + apply Zabs_9. + apply Zle_refl. + simpl in |- *. + apply not_Zeq. + intro. + apply H. + symmetry in |- *. + assumption. +Qed. + +Lemma Zabs_12 : forall z m : Z, (m < Zabs z)%Z -> {(m < z)%Z} + {(z < - m)%Z}. +Proof. + intros [| p| p] m; simpl in |- *; intros H; + [ left | left | right; apply Zmin_cancel_Zlt; rewrite Zopp_involutive ]; + assumption. +Qed. + +Lemma Zabs_mult : forall z p : Z, Zabs (z * p) = (Zabs z * Zabs p)%Z. +Proof. + intros. + case z. + simpl in |- *. + reflexivity. + case p. + simpl in |- *. + reflexivity. + intros. + simpl in |- *. + reflexivity. + intros. + simpl in |- *. + reflexivity. + case p. + intro. + simpl in |- *. + reflexivity. + intros. + simpl in |- *. + reflexivity. + intros. + simpl in |- *. + reflexivity. +Qed. + +Lemma Zabs_plus : forall z p : Z, (Zabs (z + p) <= Zabs z + Zabs p)%Z. +Proof. + intros. + case z. + simpl in |- *. + apply Zle_refl. + case p. + intro. + simpl in |- *. + apply Zle_refl. + intros. + simpl in |- *. + apply Zle_refl. + intros. + unfold Zabs at 2 in |- *. + unfold Zabs at 2 in |- *. + apply Zabs_8. + split. + apply Zplus_le_reg_l with (Zpos p1 - Zneg p0)%Z. + replace (Zpos p1 - Zneg p0 + - (Zpos p1 + Zpos p0))%Z with + (- (Zpos p0 + Zneg p0))%Z. + replace (Zpos p1 - Zneg p0 + (Zpos p1 + Zneg p0))%Z with (2 * Zpos p1)%Z. + replace (- (Zpos p0 + Zneg p0))%Z with 0%Z. + apply Zmult_gt_0_le_0_compat. + constructor. + apply Zlt_le_weak. + constructor. + rewrite <- Zopp_neg with p0. + ring. + ring. + ring. + apply Zplus_le_compat. + apply Zle_refl. + apply Zlt_le_weak. + constructor. + + case p. + simpl in |- *. + intro. + apply Zle_refl. + intros. + unfold Zabs at 2 in |- *. + unfold Zabs at 2 in |- *. + apply Zabs_8. + split. + apply Zplus_le_reg_l with (Zpos p1 + Zneg p0)%Z. + replace (Zpos p1 + Zneg p0 + - (Zpos p1 + Zpos p0))%Z with + (Zneg p0 - Zpos p0)%Z. + replace (Zpos p1 + Zneg p0 + (Zneg p1 + Zpos p0))%Z with 0%Z. + apply Zplus_le_reg_l with (Zpos p0). + replace (Zpos p0 + (Zneg p0 - Zpos p0))%Z with (Zneg p0). + simpl in |- *. + apply Zlt_le_weak. + constructor. + ring. + replace (Zpos p1 + Zneg p0 + (Zneg p1 + Zpos p0))%Z with + (Zpos p1 + Zneg p1 + (Zpos p0 + Zneg p0))%Z. + replace 0%Z with (0 + 0)%Z. + apply Zplus_eq_compat. + rewrite <- Zopp_neg with p1. + ring. + rewrite <- Zopp_neg with p0. + ring. + simpl in |- *. + constructor. + ring. + ring. + apply Zplus_le_compat. + apply Zlt_le_weak. + constructor. + apply Zle_refl. + intros. + simpl in |- *. + apply Zle_refl. +Qed. + +Lemma Zabs_neg : forall z : Z, (z <= 0)%Z -> Zabs z = (- z)%Z. +Proof. + intro. + case z. + simpl in |- *. + intro. + reflexivity. + intros. + apply False_ind. + apply H. + simpl in |- *. + reflexivity. + intros. + simpl in |- *. + reflexivity. +Qed. + +Lemma Zle_Zabs: forall z, (z <= Zabs z)%Z. +Proof. + intros [|z|z]; simpl; auto with zarith; apply Zle_neg_pos. +Qed. + +Hint Resolve Zabs_1 Zabs_2 Zabs_3 Zabs_4 Zabs_5 Zabs_6 Zabs_7 Zabs_8 Zabs_9 + Zabs_10 Zabs_11 Zabs_12 Zabs_min Zabs_neg Zabs_mult Zabs_plus Zle_Zabs: zarith. + + +(*###########################################################################*) +(** Induction on Z *) +(*###########################################################################*) + +Lemma Zind : + forall (P : Z -> Prop) (p : Z), + P p -> + (forall q : Z, (p <= q)%Z -> P q -> P (q + 1)%Z) -> + forall q : Z, (p <= q)%Z -> P q. +Proof. + intros P p. + intro. + intro. + cut (forall q : Z, (p <= q)%Z -> exists k : nat, q = (p + k)%Z). + intro. + cut (forall k : nat, P (p + k)%Z). + intro. + intros. + cut (exists k : nat, q = (p + Z_of_nat k)%Z). + intro. + case H4. + intros. + rewrite H5. + apply H2. + apply H1. + assumption. + intro. + induction k as [| k Hreck]. + simpl in |- *. + ring_simplify (p + 0)%Z. + assumption. + replace (p + Z_of_nat (S k))%Z with (p + k + 1)%Z. + apply H0. + apply Zplus_le_reg_l with (p := (- p)%Z). + replace (- p + p)%Z with (Z_of_nat 0). + ring_simplify (- p + (p + Z_of_nat k))%Z. + apply Znat.inj_le. + apply le_O_n. + ring_simplify; auto with arith. + assumption. + rewrite (Znat.inj_S k). + unfold Zsucc in |- *. + ring. + intros. + cut (exists k : nat, (q - p)%Z = Z_of_nat k). + intro. + case H2. + intro k. + intros. + exists k. + apply Zplus_reg_l with (n := (- p)%Z). + replace (- p + q)%Z with (q - p)%Z. + rewrite H3. + ring. + ring. + apply Z_of_nat_complete. + unfold Zminus in |- *. + apply Zle_left. + assumption. +Qed. + +Lemma Zrec : + forall (P : Z -> Set) (p : Z), + P p -> + (forall q : Z, (p <= q)%Z -> P q -> P (q + 1)%Z) -> + forall q : Z, (p <= q)%Z -> P q. +Proof. + intros F p. + intro. + intro. + cut (forall q : Z, (p <= q)%Z -> {k : nat | q = (p + k)%Z}). + intro. + cut (forall k : nat, F (p + k)%Z). + intro. + intros. + cut {k : nat | q = (p + Z_of_nat k)%Z}. + intro. + case H4. + intros. + rewrite e. + apply H2. + apply H1. + assumption. + intro. + induction k as [| k Hreck]. + simpl in |- *. + rewrite Zplus_0_r. + assumption. + replace (p + Z_of_nat (S k))%Z with (p + k + 1)%Z. + apply H0. + apply Zplus_le_reg_l with (p := (- p)%Z). + replace (- p + p)%Z with (Z_of_nat 0). + replace (- p + (p + Z_of_nat k))%Z with (Z_of_nat k). + apply Znat.inj_le. + apply le_O_n. + rewrite Zplus_assoc; rewrite Zplus_opp_l; reflexivity. + rewrite Zplus_opp_l; reflexivity. + assumption. + rewrite (Znat.inj_S k). + unfold Zsucc in |- *. + apply Zplus_assoc_reverse. + intros. + cut {k : nat | (q - p)%Z = Z_of_nat k}. + intro H2. + case H2. + intro k. + intros. + exists k. + apply Zplus_reg_l with (n := (- p)%Z). + replace (- p + q)%Z with (q - p)%Z. + rewrite e. + rewrite Zplus_assoc; rewrite Zplus_opp_l; reflexivity. + unfold Zminus in |- *. + apply Zplus_comm. + apply Z_of_nat_complete_inf. + unfold Zminus in |- *. + apply Zle_left. + assumption. +Qed. + +Lemma Zrec_down : + forall (P : Z -> Set) (p : Z), + P p -> + (forall q : Z, (q <= p)%Z -> P q -> P (q - 1)%Z) -> + forall q : Z, (q <= p)%Z -> P q. +Proof. + intros F p. + intro. + intro. + cut (forall q : Z, (q <= p)%Z -> {k : nat | q = (p - k)%Z}). + intro. + cut (forall k : nat, F (p - k)%Z). + intro. + intros. + cut {k : nat | q = (p - Z_of_nat k)%Z}. + intro. + case H4. + intros. + rewrite e. + apply H2. + apply H1. + assumption. + intro. + induction k as [| k Hreck]. + simpl in |- *. + replace (p - 0)%Z with p. + assumption. + unfold Zminus in |- *. + unfold Zopp in |- *. + rewrite Zplus_0_r; reflexivity. + replace (p - Z_of_nat (S k))%Z with (p - k - 1)%Z. + apply H0. + apply Zplus_le_reg_l with (p := (- p)%Z). + replace (- p + p)%Z with (- Z_of_nat 0)%Z. + replace (- p + (p - Z_of_nat k))%Z with (- Z_of_nat k)%Z. + apply Zge_le. + apply Zge_opp. + apply Znat.inj_le. + apply le_O_n. + unfold Zminus in |- *; rewrite Zplus_assoc; rewrite Zplus_opp_l; reflexivity. + rewrite Zplus_opp_l; reflexivity. + assumption. + rewrite (Znat.inj_S k). + unfold Zsucc in |- *. + unfold Zminus at 1 2 in |- *. + rewrite Zplus_assoc_reverse. + rewrite <- Zopp_plus_distr. + reflexivity. + intros. + cut {k : nat | (p - q)%Z = Z_of_nat k}. + intro. + case H2. + intro k. + intros. + exists k. + apply Zopp_inj. + apply Zplus_reg_l with (n := p). + replace (p + - (p - Z_of_nat k))%Z with (Z_of_nat k). + rewrite <- e. + reflexivity. + unfold Zminus in |- *. + rewrite Zopp_plus_distr. + rewrite Zplus_assoc. + rewrite Zplus_opp_r. + rewrite Zopp_involutive. + reflexivity. + apply Z_of_nat_complete_inf. + unfold Zminus in |- *. + apply Zle_left. + assumption. +Qed. + +Lemma Zind_down : + forall (P : Z -> Prop) (p : Z), + P p -> + (forall q : Z, (q <= p)%Z -> P q -> P (q - 1)%Z) -> + forall q : Z, (q <= p)%Z -> P q. +Proof. + intros F p. + intro. + intro. + cut (forall q : Z, (q <= p)%Z -> exists k : nat, q = (p - k)%Z). + intro. + cut (forall k : nat, F (p - k)%Z). + intro. + intros. + cut (exists k : nat, q = (p - Z_of_nat k)%Z). + intro. + case H4. + intros x e. + rewrite e. + apply H2. + apply H1. + assumption. + intro. + induction k as [| k Hreck]. + simpl in |- *. + replace (p - 0)%Z with p. + assumption. + ring. + replace (p - Z_of_nat (S k))%Z with (p - k - 1)%Z. + apply H0. + apply Zplus_le_reg_l with (p := (- p)%Z). + replace (- p + p)%Z with (- Z_of_nat 0)%Z. + replace (- p + (p - Z_of_nat k))%Z with (- Z_of_nat k)%Z. + apply Zge_le. + apply Zge_opp. + apply Znat.inj_le. + apply le_O_n. + ring. + ring_simplify; auto with arith. + assumption. + rewrite (Znat.inj_S k). + unfold Zsucc in |- *. + ring. + intros. + cut (exists k : nat, (p - q)%Z = Z_of_nat k). + intro. + case H2. + intro k. + intros. + exists k. + apply Zopp_inj. + apply Zplus_reg_l with (n := p). + replace (p + - (p - Z_of_nat k))%Z with (Z_of_nat k). + rewrite <- H3. + ring. + ring. + apply Z_of_nat_complete. + unfold Zminus in |- *. + apply Zle_left. + assumption. +Qed. + +Lemma Zrec_wf : + forall (P : Z -> Set) (p : Z), + (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) -> + forall q : Z, (p <= q)%Z -> P q. +Proof. + intros P p WF_ind_step q Hq. + cut (forall x : Z, (p <= x)%Z -> forall y : Z, (p <= y < x)%Z -> P y). + intro. + apply (H (Zsucc q)). + apply Zle_le_succ. + assumption. + + split; [ assumption | exact (Zlt_succ q) ]. + + intros x0 Hx0; generalize Hx0; pattern x0 in |- *. + apply Zrec with (p := p). + intros. + absurd (p <= p)%Z. + apply Zgt_not_le. + apply Zgt_le_trans with (m := y). + apply Zlt_gt. + elim H. + intros. + assumption. + elim H. + intros. + assumption. + apply Zle_refl. + + intros. + apply WF_ind_step. + intros. + apply (H0 H). + split. + elim H2. + intros. + assumption. + apply Zlt_le_trans with y. + elim H2. + intros. + assumption. + apply Zgt_succ_le. + apply Zlt_gt. + elim H1. + intros. + unfold Zsucc in |- *. + assumption. + assumption. +Qed. + +Lemma Zrec_wf2 : + forall (q : Z) (P : Z -> Set) (p : Z), + (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) -> + (p <= q)%Z -> P q. +Proof. + intros. + apply Zrec_wf with (p := p). + assumption. + assumption. +Qed. + +Lemma Zrec_wf_double : + forall (P : Z -> Z -> Set) (p0 q0 : Z), + (forall n m : Z, + (forall p q : Z, (q0 <= q)%Z -> (p0 <= p < n)%Z -> P p q) -> + (forall p : Z, (q0 <= p < m)%Z -> P n p) -> P n m) -> + forall p q : Z, (q0 <= q)%Z -> (p0 <= p)%Z -> P p q. +Proof. + intros P p0 q0 Hrec p. + intros. + generalize q H. + pattern p in |- *. + apply Zrec_wf with (p := p0). + intros p1 H1. + intros. + pattern q1 in |- *. + apply Zrec_wf with (p := q0). + intros q2 H3. + apply Hrec. + intros. + apply H1. + assumption. + assumption. + intros. + apply H3. + assumption. + assumption. + assumption. +Qed. + +Lemma Zind_wf : + forall (P : Z -> Prop) (p : Z), + (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) -> + forall q : Z, (p <= q)%Z -> P q. +Proof. + intros P p WF_ind_step q Hq. + cut (forall x : Z, (p <= x)%Z -> forall y : Z, (p <= y < x)%Z -> P y). + intro. + apply (H (Zsucc q)). + apply Zle_le_succ. + assumption. + + split; [ assumption | exact (Zlt_succ q) ]. + + intros x0 Hx0; generalize Hx0; pattern x0 in |- *. + apply Zind with (p := p). + intros. + absurd (p <= p)%Z. + apply Zgt_not_le. + apply Zgt_le_trans with (m := y). + apply Zlt_gt. + elim H. + intros. + assumption. + elim H. + intros. + assumption. + apply Zle_refl. + + intros. + apply WF_ind_step. + intros. + apply (H0 H). + split. + elim H2. + intros. + assumption. + apply Zlt_le_trans with y. + elim H2. + intros. + assumption. + apply Zgt_succ_le. + apply Zlt_gt. + elim H1. + intros. + unfold Zsucc in |- *. + assumption. + assumption. +Qed. + +Lemma Zind_wf2 : + forall (q : Z) (P : Z -> Prop) (p : Z), + (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) -> + (p <= q)%Z -> P q. +Proof. + intros. + apply Zind_wf with (p := p). + assumption. + assumption. +Qed. + +Lemma Zind_wf_double : + forall (P : Z -> Z -> Prop) (p0 q0 : Z), + (forall n m : Z, + (forall p q : Z, (q0 <= q)%Z -> (p0 <= p < n)%Z -> P p q) -> + (forall p : Z, (q0 <= p < m)%Z -> P n p) -> P n m) -> + forall p q : Z, (q0 <= q)%Z -> (p0 <= p)%Z -> P p q. +Proof. + intros P p0 q0 Hrec p. + intros. + generalize q H. + pattern p in |- *. + apply Zind_wf with (p := p0). + intros p1 H1. + intros. + pattern q1 in |- *. + apply Zind_wf with (p := q0). + intros q2 H3. + apply Hrec. + intros. + apply H1. + assumption. + assumption. + intros. + apply H3. + assumption. + assumption. + assumption. +Qed. + +(*###########################################################################*) +(** Properties of Zmax *) +(*###########################################################################*) + +Definition Zmax (n m : Z) := (n + m - Zmin n m)%Z. + +Lemma ZmaxSS : forall n m : Z, (Zmax n m + 1)%Z = Zmax (n + 1) (m + 1). +Proof. + intros. + unfold Zmax in |- *. + replace (Zmin (n + 1) (m + 1)) with (Zmin n m + 1)%Z. + ring. + symmetry in |- *. + change (Zmin (Zsucc n) (Zsucc m) = Zsucc (Zmin n m)) in |- *. + symmetry in |- *. + apply Zmin_SS. +Qed. + +Lemma Zle_max_l : forall n m : Z, (n <= Zmax n m)%Z. +Proof. + intros. + unfold Zmax in |- *. + apply Zplus_le_reg_l with (p := (- n + Zmin n m)%Z). + ring_simplify (- n + Zmin n m + n)%Z. + ring_simplify (- n + Zmin n m + (n + m - Zmin n m))%Z. + apply Zle_min_r. +Qed. + +Lemma Zle_max_r : forall n m : Z, (m <= Zmax n m)%Z. +Proof. + intros. + unfold Zmax in |- *. + apply Zplus_le_reg_l with (p := (- m + Zmin n m)%Z). + ring_simplify (- m + Zmin n m + m)%Z. + ring_simplify (- m + Zmin n m + (n + m - Zmin n m))%Z. + apply Zle_min_l. +Qed. + + +Lemma Zmin_or_informative : forall n m : Z, {Zmin n m = n} + {Zmin n m = m}. +Proof. + intros. + case (Z_lt_ge_dec n m). + unfold Zmin in |- *. + unfold Zlt in |- *. + intro z. + rewrite z. + left. + reflexivity. + intro. + cut ({(n > m)%Z} + {n = m :>Z}). + intro. + case H. + intros z0. + unfold Zmin in |- *. + unfold Zgt in z0. + rewrite z0. + right. + reflexivity. + intro. + rewrite e. + right. + apply Zmin_n_n. + cut ({(m < n)%Z} + {m = n :>Z}). + intro. + elim H. + intro. + left. + apply Zlt_gt. + assumption. + intro. + right. + symmetry in |- *. + assumption. + apply Z_le_lt_eq_dec. + apply Zge_le. + assumption. +Qed. + +Lemma Zmax_case : forall (n m : Z) (P : Z -> Set), P n -> P m -> P (Zmax n m). +Proof. + intros. + unfold Zmax in |- *. + case Zmin_or_informative with (n := n) (m := m). + intro. + rewrite e. + cut ((n + m - n)%Z = m). + intro. + rewrite H1. + assumption. + ring. + intro. + rewrite e. + cut ((n + m - m)%Z = n). + intro. + rewrite H1. + assumption. + ring. +Qed. + +Lemma Zmax_or_informative : forall n m : Z, {Zmax n m = n} + {Zmax n m = m}. +Proof. + intros. + unfold Zmax in |- *. + case Zmin_or_informative with (n := n) (m := m). + intro. + rewrite e. + right. + ring. + intro. + rewrite e. + left. + ring. +Qed. + +Lemma Zmax_n_n : forall n : Z, Zmax n n = n. +Proof. + intros. + unfold Zmax in |- *. + rewrite (Zmin_n_n n). + ring. +Qed. + +Hint Resolve ZmaxSS Zle_max_r Zle_max_l Zmax_n_n: zarith. + +(*###########################################################################*) +(** Properties of Arity *) +(*###########################################################################*) + +Lemma Zeven_S : forall x : Z, Zeven.Zodd x -> Zeven.Zeven (x + 1). +Proof. + exact Zeven.Zeven_Sn. +Qed. + +Lemma Zeven_pred : forall x : Z, Zeven.Zodd x -> Zeven.Zeven (x - 1). +Proof. + exact Zeven.Zeven_pred. +Qed. + +(* This lemma used to be useful since it was mentioned with an unnecessary premise + `x>=0` as Z_modulo_2 in ZArith, but the ZArith version has been fixed. *) + +Definition Z_modulo_2_always : + forall x : Z, {y : Z | x = (2 * y)%Z} + {y : Z | x = (2 * y + 1)%Z} := + Zeven.Z_modulo_2. + +(*###########################################################################*) +(** Properties of Zdiv *) +(*###########################################################################*) + +Lemma Z_div_mod_eq_2 : + forall a b : Z, (0 < b)%Z -> (b * (a / b))%Z = (a - a mod b)%Z. +Proof. + intros. + apply Zplus_minus_eq. + rewrite Zplus_comm. + apply Z_div_mod_eq. + Flip. +Qed. + +Lemma Z_div_le : + forall a b c : Z, (0 < c)%Z -> (b <= a)%Z -> (b / c <= a / c)%Z. +Proof. + intros. + apply Zge_le. + apply Z_div_ge; Flip; assumption. +Qed. + +Lemma Z_div_nonneg : + forall a b : Z, (0 < b)%Z -> (0 <= a)%Z -> (0 <= a / b)%Z. +Proof. + intros. + apply Zge_le. + apply Z_div_ge0; Flip; assumption. +Qed. + +Lemma Z_div_neg : forall a b : Z, (0 < b)%Z -> (a < 0)%Z -> (a / b < 0)%Z. +Proof. + intros. + rewrite (Z_div_mod_eq a b) in H0. + elim (Z_mod_lt a b). + intros H1 _. + apply Znot_ge_lt. + intro. + apply (Zlt_not_le (b * (a / b) + a mod b) 0 H0). + apply Zplus_le_0_compat. + apply Zmult_le_0_compat. + apply Zlt_le_weak; assumption. + Flip. + assumption. + Flip. + Flip. +Qed. + +Hint Resolve Z_div_mod_eq_2 Z_div_le Z_div_nonneg Z_div_neg: zarith. + +(*###########################################################################*) +(** Properties of Zpower *) +(*###########################################################################*) + +Lemma Zpower_1 : forall a : Z, (a ^ 1)%Z = a. +Proof. + intros; unfold Zpower in |- *; unfold Zpower_pos in |- *; simpl in |- *; + auto with zarith. +Qed. + +Lemma Zpower_2 : forall a : Z, (a ^ 2)%Z = (a * a)%Z. +Proof. + intros; unfold Zpower in |- *; unfold Zpower_pos in |- *; simpl in |- *; + ring. +Qed. + +Hint Resolve Zpower_1 Zpower_2: zarith. diff --git a/test-suite/micromega/example.v b/test-suite/micromega/example.v index d648c2e4..25e4a09f 100644 --- a/test-suite/micromega/example.v +++ b/test-suite/micromega/example.v @@ -2,13 +2,12 @@ (* *) (* Micromega: A reflexive tactic using the Positivstellensatz *) (* *) -(* Frdric Besson (Irisa/Inria) 2006-2008 *) +(* Frédéric Besson (Irisa/Inria) 2006-2008 *) (* *) (************************************************************************) Require Import ZArith. Require Import Psatz. -Require Import Ring_normalize. Open Scope Z_scope. Require Import ZMicromega. Require Import VarMap. @@ -23,7 +22,7 @@ Proof. Qed. -(* From Laurent Thry *) +(* From Laurent Théry *) Lemma some_pol : forall x, 4 * x ^ 2 + 3 * x + 2 >= 0. Proof. diff --git a/test-suite/micromega/heap3_vcgen_25.v b/test-suite/micromega/heap3_vcgen_25.v index efb5c7fd..00522f50 100644 --- a/test-suite/micromega/heap3_vcgen_25.v +++ b/test-suite/micromega/heap3_vcgen_25.v @@ -7,7 +7,7 @@ (************************************************************************) Require Import ZArith. -Require Import Psatz. +Require Import Lia. Open Scope Z_scope. diff --git a/test-suite/micromega/qexample.v b/test-suite/micromega/qexample.v index 76dc52e6..47e6005b 100644 --- a/test-suite/micromega/qexample.v +++ b/test-suite/micromega/qexample.v @@ -8,7 +8,6 @@ Require Import Psatz. Require Import QArith. -Require Import Ring_normalize. Lemma plus_minus : forall x y, 0 == x + y -> 0 == x -y -> 0 == x /\ 0 == y. diff --git a/test-suite/micromega/rexample.v b/test-suite/micromega/rexample.v index 9bb9dacc..2eed7e95 100644 --- a/test-suite/micromega/rexample.v +++ b/test-suite/micromega/rexample.v @@ -8,7 +8,6 @@ Require Import Psatz. Require Import Reals. -Require Import Ring_normalize. Open Scope R_scope. diff --git a/test-suite/micromega/zomicron.v b/test-suite/micromega/zomicron.v index 3b246023..0ec1dbfb 100644 --- a/test-suite/micromega/zomicron.v +++ b/test-suite/micromega/zomicron.v @@ -1,5 +1,5 @@ Require Import ZArith. -Require Import Psatz. +Require Import Lia. Open Scope Z_scope. Lemma two_x_eq_1 : forall x, 2 * x = 1 -> False. diff --git a/test-suite/misc/berardi_test.v b/test-suite/misc/berardi_test.v index 9f01c565..219686b9 100644 --- a/test-suite/misc/berardi_test.v +++ b/test-suite/misc/berardi_test.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/modules/Przyklad.v b/test-suite/modules/Przyklad.v index 341805a1..7214287a 100644 --- a/test-suite/modules/Przyklad.v +++ b/test-suite/modules/Przyklad.v @@ -145,8 +145,8 @@ Module ListDict (E: ELEM). Definition add (e : elt) (s : T) := cons elt e s. Fixpoint find (e : elt) (s : T) {struct s} : bool := match s with - | nil => false - | cons e' s' => ifte (E.eq_dec e e') true (find e s') + | nil _ => false + | cons _ e' s' => ifte (E.eq_dec e e') true (find e s') end. Definition find_empty_false (e : elt) := refl_equal false. diff --git a/test-suite/output/Arguments.out b/test-suite/output/Arguments.out index 7c9b1e27..629a1ab6 100644 --- a/test-suite/output/Arguments.out +++ b/test-suite/output/Arguments.out @@ -1,94 +1,110 @@ -minus : nat -> nat -> nat +Nat.sub : nat -> nat -> nat +Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] -The simpl tactic unfolds minus avoiding to expose match constructs -minus is transparent -Expands to: Constant Coq.Init.Peano.minus -minus : nat -> nat -> nat +The reduction tactics unfold Nat.sub but avoid exposing match constructs +Nat.sub is transparent +Expands to: Constant Coq.Init.Nat.sub +Nat.sub : nat -> nat -> nat +Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] -The simpl tactic unfolds minus when applied to 1 argument - avoiding to expose match constructs -minus is transparent -Expands to: Constant Coq.Init.Peano.minus -minus : nat -> nat -> nat +The reduction tactics unfold Nat.sub when applied to 1 argument + but avoid exposing match constructs +Nat.sub is transparent +Expands to: Constant Coq.Init.Nat.sub +Nat.sub : nat -> nat -> nat +Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] -The simpl tactic unfolds minus +The reduction tactics unfold Nat.sub when the 1st argument evaluates to a constructor and - when applied to 1 argument avoiding to expose match constructs -minus is transparent -Expands to: Constant Coq.Init.Peano.minus -minus : nat -> nat -> nat + when applied to 1 argument but avoid exposing match constructs +Nat.sub is transparent +Expands to: Constant Coq.Init.Nat.sub +Nat.sub : nat -> nat -> nat +Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] -The simpl tactic unfolds minus - when the 1st and 2nd arguments evaluate to a constructor and - when applied to 2 arguments -minus is transparent -Expands to: Constant Coq.Init.Peano.minus -minus : nat -> nat -> nat +The reduction tactics unfold Nat.sub when the 1st and + 2nd arguments evaluate to a constructor and when applied to 2 arguments +Nat.sub is transparent +Expands to: Constant Coq.Init.Nat.sub +Nat.sub : nat -> nat -> nat +Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] -The simpl tactic unfolds minus - when the 1st and 2nd arguments evaluate to a constructor -minus is transparent -Expands to: Constant Coq.Init.Peano.minus +The reduction tactics unfold Nat.sub when the 1st and + 2nd arguments evaluate to a constructor +Nat.sub is transparent +Expands to: Constant Coq.Init.Nat.sub pf : forall D1 C1 : Type, (D1 -> C1) -> forall D2 C2 : Type, (D2 -> C2) -> D1 * D2 -> C1 * C2 +pf is not universe polymorphic Arguments D2, C2 are implicit Arguments D1, C1 are implicit and maximally inserted Argument scopes are [foo_scope type_scope _ _ _ _ _] -The simpl tactic never unfolds pf +The reduction tactics never unfold pf pf is transparent Expands to: Constant Top.pf fcomp : forall A B C : Type, (B -> C) -> (A -> B) -> A -> C +fcomp is not universe polymorphic Arguments A, B, C are implicit and maximally inserted Argument scopes are [type_scope type_scope type_scope _ _ _] -The simpl tactic unfolds fcomp when applied to 6 arguments +The reduction tactics unfold fcomp when applied to 6 arguments fcomp is transparent Expands to: Constant Top.fcomp volatile : nat -> nat +volatile is not universe polymorphic Argument scope is [nat_scope] -The simpl tactic always unfolds volatile +The reduction tactics always unfold volatile volatile is transparent Expands to: Constant Top.volatile f : T1 -> T2 -> nat -> unit -> nat -> nat +f is not universe polymorphic Argument scopes are [_ _ nat_scope _ nat_scope] f is transparent Expands to: Constant Top.S1.S2.f f : T1 -> T2 -> nat -> unit -> nat -> nat +f is not universe polymorphic Argument scopes are [_ _ nat_scope _ nat_scope] -The simpl tactic unfolds f - when the 3rd, 4th and 5th arguments evaluate to a constructor +The reduction tactics unfold f when the 3rd, 4th and + 5th arguments evaluate to a constructor f is transparent Expands to: Constant Top.S1.S2.f f : forall T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat +f is not universe polymorphic Argument T2 is implicit Argument scopes are [type_scope _ _ nat_scope _ nat_scope] -The simpl tactic unfolds f - when the 4th, 5th and 6th arguments evaluate to a constructor +The reduction tactics unfold f when the 4th, 5th and + 6th arguments evaluate to a constructor f is transparent Expands to: Constant Top.S1.f f : forall T1 T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat +f is not universe polymorphic Arguments T1, T2 are implicit Argument scopes are [type_scope type_scope _ _ nat_scope _ nat_scope] -The simpl tactic unfolds f - when the 5th, 6th and 7th arguments evaluate to a constructor +The reduction tactics unfold f when the 5th, 6th and + 7th arguments evaluate to a constructor f is transparent Expands to: Constant Top.f + = forall v : unit, f 0 0 5 v 3 = 2 + : Prop + = 2 = 2 + : Prop f : forall T1 T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat -The simpl tactic unfolds f - when the 5th, 6th and 7th arguments evaluate to a constructor +f is not universe polymorphic +The reduction tactics unfold f when the 5th, 6th and + 7th arguments evaluate to a constructor f is transparent Expands to: Constant Top.f forall w : r, w 3 true = tt diff --git a/test-suite/output/Arguments.v b/test-suite/output/Arguments.v index 573cfdab..05eeaac6 100644 --- a/test-suite/output/Arguments.v +++ b/test-suite/output/Arguments.v @@ -1,13 +1,13 @@ -Arguments minus n m : simpl nomatch. -About minus. -Arguments minus n / m : simpl nomatch. -About minus. -Arguments minus !n / m : simpl nomatch. -About minus. -Arguments minus !n !m /. -About minus. -Arguments minus !n !m. -About minus. +Arguments Nat.sub n m : simpl nomatch. +About Nat.sub. +Arguments Nat.sub n / m : simpl nomatch. +About Nat.sub. +Arguments Nat.sub !n / m : simpl nomatch. +About Nat.sub. +Arguments Nat.sub !n !m /. +About Nat.sub. +Arguments Nat.sub !n !m. +About Nat.sub. Definition pf (D1 C1 : Type) (f : D1 -> C1) (D2 C2 : Type) (g : D2 -> C2) := fun x => (f (fst x), g (snd x)). Delimit Scope foo_scope with F. @@ -36,13 +36,15 @@ End S2. About f. End S1. About f. +Eval cbn in forall v, f 0 0 5 v 3 = 2. +Eval cbn in f 0 0 5 tt 3 = 2. Arguments f : clear implicits and scopes. About f. Record r := { pi :> nat -> bool -> unit }. Notation "$" := 3 (only parsing) : foo_scope. Notation "$" := true (only parsing) : bar_scope. Delimit Scope bar_scope with B. -Arguments pi _ _%F _%B. +Arguments pi _ _%F _%B. Check (forall w : r, pi w $ $ = tt). Fail Check (forall w : r, w $ $ = tt). Axiom w : r. diff --git a/test-suite/output/ArgumentsScope.out b/test-suite/output/ArgumentsScope.out index 756e8ede..71d5fc78 100644 --- a/test-suite/output/ArgumentsScope.out +++ b/test-suite/output/ArgumentsScope.out @@ -1,61 +1,70 @@ a : bool -> bool +a is not universe polymorphic Argument scope is [bool_scope] Expands to: Variable a b : bool -> bool +b is not universe polymorphic Argument scope is [bool_scope] Expands to: Variable b negb'' : bool -> bool +negb'' is not universe polymorphic Argument scope is [bool_scope] negb'' is transparent Expands to: Constant Top.A.B.negb'' negb' : bool -> bool +negb' is not universe polymorphic Argument scope is [bool_scope] negb' is transparent Expands to: Constant Top.A.negb' negb : bool -> bool +negb is not universe polymorphic Argument scope is [bool_scope] negb is transparent Expands to: Constant Coq.Init.Datatypes.negb -Warning: Arguments Scope is deprecated; use Arguments instead -Warning: Arguments Scope is deprecated; use Arguments instead -Warning: Arguments Scope is deprecated; use Arguments instead -Warning: Arguments Scope is deprecated; use Arguments instead -Warning: Arguments Scope is deprecated; use Arguments instead a : bool -> bool +a is not universe polymorphic Expands to: Variable a b : bool -> bool +b is not universe polymorphic Expands to: Variable b negb : bool -> bool +negb is not universe polymorphic negb is transparent Expands to: Constant Coq.Init.Datatypes.negb negb' : bool -> bool +negb' is not universe polymorphic negb' is transparent Expands to: Constant Top.A.negb' negb'' : bool -> bool +negb'' is not universe polymorphic negb'' is transparent Expands to: Constant Top.A.B.negb'' a : bool -> bool +a is not universe polymorphic Expands to: Variable a negb : bool -> bool +negb is not universe polymorphic negb is transparent Expands to: Constant Coq.Init.Datatypes.negb negb' : bool -> bool +negb' is not universe polymorphic negb' is transparent Expands to: Constant Top.negb' negb'' : bool -> bool +negb'' is not universe polymorphic negb'' is transparent Expands to: Constant Top.negb'' diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index 17c80d13..c29f5649 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -6,7 +6,7 @@ The command has indeed failed with message: Argument A renamed to T. @eq_refl : forall (B : Type) (y : B), y = y -eq_refl +@eq_refl nat : forall x : nat, x = x Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x @@ -20,6 +20,7 @@ For eq: Argument scopes are [type_scope _ _] For eq_refl: Argument scopes are [type_scope _] eq_refl : forall (A : Type) (x : A), x = x +eq_refl is not universe polymorphic Arguments are renamed to B, y When applied to no arguments: Arguments B, y are implicit and maximally inserted @@ -35,6 +36,7 @@ For myEq: Argument scopes are [type_scope _ _] For myrefl: Argument scopes are [type_scope _ _] myrefl : forall (B : Type) (x : A), B -> myEq B x x +myrefl is not universe polymorphic Arguments are renamed to C, x, _ Argument C is implicit and maximally inserted Argument scopes are [type_scope _ _] @@ -47,19 +49,21 @@ fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := end : forall T : Type, T -> nat -> nat -> nat +myplus is not universe polymorphic Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] myplus : forall T : Type, T -> nat -> nat -> nat +myplus is not universe polymorphic Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] -The simpl tactic unfolds myplus - when the 2nd and 3rd arguments evaluate to a constructor +The reduction tactics unfold myplus when the 2nd and + 3rd arguments evaluate to a constructor myplus is transparent Expands to: Constant Top.Test1.myplus -myplus +@myplus : forall Z : Type, Z -> nat -> nat -> nat Inductive myEq (A B : Type) (x : A) : A -> Prop := myrefl : B -> myEq A B x x @@ -70,6 +74,7 @@ For myEq: Argument scopes are [type_scope type_scope _ _] For myrefl: Argument scopes are [type_scope type_scope _ _] myrefl : forall (A B : Type) (x : A), B -> myEq A B x x +myrefl is not universe polymorphic Arguments are renamed to A, C, x, _ Argument C is implicit and maximally inserted Argument scopes are [type_scope type_scope _ _] @@ -84,19 +89,21 @@ fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := end : forall T : Type, T -> nat -> nat -> nat +myplus is not universe polymorphic Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] myplus : forall T : Type, T -> nat -> nat -> nat +myplus is not universe polymorphic Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] -The simpl tactic unfolds myplus - when the 2nd and 3rd arguments evaluate to a constructor +The reduction tactics unfold myplus when the 2nd and + 3rd arguments evaluate to a constructor myplus is transparent Expands to: Constant Top.myplus -myplus +@myplus : forall Z : Type, Z -> nat -> nat -> nat The command has indeed failed with message: => Error: All arguments lists must declare the same names. diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index 1ec02c56..d5903483 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -2,13 +2,23 @@ t_rect = fun (P : t -> Type) (f : let x := t in forall x0 : x, P x0 -> P (k x0)) => fix F (t : t) : P t := match t as t0 return (P t0) with - | k _ x0 => f x0 (F x0) + | @k _ x0 => f x0 (F x0) end : forall P : t -> Type, (let x := t in forall x0 : x, P x0 -> P (k x0)) -> forall t : t, P t + +t_rect is not universe polymorphic + = fun d : TT => match d with + | @CTT _ _ b => b + end + : TT -> 0 = 0 + = fun d : TT => match d with + | @CTT _ _ b => b + end + : TT -> 0 = 0 proj = fun (x y : nat) (P : nat -> Type) (def : P x) (prf : P y) => -match eq_nat_dec x y with +match Nat.eq_dec x y with | left eqprf => match eqprf in (_ = z) return (P z) with | eq_refl => def end @@ -16,6 +26,7 @@ match eq_nat_dec x y with end : forall (x y : nat) (P : nat -> Type), P x -> P y -> P y +proj is not universe polymorphic Argument scopes are [nat_scope nat_scope _ _ _] foo = fix foo (A : Type) (l : list A) {struct l} : option A := @@ -26,6 +37,29 @@ fix foo (A : Type) (l : list A) {struct l} : option A := end : forall A : Type, list A -> option A +foo is not universe polymorphic Argument scopes are [type_scope list_scope] +uncast = +fun (A : Type) (x : I A) => match x with + | x0 <: _ => x0 + end + : forall A : Type, I A -> A + +uncast is not universe polymorphic +Argument scopes are [type_scope _] foo' = if A 0 then true else false : bool + +foo' is not universe polymorphic +f = +fun H : B => +match H with +| AC x => + (let b0 := b in + if b0 as b return (P b -> True) + then fun _ : P true => Logic.I + else fun _ : P false => Logic.I) x +end + : B -> True + +f is not universe polymorphic diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index b6337586..4116a5eb 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -5,6 +5,11 @@ Inductive t : Set := Print t_rect. +Record TT : Type := CTT { f1 := 0 : nat; f2: nat; f3 : f1=f1 }. + +Eval cbv in fun d:TT => match d return 0 = 0 with CTT a _ b => b end. +Eval lazy in fun d:TT => match d return 0 = 0 with CTT a _ b => b end. + (* Do not contract nested patterns with dependent return type *) (* see bug #1699 *) @@ -34,6 +39,18 @@ Fixpoint foo (A:Type) (l:list A) : option A := Print foo. +(* Accept and use notation with binded parameters *) + +Inductive I (A: Type) : Type := C : A -> I A. +Notation "x <: T" := (C T x) (at level 38). + +Definition uncast A (x : I A) := +match x with + | x <: _ => x +end. + +Print uncast. + (* Do not duplicate the matched term *) Axiom A : nat -> bool. @@ -46,3 +63,17 @@ Definition foo' := Print foo'. +(* Was bug #3293 (eta-expansion at "match" printing time was failing because + of let-in's interpreted as being part of the expansion) *) + +Variable b : bool. +Variable P : bool -> Prop. +Inductive B : Prop := AC : P b -> B. +Definition f : B -> True. + +Proof. +intros []. +destruct b as [|] ; intros _ ; exact Logic.I. +Defined. + +Print f. diff --git a/test-suite/output/Errors.out b/test-suite/output/Errors.out index f61b7ecf..bcc37b63 100644 --- a/test-suite/output/Errors.out +++ b/test-suite/output/Errors.out @@ -1,2 +1,7 @@ The command has indeed failed with message: => Error: The field t is missing in Top.M. +The command has indeed failed with message: +=> Error: Unable to unify "nat" with "True". +The command has indeed failed with message: +=> In nested Ltac calls to "f" and "apply x", last call failed. +Error: Unable to unify "nat" with "True". diff --git a/test-suite/output/Errors.v b/test-suite/output/Errors.v index 75763f3b..352c8738 100644 --- a/test-suite/output/Errors.v +++ b/test-suite/output/Errors.v @@ -7,3 +7,12 @@ Parameter t:Type. End S. Module M : S. Fail End M. + +(* A simple check of how Ltac trace are used or not *) +(* Unfortunately, cannot test error location... *) + +Ltac f x := apply x. +Goal True. +Fail simpl; apply 0. +Fail simpl; f 0. +Abort. diff --git a/test-suite/output/Existentials.out b/test-suite/output/Existentials.out index 2f756cbb..483a9ea7 100644 --- a/test-suite/output/Existentials.out +++ b/test-suite/output/Existentials.out @@ -1,3 +1,5 @@ -Existential 1 = ?10 : [q : nat n : nat m : nat |- n = ?9] -Existential 2 = ?9 : [n : nat m : nat |- nat] -Existential 3 = ?7 : [p : nat q := S p : nat n : nat m : nat |- ?9 = m] +Existential 1 = +?Goal0 : [p : nat q := S p : nat n : nat m : nat |- ?y = m] +Existential 2 = +?y : [p : nat q := S p : nat n : nat m : nat |- nat] (p, q cannot be used) +Existential 3 = ?e : [q : nat n : nat m : nat |- n = ?y] diff --git a/test-suite/output/Extraction_matchs_2413.v b/test-suite/output/Extraction_matchs_2413.v index f5610efc..6c514b16 100644 --- a/test-suite/output/Extraction_matchs_2413.v +++ b/test-suite/output/Extraction_matchs_2413.v @@ -22,8 +22,8 @@ Inductive hole (A:Set) : Set := Hole | Hole2. Definition wrong_id (A B : Set) (x:hole A) : hole B := match x with - | Hole => @Hole _ - | Hole2 => @Hole2 _ + | Hole _ => @Hole _ + | Hole2 _ => @Hole2 _ end. Extraction wrong_id. (** should _not_ be optimized as an identity *) @@ -114,9 +114,9 @@ Definition decode_cond_mode (mode : Type) (f : word -> decoder_result mode) | Some oc => match f w with | DecInst i => DecInst (g i oc) - | DecError m => @DecError inst m - | DecUndefined => @DecUndefined inst - | DecUnpredictable => @DecUnpredictable inst + | DecError _ m => @DecError inst m + | DecUndefined _ => @DecUndefined inst + | DecUnpredictable _ => @DecUnpredictable inst end | None => @DecUndefined inst end. diff --git a/test-suite/output/Implicit.out b/test-suite/output/Implicit.out index 3b65003c..0b0f501f 100644 --- a/test-suite/output/Implicit.out +++ b/test-suite/output/Implicit.out @@ -5,6 +5,7 @@ ex_intro (P:=fun _ : nat => True) (x:=0) I d2 = fun x : nat => d1 (y:=x) : forall x x0 : nat, x0 = x -> x0 = x +d2 is not universe polymorphic Arguments x, x0 are implicit Argument scopes are [nat_scope nat_scope _] map id (1 :: nil) diff --git a/test-suite/output/InitSyntax.out b/test-suite/output/InitSyntax.out index 55017469..bbfd3405 100644 --- a/test-suite/output/InitSyntax.out +++ b/test-suite/output/InitSyntax.out @@ -1,5 +1,5 @@ Inductive sig2 (A : Type) (P Q : A -> Prop) : Type := - exist2 : forall x : A, P x -> Q x -> {x | P x & Q x} + exist2 : forall x : A, P x -> Q x -> {x : A | P x & Q x} For sig2: Argument A is implicit For exist2: Argument A is implicit diff --git a/test-suite/output/Intuition.out b/test-suite/output/Intuition.out index 5831c9f4..e99d9fde 100644 --- a/test-suite/output/Intuition.out +++ b/test-suite/output/Intuition.out @@ -1,7 +1,6 @@ 1 subgoal - m : Z - n : Z + m, n : Z H : (m >= n)%Z ============================ (m >= m)%Z diff --git a/test-suite/output/Match_subterm.out b/test-suite/output/Match_subterm.out index 951a98db..c99c8905 100644 --- a/test-suite/output/Match_subterm.out +++ b/test-suite/output/Match_subterm.out @@ -1,5 +1,7 @@ (0 = 1) +(eq 0) eq +@eq nat 0 1 diff --git a/test-suite/output/Nametab.out b/test-suite/output/Nametab.out index b1883ec0..c11621d7 100644 --- a/test-suite/output/Nametab.out +++ b/test-suite/output/Nametab.out @@ -7,15 +7,15 @@ Constant Top.Q.N.K.foo Constant Top.Q.N.K.foo Constant Top.Q.N.K.foo (shorter name to refer to it in current context is Q.N.K.foo) -No module is referred to by basename K -No module is referred to by name N.K +Module Top.Q.N.K (shorter name to refer to it in current context is Q.N.K) +Module Top.Q.N.K (shorter name to refer to it in current context is Q.N.K) Module Top.Q.N.K -Module Top.Q.N.K -No module is referred to by basename N -Module Top.Q.N +Module Top.Q.N.K (shorter name to refer to it in current context is Q.N.K) +Module Top.Q.N (shorter name to refer to it in current context is Q.N) Module Top.Q.N +Module Top.Q.N (shorter name to refer to it in current context is Q.N) Module Top.Q -Module Top.Q +Module Top.Q (shorter name to refer to it in current context is Q) Constant Top.Q.N.K.foo (shorter name to refer to it in current context is K.foo) Constant Top.Q.N.K.foo @@ -26,11 +26,11 @@ Constant Top.Q.N.K.foo Constant Top.Q.N.K.foo (shorter name to refer to it in current context is K.foo) Module Top.Q.N.K -No module is referred to by name N.K -Module Top.Q.N.K -Module Top.Q.N.K -No module is referred to by basename N -Module Top.Q.N +Module Top.Q.N.K (shorter name to refer to it in current context is K) +Module Top.Q.N.K (shorter name to refer to it in current context is K) +Module Top.Q.N.K (shorter name to refer to it in current context is K) +Module Top.Q.N (shorter name to refer to it in current context is Q.N) Module Top.Q.N +Module Top.Q.N (shorter name to refer to it in current context is Q.N) Module Top.Q -Module Top.Q +Module Top.Q (shorter name to refer to it in current context is Q) diff --git a/test-suite/output/Naming.out b/test-suite/output/Naming.out index df510063..f0d2562e 100644 --- a/test-suite/output/Naming.out +++ b/test-suite/output/Naming.out @@ -6,12 +6,8 @@ (forall x2 x5 : nat, x2 + x1 = x4 + x5) -> x + x1 = x4 + x0 1 subgoal - x3 : nat - x : nat - x1 : nat - x4 : nat - x0 : nat - H : forall x5 x6 : nat, x5 + x1 = x4 + x6 + x3, x, x1, x4, x0 : nat + H : forall x x3 : nat, x + x1 = x4 + x3 ============================ x + x1 = x4 + x0 1 subgoal @@ -33,11 +29,7 @@ forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x 1 subgoal - x3 : nat - x : nat - x1 : nat - x4 : nat - x0 : nat + x3, x, x1, x4, x0 : nat ============================ (forall x2 x5 : nat, x2 + x1 = x4 + x5 -> @@ -46,38 +38,26 @@ forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x 1 subgoal - x3 : nat - x : nat - x1 : nat - x4 : nat - x0 : nat - H : forall x5 x6 : nat, - x5 + x1 = x4 + x6 -> - forall x7 x8 x9 S : nat, x7 + S = x8 + x9 + (Datatypes.S x5 + x1) + x3, x, x1, x4, x0 : nat + H : forall x x3 : nat, + x + x1 = x4 + x3 -> + forall x0 x4 x5 S0 : nat, x0 + S0 = x4 + x5 + (S x + x1) H0 : x + x1 = x4 + x0 ============================ forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x 1 subgoal - x3 : nat - x : nat - x1 : nat - x4 : nat - x0 : nat - H : forall x5 x6 : nat, - x5 + x1 = x4 + x6 -> - forall x7 x8 x9 S : nat, x7 + S = x8 + x9 + (Datatypes.S x5 + x1) + x3, x, x1, x4, x0 : nat + H : forall x x3 : nat, + x + x1 = x4 + x3 -> + forall x0 x4 x5 S0 : nat, x0 + S0 = x4 + x5 + (Datatypes.S x + x1) H0 : x + x1 = x4 + x0 - x5 : nat - x6 : nat - x7 : nat - S : nat + x5, x6, x7, S : nat ============================ x5 + S = x6 + x7 + Datatypes.S x 1 subgoal - x3 : nat - a : nat - H : a = 0 -> forall a0 : nat, a0 = 0 + x3, a : nat + H : a = 0 -> forall a : nat, a = 0 ============================ a = 0 diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out index 66307236..60ee72b3 100644 --- a/test-suite/output/Notations.out +++ b/test-suite/output/Notations.out @@ -2,23 +2,21 @@ true ? 0; 1 : nat if true as x return (x ? nat; bool) then 0 else true : nat -Identifier 'proj1' now a keyword fun e : nat * nat => proj1 e : nat * nat -> nat -Identifier 'decomp' now a keyword decomp (true, true) as t, u in (t, u) : bool * bool -!(0 = 0) +! (0 = 0) : Prop forall n : nat, n = 0 : Prop -!(0 = 0) +! (0 = 0) : Prop -forall n : nat, #(n = n) +forall n : nat, # (n = n) : Prop -forall n n0 : nat, ##(n = n0) +forall n n0 : nat, ## (n = n0) : Prop -forall n n0 : nat, ###(n = n0) +forall n n0 : nat, ### (n = n0) : Prop 3 + 3 : Z @@ -28,21 +26,17 @@ forall n n0 : nat, ###(n = n0) : list nat (1; 2, 4) : nat * nat * nat -Identifier 'ifzero' now a keyword ifzero 3 : bool -Identifier 'pred' now a keyword pred 3 : nat fun n : nat => pred n : nat -> nat fun n : nat => pred n : nat -> nat -Identifier 'ifn' now a keyword -Identifier 'is' now a keyword fun x : nat => ifn x is succ n then n else 0 : nat -> nat -1- +1 - : bool -4 : Z @@ -50,14 +44,12 @@ The command has indeed failed with message: => Error: x should not be bound in a recursive pattern of the right-hand side. The command has indeed failed with message: => Error: in the right-hand side, y and z should appear in - term position as part of a recursive pattern. +term position as part of a recursive pattern. The command has indeed failed with message: => Error: The reference w was not found in the current environment. The command has indeed failed with message: -=> Error: x is unbound in the right-hand side. -The command has indeed failed with message: => Error: in the right-hand side, y and z should appear in - term position as part of a recursive pattern. +term position as part of a recursive pattern. The command has indeed failed with message: => Error: z is expected to occur in binding position in the right-hand side. The command has indeed failed with message: @@ -80,7 +72,6 @@ Nil : forall A : Type, list A NIL:list nat : list nat -Identifier 'I' now a keyword (false && I 3)%bool /\ I 6 : Prop [|1, 2, 3; 4, 5, 6|] @@ -89,11 +80,11 @@ Identifier 'I' now a keyword : Z * Z * (Z * Z) * (Z * Z) * (Z * bool * (Z * bool) * (Z * bool)) fun f : Z -> Z -> Z -> Z => {|f; 0; 1; 2|}:Z : (Z -> Z -> Z -> Z) -> Z -plus +Init.Nat.add : nat -> nat -> nat S : nat -> nat -mult +Init.Nat.mul : nat -> nat -> nat le : nat -> nat -> Prop @@ -101,7 +92,7 @@ plus : nat -> nat -> nat succ : nat -> nat -mult +Init.Nat.mul : nat -> nat -> nat le : nat -> nat -> Prop @@ -116,18 +107,24 @@ fun x : option Z => match x with end : option Z -> Z fun x : option Z => match x with - | SOME3 x0 => x0 - | NONE3 => 0 + | SOME2 x0 => x0 + | NONE2 => 0 end : option Z -> Z +fun x : list ?T1 => match x with + | NIL => NONE2 + | (_ :') t => SOME2 t + end + : list ?T1 -> option (list ?T1) +where +?T1 : [x : list ?T1 x1 : list ?T1 x0 := x1 : list ?T1 |- Type] (x, x1, + x0 cannot be used) s : s -Identifier 'foo' now a keyword 10 : nat fun _ : nat => 9 : nat -> nat -Identifier 'ONE' now a keyword fun (x : nat) (p : x = x) => match p with | ONE => ONE end = p diff --git a/test-suite/output/Notations.v b/test-suite/output/Notations.v index 612b5325..adba688e 100644 --- a/test-suite/output/Notations.v +++ b/test-suite/output/Notations.v @@ -68,7 +68,7 @@ Coercion Zpos: nat >-> znat. Delimit Scope znat_scope with znat. Open Scope znat_scope. -Variable addz : znat -> znat -> znat. +Parameter addz : znat -> znat -> znat. Notation "z1 + z2" := (addz z1 z2) : znat_scope. (* Check that "3+3", where 3 is in nat and the coercion to znat is implicit, @@ -133,7 +133,8 @@ Fail Notation "( x , y , .. , z )" := (pair x (pair y z)). Fail Notation "( x , y , .. , z )" := (pair x .. (pair y w) ..). (* Right-unbound variable *) -Fail Notation "( x , y , .. , z )" := (pair y .. (pair z 0) ..). +(* Now allowed with an only parsing restriction *) +Notation "( x , y , .. , z )" := (pair y .. (pair z 0) ..). (* Not the right kind of recursive pattern *) Fail Notation "( x , y , .. , z )" := (ex (fun z => .. (ex (fun y => x)) ..)). @@ -244,7 +245,11 @@ Check (fun x => match x with SOME2 x => x | NONE2 => 0 end). Notation NONE3 := @None. Notation SOME3 := @Some. -Check (fun x => match x with SOME3 x => x | NONE3 => 0 end). +Check (fun x => match x with SOME3 _ x => x | NONE3 _ => 0 end). + +Notation "a :'" := (cons a) (at level 12). + +Check (fun x => match x with | nil => NONE | h :' t => SOME3 _ t end). (* Check correct matching of "Type" in notations. Of course the notation denotes a term that will be reinterpreted with a different @@ -275,3 +280,4 @@ Check fun (x:nat) (p : x=x) => match p with ONE => ONE end = p. Notation "1" := eq_refl. Check fun (x:nat) (p : x=x) => match p with 1 => 1 end = p. + diff --git a/test-suite/output/Notations2.out b/test-suite/output/Notations2.out index cf45025e..58ec1de5 100644 --- a/test-suite/output/Notations2.out +++ b/test-suite/output/Notations2.out @@ -1,6 +1,6 @@ 2 3 : PAIR -2[+]3 +2 [+] 3 : nat forall (A : Set) (le : A -> A -> Prop) (x y : A), le x y \/ le y x : Prop @@ -10,7 +10,7 @@ end : nat let '(a, _, _) := (2, 3, 4) in a : nat -exists myx (y : bool), myx = y +exists myx y : bool, myx = y : Prop fun (P : nat -> nat -> Prop) (x : nat) => exists x0, P x x0 : (nat -> nat -> Prop) -> nat -> Prop @@ -24,7 +24,6 @@ let d := 2 in ∃ z : nat, let e := 3 in let f := 4 in x + y = z + d : Prop ∀ n p : nat, n + p = 0 : Prop -Identifier 'λ' now a keyword λ n p : nat, n + p = 0 : nat -> nat -> Prop λ (A : Type) (n p : A), n = p @@ -33,12 +32,11 @@ Identifier 'λ' now a keyword : Type -> Prop λ A : Type, ∀ n p : A, n = p : Type -> Prop -Identifier 'let'' now a keyword let' f (x y : nat) (a:=0) (z : nat) (_ : bool) := x + y + z + 1 in f 0 1 2 : bool -> nat λ (f : nat -> nat) (x : nat), f(x) + S(x) : (nat -> nat) -> nat -> nat -Notation plus2 n := (S (S n)) +Notation plus2 n := (S(S(n))) λ n : list(nat), match n with | nil => 2 diff --git a/test-suite/output/PrintAssumptions.out b/test-suite/output/PrintAssumptions.out index 23f33081..08df9150 100644 --- a/test-suite/output/PrintAssumptions.out +++ b/test-suite/output/PrintAssumptions.out @@ -2,6 +2,11 @@ Axioms: foo : nat Axioms: foo : nat +Fetching opaque proofs from disk for Coq.Numbers.NatInt.NZAdd +Fetching opaque proofs from disk for Coq.Arith.PeanoNat +Fetching opaque proofs from disk for Coq.Classes.Morphisms +Fetching opaque proofs from disk for Coq.Init.Logic +Fetching opaque proofs from disk for Coq.Numbers.NatInt.NZBase Axioms: extensionality : forall (P Q : Type) (f g : P -> Q), (forall x : P, f x = g x) -> f = g diff --git a/test-suite/output/PrintInfos.out b/test-suite/output/PrintInfos.out index 598bb728..0457c860 100644 --- a/test-suite/output/PrintInfos.out +++ b/test-suite/output/PrintInfos.out @@ -1,16 +1,17 @@ -existT : forall (A : Type) (P : A -> Type) (x : A), P x -> sigT P +existT : forall (A : Type) (P : A -> Type) (x : A), P x -> {x : A & P x} +existT is template universe polymorphic Argument A is implicit Argument scopes are [type_scope _ _ _] Expands to: Constructor Coq.Init.Specif.existT Inductive sigT (A : Type) (P : A -> Type) : Type := - existT : forall x : A, P x -> sigT P + existT : forall x : A, P x -> {x : A & P x} For sigT: Argument A is implicit For existT: Argument A is implicit For sigT: Argument scopes are [type_scope type_scope] For existT: Argument scopes are [type_scope _ _ _] -existT : forall (A : Type) (P : A -> Type) (x : A), P x -> sigT P +existT : forall (A : Type) (P : A -> Type) (x : A), P x -> {x : A & P x} Argument A is implicit Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x @@ -24,6 +25,7 @@ For eq: Argument scopes are [type_scope _ _] For eq_refl: Argument scopes are [type_scope _] eq_refl : forall (A : Type) (x : A), x = x +eq_refl is not universe polymorphic When applied to no arguments: Arguments A, x are implicit and maximally inserted When applied to 1 argument: @@ -36,28 +38,30 @@ When applied to no arguments: Arguments A, x are implicit and maximally inserted When applied to 1 argument: Argument A is implicit -plus = -fix plus (n m : nat) {struct n} : nat := +Nat.add = +fix add (n m : nat) {struct n} : nat := match n with | 0 => m - | S p => S (plus p m) + | S p => S (add p m) end : nat -> nat -> nat +Nat.add is not universe polymorphic Argument scopes are [nat_scope nat_scope] -plus : nat -> nat -> nat +Nat.add : nat -> nat -> nat +Nat.add is not universe polymorphic Argument scopes are [nat_scope nat_scope] -plus is transparent -Expands to: Constant Coq.Init.Peano.plus -plus : nat -> nat -> nat +Nat.add is transparent +Expands to: Constant Coq.Init.Nat.add +Nat.add : nat -> nat -> nat plus_n_O : forall n : nat, n = n + 0 +plus_n_O is not universe polymorphic Argument scope is [nat_scope] plus_n_O is opaque Expands to: Constant Coq.Init.Peano.plus_n_O -Warning: Implicit Arguments is deprecated; use Arguments instead Inductive le (n : nat) : nat -> Prop := le_n : n <= n | le_S : forall m : nat, n <= m -> n <= S m @@ -76,12 +80,13 @@ For le_n: Argument scope is [nat_scope] For le_S: Argument scopes are [nat_scope nat_scope _] comparison : Set +comparison is not universe polymorphic Expands to: Inductive Coq.Init.Datatypes.comparison Inductive comparison : Set := Eq : comparison | Lt : comparison | Gt : comparison -Warning: Implicit Arguments is deprecated; use Arguments instead bar : foo +bar is not universe polymorphic Expanded type for implicit arguments bar : forall x : nat, x = 0 @@ -89,12 +94,14 @@ Argument x is implicit and maximally inserted Expands to: Constant Top.bar *** [ bar : foo ] +bar is not universe polymorphic Expanded type for implicit arguments bar : forall x : nat, x = 0 Argument x is implicit and maximally inserted bar : foo +bar is not universe polymorphic Expanded type for implicit arguments bar : forall x : nat, x = 0 @@ -102,6 +109,7 @@ Argument x is implicit and maximally inserted Expands to: Constant Top.bar *** [ bar : foo ] +bar is not universe polymorphic Expanded type for implicit arguments bar : forall x : nat, x = 0 @@ -109,7 +117,6 @@ Argument x is implicit and maximally inserted Module Coq.Init.Peano Notation existS2 := existT2 Expands to: Notation Coq.Init.Specif.existS2 -Warning: Implicit Arguments is deprecated; use Arguments instead Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x For eq: Argument A is implicit and maximally inserted @@ -128,3 +135,15 @@ For eq_refl, when applied to 1 argument: Argument A is implicit and maximally inserted For eq: Argument scopes are [type_scope _ _] For eq_refl: Argument scopes are [type_scope _] +n:nat + +Hypothesis of the goal context. +h:(n <> newdef n) + +Hypothesis of the goal context. +g:(nat -> nat) + +Constant (let in) of the goal context. +h:(n <> newdef n) + +Hypothesis of the goal context. diff --git a/test-suite/output/PrintInfos.v b/test-suite/output/PrintInfos.v index deeb1f65..3c623346 100644 --- a/test-suite/output/PrintInfos.v +++ b/test-suite/output/PrintInfos.v @@ -6,9 +6,9 @@ Print eq_refl. About eq_refl. Print Implicit eq_refl. -Print plus. -About plus. -Print Implicit plus. +Print Nat.add. +About Nat.add. +Print Implicit Nat.add. About plus_n_O. @@ -39,3 +39,19 @@ Print eq_refl. Arguments eq_refl {A} {x}, {A} x. (* Test new syntax *) Print eq_refl. + + +Definition newdef := fun x:nat => x. + +Goal forall n:nat, n <> newdef n -> newdef n <> n -> False. + intros n h h'. + About n. (* search hypothesis *) + About h. (* search hypothesis *) +Abort. + +Goal forall n:nat, let g := newdef in n <> newdef n -> newdef n <> n -> False. + intros n g h h'. + About g. (* search hypothesis *) + About h. (* search hypothesis *) +Abort. + diff --git a/test-suite/output/Search.out b/test-suite/output/Search.out index 5d8f98ed..c17b285b 100644 --- a/test-suite/output/Search.out +++ b/test-suite/output/Search.out @@ -1,24 +1,108 @@ -le_S: forall n m : nat, n <= m -> n <= S m le_n: forall n : nat, n <= n -le_pred: forall n m : nat, n <= m -> pred n <= pred m +le_S: forall n m : nat, n <= m -> n <= S m +le_ind: + forall (n : nat) (P : nat -> Prop), + P n -> + (forall m : nat, n <= m -> P m -> P (S m)) -> + forall n0 : nat, n <= n0 -> P n0 +le_pred: forall n m : nat, n <= m -> Nat.pred n <= Nat.pred m le_S_n: forall n m : nat, S n <= S m -> n <= m -false: bool +le_0_n: forall n : nat, 0 <= n +le_n_S: forall n m : nat, n <= m -> S n <= S m +max_l: forall n m : nat, m <= n -> Nat.max n m = n +max_r: forall n m : nat, n <= m -> Nat.max n m = m +min_l: forall n m : nat, n <= m -> Nat.min n m = n +min_r: forall n m : nat, m <= n -> Nat.min n m = m true: bool -xorb: bool -> bool -> bool +false: bool +bool_rect: forall P : bool -> Type, P true -> P false -> forall b : bool, P b +bool_ind: forall P : bool -> Prop, P true -> P false -> forall b : bool, P b +bool_rec: forall P : bool -> Set, P true -> P false -> forall b : bool, P b +andb: bool -> bool -> bool orb: bool -> bool -> bool -negb: bool -> bool implb: bool -> bool -> bool -andb: bool -> bool -> bool -pred_Sn: forall n : nat, n = pred (S n) -plus_n_Sm: forall n m : nat, S (n + m) = n + S m +xorb: bool -> bool -> bool +negb: bool -> bool +andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true +andb_true_intro: + forall b1 b2 : bool, b1 = true /\ b2 = true -> (b1 && b2)%bool = true +eq_true: bool -> Prop +eq_true_rect: + forall P : bool -> Type, P true -> forall b : bool, eq_true b -> P b +eq_true_ind: + forall P : bool -> Prop, P true -> forall b : bool, eq_true b -> P b +eq_true_rec: + forall P : bool -> Set, P true -> forall b : bool, eq_true b -> P b +is_true: bool -> Prop +eq_true_ind_r: + forall (P : bool -> Prop) (b : bool), P b -> eq_true b -> P true +eq_true_rec_r: + forall (P : bool -> Set) (b : bool), P b -> eq_true b -> P true +eq_true_rect_r: + forall (P : bool -> Type) (b : bool), P b -> eq_true b -> P true +BoolSpec: Prop -> Prop -> bool -> Prop +BoolSpec_ind: + forall (P Q : Prop) (P0 : bool -> Prop), + (P -> P0 true) -> + (Q -> P0 false) -> forall b : bool, BoolSpec P Q b -> P0 b +Nat.eqb: nat -> nat -> bool +Nat.leb: nat -> nat -> bool +Nat.ltb: nat -> nat -> bool +Nat.even: nat -> bool +Nat.odd: nat -> bool +Nat.testbit: nat -> nat -> bool +Nat.bitwise: (bool -> bool -> bool) -> nat -> nat -> nat -> nat +bool_choice: + forall (S : Set) (R1 R2 : S -> Prop), + (forall x : S, {R1 x} + {R2 x}) -> + {f : S -> bool | forall x : S, f x = true /\ R1 x \/ f x = false /\ R2 x} +eq_S: forall x y : nat, x = y -> S x = S y +f_equal_nat: forall (B : Type) (f : nat -> B) (x y : nat), x = y -> f x = f y +f_equal_pred: forall x y : nat, x = y -> Nat.pred x = Nat.pred y +pred_Sn: forall n : nat, n = Nat.pred (S n) +eq_add_S: forall n m : nat, S n = S m -> n = m +not_eq_S: forall n m : nat, n <> m -> S n <> S m +O_S: forall n : nat, 0 <> S n +n_Sn: forall n : nat, n <> S n +f_equal2_plus: + forall x1 y1 x2 y2 : nat, x1 = y1 -> x2 = y2 -> x1 + x2 = y1 + y2 +f_equal2_nat: + forall (B : Type) (f : nat -> nat -> B) (x1 y1 x2 y2 : nat), + x1 = y1 -> x2 = y2 -> f x1 x2 = f y1 y2 plus_n_O: forall n : nat, n = n + 0 -plus_Sn_m: forall n m : nat, S n + m = S (n + m) plus_O_n: forall n : nat, 0 + n = n -mult_n_Sm: forall n m : nat, n * m + n = n * S m +plus_n_Sm: forall n m : nat, S (n + m) = n + S m +plus_Sn_m: forall n m : nat, S n + m = S (n + m) +f_equal2_mult: + forall x1 y1 x2 y2 : nat, x1 = y1 -> x2 = y2 -> x1 * x2 = y1 * y2 mult_n_O: forall n : nat, 0 = n * 0 -min_r: forall n m : nat, m <= n -> min n m = m -min_l: forall n m : nat, n <= m -> min n m = n -max_r: forall n m : nat, n <= m -> max n m = m -max_l: forall n m : nat, m <= n -> max n m = n -eq_add_S: forall n m : nat, S n = S m -> n = m -eq_S: forall x y : nat, x = y -> S x = S y +mult_n_Sm: forall n m : nat, n * m + n = n * S m +max_l: forall n m : nat, m <= n -> Nat.max n m = n +max_r: forall n m : nat, n <= m -> Nat.max n m = m +min_l: forall n m : nat, n <= m -> Nat.min n m = n +min_r: forall n m : nat, m <= n -> Nat.min n m = m +andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true +andb_true_intro: + forall b1 b2 : bool, b1 = true /\ b2 = true -> (b1 && b2)%bool = true +bool_choice: + forall (S : Set) (R1 R2 : S -> Prop), + (forall x : S, {R1 x} + {R2 x}) -> + {f : S -> bool | forall x : S, f x = true /\ R1 x \/ f x = false /\ R2 x} +andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true +andb_true_intro: + forall b1 b2 : bool, b1 = true /\ b2 = true -> (b1 && b2)%bool = true +andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true +h': newdef n <> n +h: n <> newdef n +h': newdef n <> n +h: n <> newdef n +h: n <> newdef n +h: n <> newdef n +h': ~ P n +h: P n +h': ~ P n +h: P n +h': ~ P n +h: P n +h: P n +h: P n diff --git a/test-suite/output/Search.v b/test-suite/output/Search.v index f1489f22..2a0f0b40 100644 --- a/test-suite/output/Search.v +++ b/test-suite/output/Search.v @@ -3,3 +3,27 @@ Search le. (* app nodes *) Search bool. (* no apps *) Search (@eq nat). (* complex pattern *) +Search (@eq _ _ true). +Search (@eq _ _ _) true -false. (* andb_prop *) +Search (@eq _ _ _) true -false "prop" -"intro". (* andb_prop *) + +Definition newdef := fun x:nat => x. + +Goal forall n:nat, n <> newdef n -> newdef n <> n -> False. + intros n h h'. + Search n. (* search hypothesis *) + Search newdef. (* search hypothesis *) + Search ( _ <> newdef _). (* search hypothesis, pattern *) + Search ( _ <> newdef _) -"h'". (* search hypothesis, pattern *) +Abort. + +Goal forall n (P:nat -> Prop), P n -> ~P n -> False. + intros n P h h'. + Search P. (* search hypothesis also for patterns *) + Search (P _). (* search hypothesis also for patterns *) + Search (P n). (* search hypothesis also for patterns *) + Search (P _) -"h'". (* search hypothesis also for patterns *) + Search (P _) -not. (* search hypothesis also for patterns *) + +Abort. + diff --git a/test-suite/output/SearchHead.out b/test-suite/output/SearchHead.out new file mode 100644 index 00000000..0d5924ec --- /dev/null +++ b/test-suite/output/SearchHead.out @@ -0,0 +1,39 @@ +le_n: forall n : nat, n <= n +le_S: forall n m : nat, n <= m -> n <= S m +le_pred: forall n m : nat, n <= m -> Nat.pred n <= Nat.pred m +le_S_n: forall n m : nat, S n <= S m -> n <= m +le_0_n: forall n : nat, 0 <= n +le_n_S: forall n m : nat, n <= m -> S n <= S m +true: bool +false: bool +andb: bool -> bool -> bool +orb: bool -> bool -> bool +implb: bool -> bool -> bool +xorb: bool -> bool -> bool +negb: bool -> bool +Nat.eqb: nat -> nat -> bool +Nat.leb: nat -> nat -> bool +Nat.ltb: nat -> nat -> bool +Nat.even: nat -> bool +Nat.odd: nat -> bool +Nat.testbit: nat -> nat -> bool +eq_S: forall x y : nat, x = y -> S x = S y +f_equal_pred: forall x y : nat, x = y -> Nat.pred x = Nat.pred y +pred_Sn: forall n : nat, n = Nat.pred (S n) +eq_add_S: forall n m : nat, S n = S m -> n = m +f_equal2_plus: + forall x1 y1 x2 y2 : nat, x1 = y1 -> x2 = y2 -> x1 + x2 = y1 + y2 +plus_n_O: forall n : nat, n = n + 0 +plus_O_n: forall n : nat, 0 + n = n +plus_n_Sm: forall n m : nat, S (n + m) = n + S m +plus_Sn_m: forall n m : nat, S n + m = S (n + m) +f_equal2_mult: + forall x1 y1 x2 y2 : nat, x1 = y1 -> x2 = y2 -> x1 * x2 = y1 * y2 +mult_n_O: forall n : nat, 0 = n * 0 +mult_n_Sm: forall n m : nat, n * m + n = n * S m +max_l: forall n m : nat, m <= n -> Nat.max n m = n +max_r: forall n m : nat, n <= m -> Nat.max n m = m +min_l: forall n m : nat, n <= m -> Nat.min n m = n +min_r: forall n m : nat, m <= n -> Nat.min n m = m +h: newdef n +h: P n diff --git a/test-suite/output/SearchHead.v b/test-suite/output/SearchHead.v new file mode 100644 index 00000000..2ee8a0d1 --- /dev/null +++ b/test-suite/output/SearchHead.v @@ -0,0 +1,19 @@ +(* Some tests of the Search command *) + +SearchHead le. (* app nodes *) +SearchHead bool. (* no apps *) +SearchHead (@eq nat). (* complex pattern *) + +Definition newdef := fun x:nat => x = x. + +Goal forall n:nat, newdef n -> False. + intros n h. + SearchHead newdef. (* search hypothesis *) +Abort. + + +Goal forall n (P:nat -> Prop), P n -> False. + intros n P h. + SearchHead P. (* search hypothesis also for patterns *) +Abort. + diff --git a/test-suite/output/SearchPattern.out b/test-suite/output/SearchPattern.out index 9106a4e3..1eb7eca8 100644 --- a/test-suite/output/SearchPattern.out +++ b/test-suite/output/SearchPattern.out @@ -1,30 +1,83 @@ -false: bool true: bool -xorb: bool -> bool -> bool +false: bool +andb: bool -> bool -> bool orb: bool -> bool -> bool -negb: bool -> bool implb: bool -> bool -> bool -andb: bool -> bool -> bool -S: nat -> nat +xorb: bool -> bool -> bool +negb: bool -> bool +Nat.eqb: nat -> nat -> bool +Nat.leb: nat -> nat -> bool +Nat.ltb: nat -> nat -> bool +Nat.even: nat -> bool +Nat.odd: nat -> bool +Nat.testbit: nat -> nat -> bool O: nat -pred: nat -> nat -plus: nat -> nat -> nat -mult: nat -> nat -> nat -minus: nat -> nat -> nat -min: nat -> nat -> nat -max: nat -> nat -> nat +S: nat -> nat length: forall A : Type, list A -> nat +Nat.zero: nat +Nat.one: nat +Nat.two: nat +Nat.succ: nat -> nat +Nat.pred: nat -> nat +Nat.add: nat -> nat -> nat +Nat.double: nat -> nat +Nat.mul: nat -> nat -> nat +Nat.sub: nat -> nat -> nat +Nat.max: nat -> nat -> nat +Nat.min: nat -> nat -> nat +Nat.pow: nat -> nat -> nat +Nat.div: nat -> nat -> nat +Nat.modulo: nat -> nat -> nat +Nat.gcd: nat -> nat -> nat +Nat.square: nat -> nat +Nat.sqrt_iter: nat -> nat -> nat -> nat -> nat +Nat.sqrt: nat -> nat +Nat.log2_iter: nat -> nat -> nat -> nat -> nat +Nat.log2: nat -> nat +Nat.div2: nat -> nat +Nat.bitwise: (bool -> bool -> bool) -> nat -> nat -> nat -> nat +Nat.land: nat -> nat -> nat +Nat.lor: nat -> nat -> nat +Nat.ldiff: nat -> nat -> nat +Nat.lxor: nat -> nat -> nat + S: nat -> nat -pred: nat -> nat -plus: nat -> nat -> nat -mult: nat -> nat -> nat -minus: nat -> nat -> nat -min: nat -> nat -> nat -max: nat -> nat -> nat +Nat.succ: nat -> nat +Nat.pred: nat -> nat +Nat.add: nat -> nat -> nat +Nat.double: nat -> nat +Nat.mul: nat -> nat -> nat +Nat.sub: nat -> nat -> nat +Nat.max: nat -> nat -> nat +Nat.min: nat -> nat -> nat +Nat.pow: nat -> nat -> nat +Nat.div: nat -> nat -> nat +Nat.modulo: nat -> nat -> nat +Nat.gcd: nat -> nat -> nat +Nat.square: nat -> nat +Nat.sqrt_iter: nat -> nat -> nat -> nat -> nat +Nat.sqrt: nat -> nat +Nat.log2_iter: nat -> nat -> nat -> nat -> nat +Nat.log2: nat -> nat +Nat.div2: nat -> nat +Nat.bitwise: (bool -> bool -> bool) -> nat -> nat -> nat -> nat +Nat.land: nat -> nat -> nat +Nat.lor: nat -> nat -> nat +Nat.ldiff: nat -> nat -> nat +Nat.lxor: nat -> nat -> nat mult_n_Sm: forall n m : nat, n * m + n = n * S m -le_n: forall n : nat, n <= n identity_refl: forall (A : Type) (a : A), identity a a -eq_refl: forall (A : Type) (x : A), x = x iff_refl: forall A : Prop, A <-> A +eq_refl: forall (A : Type) (x : A), x = x +Nat.divmod: nat -> nat -> nat -> nat -> nat * nat +le_n: forall n : nat, n <= n pair: forall A B : Type, A -> B -> A * B conj: forall A B : Prop, A -> B -> A /\ B +Nat.divmod: nat -> nat -> nat -> nat -> nat * nat + +h: n <> newdef n +h: n <> newdef n +h: P n +h': ~ P n +h: P n +h: P n diff --git a/test-suite/output/SearchPattern.v b/test-suite/output/SearchPattern.v index 802d8c97..bde195a5 100644 --- a/test-suite/output/SearchPattern.v +++ b/test-suite/output/SearchPattern.v @@ -17,3 +17,20 @@ SearchPattern (forall (x:?A) (y:?B), _ ?A ?B). (* No delta-reduction *) SearchPattern (Exc _). + +Definition newdef := fun x:nat => x. + +Goal forall n:nat, n <> newdef n -> False. + intros n h. + SearchPattern ( _ <> newdef _). (* search hypothesis *) + SearchPattern ( n <> newdef _). (* search hypothesis *) +Abort. + +Goal forall n (P:nat -> Prop), P n -> ~P n -> False. + intros n P h h'. + SearchPattern (P _). (* search hypothesis also for patterns *) + Search (~P n). (* search hypothesis also for patterns *) + Search (P _) -"h'". (* search hypothesis also for patterns *) + Search (P _) -not. (* search hypothesis also for patterns *) + +Abort.
\ No newline at end of file diff --git a/test-suite/output/SearchRewrite.out b/test-suite/output/SearchRewrite.out index f87aea1c..5edea5df 100644 --- a/test-suite/output/SearchRewrite.out +++ b/test-suite/output/SearchRewrite.out @@ -1,2 +1,5 @@ plus_n_O: forall n : nat, n = n + 0 plus_O_n: forall n : nat, 0 + n = n +h: n = newdef n +h: n = newdef n +h: n = newdef n diff --git a/test-suite/output/SearchRewrite.v b/test-suite/output/SearchRewrite.v index 171a7363..53d043c6 100644 --- a/test-suite/output/SearchRewrite.v +++ b/test-suite/output/SearchRewrite.v @@ -2,3 +2,12 @@ SearchRewrite (_+0). (* left *) SearchRewrite (0+_). (* right *) + +Definition newdef := fun x:nat => x. + +Goal forall n:nat, n = newdef n -> False. + intros n h. + SearchRewrite (newdef _). + SearchRewrite n. (* use hypothesis for patterns *) + SearchRewrite (newdef n). (* use hypothesis for patterns *) +Abort. diff --git a/test-suite/output/TranspModtype.out b/test-suite/output/TranspModtype.out index f94ed642..67b65d4b 100644 --- a/test-suite/output/TranspModtype.out +++ b/test-suite/output/TranspModtype.out @@ -1,7 +1,15 @@ TrM.A = M.A : Set + +TrM.A is not universe polymorphic OpM.A = M.A : Set + +OpM.A is not universe polymorphic TrM.B = M.B : Set + +TrM.B is not universe polymorphic *** [ OpM.B : Set ] + +OpM.B is not universe polymorphic diff --git a/test-suite/output/inference.out b/test-suite/output/inference.out index 4f8de1dc..d69baaec 100644 --- a/test-suite/output/inference.out +++ b/test-suite/output/inference.out @@ -4,7 +4,17 @@ fun e : option L => match e with | None => None end : option L -> option L -fun n : nat => let x := A n in ?12 ?15:T n + +P is not universe polymorphic +fun (m n p : nat) (H : S m <= S n + p) => le_S_n m (n + p) H + : forall m n p : nat, S m <= S n + p -> m <= n + p +fun n : nat => let x := A n in ?y ?y0:T n : forall n : nat, T n -fun n : nat => ?20 ?23:T n +where +?y : [n : nat x := A n : T n |- ?T0 -> T n] +?y0 : [n : nat x := A n : T n |- ?T0] +fun n : nat => ?y ?y0:T n : forall n : nat, T n +where +?y : [n : nat |- ?T0 -> T n] +?y0 : [n : nat |- ?T0] diff --git a/test-suite/output/inference.v b/test-suite/output/inference.v index 2b564f48..cd9a4a12 100644 --- a/test-suite/output/inference.v +++ b/test-suite/output/inference.v @@ -13,6 +13,10 @@ Definition P (e:option L) := Print P. +(* Check that plus is folded even if reduction is involved *) +Check (fun m n p (H : S m <= (S n) + p) => le_S_n _ _ H). + + (* Check that the heuristic to solve constraints is not artificially dependent on the presence of a let-in, and in particular that the second [_] below is not inferred to be n, as if obtained by diff --git a/test-suite/output/names.out b/test-suite/output/names.out new file mode 100644 index 00000000..2892dfd5 --- /dev/null +++ b/test-suite/output/names.out @@ -0,0 +1,6 @@ +The command has indeed failed with message: +=> Error: +In environment +y : nat +The term "a y" has type "{y0 : nat | y = y0}" +while it is expected to have type "{x : nat | x = y}". diff --git a/test-suite/output/names.v b/test-suite/output/names.v new file mode 100644 index 00000000..b3b5071a --- /dev/null +++ b/test-suite/output/names.v @@ -0,0 +1,5 @@ +(* Test no clash names occur *) +(* see bug #2723 *) + +Parameter a : forall x, {y:nat|x=y}. +Fail Definition b y : {x:nat|x=y} := a y. diff --git a/test-suite/output/reduction.v b/test-suite/output/reduction.v index c4592369..ab626282 100644 --- a/test-suite/output/reduction.v +++ b/test-suite/output/reduction.v @@ -1,6 +1,6 @@ (* Test the behaviour of hnf and simpl introduced in revision *) -Variable n:nat. +Parameter n:nat. Definition a:=0. Eval simpl in (fix plus (n m : nat) {struct n} : nat := diff --git a/test-suite/output/set.out b/test-suite/output/set.out index 333fbb86..4dfd2bc2 100644 --- a/test-suite/output/set.out +++ b/test-suite/output/set.out @@ -6,16 +6,13 @@ x = x 1 subgoal - y1 := 0 : nat - y2 := 0 : nat + y1, y2 := 0 : nat x := y2 + 0 : nat ============================ x = x 1 subgoal - y1 := 0 : nat - y2 := 0 : nat - y3 := 0 : nat + y1, y2, y3 := 0 : nat x := y2 + y3 : nat ============================ x = x diff --git a/test-suite/output/simpl.v b/test-suite/output/simpl.v index 5f1926f1..89638eed 100644 --- a/test-suite/output/simpl.v +++ b/test-suite/output/simpl.v @@ -4,10 +4,10 @@ Goal forall x, 0+x = 1+x. intro x. simpl (_ + x). Show. -Undo. +Undo 2. simpl (_ + x) at 2. Show. -Undo. +Undo 2. simpl (0 + _). Show. -Undo. +Undo 2. diff --git a/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v b/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v new file mode 100755 index 00000000..0d75d52a --- /dev/null +++ b/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v @@ -0,0 +1,3041 @@ +(* This program is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Lesser General Public License *) +(* as published by the Free Software Foundation; either version 2.1 *) +(* of the License, or (at your option) any later version. *) +(* *) +(* This program is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU General Public License for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public *) +(* License along with this program; if not, write to the Free *) +(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *) +(* 02110-1301 USA *) + + +(** This file includes random facts about Integers (and natural numbers) which are not found in the standard library. Some of the lemma here are not used in the QArith developement but are rather useful. +*) + +Require Export ZArith. +Require Export ZArithRing. + +Tactic Notation "ElimCompare" constr(c) constr(d) := elim_compare c d. + +Ltac Flip := + apply Zgt_lt || apply Zlt_gt || apply Zle_ge || apply Zge_le; assumption. + +Ltac Falsum := + try intro; apply False_ind; + repeat + match goal with + | id1:(~ ?X1) |- ?X2 => + (apply id1; assumption || reflexivity) || clear id1 + end. + + +Ltac Step_l a := + match goal with + | |- (?X1 < ?X2)%Z => replace X1 with a; [ idtac | try ring ] + end. + +Ltac Step_r a := + match goal with + | |- (?X1 < ?X2)%Z => replace X2 with a; [ idtac | try ring ] + end. + +Ltac CaseEq formula := + generalize (refl_equal formula); pattern formula at -1 in |- *; + case formula. + + +Lemma pair_1 : forall (A B : Set) (H : A * B), H = pair (fst H) (snd H). +Proof. + intros. + case H. + intros. + simpl in |- *. + reflexivity. +Qed. + +Lemma pair_2 : + forall (A B : Set) (H1 H2 : A * B), + fst H1 = fst H2 -> snd H1 = snd H2 -> H1 = H2. +Proof. + intros A B H1 H2. + case H1. + case H2. + simpl in |- *. + intros. + rewrite H. + rewrite H0. + reflexivity. +Qed. + + +Section projection. + Variable A : Set. + Variable P : A -> Prop. + + Definition projP1 (H : sig P) := let (x, h) := H in x. + Definition projP2 (H : sig P) := + let (x, h) as H return (P (projP1 H)) := H in h. +End projection. + + +(*###########################################################################*) +(* Declaring some realtions on natural numbers for stepl and stepr tactics. *) +(*###########################################################################*) + +Lemma le_stepl: forall x y z, le x y -> x=z -> le z y. +Proof. + intros x y z H_le H_eq; subst z; trivial. +Qed. + +Lemma le_stepr: forall x y z, le x y -> y=z -> le x z. +Proof. + intros x y z H_le H_eq; subst z; trivial. +Qed. + +Lemma lt_stepl: forall x y z, lt x y -> x=z -> lt z y. +Proof. + intros x y z H_lt H_eq; subst z; trivial. +Qed. + +Lemma lt_stepr: forall x y z, lt x y -> y=z -> lt x z. +Proof. + intros x y z H_lt H_eq; subst z; trivial. +Qed. + +Lemma neq_stepl:forall (x y z:nat), x<>y -> x=z -> z<>y. +Proof. + intros x y z H_lt H_eq; subst; assumption. +Qed. + +Lemma neq_stepr:forall (x y z:nat), x<>y -> y=z -> x<>z. +Proof. + intros x y z H_lt H_eq; subst; assumption. +Qed. + + +Declare Left Step le_stepl. +Declare Right Step le_stepr. +Declare Left Step lt_stepl. +Declare Right Step lt_stepr. +Declare Left Step neq_stepl. +Declare Right Step neq_stepr. + +(*###########################################################################*) +(** Some random facts about natural numbers, positive numbers and integers *) +(*###########################################################################*) + + +Lemma not_O_S : forall n : nat, n <> 0 -> {p : nat | n = S p}. +Proof. + intros [| np] Hn; [ exists 0; apply False_ind; apply Hn | exists np ]; + reflexivity. +Qed. + + +Lemma lt_minus_neq : forall m n : nat, m < n -> n - m <> 0. +Proof. + intros. + omega. +Qed. + +Lemma lt_minus_eq_0 : forall m n : nat, m < n -> m - n = 0. +Proof. + intros. + omega. +Qed. + +Lemma le_plus_Sn_1_SSn : forall n : nat, S n + 1 <= S (S n). +Proof. + intros. + omega. +Qed. + +Lemma le_plus_O_l : forall p q : nat, p + q <= 0 -> p = 0. +Proof. + intros; omega. +Qed. + +Lemma le_plus_O_r : forall p q : nat, p + q <= 0 -> q = 0. +Proof. + intros; omega. +Qed. + +Lemma minus_pred : forall m n : nat, 0 < n -> pred m - pred n = m - n. +Proof. + intros. + omega. +Qed. + + +(*###########################################################################*) +(* Declaring some realtions on integers for stepl and stepr tactics. *) +(*###########################################################################*) + +Lemma Zle_stepl: forall x y z, (x<=y)%Z -> x=z -> (z<=y)%Z. +Proof. + intros x y z H_le H_eq; subst z; trivial. +Qed. + +Lemma Zle_stepr: forall x y z, (x<=y)%Z -> y=z -> (x<=z)%Z. +Proof. + intros x y z H_le H_eq; subst z; trivial. +Qed. + +Lemma Zlt_stepl: forall x y z, (x<y)%Z -> x=z -> (z<y)%Z. +Proof. + intros x y z H_lt H_eq; subst z; trivial. +Qed. + +Lemma Zlt_stepr: forall x y z, (x<y)%Z -> y=z -> (x<z)%Z. +Proof. + intros x y z H_lt H_eq; subst z; trivial. +Qed. + +Lemma Zneq_stepl:forall (x y z:Z), (x<>y)%Z -> x=z -> (z<>y)%Z. +Proof. + intros x y z H_lt H_eq; subst; assumption. +Qed. + +Lemma Zneq_stepr:forall (x y z:Z), (x<>y)%Z -> y=z -> (x<>z)%Z. +Proof. + intros x y z H_lt H_eq; subst; assumption. +Qed. + +Declare Left Step Zle_stepl. +Declare Right Step Zle_stepr. +Declare Left Step Zlt_stepl. +Declare Right Step Zlt_stepr. +Declare Left Step Zneq_stepl. +Declare Right Step Zneq_stepr. + + +(*###########################################################################*) +(** Informative case analysis *) +(*###########################################################################*) + +Lemma Zlt_cotrans : + forall x y : Z, (x < y)%Z -> forall z : Z, {(x < z)%Z} + {(z < y)%Z}. +Proof. + intros. + case (Z_lt_ge_dec x z). + intro. + left. + assumption. + intro. + right. + apply Zle_lt_trans with (m := x). + apply Zge_le. + assumption. + assumption. +Qed. + +Lemma Zlt_cotrans_pos : + forall x y : Z, (0 < x + y)%Z -> {(0 < x)%Z} + {(0 < y)%Z}. +Proof. + intros. + case (Zlt_cotrans 0 (x + y) H x). + intro. + left. + assumption. + intro. + right. + apply Zplus_lt_reg_l with (p := x). + rewrite Zplus_0_r. + assumption. +Qed. + + +Lemma Zlt_cotrans_neg : + forall x y : Z, (x + y < 0)%Z -> {(x < 0)%Z} + {(y < 0)%Z}. +Proof. + intros x y H; case (Zlt_cotrans (x + y) 0 H x); intro Hxy; + [ right; apply Zplus_lt_reg_l with (p := x); rewrite Zplus_0_r | left ]; + assumption. +Qed. + + + +Lemma not_Zeq_inf : forall x y : Z, x <> y -> {(x < y)%Z} + {(y < x)%Z}. +Proof. + intros. + case Z_lt_ge_dec with x y. + intro. + left. + assumption. + intro H0. + generalize (Zge_le _ _ H0). + intro. + case (Z_le_lt_eq_dec _ _ H1). + intro. + right. + assumption. + intro. + apply False_rec. + apply H. + symmetry in |- *. + assumption. +Qed. + +Lemma Z_dec : forall x y : Z, {(x < y)%Z} + {(x > y)%Z} + {x = y}. +Proof. + intros. + case (Z_lt_ge_dec x y). + intro H. + left. + left. + assumption. + intro H. + generalize (Zge_le _ _ H). + intro H0. + case (Z_le_lt_eq_dec y x H0). + intro H1. + left. + right. + apply Zlt_gt. + assumption. + intro. + right. + symmetry in |- *. + assumption. +Qed. + + +Lemma Z_dec' : forall x y : Z, {(x < y)%Z} + {(y < x)%Z} + {x = y}. +Proof. + intros x y. + case (Z_eq_dec x y); intro H; + [ right; assumption | left; apply (not_Zeq_inf _ _ H) ]. +Qed. + +Lemma Z_lt_le_dec : forall x y : Z, {(x < y)%Z} + {(y <= x)%Z}. +Proof. + intros. + case (Z_lt_ge_dec x y). + intro. + left. + assumption. + intro. + right. + apply Zge_le. + assumption. +Qed. + +Lemma Z_le_lt_dec : forall x y : Z, {(x <= y)%Z} + {(y < x)%Z}. +Proof. + intros; case (Z_lt_le_dec y x); [ right | left ]; assumption. +Qed. + +Lemma Z_lt_lt_S_eq_dec : + forall x y : Z, (x < y)%Z -> {(x + 1 < y)%Z} + {(x + 1)%Z = y}. +Proof. + intros. + generalize (Zlt_le_succ _ _ H). + unfold Zsucc in |- *. + apply Z_le_lt_eq_dec. +Qed. + +Lemma quadro_leq_inf : + forall a b c d : Z, + {(c <= a)%Z /\ (d <= b)%Z} + {~ ((c <= a)%Z /\ (d <= b)%Z)}. +Proof. + intros. + case (Z_lt_le_dec a c). + intro z. + right. + intro. + elim H. + intros. + generalize z. + apply Zle_not_lt. + assumption. + intro. + case (Z_lt_le_dec b d). + intro z0. + right. + intro. + elim H. + intros. + generalize z0. + apply Zle_not_lt. + assumption. + intro. + left. + split. + assumption. + assumption. +Qed. + +(*###########################################################################*) +(** General auxiliary lemmata *) +(*###########################################################################*) + +Lemma Zminus_eq : forall x y : Z, (x - y)%Z = 0%Z -> x = y. +Proof. + intros. + apply Zplus_reg_l with (- y)%Z. + rewrite Zplus_opp_l. + unfold Zminus in H. + rewrite Zplus_comm. + assumption. +Qed. + +Lemma Zlt_minus : forall a b : Z, (b < a)%Z -> (0 < a - b)%Z. +Proof. + intros a b. + intros. + apply Zplus_lt_reg_l with b. + unfold Zminus in |- *. + rewrite (Zplus_comm a). + rewrite (Zplus_assoc b (- b)). + rewrite Zplus_opp_r. + simpl in |- *. + rewrite <- Zplus_0_r_reverse. + assumption. +Qed. + + +Lemma Zle_minus : forall a b : Z, (b <= a)%Z -> (0 <= a - b)%Z. +Proof. + intros a b. + intros. + apply Zplus_le_reg_l with b. + unfold Zminus in |- *. + rewrite (Zplus_comm a). + rewrite (Zplus_assoc b (- b)). + rewrite Zplus_opp_r. + simpl in |- *. + rewrite <- Zplus_0_r_reverse. + assumption. +Qed. + +Lemma Zlt_plus_plus : + forall m n p q : Z, (m < n)%Z -> (p < q)%Z -> (m + p < n + q)%Z. +Proof. + intros. + apply Zlt_trans with (m := (n + p)%Z). + rewrite Zplus_comm. + rewrite Zplus_comm with (n := n). + apply Zplus_lt_compat_l. + assumption. + apply Zplus_lt_compat_l. + assumption. +Qed. + +Lemma Zgt_plus_plus : + forall m n p q : Z, (m > n)%Z -> (p > q)%Z -> (m + p > n + q)%Z. + intros. + apply Zgt_trans with (m := (n + p)%Z). + rewrite Zplus_comm. + rewrite Zplus_comm with (n := n). + apply Zplus_gt_compat_l. + assumption. + apply Zplus_gt_compat_l. + assumption. +Qed. + +Lemma Zle_lt_plus_plus : + forall m n p q : Z, (m <= n)%Z -> (p < q)%Z -> (m + p < n + q)%Z. +Proof. + intros. + case (Zle_lt_or_eq m n). + assumption. + intro. + apply Zlt_plus_plus. + assumption. + assumption. + intro. + rewrite H1. + apply Zplus_lt_compat_l. + assumption. +Qed. + +Lemma Zge_gt_plus_plus : + forall m n p q : Z, (m >= n)%Z -> (p > q)%Z -> (m + p > n + q)%Z. +Proof. + intros. + case (Zle_lt_or_eq n m). + apply Zge_le. + assumption. + intro. + apply Zgt_plus_plus. + apply Zlt_gt. + assumption. + assumption. + intro. + rewrite H1. + apply Zplus_gt_compat_l. + assumption. +Qed. + +Lemma Zgt_ge_plus_plus : + forall m n p q : Z, (m > n)%Z -> (p >= q)%Z -> (m + p > n + q)%Z. +Proof. + intros. + rewrite Zplus_comm. + replace (n + q)%Z with (q + n)%Z. + apply Zge_gt_plus_plus. + assumption. + assumption. + apply Zplus_comm. +Qed. + +Lemma Zlt_resp_pos : forall x y : Z, (0 < x)%Z -> (0 < y)%Z -> (0 < x + y)%Z. +Proof. + intros. + rewrite <- Zplus_0_r with 0%Z. + apply Zlt_plus_plus; assumption. +Qed. + + +Lemma Zle_resp_neg : + forall x y : Z, (x <= 0)%Z -> (y <= 0)%Z -> (x + y <= 0)%Z. +Proof. + intros. + rewrite <- Zplus_0_r with 0%Z. + apply Zplus_le_compat; assumption. +Qed. + + +Lemma Zlt_pos_opp : forall x : Z, (0 < x)%Z -> (- x < 0)%Z. +Proof. + intros. + apply Zplus_lt_reg_l with x. + rewrite Zplus_opp_r. + rewrite Zplus_0_r. + assumption. +Qed. + +Lemma Zlt_neg_opp : forall x : Z, (x < 0)%Z -> (0 < - x)%Z. +Proof. + intros. + apply Zplus_lt_reg_l with x. + rewrite Zplus_opp_r. + rewrite Zplus_0_r. + assumption. +Qed. + + +Lemma Zle_neg_opp : forall x : Z, (x <= 0)%Z -> (0 <= - x)%Z. +Proof. + intros. + apply Zplus_le_reg_l with x. + rewrite Zplus_opp_r. + rewrite Zplus_0_r. + assumption. +Qed. + +Lemma Zle_pos_opp : forall x : Z, (0 <= x)%Z -> (- x <= 0)%Z. +Proof. + intros. + apply Zplus_le_reg_l with x. + rewrite Zplus_opp_r. + rewrite Zplus_0_r. + assumption. +Qed. + + +Lemma Zge_opp : forall x y : Z, (x <= y)%Z -> (- x >= - y)%Z. +Proof. + intros. + apply Zle_ge. + apply Zplus_le_reg_l with (p := (x + y)%Z). + ring_simplify (x + y + - y)%Z (x + y + - x)%Z. + assumption. +Qed. + + + +(* Omega can't solve this *) +Lemma Zmult_pos_pos : forall x y : Z, (0 < x)%Z -> (0 < y)%Z -> (0 < x * y)%Z. +Proof. + intros [| px| px] [| py| py] Hx Hy; trivial || constructor. +Qed. + +Lemma Zmult_neg_neg : forall x y : Z, (x < 0)%Z -> (y < 0)%Z -> (0 < x * y)%Z. +Proof. + intros [| px| px] [| py| py] Hx Hy; trivial || constructor. +Qed. + +Lemma Zmult_neg_pos : forall x y : Z, (x < 0)%Z -> (0 < y)%Z -> (x * y < 0)%Z. +Proof. + intros [| px| px] [| py| py] Hx Hy; trivial || constructor. +Qed. + +Lemma Zmult_pos_neg : forall x y : Z, (0 < x)%Z -> (y < 0)%Z -> (x * y < 0)%Z. +Proof. + intros [| px| px] [| py| py] Hx Hy; trivial || constructor. +Qed. + + + +Hint Resolve Zmult_pos_pos Zmult_neg_neg Zmult_neg_pos Zmult_pos_neg: zarith. + + +Lemma Zle_reg_mult_l : + forall x y a : Z, (0 < a)%Z -> (x <= y)%Z -> (a * x <= a * y)%Z. +Proof. + intros. + apply Zplus_le_reg_l with (p := (- a * x)%Z). + ring_simplify (- a * x + a * x)%Z. + replace (- a * x + a * y)%Z with ((y - x) * a)%Z. + apply Zmult_gt_0_le_0_compat. + apply Zlt_gt. + assumption. + unfold Zminus in |- *. + apply Zle_left. + assumption. + ring. +Qed. + +Lemma Zsimpl_plus_l_dep : + forall x y m n : Z, (x + m)%Z = (y + n)%Z -> x = y -> m = n. +Proof. + intros. + apply Zplus_reg_l with x. + rewrite <- H0 in H. + assumption. +Qed. + + +Lemma Zsimpl_plus_r_dep : + forall x y m n : Z, (m + x)%Z = (n + y)%Z -> x = y -> m = n. +Proof. + intros. + apply Zplus_reg_l with x. + rewrite Zplus_comm. + rewrite Zplus_comm with x n. + rewrite <- H0 in H. + assumption. +Qed. + +Lemma Zmult_simpl : + forall n m p q : Z, n = m -> p = q -> (n * p)%Z = (m * q)%Z. +Proof. + intros. + rewrite H. + rewrite H0. + reflexivity. +Qed. + +Lemma Zsimpl_mult_l : + forall n m p : Z, n <> 0%Z -> (n * m)%Z = (n * p)%Z -> m = p. +Proof. + intros. + apply Zplus_reg_l with (n := (- p)%Z). + replace (- p + p)%Z with 0%Z. + apply Zmult_integral_l with (n := n). + assumption. + replace ((- p + m) * n)%Z with (n * m + - (n * p))%Z. + apply Zegal_left. + assumption. + ring. + ring. +Qed. + +Lemma Zlt_reg_mult_l : + forall x y z : Z, (x > 0)%Z -> (y < z)%Z -> (x * y < x * z)%Z. (*QA*) +Proof. + intros. + case (Zcompare_Gt_spec x 0). + unfold Zgt in H. + assumption. + intros. + cut (x = Zpos x0). + intro. + rewrite H2. + unfold Zlt in H0. + unfold Zlt in |- *. + cut ((Zpos x0 * y ?= Zpos x0 * z)%Z = (y ?= z)%Z). + intro. + exact (trans_eq H3 H0). + apply Zcompare_mult_compat. + cut (x = (x + - (0))%Z). + intro. + exact (trans_eq H2 H1). + simpl in |- *. + apply (sym_eq (A:=Z)). + exact (Zplus_0_r x). +Qed. + + +Lemma Zlt_opp : forall x y : Z, (x < y)%Z -> (- x > - y)%Z. (*QA*) +Proof. + intros. + red in |- *. + apply sym_eq. + cut (Datatypes.Gt = (y ?= x)%Z). + intro. + cut ((y ?= x)%Z = (- x ?= - y)%Z). + intro. + exact (trans_eq H0 H1). + exact (Zcompare_opp y x). + apply sym_eq. + exact (Zlt_gt x y H). +Qed. + + +Lemma Zlt_conv_mult_l : + forall x y z : Z, (x < 0)%Z -> (y < z)%Z -> (x * y > x * z)%Z. (*QA*) +Proof. + intros. + cut (- x > 0)%Z. + intro. + cut (- x * y < - x * z)%Z. + intro. + cut (- (- x * y) > - (- x * z))%Z. + intro. + cut (- - (x * y) > - - (x * z))%Z. + intro. + cut ((- - (x * y))%Z = (x * y)%Z). + intro. + rewrite H5 in H4. + cut ((- - (x * z))%Z = (x * z)%Z). + intro. + rewrite H6 in H4. + assumption. + exact (Zopp_involutive (x * z)). + exact (Zopp_involutive (x * y)). + cut ((- (- x * y))%Z = (- - (x * y))%Z). + intro. + rewrite H4 in H3. + cut ((- (- x * z))%Z = (- - (x * z))%Z). + intro. + rewrite H5 in H3. + assumption. + cut ((- x * z)%Z = (- (x * z))%Z). + intro. + exact (f_equal Zopp H5). + exact (Zopp_mult_distr_l_reverse x z). + cut ((- x * y)%Z = (- (x * y))%Z). + intro. + exact (f_equal Zopp H4). + exact (Zopp_mult_distr_l_reverse x y). + exact (Zlt_opp (- x * y) (- x * z) H2). + exact (Zlt_reg_mult_l (- x) y z H1 H0). + exact (Zlt_opp x 0 H). +Qed. + +Lemma Zgt_not_eq : forall x y : Z, (x > y)%Z -> x <> y. (*QA*) +Proof. + intros. + cut (y < x)%Z. + intro. + cut (y <> x). + intro. + red in |- *. + intros. + cut (y = x). + intros. + apply H1. + assumption. + exact (sym_eq H2). + exact (Zorder.Zlt_not_eq y x H0). + exact (Zgt_lt x y H). +Qed. + +Lemma Zmult_resp_nonzero : + forall x y : Z, x <> 0%Z -> y <> 0%Z -> (x * y)%Z <> 0%Z. +Proof. + intros x y Hx Hy Hxy. + apply Hx. + apply Zmult_integral_l with y; assumption. +Qed. + + +Lemma Zopp_app : forall y : Z, y <> 0%Z -> (- y)%Z <> 0%Z. +Proof. + intros. + intro. + apply H. + apply Zplus_reg_l with (- y)%Z. + rewrite Zplus_opp_l. + rewrite H0. + simpl in |- *. + reflexivity. +Qed. + + +Lemma Zle_neq_Zlt : forall a b : Z, (a <= b)%Z -> b <> a -> (a < b)%Z. +Proof. + intros a b H H0. + case (Z_le_lt_eq_dec _ _ H); trivial. + intro; apply False_ind; apply H0; symmetry in |- *; assumption. +Qed. + +Lemma not_Zle_lt : forall x y : Z, ~ (y <= x)%Z -> (x < y)%Z. +Proof. + intros; apply Zgt_lt; apply Znot_le_gt; assumption. +Qed. + +Lemma not_Zlt : forall x y : Z, ~ (y < x)%Z -> (x <= y)%Z. +Proof. + intros x y H1 H2; apply H1; apply Zgt_lt; assumption. +Qed. + + +Lemma Zmult_absorb : + forall x y z : Z, x <> 0%Z -> (x * y)%Z = (x * z)%Z -> y = z. (*QA*) +Proof. + intros. + case (dec_eq y z). + intro. + assumption. + intro. + case (not_Zeq y z). + assumption. + intro. + case (not_Zeq x 0). + assumption. + intro. + apply False_ind. + cut (x * y > x * z)%Z. + intro. + cut ((x * y)%Z <> (x * z)%Z). + intro. + apply H5. + assumption. + exact (Zgt_not_eq (x * y) (x * z) H4). + exact (Zlt_conv_mult_l x y z H3 H2). + intro. + apply False_ind. + cut (x * y < x * z)%Z. + intro. + cut ((x * y)%Z <> (x * z)%Z). + intro. + apply H5. + assumption. + exact (Zorder.Zlt_not_eq (x * y) (x * z) H4). + cut (x > 0)%Z. + intro. + exact (Zlt_reg_mult_l x y z H4 H2). + exact (Zlt_gt 0 x H3). + intro. + apply False_ind. + cut (x * z < x * y)%Z. + intro. + cut ((x * z)%Z <> (x * y)%Z). + intro. + apply H4. + apply (sym_eq (A:=Z)). + assumption. + exact (Zorder.Zlt_not_eq (x * z) (x * y) H3). + apply False_ind. + case (not_Zeq x 0). + assumption. + intro. + cut (x * z > x * y)%Z. + intro. + cut ((x * z)%Z <> (x * y)%Z). + intro. + apply H5. + apply (sym_eq (A:=Z)). + assumption. + exact (Zgt_not_eq (x * z) (x * y) H4). + exact (Zlt_conv_mult_l x z y H3 H2). + intro. + cut (x * z < x * y)%Z. + intro. + cut ((x * z)%Z <> (x * y)%Z). + intro. + apply H5. + apply (sym_eq (A:=Z)). + assumption. + exact (Zorder.Zlt_not_eq (x * z) (x * y) H4). + cut (x > 0)%Z. + intro. + exact (Zlt_reg_mult_l x z y H4 H2). + exact (Zlt_gt 0 x H3). +Qed. + +Lemma Zlt_mult_mult : + forall a b c d : Z, + (0 < a)%Z -> (0 < d)%Z -> (a < b)%Z -> (c < d)%Z -> (a * c < b * d)%Z. +Proof. + intros. + apply Zlt_trans with (a * d)%Z. + apply Zlt_reg_mult_l. + Flip. + assumption. + rewrite Zmult_comm. + rewrite Zmult_comm with b d. + apply Zlt_reg_mult_l. + Flip. + assumption. +Qed. + +Lemma Zgt_mult_conv_absorb_l : + forall a x y : Z, (a < 0)%Z -> (a * x > a * y)%Z -> (x < y)%Z. (*QC*) +Proof. + intros. + case (dec_eq x y). + intro. + apply False_ind. + rewrite H1 in H0. + cut ((a * y)%Z = (a * y)%Z). + change ((a * y)%Z <> (a * y)%Z) in |- *. + apply Zgt_not_eq. + assumption. + trivial. + + intro. + case (not_Zeq x y H1). + trivial. + + intro. + apply False_ind. + cut (a * y > a * x)%Z. + apply Zgt_asym with (m := (a * y)%Z) (n := (a * x)%Z). + assumption. + apply Zlt_conv_mult_l. + assumption. + assumption. +Qed. + +Lemma Zgt_mult_reg_absorb_l : + forall a x y : Z, (a > 0)%Z -> (a * x > a * y)%Z -> (x > y)%Z. (*QC*) +Proof. + intros. + cut (- - a > - - (0))%Z. + intro. + cut (- a < - (0))%Z. + simpl in |- *. + intro. + replace x with (- - x)%Z. + replace y with (- - y)%Z. + apply Zlt_opp. + apply Zgt_mult_conv_absorb_l with (a := (- a)%Z) (x := (- x)%Z). + assumption. + rewrite Zmult_opp_opp. + rewrite Zmult_opp_opp. + assumption. + apply Zopp_involutive. + apply Zopp_involutive. + apply Zgt_lt. + apply Zlt_opp. + apply Zgt_lt. + assumption. + simpl in |- *. + rewrite Zopp_involutive. + assumption. +Qed. + +Lemma Zopp_Zlt : forall x y : Z, (y < x)%Z -> (- x < - y)%Z. +Proof. + intros x y Hyx. + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + constructor. + replace (-1 * - y)%Z with y. + replace (-1 * - x)%Z with x. + Flip. + ring. + ring. +Qed. + + +Lemma Zmin_cancel_Zlt : forall x y : Z, (- x < - y)%Z -> (y < x)%Z. +Proof. + intros. + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + constructor. + replace (-1 * y)%Z with (- y)%Z. + replace (-1 * x)%Z with (- x)%Z. + apply Zlt_gt. + assumption. + ring. + ring. +Qed. + + +Lemma Zmult_cancel_Zle : + forall a x y : Z, (a < 0)%Z -> (a * x <= a * y)%Z -> (y <= x)%Z. +Proof. + intros. + case (Z_le_gt_dec y x). + trivial. + intro. + apply False_ind. + apply (Zlt_irrefl (a * x)). + apply Zle_lt_trans with (m := (a * y)%Z). + assumption. + apply Zgt_lt. + apply Zlt_conv_mult_l. + assumption. + apply Zgt_lt. + assumption. +Qed. + +Lemma Zlt_mult_cancel_l : + forall x y z : Z, (0 < x)%Z -> (x * y < x * z)%Z -> (y < z)%Z. +Proof. + intros. + apply Zgt_lt. + apply Zgt_mult_reg_absorb_l with x. + apply Zlt_gt. + assumption. + apply Zlt_gt. + assumption. +Qed. + + +Lemma Zmin_cancel_Zle : forall x y : Z, (- x <= - y)%Z -> (y <= x)%Z. +Proof. + intros. + apply Zmult_cancel_Zle with (a := (-1)%Z). + constructor. + replace (-1 * y)%Z with (- y)%Z. + replace (-1 * x)%Z with (- x)%Z. + assumption. + ring. + ring. +Qed. + + + +Lemma Zmult_resp_Zle : + forall a x y : Z, (0 < a)%Z -> (a * y <= a * x)%Z -> (y <= x)%Z. +Proof. + intros. + case (Z_le_gt_dec y x). + trivial. + intro. + apply False_ind. + apply (Zlt_irrefl (a * y)). + apply Zle_lt_trans with (m := (a * x)%Z). + assumption. + apply Zlt_reg_mult_l. + apply Zlt_gt. + assumption. + apply Zgt_lt. + assumption. +Qed. + +Lemma Zopp_Zle : forall x y : Z, (y <= x)%Z -> (- x <= - y)%Z. +Proof. + intros. + apply Zmult_cancel_Zle with (a := (-1)%Z). + constructor. + replace (-1 * - y)%Z with y. + replace (-1 * - x)%Z with x. + assumption. + clear y H; ring. + clear x H; ring. +Qed. + + +Lemma Zle_lt_eq_S : forall x y : Z, (x <= y)%Z -> (y < x + 1)%Z -> y = x. +Proof. + intros. + case (Z_le_lt_eq_dec x y H). + intro H1. + apply False_ind. + generalize (Zlt_le_succ x y H1). + intro. + apply (Zlt_not_le y (x + 1) H0). + replace (x + 1)%Z with (Zsucc x). + assumption. + reflexivity. + intro H1. + symmetry in |- *. + assumption. +Qed. + +Lemma Zlt_le_eq_S : + forall x y : Z, (x < y)%Z -> (y <= x + 1)%Z -> y = (x + 1)%Z. +Proof. + intros. + case (Z_le_lt_eq_dec y (x + 1) H0). + intro H1. + apply False_ind. + generalize (Zlt_le_succ x y H). + intro. + apply (Zlt_not_le y (x + 1) H1). + replace (x + 1)%Z with (Zsucc x). + assumption. + reflexivity. + trivial. +Qed. + + +Lemma double_not_equal_zero : + forall c d : Z, ~ (c = 0%Z /\ d = 0%Z) -> c <> d \/ c <> 0%Z. +Proof. + intros. + case (Z_zerop c). + intro. + rewrite e. + left. + apply sym_not_eq. + intro. + apply H; repeat split; assumption. + intro; right; assumption. +Qed. + +Lemma triple_not_equal_zero : + forall a b c : Z, + ~ (a = 0%Z /\ b = 0%Z /\ c = 0%Z) -> a <> 0%Z \/ b <> 0%Z \/ c <> 0%Z. +Proof. + intros a b c H; case (Z_zerop a); intro Ha; + [ case (Z_zerop b); intro Hb; + [ case (Z_zerop c); intro Hc; + [ apply False_ind; apply H; repeat split | right; right ] + | right; left ] + | left ]; assumption. +Qed. + +Lemma mediant_1 : + forall m n m' n' : Z, (m' * n < m * n')%Z -> ((m + m') * n < m * (n + n'))%Z. +Proof. + intros. + rewrite Zmult_plus_distr_r. + rewrite Zmult_plus_distr_l. + apply Zplus_lt_compat_l. + assumption. +Qed. + +Lemma mediant_2 : + forall m n m' n' : Z, + (m' * n < m * n')%Z -> (m' * (n + n') < (m + m') * n')%Z. +Proof. + intros. + rewrite Zmult_plus_distr_l. + rewrite Zmult_plus_distr_r. + apply Zplus_lt_compat_r. + assumption. +Qed. + + +Lemma mediant_3 : + forall a b m n m' n' : Z, + (0 <= a * m + b * n)%Z -> + (0 <= a * m' + b * n')%Z -> (0 <= a * (m + m') + b * (n + n'))%Z. +Proof. + intros. + replace (a * (m + m') + b * (n + n'))%Z with + (a * m + b * n + (a * m' + b * n'))%Z. + apply Zplus_le_0_compat. + assumption. + assumption. + ring. +Qed. + +Lemma fraction_lt_trans : + forall a b c d e f : Z, + (0 < b)%Z -> + (0 < d)%Z -> + (0 < f)%Z -> (a * d < c * b)%Z -> (c * f < e * d)%Z -> (a * f < e * b)%Z. +Proof. + intros. + apply Zgt_lt. + apply Zgt_mult_reg_absorb_l with d. + Flip. + apply Zgt_trans with (c * b * f)%Z. + replace (d * (e * b))%Z with (b * (e * d))%Z. + replace (c * b * f)%Z with (b * (c * f))%Z. + apply Zlt_gt. + apply Zlt_reg_mult_l. + Flip. + assumption. + ring. + ring. + replace (c * b * f)%Z with (f * (c * b))%Z. + replace (d * (a * f))%Z with (f * (a * d))%Z. + apply Zlt_gt. + apply Zlt_reg_mult_l. + Flip. + assumption. + ring. + ring. +Qed. + + +Lemma square_pos : forall a : Z, a <> 0%Z -> (0 < a * a)%Z. +Proof. + intros [| p| p]; intros; [ Falsum | constructor | constructor ]. +Qed. + +Hint Resolve square_pos: zarith. + +(*###########################################################################*) +(** Properties of positive numbers, mapping between Z and nat *) +(*###########################################################################*) + + +Definition Z2positive (z : Z) := + match z with + | Zpos p => p + | Zneg p => p + | Z0 => 1%positive + end. + + +Lemma ZL9 : forall p : positive, Z_of_nat (nat_of_P p) = Zpos p. (*QF*) +Proof. + intro. + cut (exists h : nat, nat_of_P p = S h). + intro. + case H. + intros. + unfold Z_of_nat in |- *. + rewrite H0. + + apply f_equal with (A := positive) (B := Z) (f := Zpos). + cut (P_of_succ_nat (nat_of_P p) = P_of_succ_nat (S x)). + intro. + rewrite P_of_succ_nat_o_nat_of_P_eq_succ in H1. + cut (Ppred (Psucc p) = Ppred (P_of_succ_nat (S x))). + intro. + rewrite Ppred_succ in H2. + simpl in H2. + rewrite Ppred_succ in H2. + apply sym_eq. + assumption. + apply f_equal with (A := positive) (B := positive) (f := Ppred). + assumption. + apply f_equal with (f := P_of_succ_nat). + assumption. + apply ZL4. +Qed. + +Coercion Z_of_nat : nat >-> Z. + +Lemma ZERO_lt_POS : forall p : positive, (0 < Zpos p)%Z. +Proof. + intros. + constructor. +Qed. + + +Lemma POS_neq_ZERO : forall p : positive, Zpos p <> 0%Z. +Proof. + intros. + apply sym_not_eq. + apply Zorder.Zlt_not_eq. + apply ZERO_lt_POS. +Qed. + +Lemma NEG_neq_ZERO : forall p : positive, Zneg p <> 0%Z. +Proof. + intros. + apply Zorder.Zlt_not_eq. + unfold Zlt in |- *. + constructor. +Qed. + + +Lemma POS_resp_eq : forall p0 p1 : positive, Zpos p0 = Zpos p1 -> p0 = p1. +Proof. + intros. + injection H. + trivial. +Qed. + +Lemma nat_nat_pos : forall m n : nat, ((m + 1) * (n + 1) > 0)%Z. (*QF*) +Proof. + intros. + apply Zlt_gt. + cut (Z_of_nat m + 1 > 0)%Z. + intro. + cut (0 < Z_of_nat n + 1)%Z. + intro. + cut ((Z_of_nat m + 1) * 0 < (Z_of_nat m + 1) * (Z_of_nat n + 1))%Z. + rewrite Zmult_0_r. + intro. + assumption. + + apply Zlt_reg_mult_l. + assumption. + assumption. + change (0 < Zsucc (Z_of_nat n))%Z in |- *. + apply Zle_lt_succ. + change (Z_of_nat 0 <= Z_of_nat n)%Z in |- *. + apply Znat.inj_le. + apply le_O_n. + apply Zlt_gt. + change (0 < Zsucc (Z_of_nat m))%Z in |- *. + apply Zle_lt_succ. + change (Z_of_nat 0 <= Z_of_nat m)%Z in |- *. + apply Znat.inj_le. + apply le_O_n. +Qed. + + +Theorem S_predn : forall m : nat, m <> 0 -> S (pred m) = m. (*QF*) +Proof. + intros. + case (O_or_S m). + intro. + case s. + intros. + rewrite <- e. + rewrite <- pred_Sn with (n := x). + trivial. + intro. + apply False_ind. + apply H. + apply sym_eq. + assumption. +Qed. + +Lemma absolu_1 : forall x : Z, Zabs_nat x = 0 -> x = 0%Z. (*QF*) +Proof. + intros. + case (dec_eq x 0). + intro. + assumption. + intro. + apply False_ind. + cut ((x < 0)%Z \/ (x > 0)%Z). + intro. + ElimCompare x 0%Z. + intro. + cut (x = 0%Z). + assumption. + cut ((x ?= 0)%Z = Datatypes.Eq -> x = 0%Z). + intro. + apply H3. + assumption. + apply proj1 with (B := x = 0%Z -> (x ?= 0)%Z = Datatypes.Eq). + change ((x ?= 0)%Z = Datatypes.Eq <-> x = 0%Z) in |- *. + apply Zcompare_Eq_iff_eq. + + (***) + intro. + cut (exists h : nat, Zabs_nat x = S h). + intro. + case H3. + rewrite H. + exact O_S. + + change (x < 0)%Z in H2. + cut (0 > x)%Z. + intro. + cut (exists p : positive, (0 + - x)%Z = Zpos p). + simpl in |- *. + intro. + case H4. + intros. + cut (exists q : positive, x = Zneg q). + intro. + case H6. + intros. + rewrite H7. + unfold Zabs_nat in |- *. + generalize x1. + exact ZL4. + cut (x = (- Zpos x0)%Z). + simpl in |- *. + intro. + exists x0. + assumption. + cut ((- - x)%Z = x). + intro. + rewrite <- H6. + exact (f_equal Zopp H5). + apply Zopp_involutive. + apply Zcompare_Gt_spec. + assumption. + apply Zlt_gt. + assumption. + + (***) + intro. + cut (exists h : nat, Zabs_nat x = S h). + intro. + case H3. + rewrite H. + exact O_S. + + cut (exists p : positive, (x + - (0))%Z = Zpos p). + simpl in |- *. + rewrite Zplus_0_r. + intro. + case H3. + intros. + rewrite H4. + unfold Zabs_nat in |- *. + generalize x0. + exact ZL4. + apply Zcompare_Gt_spec. + assumption. + + (***) + cut ((x < 0)%Z \/ (0 < x)%Z). + intro. + apply + or_ind with (A := (x < 0)%Z) (B := (0 < x)%Z) (P := (x < 0)%Z \/ (x > 0)%Z). + intro. + left. + assumption. + intro. + right. + apply Zlt_gt. + assumption. + assumption. + apply not_Zeq. + assumption. +Qed. + +Lemma absolu_2 : forall x : Z, x <> 0%Z -> Zabs_nat x <> 0. (*QF*) +Proof. + intros. + intro. + apply H. + apply absolu_1. + assumption. +Qed. + + + + +Lemma absolu_inject_nat : forall n : nat, Zabs_nat (Z_of_nat n) = n. +Proof. + simple induction n; simpl in |- *. + reflexivity. + intros. + apply nat_of_P_o_P_of_succ_nat_eq_succ. +Qed. + + +Lemma eq_inj : forall m n : nat, m = n :>Z -> m = n. +Proof. + intros. + generalize (f_equal Zabs_nat H). + intro. + rewrite (absolu_inject_nat m) in H0. + rewrite (absolu_inject_nat n) in H0. + assumption. +Qed. + +Lemma lt_inj : forall m n : nat, (m < n)%Z -> m < n. +Proof. + intros. + omega. +Qed. + +Lemma le_inj : forall m n : nat, (m <= n)%Z -> m <= n. +Proof. + intros. + omega. +Qed. + + +Lemma inject_nat_S_inf : forall x : Z, (0 < x)%Z -> {n : nat | x = S n}. +Proof. + intros [| p| p] Hp; try discriminate Hp. + exists (pred (nat_of_P p)). + rewrite S_predn. + symmetry in |- *; apply ZL9. + clear Hp; + apply sym_not_equal; apply lt_O_neq; apply lt_O_nat_of_P. +Qed. + + + +Lemma le_absolu : + forall x y : Z, + (0 <= x)%Z -> (0 <= y)%Z -> (x <= y)%Z -> Zabs_nat x <= Zabs_nat y. +Proof. + intros [| x| x] [| y| y] Hx Hy Hxy; + apply le_O_n || + (try + match goal with + | id1:(0 <= Zneg _)%Z |- _ => + apply False_ind; apply id1; constructor + | id1:(Zpos _ <= 0)%Z |- _ => + apply False_ind; apply id1; constructor + | id1:(Zpos _ <= Zneg _)%Z |- _ => + apply False_ind; apply id1; constructor + end). + simpl in |- *. + apply le_inj. + do 2 rewrite ZL9. + assumption. +Qed. + +Lemma lt_absolu : + forall x y : Z, + (0 <= x)%Z -> (0 <= y)%Z -> (x < y)%Z -> Zabs_nat x < Zabs_nat y. +Proof. + intros [| x| x] [| y| y] Hx Hy Hxy; inversion Hxy; + try + match goal with + | id1:(0 <= Zneg _)%Z |- _ => + apply False_ind; apply id1; constructor + | id1:(Zpos _ <= 0)%Z |- _ => + apply False_ind; apply id1; constructor + | id1:(Zpos _ <= Zneg _)%Z |- _ => + apply False_ind; apply id1; constructor + end; simpl in |- *; apply lt_inj; repeat rewrite ZL9; + assumption. +Qed. + +Lemma absolu_plus : + forall x y : Z, + (0 <= x)%Z -> (0 <= y)%Z -> Zabs_nat (x + y) = Zabs_nat x + Zabs_nat y. +Proof. + intros [| x| x] [| y| y] Hx Hy; trivial; + try + match goal with + | id1:(0 <= Zneg _)%Z |- _ => + apply False_ind; apply id1; constructor + | id1:(Zpos _ <= 0)%Z |- _ => + apply False_ind; apply id1; constructor + | id1:(Zpos _ <= Zneg _)%Z |- _ => + apply False_ind; apply id1; constructor + end. + rewrite <- BinInt.Zpos_plus_distr. + unfold Zabs_nat in |- *. + apply nat_of_P_plus_morphism. +Qed. + +Lemma pred_absolu : + forall x : Z, (0 < x)%Z -> pred (Zabs_nat x) = Zabs_nat (x - 1). +Proof. + intros x Hx. + generalize (Z_lt_lt_S_eq_dec 0 x Hx); simpl in |- *; intros [H1| H1]; + [ replace (Zabs_nat x) with (Zabs_nat (x - 1 + 1)); + [ idtac | apply f_equal with Z; auto with zarith ]; + rewrite absolu_plus; + [ unfold Zabs_nat at 2, nat_of_P, Piter_op in |- *; omega + | auto with zarith + | intro; discriminate ] + | rewrite <- H1; reflexivity ]. +Qed. + +Definition pred_nat : forall (x : Z) (Hx : (0 < x)%Z), nat. +intros [| px| px] Hx; try abstract (discriminate Hx). +exact (pred (nat_of_P px)). +Defined. + +Lemma pred_nat_equal : + forall (x : Z) (Hx1 Hx2 : (0 < x)%Z), pred_nat x Hx1 = pred_nat x Hx2. +Proof. + intros [| px| px] Hx1 Hx2; try (discriminate Hx1); trivial. +Qed. + +Let pred_nat_unfolded_subproof px : + Pos.to_nat px <> 0. +Proof. +apply sym_not_equal; apply lt_O_neq; apply lt_O_nat_of_P. +Qed. + +Lemma pred_nat_unfolded : + forall (x : Z) (Hx : (0 < x)%Z), x = S (pred_nat x Hx). +Proof. + intros [| px| px] Hx; try discriminate Hx. + unfold pred_nat in |- *. + rewrite S_predn. + symmetry in |- *; apply ZL9. + clear Hx; apply pred_nat_unfolded_subproof. +Qed. + +Lemma absolu_pred_nat : + forall (m : Z) (Hm : (0 < m)%Z), S (pred_nat m Hm) = Zabs_nat m. +Proof. + intros [| px| px] Hx; try discriminate Hx. + unfold pred_nat in |- *. + rewrite S_predn. + reflexivity. + apply pred_nat_unfolded_subproof. +Qed. + +Lemma pred_nat_absolu : + forall (m : Z) (Hm : (0 < m)%Z), pred_nat m Hm = Zabs_nat (m - 1). +Proof. + intros [| px| px] Hx; try discriminate Hx. + unfold pred_nat in |- *. + rewrite <- pred_absolu; reflexivity || assumption. +Qed. + +Lemma minus_pred_nat : + forall (n m : Z) (Hn : (0 < n)%Z) (Hm : (0 < m)%Z) (Hnm : (0 < n - m)%Z), + S (pred_nat n Hn) - S (pred_nat m Hm) = S (pred_nat (n - m) Hnm). +Proof. + intros. + simpl in |- *. + destruct n; try discriminate Hn. + destruct m; try discriminate Hm. + unfold pred_nat at 1 2 in |- *. + rewrite minus_pred; try apply lt_O_nat_of_P. + apply eq_inj. + rewrite <- pred_nat_unfolded. + rewrite Znat.inj_minus1. + repeat rewrite ZL9. + reflexivity. + apply le_inj. + apply Zlt_le_weak. + repeat rewrite ZL9. + apply Zlt_O_minus_lt. + assumption. +Qed. + + +(*###########################################################################*) +(** Properties of Zsgn *) +(*###########################################################################*) + + +Lemma Zsgn_1 : + forall x : Z, {Zsgn x = 0%Z} + {Zsgn x = 1%Z} + {Zsgn x = (-1)%Z}. (*QF*) +Proof. + intros. + case x. + left. + left. + unfold Zsgn in |- *. + reflexivity. + intro. + simpl in |- *. + left. + right. + reflexivity. + intro. + right. + simpl in |- *. + reflexivity. +Qed. + + +Lemma Zsgn_2 : forall x : Z, Zsgn x = 0%Z -> x = 0%Z. (*QF*) +Proof. + intros [| p1| p1]; simpl in |- *; intro H; constructor || discriminate H. +Qed. + + +Lemma Zsgn_3 : forall x : Z, x <> 0%Z -> Zsgn x <> 0%Z. (*QF*) +Proof. + intro. + case x. + intros. + apply False_ind. + apply H. + reflexivity. + intros. + simpl in |- *. + discriminate. + intros. + simpl in |- *. + discriminate. +Qed. + + + + +Theorem Zsgn_4 : forall a : Z, a = (Zsgn a * Zabs_nat a)%Z. (*QF*) +Proof. + intro. + case a. + simpl in |- *. + reflexivity. + intro. + unfold Zsgn in |- *. + unfold Zabs_nat in |- *. + rewrite Zmult_1_l. + symmetry in |- *. + apply ZL9. + intros. + unfold Zsgn in |- *. + unfold Zabs_nat in |- *. + rewrite ZL9. + constructor. +Qed. + + +Theorem Zsgn_5 : + forall a b x y : Z, + x <> 0%Z -> + y <> 0%Z -> + (Zsgn a * x)%Z = (Zsgn b * y)%Z -> (Zsgn a * y)%Z = (Zsgn b * x)%Z. (*QF*) +Proof. + intros a b x y H H0. + case a. + + case b. + simpl in |- *. + trivial. + + intro. + unfold Zsgn in |- *. + intro. + rewrite Zmult_1_l in H1. + simpl in H1. + apply False_ind. + apply H0. + symmetry in |- *. + assumption. + intro. + unfold Zsgn in |- *. + intro. + apply False_ind. + apply H0. + apply Zopp_inj. + simpl in |- *. + transitivity (-1 * y)%Z. + constructor. + transitivity (0 * x)%Z. + symmetry in |- *. + assumption. + simpl in |- *. + reflexivity. + intro. + unfold Zsgn at 1 in |- *. + unfold Zsgn at 2 in |- *. + intro. + transitivity y. + rewrite Zmult_1_l. + reflexivity. + transitivity (Zsgn b * (Zsgn b * y))%Z. + case (Zsgn_1 b). + intro. + case s. + intro. + apply False_ind. + apply H. + rewrite e in H1. + change ((1 * x)%Z = 0%Z) in H1. + rewrite Zmult_1_l in H1. + assumption. + intro. + rewrite e. + rewrite Zmult_1_l. + rewrite Zmult_1_l. + reflexivity. + intro. + rewrite e. + ring. + rewrite Zmult_1_l in H1. + rewrite H1. + reflexivity. + intro. + unfold Zsgn at 1 in |- *. + unfold Zsgn at 2 in |- *. + intro. + transitivity (Zsgn b * (-1 * (Zsgn b * y)))%Z. + case (Zsgn_1 b). + intros. + case s. + intro. + apply False_ind. + apply H. + apply Zopp_inj. + transitivity (-1 * x)%Z. + ring. + unfold Zopp in |- *. + rewrite e in H1. + transitivity (0 * y)%Z. + assumption. + simpl in |- *. + reflexivity. + intro. + rewrite e. + ring. + intro. + rewrite e. + ring. + rewrite <- H1. + ring. +Qed. + +Lemma Zsgn_6 : forall x : Z, x = 0%Z -> Zsgn x = 0%Z. +Proof. + intros. + rewrite H. + simpl in |- *. + reflexivity. +Qed. + + +Lemma Zsgn_7 : forall x : Z, (x > 0)%Z -> Zsgn x = 1%Z. +Proof. + intro. + case x. + intro. + apply False_ind. + apply (Zlt_irrefl 0). + Flip. + intros. + simpl in |- *. + reflexivity. + intros. + apply False_ind. + apply (Zlt_irrefl (Zneg p)). + apply Zlt_trans with 0%Z. + constructor. + Flip. +Qed. + + +Lemma Zsgn_7' : forall x : Z, (0 < x)%Z -> Zsgn x = 1%Z. +Proof. + intros; apply Zsgn_7; Flip. +Qed. + + +Lemma Zsgn_8 : forall x : Z, (x < 0)%Z -> Zsgn x = (-1)%Z. +Proof. + intro. + case x. + intro. + apply False_ind. + apply (Zlt_irrefl 0). + assumption. + intros. + apply False_ind. + apply (Zlt_irrefl 0). + apply Zlt_trans with (Zpos p). + constructor. + assumption. + intros. + simpl in |- *. + reflexivity. +Qed. + +Lemma Zsgn_9 : forall x : Z, Zsgn x = 1%Z -> (0 < x)%Z. +Proof. + intro. + case x. + intro. + apply False_ind. + simpl in H. + discriminate. + intros. + constructor. + intros. + apply False_ind. + discriminate. +Qed. + +Lemma Zsgn_10 : forall x : Z, Zsgn x = (-1)%Z -> (x < 0)%Z. +Proof. + intro. + case x. + intro. + apply False_ind. + discriminate. + intros. + apply False_ind. + discriminate. + intros. + constructor. +Qed. + +Lemma Zsgn_11 : forall x : Z, (Zsgn x < 0)%Z -> (x < 0)%Z. +Proof. + intros. + apply Zsgn_10. + case (Zsgn_1 x). + intro. + apply False_ind. + case s. + intro. + generalize (Zorder.Zlt_not_eq _ _ H). + intro. + apply (H0 e). + intro. + rewrite e in H. + generalize (Zorder.Zlt_not_eq _ _ H). + intro. + discriminate. + trivial. +Qed. + +Lemma Zsgn_12 : forall x : Z, (0 < Zsgn x)%Z -> (0 < x)%Z. +Proof. + intros. + apply Zsgn_9. + case (Zsgn_1 x). + intro. + case s. + intro. + generalize (Zorder.Zlt_not_eq _ _ H). + intro. + generalize (sym_eq e). + intro. + apply False_ind. + apply (H0 H1). + trivial. + intro. + rewrite e in H. + generalize (Zorder.Zlt_not_eq _ _ H). + intro. + apply False_ind. + discriminate. +Qed. + +Lemma Zsgn_13 : forall x : Z, (0 <= Zsgn x)%Z -> (0 <= x)%Z. +Proof. + intros. + case (Z_le_lt_eq_dec 0 (Zsgn x) H). + intro. + apply Zlt_le_weak. + apply Zsgn_12. + assumption. + intro. + assert (x = 0%Z). + apply Zsgn_2. + symmetry in |- *. + assumption. + rewrite H0. + apply Zle_refl. +Qed. + +Lemma Zsgn_14 : forall x : Z, (Zsgn x <= 0)%Z -> (x <= 0)%Z. +Proof. + intros. + case (Z_le_lt_eq_dec (Zsgn x) 0 H). + intro. + apply Zlt_le_weak. + apply Zsgn_11. + assumption. + intro. + assert (x = 0%Z). + apply Zsgn_2. + assumption. + rewrite H0. + apply Zle_refl. +Qed. + +Lemma Zsgn_15 : forall x y : Z, Zsgn (x * y) = (Zsgn x * Zsgn y)%Z. +Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; constructor. +Qed. + +Lemma Zsgn_16 : + forall x y : Z, + Zsgn (x * y) = 1%Z -> {(0 < x)%Z /\ (0 < y)%Z} + {(x < 0)%Z /\ (y < 0)%Z}. +Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + try discriminate H; [ left | right ]; repeat split. +Qed. + +Lemma Zsgn_17 : + forall x y : Z, + Zsgn (x * y) = (-1)%Z -> {(0 < x)%Z /\ (y < 0)%Z} + {(x < 0)%Z /\ (0 < y)%Z}. +Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + try discriminate H; [ left | right ]; repeat split. +Qed. + +Lemma Zsgn_18 : forall x y : Z, Zsgn (x * y) = 0%Z -> {x = 0%Z} + {y = 0%Z}. +Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + try discriminate H; [ left | right | right ]; constructor. +Qed. + + + +Lemma Zsgn_19 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 < x + y)%Z. +Proof. + Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + discriminate H || (constructor || apply Zsgn_12; assumption). +Qed. + +Lemma Zsgn_20 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (x + y < 0)%Z. +Proof. + Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + discriminate H || (constructor || apply Zsgn_11; assumption). +Qed. + + +Lemma Zsgn_21 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 <= x)%Z. +Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intros H H0; + discriminate H || discriminate H0. +Qed. + +Lemma Zsgn_22 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (x <= 0)%Z. +Proof. + Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intros H H0; + discriminate H || discriminate H0. +Qed. + +Lemma Zsgn_23 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 <= y)%Z. +Proof. + intros [[| p2| p2]| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; + intros H H0; discriminate H || discriminate H0. +Qed. + +Lemma Zsgn_24 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (y <= 0)%Z. +Proof. + intros [[| p2| p2]| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; + intros H H0; discriminate H || discriminate H0. +Qed. + +Lemma Zsgn_25 : forall x : Z, Zsgn (- x) = (- Zsgn x)%Z. +Proof. + intros [| p1| p1]; simpl in |- *; reflexivity. +Qed. + + +Lemma Zsgn_26 : forall x : Z, (0 < x)%Z -> (0 < Zsgn x)%Z. +Proof. + intros [| p| p] Hp; trivial. +Qed. + +Lemma Zsgn_27 : forall x : Z, (x < 0)%Z -> (Zsgn x < 0)%Z. +Proof. + intros [| p| p] Hp; trivial. +Qed. + +Hint Resolve Zsgn_1 Zsgn_2 Zsgn_3 Zsgn_4 Zsgn_5 Zsgn_6 Zsgn_7 Zsgn_7' Zsgn_8 + Zsgn_9 Zsgn_10 Zsgn_11 Zsgn_12 Zsgn_13 Zsgn_14 Zsgn_15 Zsgn_16 Zsgn_17 + Zsgn_18 Zsgn_19 Zsgn_20 Zsgn_21 Zsgn_22 Zsgn_23 Zsgn_24 Zsgn_25 Zsgn_26 + Zsgn_27: zarith. + +(*###########################################################################*) +(** Properties of Zabs *) +(*###########################################################################*) + +Lemma Zabs_1 : forall z p : Z, (Zabs z < p)%Z -> (z < p)%Z /\ (- p < z)%Z. +Proof. + intros z p. + case z. + intros. + simpl in H. + split. + assumption. + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + replace (-1)%Z with (Zpred 0). + apply Zlt_pred. + simpl; trivial. + ring_simplify (-1 * - p)%Z (-1 * 0)%Z. + apply Zlt_gt. + assumption. + + intros. + simpl in H. + split. + assumption. + apply Zlt_trans with (m := 0%Z). + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + replace (-1)%Z with (Zpred 0). + apply Zlt_pred. + simpl; trivial. + ring_simplify (-1 * - p)%Z (-1 * 0)%Z. + apply Zlt_gt. + apply Zlt_trans with (m := Zpos p0). + constructor. + assumption. + constructor. + + intros. + simpl in H. + split. + apply Zlt_trans with (m := Zpos p0). + constructor. + assumption. + + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + replace (-1)%Z with (Zpred 0). + apply Zlt_pred. + simpl;trivial. + ring_simplify (-1 * - p)%Z. + replace (-1 * Zneg p0)%Z with (- Zneg p0)%Z. + replace (- Zneg p0)%Z with (Zpos p0). + apply Zlt_gt. + assumption. + symmetry in |- *. + apply Zopp_neg. + rewrite Zopp_mult_distr_l_reverse with (n := 1%Z). + simpl in |- *. + constructor. +Qed. + + +Lemma Zabs_2 : forall z p : Z, (Zabs z > p)%Z -> (z > p)%Z \/ (- p > z)%Z. +Proof. + intros z p. + case z. + intros. + simpl in H. + left. + assumption. + + intros. + simpl in H. + left. + assumption. + + intros. + simpl in H. + right. + apply Zlt_gt. + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + constructor. + ring_simplify (-1 * - p)%Z. + replace (-1 * Zneg p0)%Z with (Zpos p0). + assumption. + reflexivity. +Qed. + +Lemma Zabs_3 : forall z p : Z, (z < p)%Z /\ (- p < z)%Z -> (Zabs z < p)%Z. +Proof. + intros z p. + case z. + intro. + simpl in |- *. + elim H. + intros. + assumption. + + intros. + elim H. + intros. + simpl in |- *. + assumption. + + intros. + elim H. + intros. + simpl in |- *. + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + constructor. + replace (-1 * Zpos p0)%Z with (Zneg p0). + replace (-1 * p)%Z with (- p)%Z. + apply Zlt_gt. + assumption. + ring. + simpl in |- *. + reflexivity. +Qed. + +Lemma Zabs_4 : forall z p : Z, (Zabs z < p)%Z -> (- p < z < p)%Z. +Proof. + intros. + split. + apply proj2 with (A := (z < p)%Z). + apply Zabs_1. + assumption. + apply proj1 with (B := (- p < z)%Z). + apply Zabs_1. + assumption. +Qed. + + +Lemma Zabs_5 : forall z p : Z, (Zabs z <= p)%Z -> (- p <= z <= p)%Z. +Proof. + intros. + split. + replace (- p)%Z with (Zsucc (- Zsucc p)). + apply Zlt_le_succ. + apply proj2 with (A := (z < Zsucc p)%Z). + apply Zabs_1. + apply Zle_lt_succ. + assumption. + unfold Zsucc in |- *. + ring. + apply Zlt_succ_le. + apply proj1 with (B := (- Zsucc p < z)%Z). + apply Zabs_1. + apply Zle_lt_succ. + assumption. +Qed. + +Lemma Zabs_6 : forall z p : Z, (Zabs z <= p)%Z -> (z <= p)%Z. +Proof. + intros. + apply proj2 with (A := (- p <= z)%Z). + apply Zabs_5. + assumption. +Qed. + +Lemma Zabs_7 : forall z p : Z, (Zabs z <= p)%Z -> (- p <= z)%Z. +Proof. + intros. + apply proj1 with (B := (z <= p)%Z). + apply Zabs_5. + assumption. +Qed. + +Lemma Zabs_8 : forall z p : Z, (- p <= z <= p)%Z -> (Zabs z <= p)%Z. +Proof. + intros. + apply Zlt_succ_le. + apply Zabs_3. + elim H. + intros. + split. + apply Zle_lt_succ. + assumption. + apply Zlt_le_trans with (m := (- p)%Z). + apply Zgt_lt. + apply Zlt_opp. + apply Zlt_succ. + assumption. +Qed. + +Lemma Zabs_min : forall z : Z, Zabs z = Zabs (- z). +Proof. + intro. + case z. + simpl in |- *. + reflexivity. + intro. + simpl in |- *. + reflexivity. + intro. + simpl in |- *. + reflexivity. +Qed. + +Lemma Zabs_9 : + forall z p : Z, (0 <= p)%Z -> (p < z)%Z \/ (z < - p)%Z -> (p < Zabs z)%Z. +Proof. + intros. + case H0. + intro. + replace (Zabs z) with z. + assumption. + symmetry in |- *. + apply Zabs_eq. + apply Zlt_le_weak. + apply Zle_lt_trans with (m := p). + assumption. + assumption. + intro. + cut (Zabs z = (- z)%Z). + intro. + rewrite H2. + apply Zmin_cancel_Zlt. + ring_simplify (- - z)%Z. + assumption. + rewrite Zabs_min. + apply Zabs_eq. + apply Zlt_le_weak. + apply Zle_lt_trans with (m := p). + assumption. + apply Zmin_cancel_Zlt. + ring_simplify (- - z)%Z. + assumption. +Qed. + +Lemma Zabs_10 : forall z : Z, (0 <= Zabs z)%Z. +Proof. + intro. + case (Z_zerop z). + intro. + rewrite e. + simpl in |- *. + apply Zle_refl. + intro. + case (not_Zeq z 0 n). + intro. + apply Zlt_le_weak. + apply Zabs_9. + apply Zle_refl. + simpl in |- *. + right. + assumption. + intro. + apply Zlt_le_weak. + apply Zabs_9. + apply Zle_refl. + simpl in |- *. + left. + assumption. +Qed. + +Lemma Zabs_11 : forall z : Z, z <> 0%Z -> (0 < Zabs z)%Z. +Proof. + intros. + apply Zabs_9. + apply Zle_refl. + simpl in |- *. + apply not_Zeq. + intro. + apply H. + symmetry in |- *. + assumption. +Qed. + +Lemma Zabs_12 : forall z m : Z, (m < Zabs z)%Z -> {(m < z)%Z} + {(z < - m)%Z}. +Proof. + intros [| p| p] m; simpl in |- *; intros H; + [ left | left | right; apply Zmin_cancel_Zlt; rewrite Zopp_involutive ]; + assumption. +Qed. + +Lemma Zabs_mult : forall z p : Z, Zabs (z * p) = (Zabs z * Zabs p)%Z. +Proof. + intros. + case z. + simpl in |- *. + reflexivity. + case p. + simpl in |- *. + reflexivity. + intros. + simpl in |- *. + reflexivity. + intros. + simpl in |- *. + reflexivity. + case p. + intro. + simpl in |- *. + reflexivity. + intros. + simpl in |- *. + reflexivity. + intros. + simpl in |- *. + reflexivity. +Qed. + +Lemma Zabs_plus : forall z p : Z, (Zabs (z + p) <= Zabs z + Zabs p)%Z. +Proof. + intros. + case z. + simpl in |- *. + apply Zle_refl. + case p. + intro. + simpl in |- *. + apply Zle_refl. + intros. + simpl in |- *. + apply Zle_refl. + intros. + unfold Zabs at 2 in |- *. + unfold Zabs at 2 in |- *. + apply Zabs_8. + split. + apply Zplus_le_reg_l with (Zpos p1 - Zneg p0)%Z. + replace (Zpos p1 - Zneg p0 + - (Zpos p1 + Zpos p0))%Z with + (- (Zpos p0 + Zneg p0))%Z. + replace (Zpos p1 - Zneg p0 + (Zpos p1 + Zneg p0))%Z with (2 * Zpos p1)%Z. + replace (- (Zpos p0 + Zneg p0))%Z with 0%Z. + apply Zmult_gt_0_le_0_compat. + constructor. + apply Zlt_le_weak. + constructor. + rewrite <- Zopp_neg with p0. + ring. + ring. + ring. + apply Zplus_le_compat. + apply Zle_refl. + apply Zlt_le_weak. + constructor. + + case p. + simpl in |- *. + intro. + apply Zle_refl. + intros. + unfold Zabs at 2 in |- *. + unfold Zabs at 2 in |- *. + apply Zabs_8. + split. + apply Zplus_le_reg_l with (Zpos p1 + Zneg p0)%Z. + replace (Zpos p1 + Zneg p0 + - (Zpos p1 + Zpos p0))%Z with + (Zneg p0 - Zpos p0)%Z. + replace (Zpos p1 + Zneg p0 + (Zneg p1 + Zpos p0))%Z with 0%Z. + apply Zplus_le_reg_l with (Zpos p0). + replace (Zpos p0 + (Zneg p0 - Zpos p0))%Z with (Zneg p0). + simpl in |- *. + apply Zlt_le_weak. + constructor. + ring. + replace (Zpos p1 + Zneg p0 + (Zneg p1 + Zpos p0))%Z with + (Zpos p1 + Zneg p1 + (Zpos p0 + Zneg p0))%Z. + replace 0%Z with (0 + 0)%Z. + apply Zplus_eq_compat. + rewrite <- Zopp_neg with p1. + ring. + rewrite <- Zopp_neg with p0. + ring. + simpl in |- *. + constructor. + ring. + ring. + apply Zplus_le_compat. + apply Zlt_le_weak. + constructor. + apply Zle_refl. + intros. + simpl in |- *. + apply Zle_refl. +Qed. + +Lemma Zabs_neg : forall z : Z, (z <= 0)%Z -> Zabs z = (- z)%Z. +Proof. + intro. + case z. + simpl in |- *. + intro. + reflexivity. + intros. + apply False_ind. + apply H. + simpl in |- *. + reflexivity. + intros. + simpl in |- *. + reflexivity. +Qed. + +Lemma Zle_Zabs: forall z, (z <= Zabs z)%Z. +Proof. + intros [|z|z]; simpl; auto with zarith; apply Zle_neg_pos. +Qed. + +Hint Resolve Zabs_1 Zabs_2 Zabs_3 Zabs_4 Zabs_5 Zabs_6 Zabs_7 Zabs_8 Zabs_9 + Zabs_10 Zabs_11 Zabs_12 Zabs_min Zabs_neg Zabs_mult Zabs_plus Zle_Zabs: zarith. + + +(*###########################################################################*) +(** Induction on Z *) +(*###########################################################################*) + +Lemma Zind : + forall (P : Z -> Prop) (p : Z), + P p -> + (forall q : Z, (p <= q)%Z -> P q -> P (q + 1)%Z) -> + forall q : Z, (p <= q)%Z -> P q. +Proof. + intros P p. + intro. + intro. + cut (forall q : Z, (p <= q)%Z -> exists k : nat, q = (p + k)%Z). + intro. + cut (forall k : nat, P (p + k)%Z). + intro. + intros. + cut (exists k : nat, q = (p + Z_of_nat k)%Z). + intro. + case H4. + intros. + rewrite H5. + apply H2. + apply H1. + assumption. + intro. + induction k as [| k Hreck]. + simpl in |- *. + ring_simplify (p + 0)%Z. + assumption. + replace (p + Z_of_nat (S k))%Z with (p + k + 1)%Z. + apply H0. + apply Zplus_le_reg_l with (p := (- p)%Z). + replace (- p + p)%Z with (Z_of_nat 0). + ring_simplify (- p + (p + Z_of_nat k))%Z. + apply Znat.inj_le. + apply le_O_n. + ring_simplify; auto with arith. + assumption. + rewrite (Znat.inj_S k). + unfold Zsucc in |- *. + ring. + intros. + cut (exists k : nat, (q - p)%Z = Z_of_nat k). + intro. + case H2. + intro k. + intros. + exists k. + apply Zplus_reg_l with (n := (- p)%Z). + replace (- p + q)%Z with (q - p)%Z. + rewrite H3. + ring. + ring. + apply Z_of_nat_complete. + unfold Zminus in |- *. + apply Zle_left. + assumption. +Qed. + +Lemma Zrec : + forall (P : Z -> Set) (p : Z), + P p -> + (forall q : Z, (p <= q)%Z -> P q -> P (q + 1)%Z) -> + forall q : Z, (p <= q)%Z -> P q. +Proof. + intros F p. + intro. + intro. + cut (forall q : Z, (p <= q)%Z -> {k : nat | q = (p + k)%Z}). + intro. + cut (forall k : nat, F (p + k)%Z). + intro. + intros. + cut {k : nat | q = (p + Z_of_nat k)%Z}. + intro. + case H4. + intros. + rewrite e. + apply H2. + apply H1. + assumption. + intro. + induction k as [| k Hreck]. + simpl in |- *. + rewrite Zplus_0_r. + assumption. + replace (p + Z_of_nat (S k))%Z with (p + k + 1)%Z. + apply H0. + apply Zplus_le_reg_l with (p := (- p)%Z). + replace (- p + p)%Z with (Z_of_nat 0). + replace (- p + (p + Z_of_nat k))%Z with (Z_of_nat k). + apply Znat.inj_le. + apply le_O_n. + rewrite Zplus_assoc; rewrite Zplus_opp_l; reflexivity. + rewrite Zplus_opp_l; reflexivity. + assumption. + rewrite (Znat.inj_S k). + unfold Zsucc in |- *. + apply Zplus_assoc_reverse. + intros. + cut {k : nat | (q - p)%Z = Z_of_nat k}. + intro H2. + case H2. + intro k. + intros. + exists k. + apply Zplus_reg_l with (n := (- p)%Z). + replace (- p + q)%Z with (q - p)%Z. + rewrite e. + rewrite Zplus_assoc; rewrite Zplus_opp_l; reflexivity. + unfold Zminus in |- *. + apply Zplus_comm. + apply Z_of_nat_complete_inf. + unfold Zminus in |- *. + apply Zle_left. + assumption. +Qed. + +Lemma Zrec_down : + forall (P : Z -> Set) (p : Z), + P p -> + (forall q : Z, (q <= p)%Z -> P q -> P (q - 1)%Z) -> + forall q : Z, (q <= p)%Z -> P q. +Proof. + intros F p. + intro. + intro. + cut (forall q : Z, (q <= p)%Z -> {k : nat | q = (p - k)%Z}). + intro. + cut (forall k : nat, F (p - k)%Z). + intro. + intros. + cut {k : nat | q = (p - Z_of_nat k)%Z}. + intro. + case H4. + intros. + rewrite e. + apply H2. + apply H1. + assumption. + intro. + induction k as [| k Hreck]. + simpl in |- *. + replace (p - 0)%Z with p. + assumption. + unfold Zminus in |- *. + unfold Zopp in |- *. + rewrite Zplus_0_r; reflexivity. + replace (p - Z_of_nat (S k))%Z with (p - k - 1)%Z. + apply H0. + apply Zplus_le_reg_l with (p := (- p)%Z). + replace (- p + p)%Z with (- Z_of_nat 0)%Z. + replace (- p + (p - Z_of_nat k))%Z with (- Z_of_nat k)%Z. + apply Zge_le. + apply Zge_opp. + apply Znat.inj_le. + apply le_O_n. + unfold Zminus in |- *; rewrite Zplus_assoc; rewrite Zplus_opp_l; reflexivity. + rewrite Zplus_opp_l; reflexivity. + assumption. + rewrite (Znat.inj_S k). + unfold Zsucc in |- *. + unfold Zminus at 1 2 in |- *. + rewrite Zplus_assoc_reverse. + rewrite <- Zopp_plus_distr. + reflexivity. + intros. + cut {k : nat | (p - q)%Z = Z_of_nat k}. + intro. + case H2. + intro k. + intros. + exists k. + apply Zopp_inj. + apply Zplus_reg_l with (n := p). + replace (p + - (p - Z_of_nat k))%Z with (Z_of_nat k). + rewrite <- e. + reflexivity. + unfold Zminus in |- *. + rewrite Zopp_plus_distr. + rewrite Zplus_assoc. + rewrite Zplus_opp_r. + rewrite Zopp_involutive. + reflexivity. + apply Z_of_nat_complete_inf. + unfold Zminus in |- *. + apply Zle_left. + assumption. +Qed. + +Lemma Zind_down : + forall (P : Z -> Prop) (p : Z), + P p -> + (forall q : Z, (q <= p)%Z -> P q -> P (q - 1)%Z) -> + forall q : Z, (q <= p)%Z -> P q. +Proof. + intros F p. + intro. + intro. + cut (forall q : Z, (q <= p)%Z -> exists k : nat, q = (p - k)%Z). + intro. + cut (forall k : nat, F (p - k)%Z). + intro. + intros. + cut (exists k : nat, q = (p - Z_of_nat k)%Z). + intro. + case H4. + intros x e. + rewrite e. + apply H2. + apply H1. + assumption. + intro. + induction k as [| k Hreck]. + simpl in |- *. + replace (p - 0)%Z with p. + assumption. + ring. + replace (p - Z_of_nat (S k))%Z with (p - k - 1)%Z. + apply H0. + apply Zplus_le_reg_l with (p := (- p)%Z). + replace (- p + p)%Z with (- Z_of_nat 0)%Z. + replace (- p + (p - Z_of_nat k))%Z with (- Z_of_nat k)%Z. + apply Zge_le. + apply Zge_opp. + apply Znat.inj_le. + apply le_O_n. + ring. + ring_simplify; auto with arith. + assumption. + rewrite (Znat.inj_S k). + unfold Zsucc in |- *. + ring. + intros. + cut (exists k : nat, (p - q)%Z = Z_of_nat k). + intro. + case H2. + intro k. + intros. + exists k. + apply Zopp_inj. + apply Zplus_reg_l with (n := p). + replace (p + - (p - Z_of_nat k))%Z with (Z_of_nat k). + rewrite <- H3. + ring. + ring. + apply Z_of_nat_complete. + unfold Zminus in |- *. + apply Zle_left. + assumption. +Qed. + +Lemma Zrec_wf : + forall (P : Z -> Set) (p : Z), + (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) -> + forall q : Z, (p <= q)%Z -> P q. +Proof. + intros P p WF_ind_step q Hq. + cut (forall x : Z, (p <= x)%Z -> forall y : Z, (p <= y < x)%Z -> P y). + intro. + apply (H (Zsucc q)). + apply Zle_le_succ. + assumption. + + split; [ assumption | exact (Zlt_succ q) ]. + + intros x0 Hx0; generalize Hx0; pattern x0 in |- *. + apply Zrec with (p := p). + intros. + absurd (p <= p)%Z. + apply Zgt_not_le. + apply Zgt_le_trans with (m := y). + apply Zlt_gt. + elim H. + intros. + assumption. + elim H. + intros. + assumption. + apply Zle_refl. + + intros. + apply WF_ind_step. + intros. + apply (H0 H). + split. + elim H2. + intros. + assumption. + apply Zlt_le_trans with y. + elim H2. + intros. + assumption. + apply Zgt_succ_le. + apply Zlt_gt. + elim H1. + intros. + unfold Zsucc in |- *. + assumption. + assumption. +Qed. + +Lemma Zrec_wf2 : + forall (q : Z) (P : Z -> Set) (p : Z), + (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) -> + (p <= q)%Z -> P q. +Proof. + intros. + apply Zrec_wf with (p := p). + assumption. + assumption. +Qed. + +Lemma Zrec_wf_double : + forall (P : Z -> Z -> Set) (p0 q0 : Z), + (forall n m : Z, + (forall p q : Z, (q0 <= q)%Z -> (p0 <= p < n)%Z -> P p q) -> + (forall p : Z, (q0 <= p < m)%Z -> P n p) -> P n m) -> + forall p q : Z, (q0 <= q)%Z -> (p0 <= p)%Z -> P p q. +Proof. + intros P p0 q0 Hrec p. + intros. + generalize q H. + pattern p in |- *. + apply Zrec_wf with (p := p0). + intros p1 H1. + intros. + pattern q1 in |- *. + apply Zrec_wf with (p := q0). + intros q2 H3. + apply Hrec. + intros. + apply H1. + assumption. + assumption. + intros. + apply H3. + assumption. + assumption. + assumption. +Qed. + +Lemma Zind_wf : + forall (P : Z -> Prop) (p : Z), + (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) -> + forall q : Z, (p <= q)%Z -> P q. +Proof. + intros P p WF_ind_step q Hq. + cut (forall x : Z, (p <= x)%Z -> forall y : Z, (p <= y < x)%Z -> P y). + intro. + apply (H (Zsucc q)). + apply Zle_le_succ. + assumption. + + split; [ assumption | exact (Zlt_succ q) ]. + + intros x0 Hx0; generalize Hx0; pattern x0 in |- *. + apply Zind with (p := p). + intros. + absurd (p <= p)%Z. + apply Zgt_not_le. + apply Zgt_le_trans with (m := y). + apply Zlt_gt. + elim H. + intros. + assumption. + elim H. + intros. + assumption. + apply Zle_refl. + + intros. + apply WF_ind_step. + intros. + apply (H0 H). + split. + elim H2. + intros. + assumption. + apply Zlt_le_trans with y. + elim H2. + intros. + assumption. + apply Zgt_succ_le. + apply Zlt_gt. + elim H1. + intros. + unfold Zsucc in |- *. + assumption. + assumption. +Qed. + +Lemma Zind_wf2 : + forall (q : Z) (P : Z -> Prop) (p : Z), + (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) -> + (p <= q)%Z -> P q. +Proof. + intros. + apply Zind_wf with (p := p). + assumption. + assumption. +Qed. + +Lemma Zind_wf_double : + forall (P : Z -> Z -> Prop) (p0 q0 : Z), + (forall n m : Z, + (forall p q : Z, (q0 <= q)%Z -> (p0 <= p < n)%Z -> P p q) -> + (forall p : Z, (q0 <= p < m)%Z -> P n p) -> P n m) -> + forall p q : Z, (q0 <= q)%Z -> (p0 <= p)%Z -> P p q. +Proof. + intros P p0 q0 Hrec p. + intros. + generalize q H. + pattern p in |- *. + apply Zind_wf with (p := p0). + intros p1 H1. + intros. + pattern q1 in |- *. + apply Zind_wf with (p := q0). + intros q2 H3. + apply Hrec. + intros. + apply H1. + assumption. + assumption. + intros. + apply H3. + assumption. + assumption. + assumption. +Qed. + +(*###########################################################################*) +(** Properties of Zmax *) +(*###########################################################################*) + +Definition Zmax (n m : Z) := (n + m - Zmin n m)%Z. + +Lemma ZmaxSS : forall n m : Z, (Zmax n m + 1)%Z = Zmax (n + 1) (m + 1). +Proof. + intros. + unfold Zmax in |- *. + replace (Zmin (n + 1) (m + 1)) with (Zmin n m + 1)%Z. + ring. + symmetry in |- *. + change (Zmin (Zsucc n) (Zsucc m) = Zsucc (Zmin n m)) in |- *. + symmetry in |- *. + apply Zmin_SS. +Qed. + +Lemma Zle_max_l : forall n m : Z, (n <= Zmax n m)%Z. +Proof. + intros. + unfold Zmax in |- *. + apply Zplus_le_reg_l with (p := (- n + Zmin n m)%Z). + ring_simplify (- n + Zmin n m + n)%Z. + ring_simplify (- n + Zmin n m + (n + m - Zmin n m))%Z. + apply Zle_min_r. +Qed. + +Lemma Zle_max_r : forall n m : Z, (m <= Zmax n m)%Z. +Proof. + intros. + unfold Zmax in |- *. + apply Zplus_le_reg_l with (p := (- m + Zmin n m)%Z). + ring_simplify (- m + Zmin n m + m)%Z. + ring_simplify (- m + Zmin n m + (n + m - Zmin n m))%Z. + apply Zle_min_l. +Qed. + + +Lemma Zmin_or_informative : forall n m : Z, {Zmin n m = n} + {Zmin n m = m}. +Proof. + intros. + case (Z_lt_ge_dec n m). + unfold Zmin in |- *. + unfold Zlt in |- *. + intro z. + rewrite z. + left. + reflexivity. + intro. + cut ({(n > m)%Z} + {n = m :>Z}). + intro. + case H. + intros z0. + unfold Zmin in |- *. + unfold Zgt in z0. + rewrite z0. + right. + reflexivity. + intro. + rewrite e. + right. + apply Zmin_n_n. + cut ({(m < n)%Z} + {m = n :>Z}). + intro. + elim H. + intro. + left. + apply Zlt_gt. + assumption. + intro. + right. + symmetry in |- *. + assumption. + apply Z_le_lt_eq_dec. + apply Zge_le. + assumption. +Qed. + +Lemma Zmax_case : forall (n m : Z) (P : Z -> Set), P n -> P m -> P (Zmax n m). +Proof. + intros. + unfold Zmax in |- *. + case Zmin_or_informative with (n := n) (m := m). + intro. + rewrite e. + cut ((n + m - n)%Z = m). + intro. + rewrite H1. + assumption. + ring. + intro. + rewrite e. + cut ((n + m - m)%Z = n). + intro. + rewrite H1. + assumption. + ring. +Qed. + +Lemma Zmax_or_informative : forall n m : Z, {Zmax n m = n} + {Zmax n m = m}. +Proof. + intros. + unfold Zmax in |- *. + case Zmin_or_informative with (n := n) (m := m). + intro. + rewrite e. + right. + ring. + intro. + rewrite e. + left. + ring. +Qed. + +Lemma Zmax_n_n : forall n : Z, Zmax n n = n. +Proof. + intros. + unfold Zmax in |- *. + rewrite (Zmin_n_n n). + ring. +Qed. + +Hint Resolve ZmaxSS Zle_max_r Zle_max_l Zmax_n_n: zarith. + +(*###########################################################################*) +(** Properties of Arity *) +(*###########################################################################*) + +Lemma Zeven_S : forall x : Z, Zeven.Zodd x -> Zeven.Zeven (x + 1). +Proof. + exact Zeven.Zeven_Sn. +Qed. + +Lemma Zeven_pred : forall x : Z, Zeven.Zodd x -> Zeven.Zeven (x - 1). +Proof. + exact Zeven.Zeven_pred. +Qed. + +(* This lemma used to be useful since it was mentioned with an unnecessary premise + `x>=0` as Z_modulo_2 in ZArith, but the ZArith version has been fixed. *) + +Definition Z_modulo_2_always : + forall x : Z, {y : Z | x = (2 * y)%Z} + {y : Z | x = (2 * y + 1)%Z} := + Zeven.Z_modulo_2. + +(*###########################################################################*) +(** Properties of Zdiv *) +(*###########################################################################*) + +Lemma Z_div_mod_eq_2 : + forall a b : Z, (0 < b)%Z -> (b * (a / b))%Z = (a - a mod b)%Z. +Proof. + intros. + apply Zplus_minus_eq. + rewrite Zplus_comm. + apply Z_div_mod_eq. + Flip. +Qed. + +Lemma Z_div_le : + forall a b c : Z, (0 < c)%Z -> (b <= a)%Z -> (b / c <= a / c)%Z. +Proof. + intros. + apply Zge_le. + apply Z_div_ge; Flip; assumption. +Qed. + +Lemma Z_div_nonneg : + forall a b : Z, (0 < b)%Z -> (0 <= a)%Z -> (0 <= a / b)%Z. +Proof. + intros. + apply Zge_le. + apply Z_div_ge0; Flip; assumption. +Qed. + +Lemma Z_div_neg : forall a b : Z, (0 < b)%Z -> (a < 0)%Z -> (a / b < 0)%Z. +Proof. + intros. + rewrite (Z_div_mod_eq a b) in H0. + elim (Z_mod_lt a b). + intros H1 _. + apply Znot_ge_lt. + intro. + apply (Zlt_not_le (b * (a / b) + a mod b) 0 H0). + apply Zplus_le_0_compat. + apply Zmult_le_0_compat. + apply Zlt_le_weak; assumption. + Flip. + assumption. + Flip. + Flip. +Qed. + +Hint Resolve Z_div_mod_eq_2 Z_div_le Z_div_nonneg Z_div_neg: zarith. + +(*###########################################################################*) +(** Properties of Zpower *) +(*###########################################################################*) + +Lemma Zpower_1 : forall a : Z, (a ^ 1)%Z = a. +Proof. + intros; unfold Zpower in |- *; unfold Zpower_pos in |- *; simpl in |- *; + auto with zarith. +Qed. + +Lemma Zpower_2 : forall a : Z, (a ^ 2)%Z = (a * a)%Z. +Proof. + intros; unfold Zpower in |- *; unfold Zpower_pos in |- *; simpl in |- *; + ring. +Qed. + +Hint Resolve Zpower_1 Zpower_2: zarith. diff --git a/test-suite/success/AdvancedCanonicalStructure.v b/test-suite/success/AdvancedCanonicalStructure.v index 97cf316c..d819dc47 100644 --- a/test-suite/success/AdvancedCanonicalStructure.v +++ b/test-suite/success/AdvancedCanonicalStructure.v @@ -47,6 +47,24 @@ Goal forall a1 a2, eqA (plusA a1 zeroA) a2. change (eqB (plusB (phi a1) zeroB) (phi a2)). Admitted. +Variable foo : A -> Type. + +Definition local0 := fun (a1 : A) (a2 : A) (a3 : A) => + (eq_refl : plusA a1 (plusA zeroA a2) = ia _). +Definition local1 := + fun (a1 : A) (a2 : A) (f : A -> A) => + (eq_refl : plusA a1 (plusA zeroA (f a2)) = ia _). + +Definition local2 := + fun (a1 : A) (f : A -> A) => + (eq_refl : (f a1) = ia _). + +Goal forall a1 a2, eqA (plusA a1 zeroA) a2. + intros a1 a2. + refine (eq_img _ _ _). +change (eqB (plusB (phi a1) zeroB) (phi a2)). +Admitted. + End group_morphism. Open Scope type_scope. @@ -129,13 +147,3 @@ Admitted. Check L : abs _ . End type_reification. - - - - - - - - - - diff --git a/test-suite/success/Case11.v b/test-suite/success/Case11.v index fd5d139c..445ffac8 100644 --- a/test-suite/success/Case11.v +++ b/test-suite/success/Case11.v @@ -1,5 +1,5 @@ -(* L'algo d'infrence du prdicat doit grer le K-rdex dans le type de b *) -(* Problme rapport par Solange Coupet *) +(* L'algo d'inférence du prédicat doit gérer le K-rédex dans le type de b *) +(* Problème rapporté par Solange Coupet *) Section A. @@ -7,7 +7,7 @@ Variables (Alpha : Set) (Beta : Set). Definition nodep_prod_of_dep (c : sigS (fun a : Alpha => Beta)) : Alpha * Beta := match c with - | existS a b => (a, b) + | existS _ a b => (a, b) end. End A. diff --git a/test-suite/success/Case12.v b/test-suite/success/Case12.v index 729ab824..55e17fac 100644 --- a/test-suite/success/Case12.v +++ b/test-suite/success/Case12.v @@ -68,6 +68,6 @@ Inductive list''' (A:Set) (B:=(A*A)%type) (a:A) : B -> Set := Fixpoint length''' (A:Set) (B:=(A*A)%type) (a:A) (m:B) (l:list''' A a m) {struct l} : nat := match l with - | nil''' => 0 - | cons''' _ m l0 => S (length''' A a m l0) + | nil''' _ _ => 0 + | @cons''' _ _ _ _ m l0 => S (length''' A a m l0) end. diff --git a/test-suite/success/Case16.v b/test-suite/success/Case16.v index 77016bbf..ce9a0ecb 100644 --- a/test-suite/success/Case16.v +++ b/test-suite/success/Case16.v @@ -5,6 +5,6 @@ Check (fun x : {b : bool | if b then True else False} => match x return (let (b, _) := x in if b then True else False) with - | exist true y => y - | exist false z => z + | exist _ true y => y + | exist _ false z => z end). diff --git a/test-suite/success/Case17.v b/test-suite/success/Case17.v index 66af9e0d..861d0466 100644 --- a/test-suite/success/Case17.v +++ b/test-suite/success/Case17.v @@ -19,10 +19,10 @@ Axiom HHH : forall A : Prop, A. Check (match rec l0 (HHH _) with - | inleft (existS (false :: l1) _) => inright _ (HHH _) - | inleft (existS (true :: l1) (exist t1 (conj Hp Hl))) => + | inleft (existS _ (false :: l1) _) => inright _ (HHH _) + | inleft (existS _ (true :: l1) (exist _ t1 (conj Hp Hl))) => inright _ (HHH _) - | inleft (existS _ _) => inright _ (HHH _) + | inleft (existS _ _ _) => inright _ (HHH _) | inright Hnp => inright _ (HHH _) end :{l'' : list bool & @@ -39,10 +39,10 @@ Check {t : nat | parse_rel l' l'' t /\ length l'' <= length l'}} + {(forall (l'' : list bool) (t : nat), ~ parse_rel l' l'' t)}) => match rec l0 (HHH _) with - | inleft (existS (false :: l1) _) => inright _ (HHH _) - | inleft (existS (true :: l1) (exist t1 (conj Hp Hl))) => + | inleft (existS _ (false :: l1) _) => inright _ (HHH _) + | inleft (existS _ (true :: l1) (exist _ t1 (conj Hp Hl))) => inright _ (HHH _) - | inleft (existS _ _) => inright _ (HHH _) + | inleft (existS _ _ _) => inright _ (HHH _) | inright Hnp => inright _ (HHH _) end :{l'' : list bool & diff --git a/test-suite/success/Case20.v b/test-suite/success/Case20.v new file mode 100644 index 00000000..67eebf72 --- /dev/null +++ b/test-suite/success/Case20.v @@ -0,0 +1,35 @@ +(* Example taken from RelationAlgebra *) +(* Was failing from r16205 up to now *) + +Require Import BinNums. + +Section A. + +Context (A:Type) {X: A} (tst:A->Type) (top:forall X, X). + +Inductive v: (positive -> A) -> Type := +| v_L: forall f', v f' +| v_N: forall f', + v (fun n => f' (xO n)) -> + (positive -> tst (f' xH)) -> + v (fun n => f' (xI n)) -> v f'. + +Fixpoint v_add f' (t: v f') n: (positive -> tst (f' n)) -> v f' := + match t in (v o) return ((positive -> (tst (o n))) -> v o) with + | v_L f' => + match n return ((positive -> (tst (f' n))) -> v f') with + | xH => fun x => v_N _ (v_L _) x (v_L _) + | xO n => fun x => v_N _ + (v_add (fun n => f' (xO n)) (v_L _) n x) (fun _ => top _) (v_L _) + | xI n => fun x => v_N _ + (v_L _) (fun _ => top _) (v_add (fun n => f' (xI n)) (v_L _) n x) + end + | v_N f' l y r => + match n with + | xH => fun x => v_N _ l x r + | xO n => fun x => v_N _ (v_add (fun n => f' (xO n)) l n x) y r + | xI n => fun x => v_N _ l y (v_add (fun n => f' (xI n)) r n x) + end + end. + +End A. diff --git a/test-suite/success/Case21.v b/test-suite/success/Case21.v new file mode 100644 index 00000000..db91eb40 --- /dev/null +++ b/test-suite/success/Case21.v @@ -0,0 +1,15 @@ +(* Check insertion of impossible case when there is no branch at all *) + +Inductive eq_true : bool -> Prop := is_eq_true : eq_true true. + +Check fun H:eq_true false => match H with end : False. + +Inductive I : bool -> bool -> Prop := C : I true true. + +Check fun x (H:I x false) => match H with end : False. + +Check fun x (H:I false x) => match H with end : False. + +Inductive I' : bool -> Type := C1 : I' true | C2 : I' true. + +Check fun x : I' false => match x with end : False. diff --git a/test-suite/success/Case22.v b/test-suite/success/Case22.v new file mode 100644 index 00000000..4eb2dbe9 --- /dev/null +++ b/test-suite/success/Case22.v @@ -0,0 +1,7 @@ +(* Check typing in the presence of let-in in inductive arity *) + +Inductive I : let a := 1 in a=a -> let b := 2 in Type := C : I (eq_refl). +Lemma a : forall x:I eq_refl, match x in I a b c return b = b with C => eq_refl end = eq_refl. +intro. +match goal with |- ?c => let x := eval cbv in c in change x end. +Abort. diff --git a/test-suite/success/Case7.v b/test-suite/success/Case7.v index 6e4b2003..f95598aa 100644 --- a/test-suite/success/Case7.v +++ b/test-suite/success/Case7.v @@ -12,6 +12,6 @@ Parameter Type (fun (A : Set) (l : List A) => match l return (Empty A l \/ ~ Empty A l) with - | Nil => or_introl (~ Empty A (Nil A)) (intro_Empty A) - | Cons a y as b => or_intror (Empty A b) (inv_Empty A a y) + | Nil _ => or_introl (~ Empty A (Nil A)) (intro_Empty A) + | Cons _ a y as b => or_intror (Empty A b) (inv_Empty A a y) end). diff --git a/test-suite/success/Case9.v b/test-suite/success/Case9.v index a8534a0b..e34e5b9b 100644 --- a/test-suite/success/Case9.v +++ b/test-suite/success/Case9.v @@ -36,10 +36,10 @@ Parameter Fixpoint eqlongdec (x y : List nat) {struct x} : eqlong x y \/ ~ eqlong x y := match x, y return (eqlong x y \/ ~ eqlong x y) with - | Nil, Nil => or_introl (~ eqlong (Nil nat) (Nil nat)) eql_nil - | Nil, Cons a x as L => or_intror (eqlong (Nil nat) L) (inv_r a x) - | Cons a x as L, Nil => or_intror (eqlong L (Nil nat)) (inv_l a x) - | Cons a x as L1, Cons b y as L2 => + | Nil _, Nil _ => or_introl (~ eqlong (Nil nat) (Nil nat)) eql_nil + | Nil _, Cons _ a x as L => or_intror (eqlong (Nil nat) L) (inv_r a x) + | Cons _ a x as L, Nil _ => or_intror (eqlong L (Nil nat)) (inv_l a x) + | Cons _ a x as L1, Cons _ b y as L2 => match eqlongdec x y return (eqlong L1 L2 \/ ~ eqlong L1 L2) with | or_introl h => or_introl (~ eqlong L1 L2) (eql_cons a b x y h) | or_intror h => or_intror (eqlong L1 L2) (nff a b x y h) @@ -49,10 +49,10 @@ Fixpoint eqlongdec (x y : List nat) {struct x} : Type match Nil nat as x, Nil nat as y return (eqlong x y \/ ~ eqlong x y) with - | Nil, Nil => or_introl (~ eqlong (Nil nat) (Nil nat)) eql_nil - | Nil, Cons a x as L => or_intror (eqlong (Nil nat) L) (inv_r a x) - | Cons a x as L, Nil => or_intror (eqlong L (Nil nat)) (inv_l a x) - | Cons a x as L1, Cons b y as L2 => + | Nil _, Nil _ => or_introl (~ eqlong (Nil nat) (Nil nat)) eql_nil + | Nil _, Cons _ a x as L => or_intror (eqlong (Nil nat) L) (inv_r a x) + | Cons _ a x as L, Nil _ => or_intror (eqlong L (Nil nat)) (inv_l a x) + | Cons _ a x as L1, Cons _ b y as L2 => match eqlongdec x y return (eqlong L1 L2 \/ ~ eqlong L1 L2) with | or_introl h => or_introl (~ eqlong L1 L2) (eql_cons a b x y h) | or_intror h => or_intror (eqlong L1 L2) (nff a b x y h) diff --git a/test-suite/success/CaseInClause.v b/test-suite/success/CaseInClause.v new file mode 100644 index 00000000..3679eead --- /dev/null +++ b/test-suite/success/CaseInClause.v @@ -0,0 +1,22 @@ +(* in clause pattern *) +Require Vector. +Check (fun n (x: Vector.t True (S n)) => + match x in Vector.t _ (S m) return True with + |Vector.cons _ h _ _ => h + end). + +(* Notation *) +Import Vector.VectorNotations. +Notation "A \dots n" := (Vector.t A n) (at level 200). +Check (fun m (x: Vector.t nat m) => + match x in _ \dots k return Vector.t nat (S k) with + | Vector.nil _ => 0 :: [] + | Vector.cons _ h _ t => h :: h :: t + end). + +(* N should be a variable and not the inductiveRef *) +Require Import NArith. +Theorem foo : forall (n m : nat) (pf : n = m), + match pf in _ = N with + | eq_refl => unit + end. diff --git a/test-suite/success/Cases-bug1834.v b/test-suite/success/Cases-bug1834.v index 543ca0c9..cf102486 100644 --- a/test-suite/success/Cases-bug1834.v +++ b/test-suite/success/Cases-bug1834.v @@ -7,7 +7,7 @@ Definition T := sig P. Parameter Q : T -> Prop. Definition U := sig Q. Parameter a : U. -Check (match a with exist (exist tt e2) e3 => e3=e3 end). +Check (match a with exist _ (exist _ tt e2) e3 => e3=e3 end). (* There is still a form submitted by Pierre Corbineau (#1834) which fails *) diff --git a/test-suite/success/Cases-bug3758.v b/test-suite/success/Cases-bug3758.v new file mode 100644 index 00000000..e48f4523 --- /dev/null +++ b/test-suite/success/Cases-bug3758.v @@ -0,0 +1,17 @@ +(* There used to be an evar leak in the to_nat example *) + +Require Import Coq.Lists.List. +Import ListNotations. + +Fixpoint Idx {A:Type} (l:list A) : Type := + match l with + | [] => False + | _::l => True + Idx l + end. + +Fixpoint to_nat {A:Type} (l:list A) (i:Idx l) : nat := + match l,i with + | [] , i => match i with end + | _::_, inl _ => 0 + | _::l, inr i => S (to_nat l i) + end. diff --git a/test-suite/success/Cases.v b/test-suite/success/Cases.v index c9a3c08e..e4266350 100644 --- a/test-suite/success/Cases.v +++ b/test-suite/success/Cases.v @@ -2,21 +2,21 @@ (* Pattern-matching when non inductive terms occur *) (* Dependent form of annotation *) -Type match 0 as n, eq return nat with +Type match 0 as n, @eq return nat with | O, x => 0 | S x, y => x end. -Type match 0, eq, 0 return nat with +Type match 0, 0, @eq return nat with | O, x, y => 0 | S x, y, z => x end. -Type match 0, eq, 0 return _ with +Type match 0, @eq, 0 return _ with | O, x, y => 0 | S x, y, z => x end. (* Non dependent form of annotation *) -Type match 0, eq return nat with +Type match 0, @eq return nat with | O, x => 0 | S x, y => x end. @@ -309,43 +309,43 @@ Type Type (fun l : List nat => match l return (List nat) with - | Nil => Nil nat - | Cons a l => l + | Nil _ => Nil nat + | Cons _ a l => l end). Type (fun l : List nat => match l with - | Nil => Nil nat - | Cons a l => l + | Nil _ => Nil nat + | Cons _ a l => l end). Type match Nil nat return nat with - | Nil => 0 - | Cons a l => S a + | Nil _ => 0 + | Cons _ a l => S a end. Type match Nil nat with - | Nil => 0 - | Cons a l => S a + | Nil _ => 0 + | Cons _ a l => S a end. Type match Nil nat return (List nat) with - | Cons a l => l + | Cons _ a l => l | x => x end. Type match Nil nat with - | Cons a l => l + | Cons _ a l => l | x => x end. Type match Nil nat return (List nat) with - | Nil => Nil nat - | Cons a l => l + | Nil _ => Nil nat + | Cons _ a l => l end. Type match Nil nat with - | Nil => Nil nat - | Cons a l => l + | Nil _ => Nil nat + | Cons _ a l => l end. @@ -353,8 +353,8 @@ Type match 0 return nat with | O => 0 | S x => match Nil nat return nat with - | Nil => x - | Cons a l => x + a + | Nil _ => x + | Cons _ a l => x + a end end. @@ -362,8 +362,8 @@ Type match 0 with | O => 0 | S x => match Nil nat with - | Nil => x - | Cons a l => x + a + | Nil _ => x + | Cons _ a l => x + a end end. @@ -372,8 +372,8 @@ Type match y with | O => 0 | S x => match Nil nat with - | Nil => x - | Cons a l => x + a + | Nil _ => x + | Cons _ a l => x + a end end). @@ -381,8 +381,8 @@ Type Type match 0, Nil nat return nat with | O, x => 0 - | S x, Nil => x - | S x, Cons a l => x + a + | S x, Nil _ => x + | S x, Cons _ a l => x + a end. @@ -597,71 +597,60 @@ Type Type (fun (A : Set) (n : nat) (l : Listn A n) => match l return nat with - | Niln => 0 - | Consn n a Niln => 0 - | Consn n a (Consn m b l) => n + m + | Niln _ => 0 + | Consn _ n a (Niln _) => 0 + | Consn _ n a (Consn _ m b l) => n + m end). Type (fun (A : Set) (n : nat) (l : Listn A n) => match l with - | Niln => 0 - | Consn n a Niln => 0 - | Consn n a (Consn m b l) => n + m + | Niln _ => 0 + | Consn _ n a (Niln _) => 0 + | Consn _ n a (Consn _ m b l) => n + m end). -(* This example was deactivated in Cristina's code - Type (fun (A:Set) (n:nat) (l:Listn A n) => match l return Listn A O with - | Niln as b => b - | Consn n a (Niln as b) => (Niln A) - | Consn n a (Consn m b l) => (Niln A) + | Niln _ as b => b + | Consn _ n a (Niln _ as b) => (Niln A) + | Consn _ n a (Consn _ m b l) => (Niln A) end). -*) - -(* This one is (still) failing: too weak unification +(* Type (fun (A:Set) (n:nat) (l:Listn A n) => match l with - | Niln as b => b - | Consn n a (Niln as b) => (Niln A) - | Consn n a (Consn m b l) => (Niln A) + | Niln _ as b => b + | Consn _ n a (Niln _ as b) => (Niln A) + | Consn _ n a (Consn _ m b l) => (Niln A) end). *) -(* This one is failing: alias L not chosen of the right type - Type (fun (A:Set) (n:nat) (l:Listn A n) => match l return Listn A (S 0) with - | Niln as b => Consn A O O b - | Consn n a Niln as L => L - | Consn n a _ => Consn A O O (Niln A) + | Niln _ as b => Consn A O O b + | Consn _ n a (Niln _) as L => L + | Consn _ n a _ => Consn A O O (Niln A) end). -*) - -(******** This example (still) failed Type (fun (A:Set) (n:nat) (l:Listn A n) => match l return Listn A (S 0) with - | Niln as b => Consn A O O b - | Consn n a Niln as L => L - | Consn n a _ => Consn A O O (Niln A) + | Niln _ as b => Consn A O O b + | Consn _ n a (Niln _) as L => L + | Consn _ n a _ => Consn A O O (Niln A) end). -**********) - (* To test treatment of as-patterns in depth *) Type (fun (A : Set) (l : List A) => match l with - | Nil as b => Nil A - | Cons a Nil as L => L - | Cons a (Cons b m) as L => L + | Nil _ as b => Nil A + | Cons _ a (Nil _) as L => L + | Cons _ a (Cons _ b m) as L => L end). @@ -704,40 +693,40 @@ Type Type (fun (A : Set) (n : nat) (l : Listn A n) => match l with - | Niln as b => l + | Niln _ as b => l | _ => l end). Type (fun (A : Set) (n : nat) (l : Listn A n) => match l return (Listn A n) with - | Niln => l - | Consn n a Niln => l - | Consn n a (Consn m b c) => l + | Niln _ => l + | Consn _ n a (Niln _) => l + | Consn _ n a (Consn _ m b c) => l end). Type (fun (A : Set) (n : nat) (l : Listn A n) => match l with - | Niln => l - | Consn n a Niln => l - | Consn n a (Consn m b c) => l + | Niln _ => l + | Consn _ n a (Niln _) => l + | Consn _ n a (Consn _ m b c) => l end). Type (fun (A : Set) (n : nat) (l : Listn A n) => match l return (Listn A n) with - | Niln as b => l - | Consn n a (Niln as b) => l - | Consn n a (Consn m b _) => l + | Niln _ as b => l + | Consn _ n a (Niln _ as b) => l + | Consn _ n a (Consn _ m b _) => l end). Type (fun (A : Set) (n : nat) (l : Listn A n) => match l with - | Niln as b => l - | Consn n a (Niln as b) => l - | Consn n a (Consn m b _) => l + | Niln _ as b => l + | Consn _ n a (Niln _ as b) => l + | Consn _ n a (Consn _ m b _) => l end). @@ -770,40 +759,40 @@ Type match LeO 0 with Type (fun (n : nat) (l : Listn nat n) => match l return nat with - | Niln => 0 - | Consn n a l => 0 + | Niln _ => 0 + | Consn _ n a l => 0 end). Type (fun (n : nat) (l : Listn nat n) => match l with - | Niln => 0 - | Consn n a l => 0 + | Niln _ => 0 + | Consn _ n a l => 0 end). Type match Niln nat with - | Niln => 0 - | Consn n a l => 0 + | Niln _ => 0 + | Consn _ n a l => 0 end. Type match LE_n 0 return nat with - | LE_n => 0 - | LE_S m h => 0 + | LE_n _ => 0 + | LE_S _ m h => 0 end. Type match LE_n 0 with - | LE_n => 0 - | LE_S m h => 0 + | LE_n _ => 0 + | LE_S _ m h => 0 end. Type match LE_n 0 with - | LE_n => 0 - | LE_S m h => 0 + | LE_n _ => 0 + | LE_S _ m h => 0 end. @@ -825,16 +814,17 @@ Type Type match Niln nat return nat with - | Niln => 0 - | Consn n a Niln => n - | Consn n a (Consn m b l) => n + m + | Niln _ => 0 + | Consn _ n a (Niln _ +) => n + | Consn _ n a (Consn _ m b l) => n + m end. Type match Niln nat with - | Niln => 0 - | Consn n a Niln => n - | Consn n a (Consn m b l) => n + m + | Niln _ => 0 + | Consn _ n a (Niln _) => n + | Consn _ n a (Consn _ m b l) => n + m end. @@ -1027,17 +1017,17 @@ Type Type match LE_n 0 return nat with - | LE_n => 0 - | LE_S m LE_n => 0 + m - | LE_S m (LE_S y h) => 0 + m + | LE_n _ => 0 + | LE_S _ m (LE_n _) => 0 + m + | LE_S _ m (LE_S _ y h) => 0 + m end. Type match LE_n 0 with - | LE_n => 0 - | LE_S m LE_n => 0 + m - | LE_S m (LE_S y h) => 0 + m + | LE_n _ => 0 + | LE_S _ m (LE_n _) => 0 + m + | LE_S _ m (LE_S _ y h) => 0 + m end. @@ -1077,25 +1067,25 @@ Type Type (fun (A : Set) (n : nat) (l : Listn A n) => match l return (nat -> nat) with - | Niln => fun _ : nat => 0 - | Consn n a Niln => fun _ : nat => n - | Consn n a (Consn m b l) => fun _ : nat => n + m + | Niln _ => fun _ : nat => 0 + | Consn _ n a (Niln _) => fun _ : nat => n + | Consn _ n a (Consn _ m b l) => fun _ : nat => n + m end). Type (fun (A : Set) (n : nat) (l : Listn A n) => match l with - | Niln => fun _ : nat => 0 - | Consn n a Niln => fun _ : nat => n - | Consn n a (Consn m b l) => fun _ : nat => n + m + | Niln _ => fun _ : nat => 0 + | Consn _ n a (Niln _) => fun _ : nat => n + | Consn _ n a (Consn _ m b l) => fun _ : nat => n + m end). (* Also tests for multiple _ patterns *) Type (fun (A : Set) (n : nat) (l : Listn A n) => match l in (Listn _ n) return (Listn A n) with - | Niln as b => b - | Consn _ _ _ as b => b + | Niln _ as b => b + | Consn _ _ _ _ as b => b end). (** This one was said to raised once an "Horrible error message!" *) @@ -1103,8 +1093,8 @@ Type Type (fun (A:Set) (n:nat) (l:Listn A n) => match l with - | Niln as b => b - | Consn _ _ _ as b => b + | Niln _ as b => b + | Consn _ _ _ _ as b => b end). Type @@ -1123,26 +1113,26 @@ Type Type (fun (n m : nat) (h : LE n m) => match h return (nat -> nat) with - | LE_n => fun _ : nat => n - | LE_S m LE_n => fun _ : nat => n + m - | LE_S m (LE_S y h) => fun _ : nat => m + y + | LE_n _ => fun _ : nat => n + | LE_S _ m (LE_n _) => fun _ : nat => n + m + | LE_S _ m (LE_S _ y h) => fun _ : nat => m + y end). Type (fun (n m : nat) (h : LE n m) => match h with - | LE_n => fun _ : nat => n - | LE_S m LE_n => fun _ : nat => n + m - | LE_S m (LE_S y h) => fun _ : nat => m + y + | LE_n _ => fun _ : nat => n + | LE_S _ m (LE_n _) => fun _ : nat => n + m + | LE_S _ m (LE_S _ y h) => fun _ : nat => m + y end). Type (fun (n m : nat) (h : LE n m) => match h return nat with - | LE_n => n - | LE_S m LE_n => n + m - | LE_S m (LE_S y LE_n) => n + m + y - | LE_S m (LE_S y (LE_S y' h)) => n + m + (y + y') + | LE_n _ => n + | LE_S _ m (LE_n _) => n + m + | LE_S _ m (LE_S _ y (LE_n _)) => n + m + y + | LE_S _ m (LE_S _ y (LE_S _ y' h)) => n + m + (y + y') end). @@ -1150,28 +1140,28 @@ Type Type (fun (n m : nat) (h : LE n m) => match h with - | LE_n => n - | LE_S m LE_n => n + m - | LE_S m (LE_S y LE_n) => n + m + y - | LE_S m (LE_S y (LE_S y' h)) => n + m + (y + y') + | LE_n _ => n + | LE_S _ m (LE_n _) => n + m + | LE_S _ m (LE_S _ y (LE_n _)) => n + m + y + | LE_S _ m (LE_S _ y (LE_S _ y' h)) => n + m + (y + y') end). Type (fun (n m : nat) (h : LE n m) => match h return nat with - | LE_n => n - | LE_S m LE_n => n + m - | LE_S m (LE_S y h) => n + m + y + | LE_n _ => n + | LE_S _ m (LE_n _) => n + m + | LE_S _ m (LE_S _ y h) => n + m + y end). Type (fun (n m : nat) (h : LE n m) => match h with - | LE_n => n - | LE_S m LE_n => n + m - | LE_S m (LE_S y h) => n + m + y + | LE_n _ => n + | LE_S _ m (LE_n _) => n + m + | LE_S _ m (LE_S _ y h) => n + m + y end). Type @@ -1231,14 +1221,14 @@ Parameter B : Set. Type (fun (P : nat -> B -> Prop) (x : SStream B P) => match x return B with - | scons _ a _ _ => a + | scons _ _ a _ _ => a end). Type (fun (P : nat -> B -> Prop) (x : SStream B P) => match x with - | scons _ a _ _ => a + | scons _ _ a _ _ => a end). Type match (0, 0) return (nat * nat) with @@ -1267,14 +1257,14 @@ Parameter concat : forall A : Set, List A -> List A -> List A. Type match Nil nat, Nil nat return (List nat) with - | Nil as b, x => concat nat b x - | Cons _ _ as d, Nil as c => concat nat d c + | Nil _ as b, x => concat nat b x + | Cons _ _ _ as d, Nil _ as c => concat nat d c | _, _ => Nil nat end. Type match Nil nat, Nil nat with - | Nil as b, x => concat nat b x - | Cons _ _ as d, Nil as c => concat nat d c + | Nil _ as b, x => concat nat b x + | Cons _ _ _ as d, Nil _ as c => concat nat d c | _, _ => Nil nat end. @@ -1415,7 +1405,7 @@ Parameter p : eq_prf. Type match p with - | ex_intro c eqc => + | ex_intro _ c eqc => match eq_nat_dec c n with | right _ => refl_equal n | left y => (* c=n*) refl_equal n @@ -1438,7 +1428,7 @@ Type (fun N : nat => match N_cla N with | inright H => match exist_U2 N H with - | exist a b => a + | exist _ a b => a end | _ => 0 end). @@ -1636,8 +1626,8 @@ Parameter Type match Nil nat as l return (Empty nat l \/ ~ Empty nat l) with - | Nil => or_introl (~ Empty nat (Nil nat)) (intro_Empty nat) - | Cons a y => or_intror (Empty nat (Cons nat a y)) (inv_Empty nat a y) + | Nil _ => or_introl (~ Empty nat (Nil nat)) (intro_Empty nat) + | Cons _ a y => or_intror (Empty nat (Cons nat a y)) (inv_Empty nat a y) end. @@ -1687,20 +1677,20 @@ Parameter Type match Nil nat as x, Nil nat as y return (eqlong x y \/ ~ eqlong x y) with - | Nil, Nil => V1 - | Nil, Cons a x => V2 a x - | Cons a x, Nil => V3 a x - | Cons a x, Cons b y => V4 a x b y + | Nil _, Nil _ => V1 + | Nil _, Cons _ a x => V2 a x + | Cons _ a x, Nil _ => V3 a x + | Cons _ a x, Cons _ b y => V4 a x b y end. Type (fun x y : List nat => match x, y return (eqlong x y \/ ~ eqlong x y) with - | Nil, Nil => V1 - | Nil, Cons a x => V2 a x - | Cons a x, Nil => V3 a x - | Cons a x, Cons b y => V4 a x b y + | Nil _, Nil _ => V1 + | Nil _, Cons _ a x => V2 a x + | Cons _ a x, Nil _ => V3 a x + | Cons _ a x, Cons _ b y => V4 a x b y end). diff --git a/test-suite/success/CasesDep.v b/test-suite/success/CasesDep.v index bfead53c..8d9edbd6 100644 --- a/test-suite/success/CasesDep.v +++ b/test-suite/success/CasesDep.v @@ -4,8 +4,8 @@ Check (fun (P : nat -> Prop) Q (A : P 0 -> Q) (B : forall n : nat, P (S n) -> Q) x => match x return Q with - | exist O H => A H - | exist (S n) H => B n H + | exist _ O H => A H + | exist _ (S n) H => B n H end). (* Check dependencies in anonymous arguments (from FTA/listn.v) *) @@ -21,30 +21,30 @@ Variable c : C. Fixpoint foldrn (n : nat) (bs : listn B n) {struct bs} : C := match bs with - | niln => c - | consn b _ tl => g b (foldrn _ tl) + | niln _ => c + | consn _ b _ tl => g b (foldrn _ tl) end. End Folding. (** Testing post-processing of nested dependencies *) Check fun x:{x|x=0}*nat+nat => match x with - | inl ((exist 0 eq_refl),0) => None + | inl ((exist _ 0 eq_refl),0) => None | _ => Some 0 end. Check fun x:{_:{x|x=0}|True}+nat => match x with - | inl (exist (exist 0 eq_refl) I) => None + | inl (exist _ (exist _ 0 eq_refl) I) => None | _ => Some 0 end. Check fun x:{_:{x|x=0}|True}+nat => match x with - | inl (exist (exist 0 eq_refl) I) => None + | inl (exist _ (exist _ 0 eq_refl) I) => None | _ => Some 0 end. Check fun x:{_:{x|x=0}|True}+nat => match x return option nat with - | inl (exist (exist 0 eq_refl) I) => None + | inl (exist _ (exist _ 0 eq_refl) I) => None | _ => Some 0 end. @@ -52,11 +52,11 @@ Check fun x:{_:{x|x=0}|True}+nat => match x return option nat with (* due to a bug in dependencies postprocessing (revealed by CoLoR) *) Check fun x:{x:nat*nat|fst x = 0 & True} => match x return option nat with - | exist2 (x,y) eq_refl I => None + | exist2 _ _ (x,y) eq_refl I => None end. Check fun x:{_:{x:nat*nat|fst x = 0 & True}|True}+nat => match x return option nat with - | inl (exist (exist2 (x,y) eq_refl I) I) => None + | inl (exist _ (exist2 _ _ (x,y) eq_refl I) I) => None | _ => Some 0 end. @@ -521,8 +521,8 @@ end. Fixpoint app {A} {n m} (v : listn A n) (w : listn A m) : listn A (n + m) := match v with - | niln => w - | consn a n' v' => consn _ a _ (app v' w) + | niln _ => w + | consn _ a n' v' => consn _ a _ (app v' w) end. (* Testing regression of bug 2106 *) @@ -547,7 +547,7 @@ n'. Definition test (s:step E E) := match s with - | Step nil _ (cons E nil) _ Plus l l' => true + | @Step nil _ (cons E nil) _ Plus l l' => true | _ => false end. diff --git a/test-suite/success/Check.v b/test-suite/success/Check.v index 49c54916..87c38cfa 100644 --- a/test-suite/success/Check.v +++ b/test-suite/success/Check.v @@ -1,11 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* Compiling the theories allows to test parsing and typing but not printing *) +(* Compiling the theories allows testing parsing and typing but not printing *) (* This file tests that pretty-printing does not fail *) (* Test of exact output is not specified *) diff --git a/test-suite/success/Field.v b/test-suite/success/Field.v index cdf9d6da..8db08b6d 100644 --- a/test-suite/success/Field.v +++ b/test-suite/success/Field.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/success/Fixpoint.v b/test-suite/success/Fixpoint.v index 3a4f8899..5fc703cf 100644 --- a/test-suite/success/Fixpoint.v +++ b/test-suite/success/Fixpoint.v @@ -42,8 +42,8 @@ Variables (B C : Set) (g : B -> C -> C) (c : C). Fixpoint foldrn n bs := match bs with - | Vnil => c - | Vcons b _ tl => g b (foldrn _ tl) + | Vnil _ => c + | Vcons _ b _ tl => g b (foldrn _ tl) end. End folding. diff --git a/test-suite/success/Funind.v b/test-suite/success/Funind.v index ccce3bbe..3bf97c13 100644 --- a/test-suite/success/Funind.v +++ b/test-suite/success/Funind.v @@ -23,6 +23,7 @@ Function ftest (n m : nat) : nat := end | S p => 0 end. +(* MS: FIXME: apparently can't define R_ftest_complete. Rest of the file goes through. *) Lemma test1 : forall n m : nat, ftest n m <= 2. intros n m. @@ -150,7 +151,7 @@ Function nat_equal_bool (n m : nat) {struct n} : bool := Require Export Div2. - +Require Import Nat. Functional Scheme div2_ind := Induction for div2 Sort Prop. Lemma div2_inf : forall n : nat, div2 n <= n. intros n. @@ -233,11 +234,11 @@ Qed. Inductive istrue : bool -> Prop := istrue0 : istrue true. -Functional Scheme plus_ind := Induction for plus Sort Prop. +Functional Scheme add_ind := Induction for add Sort Prop. Lemma inf_x_plusxy' : forall x y : nat, x <= x + y. intros n m. - functional induction plus n m; intros. + functional induction add n m; intros. auto with arith. auto with arith. Qed. diff --git a/test-suite/success/ImplicitArguments.v b/test-suite/success/ImplicitArguments.v index 84ec298d..f702aa62 100644 --- a/test-suite/success/ImplicitArguments.v +++ b/test-suite/success/ImplicitArguments.v @@ -9,11 +9,15 @@ Require Import Coq.Program.Program. Program Definition head {A : Type} {n : nat} (v : vector A (S n)) : vector A n := match v with | vnil => ! - | vcons a n' v' => v' + | vcons a v' => v' end. Fixpoint app {A : Type} {n m : nat} (v : vector A n) (w : vector A m) : vector A (n + m) := match v in vector _ n return vector A (n + m) with | vnil => w - | vcons a n' v' => vcons a (app v' w) + | vcons a v' => vcons a (app v' w) end. + +(* Test sharing information between different hypotheses *) + +Parameters (a:_) (b:a=0). diff --git a/test-suite/success/Inductive.v b/test-suite/success/Inductive.v index da5dd5e4..3d425754 100644 --- a/test-suite/success/Inductive.v +++ b/test-suite/success/Inductive.v @@ -17,7 +17,7 @@ Check fun (P : forall A : Type, let B := A in A -> Type) (f : P True I) (A : Type) => let B := A in fun (a : A) (e : eq1 A a) => - match e in (eq1 A0 B0 a0) return (P A0 a0) with + match e in (@eq1 A0 B0 a0) return (P A0 a0) with | refl1 => f end. @@ -37,8 +37,8 @@ Check fun (x y : E -> F) (P : forall c : C, A C D x y c -> Type) (f : forall z : C, P z (I C D x y z)) (y0 : C) (a : A C D x y y0) => - match a as a0 in (A _ _ _ _ _ _ y1) return (P y1 a0) with - | I x0 => f x0 + match a as a0 in (A _ _ _ _ y1) return (P y1 a0) with + | I _ _ _ _ x0 => f x0 end). Record B (C D : Set) (E:=C) (F:=D) (x y : E -> F) : Set := {p : C; q : E}. @@ -51,7 +51,7 @@ Check (f : forall p0 q0 : C, P (Build_B C D x y p0 q0)) (b : B C D x y) => match b as b0 return (P b0) with - | Build_B x0 x1 => f x0 x1 + | Build_B _ _ _ _ x0 x1 => f x0 x1 end). (* Check inductive types with local definitions (constructors) *) @@ -107,3 +107,17 @@ Set Implicit Arguments. Inductive I A : A->Prop := C a : (forall A, A) -> I a. *) + +(* Test recursively non-uniform parameters (was formerly in params_ind.v) *) + +Inductive list (A : Set) : Set := + | nil : list A + | cons : A -> list (A -> A) -> list A. + +(* Check inference of evars in arity using information from constructors *) + +Inductive foo1 : forall p, Prop := cc1 : foo1 0. + +(* Check cross inference of evars from constructors *) + +Inductive foo2 : forall p, Prop := cc2 : forall q, foo2 q | cc3 : foo2 0. diff --git a/test-suite/success/Injection.v b/test-suite/success/Injection.v index c5cd7380..6a488244 100644 --- a/test-suite/success/Injection.v +++ b/test-suite/success/Injection.v @@ -39,7 +39,7 @@ Qed. (* Test injection as *) Lemma l5 : forall x y z t : nat, (x,y) = (z,t) -> x=z. -intros; injection H as Hyt Hxz. +intros; injection H as Hxz Hyt. exact Hxz. Qed. @@ -66,6 +66,56 @@ einjection (H O). instantiate (1:=O). Abort. +(* Test the injection intropattern *) + +Goal forall (a b:nat) l l', cons a l = cons b l' -> a=b. +intros * [= H1 H2]. +exact H1. +Qed. + +(* Test injection using K, knowing that an equality is decidable *) +(* Basic case, using sigT *) + +Scheme Equality for nat. +Goal forall n:nat, forall P:nat -> Type, forall H1 H2:P n, + existT P n H1 = existT P n H2 -> H1 = H2. +intros. +injection H. +intro H0. exact H0. +Abort. + +(* Test injection using K, knowing that an equality is decidable *) +(* Basic case, using sigT, with "as" clause *) + +Goal forall n:nat, forall P:nat -> Type, forall H1 H2:P n, + existT P n H1 = existT P n H2 -> H1 = H2. +intros. +injection H as H. +exact H. +Abort. + +(* Test injection using K, knowing that an equality is decidable *) +(* Dependent case not directly exposing sigT *) + +Inductive my_sig (A : Type) (P : A -> Type) : Type := + my_exist : forall x : A, P x -> my_sig A P. + +Goal forall n:nat, forall P:nat -> Type, forall H1 H2:P n, + my_exist _ _ n H1 = my_exist _ _ n H2 -> H1 = H2. +intros. +injection H as H. +exact H. +Abort. + +(* Test injection using K, knowing that an equality is decidable *) +(* Dependent case not directly exposing sigT deeply nested *) + +Goal forall n:nat, forall P:nat -> Type, forall H1 H2:P n, + (my_exist _ _ n H1,0) = (my_exist _ _ n H2,0) -> H1 = H2. +intros * [= H]. +exact H. +Abort. + (* Injection does not projects at positions in Prop... allow it? Inductive t (A:Prop) : Set := c : A -> t A. diff --git a/test-suite/success/Inversion.v b/test-suite/success/Inversion.v index b068f729..850f0943 100644 --- a/test-suite/success/Inversion.v +++ b/test-suite/success/Inversion.v @@ -136,3 +136,56 @@ Goal True -> True. intro. Fail inversion H using False. Fail inversion foo using True_ind. + +(* Was failing at some time between 7 and 10 September 2014 *) +(* even though, it is not clear that the resulting context is interesting *) + +Parameter P:nat*nat->Prop. +Inductive IND : nat * nat -> { x : nat * nat | P x } * nat -> Prop := +CONSTR a b (H:P (a,b)) c : IND (a,b) (exist _ (a,b) H, c). + +Goal forall x y z t u (H':P (z,t)), IND (x,y) (exist _ (z,t) H', u) -> x = z. +intros * Hyp. +inversion Hyp. + (* By the way, why is "H" removed even in non-clear mode ? *) +reflexivity. +Qed. + +Goal forall x y z t u (H':P (z,t)), IND (x,y) (exist _ (z,t) H', u) -> x = z. +intros * Hyp. +inversion Hyp as (a,b,H,c,(H1_1,H1_2),(H2_1,H2_2,H2_3)). +reflexivity. +Qed. + +(* Up to September 2014, Mapp below was called MApp0 because of a bug + in intro_replacing (short version of bug 2164.v) + (example taken from CoLoR) *) + +Parameter Term : Type. +Parameter isApp : Term -> Prop. +Parameter appBodyL : forall M, isApp M -> Prop. +Parameter lower : forall M Mapp, appBodyL M Mapp -> Term. + +Inductive BetaStep : Term -> Term -> Prop := + Beta M Mapp Mabs : BetaStep M (lower M Mapp Mabs). + +Goal forall M N, BetaStep M N -> True. +intros M N H. +inversion H as (P,Mapp,Mabs,H0,H1). +clear Mapp Mabs H0 H1. +exact Logic.I. +Qed. + +(* Up to September 2014, H0 below was renamed called H1 because of a collision + with the automaticallly generated names for equations. + (example taken from CoLoR) *) + +Inductive term := Var | Fun : term -> term -> term. +Inductive lt : term -> term -> Prop := + mpo f g ss ts : lt Var (Fun f ts) -> lt (Fun f ss) (Fun g ts). + +Goal forall f g ss ts, lt (Fun f ss) (Fun g ts) -> lt Var (Fun f ts). +intros. +inversion H as (f',g',ss',ts',H0). +exact H0. +Qed. diff --git a/test-suite/success/LegacyField.v b/test-suite/success/LegacyField.v deleted file mode 100644 index 9b2a2c6a..00000000 --- a/test-suite/success/LegacyField.v +++ /dev/null @@ -1,76 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(**** Tests of Field with real numbers ****) - -Require Import Reals LegacyRfield. - -(* Example 1 *) -Goal -forall eps : R, -(eps * (1 / (2 + 2)) + eps * (1 / (2 + 2)))%R = (eps * (1 / 2))%R. -Proof. - intros. - legacy field. -Abort. - -(* Example 2 *) -Goal -forall (f g : R -> R) (x0 x1 : R), -((f x1 - f x0) * (1 / (x1 - x0)) + (g x1 - g x0) * (1 / (x1 - x0)))%R = -((f x1 + g x1 - (f x0 + g x0)) * (1 / (x1 - x0)))%R. -Proof. - intros. - legacy field. -Abort. - -(* Example 3 *) -Goal forall a b : R, (1 / (a * b) * (1 / 1 / b))%R = (1 / a)%R. -Proof. - intros. - legacy field. -Abort. - -(* Example 4 *) -Goal -forall a b : R, a <> 0%R -> b <> 0%R -> (1 / (a * b) / 1 / b)%R = (1 / a)%R. -Proof. - intros. - legacy field. -Abort. - -(* Example 5 *) -Goal forall a : R, 1%R = (1 * (1 / a) * a)%R. -Proof. - intros. - legacy field. -Abort. - -(* Example 6 *) -Goal forall a b : R, b = (b * / a * a)%R. -Proof. - intros. - legacy field. -Abort. - -(* Example 7 *) -Goal forall a b : R, b = (b * (1 / a) * a)%R. -Proof. - intros. - legacy field. -Abort. - -(* Example 8 *) -Goal -forall x y : R, -(x * (1 / x + x / (x + y)))%R = -(- (1 / y) * y * (- (x * (x / (x + y))) - 1))%R. -Proof. - intros. - legacy field. -Abort. diff --git a/test-suite/success/LetPat.v b/test-suite/success/LetPat.v index 4c790680..0e557aee 100644 --- a/test-suite/success/LetPat.v +++ b/test-suite/success/LetPat.v @@ -9,22 +9,22 @@ Print l3. Record someT (A : Type) := mkT { a : nat; b: A }. -Definition l4 A (t : someT A) : nat := let 'mkT x y := t in x. +Definition l4 A (t : someT A) : nat := let 'mkT _ x y := t in x. Print l4. Print sigT. Definition l5 A (B : A -> Type) (t : sigT B) : B (projT1 t) := - let 'existT x y := t return B (projT1 t) in y. + let 'existT _ x y := t return B (projT1 t) in y. Definition l6 A (B : A -> Type) (t : sigT B) : B (projT1 t) := - let 'existT x y as t' := t return B (projT1 t') in y. + let 'existT _ x y as t' := t return B (projT1 t') in y. Definition l7 A (B : A -> Type) (t : sigT B) : B (projT1 t) := - let 'existT x y as t' in sigT _ := t return B (projT1 t') in y. + let 'existT _ x y as t' in sigT _ := t return B (projT1 t') in y. Definition l8 A (B : A -> Type) (t : sigT B) : B (projT1 t) := match t with - existT x y => y + existT _ x y => y end. (** An example from algebra, using let' and inference of return clauses diff --git a/test-suite/success/MatchFail.v b/test-suite/success/MatchFail.v index c2d87a44..7069bba4 100644 --- a/test-suite/success/MatchFail.v +++ b/test-suite/success/MatchFail.v @@ -4,7 +4,7 @@ Require Export ZArithRing. (* Cette tactique a pour objectif de remplacer toute instance de (POS (xI e)) ou de (POS (xO e)) par 2*(POS e)+1 ou 2*(POS e), pour rendre les expressions plus - mme d'tre utilises par Ring, lorsque ces expressions contiennent + à même d'être utilisées par Ring, lorsque ces expressions contiennent des variables de type positive. *) Ltac compute_POS := match goal with diff --git a/test-suite/success/NumberScopes.v b/test-suite/success/NumberScopes.v new file mode 100644 index 00000000..6d787210 --- /dev/null +++ b/test-suite/success/NumberScopes.v @@ -0,0 +1,62 @@ + +(* We check that various definitions or lemmas have the correct + argument scopes, especially the ones created via functor application. *) + +Close Scope nat_scope. + +Require Import PArith. +Check (Pos.add 1 2). +Check (Pos.add_comm 1 2). +Check (Pos.min_comm 1 2). +Definition f_pos (x:positive) := x. +Definition f_pos' (x:Pos.t) := x. +Check (f_pos 1). +Check (f_pos' 1). + +Require Import ZArith. +Check (Z.add 1 2). +Check (Z.add_comm 1 2). +Check (Z.min_comm 1 2). +Definition f_Z (x:Z) := x. +Definition f_Z' (x:Z.t) := x. +Check (f_Z 1). +Check (f_Z' 1). + +Require Import NArith. +Check (N.add 1 2). +Check (N.add_comm 1 2). +Check (N.min_comm 1 2). +Definition f_N (x:N) := x. +Definition f_N' (x:N.t) := x. +Check (f_N 1). +Check (f_N' 1). + +Require Import Arith. +Check (Nat.add 1 2). +Check (Nat.add_comm 1 2). +Check (Nat.min_comm 1 2). +Definition f_nat (x:nat) := x. +Definition f_nat' (x:Nat.t) := x. +Check (f_nat 1). +Check (f_nat' 1). + +Require Import BigN. +Check (BigN.add 1 2). +Check (BigN.add_comm 1 2). +Check (BigN.min_comm 1 2). +Definition f_bigN (x:bigN) := x. +Check (f_bigN 1). + +Require Import BigZ. +Check (BigZ.add 1 2). +Check (BigZ.add_comm 1 2). +Check (BigZ.min_comm 1 2). +Definition f_bigZ (x:bigZ) := x. +Check (f_bigZ 1). + +Require Import BigQ. +Check (BigQ.add 1 2). +Check (BigQ.add_comm 1 2). +Check (BigQ.min_comm 1 2). +Definition f_bigQ (x:bigQ) := x. +Check (f_bigQ 1).
\ No newline at end of file diff --git a/test-suite/success/ProgramWf.v b/test-suite/success/ProgramWf.v index 3b7f0d84..681c4716 100644 --- a/test-suite/success/ProgramWf.v +++ b/test-suite/success/ProgramWf.v @@ -100,6 +100,6 @@ Next Obligation. simpl in *; intros. apply H. simpl. omega. Qed. -Program Fixpoint check_n' (n : nat) (m : nat | m = n) (p : nat) (q : nat | q = p) +Program Fixpoint check_n' (n : nat) (m : {m:nat | m = n}) (p : nat) (q:{q : nat | q = p}) {measure (p - n) p} : nat := - _. + _.
\ No newline at end of file diff --git a/test-suite/success/Projection.v b/test-suite/success/Projection.v index d8faa88a..3ffd41ea 100644 --- a/test-suite/success/Projection.v +++ b/test-suite/success/Projection.v @@ -1,3 +1,9 @@ +Record foo (A : Type) := { B :> Type }. + +Lemma bar (f : foo nat) (x : f) : x = x. + destruct f. simpl B. simpl B in x. +Abort. + Structure S : Type := {Dom : Type; Op : Dom -> Dom -> Dom}. Check (fun s : S => Dom s). diff --git a/test-suite/success/RecTutorial.v b/test-suite/success/RecTutorial.v index 459645f6..11fbf24d 100644 --- a/test-suite/success/RecTutorial.v +++ b/test-suite/success/RecTutorial.v @@ -301,8 +301,8 @@ Section Le_case_analysis. (HS : forall m, n <= m -> Q (S m)). Check ( match H in (_ <= q) return (Q q) with - | le_n => H0 - | le_S m Hm => HS m Hm + | le_n _ => H0 + | le_S _ m Hm => HS m Hm end ). @@ -320,8 +320,8 @@ Qed. Definition Vtail_total (A : Set) (n : nat) (v : Vector.t A n) : Vector.t A (pred n):= match v in (Vector.t _ n0) return (Vector.t A (pred n0)) with -| Vector.nil => Vector.nil A -| Vector.cons _ n0 v0 => v0 +| Vector.nil _ => Vector.nil A +| Vector.cons _ _ n0 v0 => v0 end. Definition Vtail' (A:Set)(n:nat)(v:Vector.t A n) : Vector.t A (pred n). @@ -520,8 +520,7 @@ Inductive typ : Type := Definition typ_inject: typ. split. -exact typ. -Fail Defined. +Fail exact typ. (* Error: Universe Inconsistency. *) @@ -1060,8 +1059,8 @@ Fixpoint vector_nth (A:Set)(n:nat)(p:nat)(v:Vector.t A p){struct v} : option A := match n,v with _ , Vector.nil => None - | 0 , Vector.cons b _ _ => Some b - | S n', Vector.cons _ p' v' => vector_nth A n' p' v' + | 0 , Vector.cons b _ => Some b + | S n', Vector.cons _ v' => vector_nth A n' _ v' end. Implicit Arguments vector_nth [A p]. diff --git a/test-suite/success/Scopes.v b/test-suite/success/Scopes.v index a79d28fa..43e3493c 100644 --- a/test-suite/success/Scopes.v +++ b/test-suite/success/Scopes.v @@ -6,3 +6,17 @@ Module A. Definition opp := Z.opp. End A. Check (A.opp 3). + +(* Test extra scopes to be used in the presence of coercions *) + +Record B := { f :> Z -> Z }. +Variable a:B. +Arguments Scope a [Z_scope]. +Check a 0. + +(* Check that casts activate scopes if ever possible *) + +Inductive U := A. +Bind Scope u with U. +Notation "'ε'" := A : u. +Definition c := ε : U. diff --git a/test-suite/success/Tauto.v b/test-suite/success/Tauto.v index ed445c63..01d9afb4 100644 --- a/test-suite/success/Tauto.v +++ b/test-suite/success/Tauto.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/success/TestRefine.v b/test-suite/success/TestRefine.v index aecc9ed0..3090f40c 100644 --- a/test-suite/success/TestRefine.v +++ b/test-suite/success/TestRefine.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -53,7 +53,7 @@ Abort. Lemma essai2 : forall x : nat, x = x. - refine (fix f (x : nat) : x = x := _). +Fail refine (fix f (x : nat) : x = x := _). Restart. @@ -119,7 +119,7 @@ Lemma essai : {x : nat | x = 1}. Restart. (* mais si on contraint par le but alors ca marche : *) -(* Remarque : on peut toujours faire a *) +(* Remarque : on peut toujours faire ça *) refine (exist _ 1 _:{x : nat | x = 1}). Restart. @@ -176,7 +176,7 @@ Restart. end). exists 1. trivial. -elim (f0 p). +elim (f p). refine (fun (x : nat) (h : x = S p) => exist (fun x : nat => x = S (S p)) (S x) _). rewrite h. auto. @@ -184,7 +184,7 @@ Qed. -(* Quelques essais de recurrence bien fonde *) +(* Quelques essais de recurrence bien fondée *) Require Import Wf. Require Import Wf_nat. diff --git a/test-suite/success/apply.v b/test-suite/success/apply.v index 0d8bf556..21b829aa 100644 --- a/test-suite/success/apply.v +++ b/test-suite/success/apply.v @@ -164,8 +164,8 @@ intros. apply H with (y:=y). (* [x] had two possible instances: [S 0], coming from unifying the type of [y] with [I ?n] and [succ 0] coming from the unification with - the goal; only the first one allows to make the next apply (which - does not work modulo delta) working *) + the goal; only the first one allows the next apply (which + does not work modulo delta) work *) apply H0. Qed. @@ -336,25 +336,43 @@ Qed. (* From 12612, descent in conjunctions is more powerful *) (* The following, which was failing badly in bug 1980, is now properly rejected, as descend in conjunctions builds an - ill-formed elimination from Prop to Type. *) + ill-formed elimination from Prop to Type. + + Added Aug 2014: why it fails is now that trivial unification ?x = goal is + rejected by the descent in conjunctions to avoid surprising results. *) Goal True. Fail eapply ex_intro. exact I. Qed. -(* The following, which were not accepted, are now accepted as - expected by descent in conjunctions *) +Goal True. +Fail eapply (ex_intro _). +exact I. +Qed. + +(* Note: the following succeed directly (i.e. w/o "exact I") since + Aug 2014 since the descent in conjunction does not use a "cut" + anymore: the iota-redex is contracted and we get rid of the + uninstantiated evars + + Is it good or not? Maybe it does not matter so much. Goal True. eapply (ex_intro (fun _ => True) I). -exact I. +exact I. (* Not needed since Aug 2014 *) +Qed. + +Goal True. +eapply (ex_intro (fun _ => True) I _). +exact I. (* Not needed since Aug 2014 *) Qed. Goal True. eapply (fun (A:Prop) (x:A) => conj I x). -exact I. +exact I. (* Not needed since Aug 2014 *) Qed. +*) (* The following was not accepted from r12612 to r12657 *) @@ -430,3 +448,91 @@ Undo. (* H' is displayed as (forall n0, n=n0) *) apply H' with (n0:=0). Qed. + +(* Check that evars originally present in goal do not prevent apply in to work*) + +Goal (forall x, x <= 0 -> x = 0) -> exists x, x <= 0 -> 0 = 0. +intros. +eexists. +intros. +apply H in H0. +Abort. + +(* Check correct failure of apply in when hypothesis is dependent *) + +Goal forall H:0=0, H = H. +intros. +Fail apply eq_sym in H. + +(* Check that unresolved evars not originally present in goal prevent + apply in to work*) + +Goal (forall x y, x <= 0 -> x + y = 0) -> exists x, x <= 0 -> 0 = 0. +intros. +eexists. +intros. +Fail apply H in H0. +Abort. + +(* Check naming pattern in apply in *) + +Goal ((False /\ (True -> True))) -> True -> True. +intros F H. +apply F in H as H0. (* Check that H0 is not used internally *) +exact H0. +Qed. + +Goal ((False /\ (True -> True/\True))) -> True -> True/\True. +intros F H. +apply F in H as (?,?). +split. +exact H. (* Check that generated names are H and H0 *) +exact H0. +Qed. + +(* This failed at some time in between 18 August 2014 and 2 September 2014 *) + +Goal forall A B C: Prop, (True -> A -> B /\ C) -> A -> B. +intros * H. +apply H. +Abort. + +(* This failed between 2 and 3 September 2014 *) + +Goal forall A B C D:Prop, (A<->B)/\(C<->D) -> A -> B. +intros. +apply H in H0. +pose proof I as H1. (* Test that H1 does not exist *) +Abort. + +Goal forall A B C D:Prop, (A<->B)/\(C<->D) -> A. +intros. +apply H. +pose proof I as H0. (* Test that H0 does not exist *) +Abort. + +(* The first example below failed at some time in between 18 August + 2014 and 2 September 2014 *) + +Goal forall x, 2=0 -> x+1=2 -> (forall x, S x = 0) -> True. +intros x H H0 H1. +eapply eq_trans in H. 2:apply H0. +rewrite H1 in H. +change (x+0=0) in H. (* Check the result in H1 *) +Abort. + +Goal forall x, 2=x+1 -> (forall x, S x = 0) -> 2 = 0. +intros x H H0. +eapply eq_trans. apply H. +rewrite H0. +change (x+0=0). +Abort. + +(* 2nd order apply used to have delta on local definitions even though + it does not have delta on global definitions; keep it by + compatibility while finding a more uniform way to proceed. *) + +Goal forall f:nat->nat, (forall P x, P (f x)) -> let x:=f 0 in x = 0. +intros f H x. +apply H. +Qed. diff --git a/test-suite/success/applyTC.v b/test-suite/success/applyTC.v new file mode 100644 index 00000000..c2debdec --- /dev/null +++ b/test-suite/success/applyTC.v @@ -0,0 +1,15 @@ +Axiom P : nat -> Prop. + +Class class (A : Type) := { val : A }. + +Lemma usetc {t : class nat} : P (@val nat t). +Admitted. + +Notation "{val:= v }" := (@val _ v). + +Instance zero : class nat := {| val := 0 |}. + +Lemma test : P 0. +Fail apply usetc. +pose (tmp := usetc); apply tmp; clear tmp. +Qed. diff --git a/test-suite/success/auto.v b/test-suite/success/auto.v index 9b691e25..db3b19af 100644 --- a/test-suite/success/auto.v +++ b/test-suite/success/auto.v @@ -14,7 +14,7 @@ Hint Resolve L. Goal G unit Q -> F (Q tt). intro. - auto. + eauto. Qed. (* Test implicit arguments in "using" clause *) @@ -24,3 +24,24 @@ auto using (pair O). Undo. eauto using (pair O). Qed. + +Create HintDb test discriminated. + +Parameter foo : forall x, x = x + 0. +Hint Resolve foo : test. + +Variable C : nat -> Type -> Prop. + +Variable c_inst : C 0 nat. + +Hint Resolve c_inst : test. + +Hint Mode C - + : test. +Hint Resolve c_inst : test2. +Hint Mode C + + : test2. + +Goal exists n, C n nat. +Proof. + eexists. Fail progress debug eauto with test2. + progress eauto with test. +Qed. diff --git a/test-suite/success/cc.v b/test-suite/success/cc.v index b565183b..a70d9196 100644 --- a/test-suite/success/cc.v +++ b/test-suite/success/cc.v @@ -102,5 +102,32 @@ Proof. auto. Qed. +(* bug 2447 is now closed (PC, 2014) *) + +Section bug_2447. + +Variable T:Type. + +Record R := mkR {x:T;y:T;z:T}. + +Variables a a' b b' c c':T. + + + +Lemma bug_2447: mkR a b c = mkR a' b c -> a = a'. +congruence. +Qed. + +Lemma bug_2447_variant1: mkR a b c = mkR a b' c -> b = b'. +congruence. +Qed. + +Lemma bug_2447_variant2: mkR a b c = mkR a b c' -> c = c'. +congruence. +Qed. + + +End bug_2447. + diff --git a/test-suite/success/change.v b/test-suite/success/change.v index 7bed7ecb..1f0b7d38 100644 --- a/test-suite/success/change.v +++ b/test-suite/success/change.v @@ -38,3 +38,24 @@ Fail change True with (let (x,a) := ex_intro _ True (eq_refl True) in x). Fail change True with match ex_intro _ True (eq_refl True) with ex_intro x _ => x end. Abort. + +(* Check absence of loop in identity substitution (was failing up to + Sep 2014, see #3641) *) + +Goal True. +change ?x with x. +Abort. + +(* Check typability after change of type subterms *) +Goal nat = nat :> Set. +Fail change nat with (@id Type nat). (* would otherwise be ill-typed *) +Abort. + +(* Check typing env for rhs is the correct one *) + +Goal forall n, let x := n in id (fun n => n + x) 0 = 0. +intros. +unfold x. +(* check that n in 0+n is not interpreted as the n from "fun n" *) +change n with (0+n). +Abort. diff --git a/test-suite/success/coercions.v b/test-suite/success/coercions.v index 4292ecb6..b538d2ed 100644 --- a/test-suite/success/coercions.v +++ b/test-suite/success/coercions.v @@ -96,13 +96,13 @@ Inductive list (A : Type) : Type := nil : list A | cons : A -> list A -> list A. Inductive vect (A : Type) : nat -> Type := vnil : vect A 0 | vcons : forall n, A -> vect A n -> vect A (1+n). -Fixpoint size A (l : list A) : nat := match l with nil => 0 | cons _ tl => 1+size _ tl end. +Fixpoint size A (l : list A) : nat := match l with nil _ => 0 | cons _ _ tl => 1+size _ tl end. Section test_non_unif_but_complete. Fixpoint l2v A (l : list A) : vect A (size A l) := match l as l return vect A (size A l) with - | nil => vnil A - | cons x xs => vcons A (size A xs) x (l2v A xs) + | nil _ => vnil A + | cons _ x xs => vcons A (size A xs) x (l2v A xs) end. Local Coercion l2v : list >-> vect. @@ -121,8 +121,8 @@ Instance pair A B C D (c1 : coercion A B) (c2 : coercion C D) : coercion (A * C) Fixpoint l2v2 {A B} {c : coercion A B} (l : list A) : (vect B (size A l)) := match l as l return vect B (size A l) with - | nil => vnil B - | cons x xs => vcons _ _ (c x) (l2v2 xs) end. + | nil _ => vnil B + | cons _ x xs => vcons _ _ (c x) (l2v2 xs) end. Local Coercion l2v2 : list >-> vect. diff --git a/test-suite/success/decl_mode.v b/test-suite/success/decl_mode.v index 52575eca..58f79d45 100644 --- a/test-suite/success/decl_mode.v +++ b/test-suite/success/decl_mode.v @@ -67,7 +67,7 @@ proof. end proof. Qed. -Require Omega. +Require Import Omega. Lemma even_double_n: (forall m, even (double m)). proof. diff --git a/test-suite/success/destruct.v b/test-suite/success/destruct.v index fc40ea96..83a33f75 100644 --- a/test-suite/success/destruct.v +++ b/test-suite/success/destruct.v @@ -37,7 +37,6 @@ Goal True. case Refl || ecase Refl. Abort. - (* Submitted by B. Baydemir (bug #1882) *) Require Import List. @@ -93,3 +92,339 @@ Goal let T:=nat in forall (x:nat) (g:T -> nat), g x = 0. intros. destruct (g _). (* This was failing in at least r14571 *) Abort. + +(* Check that subterm selection does not solve existing evars *) + +Goal exists x, S x = S 0. +eexists. +destruct (S _). (* Incompatible occurrences but takes the first one since Oct 2014 *) +change (0 = S 0). +Abort. + +Goal exists x, S 0 = S x. +eexists. +destruct (S _). (* Incompatible occurrences but takes the first one since Oct 2014 *) +change (0 = S ?x). +Abort. + +Goal exists n p:nat, (S n,S n) = (S p,S p) /\ p = n. +do 2 eexists. +destruct (_, S _). (* Was unifying at some time in trunk, now takes the first occurrence *) +change ((n, n0) = (S ?p, S ?p) /\ ?p = ?n). +Abort. + +(* An example with incompatible but convertible occurrences *) + +Goal id (id 0) = 0. +Fail destruct (id _) at 1 2. +Abort. + +(* Avoid unnatural selection of a subterm larger than expected *) + +Goal let g := fun x:nat => x in g (S 0) = 0. +intro. +destruct S. +(* Check that it is not the larger subterm "g (S 0)" which is + selected, as it was the case in 8.4 *) +unfold g at 1. +Abort. + +(* Some tricky examples convenient to support *) + +Goal forall x, nat_rect (fun _ => nat) O (fun x y => S x) x = nat_rect (fun _ => nat) O (fun x y => S x) x. +intros. +destruct (nat_rect _ _ _ _). +Abort. +(* Check compatibility in selecting what is open or "shelved" *) + +Goal (forall x, x=0 -> nat) -> True. +intros. +Fail destruct H. +edestruct H. +- reflexivity. +- exact Logic.I. +- exact Logic.I. +Qed. + +(* Check an example which was working with case/elim in 8.4 but not with + destruct/induction *) + +Goal forall x, (True -> x = 0) -> 0=0. +intros. +destruct H. +- trivial. +- apply (eq_refl x). +Qed. + +(* Check an example which was working with case/elim in 8.4 but not with + destruct/induction (not the different order between induction/destruct) *) + +Goal forall x, (True -> x = 0) -> 0=0. +intros. +induction H. +- apply (eq_refl x). +- trivial. +Qed. + +(* This test assumes that destruct/induction on non-dependent hypotheses behave the same + when using holes or not + +Goal forall x, (True -> x = 0) -> 0=0. +intros. +destruct (H _). +- apply I. +- apply (eq_refl x). +Qed. +*) + +(* Check destruct vs edestruct *) + +Goal forall x, (forall y, y = 0 -> x = 0) -> 0=0. +intros. +Fail destruct H. +edestruct H. +- trivial. +- apply (eq_refl x). +Qed. + +Goal forall x, (forall y, y = 0 -> x = 0) -> 0=0. +intros. +Fail destruct (H _ _). +(* Now a test which assumes that edestruct on non-dependent + hypotheses accept unresolved subterms in the induction argument. +edestruct (H _ _). +- trivial. +- apply (eq_refl x). +Qed. +*) +Abort. + +(* Test selection when not in an inductive type *) +Parameter T:Type. +Axiom elim: forall P, T -> P. +Goal forall a:T, a = a. +induction a using elim. +Qed. + +Goal forall a:nat -> T, a 0 = a 1. +intro a. +induction (a 0) using elim. +Qed. + +(* From Oct 2014, a subterm is found, as if without "using"; in 8.4, + it did not find a subterm *) + +Goal forall a:nat -> T, a 0 = a 1. +intro a. +induction a using elim. +Qed. + +Goal forall a:nat -> T, forall b, a 0 = b. +intros a b. +induction a using elim. +Qed. + +(* From Oct 2014, first subterm is found; in 8.4, it failed because it + found "a 0" and wanted to clear a *) + +Goal forall a:nat -> nat, a 0 = a 1. +intro a. +destruct a. +change (0 = a 1). +Abort. + +(* This example of a variable not fully applied in the goal was working in 8.4*) + +Goal forall H : 0<>0, H = H. +destruct H. +reflexivity. +Qed. + +(* Check that variables not fully applied in the goal are not erased + (this example was failing in 8.4 because of a forbidden "clear H" in + the code of "destruct H" *) + +Goal forall H : True -> True, H = H. +destruct H. +- exact I. +- reflexivity. +Qed. + +(* Check destruct on idents with maximal implicit arguments - which did + not work in 8.4 *) + +Parameter g : forall {n:nat}, n=n -> nat. +Goal g (eq_refl 0) = 0. +destruct g. +Abort. + +(* This one was working in 8.4 (because of full conv on closed arguments) *) + +Class E. +Instance a:E. +Goal forall h : E -> nat -> nat, h (id a) 0 = h a 0. +intros. +destruct (h _). +change (0=0). +Abort. + +(* This one was not working in 8.4 because an occurrence of f was + remaining, blocking the "clear f" *) + +Goal forall h : E -> nat -> nat, h a 0 = h a 1. +intros. +destruct h. +Abort. + +(* This was not working in 8.4 *) + +Section S1. +Variables x y : Type. +Variable H : x = y. +Goal True. +destruct H. (* Was not working in 8.4 *) +(* Now check that H statement has itself be subject of the rewriting *) +change (x=x) in H. +Abort. +End S1. + +(* This was not working in 8.4 because of untracked dependencies *) +Goal forall y, forall h:forall x, x = y, h 0 = h 0. +intros. +destruct (h 0). +Abort. + +(* Check absence of useless local definitions *) + +Section S2. +Variable H : 1=1. +Goal 0=1. +destruct H. +Fail clear n. (* Check that there is no n as it was in Coq <= 8.4 *) +Abort. +End S2. + +Goal forall x:nat, x=x->x=1. +intros x H. +destruct H. +Fail clear n. (* Check that there is no n as it was in Coq <= 8.4 *) +Fail clear H. (* Check that H has been removed *) +Abort. + +(* Check support for induction arguments which do not expose an inductive + type rightaway *) + +Definition U := nat -> nat. +Definition S' := S : U. +Goal forall n, S' n = 0. +intro. +destruct S'. +Abort. + +(* This was working by chance in 8.4 thanks to "accidental" use of select + subterms _syntactically_ equal to the first matching one. + +Parameter f2:bool -> unit. +Parameter r2:f2 true=f2 true. +Goal forall (P: forall b, b=b -> Prop), f2 (id true) = tt -> P (f2 true) r2. +intros. +destruct f2. +Abort. +*) + +(* This did not work in 8.4, because of a clear failing *) + +Inductive IND : forall x y:nat, x=y -> Type := CONSTR : IND 0 0 eq_refl. +Goal forall x y e (h:x=y -> y=x) (z:IND y x (h e)), e = e /\ z = z. +intros. +destruct z. +Abort. + +(* The two following examples show how the variables occurring in the + term being destruct affects the generalization; don't know if these + behaviors are "good". None of them was working in 8.4. *) + +Goal forall x y e (t:x=y) (z:x=y -> IND y x e), e = e. +intros. +destruct (z t). +change (0=0) in t. (* Generalization made *) +Abort. + +Goal forall x y e (t:x=y) (z:x=y -> IND y x e), e = e /\ z t = z t. +intros. +destruct (z t). +change (0=0) in t. (* Generalization made *) +Abort. + +(* Check that destruct on a scheme with a functional argument works *) + +Goal (forall P:Prop, (nat->nat) -> P) -> forall h:nat->nat, h 0 = h 0. +intros. +destruct h using H. +Qed. + +Goal (forall P:Prop, (nat->nat) -> P) -> forall h:nat->nat->nat, h 0 0 = h 1 0. +intros. +induction (h 1) using H. +Qed. + +(* Check blocking generalization is not too strong (failed at some time) *) + +Goal (E -> 0=1) -> 1=0 -> True. +intros. +destruct (H _). +change (0=0) in H0. (* Check generalization on H0 was made *) +Abort. + +(* Check absence of anomaly (failed at some time) *) + +Goal forall A (a:A) (P Q:A->Prop), (forall a, P a -> Q a) -> True. +intros. +Fail destruct H. +Abort. + +(* Check keep option (bug #3791) *) + +Goal forall b:bool, True. +intro b. +destruct !b. +clear b. (* b has to be here *) +Abort. + +(* Check clearing of names *) + +Inductive IND2 : nat -> Prop := CONSTR2 : forall y, y = y -> IND2 y. +Goal forall x y z:nat, y = z -> x = y -> y = x -> x = y. +intros * Heq H Heq'. +destruct H. +Abort. + +Goal 2=1 -> 1=0. +intro H. destruct H. +Fail (match goal with n:nat |- _ => unfold n end). (* Check that no let-in remains *) +Abort. + +(* Check clearing of names *) + +Inductive eqnat (x : nat) : nat -> Prop := + reflnat : forall y, x = y -> eqnat x y. + +Goal forall x z:nat, x = z -> eqnat x z -> True. +intros * H1 H. +destruct H. +Fail clear z. (* Should not be here *) +Abort. + +(* Check ok in the presence of an equation *) + +Goal forall b:bool, b = b. +intros. +destruct b eqn:H. + +(* Check natural instantiation behavior when the goal has already an evar *) + +Goal exists x, S x = x. +eexists. +destruct (S _). +change (0 = ?x). +Abort. diff --git a/test-suite/success/eauto.v b/test-suite/success/eauto.v index b7b0f7fd..9e57801e 100644 --- a/test-suite/success/eauto.v +++ b/test-suite/success/eauto.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/success/eqdecide.v b/test-suite/success/eqdecide.v index 044b41d3..1b5c7f18 100644 --- a/test-suite/success/eqdecide.v +++ b/test-suite/success/eqdecide.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/success/evars.v b/test-suite/success/evars.v index e6088091..4e2bf451 100644 --- a/test-suite/success/evars.v +++ b/test-suite/success/evars.v @@ -1,3 +1,4 @@ + (* The "?" of cons and eq should be inferred *) Variable list : Set -> Set. Variable cons : forall T : Set, T -> list T -> list T. @@ -44,13 +45,13 @@ Fixpoint build (nl : list nat) : (* Checks that disjoint contexts are correctly set by restrict_hyp *) -(* Bug de 1999 corrig en dc 2004 *) +(* Bug de 1999 corrigé en déc 2004 *) Check (let p := fun (m : nat) f (n : nat) => match f m n with - | exist a b => exist _ a b + | exist _ a b => exist _ a b end in p :forall x : nat, @@ -61,7 +62,7 @@ Check Check (fun f:(forall (v:Type->Type), v (v nat) -> nat) => f _ (Some (Some O))). -(* This used to fail with anomaly "evar was not declared" in V8.0pl3 *) +(* This used to fail with anomaly (Pp.str "evar was not declared") in V8.0pl3 *) Theorem contradiction : forall p, ~ p -> p -> False. Proof. trivial. Qed. @@ -177,9 +178,9 @@ refine | left _ => _ | right _ => match le_step s _ _ with - | exist s' h' => + | exist _ s' h' => match hr s' _ _ with - | exist s'' _ => exist _ s'' _ + | exist _ s'' _ => exist _ s'' _ end end end)). @@ -203,7 +204,7 @@ Abort. Fixpoint filter (A:nat->Set) (l:list (sigT A)) : list (sigT A) := match l with | nil => nil - | (existT k v)::l' => (existT _ k v):: (filter A l') + | (existT _ k v)::l' => (existT _ k v):: (filter A l') end. (* Bug #2000: used to raise Out of memory in 8.2 while it should fail by @@ -379,3 +380,38 @@ Section evar_evar_occur. (* Still evars in the resulting type, but constraints should be solved *) Check match g _ with conj a b => f _ a b end. End evar_evar_occur. + +(* Eta expansion (bug #2936) *) +Record iffT (X Y:Type) : Type := mkIff { iffLR : X->Y; iffRL : Y->X }. +Record tri (R:Type->Type->Type) (S:Type->Type->Type) (T:Type->Type->Type) := mkTri { + tri0 : forall a b c, R a b -> S a c -> T b c +}. +Implicit Arguments mkTri [R S T]. +Definition tri_iffT : tri iffT iffT iffT := + (mkTri + (fun X0 X1 X2 E01 E02 => + (mkIff _ _ (fun x1 => iffLR _ _ E02 (iffRL _ _ E01 x1)) + (fun x2 => iffLR _ _ E01 (iffRL _ _ E02 x2))))). + +(* Check that local defs names are preserved if possible during unification *) + +Goal forall x (x':=x) (f:forall y, y=y:>nat -> Prop), f _ (eq_refl x'). +intros. +unfold x' at 2. (* A way to check that there are indeed 2 occurrences of x' *) +Abort. + +(* A simple example we would like not to fail (it used to fail because of + not strict enough evar restriction) *) + +Check match Some _ with None => _ | _ => _ end. + +(* Used to fail for a couple of days in Nov 2014 *) + +Axiom test : forall P1 P2, P1 = P2 -> P1 -> P2. + +(* Check use of candidates *) + +Import EqNotations. +Definition test2 {A B:Type} {H:A=B} (a:A) : B := rew H in a. + + diff --git a/test-suite/success/extraction.v b/test-suite/success/extraction.v index eaed9616..57f3775d 100644 --- a/test-suite/success/extraction.v +++ b/test-suite/success/extraction.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/success/extraction_dep.v b/test-suite/success/extraction_dep.v new file mode 100644 index 00000000..11bb25fd --- /dev/null +++ b/test-suite/success/extraction_dep.v @@ -0,0 +1,46 @@ + +(** Examples of code elimination inside modules during extraction *) + +(** NB: we should someday check the produced code instead of + simply running the commands. *) + +(** 1) Without signature ... *) + +Module A. + Definition u := 0. + Definition v := 1. + Module B. + Definition w := 2. + Definition x := 3. + End B. +End A. + +Definition testA := A.u + A.B.x. + +Recursive Extraction testA. (* without: v w *) + +(** 1b) Same with an Include *) + +Module Abis. + Include A. + Definition y := 4. +End Abis. + +Definition testAbis := Abis.u + Abis.y. + +Recursive Extraction testAbis. (* without: A B v w x *) + +(** 2) With signature, we only keep elements mentionned in signature. *) + +Module Type SIG. + Parameter u : nat. + Parameter v : nat. +End SIG. + +Module Ater : SIG. + Include A. +End Ater. + +Definition testAter := Ater.u. + +Recursive Extraction testAter. (* with only: u v *) diff --git a/test-suite/success/fix.v b/test-suite/success/fix.v index 8623f718..ff34840d 100644 --- a/test-suite/success/fix.v +++ b/test-suite/success/fix.v @@ -9,12 +9,13 @@ Inductive rBoolOp : Set := | rAnd : rBoolOp | rEq : rBoolOp. -Definition rlt (a b : rNat) : Prop := Pos.compare_cont a b Eq = Lt. +Definition rlt (a b : rNat) : Prop := Pos.compare_cont Eq a b = Lt. Definition rltDec : forall m n : rNat, {rlt m n} + {rlt n m \/ m = n}. +Proof. intros n m; generalize (nat_of_P_lt_Lt_compare_morphism n m); generalize (nat_of_P_gt_Gt_compare_morphism n m); - generalize (Pcompare_Eq_eq n m); case (Pos.compare_cont n m Eq). + generalize (Pcompare_Eq_eq n m); case (Pos.compare_cont Eq n m). intros H' H'0 H'1; right; right; auto. intros H' H'0 H'1; left; unfold rlt. apply nat_of_P_lt_Lt_compare_complement_morphism; auto. @@ -25,6 +26,7 @@ Defined. Definition rmax : rNat -> rNat -> rNat. +Proof. intros n m; case (rltDec n m); intros Rlt0. exact m. exact n. diff --git a/test-suite/success/implicit.v b/test-suite/success/implicit.v index e8019a90..a0981311 100644 --- a/test-suite/success/implicit.v +++ b/test-suite/success/implicit.v @@ -61,7 +61,7 @@ Check (eq1 0 0). Check (eq2 0 0). Check (eq3 nat 0 0). -(* Example submitted by Frdric (interesting in v8 syntax) *) +(* Example submitted by Frédéric (interesting in v8 syntax) *) Parameter f : nat -> nat * nat. Notation lhs := fst. diff --git a/test-suite/success/indelim.v b/test-suite/success/indelim.v new file mode 100644 index 00000000..91b6dee2 --- /dev/null +++ b/test-suite/success/indelim.v @@ -0,0 +1,61 @@ +Inductive boolP : Prop := +| trueP : boolP +| falseP : boolP. + +Fail Check boolP_rect. + + +Inductive True : Prop := I : True. + +Inductive False : Prop :=. + +Inductive Empty_set : Set :=. + +Fail Inductive Large_set : Set := + large_constr : forall A : Set, A -> Large_set. + +Inductive smallunitProp : Prop := +| onlyProps : True -> smallunitProp. + +Check smallunitProp_rect. + +Inductive nonsmallunitProp : Prop := +| notonlyProps : nat -> nonsmallunitProp. + +Fail Check nonsmallunitProp_rect. +Set Printing Universes. +Inductive inferProp := +| hasonlyProps : True -> nonsmallunitProp -> inferProp. + +Check (inferProp : Prop). + +Inductive inferSet := +| hasaset : nat -> True -> nonsmallunitProp -> inferSet. + +Fail Check (inferSet : Prop). + +Check (inferSet : Set). + +Inductive inferLargeSet := +| hasalargeset : Set -> True -> nonsmallunitProp -> inferLargeSet. + +Fail Check (inferLargeSet : Set). + +Inductive largeProp : Prop := somelargeprop : Set -> largeProp. + + +Inductive comparison : Set := + | Eq : comparison + | Lt : comparison + | Gt : comparison. + +Inductive CompareSpecT (Peq Plt Pgt : Prop) : comparison -> Type := + | CompEqT : Peq -> CompareSpecT Peq Plt Pgt Eq + | CompLtT : Plt -> CompareSpecT Peq Plt Pgt Lt + | CompGtT : Pgt -> CompareSpecT Peq Plt Pgt Gt. + +Inductive color := Red | Black. + +Inductive option (A : Type) : Type := +| None : option A +| Some : A -> option A.
\ No newline at end of file diff --git a/test-suite/success/inds_type_sec.v b/test-suite/success/inds_type_sec.v index 83c90929..b733aef6 100644 --- a/test-suite/success/inds_type_sec.v +++ b/test-suite/success/inds_type_sec.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/success/induct.v b/test-suite/success/induct.v index 75643d9d..7ae60d98 100644 --- a/test-suite/success/induct.v +++ b/test-suite/success/induct.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -25,7 +25,7 @@ Check fun (P : forall A : Type, let B := A in A -> Type) (f : P True I) (A : Type) => let B := A in fun (a : A) (e : eq1 A a) => - match e in (eq1 A0 B0 a0) return (P A0 a0) with + match e in (eq1 A0 a0) return (P A0 a0) with | refl1 => f end. @@ -64,3 +64,90 @@ Undo 2. Fail induction (S _) in |- * at 4. Abort. +(* Check use of "as" clause *) + +Inductive I := C : forall x, x<0 -> I -> I. + +Goal forall x:I, x=x. +intros. +induction x as [y * IHx]. +change (x = x) in IHx. (* We should have IHx:x=x *) +Abort. + +(* This was not working in 8.4 *) + +Goal forall h:nat->nat, h 0 = h 1 -> h 1 = h 2 -> h 0 = h 2. +intros. +induction h. +2:change (n = h 1 -> n = h 2) in IHn. +Abort. + +(* This was not working in 8.4 *) + +Goal forall h:nat->nat, h 0 = h 1 -> h 1 = h 2 -> h 0 = h 2. +intros h H H0. +induction h in H |- *. +Abort. + +(* "at" was not granted in 8.4 in the next two examples *) + +Goal forall h:nat->nat, h 0 = h 1 -> h 1 = h 2 -> h 0 = h 2. +intros h H H0. +induction h in H at 2, H0 at 1. +change (h 0 = 0) in H. +Abort. + +Goal forall h:nat->nat, h 0 = h 1 -> h 1 = h 2 -> h 0 = h 2. +intros h H H0. +Fail induction h in H at 2 |- *. (* Incompatible occurrences *) +Abort. + +(* Check generalization with dependencies in section variables *) + +Section S3. +Variables x : nat. +Definition cond := x = x. +Goal cond -> x = 0. +intros H. +induction x as [|n IHn]. +2:change (n = 0) in IHn. (* We don't want a generalization over cond *) +Abort. +End S3. + +(* These examples show somehow arbitrary choices of generalization wrt + to indices, when those indices are not linear. We check here 8.4 + compatibility: when an index is a subterm of a parameter of the + inductive type, it is not generalized. *) + +Inductive repr (x:nat) : nat -> Prop := reprc z : repr x z -> repr x z. + +Goal forall x, 0 = x -> repr x x -> True. +intros x H1 H. +induction H. +change True in IHrepr. +Abort. + +Goal forall x, 0 = S x -> repr (S x) (S x) -> True. +intros x H1 H. +induction H. +change True in IHrepr. +Abort. + +Inductive repr' (x:nat) : nat -> Prop := reprc' z : repr' x (S z) -> repr' x z. + +Goal forall x, 0 = x -> repr' x x -> True. +intros x H1 H. +induction H. +change True in IHrepr'. +Abort. + +(* In this case, generalization was done in 8.4 and we preserve it; this + is arbitrary choice *) + +Inductive repr'' : nat -> nat -> Prop := reprc'' x z : repr'' x z -> repr'' x z. + +Goal forall x, 0 = x -> repr'' x x -> True. +intros x H1 H. +induction H. +change (0 = z -> True) in IHrepr''. +Abort. diff --git a/test-suite/success/instantiate.v b/test-suite/success/instantiate.v deleted file mode 100644 index 4224405d..00000000 --- a/test-suite/success/instantiate.v +++ /dev/null @@ -1,11 +0,0 @@ -(* Test rgression bug #1041 *) - -Goal Prop. - -pose (P:= fun x y :Prop => y). -evar (Q: forall X Y,P X Y -> Prop) . - -instantiate (1:= fun _ => _ ) in (Value of Q). -instantiate (1:= fun _ => _ ) in (Value of Q). -instantiate (1:= fun _ => _ ) in (Value of Q). -instantiate (1:= H) in (Value of Q). diff --git a/test-suite/success/intros.v b/test-suite/success/intros.v index 3599da4d..9443d01e 100644 --- a/test-suite/success/intros.v +++ b/test-suite/success/intros.v @@ -3,5 +3,33 @@ Goal forall A, A -> True. intros _ _. +Abort. +(* This did not work until March 2013, because of underlying "red" *) +Goal (fun x => True -> True) 0. +intro H. +Abort. +(* This should still work, with "intro" calling "hnf" *) +Goal (fun f => True -> f 0 = f 0) (fun x => x). +intro H. +match goal with [ |- 0 = 0 ] => reflexivity end. +Abort. + +(* Somewhat related: This did not work until March 2013 *) +Goal (fun f => f 0 = f 0) (fun x => x). +hnf. +match goal with [ |- 0 = 0 ] => reflexivity end. +Abort. + +(* Fixing behavior of "*" and "**" in branches, so that they do not + introduce more than what the branch expects them to introduce at most *) +Goal forall n p, n + p = 0. +intros [|*]; intro p. +Abort. + +(* Check non-interference of "_" with name generation *) +Goal True -> True -> True. +intros _ ?. +exact H. +Qed. diff --git a/test-suite/success/keyedrewrite.v b/test-suite/success/keyedrewrite.v new file mode 100644 index 00000000..bbe9d4bf --- /dev/null +++ b/test-suite/success/keyedrewrite.v @@ -0,0 +1,24 @@ +Set Keyed Unification. + +Section foo. +Variable f : nat -> nat. + +Definition g := f. + +Variable lem : g 0 = 0. + +Goal f 0 = 0. +Proof. + Fail rewrite lem. +Abort. + +Declare Equivalent Keys @g @f. +(** Now f and g are considered equivalent heads for subterm selection *) +Goal f 0 = 0. +Proof. + rewrite lem. + reflexivity. +Qed. + +Print Equivalent Keys. +End foo. diff --git a/test-suite/success/letproj.v b/test-suite/success/letproj.v new file mode 100644 index 00000000..a183be62 --- /dev/null +++ b/test-suite/success/letproj.v @@ -0,0 +1,9 @@ +Set Primitive Projections. +Set Record Elimination Schemes. +Record Foo (A : Type) := { bar : A -> A; baz : A }. + +Definition test (A : Type) (f : Foo A) := + let (x, y) := f in x. + +Scheme foo_case := Case for Foo Sort Type. + diff --git a/test-suite/success/ltac.v b/test-suite/success/ltac.v index c2eb8bd7..badce063 100644 --- a/test-suite/success/ltac.v +++ b/test-suite/success/ltac.v @@ -1,6 +1,6 @@ (* The tactic language *) -(* Submitted by Pierre Crgut *) +(* Submitted by Pierre Crégut *) (* Checks substitution of x *) Ltac f x := unfold x; idtac. @@ -9,7 +9,7 @@ f plus. reflexivity. Qed. -(* Submitted by Pierre Crgut *) +(* Submitted by Pierre Crégut *) (* Check syntactic correctness *) Ltac F x := idtac; G x with G y := idtac; F y. @@ -143,7 +143,7 @@ Qed. Ltac check_binding y := cut ((fun y => y) = S). Goal True. -check_binding true. +check_binding ipattern:H. Abort. (* Check that variables explicitly parsed as ltac variables are not @@ -211,7 +211,7 @@ is. exact I. Abort. -(* Interfrence entre espaces des noms *) +(* Interférence entre espaces des noms *) Ltac O := intro. Ltac Z1 t := set (x:=t). @@ -298,7 +298,3 @@ evar(foo:nat). let evval := eval compute in foo in not_eq evval 1. let evval := eval compute in foo in not_eq 1 evval. Abort. - -(* Check that this returns an error and not an anomaly (see r13667) *) - -Fail Local Tactic Notation "myintro" := intro. diff --git a/test-suite/success/ltac_plus.v b/test-suite/success/ltac_plus.v new file mode 100644 index 00000000..8a08d646 --- /dev/null +++ b/test-suite/success/ltac_plus.v @@ -0,0 +1,12 @@ +(** Checks that Ltac's '+' tactical works as intended. *) + +Goal forall (A B C D:Prop), (A->C) -> (B->C) -> (D->C) -> B -> C. +Proof. + intros A B C D h0 h1 h2 h3. + (* backtracking *) + (apply h0 + apply h1);apply h3. + Undo. + Fail ((apply h0+apply h2) || apply h1); apply h3. + (* interaction with || *) + ((apply h0+apply h1) || apply h2); apply h3. +Qed.
\ No newline at end of file diff --git a/test-suite/success/mutual_ind.v b/test-suite/success/mutual_ind.v index 05303f37..54cfa658 100644 --- a/test-suite/success/mutual_ind.v +++ b/test-suite/success/mutual_ind.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/success/namedunivs.v b/test-suite/success/namedunivs.v new file mode 100644 index 00000000..059462fa --- /dev/null +++ b/test-suite/success/namedunivs.v @@ -0,0 +1,102 @@ +(* Inductive paths {A} (x : A) : A -> Type := idpath : paths x x where "x = y" := (@paths _ x y) : type_scope. *) +(* Goal forall A B : Set, @paths Type A B -> @paths Set A B. *) +(* intros A B H. *) +(* Fail exact H. *) +(* Section . *) + +Section lift_strict. +Polymorphic Definition liftlt := + let t := Type@{i} : Type@{k} in + fun A : Type@{i} => A : Type@{k}. + +Polymorphic Definition liftle := + fun A : Type@{i} => A : Type@{k}. +End lift_strict. + + +Set Universe Polymorphism. + +(* Inductive option (A : Type) : Type := *) +(* | None : option A *) +(* | Some : A -> option A. *) + +Inductive option (A : Type@{i}) : Type@{i} := + | None : option A + | Some : A -> option A. + +Definition foo' {A : Type@{i}} (o : option@{i} A) : option@{i} A := + o. + +Definition foo'' {A : Type@{i}} (o : option@{j} A) : option@{k} A := + o. + + +Definition testm (A : Type@{i}) : Type@{max(i,j)} := A. + +(* Inductive prod (A : Type@{i}) (B : Type@{j}) := *) +(* | pair : A -> B -> prod A B. *) + +(* Definition snd {A : Type@{i}} (B : Type@{j}) (p : prod A B) : B := *) +(* match p with *) +(* | pair _ _ a b => b *) +(* end. *) + +(* Definition snd' {A : Type@{i}} (B : Type@{i}) (p : prod A B) : B := *) +(* match p with *) +(* | pair _ _ a b => b *) +(* end. *) + +(* Inductive paths {A : Type} : A -> A -> Type := *) +(* | idpath (a : A) : paths a a. *) + +Inductive paths {A : Type@{i}} : A -> A -> Type@{i} := +| idpath (a : A) : paths a a. + +Definition Funext := + forall (A : Type) (B : A -> Type), + forall f g : (forall a, B a), (forall x : A, paths (f x) (g x)) -> paths f g. + +Definition paths_lift_closed (A : Type@{i}) (x y : A) : + paths x y -> @paths (liftle@{j Type} A) x y. +Proof. + intros. destruct X. exact (idpath _). +Defined. + +Definition paths_lift (A : Type@{i}) (x y : A) : + paths x y -> paths@{j} x y. +Proof. + intros. destruct X. exact (idpath _). +Defined. + +Definition paths_lift_closed_strict (A : Type@{i}) (x y : A) : + paths x y -> @paths (liftlt@{j Type} A) x y. +Proof. + intros. destruct X. exact (idpath _). +Defined. + +Definition paths_downward_closed_le (A : Type@{i}) (x y : A) : + paths@{j} (A:=liftle@{i j} A) x y -> paths@{i} x y. +Proof. + intros. destruct X. exact (idpath _). +Defined. + +Definition paths_downward_closed_lt (A : Type@{i}) (x y : A) : + @paths (liftlt@{j i} A) x y -> paths x y. +Proof. + intros. destruct X. exact (idpath _). +Defined. + +Definition paths_downward_closed_lt_nolift (A : Type@{i}) (x y : A) : + paths@{j} x y -> paths x y. +Proof. + intros. destruct X. exact (idpath _). +Defined. + +Definition funext_downward_closed (F : Funext@{i' j' k'}) : + Funext@{i j k}. +Proof. + intros A B f g H. red in F. + pose (F A B f g (fun x => paths_lift _ _ _ (H x))). + apply paths_downward_closed_lt_nolift. apply p. +Defined. + diff --git a/test-suite/success/paralleltac.v b/test-suite/success/paralleltac.v new file mode 100644 index 00000000..94ff96ef --- /dev/null +++ b/test-suite/success/paralleltac.v @@ -0,0 +1,46 @@ +Fixpoint fib n := match n with + | O => 1 + | S m => match m with + | O => 1 + | S o => fib o + fib m end end. +Ltac sleep n := + try (assert (fib n = S (fib n)) by reflexivity). +(* Tune that depending on your PC *) +Let time := 18. + +Axiom P : nat -> Prop. +Axiom P_triv : Type -> forall x, P x. +Ltac solve_P := + match goal with |- P (S ?X) => + sleep time; exact (P_triv Type _) + end. + +Lemma test_old x : P (S x) /\ P (S x) /\ P (S x) /\ P (S x). +Proof. +repeat split. +idtac "T1: linear". +Time all: solve_P. +Qed. + +Lemma test_ok x : P (S x) /\ P (S x) /\ P (S x) /\ P (S x). +Proof. +repeat split. +idtac "T2: parallel". +Time par: solve_P. +Qed. + +Lemma test_fail x : P (S x) /\ P x /\ P (S x) /\ P (S x). +Proof. +repeat split. +idtac "T3: linear failure". +Fail Time all: solve_P. +all: apply (P_triv Type). +Qed. + +Lemma test_fail2 x : P (S x) /\ P x /\ P (S x) /\ P (S x). +Proof. +repeat split. +idtac "T4: parallel failure". +Fail Time par: solve_P. +all: apply (P_triv Type). +Qed. diff --git a/test-suite/success/params_ind.v b/test-suite/success/params_ind.v deleted file mode 100644 index 1bee31c8..00000000 --- a/test-suite/success/params_ind.v +++ /dev/null @@ -1,4 +0,0 @@ -Inductive list (A : Set) : Set := - | nil : list A - | cons : A -> list (A -> A) -> list A. - diff --git a/test-suite/success/polymorphism.v b/test-suite/success/polymorphism.v index 56cab0f6..9167c9fc 100644 --- a/test-suite/success/polymorphism.v +++ b/test-suite/success/polymorphism.v @@ -1,12 +1,294 @@ +Module withoutpoly. + +Inductive empty :=. + +Inductive emptyt : Type :=. +Inductive singleton : Type := + single. +Inductive singletoninfo : Type := + singleinfo : unit -> singletoninfo. +Inductive singletonset : Set := + singleset. + +Inductive singletonnoninfo : Type := + singlenoninfo : empty -> singletonnoninfo. + +Inductive singletoninfononinfo : Prop := + singleinfononinfo : unit -> singletoninfononinfo. + +Inductive bool : Type := + | true | false. + +Inductive smashedbool : Prop := + | trueP | falseP. +End withoutpoly. + +Set Universe Polymorphism. + +Inductive empty :=. +Inductive emptyt : Type :=. +Inductive singleton : Type := + single. +Inductive singletoninfo : Type := + singleinfo : unit -> singletoninfo. +Inductive singletonset : Set := + singleset. + +Inductive singletonnoninfo : Type := + singlenoninfo : empty -> singletonnoninfo. + +Inductive singletoninfononinfo : Prop := + singleinfononinfo : unit -> singletoninfononinfo. + +Inductive bool : Type := + | true | false. + +Inductive smashedbool : Prop := + | trueP | falseP. + +Section foo. + Let T := Type. + Inductive polybool : T := + | trueT | falseT. +End foo. + +Inductive list (A: Type) : Type := +| nil : list A +| cons : A -> list A -> list A. + +Module ftypSetSet. +Inductive ftyp : Type := + | Funit : ftyp + | Ffun : list ftyp -> ftyp + | Fref : area -> ftyp +with area : Type := + | Stored : ftyp -> area +. +End ftypSetSet. + + +Module ftypSetProp. +Inductive ftyp : Type := + | Funit : ftyp + | Ffun : list ftyp -> ftyp + | Fref : area -> ftyp +with area : Type := + | Stored : (* ftyp -> *)area +. +End ftypSetProp. + +Module ftypSetSetForced. +Inductive ftyp : Type := + | Funit : ftyp + | Ffun : list ftyp -> ftyp + | Fref : area -> ftyp +with area : Set (* Type *) := + | Stored : (* ftyp -> *)area +. +End ftypSetSetForced. + +Unset Universe Polymorphism. + +Set Printing Universes. +Module Easy. + + Polymorphic Inductive prod (A : Type) (B : Type) : Type := + pair : A -> B -> prod A B. + + Check prod nat nat. + Print Universes. + + + Polymorphic Inductive sum (A B:Type) : Type := + | inl : A -> sum A B + | inr : B -> sum A B. + Print sum. + Check (sum nat nat). + +End Easy. + +Section Hierarchy. + +Definition Type3 := Type. +Definition Type2 := Type : Type3. +Definition Type1 := Type : Type2. + +Definition id1 := ((forall A : Type1, A) : Type2). +Definition id2 := ((forall A : Type2, A) : Type3). +Definition id1' := ((forall A : Type1, A) : Type3). +Fail Definition id1impred := ((forall A : Type1, A) : Type1). + +End Hierarchy. + +Section structures. + +Record hypo : Type := mkhypo { + hypo_type : Type; + hypo_proof : hypo_type + }. + +Definition typehypo (A : Type) : hypo := {| hypo_proof := A |}. + +Polymorphic Record dyn : Type := + mkdyn { + dyn_type : Type; + dyn_proof : dyn_type + }. + +Definition monotypedyn (A : Type) : dyn := {| dyn_proof := A |}. +Polymorphic Definition typedyn (A : Type) : dyn := {| dyn_proof := A |}. + +Definition atypedyn : dyn := typedyn Type. + +Definition projdyn := dyn_type atypedyn. + +Definition nested := {| dyn_type := dyn; dyn_proof := atypedyn |}. + +Definition nested2 := {| dyn_type := dyn; dyn_proof := nested |}. + +Definition projnested2 := dyn_type nested2. + +Polymorphic Definition nest (d : dyn) := {| dyn_proof := d |}. + +Polymorphic Definition twoprojs (d : dyn) := dyn_proof d = dyn_proof d. + +End structures. + +Section cats. + Local Set Universe Polymorphism. + Require Import Utf8. + Definition fibration (A : Type) := A -> Type. + Definition Hom (A : Type) := A -> A -> Type. + + Record sigma (A : Type) (P : fibration A) := + { proj1 : A; proj2 : P proj1} . + + Class Identity {A} (M : Hom A) := + identity : ∀ x, M x x. + + Class Inverse {A} (M : Hom A) := + inverse : ∀ x y:A, M x y -> M y x. + + Class Composition {A} (M : Hom A) := + composition : ∀ {x y z:A}, M x y -> M y z -> M x z. + + Notation "g ° f" := (composition f g) (at level 50). + + Class Equivalence T (Eq : Hom T):= + { + Equivalence_Identity :> Identity Eq ; + Equivalence_Inverse :> Inverse Eq ; + Equivalence_Composition :> Composition Eq + }. + + Class EquivalenceType (T : Type) : Type := + { + m2: Hom T; + equiv_struct :> Equivalence T m2 }. + + Polymorphic Record cat (T : Type) := + { cat_hom : Hom T; + cat_equiv : forall x y, EquivalenceType (cat_hom x y) }. + + Definition catType := sigma Type cat. + + Notation "[ T ]" := (proj1 T). + + Require Import Program. + + Program Definition small_cat : cat Empty_set := + {| cat_hom x y := unit |}. + Next Obligation. + refine ({|m2:=fun x y => True|}). + constructor; red; intros; trivial. + Defined. + + Record iso (T U : Set) := + { f : T -> U; + g : U -> T }. + + Program Definition Set_cat : cat Set := + {| cat_hom := iso |}. + Next Obligation. + refine ({|m2:=fun x y => True|}). + constructor; red; intros; trivial. + Defined. + + Record isoT (T U : Type) := + { isoT_f : T -> U; + isoT_g : U -> T }. + + Program Definition Type_cat : cat Type := + {| cat_hom := isoT |}. + Next Obligation. + refine ({|m2:=fun x y => True|}). + constructor; red; intros; trivial. + Defined. + + Polymorphic Record cat1 (T : Type) := + { cat1_car : Type; + cat1_hom : Hom cat1_car; + cat1_hom_cat : forall x y, cat (cat1_hom x y) }. +End cats. + +Polymorphic Definition id {A : Type} (a : A) : A := a. + +Definition typeid := (@id Type). + + +Fail Check (Prop : Set). +Fail Check (Set : Set). +Check (Set : Type). +Check (Prop : Type). +Definition setType := $(let t := type of Set in exact t)$. + +Definition foo (A : Prop) := A. + +Fail Check foo Set. +Check fun A => foo A. +Fail Check fun A : Type => foo A. +Check fun A : Prop => foo A. +Fail Definition bar := fun A : Set => foo A. + +Fail Check (let A := Type in foo (id A)). + +Definition fooS (A : Set) := A. + +Check (let A := nat in fooS (id A)). +Fail Check (let A := Set in fooS (id A)). +Fail Check (let A := Prop in fooS (id A)). + (* Some tests of sort-polymorphisme *) Section S. -Variable A:Type. +Polymorphic Variable A:Type. (* Definition f (B:Type) := (A * B)%type. *) -Inductive I (B:Type) : Type := prod : A->B->I B. +Polymorphic Inductive I (B:Type) : Type := prod : A->B->I B. + +Check I nat. + End S. (* Check f nat nat : Set. *) -Check I nat nat : Set.
\ No newline at end of file +Definition foo' := I nat nat. +Print Universes. Print foo. Set Printing Universes. Print foo. + +(* Polymorphic axioms: *) +Polymorphic Axiom funext : forall (A B : Type) (f g : A -> B), + (forall x, f x = g x) -> f = g. + +(* Check @funext. *) +(* Check funext. *) + +Polymorphic Definition fun_ext (A B : Type) := + forall (f g : A -> B), + (forall x, f x = g x) -> f = g. + +Polymorphic Class Funext A B := extensional : fun_ext A B. + +Section foo2. + Context `{forall A B, Funext A B}. + Print Universes. +End foo2. diff --git a/test-suite/success/primitiveproj.v b/test-suite/success/primitiveproj.v new file mode 100644 index 00000000..068f8ac3 --- /dev/null +++ b/test-suite/success/primitiveproj.v @@ -0,0 +1,190 @@ +Set Primitive Projections. +Set Record Elimination Schemes. +Module Prim. + +Record F := { a : nat; b : a = a }. +Record G (A : Type) := { c : A; d : F }. + +Check c. +End Prim. +Module Univ. +Set Universe Polymorphism. +Set Implicit Arguments. +Record Foo (A : Type) := { foo : A }. + +Record G (A : Type) := { c : A; d : c = c; e : Foo A }. + +Definition Foon : Foo nat := {| foo := 0 |}. + +Definition Foonp : nat := Foon.(foo). + +Definition Gt : G nat := {| c:= 0; d:=eq_refl; e:= Foon |}. + +Check (Gt.(e)). + +Section bla. + + Record bar := { baz : nat; def := 0; baz' : forall x, x = baz \/ x = def }. +End bla. + +End Univ. + +Set Primitive Projections. +Unset Elimination Schemes. +Set Implicit Arguments. + +Check nat. + +(* Inductive X (U:Type) := Foo (k : nat) (x : X U). *) +(* Parameter x : X nat. *) +(* Check x.(k). *) + +Inductive X (U:Type) := { k : nat; a: k = k -> X U; b : let x := a eq_refl in X U }. + +Parameter x:X nat. +Check (a x : forall _ : @eq nat (k x) (k x), X nat). +Check (b x : X nat). + +Inductive Y := { next : option Y }. + +Check _.(next) : option Y. +Lemma eta_ind (y : Y) : y = Build_Y y.(next). +Proof. reflexivity. Defined. + +Variable t : Y. + +Fixpoint yn (n : nat) (y : Y) : Y := + match n with + | 0 => t + | S n => {| next := Some (yn n y) |} + end. + +Lemma eta_ind' (y: Y) : Some (yn 100 y) = Some {| next := (yn 100 y).(next) |}. +Proof. reflexivity. Defined. + + +(* + Rules for parsing and printing of primitive projections and their eta expansions. + If r : R A where R is a primitive record with implicit parameter A. + If p : forall {A} (r : R A) {A : Set}, list (A * B). +*) + +Record R {A : Type} := { p : forall {X : Set}, A * X }. +Arguments R : clear implicits. + +Record R' {A : Type} := { p' : forall X : Set, A * X }. +Arguments R' : clear implicits. + +Unset Printing All. + +Parameter r : R nat. + +Check (r.(p)). +Set Printing Projections. +Check (r.(p)). +Unset Printing Projections. +Set Printing All. +Check (r.(p)). +Unset Printing All. + +(* Check (r.(p)). + Elaborates to a primitive application, X arg implicit. + Of type nat * ?ex + No Printing All: p r + Set Printing Projections.: r.(p) + Printing All: r.(@p) ?ex + *) + +Check p r. +Set Printing Projections. +Check p r. +Unset Printing Projections. +Set Printing All. +Check p r. +Unset Printing All. + +Check p r (X:=nat). +Set Printing Projections. +Check p r (X:=nat). +Unset Printing Projections. +Set Printing All. +Check p r (X:=nat). +Unset Printing All. + +(* Same elaboration, printing for p r *) + +(** Explicit version of the primitive projection, under applied w.r.t implicit arguments + can be printed only using projection notation. r.(@p) *) +Check r.(@p _). +Set Printing Projections. +Check r.(@p _). +Unset Printing Projections. +Set Printing All. +Check r.(@p _). +Unset Printing All. + +(** Explicit version of the primitive projection, applied to its implicit arguments + can be printed using application notation r.(p), r.(@p) in fully explicit form *) +Check r.(@p _) nat. +Set Printing Projections. +Check r.(@p _) nat. +Unset Printing Projections. +Set Printing All. +Check r.(@p _) nat. +Unset Printing All. + +Parameter r' : R' nat. + +Check (r'.(p')). +Set Printing Projections. +Check (r'.(p')). +Unset Printing Projections. +Set Printing All. +Check (r'.(p')). +Unset Printing All. + +(* Check (r'.(p')). + Elaborates to a primitive application, X arg explicit. + Of type forall X : Set, nat * X + No Printing All: p' r' + Set Printing Projections.: r'.(p') + Printing All: r'.(@p') + *) + +Check p' r'. +Set Printing Projections. +Check p' r'. +Unset Printing Projections. +Set Printing All. +Check p' r'. +Unset Printing All. + +(* Same elaboration, printing for p r *) + +(** Explicit version of the primitive projection, under applied w.r.t implicit arguments + can be printed only using projection notation. r.(@p) *) +Check r'.(@p' _). +Set Printing Projections. +Check r'.(@p' _). +Unset Printing Projections. +Set Printing All. +Check r'.(@p' _). +Unset Printing All. + +(** Explicit version of the primitive projection, applied to its implicit arguments + can be printed only using projection notation r.(p), r.(@p) in fully explicit form *) +Check p' r' nat. +Set Printing Projections. +Check p' r' nat. +Unset Printing Projections. +Set Printing All. +Check p' r' nat. +Unset Printing All. + +Check (@p' nat). +Check p'. +Set Printing All. + +Check (@p' nat). +Check p'. +Unset Printing All. diff --git a/test-suite/success/proof_using.v b/test-suite/success/proof_using.v index bf302df4..dbbd57ae 100644 --- a/test-suite/success/proof_using.v +++ b/test-suite/success/proof_using.v @@ -65,3 +65,56 @@ End S1. Check (deep 3 4 : 3 = 4). Check (deep2 3 4 : 3 = 4). + +Section P1. + +Variable x : nat. +Variable y : nat. +Variable z : nat. + + +Collection TOTO := x y. + +Collection TITI := TOTO - x. + +Lemma t1 : True. Proof using TOTO. trivial. Qed. +Lemma t2 : True. Proof using TITI. trivial. Qed. + + Section P2. + Collection TOTO := x. + Lemma t3 : True. Proof using TOTO. trivial. Qed. + End P2. + +Lemma t4 : True. Proof using TOTO. trivial. Qed. + +End P1. + +Lemma t5 : True. Fail Proof using TOTO. trivial. Qed. + +Check (t1 1 2 : True). +Check (t2 1 : True). +Check (t3 1 : True). +Check (t4 1 2 : True). + + +Section T1. + +Variable x : nat. +Hypothesis px : 1 = x. +Let w := x + 1. + +Set Suggest Proof Using. + +Set Default Proof Using "Type". + +Lemma bla : 2 = w. +Proof. +admit. +Qed. + +End T1. + +Check (bla 7 : 2 = 8). + + + diff --git a/test-suite/success/refine.v b/test-suite/success/refine.v index 4d743a6d..1e667884 100644 --- a/test-suite/success/refine.v +++ b/test-suite/success/refine.v @@ -62,14 +62,14 @@ Abort. Goal (forall n : nat, n = 0 -> Prop) -> Prop. intro P. refine (P _ _). -reflexivity. +2:reflexivity. Abort. (* Submitted by Jacek Chrzaszcz (bug #1102) *) -(* le problme a t rsolu ici par normalisation des evars prsentes - dans les types d'evars, mais le problme reste a priori ouvert dans - le cas plus gnral d'evars non instancies dans les types d'autres +(* le problème a été résolu ici par normalisation des evars présentes + dans les types d'evars, mais le problème reste a priori ouvert dans + le cas plus général d'evars non instanciées dans les types d'autres evars *) Goal exists n:nat, n=n. @@ -84,7 +84,7 @@ Definition div : refine (fun m div_rec n => match div_rec m n with - | exist _ _ => _ + | exist _ _ _ => _ end). Abort. diff --git a/test-suite/success/rewrite.v b/test-suite/success/rewrite.v index 08c406be..6dcd6592 100644 --- a/test-suite/success/rewrite.v +++ b/test-suite/success/rewrite.v @@ -129,3 +129,22 @@ intros. Fail rewrite H in H0. Abort. +(* Test subst in the presence of a dependent let-in *) +(* Was not working prior to May 2014 *) + +Goal forall x y, x=y+0 -> let z := x+1 in x+1=y -> z=z -> z=x. +intros. +subst x. (* was failing *) +subst z. +rewrite H0. +auto with arith. +Qed. + +(* Check that evars are instantiated when the term to rewrite is + closed, like in the case it is open *) + +Goal exists x, S 0 = 0 -> S x = 0. +eexists. intro H. +rewrite H. +reflexivity. +Abort. diff --git a/test-suite/success/rewrite_dep.v b/test-suite/success/rewrite_dep.v new file mode 100644 index 00000000..fe250ae8 --- /dev/null +++ b/test-suite/success/rewrite_dep.v @@ -0,0 +1,33 @@ +Require Import Setoid. +Require Import Morphisms. +Require Vector. +Notation vector := Vector.t. +Notation Vcons n t := (@Vector.cons _ n _ t). + +Class Equiv A := equiv : A -> A -> Prop. +Class Setoid A `{Equiv A} := setoid_equiv:> Equivalence (equiv). + +Instance vecequiv A `{Equiv A} n : Equiv (vector A n). +admit. +Qed. + +Global Instance vcons_proper A `{Equiv A} `{!Setoid A} : + Proper (equiv ==> forall_relation (fun k => equiv ==> equiv)) + (@Vector.cons A). +Proof. Admitted. + +Instance vecseotid A `{Setoid A} n : Setoid (vector A n). +Proof. Admitted. + +(* Instance equiv_setoid A {e : Equiv A} {s : @Setoid A e} : Equivalence e. *) +(* apply setoid_equiv. *) +(* Qed. *) +(* Typeclasses Transparent Equiv. *) + +Goal forall A `{Equiv A} `{!Setoid A} (f : A -> A) (a b : A) (H : equiv a b) n (v : vector A n), + equiv (Vcons a v) (Vcons b v). +Proof. + intros. + rewrite H0. + reflexivity. +Qed.
\ No newline at end of file diff --git a/test-suite/success/rewrite_strat.v b/test-suite/success/rewrite_strat.v new file mode 100644 index 00000000..04c67556 --- /dev/null +++ b/test-suite/success/rewrite_strat.v @@ -0,0 +1,53 @@ +Require Import Setoid. + +Variable X : Set. + +Variable f : X -> X. +Variable g : X -> X -> X. +Variable h : nat -> X -> X. + +Variable lem0 : forall x, f (f x) = f x. +Variable lem1 : forall x, g x x = f x. +Variable lem2 : forall n x, h (S n) x = g (h n x) (h n x). +Variable lem3 : forall x, h 0 x = x. + +Hint Rewrite lem0 lem1 lem2 lem3 : rew. + +Goal forall x, h 10 x = f x. +Proof. + intros. + Time autorewrite with rew. (* 0.586 *) + reflexivity. +Time Qed. (* 0.53 *) + +Goal forall x, h 6 x = f x. +intros. + Time rewrite_strat topdown lem2. + Time rewrite_strat topdown lem1. + Time rewrite_strat topdown lem0. + Time rewrite_strat topdown lem3. + reflexivity. +Undo 5. + Time rewrite_strat topdown (choice lem2 lem1). + Time rewrite_strat topdown (choice lem0 lem3). + reflexivity. +Undo 3. + Time rewrite_strat (topdown (choice lem2 lem1); topdown (choice lem0 lem3)). + reflexivity. +Undo 2. + Time rewrite_strat (topdown (choice lem2 (choice lem1 (choice lem0 lem3)))). + reflexivity. +Undo 2. + Time rewrite_strat (topdown (choice lem2 (choice lem1 (choice lem0 lem3)))). + reflexivity. +Qed. + +Goal forall x, h 10 x = f x. +Proof. + intros. + Time rewrite_strat topdown (hints rew). (* 0.38 *) + reflexivity. +Time Qed. (* 0.06 s *) + +Set Printing All. +Set Printing Depth 100000.
\ No newline at end of file diff --git a/test-suite/success/setoid_test.v b/test-suite/success/setoid_test.v index 653b5bf9..be0d49e0 100644 --- a/test-suite/success/setoid_test.v +++ b/test-suite/success/setoid_test.v @@ -153,7 +153,7 @@ End mult. does not fix the instance at the first unification, use [at], or simply rewrite for this semantics. *) -Require Import Arith. +Parameter beq_nat : forall x y : nat, bool. Class Foo (A : Type) := {foo_neg : A -> A ; foo_prf : forall x : A, x = foo_neg x}. Instance: Foo nat. admit. Defined. diff --git a/test-suite/success/setoid_unif.v b/test-suite/success/setoid_unif.v new file mode 100644 index 00000000..912596b4 --- /dev/null +++ b/test-suite/success/setoid_unif.v @@ -0,0 +1,27 @@ +(* An example of unification in rewrite which uses eager substitution + of metas (provided by Pierre-Marie). + + Put in the test suite as an indication of what the use metas + eagerly flag provides, even though the concrete cases that use it + are seldom. Today supported thanks to a new flag for using evars + eagerly, after this variant of setoid rewrite started to use clause + environments based on evars (fbbe491cfa157da627) *) + +Require Import Setoid. + +Parameter elt : Type. +Parameter T : Type -> Type. +Parameter empty : forall A, T A. +Parameter MapsTo : forall A : Type, elt -> A -> T A -> Prop. + +(* Definition In A x t := exists e, MapsTo A x e t. *) +Axiom In : forall A, A -> T A -> Prop. +Axiom foo : forall A x, In A x (empty A) <-> False. + +Record R := { t : T unit; s : unit }. +Definition Empty := {| t := empty unit; s := tt |}. + +Goal forall x, ~ In _ x (t Empty). +Proof. +intros x. +rewrite foo. diff --git a/test-suite/success/simpl.v b/test-suite/success/simpl.v index 271e6ef7..b5330779 100644 --- a/test-suite/success/simpl.v +++ b/test-suite/success/simpl.v @@ -45,3 +45,55 @@ Goal forall A B (a:A) l f (i:B), fold_right f i ((a :: l))=i. simpl. admit. Qed. (* Qed will fail if simplification is incorrect (de Bruijn!) *) + +(* Check that maximally inserted arguments do not break interpretation + of references in simpl, vm_compute etc. *) + +Arguments fst {A} {B} p. + +Goal fst (0,0) = 0. +simpl fst. +Fail set (fst _). +Abort. + +Goal fst (0,0) = 0. +vm_compute fst. +Fail set (fst _). +Abort. + +Goal let f x := x + 0 in f 0 = 0. +intro. +vm_compute f. +Fail set (f _). +Abort. + +(* This is a change wrt 8.4 (waiting to know if it breaks script a lot or not)*) + +Goal 0+0=0. +Fail simpl @eq. +Abort. + +(* Check reference by notation in simpl *) + +Goal 0+0 = 0. +simpl "+". +Fail set (_ + _). +Abort. + +(* Check occurrences *) + +Record box A := Box { unbox : A }. + +Goal unbox _ (unbox _ (unbox _ (Box _ (Box _ (Box _ True))))) = + unbox _ (unbox _ (unbox _ (Box _ (Box _ (Box _ True))))). +simpl (unbox _ (unbox _ _)) at 1. +match goal with |- True = unbox _ (unbox _ (unbox _ (Box _ (Box _ (Box _ True))))) => idtac end. +Undo 2. +Fail simpl (unbox _ (unbox _ _)) at 5. +simpl (unbox _ (unbox _ _)) at 1 4. +match goal with |- True = unbox _ (Box _ True) => idtac end. +Undo 2. +Fail simpl (unbox _ (unbox _ _)) at 3 4. (* Nested and even overlapping *) +simpl (unbox _ (unbox _ _)) at 2 4. +match goal with |- unbox _ (Box _ True) = unbox _ (Box _ True) => idtac end. +Abort. diff --git a/test-suite/success/somatching.v b/test-suite/success/somatching.v new file mode 100644 index 00000000..5ed833ec --- /dev/null +++ b/test-suite/success/somatching.v @@ -0,0 +1,64 @@ +Goal forall A B C (p : forall (x : A) (y : B), C x y) (x : A) (y : B), True. +Proof. + intros A B C p x y. + match type of p with + | forall x y, @?F x y => pose F as C1 + end. + match type of p with + | forall x y, @?F y x => pose F as C2 + end. + assert (C1 x y) as ?. + assert (C2 y x) as ?. +Abort. + +Goal forall A B C D (p : forall (x : A) (y : B) (z : C), D x y) (x : A) (y : B), True. +Proof. + intros A B C D p x y. + match type of p with + | forall x y z, @?F x y => pose F as C1 + end. + assert (C1 x y) as ?. +Abort. + +Goal forall A B C D (p : forall (z : C) (x : A) (y : B), D x y) (x : A) (y : B), True. +Proof. + intros A B C D p x y. + match type of p with + | forall z x y, @?F x y => pose F as C1 + end. + assert (C1 x y) as ?. +Abort. + +(** Those should fail *) + +Goal forall A B C (p : forall (x : A) (y : B), C x y) (x : A) (y : B), True. +Proof. + intros A B C p x y. + Fail match type of p with + | forall x, @?F x y => pose F as C1 + end. + Fail match type of p with + | forall x y, @?F x x y => pose F as C1 + end. + Fail match type of p with + | forall x y, @?F x => pose F as C1 + end. +Abort. + +(** This one is badly typed *) + +Goal forall A (B : A -> Type) (C : forall x, B x -> Type), (forall x y, C x y) -> True. +Proof. +intros A B C p. +Fail match type of p with +| forall x y, @?F y x => idtac +end. +Abort. + +Goal forall A (B : A -> Type) (C : Type) (D : forall x, B x -> Type), (forall x (z : C) y, D x y) -> True. +Proof. +intros A B C D p. +match type of p with +| forall x z y, @?F x y => idtac +end. +Abort. diff --git a/test-suite/success/unfold.v b/test-suite/success/unfold.v index c067eb81..2954e255 100644 --- a/test-suite/success/unfold.v +++ b/test-suite/success/unfold.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/success/unicode_utf8.v b/test-suite/success/unicode_utf8.v index 42e32ccc..50a65310 100644 --- a/test-suite/success/unicode_utf8.v +++ b/test-suite/success/unicode_utf8.v @@ -11,11 +11,12 @@ Parameter π : ℝ. (** Check indices *) Definition test_indices : nat -> nat := fun x₁ => x₁. -Definition π₂ := snd. +Definition π₂ := @snd. (** More unicode in identifiers *) Definition αβ_áà_אב := 0. +Notation "C 'ᵒᵖ'" := C (at level 30). (** UNICODE IN STRINGS *) diff --git a/test-suite/success/unification.v b/test-suite/success/unification.v index 997dceb4..296686e1 100644 --- a/test-suite/success/unification.v +++ b/test-suite/success/unification.v @@ -1,3 +1,7 @@ +Let test_stack_unification_interaction_with_delta A + : (if negb _ then true else false) = if orb false (negb A) then true else false + := eq_refl. + (* Test patterns unification *) Lemma l1 : (forall P, (exists x:nat, P x) -> False) @@ -97,7 +101,7 @@ apply H. Qed. (* Feature deactivated in commit 14189 (see commit log) -(* Test instanciation of evars by unification *) +(* Test instantiation of evars by unification *) Goal (forall x, 0 + x = 0 -> True) -> True. intros; eapply H. diff --git a/test-suite/success/univscompute.v b/test-suite/success/univscompute.v new file mode 100644 index 00000000..1d60ab36 --- /dev/null +++ b/test-suite/success/univscompute.v @@ -0,0 +1,32 @@ +Set Universe Polymorphism. + +Polymorphic Definition id {A : Type} (a : A) := a. + +Eval vm_compute in id 1. + +Polymorphic Inductive ind (A : Type) := cons : A -> ind A. + +Eval vm_compute in ind unit. + +Check ind unit. + +Eval vm_compute in ind unit. + +Definition bar := Eval vm_compute in ind unit. +Definition bar' := Eval vm_compute in id (cons _ tt). + +Definition bar'' := Eval native_compute in id 1. +Definition bar''' := Eval native_compute in id (cons _ tt). + +Definition barty := Eval native_compute in id (cons _ Set). + +Definition one := @id. + +Monomorphic Definition sec := one. + +Eval native_compute in sec. +Definition sec' := Eval native_compute in sec. +Eval vm_compute in sec. +Definition sec'' := Eval vm_compute in sec. + + diff --git a/test-suite/typeclasses/NewSetoid.v b/test-suite/typeclasses/NewSetoid.v index 58668d03..6f37de65 100644 --- a/test-suite/typeclasses/NewSetoid.v +++ b/test-suite/typeclasses/NewSetoid.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,7 @@ (* Certified Haskell Prelude. * Author: Matthieu Sozeau - * Institution: LRI, CNRS UMR 8623 - Universitcopyright Paris Sud + * Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud * 91405 Orsay, France *) Require Import Coq.Program.Program. diff --git a/test-suite/typeclasses/backtrack.v b/test-suite/typeclasses/backtrack.v new file mode 100644 index 00000000..fff740ed --- /dev/null +++ b/test-suite/typeclasses/backtrack.v @@ -0,0 +1,84 @@ +(* Set Typeclasses Unique Instances *) +(** This lets typeclass search assume that instance heads are unique, + so if one matches no other need to be tried, + avoiding backtracking (even in unique solutions mode) + This is on a class-by-class basis. + *) + +(* Non unique *) +Class B. +Class A. +Set Typeclasses Unique Instances. +(* Unique *) +Class D. +Class C (A : Type) := c : A. + +Hint Mode C +. +Fail Definition test := c. + +Unset Typeclasses Unique Instances. +Instance : B -> D -> C nat := fun _ _ => 0. +Instance : A -> D -> C nat := fun _ _ => 0. +Instance : B -> C bool := fun _ => true. + +Instance : forall A, C A -> C (option A) := fun A _ => None. + +Set Typeclasses Debug. + +Set Typeclasses Unique Solutions. +(** This forces typeclass resolution to fail if at least two solutions + exist to a given set of constraints. This is a global setting. + For constraints involving assumed unique instances, it will not fail + if two such instances could apply, however it will fail if two different + instances of a unique class could apply. + *) +Fail Definition foo (d d' : D) (b b' : B) (a' a'' : A) := c : nat. +Definition foo (d d' : D) (b b' : B) (a' : A) := c : nat. + +Fail Definition foo' (b b' : B) := _ : B. +Unset Typeclasses Unique Solutions. +Definition foo' (b b' : B) := _ : B. + +Set Typeclasses Unique Solutions. +Definition foo'' (d d' : D) := _ : D. + +(** Cut backtracking *) +Module BacktrackGreenCut. + Unset Typeclasses Unique Solutions. + Class C (A : Type) := c : A. + + Class D (A : Type) : Type := { c_of_d :> C A }. + + Instance D1 : D unit. + Admitted. + + Instance D2 : D unit. + Admitted. + + (** Two instances of D unit, but when searching for [C unit], no + backtracking on the second instance should be needed except + in dependent cases. Check by adding an unresolvable constraint. + *) + + Variable f : D unit -> C bool -> True. + Fail Definition foo := f _ _. + + Fail Definition foo' := let y := _ : D unit in let x := _ : C bool in f _ x. + + Unset Typeclasses Strict Resolution. + Class Transitive (A : Type) := { trans : True }. + Class PreOrder (A : Type) := { preorder_trans :> Transitive A }. + Class PartialOrder (A : Type) := { partialorder_trans :> Transitive A }. + Class PartialOrder' (A : Type) := { partialorder_trans' :> Transitive A }. + + Instance: PreOrder nat. Admitted. + Instance: PartialOrder nat. Admitted. + + Class NoInst (A : Type) := {}. + + Variable foo : forall `{ T : Transitive nat } `{ NoInst (let x:=@trans _ T in nat) }, nat. + + Fail Definition bar := foo. + + +End BacktrackGreenCut. diff --git a/test-suite/typeclasses/deftwice.v b/test-suite/typeclasses/deftwice.v new file mode 100644 index 00000000..439782c9 --- /dev/null +++ b/test-suite/typeclasses/deftwice.v @@ -0,0 +1,9 @@ +Class C (A : Type) := c : A -> Type. + +Record Inhab (A : Type) := { witness : A }. + +Instance inhab_C : C Type := Inhab. + +Variable full : forall A (X : C A), forall x : A, c x. + +Definition truc {A : Type} : Inhab A := (full _ _ _).
\ No newline at end of file diff --git a/test-suite/vio/seff.v b/test-suite/vio/seff.v new file mode 100644 index 00000000..447e7798 --- /dev/null +++ b/test-suite/vio/seff.v @@ -0,0 +1,10 @@ +Inductive equal T (x : T) : T -> Type := Equal : equal T x x. + +Module bla. + +Lemma test n : equal nat n (n + n) -> equal nat (n + n + n) n. +Proof using. +intro H. rewrite <- H. rewrite <- H. exact (Equal nat n). +Qed. + +End bla. diff --git a/test-suite/vio/simple.v b/test-suite/vio/simple.v new file mode 100644 index 00000000..407074c1 --- /dev/null +++ b/test-suite/vio/simple.v @@ -0,0 +1,2 @@ +Lemma simple : True. +Proof using. trivial. Qed. diff --git a/test-suite/vio/univ_constraints_statements.v b/test-suite/vio/univ_constraints_statements.v new file mode 100644 index 00000000..bb6b9595 --- /dev/null +++ b/test-suite/vio/univ_constraints_statements.v @@ -0,0 +1,2 @@ +Lemma ssr_congr_arrow Plemma Pgoal : Plemma = Pgoal -> Plemma -> Pgoal. +Proof using. intro H; rewrite H; trivial. Qed. |