├── .gitignore ├── Makefile ├── Makefile.coq ├── README.md ├── _CoqProject ├── coq ├── Examples.v └── exercises │ ├── Geminio.v │ ├── GeminioNamed.v │ ├── ReducioDuo.v │ ├── ReducioMaxima.v │ ├── ReducioTria.v │ ├── Relashio.v │ └── Sectumsempra.v ├── licensing └── LICENSE ├── src ├── lib │ ├── basics.ml │ ├── basics.mli │ ├── collections.ml │ ├── collections.mli │ ├── coqterms.ml │ ├── coqterms.mli │ ├── debruijn.ml │ ├── debruijn.mli │ ├── hofs.ml │ ├── hofs.mli │ ├── printing.ml │ ├── printing.mli │ ├── substitution.ml │ └── substitution.mli ├── magic.ml4 ├── spells │ ├── levicorpus.ml │ ├── levicorpus.mli │ ├── reducio.ml │ ├── reducio.mli │ ├── sectumsempra.ml │ └── sectumsempra.mli └── wand.mlpack └── theories └── Wand.v /.gitignore: -------------------------------------------------------------------------------- 1 | *.cmi 2 | *.cmo 3 | *.cmx 4 | *.mlpack.d 5 | *.o 6 | *.ml4.d 7 | *.cmxs 8 | *.coq.bak 9 | *.aux 10 | *.glob 11 | *.v.d 12 | *.vo 13 | *.ml.d 14 | *.mli.d 15 | *~ 16 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: plugin install 2 | 3 | plugin: Makefile.coq 4 | $(MAKE) -f Makefile.coq 5 | 6 | Makefile.coq: 7 | coq_makefile -f _CoqProject -o Makefile.coq 8 | 9 | clean: 10 | $(MAKE) -f Makefile.coq clean 11 | rm -f Makefile.coq 12 | 13 | install: 14 | $(MAKE) -f Makefile.coq install 15 | 16 | uninstall: 17 | $(MAKE) -f Makefile.coq uninstall 18 | 19 | .PHONY: all plugin clean install uninstall 20 | -------------------------------------------------------------------------------- /Makefile.coq: -------------------------------------------------------------------------------- 1 | ############################################################################### 2 | ## v # The Coq Proof Assistant ## 3 | ## /dev/null 2>/dev/null; echo $$?)) 72 | STDTIME?=/usr/bin/env time -f $(TIMEFMT) 73 | else 74 | ifeq (0,$(shell gtime -f $(TIMEFMT) true >/dev/null 2>/dev/null; echo $$?)) 75 | STDTIME?=gtime -f $(TIMEFMT) 76 | else 77 | STDTIME?=time 78 | endif 79 | endif 80 | else 81 | STDTIME?=/usr/bin/env time -f $(TIMEFMT) 82 | endif 83 | 84 | # Coq binaries 85 | COQC ?= "$(COQBIN)coqc" 86 | COQTOP ?= "$(COQBIN)coqtop" 87 | COQCHK ?= "$(COQBIN)coqchk" 88 | COQDEP ?= "$(COQBIN)coqdep" 89 | GALLINA ?= "$(COQBIN)gallina" 90 | COQDOC ?= "$(COQBIN)coqdoc" 91 | COQMKFILE ?= "$(COQBIN)coq_makefile" 92 | 93 | # Timing scripts 94 | COQMAKE_ONE_TIME_FILE ?= "$(COQLIB)/tools/make-one-time-file.py" 95 | COQMAKE_BOTH_TIME_FILES ?= "$(COQLIB)/tools/make-both-time-files.py" 96 | COQMAKE_BOTH_SINGLE_TIMING_FILES ?= "$(COQLIB)/tools/make-both-single-timing-files.py" 97 | BEFORE ?= 98 | AFTER ?= 99 | 100 | # FIXME this should be generated by Coq (modules already linked by Coq) 101 | CAMLDONTLINK=camlp5.gramlib,unix,str 102 | 103 | # OCaml binaries 104 | CAMLC ?= "$(OCAMLFIND)" ocamlc -c 105 | CAMLOPTC ?= "$(OCAMLFIND)" opt -c 106 | CAMLLINK ?= "$(OCAMLFIND)" ocamlc -linkpkg -dontlink $(CAMLDONTLINK) 107 | CAMLOPTLINK ?= "$(OCAMLFIND)" opt -linkpkg -dontlink $(CAMLDONTLINK) 108 | CAMLDOC ?= "$(OCAMLFIND)" ocamldoc 109 | CAMLDEP ?= "$(OCAMLFIND)" ocamldep -slash -ml-synonym .ml4 -ml-synonym .mlpack 110 | 111 | # DESTDIR is prepended to all installation paths 112 | DESTDIR ?= 113 | 114 | # Debug builds, typically -g to OCaml, -debug to Coq. 115 | CAMLDEBUG ?= 116 | COQDEBUG ?= 117 | 118 | # Extra packages to be linked in (as in findlib -package) 119 | CAMLPKGS ?= 120 | 121 | # Option for making timing files 122 | TIMING?= 123 | # Option for changing sorting of timing output file 124 | TIMING_SORT_BY ?= auto 125 | # Output file names for timed builds 126 | TIME_OF_BUILD_FILE ?= time-of-build.log 127 | TIME_OF_BUILD_BEFORE_FILE ?= time-of-build-before.log 128 | TIME_OF_BUILD_AFTER_FILE ?= time-of-build-after.log 129 | TIME_OF_PRETTY_BUILD_FILE ?= time-of-build-pretty.log 130 | TIME_OF_PRETTY_BOTH_BUILD_FILE ?= time-of-build-both.log 131 | TIME_OF_PRETTY_BUILD_EXTRA_FILES ?= - # also output to the command line 132 | 133 | ########## End of parameters ################################################## 134 | # What follows may be relevant to you only if you need to 135 | # extend this Makefile. If so, look for 'Extension point' here and 136 | # put in Makefile.coq.local double colon rules accordingly. 137 | # E.g. to perform some work after the all target completes you can write 138 | # 139 | # post-all:: 140 | # echo "All done!" 141 | # 142 | # in Makefile.coq.local 143 | # 144 | ############################################################################### 145 | 146 | 147 | 148 | 149 | # Flags ####################################################################### 150 | # 151 | # We define a bunch of variables combining the parameters 152 | 153 | SHOW := $(if $(VERBOSE),@true "",@echo "") 154 | HIDE := $(if $(VERBOSE),,@) 155 | 156 | TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) 157 | 158 | OPT?= 159 | 160 | # The DYNOBJ and DYNLIB variables are used by "coqdep -dyndep var" in .v.d 161 | ifeq '$(OPT)' '-byte' 162 | USEBYTE:=true 163 | DYNOBJ:=.cma 164 | DYNLIB:=.cma 165 | else 166 | USEBYTE:= 167 | DYNOBJ:=.cmxs 168 | DYNLIB:=.cmxs 169 | endif 170 | 171 | COQFLAGS?=-q $(OPT) $(COQLIBS) $(OTHERFLAGS) 172 | COQCHKFLAGS?=-silent -o $(COQLIBS) 173 | COQDOCFLAGS?=-interpolate -utf8 174 | COQDOCLIBS?=$(COQLIBS_NOML) 175 | 176 | # The version of Coq being run and the version of coq_makefile that 177 | # generated this makefile 178 | COQ_VERSION:=$(shell $(COQC) --print-version | cut -d " " -f 1) 179 | COQMAKEFILE_VERSION:=8.8.0 180 | 181 | COQSRCLIBS?= $(foreach d,$(COQ_SRC_SUBDIRS), -I "$(COQLIB)$(d)") 182 | 183 | CAMLFLAGS+=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP5LIB) 184 | 185 | # ocamldoc fails with unknown argument otherwise 186 | CAMLDOCFLAGS=$(filter-out -annot, $(filter-out -bin-annot, $(CAMLFLAGS))) 187 | 188 | # FIXME This should be generated by Coq 189 | GRAMMARS:=grammar.cma 190 | CAMLP5EXTEND=pa_extend.cmo q_MLast.cmo pa_macro.cmo 191 | 192 | CAMLLIB:=$(shell "$(OCAMLFIND)" printconf stdlib 2> /dev/null) 193 | ifeq (,$(CAMLLIB)) 194 | PP=$(error "Cannot find the 'ocamlfind' binary used to build Coq ($(OCAMLFIND)). Pre-compiled binary packages of Coq do not support compiling plugins this way. Please download the sources of Coq and run the Windows build script.") 195 | else 196 | PP:=-pp '$(CAMLP5O) -I $(CAMLLIB) -I "$(COQLIB)/grammar" $(CAMLP5EXTEND) $(GRAMMARS) $(CAMLP5OPTIONS) -impl' 197 | endif 198 | 199 | ifneq (,$(TIMING)) 200 | TIMING_ARG=-time 201 | ifeq (after,$(TIMING)) 202 | TIMING_EXT=after-timing 203 | else 204 | ifeq (before,$(TIMING)) 205 | TIMING_EXT=before-timing 206 | else 207 | TIMING_EXT=timing 208 | endif 209 | endif 210 | else 211 | TIMING_ARG= 212 | endif 213 | 214 | # Retro compatibility (DESTDIR is standard on Unix, DSTROOT is not) 215 | ifdef DSTROOT 216 | DESTDIR := $(DSTROOT) 217 | endif 218 | 219 | concat_path = $(if $(1),$(1)/$(subst $(COQMF_WINDRIVE),/,$(2)),$(2)) 220 | 221 | COQLIBINSTALL = $(call concat_path,$(DESTDIR),$(COQLIB)user-contrib) 222 | COQDOCINSTALL = $(call concat_path,$(DESTDIR),$(DOCDIR)user-contrib) 223 | COQTOPINSTALL = $(call concat_path,$(DESTDIR),$(COQLIB)toploop) 224 | 225 | # Files ####################################################################### 226 | # 227 | # We here define a bunch of variables about the files being part of the 228 | # Coq project in order to ease the writing of build target and build rules 229 | 230 | VDFILE := .coqdeps 231 | 232 | ALLSRCFILES := \ 233 | $(ML4FILES) \ 234 | $(MLFILES) \ 235 | $(MLPACKFILES) \ 236 | $(MLLIBFILES) \ 237 | $(MLIFILES) 238 | 239 | # helpers 240 | vo_to_obj = $(addsuffix .o,\ 241 | $(filter-out Warning: Error:,\ 242 | $(shell $(COQTOP) -q -noinit -batch -quiet -print-mod-uid $(1)))) 243 | strip_dotslash = $(patsubst ./%,%,$(1)) 244 | VO = vo 245 | 246 | VOFILES = $(VFILES:.v=.$(VO)) 247 | GLOBFILES = $(VFILES:.v=.glob) 248 | GFILES = $(VFILES:.v=.g) 249 | HTMLFILES = $(VFILES:.v=.html) 250 | GHTMLFILES = $(VFILES:.v=.g.html) 251 | BEAUTYFILES = $(addsuffix .beautified,$(VFILES)) 252 | TEXFILES = $(VFILES:.v=.tex) 253 | GTEXFILES = $(VFILES:.v=.g.tex) 254 | CMOFILES = \ 255 | $(ML4FILES:.ml4=.cmo) \ 256 | $(MLFILES:.ml=.cmo) \ 257 | $(MLPACKFILES:.mlpack=.cmo) 258 | CMXFILES = $(CMOFILES:.cmo=.cmx) 259 | OFILES = $(CMXFILES:.cmx=.o) 260 | CMAFILES = $(MLLIBFILES:.mllib=.cma) $(MLPACKFILES:.mlpack=.cma) 261 | CMXAFILES = $(CMAFILES:.cma=.cmxa) 262 | CMIFILES = \ 263 | $(CMOFILES:.cmo=.cmi) \ 264 | $(MLIFILES:.mli=.cmi) 265 | # the /if/ is because old _CoqProject did not list a .ml(pack|lib) but just 266 | # a .ml4 file 267 | CMXSFILES = \ 268 | $(MLPACKFILES:.mlpack=.cmxs) \ 269 | $(CMXAFILES:.cmxa=.cmxs) \ 270 | $(if $(MLPACKFILES)$(CMXAFILES),,\ 271 | $(ML4FILES:.ml4=.cmxs) $(MLFILES:.ml=.cmxs)) 272 | 273 | # files that are packed into a plugin (no extension) 274 | PACKEDFILES = \ 275 | $(call strip_dotslash, \ 276 | $(foreach lib, \ 277 | $(call strip_dotslash, \ 278 | $(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES)),$($(lib)))) 279 | # files that are archived into a .cma (mllib) 280 | LIBEDFILES = \ 281 | $(call strip_dotslash, \ 282 | $(foreach lib, \ 283 | $(call strip_dotslash, \ 284 | $(MLLIBFILES:.mllib=_MLLIB_DEPENDENCIES)),$($(lib)))) 285 | CMIFILESTOINSTALL = $(filter-out $(addsuffix .cmi,$(PACKEDFILES)),$(CMIFILES)) 286 | CMOFILESTOINSTALL = $(filter-out $(addsuffix .cmo,$(PACKEDFILES)),$(CMOFILES)) 287 | OBJFILES = $(call vo_to_obj,$(VOFILES)) 288 | ALLNATIVEFILES = \ 289 | $(OBJFILES:.o=.cmi) \ 290 | $(OBJFILES:.o=.cmx) \ 291 | $(OBJFILES:.o=.cmxs) 292 | # trick: wildcard filters out non-existing files, so that `install` doesn't show 293 | # warnings and `clean` doesn't pass to rm a list of files that is too long for 294 | # the shell. 295 | NATIVEFILES = $(wildcard $(ALLNATIVEFILES)) 296 | FILESTOINSTALL = \ 297 | $(VOFILES) \ 298 | $(VFILES) \ 299 | $(GLOBFILES) \ 300 | $(NATIVEFILES) \ 301 | $(CMIFILESTOINSTALL) 302 | BYTEFILESTOINSTALL = \ 303 | $(CMOFILESTOINSTALL) \ 304 | $(CMAFILES) 305 | ifeq '$(HASNATDYNLINK)' 'true' 306 | DO_NATDYNLINK = yes 307 | FILESTOINSTALL += $(CMXSFILES) $(CMXAFILES) $(CMOFILESTOINSTALL:.cmo=.cmx) 308 | else 309 | DO_NATDYNLINK = 310 | endif 311 | 312 | ALLDFILES = $(addsuffix .d,$(ALLSRCFILES) $(VDFILE)) 313 | 314 | # Compilation targets ######################################################### 315 | 316 | all: 317 | $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" pre-all 318 | $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" real-all 319 | $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" post-all 320 | .PHONY: all 321 | 322 | all.timing.diff: 323 | $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" pre-all 324 | $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" real-all.timing.diff TIME_OF_PRETTY_BUILD_EXTRA_FILES="" 325 | $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" post-all 326 | .PHONY: all.timing.diff 327 | 328 | make-pretty-timed-before:: TIME_OF_BUILD_FILE=$(TIME_OF_BUILD_BEFORE_FILE) 329 | make-pretty-timed-after:: TIME_OF_BUILD_FILE=$(TIME_OF_BUILD_AFTER_FILE) 330 | make-pretty-timed make-pretty-timed-before make-pretty-timed-after:: 331 | $(HIDE)rm -f pretty-timed-success.ok 332 | $(HIDE)($(MAKE) --no-print-directory -f "$(PARENT)" $(TGTS) TIMED=1 2>&1 && touch pretty-timed-success.ok) | tee -a $(TIME_OF_BUILD_FILE) 333 | $(HIDE)rm pretty-timed-success.ok # must not be -f; must fail if the touch failed 334 | print-pretty-timed:: 335 | $(HIDE)$(COQMAKE_ONE_TIME_FILE) $(TIME_OF_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) 336 | print-pretty-timed-diff:: 337 | $(HIDE)$(COQMAKE_BOTH_TIME_FILES) --sort-by=$(TIMING_SORT_BY) $(TIME_OF_BUILD_BEFORE_FILE) $(TIME_OF_BUILD_AFTER_FILE) $(TIME_OF_PRETTY_BOTH_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) 338 | ifeq (,$(BEFORE)) 339 | print-pretty-single-time-diff:: 340 | @echo 'Error: Usage: $(MAKE) print-pretty-single-time-diff BEFORE=path/to/file.v.before-timing AFTER=path/to/file.v.after-timing' 341 | $(HIDE)false 342 | else 343 | ifeq (,$(AFTER)) 344 | print-pretty-single-time-diff:: 345 | @echo 'Error: Usage: $(MAKE) print-pretty-single-time-diff BEFORE=path/to/file.v.before-timing AFTER=path/to/file.v.after-timing' 346 | $(HIDE)false 347 | else 348 | print-pretty-single-time-diff:: 349 | $(HIDE)$(COQMAKE_BOTH_SINGLE_TIMING_FILES) --sort-by=$(TIMING_SORT_BY) $(BEFORE) $(AFTER) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) 350 | endif 351 | endif 352 | pretty-timed: 353 | $(HIDE)$(MAKE) --no-print-directory -f "$(PARENT)" make-pretty-timed 354 | $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" print-pretty-timed 355 | .PHONY: pretty-timed make-pretty-timed make-pretty-timed-before make-pretty-timed-after print-pretty-timed print-pretty-timed-diff print-pretty-single-time-diff 356 | 357 | # Extension points for actions to be performed before/after the all target 358 | pre-all:: 359 | @# Extension point 360 | $(HIDE)if [ "$(COQMAKEFILE_VERSION)" != "$(COQ_VERSION)" ]; then\ 361 | echo "W: This Makefile was generated by Coq $(COQMAKEFILE_VERSION)";\ 362 | echo "W: while the current Coq version is $(COQ_VERSION)";\ 363 | fi 364 | .PHONY: pre-all 365 | 366 | post-all:: 367 | @# Extension point 368 | .PHONY: post-all 369 | 370 | real-all: $(VOFILES) $(if $(USEBYTE),bytefiles,optfiles) 371 | .PHONY: real-all 372 | 373 | real-all.timing.diff: $(VOFILES:.vo=.v.timing.diff) 374 | .PHONE: real-all.timing.diff 375 | 376 | bytefiles: $(CMOFILES) $(CMAFILES) 377 | .PHONY: bytefiles 378 | 379 | optfiles: $(if $(DO_NATDYNLINK),$(CMXSFILES)) 380 | .PHONY: optfiles 381 | 382 | # FIXME, see Ralf's bugreport 383 | quick: $(VOFILES:.vo=.vio) 384 | .PHONY: quick 385 | 386 | vio2vo: 387 | $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) \ 388 | -schedule-vio2vo $(J) $(VOFILES:%.vo=%.vio) 389 | .PHONY: vio2vo 390 | 391 | quick2vo: 392 | $(HIDE)make -j $(J) quick 393 | $(HIDE)VIOFILES=$$(for vofile in $(VOFILES); do \ 394 | viofile="$$(echo "$$vofile" | sed "s/\.vo$$/.vio/")"; \ 395 | if [ "$$vofile" -ot "$$viofile" -o ! -e "$$vofile" ]; then printf "$$viofile "; fi; \ 396 | done); \ 397 | echo "VIO2VO: $$VIOFILES"; \ 398 | if [ -n "$$VIOFILES" ]; then \ 399 | $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) -schedule-vio2vo $(J) $$VIOFILES; \ 400 | fi 401 | .PHONY: quick2vo 402 | 403 | checkproofs: 404 | $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) \ 405 | -schedule-vio-checking $(J) $(VOFILES:%.vo=%.vio) 406 | .PHONY: checkproofs 407 | 408 | validate: $(VOFILES) 409 | $(TIMER) $(COQCHK) $(COQCHKFLAGS) $^ 410 | .PHONY: validate 411 | 412 | only: $(TGTS) 413 | .PHONY: only 414 | 415 | # Documentation targets ####################################################### 416 | 417 | html: $(GLOBFILES) $(VFILES) 418 | $(SHOW)'COQDOC -d html $(GAL)' 419 | $(HIDE)mkdir -p html 420 | $(HIDE)$(COQDOC) \ 421 | -toc $(COQDOCFLAGS) -html $(GAL) $(COQDOCLIBS) -d html $(VFILES) 422 | 423 | mlihtml: $(MLIFILES:.mli=.cmi) 424 | $(SHOW)'CAMLDOC -d $@' 425 | $(HIDE)mkdir $@ || rm -rf $@/* 426 | $(HIDE)$(CAMLDOC) -html \ 427 | -d $@ -m A $(CAMLDEBUG) $(CAMLDOCFLAGS) $(MLIFILES) 428 | 429 | all-mli.tex: $(MLIFILES:.mli=.cmi) 430 | $(SHOW)'CAMLDOC -latex $@' 431 | $(HIDE)$(CAMLDOC) -latex \ 432 | -o $@ -m A $(CAMLDEBUG) $(CAMLDOCFLAGS) $(MLIFILES) 433 | 434 | gallina: $(GFILES) 435 | 436 | all.ps: $(VFILES) 437 | $(SHOW)'COQDOC -ps $(GAL)' 438 | $(HIDE)$(COQDOC) \ 439 | -toc $(COQDOCFLAGS) -ps $(GAL) $(COQDOCLIBS) \ 440 | -o $@ `$(COQDEP) -sort -suffix .v $(VFILES)` 441 | 442 | all.pdf: $(VFILES) 443 | $(SHOW)'COQDOC -pdf $(GAL)' 444 | $(HIDE)$(COQDOC) \ 445 | -toc $(COQDOCFLAGS) -pdf $(GAL) $(COQDOCLIBS) \ 446 | -o $@ `$(COQDEP) -sort -suffix .v $(VFILES)` 447 | 448 | # FIXME: not quite right, since the output name is different 449 | gallinahtml: GAL=-g 450 | gallinahtml: html 451 | 452 | all-gal.ps: GAL=-g 453 | all-gal.ps: all.ps 454 | 455 | all-gal.pdf: GAL=-g 456 | all-gal.pdf: all.pdf 457 | 458 | # ? 459 | beautify: $(BEAUTYFILES) 460 | for file in $^; do mv $${file%.beautified} $${file%beautified}old && mv $${file} $${file%.beautified}; done 461 | @echo 'Do not do "make clean" until you are sure that everything went well!' 462 | @echo 'If there were a problem, execute "for file in $$(find . -name \*.v.old -print); do mv $${file} $${file%.old}; done" in your shell/' 463 | .PHONY: beautify 464 | 465 | # Installation targets ######################################################## 466 | # 467 | # There rules can be extended in Makefile.coq.local 468 | # Extensions can't assume when they run. 469 | 470 | install: 471 | $(HIDE)for f in $(FILESTOINSTALL); do\ 472 | df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`";\ 473 | if [ "$$?" != "0" -o -z "$$df" ]; then\ 474 | echo SKIP "$$f" since it has no logical path;\ 475 | else\ 476 | install -d "$(COQLIBINSTALL)/$$df" &&\ 477 | install -m 0644 "$$f" "$(COQLIBINSTALL)/$$df" &&\ 478 | echo INSTALL "$$f" "$(COQLIBINSTALL)/$$df";\ 479 | fi;\ 480 | done 481 | $(HIDE)$(MAKE) install-extra -f "$(SELF)" 482 | install-extra:: 483 | @# Extension point 484 | .PHONY: install install-extra 485 | 486 | install-byte: 487 | $(HIDE)for f in $(BYTEFILESTOINSTALL); do\ 488 | df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`";\ 489 | if [ "$$?" != "0" -o -z "$$df" ]; then\ 490 | echo SKIP "$$f" since it has no logical path;\ 491 | else\ 492 | install -d "$(COQLIBINSTALL)/$$df" &&\ 493 | install -m 0644 "$$f" "$(COQLIBINSTALL)/$$df" &&\ 494 | echo INSTALL "$$f" "$(COQLIBINSTALL)/$$df";\ 495 | fi;\ 496 | done 497 | 498 | install-doc:: html mlihtml 499 | @# Extension point 500 | $(HIDE)install -d "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html" 501 | $(HIDE)for i in html/*; do \ 502 | dest="$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/$$i";\ 503 | install -m 0644 "$$i" "$$dest";\ 504 | echo INSTALL "$$i" "$$dest";\ 505 | done 506 | $(HIDE)install -d \ 507 | "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml" 508 | $(HIDE)for i in mlihtml/*; do \ 509 | dest="$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/$$i";\ 510 | install -m 0644 "$$i" "$$dest";\ 511 | echo INSTALL "$$i" "$$dest";\ 512 | done 513 | .PHONY: install-doc 514 | 515 | uninstall:: 516 | @# Extension point 517 | $(HIDE)for f in $(FILESTOINSTALL); do \ 518 | df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`" &&\ 519 | instf="$(COQLIBINSTALL)/$$df/`basename $$f`" &&\ 520 | rm -f "$$instf" &&\ 521 | echo RM "$$instf" &&\ 522 | (rmdir "$(call concat_path,,$(COQLIBINSTALL)/$$df/)" 2>/dev/null || true); \ 523 | done 524 | .PHONY: uninstall 525 | 526 | uninstall-doc:: 527 | @# Extension point 528 | $(SHOW)'RM $(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html' 529 | $(HIDE)rm -rf "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html" 530 | $(SHOW)'RM $(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml' 531 | $(HIDE)rm -rf "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml" 532 | $(HIDE) rmdir "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/" || true 533 | .PHONY: uninstall-doc 534 | 535 | # Cleaning #################################################################### 536 | # 537 | # There rules can be extended in Makefile.coq.local 538 | # Extensions can't assume when they run. 539 | 540 | clean:: 541 | @# Extension point 542 | $(SHOW)'CLEAN' 543 | $(HIDE)rm -f $(CMOFILES) 544 | $(HIDE)rm -f $(CMIFILES) 545 | $(HIDE)rm -f $(CMAFILES) 546 | $(HIDE)rm -f $(CMOFILES:.cmo=.cmx) 547 | $(HIDE)rm -f $(CMXAFILES) 548 | $(HIDE)rm -f $(CMXSFILES) 549 | $(HIDE)rm -f $(CMOFILES:.cmo=.o) 550 | $(HIDE)rm -f $(CMXAFILES:.cmxa=.a) 551 | $(HIDE)rm -f $(ALLDFILES) 552 | $(HIDE)rm -f $(NATIVEFILES) 553 | $(HIDE)find . -name .coq-native -type d -empty -delete 554 | $(HIDE)rm -f $(VOFILES) 555 | $(HIDE)rm -f $(VOFILES:.vo=.vio) 556 | $(HIDE)rm -f $(GFILES) 557 | $(HIDE)rm -f $(BEAUTYFILES) $(VFILES:=.old) 558 | $(HIDE)rm -f all.ps all-gal.ps all.pdf all-gal.pdf all.glob all-mli.tex 559 | $(HIDE)rm -f $(VFILES:.v=.glob) 560 | $(HIDE)rm -f $(VFILES:.v=.tex) 561 | $(HIDE)rm -f $(VFILES:.v=.g.tex) 562 | $(HIDE)rm -f pretty-timed-success.ok 563 | $(HIDE)rm -rf html mlihtml 564 | .PHONY: clean 565 | 566 | cleanall:: clean 567 | @# Extension point 568 | $(SHOW)'CLEAN *.aux *.timing' 569 | $(HIDE)rm -f $(foreach f,$(VFILES:.v=),$(dir $(f)).$(notdir $(f)).aux) 570 | $(HIDE)rm -f $(TIME_OF_BUILD_FILE) $(TIME_OF_BUILD_BEFORE_FILE) $(TIME_OF_BUILD_AFTER_FILE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BOTH_BUILD_FILE) 571 | $(HIDE)rm -f $(VOFILES:.vo=.v.timing) 572 | $(HIDE)rm -f $(VOFILES:.vo=.v.before-timing) 573 | $(HIDE)rm -f $(VOFILES:.vo=.v.after-timing) 574 | $(HIDE)rm -f $(VOFILES:.vo=.v.timing.diff) 575 | .PHONY: cleanall 576 | 577 | archclean:: 578 | @# Extension point 579 | $(SHOW)'CLEAN *.cmx *.o' 580 | $(HIDE)rm -f $(NATIVEFILES) 581 | $(HIDE)rm -f $(CMOFILES:%.cmo=%.cmx) 582 | .PHONY: archclean 583 | 584 | 585 | # Compilation rules ########################################################### 586 | 587 | $(MLIFILES:.mli=.cmi): %.cmi: %.mli 588 | $(SHOW)'CAMLC -c $<' 589 | $(HIDE)$(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $< 590 | 591 | $(ML4FILES:.ml4=.cmo): %.cmo: %.ml4 592 | $(SHOW)'CAMLC -pp -c $<' 593 | $(HIDE)$(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $(PP) -impl $< 594 | 595 | $(ML4FILES:.ml4=.cmx): %.cmx: %.ml4 596 | $(SHOW)'CAMLOPT -pp -c $(FOR_PACK) $<' 597 | $(HIDE)$(CAMLOPTC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $(PP) $(FOR_PACK) -impl $< 598 | 599 | $(MLFILES:.ml=.cmo): %.cmo: %.ml 600 | $(SHOW)'CAMLC -c $<' 601 | $(HIDE)$(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $< 602 | 603 | $(MLFILES:.ml=.cmx): %.cmx: %.ml 604 | $(SHOW)'CAMLOPT -c $(FOR_PACK) $<' 605 | $(HIDE)$(CAMLOPTC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $(FOR_PACK) $< 606 | 607 | 608 | $(MLLIBFILES:.mllib=.cmxs): %.cmxs: %.cmxa 609 | $(SHOW)'CAMLOPT -shared -o $@' 610 | $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ 611 | -linkall -shared -o $@ $< 612 | 613 | $(MLLIBFILES:.mllib=.cma): %.cma: | %.mllib 614 | $(SHOW)'CAMLC -a -o $@' 615 | $(HIDE)$(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) -a -o $@ $^ 616 | 617 | $(MLLIBFILES:.mllib=.cmxa): %.cmxa: | %.mllib 618 | $(SHOW)'CAMLOPT -a -o $@' 619 | $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) -a -o $@ $^ 620 | 621 | 622 | $(MLPACKFILES:.mlpack=.cmxs): %.cmxs: %.cmxa 623 | $(SHOW)'CAMLOPT -shared -o $@' 624 | $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ 625 | -shared -linkall -o $@ $< 626 | 627 | $(MLPACKFILES:.mlpack=.cmxa): %.cmxa: %.cmx 628 | $(SHOW)'CAMLOPT -a -o $@' 629 | $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -a -o $@ $< 630 | 631 | $(MLPACKFILES:.mlpack=.cma): %.cma: %.cmo | %.mlpack 632 | $(SHOW)'CAMLC -a -o $@' 633 | $(HIDE)$(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) -a -o $@ $^ 634 | 635 | $(MLPACKFILES:.mlpack=.cmo): %.cmo: | %.mlpack 636 | $(SHOW)'CAMLC -pack -o $@' 637 | $(HIDE)$(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) -pack -o $@ $^ 638 | 639 | $(MLPACKFILES:.mlpack=.cmx): %.cmx: | %.mlpack 640 | $(SHOW)'CAMLOPT -pack -o $@' 641 | $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -pack -o $@ $^ 642 | 643 | # This rule is for _CoqProject with no .mllib nor .mlpack 644 | $(filter-out $(MLLIBFILES:.mllib=.cmxs) $(MLPACKFILES:.mlpack=.cmxs) $(addsuffix .cmxs,$(PACKEDFILES)) $(addsuffix .cmxs,$(LIBEDFILES)),$(MLFILES:.ml=.cmxs) $(ML4FILES:.ml4=.cmxs)): %.cmxs: %.cmx 645 | $(SHOW)'[deprecated,use-mllib-or-mlpack] CAMLOPT -shared -o $@' 646 | $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ 647 | -shared -o $@ $< 648 | 649 | ifneq (,$(TIMING)) 650 | TIMING_EXTRA = > $<.$(TIMING_EXT) 651 | else 652 | TIMING_EXTRA = 653 | endif 654 | 655 | $(VOFILES): %.vo: %.v 656 | $(SHOW)COQC $< 657 | $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(TIMING_ARG) $(COQFLAGS) $< $(TIMING_EXTRA) 658 | 659 | # FIXME ?merge with .vo / .vio ? 660 | $(GLOBFILES): %.glob: %.v 661 | $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $< 662 | 663 | $(VFILES:.v=.vio): %.vio: %.v 664 | $(SHOW)COQC -quick $< 665 | $(HIDE)$(TIMER) $(COQC) -quick $(COQDEBUG) $(COQFLAGS) $< 666 | 667 | $(addsuffix .timing.diff,$(VFILES)): %.timing.diff : %.before-timing %.after-timing 668 | $(SHOW)PYTHON TIMING-DIFF $< 669 | $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" print-pretty-single-time-diff BEFORE=$*.before-timing AFTER=$*.after-timing TIME_OF_PRETTY_BUILD_FILE="$@" 670 | 671 | $(BEAUTYFILES): %.v.beautified: %.v 672 | $(SHOW)'BEAUTIFY $<' 673 | $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) -beautify $< 674 | 675 | $(GFILES): %.g: %.v 676 | $(SHOW)'GALLINA $<' 677 | $(HIDE)$(GALLINA) $< 678 | 679 | $(TEXFILES): %.tex: %.v 680 | $(SHOW)'COQDOC -latex $<' 681 | $(HIDE)$(COQDOC) $(COQDOCFLAGS) -latex $< -o $@ 682 | 683 | $(GTEXFILES): %.g.tex: %.v 684 | $(SHOW)'COQDOC -latex -g $<' 685 | $(HIDE)$(COQDOC) $(COQDOCFLAGS) -latex -g $< -o $@ 686 | 687 | $(HTMLFILES): %.html: %.v %.glob 688 | $(SHOW)'COQDOC -html $<' 689 | $(HIDE)$(COQDOC) $(COQDOCFLAGS) -html $< -o $@ 690 | 691 | $(GHTMLFILES): %.g.html: %.v %.glob 692 | $(SHOW)'COQDOC -html -g $<' 693 | $(HIDE)$(COQDOC) $(COQDOCFLAGS) -html -g $< -o $@ 694 | 695 | # Dependency files ############################################################ 696 | 697 | ifneq ($(filter-out archclean clean cleanall printenv make-pretty-timed make-pretty-timed-before make-pretty-timed-after print-pretty-timed print-pretty-timed-diff print-pretty-single-time-diff,$(MAKECMDGOALS)),) 698 | -include $(ALLDFILES) 699 | else 700 | ifeq ($(MAKECMDGOALS),) 701 | -include $(ALLDFILES) 702 | endif 703 | endif 704 | 705 | .SECONDARY: $(ALLDFILES) 706 | 707 | redir_if_ok = > "$@" || ( RV=$$?; rm -f "$@"; exit $$RV ) 708 | 709 | $(addsuffix .d,$(MLIFILES)): %.mli.d: %.mli 710 | $(SHOW)'CAMLDEP $<' 711 | $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) 712 | 713 | $(addsuffix .d,$(ML4FILES)): %.ml4.d: %.ml4 714 | $(SHOW)'CAMLDEP -pp $<' 715 | $(HIDE)$(CAMLDEP) $(OCAMLLIBS) $(PP) -impl "$<" $(redir_if_ok) 716 | 717 | $(addsuffix .d,$(MLFILES)): %.ml.d: %.ml 718 | $(SHOW)'CAMLDEP $<' 719 | $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) 720 | 721 | $(addsuffix .d,$(MLLIBFILES)): %.mllib.d: %.mllib 722 | $(SHOW)'COQDEP $<' 723 | $(HIDE)$(COQDEP) $(OCAMLLIBS) -c "$<" $(redir_if_ok) 724 | 725 | $(addsuffix .d,$(MLPACKFILES)): %.mlpack.d: %.mlpack 726 | $(SHOW)'COQDEP $<' 727 | $(HIDE)$(COQDEP) $(OCAMLLIBS) -c "$<" $(redir_if_ok) 728 | 729 | # If this makefile is created using a _CoqProject we have coqdep get 730 | # options from it. This avoids argument length limits for pathological 731 | # projects. Note that extra options might be on the command line. 732 | VDFILE_FLAGS:=$(if _CoqProject,-f _CoqProject,) $(CMDLINE_COQLIBS) $(CMDLINE_VFILES) 733 | 734 | $(VDFILE).d: $(VFILES) 735 | $(SHOW)'COQDEP VFILES' 736 | $(HIDE)$(COQDEP) -dyndep var $(VDFILE_FLAGS) $(redir_if_ok) 737 | 738 | # Misc ######################################################################## 739 | 740 | byte: 741 | $(HIDE)$(MAKE) all "OPT:=-byte" -f "$(SELF)" 742 | .PHONY: byte 743 | 744 | opt: 745 | $(HIDE)$(MAKE) all "OPT:=-opt" -f "$(SELF)" 746 | .PHONY: opt 747 | 748 | # This is deprecated. To extend this makefile use 749 | # extension points and Makefile.coq.local 750 | printenv:: 751 | $(warning printenv is deprecated) 752 | $(warning write extensions in Makefile.coq.local or include Makefile.coq.conf) 753 | @echo 'LOCAL = $(LOCAL)' 754 | @echo 'COQLIB = $(COQLIB)' 755 | @echo 'DOCDIR = $(DOCDIR)' 756 | @echo 'OCAMLFIND = $(OCAMLFIND)' 757 | @echo 'CAMLP5O = $(CAMLP5O)' 758 | @echo 'CAMLP5BIN = $(CAMLP5BIN)' 759 | @echo 'CAMLP5LIB = $(CAMLP5LIB)' 760 | @echo 'CAMLP5OPTIONS = $(CAMLP5OPTIONS)' 761 | @echo 'HASNATDYNLINK = $(HASNATDYNLINK)' 762 | @echo 'SRC_SUBDIRS = $(SRC_SUBDIRS)' 763 | @echo 'COQ_SRC_SUBDIRS = $(COQ_SRC_SUBDIRS)' 764 | @echo 'OCAMLFIND = $(OCAMLFIND)' 765 | @echo 'PP = $(PP)' 766 | @echo 'COQFLAGS = $(COQFLAGS)' 767 | @echo 'COQLIBINSTALL = $(COQLIBINSTALL)' 768 | @echo 'COQDOCINSTALL = $(COQDOCINSTALL)' 769 | .PHONY: printenv 770 | 771 | # Generate a .merlin file. If you need to append directives to this 772 | # file you can extend the merlin-hook target in Makefile.coq.local 773 | .merlin: 774 | $(SHOW)'FILL .merlin' 775 | $(HIDE)echo 'FLG $(COQMF_CAMLFLAGS)' > .merlin 776 | $(HIDE)echo 'B $(COQLIB)' >> .merlin 777 | $(HIDE)echo 'S $(COQLIB)' >> .merlin 778 | $(HIDE)$(foreach d,$(COQ_SRC_SUBDIRS), \ 779 | echo 'B $(COQLIB)$(d)' >> .merlin;) 780 | $(HIDE)$(foreach d,$(COQ_SRC_SUBDIRS), \ 781 | echo 'S $(COQLIB)$(d)' >> .merlin;) 782 | $(HIDE)$(foreach d,$(SRC_SUBDIRS), echo 'B $(d)' >> .merlin;) 783 | $(HIDE)$(foreach d,$(SRC_SUBDIRS), echo 'S $(d)' >> .merlin;) 784 | $(HIDE)$(MAKE) merlin-hook -f "$(SELF)" 785 | .PHONY: merlin 786 | 787 | merlin-hook:: 788 | @# Extension point 789 | .PHONY: merlin-hook 790 | 791 | # prints all variables 792 | debug: 793 | $(foreach v,\ 794 | $(sort $(filter-out $(INITIAL_VARS) INITIAL_VARS,\ 795 | $(.VARIABLES))),\ 796 | $(info $(v) = $($(v)))) 797 | .PHONY: debug 798 | 799 | .DEFAULT_GOAL := all 800 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | This plugin is to help you learn how to write fun spells (supertactics implemented as program transformations) 2 | using the Coq plugin infrastructure and understand the magic behind them. 3 | There are a number of example spells and some exercises to try out yourself. 4 | 5 | # Citing 6 | 7 | If you build on any of the commands or tactics here and then publish a paper, please cite the 8 | [PUMPKIN PATCH](http://tlringer.github.io/pdf/pumpkinpaper.pdf) paper, since the interesting commands and tactics 9 | all build on components from that paper. 10 | 11 | # Building 12 | 13 | The plugin runs on Coq 8.8. Just run `make`. 14 | 15 | # Example Spells 16 | 17 | There are a number of toy example spells in [magic.ml4](/src/magic.ml4) for the sake of demonstration. 18 | The test code for these examples is in [Examples.v](/coq/Examples.v). Since these are purely demonstrative, 19 | they are not guaranteed to work for code outside of these examples. 20 | 21 | Many of the examples use simplified functionality from [PUMPKIN PATCH](http://github.com/uwplse/PUMPKIN-PATCH). 22 | If you are curious, the paper is [here](http://tlringer.github.io/pdf/pumpkinpaper.pdf). 23 | 24 | # Exercises 25 | 26 | Exercises are in [magic.ml4](/src/magic.ml4). Tests for these exercises are in the [exercises](/coq/exercises/) directory. 27 | The comments for each exercise note which file contains the test for that exercise. 28 | 29 | # Pop Culture References 30 | 31 | Any pop culture references in this repository are references to Harry Potter. This is just for fun, 32 | since this was originally presented in a themed lecture to a group of graduate students. 33 | If you do not understand the pop culture references, don't worry about them. 34 | 35 | # Other Questions 36 | 37 | If you have any questions, please contact Talia Ringer (tringer@cs.washington.edu) or cut an issue in this 38 | GitHub repository. 39 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -I src/lib 2 | -I src/spells 3 | -I src 4 | -Q theories Magic 5 | 6 | src/lib/collections.mli 7 | src/lib/collections.ml 8 | 9 | src/lib/basics.mli 10 | src/lib/basics.ml 11 | src/lib/coqterms.mli 12 | src/lib/coqterms.ml 13 | 14 | src/lib/printing.mli 15 | src/lib/printing.ml 16 | 17 | src/lib/hofs.mli 18 | src/lib/hofs.ml 19 | src/lib/debruijn.mli 20 | src/lib/debruijn.ml 21 | src/lib/substitution.mli 22 | src/lib/substitution.ml 23 | 24 | src/spells/sectumsempra.mli 25 | src/spells/sectumsempra.ml 26 | src/spells/levicorpus.mli 27 | src/spells/levicorpus.ml 28 | src/spells/reducio.mli 29 | src/spells/reducio.ml 30 | 31 | src/magic.ml4 32 | src/wand.mlpack 33 | 34 | theories/Wand.v 35 | -------------------------------------------------------------------------------- /coq/Examples.v: -------------------------------------------------------------------------------- 1 | Require Import Arith NPeano. 2 | Require Import Magic.Wand. 3 | 4 | (* --- Geminio --- *) 5 | 6 | Theorem obvious: 7 | forall n : nat, 8 | (nat * nat). 9 | Proof. 10 | intros. geminio n. apply (n, n0). 11 | Qed. 12 | 13 | (* --- Sectumsempra --- *) 14 | 15 | Theorem lt_S_m_p: 16 | forall n m p : nat, 17 | n < m + S p -> n < S (p + m). 18 | Proof. 19 | intros n m p H. 20 | rewrite <- Nat.add_succ_l. 21 | rewrite plus_comm. 22 | apply H. 23 | Qed. 24 | 25 | Sectumsempra lt_S_m_p. 26 | 27 | Theorem test_lt_S_m_p_0: 28 | forall n m p : nat, 29 | n < m + S p -> n < S p + m. 30 | Proof. 31 | exact lt_S_m_p_0. 32 | Qed. 33 | 34 | Theorem test_lt_S_m_p_1: 35 | forall n m p : nat, 36 | n < S p + m -> n < S (p + m). 37 | Proof. 38 | exact lt_S_m_p_1. 39 | Qed. 40 | 41 | (* --- Levicorpus --- *) 42 | 43 | Levicorpus lt_S_m_p. 44 | 45 | Theorem test_lt_S_m_p_inv: 46 | forall n m p : nat, 47 | n < S (p + m) -> n < m + S p. 48 | Proof. 49 | exact lt_S_m_p_inv. 50 | Qed. 51 | 52 | (* --- Reducio --- *) 53 | 54 | Theorem engorged: 55 | forall (a b : nat), 56 | a <= b -> 57 | a <= S b. 58 | Proof. 59 | intros. rewrite plus_n_O. rewrite plus_comm. 60 | constructor. auto. 61 | Qed. 62 | 63 | Reducio engorged. 64 | 65 | Theorem found_minimal_app: 66 | engorged_red = le_S. 67 | Proof. 68 | reflexivity. 69 | Qed. 70 | 71 | (* --- Spells in combination --- *) 72 | 73 | Theorem lt_S_m_p_iff: 74 | forall n m p : nat, 75 | n < m + S p <-> n < S (p + m). 76 | Proof. 77 | intros. 78 | geminio lt_S_m_p. 79 | levicorpus lt_S_m_p. 80 | constructor; auto. 81 | Qed. 82 | 83 | -------------------------------------------------------------------------------- /coq/exercises/Geminio.v: -------------------------------------------------------------------------------- 1 | Require Import Arith NPeano. 2 | Require Import Magic.Wand. 3 | 4 | (* 5 | * Test for the second exercise. 6 | *) 7 | 8 | Definition f (x : nat) := 9 | S (S x). 10 | 11 | Geminio f. 12 | 13 | Theorem test_geminio: 14 | f = f_clone. 15 | Proof. 16 | reflexivity. 17 | Qed. 18 | -------------------------------------------------------------------------------- /coq/exercises/GeminioNamed.v: -------------------------------------------------------------------------------- 1 | Require Import Arith NPeano. 2 | Require Import Magic.Wand. 3 | 4 | (* 5 | * Test for the first exercise. 6 | *) 7 | 8 | Definition f (x : nat) := 9 | S (S x). 10 | 11 | Geminio f as g. 12 | 13 | Theorem test_geminio: 14 | f = g. 15 | Proof. 16 | reflexivity. 17 | Qed. 18 | -------------------------------------------------------------------------------- /coq/exercises/ReducioDuo.v: -------------------------------------------------------------------------------- 1 | Require Import Arith NPeano. 2 | Require Import Magic.Wand. 3 | 4 | (* 5 | * Test for the fourth exercise. 6 | *) 7 | 8 | (* --- Regresssion test --- *) 9 | 10 | Theorem engorged: 11 | forall (a b : nat), 12 | a <= b -> 13 | a <= S b. 14 | Proof. 15 | intros. rewrite plus_n_O. rewrite plus_comm. 16 | constructor. auto. 17 | Qed. 18 | 19 | Reducio Duo engorged. 20 | 21 | Theorem found_minimal_app: 22 | engorged_red = le_S. 23 | Proof. 24 | reflexivity. 25 | Qed. 26 | 27 | (* --- Identity type in path --- *) 28 | 29 | Theorem engorged2: 30 | forall (n m : nat), 31 | n < n + S m -> 32 | n < S n + m. 33 | Proof. 34 | intros. 35 | rewrite Nat.add_succ_l. 36 | rewrite <- Nat.add_succ_r. 37 | auto. 38 | Qed. 39 | 40 | Sectumsempra engorged2. 41 | 42 | Reducio Duo engorged2. 43 | 44 | Theorem found_minimal_app2: 45 | engorged2_red = engorged2_0. 46 | Proof. 47 | reflexivity. 48 | Qed. 49 | 50 | (* --- Identity type between inverses --- *) 51 | 52 | Theorem engorged3: 53 | forall (a b : nat), 54 | a <= b -> 55 | a <= S b. 56 | Proof. 57 | intros. 58 | rewrite plus_n_O. 59 | rewrite Nat.add_succ_l. 60 | rewrite plus_comm. 61 | constructor. 62 | auto. 63 | Qed. 64 | 65 | Sectumsempra engorged3. 66 | 67 | Reducio Duo engorged3. 68 | 69 | Theorem found_minimal_app3: 70 | engorged3_red = engorged3_0. 71 | Proof. 72 | reflexivity. 73 | Qed. -------------------------------------------------------------------------------- /coq/exercises/ReducioMaxima.v: -------------------------------------------------------------------------------- 1 | Require Import Arith NPeano. 2 | Require Import Magic.Wand. 3 | 4 | (* 5 | * Test for the sixth exercise. 6 | *) 7 | 8 | (* --- Regresssion test --- *) 9 | 10 | Theorem engorged: 11 | forall (a b : nat), 12 | a <= b -> 13 | a <= S b. 14 | Proof. 15 | intros. rewrite plus_n_O. rewrite plus_comm. 16 | constructor. auto. 17 | Qed. 18 | 19 | Reducio Maxima engorged. 20 | 21 | Theorem found_minimal_app: 22 | engorged_red = le_S. 23 | Proof. 24 | reflexivity. 25 | Qed. 26 | 27 | (* --- Cycles --- *) 28 | 29 | Theorem engorged2: 30 | forall (a b : nat), 31 | a <= b -> 32 | a <= S (S (b + 0)). 33 | Proof. 34 | intros. 35 | constructor. 36 | rewrite plus_n_O. 37 | rewrite plus_Snm_nSm. 38 | rewrite plus_comm. 39 | rewrite plus_0_r. 40 | constructor. 41 | auto. 42 | Qed. 43 | 44 | Sectumsempra engorged2. 45 | 46 | (* 47 | * Simplified factor types, for reference: 48 | * 49 | * 0. a <= b -> a <= S b 50 | * 1. a <= S b -> a <= S (b + 0) 51 | * 2. a <= S (b + 0) -> a <= b + 0 + 1 52 | * 3. a <= b + 0 + 1 -> a <= S (b + 0 + 0) 53 | * 4. a <= S (b + 0 + 0) -> a <= S (b + 0) 54 | * 5. a <= S (b + 0) -> a <= S (S (b + 0)) 55 | * 56 | * Or, in other words: 57 | * 58 | * 0. A -> B 59 | * 1. B -> C 60 | * 2. C -> D 61 | * 3. D -> E 62 | * 4. E -> C 63 | * 5. C -> F 64 | *) 65 | 66 | Reducio Maxima engorged2. 67 | 68 | Theorem reduced2: 69 | forall (a b : nat), 70 | a <= b -> 71 | a <= S (S (b + 0)). 72 | Proof. 73 | intros. 74 | constructor. 75 | rewrite plus_0_r. 76 | constructor. 77 | auto. 78 | Defined. 79 | 80 | Theorem found_minimal_app2: 81 | engorged2_red = reduced2. 82 | Proof. 83 | reflexivity. 84 | Qed. 85 | 86 | 87 | -------------------------------------------------------------------------------- /coq/exercises/ReducioTria.v: -------------------------------------------------------------------------------- 1 | Require Import Arith NPeano. 2 | Require Import Magic.Wand. 3 | 4 | (* 5 | * Test for the fifth exercise. 6 | *) 7 | 8 | (* --- Regresssion test --- *) 9 | 10 | Theorem engorged: 11 | forall (a b : nat), 12 | a <= b -> 13 | a <= S b. 14 | Proof. 15 | intros. rewrite plus_n_O. rewrite plus_comm. 16 | constructor. auto. 17 | Qed. 18 | 19 | Reducio Tria engorged. 20 | 21 | Theorem found_minimal_app: 22 | engorged_red = le_S. 23 | Proof. 24 | reflexivity. 25 | Qed. 26 | 27 | (* --- Nested inverses --- *) 28 | 29 | Theorem engorged2: 30 | forall (a b : nat), 31 | a <= b -> 32 | a <= S b. 33 | Proof. 34 | intros. 35 | rewrite <- plus_0_r. 36 | rewrite plus_n_O. 37 | rewrite plus_0_r. 38 | rewrite plus_comm. 39 | constructor. 40 | auto. 41 | Qed. 42 | 43 | Reducio Tria engorged2. 44 | 45 | Theorem found_minimal_app2: 46 | engorged2_red = le_S. 47 | Proof. 48 | reflexivity. 49 | Qed. 50 | -------------------------------------------------------------------------------- /coq/exercises/Relashio.v: -------------------------------------------------------------------------------- 1 | Require Import Arith NPeano. 2 | Require Import Magic.Wand. 3 | 4 | (* 5 | * Test for the seventh exercise. 6 | *) 7 | 8 | Definition foo (n : nat) := n + 0. 9 | Definition bar (n : nat) := n + (0 + 0). 10 | 11 | Relashio 0 in foo. 12 | Relashio 0 in bar. 13 | 14 | Definition baz (m : nat) (n : nat) := n + m. 15 | 16 | Theorem test_foo: 17 | baz = foo_rel. 18 | Proof. 19 | reflexivity. 20 | Qed. 21 | 22 | Theorem test_bar: 23 | baz = bar_rel. 24 | Proof. 25 | reflexivity. 26 | Qed. 27 | -------------------------------------------------------------------------------- /coq/exercises/Sectumsempra.v: -------------------------------------------------------------------------------- 1 | Require Import Arith NPeano. 2 | Require Import Magic.Wand. 3 | 4 | (* 5 | * Test for the third exercise 3 6 | *) 7 | 8 | Theorem lt_S_m_p: 9 | forall n m p : nat, 10 | n < m + S p -> n < S (p + m). 11 | Proof. 12 | intros n m p H. 13 | rewrite <- Nat.add_succ_l. 14 | rewrite plus_comm. 15 | apply H. 16 | Qed. 17 | 18 | Theorem test_lt_S_m_p_0: 19 | forall n m p : nat, 20 | n < m + S p -> n < S p + m. 21 | Proof. 22 | sectumsempra lt_S_m_p. 23 | auto. 24 | Qed. 25 | -------------------------------------------------------------------------------- /licensing/LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2018 Talia Ringer 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21 | THE SOFTWARE. -------------------------------------------------------------------------------- /src/lib/basics.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Plugin basics 3 | * 4 | * Note: In this example plugin, I don't ever update evd, the evar_map. 5 | * This is OK for exemplary purposes, but if you do this when you make 6 | * your own magic spells, you may find that if you do this the universe may be 7 | * inconsistent inside your plugin, but consistent outside of your plugin with 8 | * the same terms. This means your spells may fail when they ought to succeed. 9 | *) 10 | 11 | open Environ 12 | open Evd 13 | open Constr 14 | open Decl_kinds 15 | open Names 16 | open Collections 17 | open Declarations 18 | 19 | (* Constant ID *) 20 | let k_fresh = ref (1) 21 | 22 | (* Get a fresh constant identifier *) 23 | let fid () : int = 24 | let id = !k_fresh in 25 | k_fresh := id + 1; 26 | id 27 | 28 | (* Intern a term *) 29 | let intern (env : env) (evm : evar_map) (t : Constrexpr.constr_expr) : types = 30 | let (trm, _) = Constrintern.interp_constr env evm t in 31 | EConstr.to_constr evm trm 32 | 33 | (* Extern a term *) 34 | let extern env evm t : Constrexpr.constr_expr = 35 | Constrextern.extern_constr true env evm (EConstr.of_constr t) 36 | 37 | (* https://github.com/ybertot/plugin_tutorials/blob/master/tuto1/src/simple_declare.ml *) 38 | let edeclare ident (_, poly, _ as k) ~opaque sigma udecl body tyopt imps hook refresh = 39 | let open EConstr in 40 | (* XXX: "Standard" term construction combinators such as `mkApp` 41 | don't add any universe constraints that may be needed later for 42 | the kernel to check that the term is correct. 43 | We could manually call `Evd.add_universe_constraints` 44 | [high-level] or `Evd.add_constraints` [low-level]; however, that 45 | turns out to be a bit heavyweight. 46 | Instead, we call type inference on the manually-built term which 47 | will happily infer the constraint for us, even if that's way more 48 | costly in term of CPU cycles. 49 | Beware that `type_of` will perform full type inference including 50 | canonical structure resolution and what not. 51 | *) 52 | let env = Global.env () in 53 | let sigma = 54 | if refresh then 55 | fst (Typing.type_of ~refresh:false env sigma body) 56 | else 57 | sigma 58 | in 59 | let sigma = Evd.minimize_universes sigma in 60 | let body = to_constr sigma body in 61 | let tyopt = Option.map (to_constr sigma) tyopt in 62 | let uvars_fold uvars c = 63 | Univ.LSet.union uvars (Univops.universes_of_constr env c) in 64 | let uvars = List.fold_left uvars_fold Univ.LSet.empty 65 | (Option.List.cons tyopt [body]) in 66 | let sigma = Evd.restrict_universe_context sigma uvars in 67 | let univs = Evd.check_univ_decl ~poly sigma udecl in 68 | let ubinders = Evd.universe_binders sigma in 69 | let ce = Declare.definition_entry ?types:tyopt ~univs body in 70 | DeclareDef.declare_definition ident k ce ubinders imps hook 71 | 72 | (* Define a new Coq term *) 73 | let define_term (n : Id.t) (evm : evar_map) (trm : types) = 74 | let k = (Global, Flags.is_universe_polymorphism(), Definition) in 75 | let udecl = Univdecls.default_univ_decl in 76 | let nohook = Lemmas.mk_hook (fun _ x -> x) in 77 | let etrm = EConstr.of_constr trm in 78 | ignore (edeclare n k ~opaque:false evm udecl etrm None [] nohook false) 79 | -------------------------------------------------------------------------------- /src/lib/basics.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Plugin basics 3 | *) 4 | 5 | open Environ 6 | open Evd 7 | open Constr 8 | open Names 9 | 10 | (* Get a fresh constant identifier *) 11 | val fid : unit -> int 12 | 13 | (* --- Representations --- *) 14 | 15 | (* Internalize *) 16 | val intern : env -> evar_map -> Constrexpr.constr_expr -> types 17 | 18 | (* Externalize *) 19 | val extern : env -> evar_map -> types -> Constrexpr.constr_expr 20 | 21 | (* --- Definitions --- *) 22 | 23 | (* Define a new Coq term *) 24 | val define_term : Id.t -> evar_map -> types -> unit 25 | -------------------------------------------------------------------------------- /src/lib/collections.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Auxiliary functions on collections 3 | *) 4 | 5 | (* seq from template-coq *) 6 | let rec range (min : int) (max : int) : int list = 7 | if min < max then 8 | min :: range (min + 1) max 9 | else 10 | [] 11 | 12 | (* Creates a list from the index 1 to max, inclusive *) 13 | let from_one_to (max : int) : int list = 14 | range 1 (max + 1) 15 | 16 | (* 17 | * Get values from a list of optionals only if every optional is some 18 | * Otherwise, return the empty list 19 | *) 20 | let get_all_or_none (l : 'a option list) : 'a list = 21 | if List.for_all Option.has_some l then 22 | List.map Option.get l 23 | else 24 | [] 25 | 26 | (* Gets the last element of l *) 27 | let last (l : 'a list) = List.hd (List.rev l) 28 | 29 | (* Map3 *) 30 | let rec map3 (f : 'a -> 'b -> 'c -> 'd) l1 l2 l3 : 'd list = 31 | match (l1, l2, l3) with 32 | | ([], [], []) -> 33 | [] 34 | | (h1 :: t1, h2 :: t2, h3 :: t3) -> 35 | let r = f h1 h2 h3 in r :: map3 f t1 t2 t3 36 | -------------------------------------------------------------------------------- /src/lib/collections.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Auxiliary functions on collections 3 | *) 4 | 5 | (* [min, max) *) 6 | val range : int -> int -> int list 7 | 8 | (* [1, max] *) 9 | val from_one_to : int -> int list 10 | 11 | (* 12 | * Get values from a list of optionals only if every optional is some 13 | * Otherwise, return the empty list 14 | *) 15 | val get_all_or_none : 'a option list -> 'a list 16 | 17 | (* Gets the last element of l *) 18 | val last : 'a list -> 'a 19 | 20 | (* Map3 *) 21 | val map3 : ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list 22 | -------------------------------------------------------------------------------- /src/lib/coqterms.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Basic term and environment management, and some useful constants 3 | *) 4 | 5 | open Basics 6 | open Environ 7 | open Declarations 8 | open Constr 9 | open Names 10 | open Evd 11 | open Collections 12 | 13 | module CRD = Context.Rel.Declaration 14 | 15 | (* --- Basic term and environment management --- *) 16 | 17 | (* Convertibility *) 18 | let convertible env evm (trm1 : types) (trm2 : types) : bool = 19 | let etrm1 = EConstr.of_constr trm1 in 20 | let etrm2 = EConstr.of_constr trm2 in 21 | Reductionops.is_conv env evm etrm1 etrm2 22 | 23 | (* Infer a type (can cause universe leaks; not a problem for this plugin) *) 24 | let infer_type (env : env) (evd : evar_map) (trm : types) : types = 25 | let jmt = Typeops.infer env trm in 26 | j_type jmt 27 | 28 | (* Check whether a term has a given type *) 29 | let has_type (env : env) (evd : evar_map) (typ : types) (trm : types) : bool = 30 | try 31 | let trm_typ = infer_type env evd trm in 32 | convertible env evd trm_typ typ 33 | with _ -> false 34 | 35 | (* Default reducer *) 36 | let reduce_term (env : env) (evd : evar_map) (trm : types) : types = 37 | EConstr.to_constr 38 | evd 39 | (Reductionops.nf_betaiotazeta env evd (EConstr.of_constr trm)) 40 | 41 | (* Default reducers on types *) 42 | let reduce_type (env : env) (evd : evar_map) (trm : types) : types = 43 | reduce_term env evd (infer_type env evd trm) 44 | 45 | (* Push a local binding *) 46 | let push_local (n, t) = push_rel CRD.(LocalAssum (n, t)) 47 | 48 | (* Push a let-in definition to an environment *) 49 | let push_in (n, e, t) = push_rel CRD.(LocalDef(n, e, t)) 50 | 51 | (* Lookup n rels and remove then *) 52 | let lookup_pop (n : int) (env : env) = 53 | let rels = List.map (fun i -> lookup_rel i env) (from_one_to n) in 54 | (pop_rel_context n env, rels) 55 | 56 | (* Return a list of all indexes in env, starting with 1 *) 57 | let all_rel_indexes (env : env) : int list = 58 | from_one_to (nb_rel env) 59 | 60 | (* Push bindings for a fixpoint *) 61 | let bindings_for_fix (names : name array) (typs : types array) : CRD.t list = 62 | Array.to_list 63 | (CArray.map2_i 64 | (fun i name typ -> CRD.LocalAssum (name, Vars.lift i typ)) 65 | names typs) 66 | 67 | (* Lookup a definition *) 68 | let lookup_definition (env : env) (def : types) : types = 69 | match kind def with 70 | | Const (c, u) -> 71 | let c_body = (lookup_constant c env).const_body in 72 | (match c_body with 73 | | Def cs -> Mod_subst.force_constr cs 74 | | OpaqueDef o -> Opaqueproof.force_proof (Global.opaque_tables ()) o 75 | | _ -> failwith "an axiom has no definition") 76 | | Ind _ -> def 77 | | _ -> failwith "not a definition" 78 | 79 | (* 80 | * Fully lookup a def in env which may be an alias 81 | * If it's not a definition, return the original term 82 | * Don't fully delta-expand 83 | *) 84 | let rec unwrap_definition (env : env) (trm : types) : types = 85 | try 86 | unwrap_definition env (lookup_definition env trm) 87 | with _ -> 88 | trm 89 | 90 | (* Get the name of a term if it's constant, otherwise fail *) 91 | let name_of_const (trm : types) = 92 | match kind trm with 93 | | Const (c, u) -> 94 | let kn = Constant.canonical c in 95 | let (modpath, dirpath, label) = KerName.repr kn in 96 | Id.of_string_soft (Label.to_string label) 97 | | _ -> 98 | failwith "not a constant" 99 | 100 | (* Try to get a name, and if it fails, call the default *) 101 | let id_or_default (trm : types) get_id default = 102 | try 103 | get_id trm 104 | with _ -> 105 | default () 106 | 107 | (* Add a suffix to a name ID *) 108 | let with_suffix (suffix : string) (id : Id.t) : Id.t = 109 | Id.of_string (String.concat "_" [Id.to_string id; suffix]) 110 | 111 | (* Get a fresh constant identifier with a prefix as an ID *) 112 | let fresh_with_prefix (prefix : string) () : Id.t = 113 | let id_string = string_of_int (fid ()) in 114 | with_suffix id_string (Id.of_string prefix) 115 | 116 | (* Zoom all the way into a lambda term *) 117 | let rec zoom_lambda_term (env : env) (trm : types) : env * types = 118 | match kind trm with 119 | | Lambda (n, t, b) -> 120 | zoom_lambda_term (push_local (n, t) env) b 121 | | _ -> 122 | (env, trm) 123 | 124 | (* Reconstruct a lambda from an environment, but stop when i are left *) 125 | let rec reconstruct_lambda_n (env : env) (b : types) (i : int) : types = 126 | if nb_rel env = i then 127 | b 128 | else 129 | let (n, _, t) = CRD.to_tuple @@ lookup_rel 1 env in 130 | let env' = pop_rel_context 1 env in 131 | reconstruct_lambda_n env' (mkLambda (n, t, b)) i 132 | 133 | (* Reconstruct a lambda from an environment *) 134 | let reconstruct_lambda (env : env) (b : types) : types = 135 | reconstruct_lambda_n env b 0 136 | 137 | (* --- Useful constants --- *) 138 | 139 | (* 140 | * This is not a good way to construct constants. Don't copy it. 141 | * See recent coq-club email on this topic. 142 | *) 143 | 144 | (* eq_ind_r *) 145 | let eq_ind_r : types = 146 | mkConst 147 | (Constant.make2 148 | (ModPath.MPfile 149 | (DirPath.make (List.map Id.of_string ["Logic"; "Init"; "Coq"]))) 150 | (Label.make "eq_ind_r")) 151 | 152 | (* eq_ind *) 153 | let eq_ind : types = 154 | mkConst 155 | (Constant.make2 156 | (ModPath.MPfile 157 | (DirPath.make (List.map Id.of_string ["Logic"; "Init"; "Coq"]))) 158 | (Label.make "eq_ind")) 159 | 160 | (* eq_rec_r *) 161 | let eq_rec_r : types = 162 | mkConst 163 | (Constant.make2 164 | (ModPath.MPfile 165 | (DirPath.make (List.map Id.of_string ["Logic"; "Init"; "Coq"]))) 166 | (Label.make "eq_rec_r")) 167 | 168 | (* eq_rec *) 169 | let eq_rec : types = 170 | mkConst 171 | (Constant.make2 172 | (ModPath.MPfile 173 | (DirPath.make (List.map Id.of_string ["Logic"; "Init"; "Coq"]))) 174 | (Label.make "eq_rec")) 175 | 176 | (* eq_sym *) 177 | let eq_sym : types = 178 | mkConst 179 | (Constant.make2 180 | (ModPath.MPfile 181 | (DirPath.make (List.map Id.of_string ["Logic"; "Init"; "Coq"]))) 182 | (Label.make "eq_sym")) 183 | 184 | (* 185 | * Check if a term is a rewrite via eq_ind or eq_ind_r 186 | * For efficiency, just check syntactic equality 187 | * Don't consider convertible terms for now 188 | *) 189 | let is_rewrite (trm : types) : bool = 190 | equal trm eq_ind_r || 191 | equal trm eq_ind || 192 | equal trm eq_rec_r || 193 | equal trm eq_rec 194 | -------------------------------------------------------------------------------- /src/lib/coqterms.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Basic term and environment management, and some useful constants 3 | *) 4 | 5 | open Environ 6 | open Evd 7 | open Constr 8 | open Declarations 9 | open Names 10 | 11 | module CRD = Context.Rel.Declaration 12 | 13 | (* --- Constants --- *) 14 | 15 | val eq_sym : types 16 | 17 | (* --- Term and environment management --- *) 18 | 19 | (* Convertibility *) 20 | val convertible : env -> evar_map -> types -> types -> bool 21 | 22 | (* Infer the type of a term in an environment *) 23 | val infer_type : env -> evar_map -> types -> types 24 | 25 | (* Check whether a term has a given type *) 26 | val has_type : env -> evar_map -> types -> types -> bool 27 | 28 | (* betaiotazeta, which is often useful, but doesn't fully normalize *) 29 | val reduce_term : env -> evar_map -> types -> types 30 | 31 | (* betaiotazeta on the type *) 32 | val reduce_type : env -> evar_map -> types -> types 33 | 34 | (* Push a local binding *) 35 | val push_local : (name * types) -> env -> env 36 | 37 | (* Push a let-in definition to an environment *) 38 | val push_in : (name * types * types) -> env -> env 39 | 40 | (* Lookup n rels and remove then *) 41 | val lookup_pop : int -> env -> (env * CRD.t list) 42 | 43 | (* Return a list of all indexes in env, starting with 1 *) 44 | val all_rel_indexes : env -> int list 45 | 46 | (* Get bindings for a fixpoint *) 47 | val bindings_for_fix : name array -> types array -> CRD.t list 48 | 49 | (* Lookup a definition *) 50 | val lookup_definition : env -> types -> types 51 | 52 | (* Unwrap a term until it is no longer a definition *) 53 | val unwrap_definition : env -> types -> types 54 | 55 | (* Get the name of a term if it's constant, otherwise fail *) 56 | val name_of_const : types -> Id.t 57 | 58 | (* Try to get a name, and if it fails, call the default *) 59 | val id_or_default : types -> (types -> Id.t) -> (unit -> Id.t) -> Id.t 60 | 61 | (* Add a suffix to a name ID *) 62 | val with_suffix : string -> Id.t -> Id.t 63 | 64 | (* Get a fresh constant identifier with a prefix as an ID *) 65 | val fresh_with_prefix : string -> unit -> Id.t 66 | 67 | (* Zoom all the way into a lambda term *) 68 | val zoom_lambda_term : env -> types -> (env * types) 69 | 70 | (* Reconstruct a lambda from an environment and a body *) 71 | val reconstruct_lambda : env -> types -> types 72 | 73 | (* Check if a term is exactly a rewrite induction principle *) 74 | val is_rewrite : types -> bool 75 | 76 | 77 | -------------------------------------------------------------------------------- /src/lib/debruijn.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * The ugliest part of magic, DeBruijn indices. 3 | * 4 | * This is not quite a canonical shift/unshift like you're used to in theory. 5 | * If you want to know why, ask, but it's fine for this plugin. 6 | *) 7 | 8 | open Environ 9 | open Constr 10 | open Hofs 11 | 12 | (* 13 | * Map a function over a term, when the environment doesn't matter 14 | * Update the argument of type 'a using the a supplied update function 15 | * Return a new term 16 | *) 17 | let map_term f d (a : 'a) (trm : types) : types = 18 | map_term_env (fun _ a t -> f a t) d empty_env a trm 19 | 20 | (* Unshift an index by n *) 21 | let unshift_i_by (n : int) (i : int) : int = 22 | i - n 23 | 24 | (* Shift an index by n *) 25 | let shift_i_by (n : int) (i : int) : int = 26 | unshift_i_by (- n) i 27 | 28 | (* Shift an index *) 29 | let shift_i (i : int) : int = 30 | shift_i_by 1 i 31 | 32 | (* 33 | * Unshifts a term by n if it is greater than the maximum index 34 | * max of a local binding 35 | *) 36 | let unshift_local (max : int) (n : int) (trm : types) : types = 37 | map_term 38 | (fun (m, adj) t -> 39 | match kind t with 40 | | Rel i -> 41 | let i' = if i > m then unshift_i_by adj i else i in 42 | mkRel i' 43 | | _ -> 44 | t) 45 | (fun (m, adj) -> (shift_i m, adj)) 46 | (max, n) 47 | trm 48 | 49 | (* Decrement the relative indexes of a term t by n *) 50 | let unshift_by (n : int) (trm : types) : types = 51 | unshift_local 0 n trm 52 | 53 | (* Increment the relative indexes of a term t by n *) 54 | let shift_by (n : int) (t : types) : types = 55 | unshift_by (- n) t 56 | 57 | (* Increment the relative indexes of a term t by one *) 58 | let shift (t : types) : types = 59 | shift_by 1 t 60 | 61 | (* Decrement the relative indexes of a term t by one *) 62 | let unshift (t : types) : types = 63 | unshift_by 1 t 64 | -------------------------------------------------------------------------------- /src/lib/debruijn.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * The ugliest part of magic, DeBruijn indices. 3 | * 4 | * This is not quite a canonical shift/unshift like you're used to in theory. 5 | * In particular, depending on the term you pass it, unshift (shift t) might 6 | * not be t. There's a reason for this, but you can ignore it for 7 | * the sake of this plugin. 8 | *) 9 | 10 | open Constr 11 | 12 | (* Decrement the relative indexes of a term t by n *) 13 | val unshift_by : int -> types -> types 14 | 15 | (* Increment the relative indexes of a term t by n *) 16 | val shift_by : int -> types -> types 17 | 18 | (* Increment the relative indexes of a term t by one *) 19 | val shift : types -> types 20 | 21 | (* Decrement the relative indexes of a term t by one *) 22 | val unshift : types -> types 23 | -------------------------------------------------------------------------------- /src/lib/hofs.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Higher-order functions on terms 3 | *) 4 | 5 | open Collections 6 | open Constr 7 | open Environ 8 | open Coqterms 9 | open Names 10 | 11 | (* Recurse on a mapping function with an environment for a fixpoint *) 12 | let map_rec_env_fix map_rec d env a (ns : name array) (ts : types array) = 13 | let fix_bindings = bindings_for_fix ns ts in 14 | let env_fix = push_rel_context fix_bindings env in 15 | let n = List.length fix_bindings in 16 | let d_n = List.fold_left (fun a' _ -> d a') a (range 0 n) in 17 | map_rec env_fix d_n 18 | 19 | (* 20 | * Map a function over a term in an environment 21 | * Update the environment as you go 22 | * Update the argument of type 'a using the a supplied update function 23 | * Return a new term 24 | *) 25 | let rec map_term_env f d (env : env) (a : 'a) (trm : types) : types = 26 | let map_rec = map_term_env f d in 27 | match kind trm with 28 | | Cast (c, k, t) -> 29 | let c' = map_rec env a c in 30 | let t' = map_rec env a t in 31 | mkCast (c', k, t') 32 | | Prod (n, t, b) -> 33 | let t' = map_rec env a t in 34 | let b' = map_rec (push_local (n, t) env) (d a) b in 35 | mkProd (n, t', b') 36 | | Lambda (n, t, b) -> 37 | let t' = map_rec env a t in 38 | let b' = map_rec (push_local (n, t) env) (d a) b in 39 | mkLambda (n, t', b') 40 | | LetIn (n, trm, typ, e) -> 41 | let trm' = map_rec env a trm in 42 | let typ' = map_rec env a typ in 43 | let e' = map_rec (push_in (n, e, typ) env) (d a) e in 44 | mkLetIn (n, trm', typ', e') 45 | | App (fu, args) -> 46 | let fu' = map_rec env a fu in 47 | let args' = Array.map (map_rec env a) args in 48 | mkApp (fu', args') 49 | | Case (ci, ct, m, bs) -> 50 | let ct' = map_rec env a ct in 51 | let m' = map_rec env a m in 52 | let bs' = Array.map (map_rec env a) bs in 53 | mkCase (ci, ct', m', bs') 54 | | Fix ((is, i), (ns, ts, ds)) -> 55 | let ts' = Array.map (map_rec env a) ts in 56 | let ds' = Array.map (map_rec_env_fix map_rec d env a ns ts) ds in 57 | mkFix ((is, i), (ns, ts', ds')) 58 | | CoFix (i, (ns, ts, ds)) -> 59 | let ts' = Array.map (map_rec env a) ts in 60 | let ds' = Array.map (map_rec_env_fix map_rec d env a ns ts) ds in 61 | mkCoFix (i, (ns, ts', ds')) 62 | | Proj (p, c) -> 63 | let c' = map_rec env a c in 64 | mkProj (p, c') 65 | | _ -> 66 | f env a trm 67 | 68 | (* 69 | * Map a function over a term in an environment 70 | * Only apply the function when a proposition is true 71 | * Apply the function eagerly 72 | * Update the environment as you go 73 | * Update the argument of type 'a using the a supplied update function 74 | * Return a new term 75 | *) 76 | let rec map_term_env_if p f d (env : env) (a : 'a) (trm : types) : types = 77 | let map_rec = map_term_env_if p f d in 78 | if p env a trm then 79 | f env a trm 80 | else 81 | match kind trm with 82 | | Cast (c, k, t) -> 83 | let c' = map_rec env a c in 84 | let t' = map_rec env a t in 85 | mkCast (c', k, t') 86 | | Prod (n, t, b) -> 87 | let t' = map_rec env a t in 88 | let b' = map_rec (push_local (n, t') env) (d a) b in 89 | mkProd (n, t', b') 90 | | Lambda (n, t, b) -> 91 | let t' = map_rec env a t in 92 | let b' = map_rec (push_local (n, t') env) (d a) b in 93 | mkLambda (n, t', b') 94 | | LetIn (n, trm, typ, e) -> 95 | let trm' = map_rec env a trm in 96 | let typ' = map_rec env a typ in 97 | let e' = map_rec (push_in (n, e, typ') env) (d a) e in 98 | mkLetIn (n, trm', typ', e') 99 | | App (fu, args) -> 100 | let fu' = map_rec env a fu in 101 | let args' = Array.map (map_rec env a) args in 102 | mkApp (fu', args') 103 | | Case (ci, ct, m, bs) -> 104 | let ct' = map_rec env a ct in 105 | let m' = map_rec env a m in 106 | let bs' = Array.map (map_rec env a) bs in 107 | mkCase (ci, ct', m', bs') 108 | | Fix ((is, i), (ns, ts, ds)) -> 109 | let ts' = Array.map (map_rec env a) ts in 110 | let ds' = Array.map (map_rec_env_fix map_rec d env a ns ts) ds in 111 | mkFix ((is, i), (ns, ts', ds')) 112 | | CoFix (i, (ns, ts, ds)) -> 113 | let ts' = Array.map (map_rec env a) ts in 114 | let ds' = Array.map (map_rec_env_fix map_rec d env a ns ts) ds in 115 | mkCoFix (i, (ns, ts', ds')) 116 | | Proj (pr, c) -> 117 | let c' = map_rec env a c in 118 | mkProj (pr, c') 119 | | _ -> 120 | trm 121 | -------------------------------------------------------------------------------- /src/lib/hofs.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Higher-order functions on terms. 3 | * 4 | * There are a lot more of these in the PUMPKIN PATCH repository 5 | * if they are useful for you. 6 | *) 7 | 8 | open Constr 9 | open Environ 10 | 11 | (* 12 | * Map a function over a term in an environment 13 | * Update the environment as you go 14 | * Update the argument of type 'a using the a supplied update function 15 | * Return a new term 16 | *) 17 | val map_term_env : 18 | (env -> 'a -> types -> types) -> 19 | ('a -> 'a) -> 20 | env -> 21 | 'a -> 22 | types -> 23 | types 24 | 25 | (* 26 | * Map a function over a term in an environment 27 | * Only apply the function when a proposition is true 28 | * Apply the function eagerly 29 | * Update the environment as you go 30 | * Update the argument of type 'a using the a supplied update function 31 | * Return a new term 32 | *) 33 | val map_term_env_if : 34 | (env -> 'a -> types -> bool) -> 35 | (env -> 'a -> types -> types) -> 36 | ('a -> 'a) -> 37 | env -> 38 | 'a -> 39 | types -> 40 | types 41 | -------------------------------------------------------------------------------- /src/lib/printing.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Auxiliary functions for printing. 3 | * 4 | * Some of these implementations are incomplete right now. 5 | * Those pieces will show the wrong environments, so indexes will 6 | * appear to be incorrect. 7 | *) 8 | 9 | open Format 10 | open Names 11 | open Univ 12 | open Constr 13 | open Environ 14 | open Coqterms 15 | open Collections 16 | 17 | module CRD = Context.Rel.Declaration 18 | 19 | (* --- Strings --- *) 20 | 21 | (* 22 | * Using pp, prints directly to a string 23 | *) 24 | let print_to_string (pp : formatter -> 'a -> unit) (trm : 'a) : string = 25 | Format.asprintf "%a" pp trm 26 | 27 | (* --- Coq terms --- *) 28 | 29 | (* Gets n as a string *) 30 | let name_as_string (n : name) : string = 31 | match n with 32 | | Name id -> string_of_id id 33 | | Anonymous -> "_" 34 | 35 | (* Pretty prints a universe level *) 36 | let print_univ_level (fmt : formatter) (l : Level.t) = 37 | Pp.pp_with fmt (Level.pr l) 38 | 39 | (* Prints a universe *) 40 | let universe_as_string u = 41 | match Universe.level u with 42 | | Some l -> print_to_string print_univ_level l 43 | | None -> Printf.sprintf "Max{%s}" (String.concat ", " (List.map (print_to_string print_univ_level) (LSet.elements (Universe.levels u)))) 44 | 45 | (* Gets a sort as a string *) 46 | let sort_as_string s = 47 | match s with 48 | | Term.Prop _ -> if s = Sorts.prop then "Prop" else "Set" 49 | | Term.Type u -> Printf.sprintf "Type %s" (universe_as_string u) 50 | 51 | (* Prints a term *) 52 | let rec term_as_string (env : env) (trm : types) = 53 | match kind trm with 54 | | Rel i -> 55 | (try 56 | let (n, _, _) = CRD.to_tuple @@ lookup_rel i env in 57 | Printf.sprintf "(%s [Rel %d])" (name_as_string n) i 58 | with 59 | Not_found -> Printf.sprintf "(Unbound_Rel %d)" i) 60 | | Var v -> 61 | string_of_id v 62 | | Meta mv -> 63 | failwith "Metavariables are not yet supported" 64 | | Evar (k, cs) -> 65 | Printf.sprintf "??" 66 | | Sort s -> 67 | sort_as_string s 68 | | Cast (c, k, t) -> 69 | Printf.sprintf "(%s : %s)" (term_as_string env c) (term_as_string env t) 70 | | Prod (n, t, b) -> 71 | Printf.sprintf "(Π (%s : %s) . %s)" (name_as_string n) (term_as_string env t) (term_as_string (push_rel CRD.(LocalAssum(n, t)) env) b) 72 | | Lambda (n, t, b) -> 73 | Printf.sprintf "(λ (%s : %s) . %s)" (name_as_string n) (term_as_string env t) (term_as_string (push_rel CRD.(LocalAssum(n, t)) env) b) 74 | | LetIn (n, trm, typ, e) -> 75 | Printf.sprintf "(let (%s : %s) := %s in %s)" (name_as_string n) (term_as_string env typ) (term_as_string env typ) (term_as_string (push_rel CRD.(LocalDef(n, e, typ)) env) e) 76 | | App (f, xs) -> 77 | Printf.sprintf "(%s %s)" (term_as_string env f) (String.concat " " (List.map (term_as_string env) (Array.to_list xs))) 78 | | Const (c, u) -> 79 | let ker_name = Constant.canonical c in 80 | string_of_kn ker_name 81 | | Construct (((i, i_index), c_index), u) -> 82 | let mutind_body = lookup_mind i env in 83 | let ind_body = mutind_body.mind_packets.(i_index) in 84 | let constr_name_id = ind_body.mind_consnames.(c_index - 1) in 85 | string_of_id constr_name_id 86 | | Ind ((i, i_index), u) -> 87 | let mutind_body = lookup_mind i env in 88 | let ind_bodies = mutind_body.mind_packets in 89 | let name_id = (ind_bodies.(i_index)).mind_typename in 90 | string_of_id name_id 91 | | Case (ci, ct, m, bs) -> 92 | let (i, i_index) = ci.ci_ind in 93 | let mutind_body = lookup_mind i env in 94 | let ind_body = mutind_body.mind_packets.(i_index) in 95 | Printf.sprintf 96 | "(match %s : %s with %s)" 97 | (term_as_string env m) 98 | (term_as_string env ct) 99 | (String.concat 100 | " " 101 | (Array.to_list 102 | (Array.mapi 103 | (fun c_i b -> 104 | Printf.sprintf 105 | "(case %s => %s)" 106 | (string_of_id (ind_body.mind_consnames.(c_i))) 107 | (term_as_string env b)) 108 | bs))) 109 | | Fix ((is, i), (ns, ts, ds)) -> 110 | let env_fix = push_rel_context (bindings_for_fix ns ds) env in 111 | String.concat 112 | " with " 113 | (map3 114 | (fun n t d -> 115 | Printf.sprintf 116 | "(Fix %s : %s := %s)" 117 | (name_as_string n) 118 | (term_as_string env t) 119 | (term_as_string env_fix d)) 120 | (Array.to_list ns) 121 | (Array.to_list ts) 122 | (Array.to_list ds)) 123 | | CoFix (i, (ns, ts, ds)) -> 124 | Printf.sprintf "TODO" (* TODO *) 125 | | Proj (p, c) -> 126 | Printf.sprintf "TODO" (* TODO *) 127 | 128 | (* --- Coq environments --- *) 129 | 130 | (* Gets env as a string *) 131 | let env_as_string (env : env) : string = 132 | let all_relis = all_rel_indexes env in 133 | String.concat 134 | ",\n" 135 | (List.map 136 | (fun i -> 137 | let (n, b, t) = CRD.to_tuple @@ lookup_rel i env in 138 | Printf.sprintf "%s (Rel %d): %s" (name_as_string n) i (term_as_string (pop_rel_context i env) t)) 139 | all_relis) 140 | 141 | (* --- Debugging --- *) 142 | 143 | (* Print a separator string *) 144 | let print_separator unit : unit = 145 | Printf.printf "%s\n\n" "-----------------" 146 | 147 | (* Debug a term *) 148 | let debug_term (env : env) (trm : types) (descriptor : string) : unit = 149 | Printf.printf "%s: %s\n\n" descriptor (term_as_string env trm) 150 | 151 | (* Debug a list of terms *) 152 | let debug_terms (env : env) (trms : types list) (descriptor : string) : unit = 153 | List.iter (fun t -> debug_term env t descriptor) trms 154 | 155 | (* Debug an environment *) 156 | let debug_env (env : env) (descriptor : string) : unit = 157 | Printf.printf "%s: %s\n\n" descriptor (env_as_string env) 158 | -------------------------------------------------------------------------------- /src/lib/printing.mli: -------------------------------------------------------------------------------- 1 | (* Auxiliary functions for printing *) 2 | 3 | open Format 4 | open Names 5 | open Constr 6 | open Environ 7 | 8 | (* --- Strings --- *) 9 | 10 | (* Using a supplied pretty printing function, prints directly to a string *) 11 | val print_to_string : (formatter -> 'a -> unit) -> 'a -> string 12 | 13 | (* --- Coq terms --- *) 14 | 15 | (* Gets a name as a string *) 16 | val name_as_string : name -> string 17 | 18 | (* Gets a term as a string in an environment *) 19 | val term_as_string : env -> types -> string 20 | 21 | (* --- Coq environments --- *) 22 | 23 | (* Gets an environment as a string *) 24 | val env_as_string : env -> string 25 | 26 | (* --- Debugging --- *) 27 | 28 | (* Print a separator string *) 29 | val print_separator : unit -> unit 30 | 31 | (* Debug a term with a descriptor string *) 32 | val debug_term : env -> types -> string -> unit 33 | 34 | (* Debug a list of terms with a descriptor string *) 35 | val debug_terms : env -> types list -> string -> unit 36 | 37 | (* Debug an environment with a descriptor string *) 38 | val debug_env : env -> string -> unit 39 | -------------------------------------------------------------------------------- /src/lib/substitution.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Recursive substitutions on a term 3 | *) 4 | 5 | open Environ 6 | open Constr 7 | open Evd 8 | open Hofs 9 | open Debruijn 10 | open Coqterms 11 | 12 | (* Map a substitution over a term *) 13 | let all_substs p env evd (src, dst) trm : types = 14 | map_term_env_if 15 | (fun en (s, _) t -> p en evd s t) 16 | (fun _ (_, d) _ -> d) 17 | (fun (s, d) -> (shift s, shift d)) 18 | env 19 | (src, dst) 20 | trm 21 | 22 | (* In env, substitute all subterms of trm that are convertible to src with dst *) 23 | let all_conv_substs = 24 | all_substs convertible 25 | -------------------------------------------------------------------------------- /src/lib/substitution.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Recursive substitutions on a term 3 | *) 4 | 5 | open Environ 6 | open Constr 7 | open Evd 8 | 9 | (* Map a substitution over subterms of a term *) 10 | val all_substs : 11 | (env -> evar_map -> types -> types -> bool) -> 12 | env -> 13 | evar_map -> 14 | (types * types) -> 15 | types -> 16 | types 17 | 18 | (* 19 | * Substitute all subterms of that are convertible to a source 20 | * term with a destination term 21 | *) 22 | val all_conv_substs : env -> evar_map -> (types * types) -> types -> types 23 | 24 | -------------------------------------------------------------------------------- /src/magic.ml4: -------------------------------------------------------------------------------- 1 | DECLARE PLUGIN "wand" 2 | 3 | open Stdarg 4 | open Names 5 | open Environ 6 | open Constr 7 | open Evd 8 | open Tactics 9 | open Basics 10 | open Coqterms 11 | open Ltac_plugin 12 | open Substitution (* useful for later exercises *) 13 | open Printing (* useful for debugging *) 14 | 15 | (* --- Spells --- *) 16 | 17 | (* 18 | * These modules contain the magic behind the non-trivial spells. 19 | * You should inspect and modify these as needed. 20 | *) 21 | 22 | open Sectumsempra 23 | open Levicorpus 24 | open Reducio 25 | 26 | (* --- Spell top-levels --- *) 27 | 28 | (* 29 | * Some of these are implemented, and some are left as exercises. 30 | * Do the exercises in whichever order you please. 31 | * Tests for these exercises are in the coq/exercises directory. 32 | *) 33 | 34 | (* Tactic version of Geminio *) 35 | let geminio_in (etrm : EConstr.constr) : unit Proofview.tactic = 36 | let (evm, env) = Pfedit.get_current_context () in 37 | letin_pat_tac false None Anonymous (evm, etrm) Locusops.nowhere 38 | 39 | (* 40 | * Exercise 1 [2 points]: Implement a command version of Geminio, 41 | * which takes an expicit identifier n and defines it to refer 42 | * to the cloned term. This is a nice way to get used to the infrastructure. 43 | * It should be about two lines of code. 44 | * 45 | * If successful, GeminioNamed.v should compile. 46 | *) 47 | let geminio_named n target : unit = 48 | () (* Your code here *) 49 | 50 | (* 51 | * Exercise 2 [5 points]: Implement a command version of Geminio 52 | * that automatically determines the identifier name by adding the 53 | * "_clone" suffix, so that f is cloned to f_clone. 54 | * 55 | * If successful, Geminio.v should compile. 56 | *) 57 | let geminio target : unit = 58 | () (* Your code here *) 59 | 60 | (* Sectumsempra *) 61 | let sectumsempra target : unit = 62 | let (evm, env) = Pfedit.get_current_context () in 63 | let trm = intern env evm target in 64 | let id = id_or_default trm name_of_const (fresh_with_prefix "factor") in 65 | let body = unwrap_definition env trm in 66 | let fs = sectumsempra_body env evm body in 67 | List.iteri 68 | (fun i lemma -> 69 | let lemma_id = with_suffix (string_of_int i) id in 70 | define_term lemma_id evm lemma; 71 | Printf.printf "Defined %s\n" (Id.to_string lemma_id)) 72 | fs 73 | 74 | (* 75 | * Exercise 3 [10 points]: Implement a tactic version of Sectumsempra. 76 | * 77 | * Hint: To form a name from an identifier, you can use the Name constructor. 78 | * To string tactics together, see tclTHEN proofview.mli in the 79 | * Coq source code. 80 | * 81 | * If successful, Sectumsempra.v should compile. 82 | *) 83 | let sectumsempra_in trm : unit Proofview.tactic = 84 | Proofview.tclUNIT () (* Your code here *) 85 | 86 | (* Common code for Levicorpus *) 87 | let levicorpus_common env evm trm define = 88 | let inverted = levicorpus_body env evm trm in 89 | if Option.has_some inverted then 90 | let flipped = Option.get inverted in 91 | define evm flipped 92 | else 93 | failwith "Could not flip the body upside-down; are you sure this is a human?" 94 | 95 | (* Tactic version of Levicorpus *) 96 | let levicorpus_in (etrm : EConstr.t) : unit Proofview.tactic = 97 | let (evm, env) = Pfedit.get_current_context () in 98 | let trm = EConstr.to_constr evm etrm in 99 | let body = unwrap_definition env trm in 100 | let define evm trm = 101 | let etrm = EConstr.of_constr trm in 102 | letin_pat_tac false None Anonymous (evm, etrm) Locusops.nowhere 103 | in levicorpus_common env evm body define 104 | 105 | (* Command version of Levicorpus *) 106 | let levicorpus target : unit = 107 | let (evm, env) = Pfedit.get_current_context () in 108 | let trm = intern env evm target in 109 | let name_of_inv t = with_suffix "inv" (name_of_const t) in 110 | let inv_id = id_or_default trm name_of_inv (fresh_with_prefix "inverse") in 111 | let body = unwrap_definition env trm in 112 | let define evm trm = 113 | define_term inv_id evm trm; 114 | Printf.printf "Defined %s\n" (Id.to_string inv_id) 115 | in levicorpus_common env evm body define 116 | 117 | (* Reducio *) 118 | let reducio target : unit = 119 | let (evm, env) = Pfedit.get_current_context () in 120 | let trm = intern env evm target in 121 | let name_of_red t = with_suffix "red" (name_of_const t) in 122 | let red_id = id_or_default trm name_of_red (fresh_with_prefix "reduced") in 123 | let body = unwrap_definition env trm in 124 | let red = reducio_body env evm body in 125 | define_term red_id evm red; 126 | Printf.printf "Defined %s\n" (Id.to_string red_id) 127 | 128 | (* 129 | * Exercise 4 [15 points]: Implement a version of Reducio that 130 | * also gets rid of factors with the identity type. 131 | * That is, a term with the following factors: 132 | * 133 | * A -> B 134 | * B -> C 135 | * C -> C 136 | * C -> B 137 | * B -> D 138 | * 139 | * should reduce to a term with the following factors: 140 | * 141 | * A -> B 142 | * B -> D 143 | * 144 | * If successful, ReducioDuo.v should compile. 145 | *) 146 | let reducio_duo target : unit = 147 | () (* Your code here *) 148 | 149 | (* 150 | * Exercise 5 [15 points]: Implement a version of Reducio 151 | * that handles nested inverses. So, for example, 152 | * a term with factors of the following types: 153 | * 154 | * A -> B 155 | * B -> C 156 | * C -> D 157 | * D -> C 158 | * C -> B 159 | * B -> E 160 | * 161 | * should reduce to a term with the following factors: 162 | * 163 | * A -> B 164 | * B -> E 165 | * 166 | * If successful, ReducioTria.v should compile. 167 | *) 168 | let reducio_tria target : unit = 169 | () (* Your code here *) 170 | 171 | (* 172 | * Exercise 6 [20 points]: Implement a version of Reducio 173 | * that handles cycles. So, for example, 174 | * a term with factors of the following types: 175 | * 176 | * A -> B 177 | * B -> C 178 | * C -> D 179 | * D -> B 180 | * B -> E 181 | * 182 | * should reduce to a term with the following factors: 183 | * 184 | * A -> B 185 | * B -> E 186 | * 187 | * If successful, ReducioMaxima.v should compile. 188 | *) 189 | let reducio_maxima target : unit = 190 | () (* Your code here *) 191 | 192 | (* 193 | * Exercise 7 [15 points] The Relashio spell releases the target 194 | * from a binding. Implement a simple version of Relashio 195 | * that takes a constant c and abstracts all terms convertible with c 196 | * in target at the highest level possible. 197 | * So, for example, given the following two definitions: 198 | * 199 | * Definition bar (n : nat) := n + 0. 200 | * Definition foo (n : nat) := n + (0 + 0). 201 | * 202 | * casting the following spells: 203 | * 204 | * Relashio 0 in foo. 205 | * Relashio 0 in bar. 206 | * 207 | * should produce two terms foo_rel, bar_rel which both have the same body 208 | * (the name of the released binding m is irrelevant): 209 | * 210 | * fun (m : nat) (n : nat) => n + m 211 | * 212 | * Hint: The all_conv_substs function from substitution.ml will do this 213 | * substitution for you. This is all doable in about 10 lines of code. 214 | * 215 | * If successful, Relashio.v should compile. 216 | *) 217 | let relashio c target : unit = 218 | () (* Your code here *) 219 | 220 | (* 221 | * Bonus (I'll buy you a beer if you're the first one 222 | * to implement this): Implement the Lumos tactic, which helps 223 | * the user when they are stuck during an inductive proof. 224 | * Lumos lights up the way by generating an intermediate goal and inductive 225 | * hypothesis that are generalized versions of the current goal and inductive 226 | * hypothesis. his allows the user to play around trying to prove the 227 | * intermediate goal, and see if that's the inductive hypothesis they 228 | * really want. They can then go back and change the theorem statement 229 | * appropriately. 230 | * 231 | * Hint: You'll want something similar to all_conv_substs to generalize 232 | * the inductive hypothesis, but you'll likely need to be smarter about how you 233 | * generalize if you want to produce useful goals. 234 | *) 235 | let lumos_in trm : unit Proofview.tactic = 236 | Proofview.tclUNIT () (* Your code here *) 237 | 238 | (* --- Spells --- *) 239 | 240 | (* 241 | * Simply duplicates a term in the context. 242 | *) 243 | TACTIC EXTEND geminio 244 | | [ "geminio" constr(target) ] -> 245 | [ geminio_in target ] 246 | END 247 | 248 | (* 249 | * Command version of Geminio (left to the wizard). 250 | *) 251 | VERNAC COMMAND EXTEND Geminio CLASSIFIED AS SIDEFF 252 | | [ "Geminio" constr(target) ] -> 253 | [ geminio target ] 254 | | [ "Geminio" constr(target) "as" ident(n)] -> 255 | [ geminio_named n target ] 256 | END 257 | 258 | (* 259 | * Slices the body of the target. 260 | * For more details, see Snape (1971). 261 | *) 262 | VERNAC COMMAND EXTEND Sectumsempra CLASSIFIED AS SIDEFF 263 | | [ "Sectumsempra" constr(target) ] -> 264 | [ sectumsempra target ] 265 | END 266 | 267 | (* 268 | * Tactic version of the Sectumsempra spell. 269 | *) 270 | TACTIC EXTEND sectumsempra 271 | | [ "sectumsempra" constr(target) ] -> 272 | [ sectumsempra_in target ] 273 | END 274 | 275 | (* 276 | * Flips the body of the target upside-down. 277 | * This is the command version of the spell. 278 | * For more details, see Snape (1975). 279 | *) 280 | VERNAC COMMAND EXTEND Levicorpus CLASSIFIED AS SIDEFF 281 | | [ "Levicorpus" constr(target) ] -> 282 | [ levicorpus target ] 283 | END 284 | 285 | (* 286 | * Tactic version of the Levicorpus spell. 287 | *) 288 | TACTIC EXTEND levicorpus 289 | | [ "levicorpus" constr(target) ] -> 290 | [ levicorpus_in target ] 291 | END 292 | 293 | (* 294 | * Reduces the target to its normal size. 295 | *) 296 | VERNAC COMMAND EXTEND Reducio CLASSIFIED AS SIDEFF 297 | | [ "Reducio" constr(target) ] -> 298 | [ reducio target ] 299 | | [ "Reducio" "Duo" constr(target) ] -> 300 | [ reducio_duo target ] 301 | | [ "Reducio" "Tria" constr(target) ] -> 302 | [ reducio_tria target ] 303 | | [ "Reducio" "Maxima" constr(target) ] -> 304 | [ reducio_maxima target ] 305 | END 306 | 307 | (* 308 | * Releases the binding to c in target. 309 | *) 310 | VERNAC COMMAND EXTEND Relashio CLASSIFIED AS SIDEFF 311 | | [ "Relashio" constr(c) "in" constr(target) ] -> 312 | [ relashio c target ] 313 | END 314 | 315 | (* 316 | * Helps a user who is stuck during induction. 317 | *) 318 | TACTIC EXTEND lumos 319 | | [ "lumos" constr(target) ] -> 320 | [ lumos_in target ] 321 | END 322 | 323 | -------------------------------------------------------------------------------- /src/spells/levicorpus.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Levicorpus flips a body upside-down (inverts a proof body). 3 | * What the Levicorpus spell shows is that benign and 4 | * useful magic can sometimes be built on dark magic. 5 | * 6 | * While Sectumsempra alone is a dark spell, Levicorpus, 7 | * a much more innocent spell, 8 | * is built on the foundations of Sectumsempra (Snape's prior work): 9 | * It would be too difficult to simply flip a complex body upside-down, 10 | * so instead, the spell works by getting all of the parts, 11 | * flipping each part upside-down, and then reconstructing those parts 12 | * in the opposite order. 13 | * 14 | * It is painless for the target, who never notices being deconstructed to 15 | * begin with. 16 | * 17 | * This is also a simplified version; consult me for details on how to handle 18 | * other kinds of bodies, or see the PUMPKIN PATCH paper. 19 | *) 20 | 21 | open Constr 22 | open Environ 23 | open Evd 24 | open Collections 25 | open Coqterms 26 | open Debruijn 27 | open Substitution 28 | open Printing (* useful for debugging *) 29 | open Sectumsempra 30 | 31 | (* 32 | * Invert rewrites by exploiting symmetry of equality. 33 | * Simplified inversion for this toy plugin only handles sequences of rewrites. 34 | *) 35 | let invert_rewrite (env : env) (evd : evar_map) (trm : types) : (env * types) option = 36 | let trm = reduce_term env evd trm in 37 | match kind trm with 38 | | Lambda (n, t, b) -> 39 | let env_b = push_local (n, t) env in 40 | let t' = unshift (reduce_term env_b evd (infer_type env_b evd b)) in 41 | let trm' = all_conv_substs env evd (t, t') trm in 42 | let (n, t', b') = destLambda trm' in 43 | if isApp b' && is_rewrite (fst (destApp b')) then 44 | let (f, args) = destApp b' in 45 | let i_eq = Array.length args - 1 in 46 | let eq = args.(i_eq) in 47 | let eq_type = infer_type env evd eq in 48 | let eq_typ_args = Array.to_list (snd (destApp eq_type)) in 49 | let eq_args = List.append eq_typ_args [eq] in 50 | let eq_r = mkApp (eq_sym, Array.of_list eq_args) in 51 | let i_src = 1 in 52 | let i_dst = 4 in 53 | let args_r = 54 | Array.mapi 55 | (fun i a -> 56 | if i = i_eq then 57 | eq_r 58 | else if i = i_src then 59 | args.(i_dst) 60 | else if i = i_dst then 61 | args.(i_src) 62 | else 63 | a) 64 | args 65 | in Some (env, mkLambda (n, t', mkApp (f, args_r))) 66 | else 67 | None 68 | | _ -> 69 | Some (env, trm) 70 | 71 | 72 | (* 73 | * Given the factors for a term and an inverter, 74 | * invert every factor, and produce the inverse factors by reversing it. 75 | * 76 | * That is, take [X; X -> Y; Y -> Z] and produce [Z; Z -> Y; Y -> X]. 77 | * 78 | * If inverting any term along the way fails, produce the empty list. 79 | * 80 | * For simplicity, we assume a sequence of rewrites for this example plugin. 81 | *) 82 | let invert_factors (evd : evar_map) (fs : factors) : factors = 83 | let inverse_options = List.map (fun (en, f) -> invert_rewrite en evd f) fs in 84 | let inverted = List.rev (get_all_or_none inverse_options) in 85 | match inverted with (* swap final hypothesis *) 86 | | (env_inv, trm_inv) :: t when List.length t > 0 -> 87 | let (n, h_inv, _) = destLambda (snd (last t)) in 88 | let env_inv = push_rel CRD.(LocalAssum(n, h_inv)) (pop_rel_context 1 env_inv) in 89 | (env_inv, trm_inv) :: t 90 | | _ -> 91 | inverted 92 | 93 | (* Invert a body in an environment *) 94 | let levicorpus_body (env : env) (evd : evar_map) (trm : types) : types option = 95 | let inv_fs = invert_factors evd (factor_term env evd trm) in 96 | if List.length inv_fs > 0 then 97 | Some (apply_factors inv_fs) 98 | else 99 | None 100 | -------------------------------------------------------------------------------- /src/spells/levicorpus.mli: -------------------------------------------------------------------------------- 1 | open Environ 2 | open Evd 3 | open Constr 4 | 5 | (* 6 | * Levicorpus flips a body upside-down (inverts a proof body). 7 | * What the Levicorpus spell shows is that benign and 8 | * useful magic can sometimes be built on dark magic. 9 | * 10 | * This is also a simplified version; consult me for details on how to handle 11 | * other kinds of bodies, or see the PUMPKIN PATCH paper. 12 | *) 13 | 14 | (* Invert a body in an environment *) 15 | val levicorpus_body : env -> evar_map -> types -> types option 16 | -------------------------------------------------------------------------------- /src/spells/reducio.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * The Reducio spell reduces the target back to its normal size. 3 | * Please do not use this on humans unless they are impacted by Engorgio. 4 | * 5 | * This is a simple version of Reducio. 6 | * More complex versions are left to the witch or wizard. 7 | *) 8 | 9 | open Environ 10 | open Constr 11 | open Evd 12 | open Coqterms 13 | open Sectumsempra 14 | open Debruijn 15 | open Printing (* useful for debugging *) 16 | 17 | (* 18 | * Check if two consecutive factors are inverses 19 | *) 20 | let are_inverses (evd : evar_map) (env', trm') (env, trm) : bool = 21 | try 22 | let (_, t, b) = destProd (reduce_type env evd trm) in 23 | let (_, t', b') = destProd (reduce_type env' evd trm') in 24 | convertible env evd t (unshift b') && convertible env' evd (unshift b) t' 25 | with _ -> 26 | false 27 | 28 | (* 29 | * Filter out every pair of consecutive inverses 30 | *) 31 | let rec filter_inverses (evd : evar_map) (fs : factors) = 32 | match fs with 33 | | f' :: (f :: tl) -> 34 | if are_inverses evd f' f then 35 | filter_inverses evd tl 36 | else 37 | f' :: (filter_inverses evd (f :: tl)) 38 | | _ -> 39 | fs 40 | 41 | (* 42 | * Like Levicorpus, the foundations of Reducio are grounded in Sectumsempra. 43 | * Reducio first slices the target into pieces, then looks for redundant pieces 44 | * to get rid of, then reconstructs the target. When it fails, 45 | * it simply produces the original term. 46 | * 47 | * Note: This is precisely why it can be dangerous to use on humans if they 48 | * have not been engorged first, since they will not have any redundant 49 | * pieces to get rid of. 50 | * 51 | * In this simple version, two pieces are redundant exactly when one 52 | * has the inverse type of the other, and the spell only gets rid 53 | * of consecutive redundant pieces. 54 | *) 55 | let reducio_body (env : env) (evd : evar_map) (trm : types) : types = 56 | let fs = List.rev (factor_term env evd trm) in 57 | let red_fs = List.hd fs :: (List.rev (filter_inverses evd (List.tl fs))) in 58 | let red = apply_factors red_fs in 59 | if has_type env evd (infer_type env evd trm) red then 60 | reduce_term env evd red 61 | else 62 | trm 63 | -------------------------------------------------------------------------------- /src/spells/reducio.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * The Reducio spell reduces the target back to its normal size. 3 | * Please do not use this on humans unless they are impacted by Engorgio. 4 | * 5 | * This is a simple version of Reducio. 6 | * More complex versions are left to the witch or wizard. 7 | *) 8 | 9 | open Environ 10 | open Constr 11 | open Evd 12 | 13 | (* 14 | * Like Levicorpus, the foundations of Reducio are grounded in Sectumsempra. 15 | * Reducio first slices the target into pieces, then looks for redundant pieces 16 | * to get rid of, then reconstructs the target. When it fails, 17 | * it simply produces the original term. 18 | * 19 | * Note: This is precisely why it can be dangerous to use on humans if they 20 | * have not been engorged first, since they will not have any redundant 21 | * pieces to get rid of. 22 | *) 23 | val reducio_body : env -> evar_map -> types -> types 24 | -------------------------------------------------------------------------------- /src/spells/sectumsempra.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * The Sectumsempra [Snape (1971)] spell cuts the body of a proof into pieces. 3 | * We call each of these pieces a factor. 4 | * See Example.v for more information. 5 | * 6 | * This is the implementation of the simplest existing version of this spell. 7 | * This simple exemplary version makes a lot of assumptions about the body, 8 | * and only handles certain kinds of types. More general versions of this 9 | * exist; if you are interested, let me know. 10 | *) 11 | 12 | open Constr 13 | open Names 14 | open Environ 15 | open Evd 16 | open Collections 17 | open Basics 18 | open Coqterms 19 | open Debruijn 20 | open Printing (* useful for debugging *) 21 | 22 | module CRD = Context.Rel.Declaration 23 | 24 | (* --- Sectumsempra --- *) 25 | 26 | type factors = (env * types) list 27 | 28 | let assum : types = mkRel 1 29 | 30 | (* Apply the assumption in the term *) 31 | let apply_assumption (fs : factors) (trm : types) : types = 32 | if List.length fs > 0 then assum else trm 33 | 34 | (* Check if the term is the assumption *) 35 | let is_assumption (env : env) (evd : evar_map) (trm : types) : bool = 36 | convertible env evd trm assum 37 | 38 | (* Swap out the assumption for a new one *) 39 | let assume (env : env) (n : name) (typ : types) : env = 40 | push_local (n, typ) (pop_rel_context 1 env) 41 | 42 | (* 43 | * Auxiliary path-finding function when we have a sequence of applications 44 | * and the hypothesis we care about is the assumption (last bound term 45 | * in the environment, or Rel 1). 46 | * 47 | * The type path is in reverse order for efficiency, and is really 48 | * a list of environments (assumptions) and terms. When we refer to 49 | * "the end" it is the head of the list. 50 | * 51 | * The spell works as follows: 52 | * 1. If a term is the assumption, return a single path with 53 | * the environment and term, which is the identity path. 54 | * 2. Otherwise, if it is an application: 55 | * a. Recursively get the type path for each argument. 56 | * b. If there are multiple nonempty type paths, then we cannot abstract out 57 | * the assumption in a single function, so return the identity path. 58 | * c. Otherwise, get the only non-empty path, then: 59 | * i. Zoom in on each argument with the current assumption 60 | * ii. Assume the conclusion of the element at the end of the path 61 | * ii. Apply the function to the zoomed arguments in the environment 62 | * with the new assumption, and add that to the end of the path 63 | * iv. If applying the assumption at any point fails, return the empty 64 | * path 65 | * 66 | * In other words, this is going as deep into the term as possible and 67 | * finding some Y for which X -> Y. It is then assuming Y, 68 | * and asking if there is some path from Y to the conclusion. 69 | *) 70 | let rec find_path (env : env) (evd : evar_map) (trm : types) : factors = 71 | if is_assumption env evd trm then 72 | [(env, trm)] 73 | else 74 | match kind trm with 75 | | App (f, args) -> 76 | let paths = Array.map (find_path env evd) args in 77 | let nonempty_paths = 78 | List.filter 79 | (fun l -> List.length l > 0) 80 | (Array.to_list paths) 81 | in 82 | if List.length nonempty_paths > 1 then 83 | [(env, trm)] 84 | else if List.length nonempty_paths = 1 then 85 | let path = List.hd nonempty_paths in 86 | let (env_arg, arg) = List.hd path in 87 | let assume_arg i a = apply_assumption (Array.get paths i) a in 88 | let args_assumed = Array.mapi assume_arg args in 89 | try 90 | let t = unshift (reduce_type env_arg evd arg) in 91 | (assume env Anonymous t, mkApp (f, args_assumed)) :: path 92 | with _ -> 93 | [] 94 | else 95 | [] 96 | | _ -> 97 | [] 98 | 99 | (* 100 | * Given a term trm, if the type of trm is a function type 101 | * X -> Z, find factors through which it passes 102 | * (e.g., [H : X, F : X -> Y, G : Y -> Z] where trm = G o F) 103 | * 104 | * First zoom in all the way, then use the auxiliary path-finding 105 | * function. 106 | *) 107 | let factor_term (env : env) (evd : evar_map) (trm : types) : factors = 108 | let (env_zoomed, trm_zoomed) = zoom_lambda_term env (reduce_term env evd trm) in 109 | let path_body = find_path env_zoomed evd trm_zoomed in 110 | List.map 111 | (fun (env, body) -> 112 | if is_assumption env evd body then 113 | (env, body) 114 | else 115 | let (n, _, t) = CRD.to_tuple @@ lookup_rel 1 env in 116 | (pop_rel_context 1 env, mkLambda (n, t, body))) 117 | path_body 118 | 119 | (* 120 | * Reconstruct factors as terms using hypotheses from the environment. 121 | * This produces a friendly form in the correct order. 122 | * The other form is useful for efficiency for other spells, like levicorpus. 123 | *) 124 | let reconstruct_factors (fs : factors) : types list = 125 | List.map 126 | (fun (en, t) -> reconstruct_lambda en t) 127 | (List.tl (List.rev fs)) 128 | 129 | (* Apply factors to reconstruct a single term *) 130 | let apply_factors (fs : factors) : types = 131 | let (env, base) = List.hd fs in 132 | let body = 133 | List.fold_right 134 | (fun (_, t) t_app -> 135 | mkApp (shift t, Array.make 1 t_app)) 136 | (List.tl fs) 137 | base 138 | in reconstruct_lambda env body 139 | 140 | (* Sectumsempra *) 141 | let sectumsempra_body (env : env) (evd : evar_map) (body : types) : types list = 142 | reconstruct_factors (factor_term env evd body) 143 | -------------------------------------------------------------------------------- /src/spells/sectumsempra.mli: -------------------------------------------------------------------------------- 1 | open Constr 2 | open Environ 3 | open Evd 4 | 5 | (* 6 | * The Sectumsempra [Snape (1971)] spell cuts the body of a proof into pieces. 7 | * We call each of these pieces a factor. 8 | * See Example.v for more information. 9 | *) 10 | 11 | (* 12 | * Factors are a list of terms and environments stored in reverse order (!!!). 13 | * If you reverse the list, then the first element is the assumption, 14 | * and every element after that takes the element before it to a new term. 15 | * So for the factors [H : X, F : X -> Y, G : Y -> Z], we store 16 | * [(env ++ Y, G (Rel 1) : Z), (env ++ X, G (Rel 1) : Y), ..., (env, X)]. 17 | * 18 | * You can get these back as lambdas by calling reconstruct_factors, 19 | * but this form is efficient for folding it back together for inversion. 20 | *) 21 | type factors = (env * types) list 22 | 23 | (* 24 | * Given a term trm, if the type of trm is a function type 25 | * X -> Z, find factors through which it passes 26 | * (e.g., [H : X, F : X -> Y, G : Y -> Z] where trm = G o F). 27 | * 28 | * First zoom in all the way, then use the auxiliary path-finding 29 | * function. 30 | *) 31 | val factor_term : env -> evar_map -> types -> factors 32 | 33 | (* Apply factors to reconstruct a single term *) 34 | val apply_factors : factors -> types 35 | 36 | (* Sectumsempra *) 37 | val sectumsempra_body : env -> evar_map -> types -> types list 38 | -------------------------------------------------------------------------------- /src/wand.mlpack: -------------------------------------------------------------------------------- 1 | Collections 2 | 3 | Basics 4 | Coqterms 5 | 6 | Printing 7 | 8 | Hofs 9 | Debruijn 10 | Substitution 11 | 12 | Sectumsempra 13 | Levicorpus 14 | Reducio 15 | 16 | Magic 17 | -------------------------------------------------------------------------------- /theories/Wand.v: -------------------------------------------------------------------------------- 1 | Declare ML Module "wand". 2 | 3 | --------------------------------------------------------------------------------