├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── _CoqProject ├── coq-githash-used ├── coq-version-used ├── doit ├── elist.v ├── erasable.v ├── ezbool.v ├── factorevars.v ├── hypiter.v ├── ordered.v ├── solvesorted.v ├── utils.v ├── wavl.ml ├── wavl.mli ├── wavl.v ├── wavl_noauto.ml ├── wavl_noauto.mli ├── wavl_noauto.v ├── wavl_noninter.ml ├── wavl_noninter.mli └── wavl_noninter.v /.gitignore: -------------------------------------------------------------------------------- 1 | *.v.d 2 | *.vo 3 | *.vio 4 | *.glob 5 | *~ 6 | *.aux 7 | TAGS 8 | *.cache 9 | #*# 10 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2020 Jonathan Leivent 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 all 13 | 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 THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | ########################################################################## 2 | ## # The Coq Proof Assistant / The Coq Development Team ## 3 | ## v # Copyright INRIA, CNRS and contributors ## 4 | ## /dev/null 2>/dev/null; echo $$?)) 72 | STDTIME?=command time -f $(TIMEFMT) 73 | else 74 | ifeq (0,$(shell gtime -f "" true >/dev/null 2>/dev/null; echo $$?)) 75 | STDTIME?=gtime -f $(TIMEFMT) 76 | else 77 | STDTIME?=command time 78 | endif 79 | endif 80 | else 81 | STDTIME?=command time -f $(TIMEFMT) 82 | endif 83 | 84 | ifneq (,$(COQBIN)) 85 | # add an ending / 86 | COQBIN:=$(COQBIN)/ 87 | endif 88 | 89 | # Coq binaries 90 | COQC ?= "$(COQBIN)coqc" 91 | COQTOP ?= "$(COQBIN)coqtop" 92 | COQCHK ?= "$(COQBIN)coqchk" 93 | COQDEP ?= "$(COQBIN)coqdep" 94 | COQDOC ?= "$(COQBIN)coqdoc" 95 | COQPP ?= "$(COQBIN)coqpp" 96 | COQMKFILE ?= "$(COQBIN)coq_makefile" 97 | OCAMLLIBDEP ?= "$(COQBIN)ocamllibdep" 98 | 99 | # Timing scripts 100 | COQMAKE_ONE_TIME_FILE ?= "$(COQLIB)/tools/make-one-time-file.py" 101 | COQMAKE_BOTH_TIME_FILES ?= "$(COQLIB)/tools/make-both-time-files.py" 102 | COQMAKE_BOTH_SINGLE_TIMING_FILES ?= "$(COQLIB)/tools/make-both-single-timing-files.py" 103 | BEFORE ?= 104 | AFTER ?= 105 | 106 | # FIXME this should be generated by Coq (modules already linked by Coq) 107 | CAMLDONTLINK=num,str,unix,dynlink,threads 108 | 109 | # OCaml binaries 110 | CAMLC ?= "$(OCAMLFIND)" ocamlc -c 111 | CAMLOPTC ?= "$(OCAMLFIND)" opt -c 112 | CAMLLINK ?= "$(OCAMLFIND)" ocamlc -linkpkg -dontlink $(CAMLDONTLINK) 113 | CAMLOPTLINK ?= "$(OCAMLFIND)" opt -linkpkg -dontlink $(CAMLDONTLINK) 114 | CAMLDOC ?= "$(OCAMLFIND)" ocamldoc 115 | CAMLDEP ?= "$(OCAMLFIND)" ocamldep -slash -ml-synonym .mlpack 116 | 117 | # DESTDIR is prepended to all installation paths 118 | DESTDIR ?= 119 | 120 | # Debug builds, typically -g to OCaml, -debug to Coq. 121 | CAMLDEBUG ?= 122 | COQDEBUG ?= 123 | 124 | # Extra packages to be linked in (as in findlib -package) 125 | CAMLPKGS ?= 126 | 127 | # Option for making timing files 128 | TIMING?= 129 | # Option for changing sorting of timing output file 130 | TIMING_SORT_BY ?= auto 131 | # Option for changing the fuzz parameter on the output file 132 | TIMING_FUZZ ?= 0 133 | # Option for changing whether to use real or user time for timing tables 134 | TIMING_REAL?= 135 | # Option for including the memory column(s) 136 | TIMING_INCLUDE_MEM?= 137 | # Option for sorting by the memory column 138 | TIMING_SORT_BY_MEM?= 139 | # Output file names for timed builds 140 | TIME_OF_BUILD_FILE ?= time-of-build.log 141 | TIME_OF_BUILD_BEFORE_FILE ?= time-of-build-before.log 142 | TIME_OF_BUILD_AFTER_FILE ?= time-of-build-after.log 143 | TIME_OF_PRETTY_BUILD_FILE ?= time-of-build-pretty.log 144 | TIME_OF_PRETTY_BOTH_BUILD_FILE ?= time-of-build-both.log 145 | TIME_OF_PRETTY_BUILD_EXTRA_FILES ?= - # also output to the command line 146 | 147 | TGTS ?= 148 | 149 | ########## End of parameters ################################################## 150 | # What follows may be relevant to you only if you need to 151 | # extend this Makefile. If so, look for 'Extension point' here and 152 | # put in Makefile.local double colon rules accordingly. 153 | # E.g. to perform some work after the all target completes you can write 154 | # 155 | # post-all:: 156 | # echo "All done!" 157 | # 158 | # in Makefile.local 159 | # 160 | ############################################################################### 161 | 162 | 163 | 164 | 165 | # Flags ####################################################################### 166 | # 167 | # We define a bunch of variables combining the parameters. 168 | # To add additional flags to coq, coqchk or coqdoc, set the 169 | # {COQ,COQCHK,COQDOC}EXTRAFLAGS variable to whatever you want to add. 170 | # To overwrite the default choice and set your own flags entirely, set the 171 | # {COQ,COQCHK,COQDOC}FLAGS variable. 172 | 173 | SHOW := $(if $(VERBOSE),@true "",@echo "") 174 | HIDE := $(if $(VERBOSE),,@) 175 | 176 | TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) 177 | 178 | OPT?= 179 | 180 | # The DYNOBJ and DYNLIB variables are used by "coqdep -dyndep var" in .v.d 181 | ifeq '$(OPT)' '-byte' 182 | USEBYTE:=true 183 | DYNOBJ:=.cma 184 | DYNLIB:=.cma 185 | else 186 | USEBYTE:= 187 | DYNOBJ:=.cmxs 188 | DYNLIB:=.cmxs 189 | endif 190 | 191 | # these variables are meant to be overridden if you want to add *extra* flags 192 | COQEXTRAFLAGS?= 193 | COQCHKEXTRAFLAGS?= 194 | COQDOCEXTRAFLAGS?= 195 | 196 | # these flags do NOT contain the libraries, to make them easier to overwrite 197 | COQFLAGS?=-q $(OTHERFLAGS) $(COQEXTRAFLAGS) 198 | COQCHKFLAGS?=-silent -o $(COQCHKEXTRAFLAGS) 199 | COQDOCFLAGS?=-interpolate -utf8 $(COQDOCEXTRAFLAGS) 200 | 201 | COQDOCLIBS?=$(COQLIBS_NOML) 202 | 203 | # The version of Coq being run and the version of coq_makefile that 204 | # generated this makefile 205 | COQ_VERSION:=$(shell $(COQC) --print-version | cut -d " " -f 1) 206 | COQMAKEFILE_VERSION:=8.12.0 207 | 208 | COQSRCLIBS?= $(foreach d,$(COQ_SRC_SUBDIRS), -I "$(COQLIB)/$(d)") 209 | 210 | CAMLFLAGS+=$(OCAMLLIBS) $(COQSRCLIBS) 211 | # ocamldoc fails with unknown argument otherwise 212 | CAMLDOCFLAGS:=$(filter-out -annot, $(filter-out -bin-annot, $(CAMLFLAGS))) 213 | CAMLFLAGS+=$(OCAMLWARN) 214 | 215 | ifneq (,$(TIMING)) 216 | TIMING_ARG=-time 217 | ifeq (after,$(TIMING)) 218 | TIMING_EXT=after-timing 219 | else 220 | ifeq (before,$(TIMING)) 221 | TIMING_EXT=before-timing 222 | else 223 | TIMING_EXT=timing 224 | endif 225 | endif 226 | else 227 | TIMING_ARG= 228 | endif 229 | 230 | # Retro compatibility (DESTDIR is standard on Unix, DSTROOT is not) 231 | ifdef DSTROOT 232 | DESTDIR := $(DSTROOT) 233 | endif 234 | 235 | concat_path = $(if $(1),$(1)/$(if $(COQMF_WINDRIVE),$(subst $(COQMF_WINDRIVE),/,$(2)),$(2)),$(2)) 236 | 237 | COQLIBINSTALL = $(call concat_path,$(DESTDIR),$(COQLIB)/user-contrib) 238 | COQDOCINSTALL = $(call concat_path,$(DESTDIR),$(DOCDIR)/user-contrib) 239 | COQTOPINSTALL = $(call concat_path,$(DESTDIR),$(COQLIB)/toploop) 240 | 241 | # Files ####################################################################### 242 | # 243 | # We here define a bunch of variables about the files being part of the 244 | # Coq project in order to ease the writing of build target and build rules 245 | 246 | VDFILE := .Makefile.d 247 | 248 | ALLSRCFILES := \ 249 | $(MLGFILES) \ 250 | $(MLFILES) \ 251 | $(MLPACKFILES) \ 252 | $(MLLIBFILES) \ 253 | $(MLIFILES) 254 | 255 | # helpers 256 | vo_to_obj = $(addsuffix .o,\ 257 | $(filter-out Warning: Error:,\ 258 | $(shell $(COQTOP) -q -noinit -batch -quiet -print-mod-uid $(1)))) 259 | strip_dotslash = $(patsubst ./%,%,$(1)) 260 | 261 | # without this we get undefined variables in the expansion for the 262 | # targets of the [deprecated,use-mllib-or-mlpack] rule 263 | with_undef = $(if $(filter-out undefined, $(origin $(1))),$($(1))) 264 | 265 | VO = vo 266 | VOS = vos 267 | 268 | VOFILES = $(VFILES:.v=.$(VO)) 269 | GLOBFILES = $(VFILES:.v=.glob) 270 | HTMLFILES = $(VFILES:.v=.html) 271 | GHTMLFILES = $(VFILES:.v=.g.html) 272 | BEAUTYFILES = $(addsuffix .beautified,$(VFILES)) 273 | TEXFILES = $(VFILES:.v=.tex) 274 | GTEXFILES = $(VFILES:.v=.g.tex) 275 | CMOFILES = \ 276 | $(MLGFILES:.mlg=.cmo) \ 277 | $(MLFILES:.ml=.cmo) \ 278 | $(MLPACKFILES:.mlpack=.cmo) 279 | CMXFILES = $(CMOFILES:.cmo=.cmx) 280 | OFILES = $(CMXFILES:.cmx=.o) 281 | CMAFILES = $(MLLIBFILES:.mllib=.cma) $(MLPACKFILES:.mlpack=.cma) 282 | CMXAFILES = $(CMAFILES:.cma=.cmxa) 283 | CMIFILES = \ 284 | $(CMOFILES:.cmo=.cmi) \ 285 | $(MLIFILES:.mli=.cmi) 286 | # the /if/ is because old _CoqProject did not list a .ml(pack|lib) but just 287 | # a .mlg file 288 | CMXSFILES = \ 289 | $(MLPACKFILES:.mlpack=.cmxs) \ 290 | $(CMXAFILES:.cmxa=.cmxs) \ 291 | $(if $(MLPACKFILES)$(CMXAFILES),,\ 292 | $(MLGFILES:.mlg=.cmxs) $(MLFILES:.ml=.cmxs)) 293 | 294 | # files that are packed into a plugin (no extension) 295 | PACKEDFILES = \ 296 | $(call strip_dotslash, \ 297 | $(foreach lib, \ 298 | $(call strip_dotslash, \ 299 | $(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES)),$(call with_undef,$(lib)))) 300 | # files that are archived into a .cma (mllib) 301 | LIBEDFILES = \ 302 | $(call strip_dotslash, \ 303 | $(foreach lib, \ 304 | $(call strip_dotslash, \ 305 | $(MLLIBFILES:.mllib=_MLLIB_DEPENDENCIES)),$(call with_undef,$(lib)))) 306 | CMIFILESTOINSTALL = $(filter-out $(addsuffix .cmi,$(PACKEDFILES)),$(CMIFILES)) 307 | CMOFILESTOINSTALL = $(filter-out $(addsuffix .cmo,$(PACKEDFILES)),$(CMOFILES)) 308 | OBJFILES = $(call vo_to_obj,$(VOFILES)) 309 | ALLNATIVEFILES = \ 310 | $(OBJFILES:.o=.cmi) \ 311 | $(OBJFILES:.o=.cmx) \ 312 | $(OBJFILES:.o=.cmxs) 313 | # trick: wildcard filters out non-existing files, so that `install` doesn't show 314 | # warnings and `clean` doesn't pass to rm a list of files that is too long for 315 | # the shell. 316 | NATIVEFILES = $(wildcard $(ALLNATIVEFILES)) 317 | FILESTOINSTALL = \ 318 | $(VOFILES) \ 319 | $(VFILES) \ 320 | $(GLOBFILES) \ 321 | $(NATIVEFILES) \ 322 | $(CMIFILESTOINSTALL) 323 | BYTEFILESTOINSTALL = \ 324 | $(CMOFILESTOINSTALL) \ 325 | $(CMAFILES) 326 | ifeq '$(HASNATDYNLINK)' 'true' 327 | DO_NATDYNLINK = yes 328 | FILESTOINSTALL += $(CMXSFILES) $(CMXAFILES) $(CMOFILESTOINSTALL:.cmo=.cmx) 329 | else 330 | DO_NATDYNLINK = 331 | endif 332 | 333 | ALLDFILES = $(addsuffix .d,$(ALLSRCFILES)) $(VDFILE) 334 | 335 | # Compilation targets ######################################################### 336 | 337 | all: 338 | $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" pre-all 339 | $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" real-all 340 | $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" post-all 341 | .PHONY: all 342 | 343 | all.timing.diff: 344 | $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" pre-all 345 | $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" real-all.timing.diff TIME_OF_PRETTY_BUILD_EXTRA_FILES="" 346 | $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" post-all 347 | .PHONY: all.timing.diff 348 | 349 | ifeq (0,$(TIMING_REAL)) 350 | TIMING_REAL_ARG := 351 | TIMING_USER_ARG := --user 352 | else 353 | ifeq (1,$(TIMING_REAL)) 354 | TIMING_REAL_ARG := --real 355 | TIMING_USER_ARG := 356 | else 357 | TIMING_REAL_ARG := 358 | TIMING_USER_ARG := 359 | endif 360 | endif 361 | 362 | ifeq (0,$(TIMING_INCLUDE_MEM)) 363 | TIMING_INCLUDE_MEM_ARG := --no-include-mem 364 | else 365 | TIMING_INCLUDE_MEM_ARG := 366 | endif 367 | 368 | ifeq (1,$(TIMING_SORT_BY_MEM)) 369 | TIMING_SORT_BY_MEM_ARG := --sort-by-mem 370 | else 371 | TIMING_SORT_BY_MEM_ARG := 372 | endif 373 | 374 | make-pretty-timed-before:: TIME_OF_BUILD_FILE=$(TIME_OF_BUILD_BEFORE_FILE) 375 | make-pretty-timed-after:: TIME_OF_BUILD_FILE=$(TIME_OF_BUILD_AFTER_FILE) 376 | make-pretty-timed make-pretty-timed-before make-pretty-timed-after:: 377 | $(HIDE)rm -f pretty-timed-success.ok 378 | $(HIDE)($(MAKE) --no-print-directory -f "$(PARENT)" $(TGTS) TIMED=1 2>&1 && touch pretty-timed-success.ok) | tee -a $(TIME_OF_BUILD_FILE) 379 | $(HIDE)rm pretty-timed-success.ok # must not be -f; must fail if the touch failed 380 | print-pretty-timed:: 381 | $(HIDE)$(COQMAKE_ONE_TIME_FILE) $(TIMING_INCLUDE_MEM_ARG) $(TIMING_SORT_BY_MEM_ARG) $(TIMING_REAL_ARG) $(TIME_OF_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) 382 | print-pretty-timed-diff:: 383 | $(HIDE)$(COQMAKE_BOTH_TIME_FILES) --sort-by=$(TIMING_SORT_BY) $(TIMING_INCLUDE_MEM_ARG) $(TIMING_SORT_BY_MEM_ARG) $(TIMING_REAL_ARG) $(TIME_OF_BUILD_AFTER_FILE) $(TIME_OF_BUILD_BEFORE_FILE) $(TIME_OF_PRETTY_BOTH_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) 384 | ifeq (,$(BEFORE)) 385 | print-pretty-single-time-diff:: 386 | @echo 'Error: Usage: $(MAKE) print-pretty-single-time-diff AFTER=path/to/file.v.after-timing BEFORE=path/to/file.v.before-timing' 387 | $(HIDE)false 388 | else 389 | ifeq (,$(AFTER)) 390 | print-pretty-single-time-diff:: 391 | @echo 'Error: Usage: $(MAKE) print-pretty-single-time-diff AFTER=path/to/file.v.after-timing BEFORE=path/to/file.v.before-timing' 392 | $(HIDE)false 393 | else 394 | print-pretty-single-time-diff:: 395 | $(HIDE)$(COQMAKE_BOTH_SINGLE_TIMING_FILES) --fuzz=$(TIMING_FUZZ) --sort-by=$(TIMING_SORT_BY) $(TIMING_USER_ARG) $(AFTER) $(BEFORE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) 396 | endif 397 | endif 398 | pretty-timed: 399 | $(HIDE)$(MAKE) --no-print-directory -f "$(PARENT)" make-pretty-timed 400 | $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" print-pretty-timed 401 | .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 402 | 403 | # Extension points for actions to be performed before/after the all target 404 | pre-all:: 405 | @# Extension point 406 | $(HIDE)if [ "$(COQMAKEFILE_VERSION)" != "$(COQ_VERSION)" ]; then\ 407 | echo "W: This Makefile was generated by Coq $(COQMAKEFILE_VERSION)";\ 408 | echo "W: while the current Coq version is $(COQ_VERSION)";\ 409 | fi 410 | .PHONY: pre-all 411 | 412 | post-all:: 413 | @# Extension point 414 | .PHONY: post-all 415 | 416 | real-all: $(VOFILES) $(if $(USEBYTE),bytefiles,optfiles) 417 | .PHONY: real-all 418 | 419 | real-all.timing.diff: $(VOFILES:.vo=.v.timing.diff) 420 | .PHONY: real-all.timing.diff 421 | 422 | bytefiles: $(CMOFILES) $(CMAFILES) 423 | .PHONY: bytefiles 424 | 425 | optfiles: $(if $(DO_NATDYNLINK),$(CMXSFILES)) 426 | .PHONY: optfiles 427 | 428 | # FIXME, see Ralf's bugreport 429 | # quick is deprecated, now renamed vio 430 | vio: $(VOFILES:.vo=.vio) 431 | .PHONY: vio 432 | quick: vio 433 | $(warning "'make quick' is deprecated, use 'make vio' or consider using 'vos' files") 434 | .PHONY: quick 435 | 436 | vio2vo: 437 | $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) \ 438 | -schedule-vio2vo $(J) $(VOFILES:%.vo=%.vio) 439 | .PHONY: vio2vo 440 | 441 | # quick2vo is undocumented 442 | quick2vo: 443 | $(HIDE)make -j $(J) vio 444 | $(HIDE)VIOFILES=$$(for vofile in $(VOFILES); do \ 445 | viofile="$$(echo "$$vofile" | sed "s/\.vo$$/.vio/")"; \ 446 | if [ "$$vofile" -ot "$$viofile" -o ! -e "$$vofile" ]; then printf "$$viofile "; fi; \ 447 | done); \ 448 | echo "VIO2VO: $$VIOFILES"; \ 449 | if [ -n "$$VIOFILES" ]; then \ 450 | $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) -schedule-vio2vo $(J) $$VIOFILES; \ 451 | fi 452 | .PHONY: quick2vo 453 | 454 | checkproofs: 455 | $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) \ 456 | -schedule-vio-checking $(J) $(VOFILES:%.vo=%.vio) 457 | .PHONY: checkproofs 458 | 459 | vos: $(VOFILES:%.vo=%.vos) 460 | .PHONY: vos 461 | 462 | vok: $(VOFILES:%.vo=%.vok) 463 | .PHONY: vok 464 | 465 | validate: $(VOFILES) 466 | $(TIMER) $(COQCHK) $(COQCHKFLAGS) $(COQLIBS) $^ 467 | .PHONY: validate 468 | 469 | only: $(TGTS) 470 | .PHONY: only 471 | 472 | # Documentation targets ####################################################### 473 | 474 | html: $(GLOBFILES) $(VFILES) 475 | $(SHOW)'COQDOC -d html $(GAL)' 476 | $(HIDE)mkdir -p html 477 | $(HIDE)$(COQDOC) \ 478 | -toc $(COQDOCFLAGS) -html $(GAL) $(COQDOCLIBS) -d html $(VFILES) 479 | 480 | mlihtml: $(MLIFILES:.mli=.cmi) 481 | $(SHOW)'CAMLDOC -d $@' 482 | $(HIDE)mkdir $@ || rm -rf $@/* 483 | $(HIDE)$(CAMLDOC) -html \ 484 | -d $@ -m A $(CAMLDEBUG) $(CAMLDOCFLAGS) $(MLIFILES) 485 | 486 | all-mli.tex: $(MLIFILES:.mli=.cmi) 487 | $(SHOW)'CAMLDOC -latex $@' 488 | $(HIDE)$(CAMLDOC) -latex \ 489 | -o $@ -m A $(CAMLDEBUG) $(CAMLDOCFLAGS) $(MLIFILES) 490 | 491 | all.ps: $(VFILES) 492 | $(SHOW)'COQDOC -ps $(GAL)' 493 | $(HIDE)$(COQDOC) \ 494 | -toc $(COQDOCFLAGS) -ps $(GAL) $(COQDOCLIBS) \ 495 | -o $@ `$(COQDEP) -sort $(VFILES)` 496 | 497 | all.pdf: $(VFILES) 498 | $(SHOW)'COQDOC -pdf $(GAL)' 499 | $(HIDE)$(COQDOC) \ 500 | -toc $(COQDOCFLAGS) -pdf $(GAL) $(COQDOCLIBS) \ 501 | -o $@ `$(COQDEP) -sort $(VFILES)` 502 | 503 | # FIXME: not quite right, since the output name is different 504 | gallinahtml: GAL=-g 505 | gallinahtml: html 506 | 507 | all-gal.ps: GAL=-g 508 | all-gal.ps: all.ps 509 | 510 | all-gal.pdf: GAL=-g 511 | all-gal.pdf: all.pdf 512 | 513 | # ? 514 | beautify: $(BEAUTYFILES) 515 | for file in $^; do mv $${file%.beautified} $${file%beautified}old && mv $${file} $${file%.beautified}; done 516 | @echo 'Do not do "make clean" until you are sure that everything went well!' 517 | @echo 'If there were a problem, execute "for file in $$(find . -name \*.v.old -print); do mv $${file} $${file%.old}; done" in your shell/' 518 | .PHONY: beautify 519 | 520 | # Installation targets ######################################################## 521 | # 522 | # There rules can be extended in Makefile.local 523 | # Extensions can't assume when they run. 524 | 525 | install: 526 | $(HIDE)code=0; for f in $(FILESTOINSTALL); do\ 527 | if ! [ -f "$$f" ]; then >&2 echo $$f does not exist; code=1; fi \ 528 | done; exit $$code 529 | $(HIDE)for f in $(FILESTOINSTALL); do\ 530 | df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`";\ 531 | if [ "$$?" != "0" -o -z "$$df" ]; then\ 532 | echo SKIP "$$f" since it has no logical path;\ 533 | else\ 534 | install -d "$(COQLIBINSTALL)/$$df" &&\ 535 | install -m 0644 "$$f" "$(COQLIBINSTALL)/$$df" &&\ 536 | echo INSTALL "$$f" "$(COQLIBINSTALL)/$$df";\ 537 | fi;\ 538 | done 539 | $(HIDE)$(MAKE) install-extra -f "$(SELF)" 540 | install-extra:: 541 | @# Extension point 542 | .PHONY: install install-extra 543 | 544 | install-byte: 545 | $(HIDE)for f in $(BYTEFILESTOINSTALL); do\ 546 | df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`";\ 547 | if [ "$$?" != "0" -o -z "$$df" ]; then\ 548 | echo SKIP "$$f" since it has no logical path;\ 549 | else\ 550 | install -d "$(COQLIBINSTALL)/$$df" &&\ 551 | install -m 0644 "$$f" "$(COQLIBINSTALL)/$$df" &&\ 552 | echo INSTALL "$$f" "$(COQLIBINSTALL)/$$df";\ 553 | fi;\ 554 | done 555 | 556 | install-doc:: html mlihtml 557 | @# Extension point 558 | $(HIDE)install -d "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html" 559 | $(HIDE)for i in html/*; do \ 560 | dest="$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/$$i";\ 561 | install -m 0644 "$$i" "$$dest";\ 562 | echo INSTALL "$$i" "$$dest";\ 563 | done 564 | $(HIDE)install -d \ 565 | "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml" 566 | $(HIDE)for i in mlihtml/*; do \ 567 | dest="$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/$$i";\ 568 | install -m 0644 "$$i" "$$dest";\ 569 | echo INSTALL "$$i" "$$dest";\ 570 | done 571 | .PHONY: install-doc 572 | 573 | uninstall:: 574 | @# Extension point 575 | $(HIDE)for f in $(FILESTOINSTALL); do \ 576 | df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`" &&\ 577 | instf="$(COQLIBINSTALL)/$$df/`basename $$f`" &&\ 578 | rm -f "$$instf" &&\ 579 | echo RM "$$instf" &&\ 580 | (rmdir "$(call concat_path,,$(COQLIBINSTALL)/$$df/)" 2>/dev/null || true); \ 581 | done 582 | .PHONY: uninstall 583 | 584 | uninstall-doc:: 585 | @# Extension point 586 | $(SHOW)'RM $(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html' 587 | $(HIDE)rm -rf "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html" 588 | $(SHOW)'RM $(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml' 589 | $(HIDE)rm -rf "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml" 590 | $(HIDE) rmdir "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/" || true 591 | .PHONY: uninstall-doc 592 | 593 | # Cleaning #################################################################### 594 | # 595 | # There rules can be extended in Makefile.local 596 | # Extensions can't assume when they run. 597 | 598 | clean:: 599 | @# Extension point 600 | $(SHOW)'CLEAN' 601 | $(HIDE)rm -f $(CMOFILES) 602 | $(HIDE)rm -f $(CMIFILES) 603 | $(HIDE)rm -f $(CMAFILES) 604 | $(HIDE)rm -f $(CMOFILES:.cmo=.cmx) 605 | $(HIDE)rm -f $(CMXAFILES) 606 | $(HIDE)rm -f $(CMXSFILES) 607 | $(HIDE)rm -f $(CMOFILES:.cmo=.o) 608 | $(HIDE)rm -f $(CMXAFILES:.cmxa=.a) 609 | $(HIDE)rm -f $(MLGFILES:.mlg=.ml) 610 | $(HIDE)rm -f $(ALLDFILES) 611 | $(HIDE)rm -f $(NATIVEFILES) 612 | $(HIDE)find . -name .coq-native -type d -empty -delete 613 | $(HIDE)rm -f $(VOFILES) 614 | $(HIDE)rm -f $(VOFILES:.vo=.vio) 615 | $(HIDE)rm -f $(VOFILES:.vo=.vos) 616 | $(HIDE)rm -f $(VOFILES:.vo=.vok) 617 | $(HIDE)rm -f $(BEAUTYFILES) $(VFILES:=.old) 618 | $(HIDE)rm -f all.ps all-gal.ps all.pdf all-gal.pdf all.glob all-mli.tex 619 | $(HIDE)rm -f $(VFILES:.v=.glob) 620 | $(HIDE)rm -f $(VFILES:.v=.tex) 621 | $(HIDE)rm -f $(VFILES:.v=.g.tex) 622 | $(HIDE)rm -f pretty-timed-success.ok 623 | $(HIDE)rm -rf html mlihtml 624 | .PHONY: clean 625 | 626 | cleanall:: clean 627 | @# Extension point 628 | $(SHOW)'CLEAN *.aux *.timing' 629 | $(HIDE)rm -f $(foreach f,$(VFILES:.v=),$(dir $(f)).$(notdir $(f)).aux) 630 | $(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) 631 | $(HIDE)rm -f $(VOFILES:.vo=.v.timing) 632 | $(HIDE)rm -f $(VOFILES:.vo=.v.before-timing) 633 | $(HIDE)rm -f $(VOFILES:.vo=.v.after-timing) 634 | $(HIDE)rm -f $(VOFILES:.vo=.v.timing.diff) 635 | $(HIDE)rm -f .lia.cache .nia.cache 636 | .PHONY: cleanall 637 | 638 | archclean:: 639 | @# Extension point 640 | $(SHOW)'CLEAN *.cmx *.o' 641 | $(HIDE)rm -f $(NATIVEFILES) 642 | $(HIDE)rm -f $(CMOFILES:%.cmo=%.cmx) 643 | .PHONY: archclean 644 | 645 | 646 | # Compilation rules ########################################################### 647 | 648 | $(MLIFILES:.mli=.cmi): %.cmi: %.mli 649 | $(SHOW)'CAMLC -c $<' 650 | $(HIDE)$(TIMER) $(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $< 651 | 652 | $(MLGFILES:.mlg=.ml): %.ml: %.mlg 653 | $(SHOW)'COQPP $<' 654 | $(HIDE)$(COQPP) $< 655 | 656 | # Stupid hack around a deficient syntax: we cannot concatenate two expansions 657 | $(filter %.cmo, $(MLFILES:.ml=.cmo) $(MLGFILES:.mlg=.cmo)): %.cmo: %.ml 658 | $(SHOW)'CAMLC -c $<' 659 | $(HIDE)$(TIMER) $(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $< 660 | 661 | # Same hack 662 | $(filter %.cmx, $(MLFILES:.ml=.cmx) $(MLGFILES:.mlg=.cmx)): %.cmx: %.ml 663 | $(SHOW)'CAMLOPT -c $(FOR_PACK) $<' 664 | $(HIDE)$(TIMER) $(CAMLOPTC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $(FOR_PACK) $< 665 | 666 | 667 | $(MLLIBFILES:.mllib=.cmxs): %.cmxs: %.cmxa 668 | $(SHOW)'CAMLOPT -shared -o $@' 669 | $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ 670 | -linkall -shared -o $@ $< 671 | 672 | $(MLLIBFILES:.mllib=.cma): %.cma: | %.mllib 673 | $(SHOW)'CAMLC -a -o $@' 674 | $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) -a -o $@ $^ 675 | 676 | $(MLLIBFILES:.mllib=.cmxa): %.cmxa: | %.mllib 677 | $(SHOW)'CAMLOPT -a -o $@' 678 | $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -a -o $@ $^ 679 | 680 | 681 | $(MLPACKFILES:.mlpack=.cmxs): %.cmxs: %.cmxa 682 | $(SHOW)'CAMLOPT -shared -o $@' 683 | $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ 684 | -shared -linkall -o $@ $< 685 | 686 | $(MLPACKFILES:.mlpack=.cmxa): %.cmxa: %.cmx 687 | $(SHOW)'CAMLOPT -a -o $@' 688 | $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -a -o $@ $< 689 | 690 | $(MLPACKFILES:.mlpack=.cma): %.cma: %.cmo | %.mlpack 691 | $(SHOW)'CAMLC -a -o $@' 692 | $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) -a -o $@ $^ 693 | 694 | $(MLPACKFILES:.mlpack=.cmo): %.cmo: | %.mlpack 695 | $(SHOW)'CAMLC -pack -o $@' 696 | $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) -pack -o $@ $^ 697 | 698 | $(MLPACKFILES:.mlpack=.cmx): %.cmx: | %.mlpack 699 | $(SHOW)'CAMLOPT -pack -o $@' 700 | $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -pack -o $@ $^ 701 | 702 | # This rule is for _CoqProject with no .mllib nor .mlpack 703 | $(filter-out $(MLLIBFILES:.mllib=.cmxs) $(MLPACKFILES:.mlpack=.cmxs) $(addsuffix .cmxs,$(PACKEDFILES)) $(addsuffix .cmxs,$(LIBEDFILES)),$(MLFILES:.ml=.cmxs) $(MLGFILES:.mlg=.cmxs)): %.cmxs: %.cmx 704 | $(SHOW)'[deprecated,use-mllib-or-mlpack] CAMLOPT -shared -o $@' 705 | $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ 706 | -shared -o $@ $< 707 | 708 | ifneq (,$(TIMING)) 709 | TIMING_EXTRA = > $<.$(TIMING_EXT) 710 | else 711 | TIMING_EXTRA = 712 | endif 713 | 714 | $(VOFILES): %.vo: %.v 715 | $(SHOW)COQC $< 716 | $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(TIMING_ARG) $(COQFLAGS) $(COQLIBS) $< $(TIMING_EXTRA) 717 | 718 | # FIXME ?merge with .vo / .vio ? 719 | $(GLOBFILES): %.glob: %.v 720 | $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< 721 | 722 | $(VFILES:.v=.vio): %.vio: %.v 723 | $(SHOW)COQC -vio $< 724 | $(HIDE)$(TIMER) $(COQC) -vio $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< 725 | 726 | $(VFILES:.v=.vos): %.vos: %.v 727 | $(SHOW)COQC -vos $< 728 | $(HIDE)$(TIMER) $(COQC) -vos $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< 729 | 730 | $(VFILES:.v=.vok): %.vok: %.v 731 | $(SHOW)COQC -vok $< 732 | $(HIDE)$(TIMER) $(COQC) -vok $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< 733 | 734 | $(addsuffix .timing.diff,$(VFILES)): %.timing.diff : %.before-timing %.after-timing 735 | $(SHOW)PYTHON TIMING-DIFF $*.{before,after}-timing 736 | $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" print-pretty-single-time-diff BEFORE=$*.before-timing AFTER=$*.after-timing TIME_OF_PRETTY_BUILD_FILE="$@" 737 | 738 | $(BEAUTYFILES): %.v.beautified: %.v 739 | $(SHOW)'BEAUTIFY $<' 740 | $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) -beautify $< 741 | 742 | $(TEXFILES): %.tex: %.v 743 | $(SHOW)'COQDOC -latex $<' 744 | $(HIDE)$(COQDOC) $(COQDOCFLAGS) -latex $< -o $@ 745 | 746 | $(GTEXFILES): %.g.tex: %.v 747 | $(SHOW)'COQDOC -latex -g $<' 748 | $(HIDE)$(COQDOC) $(COQDOCFLAGS) -latex -g $< -o $@ 749 | 750 | $(HTMLFILES): %.html: %.v %.glob 751 | $(SHOW)'COQDOC -html $<' 752 | $(HIDE)$(COQDOC) $(COQDOCFLAGS) -html $< -o $@ 753 | 754 | $(GHTMLFILES): %.g.html: %.v %.glob 755 | $(SHOW)'COQDOC -html -g $<' 756 | $(HIDE)$(COQDOC) $(COQDOCFLAGS) -html -g $< -o $@ 757 | 758 | # Dependency files ############################################################ 759 | 760 | ifndef MAKECMDGOALS 761 | -include $(ALLDFILES) 762 | else 763 | 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)),) 764 | -include $(ALLDFILES) 765 | endif 766 | endif 767 | 768 | .SECONDARY: $(ALLDFILES) 769 | 770 | redir_if_ok = > "$@" || ( RV=$$?; rm -f "$@"; exit $$RV ) 771 | 772 | GENMLFILES:=$(MLGFILES:.mlg=.ml) 773 | $(addsuffix .d,$(ALLSRCFILES)): $(GENMLFILES) 774 | 775 | $(addsuffix .d,$(MLIFILES)): %.mli.d: %.mli 776 | $(SHOW)'CAMLDEP $<' 777 | $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) 778 | 779 | $(addsuffix .d,$(MLGFILES)): %.mlg.d: %.ml 780 | $(SHOW)'CAMLDEP $<' 781 | $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) 782 | 783 | $(addsuffix .d,$(MLFILES)): %.ml.d: %.ml 784 | $(SHOW)'CAMLDEP $<' 785 | $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) 786 | 787 | $(addsuffix .d,$(MLLIBFILES)): %.mllib.d: %.mllib 788 | $(SHOW)'OCAMLLIBDEP $<' 789 | $(HIDE)$(OCAMLLIBDEP) -c $(OCAMLLIBS) "$<" $(redir_if_ok) 790 | 791 | $(addsuffix .d,$(MLPACKFILES)): %.mlpack.d: %.mlpack 792 | $(SHOW)'OCAMLLIBDEP $<' 793 | $(HIDE)$(OCAMLLIBDEP) -c $(OCAMLLIBS) "$<" $(redir_if_ok) 794 | 795 | # If this makefile is created using a _CoqProject we have coqdep get 796 | # options from it. This avoids argument length limits for pathological 797 | # projects. Note that extra options might be on the command line. 798 | VDFILE_FLAGS:=$(if _CoqProject,-f _CoqProject,) $(CMDLINE_COQLIBS) $(CMDLINE_VFILES) 799 | 800 | $(VDFILE): $(VFILES) 801 | $(SHOW)'COQDEP VFILES' 802 | $(HIDE)$(COQDEP) -vos -dyndep var $(VDFILE_FLAGS) $(redir_if_ok) 803 | 804 | # Misc ######################################################################## 805 | 806 | byte: 807 | $(HIDE)$(MAKE) all "OPT:=-byte" -f "$(SELF)" 808 | .PHONY: byte 809 | 810 | opt: 811 | $(HIDE)$(MAKE) all "OPT:=-opt" -f "$(SELF)" 812 | .PHONY: opt 813 | 814 | # This is deprecated. To extend this makefile use 815 | # extension points and Makefile.local 816 | printenv:: 817 | $(warning printenv is deprecated) 818 | $(warning write extensions in Makefile.local or include Makefile.conf) 819 | @echo 'LOCAL = $(LOCAL)' 820 | @echo 'COQLIB = $(COQLIB)' 821 | @echo 'DOCDIR = $(DOCDIR)' 822 | @echo 'OCAMLFIND = $(OCAMLFIND)' 823 | @echo 'HASNATDYNLINK = $(HASNATDYNLINK)' 824 | @echo 'SRC_SUBDIRS = $(SRC_SUBDIRS)' 825 | @echo 'COQ_SRC_SUBDIRS = $(COQ_SRC_SUBDIRS)' 826 | @echo 'OCAMLFIND = $(OCAMLFIND)' 827 | @echo 'PP = $(PP)' 828 | @echo 'COQFLAGS = $(COQFLAGS)' 829 | @echo 'COQLIB = $(COQLIBS)' 830 | @echo 'COQLIBINSTALL = $(COQLIBINSTALL)' 831 | @echo 'COQDOCINSTALL = $(COQDOCINSTALL)' 832 | .PHONY: printenv 833 | 834 | # Generate a .merlin file. If you need to append directives to this 835 | # file you can extend the merlin-hook target in Makefile.local 836 | .merlin: 837 | $(SHOW)'FILL .merlin' 838 | $(HIDE)echo 'FLG $(COQMF_CAMLFLAGS)' > .merlin 839 | $(HIDE)echo 'B $(COQLIB)' >> .merlin 840 | $(HIDE)echo 'S $(COQLIB)' >> .merlin 841 | $(HIDE)$(foreach d,$(COQ_SRC_SUBDIRS), \ 842 | echo 'B $(COQLIB)$(d)' >> .merlin;) 843 | $(HIDE)$(foreach d,$(COQ_SRC_SUBDIRS), \ 844 | echo 'S $(COQLIB)$(d)' >> .merlin;) 845 | $(HIDE)$(foreach d,$(SRC_SUBDIRS), echo 'B $(d)' >> .merlin;) 846 | $(HIDE)$(foreach d,$(SRC_SUBDIRS), echo 'S $(d)' >> .merlin;) 847 | $(HIDE)$(MAKE) merlin-hook -f "$(SELF)" 848 | .PHONY: merlin 849 | 850 | merlin-hook:: 851 | @# Extension point 852 | .PHONY: merlin-hook 853 | 854 | # prints all variables 855 | debug: 856 | $(foreach v,\ 857 | $(sort $(filter-out $(INITIAL_VARS) INITIAL_VARS,\ 858 | $(.VARIABLES))),\ 859 | $(info $(v) = $($(v)))) 860 | .PHONY: debug 861 | 862 | .DEFAULT_GOAL := all 863 | 864 | # Local Variables: 865 | # mode: makefile-gmake 866 | # End: 867 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | mindless-coding, phase 2 3 | ======================== 4 | 5 | Please refer to https://github.com/jonleivent/mindless-coding for phase 1 of 6 | this project. 7 | 8 | Phase 2 will concentrate more on the tactic infrastructure and proof 9 | techniques, in an attempt to make them easier to use (phase 1 was a hodgepodge 10 | of many different techniques without much clarity - mostly just a proof of 11 | concept). 12 | 13 | This site uses Coq version 8.6. The exact file coq-version-used will be 14 | updated with the output of coqtop --version, and the file coq-githash-used 15 | will be updated with the git hash (as reported by coqtop -batch for 16 | development versions) for the exact Coq build used. However, all attempts 17 | will be made to keep compatibility with the released 8.6 version. 18 | 19 | First up: a rewrite of gaptrees, renamed to wavltrees, and made to correspond 20 | more closely with the work on weak-AVL trees at Princeton as reported in 21 | http://www.cs.princeton.edu/~sssix/papers/rb-trees-talg.pdf. Those familiar 22 | with phase 1 of this project will recall that weak-AVL trees (gaptrees) were 23 | "discovered" by accident there, but the Princeton group has claim to finding 24 | them first. 25 | 26 | ------------------------------------------------------------------------ 27 | 28 | Dependent Type-Directed Development (a.k.a "Mindless Coding"). 29 | 30 | The point of this exercise is best seen by comparing the Coq sources wavl.v 31 | and wavl-noninter.v to their respective extracted OCaml output files wavl.ml 32 | and wavl-nointer.ml. 33 | 34 | First, the reason I have provided both wavl.v and wavl-noninter.v is that the 35 | latter is perhaps more "programmer-friendly" to many, especially those 36 | unfamiliar with Coq's interactive proof mode. Note that they both generate 37 | nearly identical OCaml code (compare wavl.ml to wavl-noninter.ml, and note 38 | that virtually all differences between them involve just variable renamings). 39 | Even though I am a software developer, and certainly not a type theorist, I 40 | have come to favor use of Coq's interactive proof mode for its ability to 41 | guide one to a solution - providing: Interactive Dependent Type-Directed 42 | Development. 43 | 44 | Back to the main result: Note how the main wavltree functions (find, rot1, 45 | rot2, insert, drot1, drot2, delmin, delmax and delete) in the primary input 46 | files (wavl.v and wavl-noninter.v) closely follow the generated OCaml code 47 | (wavl.ml and wavl-noninter.ml). But, note the important difference: although 48 | the control flows in the functions are apparent in the .v files, the function 49 | "leaves" (the terms returned at the end of each control path) are all filled 50 | in using Coq's proof search via tactics. This is only possible due to the 51 | very dependent nature of the function specifications (argument and return 52 | types), as well as the very dependent nature of the data structure (wavltree) 53 | itself. As a result, the functions in the primary .v files are far easier to 54 | "code" (the distinction between proving and coding disappears) than they would 55 | be if the user was coding directly in the output language (OCaml), as well as 56 | being guaranteed (modulo Coq's trustworthiness, as well as that of the 57 | invariants specified in the dependent types) to be correct, as well as being 58 | generated (in the .ml files) completely unburdened by proof-required parts. 59 | 60 | ------------------------------------------------------------------------ 61 | 62 | What are the underlying contributions enabling this result?: 63 | 64 | * True Erasability. 65 | 66 | I wish Coq had this built in, but it doesn't (Idris does, but Idris was 67 | still not quite mature enough to handle the other complexity of this project 68 | last I checked; Agda doesn't have true erasability, but can handle the other 69 | complexity). Instead, Coq's erasure of Props and some type args has to be 70 | enhanced via. erasable.v. However, when this is done (with sufficient care 71 | so as not to become inconsistent), the OCaml output code is as good as one 72 | would expect from an expert developer, and is completely free of all 73 | required-only-for-proving elements. Claiming this as a "contribution" is 74 | perhaps claiming too much, as this kind of erasability has been suggested 75 | before. However, this project attempts to demonstrate how important a 76 | feature this is (or would be). 77 | 78 | As the erasability feature is implemented here (Coq Props + erasable.v), one 79 | important detail for nay-sayers to notice is that the impact on the Coq 80 | source files wavl.v and wavl-noninter.v is very minor. While it is true 81 | that certain types need to be mirrored as erasable types (EZ for Z, EB for 82 | bool, EL for list A), as well as certain functions, the definitions are 83 | trivial. 84 | 85 | Another important detail is that implementations of erasability similar to 86 | this one (as opposed to Coq's "Extraction Implicit" mechanism, for example) 87 | prevents automated proof search, as well as the programmer, from 88 | accidentally using elements marked for erasure in a way that prevents their 89 | eventual erasure. 90 | 91 | * Specialized (semi)decision procedures for types used in specifications. 92 | 93 | The files sorted.v and solvesorted.v provide a (semi)decision procedure 94 | (semi only because I haven't determined it is complete, but it has held up 95 | under considerable stress) for sorted lists of arbitrary elements. The 96 | Examples at the end of solvesorted.v demonstrate some of what this decision 97 | procedure can decide. 98 | 99 | The file ezbool.v provides a (semi)decision procedure (or, rather enhances 100 | the already existent ones omega and ring) for bools and integers (Z). The 101 | enhancements enable multi-goal solution using Coq's (new to version 8.5) 102 | backtracking proof search capabilities, including techniques for the 103 | solution of subgoals sharing existential variables (evars). I believe this 104 | may be one of the first Coq developments to exploit backtracking in this 105 | way. 106 | 107 | As a result, it becomes very easy to write small specialized proof-search 108 | tactics (solve_find, solve_wavl, solve_insert, etc.) for each function, and 109 | use them in a predictable and consistent way to remove the burden of 110 | algorithm implementation - even in cases where one does not know the 111 | algorithm, nor even know if an algorithm exists (as was the case with 112 | wavltrees/gaptrees). 113 | 114 | The important point to these (semi)decision procedures is that they are 115 | generic - nothing about them restricts their usage to wavltrees, or to just 116 | binary trees, etc. They are developed once, and should be usable by a large 117 | variety of dependent-type driven developments (although they may not be 118 | sufficiently complete yet). 119 | 120 | 121 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -R . mindless 2 | -arg -impredicative-set 3 | utils.v 4 | hypiter.v 5 | factorevars.v 6 | ordered.v 7 | erasable.v 8 | solvesorted.v 9 | elist.v 10 | ezbool.v 11 | -------------------------------------------------------------------------------- /coq-githash-used: -------------------------------------------------------------------------------- 1 | 22b5623d56444e2a4d5747f4e4ae99697bc78f2d 2 | -------------------------------------------------------------------------------- /coq-version-used: -------------------------------------------------------------------------------- 1 | The Coq Proof Assistant, version 8.12.0 (July 2020) 2 | compiled on Jul 24 2020 22:04:52 with OCaml 4.05.0 3 | -------------------------------------------------------------------------------- /doit: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | coqtop --version > coq-version-used 4 | git hash-object `which coqtop` > coq-githash-used 5 | make clean 6 | make 7 | time coqtop -m -time -batch -R . mindless -impredicative-set -l wavl_noauto.v 8 | time coqtop -m -time -batch -R . mindless -impredicative-set -l wavl.v 9 | time coqtop -m -time -batch -R . mindless -impredicative-set -l wavl_noninter.v 10 | -------------------------------------------------------------------------------- /elist.v: -------------------------------------------------------------------------------- 1 | 2 | From Coq Require Export Lists.List. 3 | Require Export mindless.ordered. 4 | Require Export mindless.solvesorted. 5 | Require Export mindless.erasable. 6 | Export ErasableNotation. 7 | Export Notations. 8 | Require Import mindless.utils. 9 | 10 | Notation " [ ] " := nil (format "[ ]") : list_scope. 11 | Notation " [ x ] " := (cons x nil) : list_scope. 12 | 13 | Global Opaque NotIn. 14 | 15 | Section defs. 16 | Context {A : Set}. 17 | 18 | Definition Eapp := (lift2 (@app A)). 19 | 20 | Lemma Eapp_rw : 21 | forall (x y : list A), (Eapp #x #y) = #(app x y). 22 | Proof. 23 | unfold Eapp. 24 | unerase. 25 | tauto. 26 | Qed. 27 | 28 | Definition ENotIn(x : A) := liftP1 (NotIn x). 29 | 30 | Lemma ENotIn_rw : 31 | forall (a : A)(x : list A), ENotIn a #x <-> NotIn a x. 32 | Proof. 33 | unfold ENotIn. 34 | unerase. 35 | tauto. 36 | Qed. 37 | 38 | Context {ordA : Ordered A}. 39 | 40 | Definition Esorted := (liftP1 sorted). 41 | 42 | Lemma Esorted_rw : 43 | forall (x : list A), Esorted #x <-> sorted x. 44 | Proof. 45 | unfold Esorted. 46 | unerase. 47 | tauto. 48 | Qed. 49 | 50 | End defs. 51 | 52 | (*Global Opaque Eapp ENotIn.*) 53 | Hint Unfold Eapp ENotIn Esorted : lift_unfolds. 54 | 55 | Hint Rewrite @Esorted_rw @ENotIn_rw @Eapp_rw : unerase_rws. 56 | 57 | Lemma lnenil : forall {A}(d : A)(lf rf : list A), (lf++d::rf)%list <> nil. 58 | Proof. 59 | dintros. 60 | intro H. 61 | eapply app_eq_nil in H as [? ?]. 62 | discriminate. 63 | Qed. 64 | 65 | Lemma lnenilrw : forall {A}(d : A)(lf rf : list A), ((lf++d::rf)%list = nil) <-> False. 66 | Proof. 67 | dintros. 68 | split. 69 | - intro. 70 | eapply lnenil. 71 | eassumption. 72 | - contradiction. 73 | Qed. 74 | 75 | Lemma red_app : forall {A}(a : A)(l : list A), ([a]++l)%list = (a::l)%list. 76 | Proof. 77 | cbn. 78 | reflexivity. 79 | Qed. 80 | 81 | Hint Rewrite @red_app @lnenilrw : bang_rws. 82 | 83 | (* Some nice syntax for erasable lists. Note the use of ^x instead 84 | of [x] - because for some reason [x] wouldn't work in all cases. *) 85 | Declare Scope E_scope. 86 | Infix "++" := Eapp (right associativity, at level 60) : E_scope. 87 | Notation " [ ] " := (# nil) : E_scope. 88 | Notation " [ x ] " := (# (cons x nil)) : E_scope. 89 | Bind Scope E_scope with Erasable. 90 | Bind Scope list_scope with list. 91 | Open Scope E_scope. 92 | 93 | Section EL_lemmas. 94 | Context {A : Set}. 95 | 96 | Notation EL := (## (list A)). 97 | 98 | Lemma Eapp_assoc: forall {p q r : EL}, (p++q)++r = p++(q++r). 99 | Proof. 100 | intros. 101 | unerase. 102 | rewrite <- app_assoc. 103 | reflexivity. 104 | Qed. 105 | 106 | Lemma group3Eapp: forall (p q r s : EL), p++q++r++s = (p++q++r)++s. 107 | Proof. 108 | intros. 109 | rewrite ?Eapp_assoc. 110 | reflexivity. 111 | Qed. 112 | 113 | Lemma Eapp_nil_l : forall (l : EL), []++l = l. 114 | Proof. 115 | unerase. 116 | reflexivity. 117 | Qed. 118 | 119 | Lemma Eapp_nil_r : forall (l : EL), l++[] = l. 120 | Proof. 121 | unerase. 122 | intros. 123 | rewrite app_nil_r. 124 | reflexivity. 125 | Qed. 126 | 127 | Lemma fnenil1 : forall (d : A), [d] <> []. 128 | Proof. 129 | unerase. 130 | discriminate. 131 | Qed. 132 | 133 | Lemma fnenil2 : forall (d : A)(rf : EL), [d]++rf <> []. 134 | Proof. 135 | unerase. 136 | intro H. 137 | discriminate. 138 | Qed. 139 | 140 | Lemma fnenilright : forall (lf rf : EL), rf <> [] -> lf++rf <> []. 141 | Proof. 142 | unerase. 143 | intro H'. 144 | eapply app_eq_nil in H'. 145 | intuition discriminate. 146 | Qed. 147 | 148 | Lemma fnenilrw : forall (d : A)(lf rf : EL), lf++[d]++rf = [] <-> False. 149 | Proof. 150 | dintros. 151 | unerase. 152 | cbn. 153 | rewrite lnenilrw. 154 | tauto. 155 | Qed. 156 | 157 | End EL_lemmas. 158 | 159 | Ltac reassociate_step := 160 | lazymatch goal with 161 | |- context [?X ++ ?Y] => 162 | let V:=fresh in 163 | set (V:=X++Y); 164 | let H:=fresh in 165 | lazymatch get_value V with 166 | ?A ++ ?B ++ ?C => 167 | assert (((A++B)++C) = V) as H by apply Eapp_assoc; 168 | clearbody V 169 | end; 170 | lazymatch type of H with 171 | ?A ++ ?B = V => 172 | let V':=fresh in 173 | set (V':=A) in H; 174 | let H':=fresh in 175 | assert (V'=A) as H' by reflexivity; 176 | rewrite ?Eapp_assoc in H'; 177 | clearbody V'; 178 | subst V' 179 | end; 180 | subst V 181 | end. 182 | 183 | Ltac reassoc := 184 | rewrite ?Eapp_assoc; 185 | let rec f := idtac + (reassociate_step; f) in f. 186 | 187 | Tactic Notation "assoc" integer(n) := 188 | rewrite ?Eapp_assoc; 189 | do n reassociate_step. 190 | 191 | Ltac rootify d := 192 | reassoc; 193 | (lazymatch goal with 194 | |- context [?X ++ ?Y] => 195 | lazymatch constr:(X ++ Y) with 196 | _ ++ [d] ++ _ => idtac 197 | end 198 | end). 199 | 200 | Ltac fnenil := 201 | let rec f := (idtac + (apply fnenilright; f)) in 202 | let rec g := rewrite ?Eapp_assoc; f; solve [apply fnenil2 | apply fnenil1] in 203 | match goal with 204 | | |- ([] = [])%type => reflexivity 205 | | H : ([] <> [])%type |- _ => contradict H; reflexivity 206 | | |- (_ <> [])%type => g 207 | | |- ([] <> _)%type => apply not_eq_sym; g 208 | | H : (_ = [])%type |- _ => contradict H; g 209 | | H : ([] = _)%type |- _ => symmetry in H; contradict H; g 210 | end. 211 | -------------------------------------------------------------------------------- /erasable.v: -------------------------------------------------------------------------------- 1 | 2 | Require Import mindless.hypiter. 3 | Require Import mindless.factorevars. 4 | 5 | Global Set Keep Proof Equalities. 6 | 7 | Inductive Erasable(A : Set) : Prop := 8 | erasable: A -> Erasable A. 9 | 10 | Arguments erasable [A] _. 11 | 12 | Hint Constructors Erasable : core. 13 | 14 | Scheme Erasable_elim := Induction for Erasable Sort Prop. 15 | 16 | Module ErasableNotation. 17 | Declare Scope Erasable_scope. 18 | Notation "## T" := (Erasable T) (at level 1, format "## T") : Erasable_scope. 19 | Notation "# x" := (erasable x) (at level 1, format "# x") : Erasable_scope. 20 | Open Scope Erasable_scope. 21 | End ErasableNotation. 22 | 23 | Import ErasableNotation. 24 | 25 | (*This Erasable_inj axiom is the key enabler of erasability beyond 26 | what Prop already provides. Note that it can't be mixed with 27 | proof irrelevance.*) 28 | Axiom Erasable_inj : forall {A : Set}{a b : A}, #a=#b -> a=b. 29 | 30 | Require Setoid. (*needed for Erasable_rw users*) 31 | 32 | Lemma Erasable_rw : forall (A: Set)(a b : A), (#a=#b) <-> (a=b). 33 | Proof. 34 | intros A a b. 35 | split. 36 | - apply Erasable_inj. 37 | - congruence. 38 | Qed. 39 | 40 | Create HintDb unerase_rws discriminated. 41 | Hint Rewrite Erasable_rw : unerase_rws. 42 | 43 | Create HintDb unerase_unfolds discriminated. 44 | Create HintDb lift_unfolds discriminated. 45 | 46 | Ltac unerase_hyp H := 47 | autounfold with unerase_unfolds in H; 48 | autorewrite with unerase_rws in H; 49 | tryif has_value H 50 | then 51 | let V:=get_value H in 52 | let R:=fresh in 53 | let E:=fresh in 54 | remember V as R eqn:E; 55 | autorewrite with unerase_rws in E; 56 | lazymatch type of H with 57 | | ## _ => 58 | destruct R as [R]; 59 | rewrite Erasable_rw in E; 60 | let H':=fresh in 61 | set (H':=R) in H; 62 | unfold H in *; 63 | clear H; 64 | rename H' into H 65 | | _ => idtac 66 | end; 67 | subst R 68 | else 69 | lazymatch type of H with 70 | | ## _ => 71 | let H':=fresh H in 72 | destruct H as [H']; 73 | clear H; 74 | rename H' into H 75 | | # _ = # _ => apply Erasable_inj in H as ? 76 | | _ => idtac 77 | end. 78 | 79 | Tactic Notation "unerase" constr(H) := unerase_hyp H. 80 | 81 | Ltac try_unerase_hyp H := try (unerase_hyp H). 82 | 83 | Ltac unerase_hyps := allhyps_introing try_unerase_hyp. 84 | 85 | Ltac check_in_prop := 86 | lazymatch goal with 87 | |- ?G => 88 | let U:=type of G in 89 | first [constr_eq U Prop 90 | |fail 1 "check_in_prop:" G "is not a Prop"] 91 | end. 92 | 93 | Ltac unerase_internal' := 94 | autounfold with unerase_unfolds; 95 | unerase_hyps; 96 | autorewrite with unerase_rws; 97 | try apply erasable. 98 | 99 | Create HintDb lift_rws discriminated. 100 | 101 | Hint Rewrite -> Erasable_rw : lift_rws. 102 | 103 | Ltac unerase_do_rws := 104 | idtac; 105 | autorewrite with lift_rws in *. 106 | 107 | Local Ltac solve_erasable_exists := 108 | intros T x P; 109 | split; 110 | [ intros (y & H1 & H2); 111 | first[apply Erasable_inj in H1|apply Erasable_inj in H2]; 112 | subst; 113 | assumption 114 | | intro H; 115 | exists x; 116 | tauto]. 117 | 118 | Lemma Erasable_exists_rw1 : 119 | forall (T : Set) (x : T) (P : T -> Prop), (exists (y : T), #y = #x /\ P y) <-> P x. 120 | Proof. solve_erasable_exists. Qed. 121 | 122 | Lemma Erasable_exists_rw2 : 123 | forall (T : Set) (x : T) (P : T -> Prop), (exists (y : T), #x = #y /\ P y) <-> P x. 124 | Proof. solve_erasable_exists. Qed. 125 | 126 | Lemma Erasable_exists_rw3 : 127 | forall (T : Set) (x : T) (P : T -> Prop), (exists (y : T), P y /\ #y = #x) <-> P x. 128 | Proof. solve_erasable_exists. Qed. 129 | 130 | Lemma Erasable_exists_rw4 : 131 | forall (T : Set) (x : T) (P : T -> Prop), (exists (y : T), P y /\ #x = #y) <-> P x. 132 | Proof. solve_erasable_exists. Qed. 133 | 134 | (* Hint Rewrite Erasable_exists_rw1 Erasable_exists_rw2 Erasable_exists_rw3 Erasable_exists_rw4 : unerase_rws. *) 135 | 136 | (* Erasable+Prop is a monad, and appE is application within that monad 137 | of lifted functions. But, the result would then need the "f $ x $ y" 138 | syntax, and would also make operators ugly... *) 139 | Definition appE{T1 T2 : Set}(f : ##(T1 -> T2))(x : ## T1) : ## T2. 140 | Proof. 141 | destruct f as [f]. 142 | destruct x as [x]. 143 | constructor. 144 | exact (f x). 145 | Defined. 146 | 147 | (*Infix "$" := appE (left associativity, at level 98) : E_scope.*) 148 | 149 | (* ... So, instead of lifting functions with # alone, we use lifters 150 | that leave the normal application syntax intact. This means we need 151 | to do a little more work to lift, but end up with a much more readable 152 | result. *) 153 | 154 | Definition lift1{A B : Set}(f : A -> B)(a : ##A) : ##B := 155 | match a with 156 | | erasable a => # (f a) 157 | end. 158 | 159 | Lemma liftrw1: forall {A B : Set}{f : A -> B}{a : A}, (lift1 f) # a = # (f a). 160 | Proof. 161 | intros. reflexivity. 162 | Qed. 163 | 164 | Definition lift2{A B C : Set}(f : A -> B -> C)(a : ##A)(b : ##B) : ##C := 165 | match a, b with 166 | | erasable a, erasable b => # (f a b) 167 | end. 168 | 169 | Lemma liftrw2: forall{A B C : Set}{f : A -> B -> C}{a : A}{b : B}, 170 | (lift2 f) # a # b = # (f a b). 171 | Proof. 172 | intros. reflexivity. 173 | Qed. 174 | 175 | (* For Props, instead of a normal lifting of the entire signature, 176 | which would result in ##Prop type instead of a more usable Prop type, 177 | the Prop is wrapped in an existential to accept the erasable arg. *) 178 | Definition liftP1{A : Set}(p : A -> Prop)(ea : ##A) : Prop := 179 | exists (a : A), #a=ea /\ p a. 180 | 181 | Lemma liftrwP1 : forall {A : Set}{p : A -> Prop}{a : A}, 182 | (liftP1 p) # a <-> p a. 183 | Proof. 184 | intros ? ? a. unfold liftP1. split. 185 | - intros (? & ->%Erasable_inj & H). exact H. 186 | - intro H. exists a. tauto. 187 | Qed. 188 | 189 | Hint Rewrite @liftrwP1 : lift_rws. 190 | 191 | Definition liftP2{A B : Set}(p : A -> B -> Prop)(ea : ##A)(eb : ##B) : Prop := 192 | exists (a : A), #a=ea /\ exists (b : B), #b=eb /\ p a b. 193 | 194 | Lemma liftrwP2: forall{A B : Set}{p : A -> B -> Prop}{ea : A}{eb : B}, 195 | (liftP2 p) #ea #eb <-> p ea eb. 196 | Proof. 197 | intros. unfold liftP2. split. 198 | - intros (a & Ea & b & Eb & H). apply ->Erasable_rw in Ea. apply ->Erasable_rw in Eb. 199 | subst. exact H. 200 | - intro H. exists ea. split; [reflexivity|]. exists eb. tauto. 201 | Qed. 202 | 203 | Hint Rewrite @liftrwP2 : lift_rws. 204 | 205 | Hint Unfold lift1 lift2 liftP1 liftP2 : unerase_unfolds. 206 | 207 | 208 | 209 | Module Unerase_Reflect. 210 | 211 | Inductive expr := 212 | | And : expr -> expr -> expr 213 | | Or : expr -> expr -> expr 214 | | Not : expr -> expr 215 | | Imp : expr -> expr -> expr 216 | | Bim : expr -> expr -> expr 217 | | Eq{t:Set}(i j:t) : expr 218 | | Neq{t:Set}(i j:t) : expr 219 | | L1{t:Set}(p:t->Prop)(i:t) : expr 220 | | L2{t1 t2:Set}(p:t1->t2->Prop)(i:t1)(j:t2) : expr 221 | | Skip : Prop -> expr. 222 | 223 | Fixpoint denote (e:expr) : Prop := 224 | match e with 225 | | And e1 e2 => (denote e1) /\ (denote e2) 226 | | Or e1 e2 => (denote e1) \/ (denote e2) 227 | | Not e => ~ (denote e) 228 | | Imp e1 e2 => (denote e1) -> (denote e2) 229 | | Bim e1 e2 => (denote e1) <-> (denote e2) 230 | | Eq i j => (# i) = (# j) 231 | | Neq i j => (# i) <> (# j) 232 | | L1 p i => (liftP1 p) # i 233 | | L2 p i j => (liftP2 p) # i # j 234 | | Skip p => p 235 | end. 236 | 237 | Ltac reify cont e := 238 | lazymatch e with 239 | | ?e1 /\ ?e2 => reify ltac:(fun d1 => reify ltac:(fun d2 => cont uconstr:(And d1 d2)) e2) e1 240 | | ?e1 \/ ?e2 => reify ltac:(fun d1 => reify ltac:(fun d2 => cont uconstr:(Or d1 d2)) e2) e1 241 | | ~ ?e => reify ltac:(fun d => cont uconstr:(Not d)) e 242 | | ?e1 -> ?e2 => reify ltac:(fun d1 => reify ltac:(fun d2 => cont uconstr:(Imp d1 d2)) e2) e1 243 | | ?e1 <-> ?e2 => reify ltac:(fun d1 => reify ltac:(fun d2 => cont uconstr:(Bim d1 d2)) e2) e1 244 | | # ?e1 = # ?e2 => cont uconstr:(Eq e1 e2) 245 | | # ?e1 <> # ?e2 => cont uconstr:(Neq e1 e2) 246 | | (liftP1 ?p) # ?i => cont uconstr:(L1 p i) 247 | | (liftP2 ?p) # ?i # ?j => cont uconstr:(L2 p i j) 248 | | _ => cont uconstr:(Skip e) 249 | end. 250 | 251 | Fixpoint reflect (e:expr) : Prop := 252 | match e with 253 | | And e1 e2 => (reflect e1) /\ (reflect e2) 254 | | Or e1 e2 => (reflect e1) \/ (reflect e2) 255 | | Not e => ~ reflect e 256 | | Imp e1 e2 => (reflect e1) -> (reflect e2) 257 | | Bim e1 e2 => (reflect e1) <-> (reflect e2) 258 | | Eq i j => i = j 259 | | Neq i j => i <> j 260 | | L1 p i => p i 261 | | L2 p i j => p i j 262 | | Skip p => p 263 | end. 264 | 265 | Theorem soundness: forall e, reflect e <-> denote e. 266 | Proof. 267 | intro e. induction e; cbn; autorewrite with lift_rws; tauto. 268 | Qed. 269 | 270 | Lemma do_reflection: forall e, reflect e -> denote e. 271 | Proof. 272 | apply soundness. 273 | Qed. 274 | 275 | Ltac destruct_erased := 276 | idtac; 277 | repeat match goal with 278 | | H : ## _ |- _ => 279 | first [destruct H as [H] 280 | |let x:=fresh in destruct H as [x]; clear H; rename x into H] 281 | end. 282 | 283 | Ltac doit := 284 | destruct_erased; cbn in *; autounfold with lift_unfolds in *; 285 | let refun e := (apply (do_reflection e)) in 286 | let rec rev := 287 | match goal with 288 | | H : ?T |- _ => let x:=constr:(T:Prop) in (revert H; rev; intro H) 289 | | |- ?G => reify refun G; cbn [reflect] 290 | end 291 | in rev; subst. 292 | 293 | End Unerase_Reflect. 294 | 295 | Ltac unerase_internal := 296 | repeat lazymatch goal with 297 | | H : ## _ |- _ => 298 | first [destruct H as [H] 299 | |let x:=fresh in destruct H as [x]; clear H; rename x into H] 300 | end; 301 | cbn in *; 302 | autounfold with lift_unfolds in *; 303 | unerase_do_rws; 304 | subst. 305 | 306 | Tactic Notation "unerase" := 307 | intros; 308 | tryif check_in_prop 309 | then Unerase_Reflect.doit (*unerase_internal*) 310 | else rewrite ?Erasable_rw in *. 311 | 312 | 313 | (*Lifting preserves well-foundedness - useful for well_founded_induction*) 314 | 315 | Require Import Coq.Init.Wf. 316 | 317 | Lemma Ewf : forall {A:Set}{R : A -> A -> Prop}, well_founded R -> well_founded (liftP2 R). 318 | Proof. 319 | intros A R wfR. unfold well_founded. intro b. destruct b as [b]. 320 | induction b as [b IHb] using (well_founded_induction wfR). 321 | apply Acc_intro. intros. unerase. apply IHb. assumption. 322 | Qed. 323 | 324 | Lemma Ewfof : forall {A B:Set}{R : A -> A -> Prop}(f : B -> A), 325 | well_founded R -> well_founded (fun x y => (liftP2 R) ((lift1 f) x) ((lift1 f) y)). 326 | Proof. 327 | intros A B R f wfR. unfold well_founded. intro b. unerase b. 328 | remember (f b) as fb eqn:E. revert b E. 329 | induction fb as [fb IHb] using (well_founded_induction wfR). intros b ->. 330 | apply Acc_intro. intros a Rfafb. unerase. eapply IHb. 331 | - eassumption. 332 | - reflexivity. 333 | Qed. 334 | 335 | (*Lifting preserves decidability*) 336 | 337 | Lemma Edec : forall {A:Set}, (forall (x y:A), {x = y} + {x <> y}) -> forall (x y:A), {#x = #y} + {#x <> #y}. 338 | Proof. 339 | intros A H x y. 340 | specialize (H x y). 341 | destruct H. 342 | - subst. tauto. 343 | - right. unerase. tauto. 344 | Qed. 345 | 346 | Lemma EPdec : forall {A:Set}, (forall (x y:A), x = y \/ x <> y) -> forall (x y:##A), x = y \/ x <> y. 347 | Proof. 348 | intros A H x y. 349 | unerase. 350 | apply H. 351 | Qed. 352 | 353 | Require Coq.Logic.Eqdep_dec. 354 | 355 | Lemma Eeq_proofs_unicity : forall {A:Set}, (forall x y:A, x = y \/ x <> y) -> forall (x y:##A) (p1 p2 : x = y), p1 = p2. 356 | Proof. 357 | intros A H. 358 | apply Eqdep_dec.eq_proofs_unicity. 359 | apply EPdec. 360 | exact H. 361 | Qed. 362 | 363 | -------------------------------------------------------------------------------- /ezbool.v: -------------------------------------------------------------------------------- 1 | 2 | Require Export mindless.erasable. 3 | Import ErasableNotation. 4 | Require Export Coq.ZArith.ZArith. 5 | Require Import mindless.utils. 6 | Require Import mindless.factorevars. 7 | Require Import mindless.hypiter. 8 | Require Import Coq.micromega.Lia. 9 | 10 | Notation EZ := ##Z (only parsing). 11 | 12 | Open Scope Z_scope. 13 | 14 | Arguments Z.add x y : simpl nomatch. 15 | Arguments Z.sub m n : simpl nomatch. 16 | Arguments Z.opp x : simpl nomatch. 17 | Arguments Z.mul x y : simpl nomatch. 18 | 19 | Definition ezadd(x y : EZ) := (lift2 Z.add) x y. 20 | Arguments ezadd !x !y. 21 | Definition ezsub(x y : EZ) := (lift2 Z.sub) x y. 22 | Arguments ezsub !x !y. 23 | Definition ezopp(x : EZ) := (lift1 Z.opp) x. 24 | Arguments ezopp !x. 25 | Definition ezmul(x y : EZ) := (lift2 Z.mul) x y. 26 | Arguments ezmul !x !y. 27 | 28 | Declare Scope E_scope. 29 | Notation "x + y" := (ezadd x y) : E_scope. 30 | Notation "x - y" := (ezsub x y) : E_scope. 31 | Notation "- x" := (ezopp x) : E_scope. 32 | Notation "x * y" := (ezmul x y) : E_scope. 33 | 34 | Notation "x < y" := ((liftP2 Z.lt) x y) : E_scope. 35 | Notation "x > y" := ((liftP2 Z.gt) x y) : E_scope. 36 | Notation "x <= y" := ((liftP2 Z.le) x y) : E_scope. 37 | Notation "x >= y" := ((liftP2 Z.ge) x y) : E_scope. 38 | 39 | Opaque Z.mul. 40 | 41 | Notation EB := ##bool (only parsing). 42 | 43 | Definition Enegb := lift1 negb. 44 | 45 | Definition b2Z(b : bool) : Z := if b then 1 else 0. 46 | Definition Eb2Z := lift1 b2Z. 47 | 48 | Hint Unfold ezadd ezsub ezopp ezmul Enegb Eb2Z : lift_unfolds. 49 | 50 | Notation "^ b" := (b2Z b) (at level 30, format "^ b") : Z_scope. 51 | Notation "^ b" := (Eb2Z b) (at level 30, format "^ b") : E_scope. 52 | 53 | Lemma b2Zbounds : forall b, ^b >= 0 /\ ^b <= 1. 54 | Proof. 55 | dintros. 56 | destruct b; cbn; lia. 57 | Qed. 58 | 59 | (* How should we classify rewrite rules? By their applicability - 60 | meaning by the type of formula in which they would have a chance of 61 | rewriting something. *) 62 | 63 | (*Set Default Proof Using "Type". 64 | Set Proof Using Clear Unused.*) 65 | 66 | Set Default Proof Using "Type". 67 | Set Suggest Proof Using. 68 | 69 | Section Bool_Rewrites. 70 | 71 | Variables b b1 b2 : bool. 72 | 73 | Tactic Notation "!!" := 74 | repeat destruct_goal_bool; cbn; intuition congruence. 75 | 76 | (*bool term rewrites*) 77 | Lemma negbf_rw : negb false = true. Proof. !!. Qed. 78 | Lemma negbt_rw : negb true = false. Proof. !!. Qed. 79 | Lemma dubnegb_rw : negb (negb b) = b. Proof. !!. Qed. 80 | 81 | (*bool equality rewrites*) 82 | Lemma teqt_rw : true = true <-> True. Proof. !!. Qed. 83 | Lemma feqf_rw : false = false <-> True. Proof. !!. Qed. 84 | Lemma teqf_rw : true = false <-> False. Proof. !!. Qed. 85 | Lemma feqt_rw : false = true <-> False. Proof. !!. Qed. 86 | Lemma bneq_rw : b1 <> b2 <-> b1 = negb b2. Proof. !!. Qed. 87 | Lemma negbfl_rw : negb b = false <-> b = true. Proof. !!. Qed. 88 | Lemma negbfr_rw : false = negb b <-> b = true. Proof. !!. Qed. 89 | Lemma negbtl_rw : negb b = true <-> b = false. Proof. !!. Qed. 90 | Lemma negbtr_rw : true = negb b <-> b = false. Proof. !!. Qed. 91 | Lemma negb_inj_rw : negb b1 = negb b2 <-> b1 = b2. Proof. !!. Qed. 92 | 93 | End Bool_Rewrites. 94 | 95 | Hint Rewrite 96 | negbf_rw negbt_rw dubnegb_rw 97 | : bool_term_rws simp_rws term_rws. 98 | 99 | Hint Rewrite 100 | teqt_rw feqf_rw teqf_rw feqt_rw bneq_rw negbfl_rw negbfr_rw negbtl_rw 101 | negbtr_rw negb_inj_rw 102 | : bool_eq_rws simp_rws eq_rws. 103 | 104 | Section EB_Rewrites. 105 | Variables b b1 b2 : EB. 106 | 107 | Tactic Notation "!!" := 108 | clear; unerase; cbn; autorewrite with bool_term_rws bool_eq_rws unerase_rws; tauto. 109 | 110 | (*EB term rewrites*) 111 | Lemma Enegbf_rw : Enegb #false = #true. Proof. !!. Qed. 112 | Lemma Enegbt_rw : Enegb #true = #false. Proof. !!. Qed. 113 | Lemma Edubnegb_rw : Enegb (Enegb b) = b. Proof. !!. Qed. 114 | 115 | (*EB equality rewrites*) 116 | Lemma Eteqt_rw : #true = #true <-> True. Proof. !!. Qed. 117 | Lemma Efeqf_rw : #false = #false <-> True. Proof. !!. Qed. 118 | Lemma Eteqf_rw : #true = #false <-> False. Proof. !!. Qed. 119 | Lemma Efeqt_rw : #false = #true <-> False. Proof. !!. Qed. 120 | Lemma Ebneq_rw : b1 <> b2 <-> b1 = Enegb b2. Proof. !!. Qed. 121 | Lemma Enegbfl_rw : Enegb b = #false <-> b = #true. Proof. !!. Qed. 122 | Lemma Enegbfr_rw : #false = Enegb b <-> b = #true. Proof. !!. Qed. 123 | Lemma Enegbtl_rw : Enegb b = #true <-> b = #false. Proof. !!. Qed. 124 | Lemma Enegbtr_rw : #true = Enegb b <-> b = #false. Proof. !!. Qed. 125 | Lemma Enegb_inj_rw : Enegb b1 = Enegb b2 <-> b1 = b2. Proof. !!. Qed. 126 | 127 | End EB_Rewrites. 128 | 129 | Hint Rewrite 130 | Enegbf_rw Enegbt_rw Edubnegb_rw 131 | : EB_term_rws simp_rws term_rws. 132 | 133 | Hint Rewrite 134 | Eteqt_rw Efeqf_rw Eteqf_rw Efeqt_rw Ebneq_rw Enegbfl_rw Enegbfr_rw 135 | Enegbtl_rw Enegbtr_rw Enegb_inj_rw 136 | : EB_eq_rws eq_rws. 137 | 138 | Section EZ_Desharping_Rewrites. 139 | Variables m n : Z. 140 | Variable b : bool. 141 | 142 | Tactic Notation "!!" := clear; cbn; reflexivity. 143 | Open Scope E_scope. 144 | Lemma eadd_desharp_rw : (#n + #m) = #(n + m)%Z. Proof. !!. Qed. 145 | Lemma esub_desharp_rw : (#n - #m) = #(n - m)%Z. Proof. !!. Qed. 146 | Lemma emul_desharp_rw : (#n * #m) = #(n * m)%Z. Proof. !!. Qed. 147 | Lemma eopp_desharp_rw : - #n = #(- n)%Z. Proof. !!. Qed. 148 | Lemma Enegb_desharp_rw : Enegb #b = #(negb b). Proof. !!. Qed. 149 | Lemma Eb2Z_desharp_rw : ^#b = #(^b)%Z. Proof. !!. Qed. 150 | 151 | End EZ_Desharping_Rewrites. 152 | 153 | Hint Rewrite 154 | eadd_desharp_rw esub_desharp_rw emul_desharp_rw eopp_desharp_rw 155 | Enegb_desharp_rw Eb2Z_desharp_rw 156 | : desharping_rws unerase_rws. 157 | 158 | Hint Rewrite <- 159 | eadd_desharp_rw esub_desharp_rw emul_desharp_rw eopp_desharp_rw 160 | Enegb_desharp_rw Eb2Z_desharp_rw 161 | : ensharping_rws simp_rws. 162 | 163 | Section B2Z_Rewrites. 164 | Variable b b1 b2 : bool. 165 | 166 | Tactic Notation "!!" := 167 | repeat destruct_goal_bool; cbn; intuition congruence. 168 | 169 | (*b2Z term rewrites*) 170 | Lemma b2Zt_rw : ^true = 1. Proof. !!. Qed. 171 | Lemma b2Zf_rw : ^false = 0. Proof. !!. Qed. 172 | Lemma b2Z_negb_rw : ^(negb b) = 1 - ^b. Proof. !!. Qed. 173 | 174 | (*b2Z equality rewrites*) 175 | Lemma b2Z_inj_rw : ^b1 = ^b2 <-> b1 = b2. Proof. !!. Qed. 176 | Lemma b2Zeq1l_rw : ^b = 1 <-> b = true. Proof. !!. Qed. 177 | Lemma b2Zeq1r_rw : 1 = ^b <-> b = true. Proof. !!. Qed. 178 | Lemma b2Zeq0l_rw : ^b = 0 <-> b = false. Proof. !!. Qed. 179 | Lemma b2Zeq0r_rw : 0 = ^b <-> b = false. Proof. !!. Qed. 180 | Lemma b2Zeq1mb2Z_rw : ^b1 = 1 - ^b2 <-> b1 = negb b2. Proof. !!. Qed. 181 | Lemma b2Zeq1mb2Zs_rw : 1 - ^b2 = ^b1 <-> b1 = negb b2. Proof. !!. Qed. 182 | Lemma b2Zeqnb2Zp1_rw : ^b1 = - ^b2 + 1 <-> b1 = negb b2. Proof. !!. Qed. 183 | Lemma b2Zeqnb2Zp1s_rw : - ^b2 + 1 = ^b1 <-> b1 = negb b2. Proof. !!. Qed. 184 | 185 | End B2Z_Rewrites. 186 | 187 | Hint Rewrite 188 | b2Zt_rw b2Zf_rw b2Z_negb_rw 189 | : b2Z_term_rws simp_rws term_rws bang_rws. 190 | 191 | Hint Rewrite 192 | b2Z_inj_rw b2Zeq1l_rw b2Zeq1r_rw b2Zeq0l_rw b2Zeq0r_rw 193 | b2Zeq1mb2Z_rw b2Zeq1mb2Zs_rw b2Zeqnb2Zp1_rw b2Zeqnb2Zp1s_rw 194 | : b2Z_eq_rws eq_rws. 195 | 196 | Hint Rewrite <- b2Z_inj_rw : simp_rws. 197 | 198 | Section Eb2Z_Rewrites. 199 | Variables b b1 b2 : EB. 200 | 201 | Tactic Notation "!!" := 202 | clear; unerase; autorewrite with b2Z_term_rws b2Z_eq_rws; tauto. 203 | Open Scope E_scope. 204 | (*Eb2Z term rewrites*) 205 | Lemma Eb2Zt_rw : ^#true = #1. Proof. !!. Qed. 206 | Lemma Eb2Zf_rw : ^#false = #0. Proof. !!. Qed. 207 | Lemma Eb2Z_negb_rw : ^(Enegb b) = #1 - ^b. Proof. !!. Qed. 208 | 209 | (*Eb2Z equality rewrites*) 210 | Lemma Eb2Z_inj_rw : ^b1 = ^b2 <-> b1 = b2. Proof. !!. Qed. 211 | Lemma Eb2Zeq1l_rw : ^b = #1 <-> b = #true. Proof. !!. Qed. 212 | Lemma Eb2Zeq1r_rw : #1 = ^b <-> b = #true. Proof. !!. Qed. 213 | Lemma Eb2Zeq0l_rw : ^b = #0 <-> b = #false. Proof. !!. Qed. 214 | Lemma Eb2Zeq0r_rw : #0 = ^b <-> b = #false. Proof. !!. Qed. 215 | Lemma Eb2Zeq1mb2Z_rw : ^b1 = #1 - ^b2 <-> b1 = Enegb b2. Proof. !!. Qed. 216 | Lemma Eb2Zeq1mb2Zs_rw : #1 - ^b2 = ^b1 <-> b1 = Enegb b2. Proof. !!. Qed. 217 | Lemma Eb2Zeqnb2Zp1_rw : 218 | ^b1 = - ^b2 + #1 <-> b1 = Enegb b2. Proof. !!. Qed. 219 | Lemma Eb2Zeqnb2Zp1s_rw : 220 | - ^b2 + #1 = ^b1 <-> b1 = Enegb b2. Proof. !!. Qed. 221 | 222 | End Eb2Z_Rewrites. 223 | 224 | Hint Rewrite Eb2Zt_rw Eb2Zf_rw Eb2Z_negb_rw 225 | : Eb2Z_term_rws simp_rws term_rws. 226 | 227 | Hint Rewrite 228 | Eb2Z_inj_rw Eb2Zeq1l_rw Eb2Zeq1r_rw Eb2Zeq0l_rw Eb2Zeq0r_rw 229 | Eb2Zeq1mb2Z_rw Eb2Zeq1mb2Zs_rw Eb2Zeqnb2Zp1_rw Eb2Zeqnb2Zp1s_rw 230 | : Eb2Z_eq_rws eq_rws. 231 | 232 | Hint Rewrite <- Eb2Z_inj_rw : simp_rws. 233 | 234 | Section Z_LHSify_Rewrites. 235 | Variables x y z : Z. 236 | 237 | Tactic Notation "!!" := lia. 238 | 239 | Lemma zlhs_rw : x = y <-> x - y = 0. Proof. !!. Qed. 240 | Lemma zadd1_lhs_rw : x + y = z <-> x = z - y. Proof. !!. Qed. 241 | Lemma zadd2_lhs_rw : x + y = z <-> y = z - x. Proof. !!. Qed. 242 | Lemma zsub1_lhs_rw : x - y = z <-> x = z + y. Proof. !!. Qed. 243 | Lemma zsub2_lhs_rw : x - y = z <-> y = x - z. Proof. !!. Qed. 244 | Lemma zopp_lhs_rw : -x = y <-> x = -y. Proof. !!. Qed. 245 | 246 | Lemma ziso1_rw : y = 0 <-> x = x + y. Proof. !!. Qed. 247 | Lemma ziso2_rw : y = 0 <-> x = x - y. Proof. !!. Qed. 248 | 249 | End Z_LHSify_Rewrites. 250 | 251 | 252 | Section EZ_LHSify_Rewrites. 253 | Variables x y z : EZ. 254 | 255 | Tactic Notation "!!" := clear; unerase; lia. 256 | Open Scope E_scope. 257 | Lemma Ezlhs_rw : x = y <-> x - y = #0. Proof. !!. Qed. 258 | Lemma Ezadd1_lhs_rw : x + y = z <-> x = z - y. Proof. !!. Qed. 259 | Lemma Ezadd2_lhs_rw : x + y = z <-> y = z - x. Proof. !!. Qed. 260 | Lemma Ezsub1_lhs_rw : x - y = z <-> x = z + y. Proof. !!. Qed. 261 | Lemma Ezsub2_lhs_rw : x - y = z <-> y = x - z. Proof. !!. Qed. 262 | Lemma Ezopp_lhs_rw : - x = y <-> x = - y. Proof. !!. Qed. 263 | 264 | Lemma Eziso1_rw : y = #0 <-> x = x + y. Proof. !!. Qed. 265 | Lemma Eziso2_rw : y = #0 <-> x = x - y. Proof. !!. Qed. 266 | 267 | End EZ_LHSify_Rewrites. 268 | 269 | Lemma ezring_theory : 270 | ring_theory (R:=EZ) #0 #1 ezadd ezmul ezsub ezopp eq. 271 | Proof. 272 | constructor. 273 | all: intros; unerase; ring. 274 | Qed. 275 | 276 | Ltac ezconst term := 277 | match term with 278 | | # ?x => Zcst x 279 | | _ => InitialRing.NotConstant 280 | end. 281 | 282 | Ltac EZring_preprocess := 283 | autorewrite with term_rws; 284 | autorewrite with ensharping_rws. 285 | 286 | Ltac EZring_postprocess := 287 | idtac. 288 | 289 | Add Ring ezring : 290 | ezring_theory (abstract, 291 | (*cannot be decidable, because no equality function is: EZ -> EZ -> bool*) 292 | constants [ezconst], 293 | preprocess [EZring_preprocess], 294 | postprocess [EZring_postprocess] 295 | ). 296 | 297 | Ltac safe_ring_simplify_in H := 298 | factor_evars H; 299 | try ring_simplify in H; 300 | defactor_all_evars. 301 | 302 | Ltac safe_ring_simplify := 303 | factor_conc_evars; 304 | try ring_simplify; 305 | defactor_all_evars. 306 | 307 | Ltac rsimp_term T := 308 | lazymatch T with 309 | | ?F ?A => rsimp_fun F A 310 | | ?A -> ?C => rsimp_term A; rsimp_term C 311 | | _ => idtac 312 | end 313 | with rsimp_fun F A := 314 | let T:=constr:(F A) in 315 | let tT:=type of T in 316 | tryif first [constr_eq tT Z|constr_eq tT (##Z)] 317 | then let e:=fresh in 318 | let ee:=fresh in 319 | remember T as e eqn:ee in *; 320 | (*safe_ring_simplify_in ee;*) try ring_simplify in ee; 321 | (*do not use subst e - it causes problems*) 322 | rewrite ?ee in *; clear e ee 323 | else (rsimp_term F; rsimp_term A). 324 | 325 | Ltac rsimp_in H := 326 | try rewrite Ezlhs_rw in H; 327 | try rewrite zlhs_rw in H; 328 | autorewrite with ensharping_rws in H; 329 | autorewrite with term_rws in H; 330 | let T:=type of H in rsimp_term T. 331 | 332 | Ltac rsimp_conc := 333 | try rewrite Ezlhs_rw; 334 | try rewrite zlhs_rw; 335 | autorewrite with ensharping_rws; 336 | autorewrite with term_rws; 337 | try ring_simplify. 338 | (* lazymatch goal with *) 339 | (* | |- ?G => rsimp_term G *) 340 | (* end. *) 341 | 342 | Ltac try_rsimp_in H := let T := type of H in rsimp_term T. 343 | 344 | Ltac rsimp := 345 | autorewrite with b2Z_term_rws in *; 346 | try ring_simplify; 347 | allhyps_reverting try_rsimp_in. 348 | 349 | (************************************************************************) 350 | 351 | Hint Rewrite <- b2Z_inj_rw : bang_rws. 352 | 353 | Ltac bang_setup_tactic := idtac. (*to be redefined*) 354 | 355 | Ltac pose_b2Zbounds := 356 | let f H := try generalize (b2Zbounds H) in 357 | allhyps_reverting_stop f; 358 | pose proof (b2Zbounds true); 359 | pose proof (b2Zbounds false). 360 | 361 | Ltac bang_internal setup := 362 | dintros; 363 | unsetall; 364 | try tauto; 365 | first[check_in_prop|exfalso]; 366 | setup; 367 | unerase; 368 | autorewrite with bang_rws in *; 369 | pose_b2Zbounds; 370 | (lia || 371 | lazymatch goal with 372 | | |- _ /\ _ => deconj; first[congruence|lia] 373 | | _ => congruence 374 | end). 375 | 376 | Ltac bang := bang_internal bang_setup_tactic. 377 | Ltac bang0 := bang_internal idtac. 378 | 379 | Ltac clear_evars := 380 | (*assumes all evars are factored*) 381 | repeat match goal with 382 | | H := ?V |- _ => is_evar V; clearbody H 383 | end. 384 | 385 | Ltac hyps_have_evars := 386 | (*assumes all evars are factored*) 387 | match goal with 388 | H := ?V |- _ => 389 | is_evar V; 390 | lazymatch goal with 391 | | _ : context[H] |- _ => idtac 392 | | _ := context[H] |- _ => idtac 393 | end 394 | end. 395 | 396 | Ltac nbang := 397 | (*assumes all evars are factored*) 398 | intros; 399 | tryif hyps_have_evars then idtac 400 | else 401 | lazymatch goal with 402 | |- ?G => 403 | tryif (let x := constr:((ltac:(intros; clear_evars; bang)):(G -> False)) in idtac) 404 | then fail 405 | else idtac 406 | end. 407 | 408 | Ltac check_cycle V Sub := 409 | lazymatch Sub with context[V] => fail | _ => idtac end. 410 | 411 | Ltac notin_conc_rhs E := 412 | lazymatch goal with 413 | | |- _ = ?R => check_cycle E R 414 | | |- ?G => fail 99 "notin_conc_rhs when conc is " G 415 | end. 416 | 417 | (* TBD: can we speed up the inst funs by using a bool xor fun to 418 | combine b/negb b by delaying the sign? 419 | *) 420 | 421 | Ltac unify_evar E V := 422 | (*instantiate (1:=V) in (Value of E).*) 423 | let Ee := get_value E in 424 | is_evar Ee; 425 | tryif constr_eq Ee V 426 | then fail 427 | else unify Ee V. 428 | 429 | Ltac inst_bool E := 430 | ((multimatch goal with 431 | | b := ?V : bool |- _ => 432 | is_evar V; 433 | (unify_evar E (V) + 434 | unify_evar E (negb V)) 435 | end) + 436 | (unify_evar E (true)) + 437 | (unify_evar E (false)) + 438 | (multimatch goal with 439 | | b : bool |- _ => 440 | tryif has_value b 441 | then fail 442 | else (unify_evar E (b) + 443 | unify_evar E (negb b)) 444 | end)); 445 | unfold E in *; clear E. 446 | 447 | Ltac inst_EB E := 448 | ((multimatch goal with 449 | | b := ?V : EB |- _ => 450 | is_evar V; 451 | (unify_evar E (V) + 452 | unify_evar E (Enegb V)) 453 | | b := ?V : bool |- _ => 454 | is_evar V; 455 | (unify_evar E (#V) + 456 | unify_evar E (Enegb #V)) 457 | end) + 458 | (unify_evar E (#true)) + 459 | (unify_evar E (#false)) + 460 | (multimatch goal with 461 | | b : EB |- _ => 462 | tryif has_value b 463 | then fail 464 | else (unify_evar E (b) + 465 | unify_evar E (Enegb b)) 466 | | b : bool |- _ => 467 | tryif has_value b 468 | then fail 469 | else (unify_evar E (#b) + 470 | unify_evar E (Enegb #b)) 471 | end)); 472 | unfold E in *; clear E. 473 | 474 | Ltac unify_booleq E := 475 | first [rewrite (Eziso1_rw (Eb2Z #E)); 476 | ring_simplify; notin_conc_rhs E 477 | |rewrite (Eziso2_rw (Eb2Z #E)); 478 | ring_simplify; notin_conc_rhs E]; 479 | autorewrite with Eb2Z_eq_rws; 480 | autorewrite with desharping_rws; 481 | defactor_all_evars; 482 | reflexivity. 483 | 484 | Ltac unify_EBeq E := 485 | first [rewrite (Eziso1_rw (Eb2Z E)); 486 | ring_simplify; notin_conc_rhs E 487 | |rewrite (Eziso2_rw (Eb2Z E)); 488 | ring_simplify; notin_conc_rhs E]; 489 | autorewrite with Eb2Z_eq_rws; 490 | defactor_all_evars; 491 | reflexivity. 492 | 493 | Ltac unify_Zeq E := 494 | first[rewrite (Eziso1_rw #E); 495 | ring_simplify; notin_conc_rhs E 496 | |rewrite (Eziso2_rw #E); 497 | ring_simplify; notin_conc_rhs E]; 498 | autorewrite with desharping_rws; 499 | defactor_all_evars; 500 | reflexivity. 501 | 502 | Ltac unify_EZeq E := 503 | first[rewrite (Eziso1_rw E); 504 | ring_simplify; notin_conc_rhs E 505 | |rewrite (Eziso2_rw E); 506 | ring_simplify; notin_conc_rhs E]; 507 | defactor_all_evars; 508 | reflexivity. 509 | 510 | Ltac boom_internal doinsts := 511 | dintros; 512 | defactor_all_evars; 513 | lazymatch goal with 514 | | |- (@eq EB _ _) => try reflexivity; rewrite <-Eb2Z_inj_rw 515 | | _ => idtac 516 | end; 517 | rsimp_conc; 518 | try simple_reflex; 519 | factor_all_evars; 520 | match goal with 521 | | [E := ?V : Z |- (@eq EZ _ _)] => is_evar V; unify_Zeq E 522 | | [E := ?V : EZ |- (@eq EZ _ _)] => is_evar V; unify_EZeq E 523 | | [E := ?V : EB |- (@eq EZ _ _)] => is_evar V; unify_EBeq E 524 | | [E := ?V : bool |- (@eq EZ _ _)] => is_evar V; unify_booleq E 525 | | _ => try bang 526 | end; 527 | match goal with 528 | | [E := ?V : EB |- _] => is_evar V 529 | | [E := ?V : bool |- _] => is_evar V 530 | end; 531 | check_in_prop; 532 | lazymatch doinsts with 533 | | 0 => idtac 534 | | false => fail "boom prevented from trying bool/EB instantiations" 535 | | true => nbang 536 | | I => shelve 537 | end; 538 | (*TBD - the following multimatch does too much, in that it tries all 539 | permutations of instantiations instead of just all combinations.*) 540 | multimatch goal with 541 | | [E := ?V : EB |- _] => is_evar V; inst_EB E; boom_internal 0 542 | | [E := ?V : bool |- _] => is_evar V; inst_bool E; boom_internal 0 543 | end. 544 | 545 | Ltac boom := boom_internal 0. 546 | -------------------------------------------------------------------------------- /factorevars.v: -------------------------------------------------------------------------------- 1 | 2 | (* Find all evars in a goal, and migrate them into standalone bodies 3 | of local defs - so that every evar in the goal exists only as such a 4 | standalone body. 5 | 6 | This currently only works for evars that are not under binders. 7 | *) 8 | 9 | Require Import hypiter. 10 | 11 | Ltac get_value H := eval cbv delta [H] in H. 12 | 13 | Ltac has_value H := let x:=get_value H in idtac. 14 | 15 | Ltac factor_value_evars H := 16 | repeat 17 | let vH:=get_value H in 18 | has_evar vH; 19 | match vH with 20 | context[?E] => 21 | is_evar E; 22 | let nE:=fresh "E0" in 23 | set (nE:=E) in * 24 | end. 25 | 26 | Ltac factor_type_evars H := 27 | repeat 28 | let tH:=type of H in 29 | has_evar tH; 30 | match tH with 31 | context[?E] => 32 | is_evar E; 33 | let nE:=fresh "E0" in 34 | set (nE:=E) in * 35 | end. 36 | 37 | Ltac factor_evars H := 38 | factor_value_evars H; 39 | factor_type_evars H. 40 | 41 | Ltac factor_conc_evars := 42 | repeat 43 | match goal with 44 | |- context[?E] => 45 | is_evar E; 46 | let nE := fresh "E0" in 47 | set (nE := E) in * 48 | end. 49 | 50 | Ltac factor_hyp_evars := 51 | allhyps_td factor_evars. 52 | 53 | Ltac factor_all_evars := 54 | factor_hyp_evars; 55 | factor_conc_evars. 56 | 57 | Ltac defactor_all_evars := 58 | let f H := try (let v:=get_value H in 59 | is_evar v; unfold H in *; clear H) 60 | in 61 | allhyps_td f. 62 | 63 | Ltac clearbody_evars := 64 | let f H := try (let v:=get_value H in 65 | is_evar v; clearbody H) 66 | in 67 | allhyps_td f. 68 | -------------------------------------------------------------------------------- /hypiter.v: -------------------------------------------------------------------------------- 1 | 2 | (*Iteration over Hypotheses *) 3 | 4 | (*fast non-kludgy versions of iteration - using dual continuations. The icont continuation re-intros each hyp that was reverted. The tcont continuation calls the target tac on each hyp in the desired order. Even though these use revert/re-intro style iteration, they are about twice as fast as the hypothesis harvesting method. The original harvesting tactics allow for much more functionality (including filtering, conditional iteration, etc.) that should be reproducible with this dual-continuation style if needed (and nothing needs them yet):*) 5 | 6 | Ltac allhyps_bu tac := 7 | idtac; (*tac runs in bottom-up hyp order, with all hyps present*) 8 | let rec f icont tcont := 9 | idtac; 10 | lazymatch goal with 11 | | H : _ |- _ => revert H; f ltac:(intro H; icont) ltac:(tcont; tac H) 12 | | _ => icont; tcont 13 | end 14 | in f ltac:(idtac) ltac:(idtac). 15 | 16 | Ltac allhyps_td tac := 17 | idtac; (*tac runs in top-down hyp order, with all hyps present*) 18 | let rec f icont tcont := 19 | idtac; 20 | lazymatch goal with 21 | | H : _ |- _ => revert H; f ltac:(intro H; icont) ltac:(tac H; tcont) 22 | | _ => icont; tcont 23 | end 24 | in f ltac:(idtac) ltac:(idtac). 25 | 26 | (*The following two forms are faster than the above two, but the tac runs in a context where it is being called with other hyps reverted - hence they will not work well when tac wishes to perform actions from its target hyp onto others (such as rewrites).*) 27 | Ltac allhyps_reverting tac := 28 | idtac; (*like allhyps_bu, but runs tac on last then reverts for next *) 29 | lazymatch goal with 30 | | H : _ |- _ => tac H; revert H; allhyps_reverting tac; intro H 31 | | _ => idtac 32 | end. 33 | 34 | Ltac allhyps_introing tac := 35 | idtac; (*like allhyps_td, but reverts all then runs tac as they are reintroed*) 36 | lazymatch goal with 37 | | H : _ |- _ => revert H; allhyps_introing tac; intro H; tac H 38 | | _ => idtac 39 | end. 40 | 41 | Inductive Stop := CStop. 42 | 43 | (*Like the above, but uses a dedicated Stop hyp to decide when it has reintroed back to the original conclusion *) 44 | Ltac allhyps_reverting_stop tac := 45 | generalize (CStop : Stop); 46 | repeat lazymatch goal with 47 | | H : _ |- _ => tac H; revert H 48 | end; 49 | repeat lazymatch goal with 50 | | |- Stop -> _ => fail 51 | | _ => intro 52 | end; 53 | intros _. 54 | 55 | Ltac allhyps_introing_stop tac := 56 | generalize (CStop : Stop); 57 | repeat lazymatch goal with 58 | | H : _ |- _ => revert H 59 | end; 60 | repeat lazymatch goal with 61 | | H : Stop |- _ => fail 62 | | H : _ |- _ => tac H; intro 63 | end; 64 | lazymatch goal with 65 | | H : Stop |- _ => clear H 66 | end. 67 | 68 | 69 | -------------------------------------------------------------------------------- /ordered.v: -------------------------------------------------------------------------------- 1 | 2 | Require Export Coq.Classes.RelationClasses. 3 | 4 | Set Default Goal Selector "all". 5 | 6 | Class Ordered(A : Set) := 7 | { lt : A -> A -> Prop; 8 | lt_strict :> StrictOrder lt 9 | }. 10 | 11 | Class OrderedKeyed (A K : Set) := 12 | { keyof : A -> K; 13 | OA :> Ordered A 14 | }. 15 | 16 | Class KeyOrdered (A K : Set) := 17 | { getkey : A -> K; 18 | OK :> Ordered K 19 | }. 20 | 21 | Definition KOlt{A K : Set}`{KeyOrdered A K}(a b : A) : Prop := lt (getkey a) (getkey b). 22 | 23 | Instance KOisO A K `{KeyOrdered A K} : Ordered A. 24 | Proof. 25 | destruct (_:KeyOrdered A K) as [gk [ltk [SOI SOT]]]. unshelve eexists. 26 | - intros a b. exact (ltk (gk a) (gk b)). 27 | - split. 28 | + unfold Irreflexive, Reflexive, complement in *. intro. apply SOI. 29 | + unfold Transitive in *. intros x y z. apply SOT. 30 | Defined. 31 | 32 | Instance KOisOK A K `{KeyOrdered A K} : OrderedKeyed A K := 33 | { keyof := getkey }. 34 | 35 | Class ComparableKeyed (A K : Set) := 36 | { OKOK :> OrderedKeyed A K; 37 | compare : K -> K -> comparison; 38 | compare_spec x y: CompareSpecT (eq x y) 39 | (forall (a b : A), x = keyof a -> y = keyof b -> lt a b) 40 | (forall (a b : A), x = keyof a -> y = keyof b -> lt b a) 41 | (compare x y); 42 | lt_same_keys w x y z: lt w y -> keyof x = keyof w -> keyof z = keyof y -> lt x z 43 | }. 44 | 45 | Require Coq.Init.Nat. 46 | Require Coq.Arith.PeanoNat. 47 | 48 | Module Test. 49 | 50 | Import Nat. 51 | Import PeanoNat. 52 | 53 | Open Scope nat_scope. 54 | 55 | Context {A : Set}. 56 | Context {Ord : Ordered A}. 57 | 58 | Record OK : Set := { val : A; key : nat }. 59 | 60 | Definition OKlt (a b : OK) : Prop := a.(key) < b.(key). 61 | 62 | Lemma le_Sn_n : forall n, S n <= n -> False. 63 | Proof. 64 | induction n as [|? IHn]. intro H. 65 | - inversion H. 66 | - apply IHn. apply le_S_n. assumption. 67 | Qed. 68 | 69 | Lemma OKlt_strict : StrictOrder OKlt. 70 | Proof. 71 | eexists. red. 72 | - red. red. intros [v k]. cbv. apply le_Sn_n. 73 | - intros [? ?] [? ykey] [? ?]. unfold OKlt, key. transitivity ykey. assumption. 74 | Qed. 75 | 76 | Instance OKOrd : Ordered OK := { lt := OKlt; lt_strict := OKlt_strict }. 77 | 78 | Lemma OKOrd_compare_spec (x y:nat) : 79 | CompareSpecT (eq x y) 80 | (forall (a b : OK), x = a.(key) -> y = b.(key) -> OKlt a b) 81 | (forall (a b : OK), x = a.(key) -> y = b.(key) -> OKlt b a) 82 | (Nat.compare x y). 83 | Proof. 84 | destruct (CompareSpec2Type (Nat.compare_spec x y)). constructor. 85 | - assumption. 86 | - intros ? ? -> -> . assumption. 87 | - intros ? ? -> -> . assumption. 88 | Qed. 89 | 90 | Lemma OKOrd_lt_same_keys w x y z : 91 | OKlt w y -> x.(key) = w.(key) -> z.(key) = y.(key) -> OKlt x z. 92 | Proof. 93 | unfold OKlt. intros H -> -> . assumption. 94 | Qed. 95 | 96 | Instance OKnat : OrderedKeyed OK nat := { keyof := key }. 97 | 98 | Instance CKnat : ComparableKeyed OK nat := 99 | { compare := Nat.compare; 100 | compare_spec := OKOrd_compare_spec; 101 | lt_same_keys := OKOrd_lt_same_keys 102 | }. 103 | 104 | End Test. 105 | 106 | -------------------------------------------------------------------------------- /utils.v: -------------------------------------------------------------------------------- 1 | 2 | Ltac revert_all := 3 | repeat lazymatch goal with H:_ |- _ => revert H end. 4 | 5 | Ltac get_value H := eval cbv delta [H] in H. 6 | 7 | Ltac has_value H := let X:=get_value H in idtac. 8 | 9 | Ltac minlines := 10 | idtac; (*prevent early eval*) 11 | let stop:=fresh "stop" in 12 | generalize I as stop; 13 | revert_all; 14 | let rec f := 15 | try (intro; 16 | lazymatch goal with H:?T |- _ => 17 | first[constr_eq H stop; clear stop 18 | |let v := get_value H in 19 | try match goal with H' := v : T |- _ => 20 | first[constr_eq H H'; fail 1 21 | |move H before H'] end; f 22 | |try match goal with H':T |- _ => 23 | first[constr_eq H H'; fail 1 24 | |has_value H'; fail 1 25 | |move H before H'] end; f 26 | |f] 27 | end) 28 | in f. 29 | 30 | Ltac is_head_of head type := 31 | lazymatch type with 32 | | head => idtac 33 | | ?H ?T => is_head_of head H 34 | end. 35 | 36 | Tactic Notation "onhead" constr(head) tactic3(tac) := 37 | multimatch goal with H : ?T |- _ => is_head_of head T; tac H end. 38 | 39 | Ltac destr H := destruct H. 40 | Ltac induct H := induction H. 41 | Ltac invert H := inversion H. 42 | 43 | Ltac pick head := 44 | let rec f x H := 45 | lazymatch x with 46 | | head => H 47 | | ?y _ => f y H 48 | end in 49 | multimatch goal with H : ?T |- _ => f T H end. 50 | 51 | Ltac cleanup_tac := 52 | tauto||congruence||(constructor;cleanup_tac). 53 | 54 | Tactic Notation "clean" "using" tactic(tac) := 55 | repeat match goal with 56 | H : ?T |- _ => clear H; assert T as _ by tac end. 57 | 58 | Ltac clean := clean using cleanup_tac. 59 | 60 | Ltac destruct_goal_bool := 61 | match goal with 62 | | B : bool |- context[?G] => constr_eq B G; destruct B 63 | end. 64 | 65 | Ltac destruct_useful_bool := 66 | onhead bool (fun B => 67 | lazymatch goal with 68 | _ : context [B] |- _ => 69 | destruct B 70 | end). 71 | 72 | Ltac deconj := repeat apply conj. 73 | 74 | Ltac unsetall := 75 | repeat lazymatch goal with H := _ |- _ => unfold H in *; clearbody H end. 76 | 77 | Ltac simple_reflex := 78 | lazymatch goal with 79 | | |- ?X = ?X => reflexivity 80 | | |- ?L = ?R => 81 | first[is_evar L|is_evar R]; unify L R; reflexivity 82 | end. 83 | 84 | Local Lemma feq : forall {A B} (f g : A -> B) (x y : A), f=g -> x=y -> f x = g y. 85 | Proof. 86 | intros. 87 | subst. 88 | reflexivity. 89 | Qed. 90 | 91 | Local Lemma depfeq : forall {A B}(f g : forall x:A, B x), f=g -> forall x, f x = g x. 92 | Proof. 93 | intros. 94 | subst. 95 | reflexivity. 96 | Qed. 97 | 98 | Ltac lowereq := 99 | lazymatch goal with 100 | |- @eq ?T ?X ?Y => (*in case T is a higher-than necessary universe*) 101 | let H := fresh in 102 | assert (X = Y) as H; [|try rewrite H; reflexivity] 103 | end. 104 | 105 | Ltac my_f_equal := 106 | try simple_reflex; 107 | lowereq; 108 | lazymatch goal with 109 | | |- ?f ?x = ?g ?x => apply (depfeq f g); my_f_equal 110 | | _ => try (apply feq; [my_f_equal|try simple_reflex]) 111 | end. 112 | 113 | Ltac equator H := 114 | let tH:=type of H in 115 | lazymatch goal with 116 | |- ?G => replace G with tH; [exact H|] 117 | end. 118 | 119 | Tactic Notation "force" "exact" constr(H) := 120 | equator H; [my_f_equal|..]. 121 | 122 | Tactic Notation "equate" uconstr(term) := 123 | let H := fresh in 124 | simple refine (let H := term in _); cycle -1; 125 | [equator H;clear H|..]; shelve_unifiable. 126 | 127 | Tactic Notation "force" "refine" uconstr(H) "by" tactic1(frtac) := 128 | equate H; [my_f_equal; [frtac..]|..]. 129 | 130 | Tactic Notation "force" "refine" uconstr(X) := force refine X by idtac. 131 | 132 | Ltac reassumption := 133 | multimatch goal with H:_ |- _ => exact H end. 134 | 135 | Ltac vgoal := 136 | idtac; (*prevents early eval*) 137 | match reverse goal with 138 | | H : ?T |- _ => 139 | first[let v := get_value H in 140 | idtac H ":=" v ":" T 141 | |idtac H ":" T]; 142 | fail 143 | | |- ?G => 144 | idtac "======"; idtac G; idtac "" 145 | end. 146 | 147 | Ltac dintros := 148 | intros; 149 | repeat (match goal with 150 | | H : _ /\ _ |- _ => destruct H as (? & ?) 151 | end); 152 | subst. 153 | -------------------------------------------------------------------------------- /wavl.ml: -------------------------------------------------------------------------------- 1 | 2 | type compareSpecT = 3 | | CompEqT 4 | | CompLtT 5 | | CompGtT 6 | 7 | type 'a sig0 = 'a 8 | (* singleton inductive, whose constructor was exist *) 9 | 10 | 11 | 12 | type a (* AXIOM TO BE REALIZED *) 13 | 14 | (** val compare_spec : a -> a -> compareSpecT **) 15 | 16 | let compare_spec = 17 | failwith "AXIOM TO BE REALIZED" 18 | 19 | type wavltree = 20 | | Node of bool * a * wavltree * wavltree 21 | | Missing 22 | 23 | type findResult = 24 | | Found 25 | | NotFound 26 | 27 | (** val find : a -> wavltree -> findResult **) 28 | 29 | let rec find x = function 30 | | Node (_, d, lw, rw) -> (match compare_spec x d with 31 | | CompEqT -> Found 32 | | CompLtT -> find x lw 33 | | CompGtT -> find x rw) 34 | | Missing -> NotFound 35 | 36 | (** val setgap : wavltree -> bool -> wavltree **) 37 | 38 | let setgap w og = 39 | match w with 40 | | Node (_, d, lw, rw) -> Node (og, d, lw, rw) 41 | | Missing -> Missing 42 | 43 | (** val getgap : wavltree -> bool **) 44 | 45 | let getgap = function 46 | | Node (g0, _, _, _) -> g0 47 | | Missing -> false 48 | 49 | (** val isgap : wavltree -> bool -> bool **) 50 | 51 | let isgap w g' = 52 | match w with 53 | | Node (g0, _, _, _) -> (=) g' g0 54 | | Missing -> false 55 | 56 | (** val isMissing : wavltree -> bool **) 57 | 58 | let isMissing = function 59 | | Node (_, _, _, _) -> false 60 | | Missing -> true 61 | 62 | (** val irot1 : wavltree -> a -> wavltree -> bool -> wavltree **) 63 | 64 | let irot1 lw x rw g = 65 | match lw with 66 | | Node (_, d, lw0, rw0) -> 67 | (match rw0 with 68 | | Node (g1, d0, lw1, rw1) -> 69 | if g1 70 | then Node (g, d, lw0, (Node (false, x, (setgap rw0 false), (setgap rw false)))) 71 | else Node (g, d0, (Node (false, d, (setgap lw0 false), lw1)), (Node (false, x, rw1, (setgap rw false)))) 72 | | Missing -> Node (g, d, lw0, (Node (false, x, Missing, (setgap rw false))))) 73 | | Missing -> assert false (* absurd case *) 74 | 75 | (** val irot2 : wavltree -> a -> wavltree -> bool -> wavltree **) 76 | 77 | let irot2 lw x rw g = 78 | match rw with 79 | | Node (_, d, lw0, rw0) -> 80 | (match lw0 with 81 | | Node (g1, d0, lw1, rw1) -> 82 | if g1 83 | then Node (g, d, (Node (false, x, (setgap lw false), (setgap lw0 false))), rw0) 84 | else Node (g, d0, (Node (false, x, (setgap lw false), lw1)), (Node (false, d, rw1, (setgap rw0 false)))) 85 | | Missing -> Node (g, d, (Node (false, x, (setgap lw false), Missing)), rw0)) 86 | | Missing -> assert false (* absurd case *) 87 | 88 | type insertedHow = 89 | | ISameK 90 | | IWasMissing 91 | | IHigherK 92 | 93 | type insertResult = 94 | | Inserted of wavltree * insertedHow 95 | | FoundByInsert 96 | 97 | (** val insert : a -> wavltree -> insertResult **) 98 | 99 | let rec insert x = function 100 | | Node (g0, d, lw, rw) -> 101 | (match compare_spec x d with 102 | | CompEqT -> FoundByInsert 103 | | CompLtT -> 104 | (match insert x lw with 105 | | Inserted (ow, insertedHow0) -> 106 | (match insertedHow0 with 107 | | ISameK -> Inserted ((Node (g0, d, ow, rw)), ISameK) 108 | | IWasMissing -> 109 | if isMissing rw 110 | then Inserted ((Node (false, d, ow, Missing)), IHigherK) 111 | else Inserted ((Node (g0, d, ow, rw)), ISameK) 112 | | IHigherK -> 113 | if getgap lw 114 | then Inserted ((Node (g0, d, ow, rw)), ISameK) 115 | else if isgap rw false 116 | then Inserted ((Node (false, d, ow, (setgap rw true))), IHigherK) 117 | else Inserted ((irot1 ow d rw g0), ISameK)) 118 | | FoundByInsert -> FoundByInsert) 119 | | CompGtT -> 120 | (match insert x rw with 121 | | Inserted (ow, insertedHow0) -> 122 | (match insertedHow0 with 123 | | ISameK -> Inserted ((Node (g0, d, lw, ow)), ISameK) 124 | | IWasMissing -> 125 | if isMissing lw 126 | then Inserted ((Node (false, d, Missing, ow)), IHigherK) 127 | else Inserted ((Node (g0, d, lw, ow)), ISameK) 128 | | IHigherK -> 129 | if getgap rw 130 | then Inserted ((Node (g0, d, lw, ow)), ISameK) 131 | else if isgap lw false 132 | then Inserted ((Node (false, d, (setgap lw true), ow)), IHigherK) 133 | else Inserted ((irot2 lw d ow g0), ISameK)) 134 | | FoundByInsert -> FoundByInsert)) 135 | | Missing -> Inserted ((Node (false, x, Missing, Missing)), IWasMissing) 136 | 137 | type tryLoweringResult = 138 | | TLlowered of wavltree 139 | | TLtooLow 140 | 141 | (** val tryLowering : wavltree -> tryLoweringResult **) 142 | 143 | let tryLowering = function 144 | | Node (g0, d, lw, rw) -> 145 | if isgap lw true 146 | then if isgap rw true then TLlowered (Node (g0, d, (setgap lw false), (setgap rw false))) else TLtooLow 147 | else TLtooLow 148 | | Missing -> TLtooLow 149 | 150 | type deletedHow = 151 | | DSameK 152 | | DLowerK 153 | 154 | (** val drot1 : wavltree -> a -> wavltree -> bool -> ( * ) **) 155 | 156 | let drot1 lw x rw g = 157 | match rw with 158 | | Node (_, d, lw0, rw0) -> 159 | (match lw0 with 160 | | Node (_, d0, lw1, rw1) -> 161 | if isgap rw0 false 162 | then (DSameK, (Node (g, d, (Node (false, x, lw, lw0)), (setgap rw0 true)))) 163 | else (DSameK, (Node (g, d0, (Node (true, x, (setgap lw false), lw1)), (Node (true, d, rw1, 164 | (setgap rw0 false)))))) 165 | | Missing -> (DSameK, (Node (g, d, (Node (true, x, (setgap lw false), Missing)), (setgap rw0 true))))) 166 | | Missing -> assert false (* absurd case *) 167 | 168 | (** val drot2 : wavltree -> a -> wavltree -> bool -> ( * ) **) 169 | 170 | let drot2 lw x rw g = 171 | match lw with 172 | | Node (_, d, lw0, rw0) -> 173 | (match rw0 with 174 | | Node (_, d0, lw1, rw1) -> 175 | if isgap lw0 false 176 | then (DSameK, (Node (g, d, (setgap lw0 true), (Node (false, x, rw0, rw))))) 177 | else (DSameK, (Node (g, d0, (Node (true, d, (setgap lw0 false), lw1)), (Node (true, x, rw1, 178 | (setgap rw false)))))) 179 | | Missing -> (DSameK, (Node (g, d, (setgap lw0 true), (Node (true, x, Missing, (setgap rw false))))))) 180 | | Missing -> assert false (* absurd case *) 181 | 182 | (** val delmin : wavltree -> ( * ) **) 183 | 184 | let rec delmin = function 185 | | Node (g0, d, lw, rw) -> 186 | if isMissing lw 187 | then (d, (DLowerK, (setgap rw true))) 188 | else let (min, dp) = delmin lw in 189 | let (dh, ow) = dp in 190 | (match dh with 191 | | DSameK -> (min, (DSameK, (Node (g0, d, ow, rw)))) 192 | | DLowerK -> 193 | if isgap rw false 194 | then if isgap lw true 195 | then (match tryLowering rw with 196 | | TLlowered ow0 -> (min, (DLowerK, (Node (true, d, ow, ow0)))) 197 | | TLtooLow -> (min, (drot1 ow d rw g0))) 198 | else (min, (DSameK, (Node (g0, d, ow, rw)))) 199 | else (min, (DLowerK, (Node (true, d, (setgap ow (getgap lw)), (setgap rw false)))))) 200 | | Missing -> assert false (* absurd case *) 201 | 202 | (** val delmax : wavltree -> ( * ) **) 203 | 204 | let rec delmax = function 205 | | Node (g0, d, lw, rw) -> 206 | if isMissing rw 207 | then (d, (DLowerK, (setgap lw true))) 208 | else let (max, dp) = delmax rw in 209 | let (dh, ow) = dp in 210 | (match dh with 211 | | DSameK -> (max, (DSameK, (Node (g0, d, lw, ow)))) 212 | | DLowerK -> 213 | if isgap lw false 214 | then if isgap rw true 215 | then (match tryLowering lw with 216 | | TLlowered ow0 -> (max, (DLowerK, (Node (true, d, ow0, ow)))) 217 | | TLtooLow -> (max, (drot2 lw d ow g0))) 218 | else (max, (DSameK, (Node (g0, d, lw, ow)))) 219 | else (max, (DLowerK, (Node (true, d, (setgap lw false), (setgap ow (getgap rw))))))) 220 | | Missing -> assert false (* absurd case *) 221 | 222 | type deleteResult = 223 | | Deleted of ( * ) 224 | | DNotFound 225 | 226 | (** val delete : a -> wavltree -> deleteResult **) 227 | 228 | let rec delete x = function 229 | | Node (g0, d, lw, rw) -> 230 | (match compare_spec x d with 231 | | CompEqT -> 232 | if isMissing lw 233 | then Deleted (DLowerK, (setgap rw true)) 234 | else if isMissing rw 235 | then Deleted (DLowerK, (setgap lw true)) 236 | else if getgap lw 237 | then let (min, dp) = delmin rw in 238 | let (dh, ow) = dp in 239 | (match dh with 240 | | DSameK -> Deleted (DSameK, (Node (g0, min, lw, ow))) 241 | | DLowerK -> Deleted (DLowerK, (Node (true, min, (setgap lw false), (setgap ow (getgap rw)))))) 242 | else let (max, dp) = delmax lw in let (_, ow) = dp in Deleted (DSameK, (Node (g0, max, ow, rw))) 243 | | CompLtT -> 244 | (match delete x lw with 245 | | Deleted dp -> 246 | let (dh, ow) = dp in 247 | (match dh with 248 | | DSameK -> Deleted (DSameK, (Node (g0, d, ow, rw))) 249 | | DLowerK -> 250 | if getgap lw 251 | then if getgap rw 252 | then Deleted (DLowerK, (Node (true, d, ow, (setgap rw false)))) 253 | else (match tryLowering rw with 254 | | TLlowered ow0 -> Deleted (DLowerK, (Node (true, d, ow, ow0))) 255 | | TLtooLow -> Deleted (drot1 ow d rw g0)) 256 | else if isMissing rw 257 | then Deleted (DLowerK, (Node (true, d, (setgap ow false), Missing))) 258 | else Deleted (DSameK, (Node (g0, d, ow, rw)))) 259 | | DNotFound -> DNotFound) 260 | | CompGtT -> 261 | (match delete x rw with 262 | | Deleted dp -> 263 | let (dh, ow) = dp in 264 | (match dh with 265 | | DSameK -> Deleted (DSameK, (Node (g0, d, lw, ow))) 266 | | DLowerK -> 267 | if getgap rw 268 | then if getgap lw 269 | then Deleted (DLowerK, (Node (true, d, (setgap lw false), ow))) 270 | else (match tryLowering lw with 271 | | TLlowered ow0 -> Deleted (DLowerK, (Node (true, d, ow0, ow))) 272 | | TLtooLow -> Deleted (drot2 lw d ow g0)) 273 | else if isMissing lw 274 | then Deleted (DLowerK, (Node (true, d, Missing, (setgap ow false)))) 275 | else Deleted (DSameK, (Node (g0, d, lw, ow)))) 276 | | DNotFound -> DNotFound)) 277 | | Missing -> DNotFound 278 | -------------------------------------------------------------------------------- /wavl.mli: -------------------------------------------------------------------------------- 1 | 2 | type compareSpecT = 3 | | CompEqT 4 | | CompLtT 5 | | CompGtT 6 | 7 | type 'a sig0 = 'a 8 | (* singleton inductive, whose constructor was exist *) 9 | 10 | 11 | 12 | type a (* AXIOM TO BE REALIZED *) 13 | 14 | val compare_spec : a -> a -> compareSpecT 15 | 16 | type wavltree = 17 | | Node of bool * a * wavltree * wavltree 18 | | Missing 19 | 20 | type findResult = 21 | | Found 22 | | NotFound 23 | 24 | val find : a -> wavltree -> findResult 25 | 26 | val setgap : wavltree -> bool -> wavltree 27 | 28 | val getgap : wavltree -> bool 29 | 30 | val isgap : wavltree -> bool -> bool 31 | 32 | val isMissing : wavltree -> bool 33 | 34 | val irot1 : wavltree -> a -> wavltree -> bool -> wavltree 35 | 36 | val irot2 : wavltree -> a -> wavltree -> bool -> wavltree 37 | 38 | type insertedHow = 39 | | ISameK 40 | | IWasMissing 41 | | IHigherK 42 | 43 | type insertResult = 44 | | Inserted of wavltree * insertedHow 45 | | FoundByInsert 46 | 47 | val insert : a -> wavltree -> insertResult 48 | 49 | type tryLoweringResult = 50 | | TLlowered of wavltree 51 | | TLtooLow 52 | 53 | val tryLowering : wavltree -> tryLoweringResult 54 | 55 | type deletedHow = 56 | | DSameK 57 | | DLowerK 58 | 59 | val drot1 : wavltree -> a -> wavltree -> bool -> ( * ) 60 | 61 | val drot2 : wavltree -> a -> wavltree -> bool -> ( * ) 62 | 63 | val delmin : wavltree -> ( * ) 64 | 65 | val delmax : wavltree -> ( * ) 66 | 67 | type deleteResult = 68 | | Deleted of ( * ) 69 | | DNotFound 70 | 71 | val delete : a -> wavltree -> deleteResult 72 | -------------------------------------------------------------------------------- /wavl.v: -------------------------------------------------------------------------------- 1 | 2 | (*** Weak AVL Trees ***) 3 | 4 | (*+ 5 | See "Rank-Balanced Trees" by Haeupler, Sen, Tarjan 6 | [http://www.cs.princeton.edu/~sssix/papers/rb-trees-talg.pdf]. 7 | *) 8 | 9 | (*! Coq proof style: 10 | 11 | - Define all but most trivial functions using proof mode. 12 | 13 | - Keep all but the most trivial functions opaque (via Qed), as their types 14 | should suffice for all usages, making unfolding unnecessary (unfolding is 15 | unmodular). 16 | 17 | - Do not depend on any non-argument hypotheses names. 18 | 19 | - Do not depend on hypothesis order. 20 | 21 | - Do not use intro patterns. 22 | 23 | - Target tactics to hyps based on their type and relationship to arguments, 24 | using projector-like tactic/notations for readability. 25 | 26 | - Do not use type indexes - use type parameters and equality fields instead. 27 | 28 | - Tailor simple solver tactics for each function definition. 29 | 30 | - Use brief tactic notations and proof bullets to improve proof structure 31 | readability. 32 | 33 | *) 34 | Set Ltac Profiling. 35 | Require Import mindless.elist. 36 | Require Import mindless.ezbool. 37 | Require Import mindless.utils. 38 | Require Import mindless.hypiter. 39 | 40 | Generalizable All Variables. 41 | 42 | Set Default Goal Selector "all". 43 | 44 | Context {A : Set}. 45 | 46 | Context {ordA : Ordered A}. 47 | 48 | Context {compare : A -> A -> comparison}. 49 | 50 | Context {compare_spec : forall x y, CompareSpecT (eq x y) (lt x y) (lt y x) (compare x y)}. 51 | 52 | (* trinary (eq, lt, gt) comparisons of A elements: *) 53 | Notation "x =<> y" := (compare_spec x y) (at level 70, only parsing). 54 | 55 | (*All type parameters will be in these three erasable types:*) 56 | Notation EL := ##(list A). 57 | Notation EZ := ##Z. 58 | Notation EB := ##bool. 59 | (*These types are sufficient for the specification of all relevant invariants 60 | in the definitions that follow. Furthermore, we have specialized tactics for 61 | solving goals involving these types. The tactic solve_sorted from 62 | solve_sorted.v solves Esorted and ENotIn goals on ELs. The tactics bang and 63 | boom from ezbool.v solve equalities in EZ that include converted (using ^ 64 | prefix operator) EBs, and which (in the case of boom) may include evars 65 | linking multiple goals.*) 66 | 67 | (*E_scope has been defined so that erasable versions of operators in Z (+, -) 68 | and list (++ and [_]) can be written directly, so that they resemble the 69 | corresponding unerased operators. The erasable operator itself (#) is then 70 | only needed for constants and variables.*) 71 | Open Scope E_scope. 72 | 73 | (* Weak-AVL trees with rank k, parent gap pg, child gaps lg and rg (for left 74 | and right children respectively) and contents c (as a flattened list of all 75 | elements in sorted order). 76 | 77 | The presence of a gap between a parent and child indicates that the rank of 78 | the parent is 2 greater than that of the child. The absence of a gap 79 | indicates a rank difference of 1. 80 | 81 | Each node contains fields g (gap : boolean), d (datum), lw (left subtree), and 82 | rw (right subtree) as its only runtime (unerasable) fields. The remaining 83 | fields are all in Prop, and so will all be erased at Extraction. 84 | 85 | Missing trees have (obviously) no runtime fields, but do have erasable fields 86 | specifying that the contents are empty (c = []), that the rank is -1, and that 87 | both missing subtree gaps should be considered false (this choice makes a few 88 | things slightly easier, primarily tryLowering, but any choide could be 89 | accommodated - as well as leaving them to "float"). 90 | 91 | The formulation, specifically with regard to ranks, is intended to mirror the 92 | formulation in "Rank-Balanced Trees" by Haeupler, Sen, Tarjan 93 | [http://www.cs.princeton.edu/~sssix/papers/rb-trees-talg.pdf], specifically: 94 | 95 | "A ranked binary tree is a binary tree each of whose nodes x has a 96 | non-negative integer rank r(x). We adopt the convention that missing nodes 97 | have rank −1. The rank of a ranked binary tree is the rank of its root. If x 98 | is a node with parent p(x), the rank difference of x is r(p(x)) − r(x)." 99 | 100 | and 101 | 102 | "Weak AVL Rule: All rank differences are 1 or 2 and every leaf has rank 0." 103 | 104 | and 105 | 106 | "We can represent ranks in a wavl tree using one bit per node. The most 107 | straightforward way to do this is to use the bit in a node to indicate whether 108 | its rank difference is 1 or 2." 109 | 110 | However, we use k for ranks instead of r. We reserve r as a prefix to 111 | indicate "right" (and l for "left"). The gap fields are the bit per node 112 | indicators of rank difference. 113 | 114 | Note that the leaf_rule field in Node corresponds to the requirement that 115 | every leaf has rank 0, as it requires that a node with rank 1 must have at 116 | least one child with no gap, hence at rank 0, hence not missing. This 117 | roundabout way of specifying the leaf rule makes use of the existing gap and 118 | rank parameters, without requiring any additional parameters (such as a 119 | boolean type parameter signifying if the subtree is missing or not). We check 120 | in section Check_Leaf_Rule below that the expected equivalence between rank 0 121 | and leaves is enforced.*) 122 | Inductive wavltree (k : EZ)(pg lg rg : EB)(c : EL) : Set := 123 | | Node(g : bool)(d : A) 124 | (_: #g = pg) 125 | `(_: c = lc++[d]++rc) 126 | `(lw : wavltree (k - #1 - ^lg) lg llg lrg lc) 127 | `(rw : wavltree (k - #1 - ^rg) rg rlg rrg rc) 128 | (leaf_rule: k = #1 -> lg = #false \/ rg = #false) 129 | (_: Esorted c) 130 | | Missing(_: c = [])(_: k = - #1)(_: lg = #false)(_: rg = #false). 131 | 132 | (**********************************************************************) 133 | 134 | (*Tactic notations to make the proofs more readable:*) 135 | 136 | (*The only case analysis tactics we will use are ?? and ??_on. The reason for 137 | using a concise notation for case analysis tactics (and later also solver 138 | tactics) is so that the structure of the function is easier to recognize in 139 | the proof:*) 140 | Tactic Notation "??" constr(H) := 141 | (*use case_eq if H is a hyp with dependents, else case*) 142 | (tryif (is_var H; try (clear H; (*clear H fails if H as dependents*) 143 | fail 1)) 144 | then case_eq H 145 | else case H); 146 | dintros. 147 | 148 | (*This "on" version is just used for recursive calls, as it removes the need 149 | to "_" args that would be implicit in outside calls: *) 150 | Tactic Notation "??" constr(H) "on" constr(H') := 151 | case H with (1:=H'); dintros. 152 | 153 | (*Projector-like tactic/notation combos to select hypotheses based on type and 154 | relationship to the wavltree argument. This enables the proofs to maintain 155 | independence from both non-argument hypothesis naming and ordering while 156 | retaining readability. *) 157 | 158 | Tactic Notation "just" tactic1(tac) := let x := tac in exact x. 159 | 160 | Ltac left_child w := 161 | lazymatch type of w with 162 | wavltree _ _ _ _ (?C++[_]++_) => 163 | lazymatch goal with 164 | L:wavltree _ _ _ _ C |- _ => L 165 | end 166 | end. 167 | 168 | Notation "'left_child' w" := ltac:(just left_child w) 169 | (at level 199, no associativity, only parsing). 170 | 171 | Ltac right_child w := 172 | lazymatch type of w with 173 | wavltree _ _ _ _ (_++[_]++?C) => 174 | lazymatch goal with 175 | R:wavltree _ _ _ _ C |- _ => R 176 | end 177 | end. 178 | 179 | Notation "'right_child' w" := ltac:(just right_child w) 180 | (at level 199, no associativity, only parsing). 181 | 182 | Ltac datum w := 183 | lazymatch type of w with 184 | wavltree _ _ _ _ (_++[?D]++_) => D 185 | end. 186 | 187 | Notation "'datum' w" := ltac:(just datum w) 188 | (at level 199, no associativity, only parsing). 189 | 190 | Ltac gap w := 191 | lazymatch type of w with 192 | wavltree _ # ?G _ _ _ => G 193 | end. 194 | 195 | Notation "'gap' w" := ltac:(just gap w) 196 | (at level 199, no associativity, only parsing). 197 | 198 | Notation "'pick' x" := ltac:(just pick x) 199 | (at level 199, no associativity, only parsing). 200 | 201 | (*We will denote solving tactics with ! and !!. ! will always refer to the 202 | bang tactic defined in ezbool.v, which will be the workhorse for solving goals 203 | involving gaps and ranks. The boom tactic, a more powerful version of bang, 204 | which also solves interdependent goals involving shared evars, will be used 205 | within later solver tactics. !! will refer in each section to a solver tactic 206 | specific to the proofs in that section. The "[>..]" tactical is used to wrap 207 | solver tactics so that they run faster over multiple goals. This is because 208 | Coq's backtracking search is a bit too conservative when it has global focus, 209 | and this results in a loss of performance. The [>..] tactical forces proof 210 | search within it to have local focus over all subgoals.*) 211 | 212 | Tactic Notation "!" := [>bang..]. 213 | 214 | (**********************************************************************) 215 | 216 | Section Lemmas. 217 | 218 | (*Because we use Z (integers) for ranks, instead of nat, we need to prove a 219 | lower bound for ranks: *) 220 | Lemma wavl_min_rank`(w : wavltree k g lg rg c) : k >= - #1. 221 | Proof. induction w. !. Qed. 222 | 223 | (*Nodes, which have non-empty contents, must have non-negative ranks.*) 224 | Lemma wavl_node_min_rank`(w : wavltree k g lg rg c) : c <> [] -> k >= #0. 225 | Proof. 226 | ?? w. 227 | 1: pose proof (wavl_min_rank (left_child w)). (*either child would work*) 228 | !. 229 | Qed. 230 | 231 | (*reverse implication of the above*) 232 | Lemma wavl_node_nonempty`(w : wavltree k g lg rg c) : k >= #0 -> c <> [] . 233 | Proof. ?? w. !. Qed. 234 | 235 | (*Two lemmas that are used to project the field equalities from Missings: *) 236 | Lemma missing_contents`(w : wavltree (- #1) g lg rg c) : c = [] . 237 | Proof. 238 | pose proof (wavl_node_min_rank w). 239 | ?? w. !. 240 | Qed. 241 | 242 | Lemma missing_rank`(w : wavltree k g lg rg []) : k = - #1. 243 | Proof. 244 | ?? w. 245 | - fnenil. 246 | - tauto. 247 | Qed. 248 | 249 | (*A projector for the Esorted field, used by ss_setup_tactic below.*) 250 | Lemma wavl_is_sorted`(w : wavltree k g lg rg c) : Esorted c. 251 | Proof. 252 | ?? w. 253 | - assumption. 254 | - repeat econstructor. 255 | Qed. 256 | 257 | End Lemmas. 258 | 259 | (*We use the above lemmas to augment the power of the primary solver tactics 260 | bang (from ezbool.v) and solve_sorted (from solvesorted.v) by adding relevant 261 | wavltree information to the proof context prior to attempting a solution. The 262 | bang_setup_tactic is already defined for use by bang, so we redefine it to 263 | make use of the above lemmas: *) 264 | Ltac bang_setup_tactic ::= 265 | let f H := 266 | (lazymatch type of H with 267 | | wavltree _ _ _ _ _ => 268 | (*it is important that wavl_min_rank is tried last (the rest of the 269 | order doesn't matter) because wavl_min_rank always works, but 270 | produces the least specific info*) 271 | first [apply missing_rank in H 272 | |apply wavl_node_min_rank in H; [|assumption||fnenil] 273 | |apply wavl_min_rank in H] 274 | | _ => idtac 275 | end) in 276 | allhyps_td f. 277 | 278 | (*The solve_sorted tactic is defined over normal lists and NotIn, not EL or 279 | ENotIn, and does not come equipped with its own setup tactic - so we both 280 | define a setup tactic and a solver tactic that uses it, as well as calling 281 | unerase (which alters a goal with a Prop conclusion so that all erasable types 282 | are replaced by their base types):*) 283 | Ltac ss_setup_tactic := 284 | let f H := (try apply wavl_is_sorted in H) in 285 | allhyps_td f. 286 | 287 | Ltac ss := ss_setup_tactic; unerase; solve[solve_sorted]. 288 | 289 | (*The unerase tactic, defined in erasable.v, can be thought of as transforming 290 | the current goal such that all erasable data in its context becomes "normal" 291 | data - the names of hypotheses are preserved, just their types are altered. 292 | The result is that the formerly erased data becomes accessible to subsequent 293 | tactics. This is only possible if the conclusion is a Prop, as that ensures 294 | that the current goal is "uninformative": it will not be involved in the 295 | extracted program, hence the transformation from erasable to normal data is 296 | legal. However, unerase is able to do some minor things when the conclusion 297 | is not a Prop, most notably transform some equalities of erased data to 298 | equalities of normal data.*) 299 | 300 | (**********************************************************************) 301 | 302 | Section Check_Leaf_Rule. 303 | 304 | (*Check that the leaf_rule field in wavltree's Node constructor properly 305 | enforces the expected equivalence between rank 0 and leaves:*) 306 | 307 | Local Set Asymmetric Patterns. 308 | 309 | Local Definition is_leaf`(w : wavltree k g lg rg c) : bool := 310 | match w with 311 | | Node _ _ _ _ _ _ _ _ (Missing _ _ _ _) _ _ (Missing _ _ _ _) _ _ => true 312 | | _ => false 313 | end. 314 | 315 | Local Ltac destruct_match := 316 | match goal with |- context[match ?X with _ => _ end] => destruct X end. 317 | 318 | Local Lemma leaf_rule_works`(w : wavltree k g lg rg c) : k = #0 <-> is_leaf w = true. 319 | Proof. 320 | unfold is_leaf. 321 | repeat destruct_match. 322 | !. 323 | Qed. 324 | 325 | (*Note: this is a case of a non-proof-mode, non-Qed function (is_leaf) that 326 | is unfolded - an apparent violation of proof style. But, it is only used to 327 | demonstrate that the leaf-rule works.*) 328 | 329 | End Check_Leaf_Rule. 330 | 331 | (**********************************************************************) 332 | 333 | Section Find. 334 | 335 | (*A simple example: the find function. We will tend to use the same 336 | procedure for all functions: define a Result type for the function, define a 337 | simple tailored solver tactic that uses backtracking proof search, use the 338 | tactic notation !! for this solver tactic, then define the function. *) 339 | 340 | Inductive findResult(x : A)(c : EL) : Set := 341 | | Found`(_: c = lc++[x]++rc) 342 | | NotFound(_: ENotIn x c). 343 | 344 | Ltac solve_find := 345 | dintros; (*does intros, decomposes conjunctions, and substs*) 346 | reassoc; (*see note below*) 347 | ((eapply Found; reflexivity) || (eapply NotFound; ss)). 348 | 349 | (*Note: the reassoc tactic, which is defined in elist.v, is a backtracking 350 | tactic where each success is a different rewrite of a list (EL) in the 351 | conclusion with distinct top-level assocativity. We will later use reassoc as 352 | a way to force the associativity of the conclusion's contents parameter to 353 | guide proof search down different search paths corresponding to different 354 | placements of its root datum.*) 355 | 356 | Tactic Notation "!!" := [>solve_find..]. 357 | 358 | Fixpoint find(x : A)`(w : wavltree k g lg rg c) : findResult x c. 359 | Proof. 360 | (*examine w*)?? w. 361 | - (*w is Node*)?? (x =<> (datum w)). 362 | + (*x=d*)!!. 363 | + (*xd*)?? (find x) on (right_child w). !!. 365 | - (*w is Missing*)!!. 366 | Qed. 367 | 368 | End Find. 369 | 370 | (*Some auxiliary helper functions:*) 371 | 372 | Section SetGap. 373 | 374 | Tactic Notation "!!" := [>econstructor; (reflexivity || eassumption)..]. 375 | 376 | Definition setgap`(w : wavltree k ig lg rg c)(og : bool) : wavltree k #og lg rg c. 377 | Proof. ?? w. !!. Qed. 378 | 379 | End SetGap. 380 | 381 | Section GetGap. 382 | 383 | Tactic Notation "!!" := [>unshelve eexists; [eassumption || exact false | boom]..]. 384 | 385 | Definition getgap`(w : wavltree k g lg rg c) : { g' | c <> [] -> #g' = g}. 386 | Proof. ?? w. !!. Qed. 387 | 388 | Definition getgap2`(w : wavltree k g lg rg c) : { g' | k >= #0 -> #g' = g}. 389 | Proof. ?? w. !!. Qed. (*isn't used*) 390 | 391 | End GetGap. 392 | 393 | Section IsGap. 394 | 395 | Tactic Notation "!!" := [>constructor; boom..]. 396 | 397 | Notation "x ?= y" := (Bool.bool_dec x y) (only parsing). 398 | 399 | Definition isgap`(w : wavltree k g lg rg c)(g' : bool) : {k >= #0 /\ #g' = g} + {k= - #1 \/ #g' <> g}. 400 | Proof. 401 | ?? w. 402 | 1: ?? (g' ?= (gap w)). 403 | !!. 404 | Qed. 405 | 406 | End IsGap. 407 | 408 | Section IsMissing. 409 | 410 | Tactic Notation "!!" := [>constructor; boom..]. 411 | 412 | Definition isMissing`(w : wavltree k g lg rg c) : {c = [] /\ k = - #1} + {c <> [] /\ k >= #0}. 413 | Proof. ?? w. !!. Qed. 414 | 415 | End IsMissing. 416 | 417 | (*Constructing a general way to solve wavltree-conclusion goals that will 418 | culminate with solve_wavl, which will attempt to solve each wavltree goal in 419 | one of three ways: using a Missing tree, by assumption, or by Node 420 | construction - in that order.*) 421 | 422 | Ltac wavl_missing := 423 | eapply Missing; 424 | [reflexivity (* c = [] *) 425 | |boom.. (*k/lg/rg*) 426 | ]. 427 | 428 | Ltac wavl_assumption := 429 | multimatch goal with W:wavltree _ _ _ _ ?C |- wavltree _ _ _ _ ?C' => 430 | replace C' with C by (rewrite ?Eapp_assoc; reflexivity); 431 | (force exact W + force refine (setgap W _)) 432 | end;[boom..]. 433 | 434 | (*Note that wavl_assumption must be more than just "eassumption" because 435 | eassumption requires that the assumption's type parameters match the conclusion 436 | syntactically (roughly), not semantically (the actual requirement is that they 437 | be unifiable - which is mostly syntatic). For example, C and C' may not 438 | directly unify until after canonizalizing their associativity. Also, eassumption 439 | does not produce multiple solutions for backtracking. We need semantic matching 440 | with backtracking because even ring_simplify cannot guarantee canonical forms of 441 | ring terms that may involve evars - or, a better way to say this is that there 442 | is no canonical-form-based syntactic matching procedure that can involve evars 443 | and permit all possible instantiations of those evars that would produce 444 | semantic matches. For example, consider matching terms 2 and ?x + ?y in Z. 445 | They aren't directly unifiable, but there are many semantic matches. The best 446 | procedure is to solve the induced equality to something like ?x = 2 - ?y, then 447 | unify the lhs and rhs. Because Z is a ring with + invertable to -, this one 448 | solution is general. However, because booleans may be present in the wavltree 449 | rank terms (via coercion), an induced equality involving only boolean evars may 450 | not always have a single general solution, hence the need for backtracking over 451 | successes. These semantic solutions are generated by the boom tactic. 452 | 453 | Instead of eassumption, we use the "force exact" and "force refine" tacticals 454 | from utils.v within a multimatch. The multimatch, "+" tactical, and the usage 455 | of boom, provide backtracking over successes. The force tacticals create 456 | equality subgoals for each non-trivially-matching type parameter, which can 457 | then be solved (with possibly multiple successes) via boom. We can restrict 458 | the attempted assumptions (to speed things up) to just those that have the 459 | same contents modulo associativity - which is handled by the replace tactic 460 | prior to force exact. The reason for the force refine of setgap is that we 461 | also want to try assumptions that may need their gaps modified in some way to 462 | produce solutions.*) 463 | 464 | Ltac solve_wavl := 465 | dintros; 466 | (wavl_missing + wavl_assumption + wavl_construction) 467 | with wavl_construction := 468 | reassoc; 469 | eapply Node; 470 | [reflexivity (* #g = pg *) 471 | |reflexivity (* c = lc++[d]++rc *) 472 | |solve_wavl (*lw*) 473 | |solve_wavl (*rw*) 474 | |boom (*leaf_rule*) 475 | |ss (* Esorted c *) 476 | ]. 477 | 478 | (*Note that reflexivity is sufficient to solve the "#g = pg" and "c = 479 | lc++[d]++rc" subgoals above. In the first case, this is because g is introduced 480 | by Node, and so will always be an evar in this equation - and pg will itself 481 | either be an evar or a "#"'ed term due to our usage. In the second case, this 482 | is because of the reassoc tactic, and the fact that lc, d and rc will always be 483 | evars due to being introduced by Node. *) 484 | 485 | Section Insert_Rotations. 486 | 487 | (*These two insert rotation functions were created for goals encountered 488 | within the insert function (below) that involve constructing a wavltree when 489 | the required (based on contents) wavltree assumptions differ in rank by 2. 490 | That they are "rotations" only becomes evident when viewing the extracted 491 | source. However, in terms of the proofs, the decision to separate these 492 | functions is based on the need to case-analyze more than just one level of 493 | wavltree. All of the non-rotation functions directly case analyze (other 494 | than by auxiliary function such as isgap, isMissing, etc.) just one wavltree 495 | argument, as their first proof step - which implies that they never have 496 | multiple generations of wavltrees available as assumptions, and so cannot 497 | perform rotations. This demonstrates how certain meta-logical structuring 498 | of the proofs can induce some nice modularization properties (rotations are 499 | separate functions) in the extracted code.*) 500 | 501 | Tactic Notation "!!" := [>solve_wavl..]. 502 | 503 | Definition irot1`(lw : wavltree k #false llg lrg lc)(x : A)`(rw : wavltree (k - #2) #true rlg rrg rc) 504 | : llg = Enegb lrg -> Esorted(lc++[x]++rc) -> forall g, wavltree k #g #false #false (lc++[x]++rc). 505 | Proof. 506 | ?? lw. 507 | - ?? (right_child lw). 508 | + ?? (gap (right_child lw)). !!. 509 | + !!. 510 | - !. 511 | Qed. 512 | 513 | Definition irot2`(lw : wavltree (k - #2) #true llg lrg lc)(x : A)`(rw : wavltree k #false rlg rrg rc) 514 | : Enegb rlg = rrg -> Esorted(lc++[x]++rc) -> forall g, wavltree k #g #false #false (lc++[x]++rc). 515 | Proof. 516 | ?? rw. 517 | - ?? (left_child rw). 518 | + ?? (gap (left_child rw)). !!. 519 | + !!. 520 | - !. 521 | Qed. 522 | 523 | End Insert_Rotations. 524 | 525 | (*We will construct other rotation functions later for delete (and its helper 526 | functions), but all will have a similar parameterization, which allows us to 527 | create a single tactic to use them. Note that we only try assumptions to fill 528 | in the wavltree parameters for rotations. Care must be taken so that the 529 | conclusions of the rotation functions are unifiable via eapply with all 530 | potential goal conclusions, else we would need to use force refine instead to 531 | generate extra equality subgoals.*) 532 | 533 | Ltac use_rotations r1 r2 := 534 | dintros; 535 | reassoc; 536 | (eapply r1 + eapply r2); 537 | [wavl_assumption (*lw*) 538 | |wavl_assumption (*rw*) 539 | |boom (*_lg<>_rg*) 540 | |ss (*Esorted*) 541 | ]. 542 | 543 | (*There will be times when wavltrees can have their gaps "unerased" even in a 544 | non-Prop goal, because it is provable that the wavltree is not Missing and 545 | hence has a real gap field. The following unerase_gaps tactic does this. It 546 | can be used to allow case analysis of gaps directly (instead of using the 547 | isgap function), and it can also be used prior to a wavl_assumption to allow 548 | its setgap call to be solved based on those unerased gaps. Unfortunately, it 549 | cannot be called only when the need is established, because of Coq's rules 550 | about evar scopes (meaning that a gap must be unerased prior to the 551 | introduction of any evar it is meant to fill).*) 552 | 553 | Ltac unerase_gaps := 554 | subst; 555 | let f H := 556 | try 557 | lazymatch type of H with 558 | wavltree _ ?G _ _ _ => 559 | is_var G; (*H is a suitable target for gap unerasure*) 560 | case (getgap H); (*do the unerasure by calling getgap...*) 561 | let X := fresh in 562 | let G' := fresh in 563 | intros G' X; 564 | (*...and then attempt to prove that H isn't missing, so that getgap 565 | can produce the gap*) 566 | first [specialize (X ltac:(assumption||fnenil)) 567 | |specialize (X (wavl_node_nonempty H ltac:(bang)))]; 568 | (*If the above proof works, we can replace the old erasable gap var 569 | with the new unerased one, keeping the old one's name:*) 570 | rewrite <-X in *; 571 | clear X G; 572 | rename G' into G 573 | end in 574 | allhyps_td f. 575 | 576 | Section Insert. 577 | 578 | (*For insert and some of the remaining functions, we will compose the result 579 | type from multiple parts. The "innermost" part (instertedHow here) will 580 | become an enumeration on extraction - with no "informative" fields. It is 581 | separated out just for clarity. Other parts (Delout for the delete 582 | functions below) allow sharing of sub-result types.*) 583 | 584 | Inductive insertedHow(ik ok : EZ)(ig og olg org : EB) : Set := 585 | | ISameK(_: ok = ik)(_: og = ig) 586 | | IWasMissing(_: ik = - #1)(_: ok = #0)(_: og = #false) 587 | | IHigherK(_: ik >= #0)(_: ok = ik + #1)(_: olg = Enegb org)(_: og = #false). 588 | 589 | (*Note that insertedHow only needs 2 ctors - ISameK and IHigherK. However, 590 | by adding IWasMissing, we can avoid some redundant casing. The same idea 591 | doesn't work as well with the delete functions. *) 592 | 593 | Inductive insertResult(x: A)(k : EZ)(g lg rg : EB)(c : EL) : Set := 594 | | Inserted`(_: c = lc++rc) 595 | `(ow: wavltree ok og olg org (lc++[x]++rc)) 596 | `(_: insertedHow k ok g og olg org) 597 | | FoundByInsert`(_: c = lc++[x]++rc). 598 | 599 | (*Augment the generic solve_wavl with the rotation functions:*) 600 | Ltac solve_wavl2 := use_rotations irot1 irot2 + solve_wavl. 601 | 602 | (* This lemma covers the case where c is [], which can't be solved by 603 | reflexivity vs. ?lc++?rc (two evars appended).*) 604 | Lemma nilnilnil : [] = [] ++ [] :> EL. 605 | Proof. 606 | rewrite Eapp_nil_l. 607 | reflexivity. 608 | Qed. 609 | 610 | Ltac solve_insert := 611 | dintros; 612 | reassoc; 613 | ((eapply FoundByInsert; reflexivity) + 614 | (eapply Inserted; 615 | [reflexivity || eapply nilnilnil (* c = lc++rc *) 616 | |solve_wavl2 (*ow*) 617 | |econstructor;[boom..] (*insertedHow*) 618 | ])). 619 | 620 | (*Why do we solve for the output wavltree (ow) before solving for 621 | insertedHow? Only because it is about 8X faster this way, and doesn't alter 622 | the extracted output. However, it certainly would make sense to solve for 623 | insertedHow first, and thus be able to force the proof search to favor 624 | ISameK over IHigherK by trying all possible ISameK successes first.*) 625 | 626 | Tactic Notation "!!" := [>solve_insert..]. 627 | 628 | Fixpoint insert(x : A)`(w : wavltree k g lg rg c) : insertResult x k g lg rg c. 629 | Proof. 630 | ?? w. 631 | - ?? (x =<> (datum w)). 632 | + !!. 633 | + ?? (insert x) on (left_child w). 634 | * ?? (pick insertedHow). 635 | -- !!. 636 | -- ?? (isMissing (right_child w)). !!. 637 | -- unerase_gaps. ?? (gap (left_child w)). 638 | ++ !!. 639 | ++ ?? (isgap (right_child w) false). !!. 640 | * !!. 641 | + ?? (insert x) on (right_child w). 642 | * ?? (pick insertedHow). 643 | -- !!. 644 | -- ?? (isMissing (left_child w)). !!. 645 | -- unerase_gaps. ?? (gap (right_child w)). 646 | ++ !!. 647 | ++ ?? (isgap (left_child w) false). !!. 648 | * !!. 649 | - !!. 650 | Qed. 651 | 652 | (*Note: in both cases above when we use unerase_gaps, followed by casing a 653 | gap, we could instead have cased on (isgap child true) without using 654 | unerase_gaps, as is done elsewhere. Maybe there's a very small performance 655 | advantage, as the getgap function (which is what extracts when casing an 656 | unerased gap directly) contains fewer conditionals than the isgap 657 | function.*) 658 | 659 | End Insert. 660 | 661 | (**********************************************************************) 662 | 663 | Section TryLowering. 664 | 665 | (*tryLowering is a helper function for deletions - it tries to reduce the 666 | rank of a wavltree by 1 in the most trivial way - by removing the gaps (if 667 | they are both present) from both immediate children of its root. Even if 668 | the lowering fails, we learn something about those gaps that is needed for 669 | calling the delete rotations (below).*) 670 | 671 | Inductive tryLoweringResult(k : EZ)(g lg rg : EB)(c : EL) : Set := 672 | | TLlowered(_: lg = #true)(_: rg = #true)(ow: wavltree (k - #1) g #false #false c) 673 | | TLtooLow(_: lg = #false \/ rg = #false). 674 | 675 | Ltac solve_tl := 676 | dintros; 677 | ((eapply TLlowered; 678 | [reflexivity (*lg*) 679 | |reflexivity (*rg*) 680 | |solve_wavl (*ow*) 681 | ]) 682 | || (eapply TLtooLow; boom)). 683 | 684 | Tactic Notation "!!" := [>solve_tl..]. 685 | 686 | Definition tryLowering`(w : wavltree k g lg rg c) : tryLoweringResult k g lg rg c. 687 | Proof. 688 | ?? w. 689 | - ?? (isgap (left_child w) true). 690 | + ?? (isgap (right_child w) true). !!. 691 | + !!. 692 | - !!. 693 | Qed. 694 | 695 | End TryLowering. 696 | 697 | (*The remaining deletion functions will share the following result parts, and 698 | solve_delpair solver tactic:*) 699 | 700 | Inductive deletedHow(ik ok : EZ)(ig og : EB) : Set := 701 | | DSameK(_: ok = ik)(_: og = ig) 702 | | DLowerK(_: ok = ik - #1)(_: og = #true). 703 | 704 | Inductive delpair(k : EZ)(g : EB)(c : EL) : Set := 705 | | Delout`(dh : deletedHow k ok g og)`(ow : wavltree ok og olg org c). 706 | 707 | Ltac solve_delpair := 708 | dintros; 709 | eapply Delout; 710 | [constructor; [boom..] (*dh*) 711 | |solve_wavl (*ow*) 712 | ]. 713 | 714 | Section Delete_Rotations. 715 | 716 | (*These two delete rotation functions were created for goals within the 717 | delete function (later) that involve constructing a wavltree when the 718 | wavltree assumptions differ in rank by 2. That they are "rotations" only 719 | becomes evident when viewing the extracted source.*) 720 | 721 | (*Note: these two functions take the longest to prove. About 15 minutes a 722 | piece, depending obviously on hardware.*) 723 | 724 | Tactic Notation "!!" := [>solve_delpair..]. 725 | 726 | Definition drot1`(lw : wavltree (k - #3) #true llg lrg lc)(x : A)`(rw : wavltree (k - #1) #false rlg rrg rc) 727 | : rlg = #false \/ rrg = #false -> Esorted(lc++[x]++rc) -> forall g, delpair k #g (lc++[x]++rc). 728 | Proof. 729 | ?? rw. 730 | - ?? (left_child rw). 731 | + ?? (isgap (right_child rw) false); !!. 732 | + !!. 733 | - !. 734 | Qed. 735 | 736 | Definition drot2`(lw : wavltree (k - #1) #false llg lrg lc)(x : A)`(rw : wavltree (k - #3) #true rlg rrg rc) 737 | : llg = #false \/ lrg = #false -> Esorted(lc++[x]++rc) -> forall g, delpair k #g (lc++[x]++rc). 738 | Proof. 739 | ?? lw. 740 | - ?? (right_child lw). 741 | + ?? (isgap (left_child lw) false). !!. 742 | + !!. 743 | - !. 744 | Qed. 745 | 746 | End Delete_Rotations. 747 | 748 | (*Again, using the above rotations to augment a solver, this time solve_delpair:*) 749 | Ltac solve_delpair2 := use_rotations drot1 drot2 + solve_delpair. 750 | 751 | Section Delete_Minimum. 752 | 753 | (*Before defining delete, we first need at least one of the following two 754 | functions: delmin and delmax. These are used by delete to find a replacement 755 | for the deleted datum. Although we need only one, we'll define and use 756 | both. *) 757 | 758 | Inductive delminResult(k : EZ)(g : EB)(c : EL) : Set := 759 | MinDeleted(min : A)`(_: c = [min]++rc)(dp : delpair k g rc). 760 | 761 | Ltac solve_delmin := 762 | dintros; 763 | reassoc; 764 | try rewrite Eapp_nil_l; (*removes leading []++...*) 765 | eapply MinDeleted; 766 | [reflexivity|solve_delpair2]. 767 | 768 | Tactic Notation "!!" := [>solve_delmin..]. 769 | 770 | Fixpoint delmin`(w : wavltree k g lg rg c) : k >= #0 -> delminResult k g c. 771 | Proof. 772 | ?? w. 773 | - ?? (isMissing (left_child w)). 774 | + !!. 775 | + ?? delmin on (left_child w). 776 | * !. 777 | * ?? (pick delpair). ?? (pick deletedHow). 778 | -- !!. 779 | -- ?? (isgap (right_child w) false). 780 | ++ ?? (isgap (left_child w) true). 781 | ** ?? (tryLowering (right_child w)). !!. 782 | ** !!. 783 | ++ unerase_gaps. !!. 784 | - !. 785 | Qed. 786 | 787 | End Delete_Minimum. 788 | 789 | Section Delete_Maximum. 790 | 791 | Inductive delmaxResult(k : EZ)(g : EB)(c : EL) : Set := 792 | MaxDeleted(max : A)`(_: c = lc++[max])(dp : delpair k g lc). 793 | 794 | Ltac solve_delmax := 795 | dintros; 796 | reassoc; 797 | try rewrite Eapp_nil_r; (*removes trailing ...++[]*) 798 | eapply MaxDeleted; 799 | [reflexivity|solve_delpair2]. 800 | 801 | Tactic Notation "!!" := [>solve_delmax..]. 802 | 803 | Fixpoint delmax`(w : wavltree k g lg rg c) : k >= #0 -> delmaxResult k g c. 804 | Proof. 805 | ?? w. 806 | - ?? (isMissing (right_child w)). 807 | + !!. 808 | + ?? delmax on (right_child w). 809 | * !. 810 | * ?? (pick delpair). ?? (pick deletedHow). 811 | -- !!. 812 | -- ?? (isgap (left_child w) false). 813 | ++ ?? (isgap (right_child w) true). 814 | ** ?? (tryLowering (left_child w)). !!. 815 | ** !!. 816 | ++ unerase_gaps. !!. 817 | - !. 818 | Qed. 819 | 820 | End Delete_Maximum. 821 | 822 | Section Delete. 823 | 824 | (*Finally - delete - which is often omitted from formal treatments of 825 | balanced binary trees due to its proof complexity. However, the 826 | infrastructure created here can handle it without difficulty.*) 827 | 828 | Inductive deleteResult(x : A)(k : EZ)(g : EB)(c : EL) : Set := 829 | | Deleted`(_: c = lc++[x]++rc)(dp : delpair k g (lc++rc)) 830 | | DNotFound(_: ENotIn x c). 831 | 832 | Ltac solve_delete := 833 | dintros; 834 | reassoc; 835 | ((eapply Deleted; 836 | [reflexivity (* c = lc++[x]++rc *) 837 | |(rewrite Eapp_nil_r + rewrite Eapp_nil_l + idtac); solve_delpair2 838 | ]) 839 | + (eapply DNotFound; ss)). 840 | 841 | Tactic Notation "!!" := [>solve_delete..]. 842 | 843 | Fixpoint delete(x : A)`(w : wavltree k g lg rg c) : deleteResult x k g c. 844 | Proof. 845 | ?? w. 846 | - ?? (x =<> (datum w)). 847 | + ?? (isMissing (left_child w)). 848 | * !!. 849 | * ?? (isMissing (right_child w)). 850 | -- !!. 851 | -- (*decide whether to replace the root datum using delmin on the 852 | right child or delmax on the left by examining either child's 853 | gap, preferring to delete from a child with no gap (higher rank), 854 | if there is one.*) 855 | unerase_gaps. ?? (gap (left_child w)). 856 | ++ ?? (delmin (right_child w)). 857 | ** !. 858 | ** ?? (pick delpair). ?? (pick deletedHow). !!. 859 | ++ ?? (delmax (left_child w)). 860 | ** !. 861 | ** ?? (pick delpair). ?? (pick deletedHow). !!. 862 | + ?? (delete x) on (left_child w). 863 | * ?? (pick delpair). ?? (pick deletedHow). 864 | -- !!. 865 | -- unerase_gaps. ?? (gap (left_child w)). 866 | ++ unerase_gaps. ?? (gap (right_child w)). 867 | ** !!. 868 | ** ?? (tryLowering (right_child w)). !!. 869 | ++ ?? (isMissing (right_child w)). !!. 870 | * !!. 871 | + ?? (delete x) on (right_child w). 872 | * ?? (pick delpair). ?? (pick deletedHow). 873 | -- !!. 874 | -- unerase_gaps. ?? (gap (right_child w)). 875 | ++ unerase_gaps. ?? (gap (left_child w)). 876 | ** !!. 877 | ** ?? (tryLowering (left_child w)). !!. 878 | ++ ?? (isMissing (left_child w)). !!. 879 | * !!. 880 | - !!. 881 | Qed. 882 | 883 | End Delete. 884 | Show Ltac Profile CutOff 1. 885 | Set Printing Width 120. 886 | 887 | Require Import ExtrOcamlBasic. 888 | 889 | Extract Inductive delpair => "( * )" [ "" ]. 890 | Extract Inductive delminResult => "( * )" [ "" ]. 891 | Extract Inductive delmaxResult => "( * )" [ "" ]. 892 | 893 | Extraction Inline negb. 894 | 895 | Extract Inlined Constant Bool.bool_dec => "(=)". 896 | 897 | Extraction "wavl.ml" find insert delete. 898 | 899 | 900 | (* Local Variables: *) 901 | (* company-coq-local-symbols: (("++" . ?⧺) ("Esorted" . ?⊿) ("#" . ?◻) ("wavltree" . ?🎄) ("[]" . ?∅) ("^" . ?⋄) ("^#" . ?⟎) ("Enegb" . ?¬) ("true" . ?Ṫ) ("false" . ?Ḟ) ("EL" . ?Ḷ) ("EB" . ?Ḅ) ("EZ" . ?Ẓ)) *) 902 | (* End: *) 903 | -------------------------------------------------------------------------------- /wavl_noauto.ml: -------------------------------------------------------------------------------- 1 | 2 | type compareSpecT = 3 | | CompEqT 4 | | CompLtT 5 | | CompGtT 6 | 7 | type 'a sig0 = 'a 8 | (* singleton inductive, whose constructor was exist *) 9 | 10 | 11 | 12 | type a (* AXIOM TO BE REALIZED *) 13 | 14 | (** val compare_spec : a -> a -> compareSpecT **) 15 | 16 | let compare_spec = 17 | failwith "AXIOM TO BE REALIZED" 18 | 19 | type wavltree = 20 | | Node of bool * a * wavltree * wavltree 21 | | Missing 22 | 23 | type findResult = 24 | | Found 25 | | NotFound 26 | 27 | (** val find : a -> wavltree -> findResult **) 28 | 29 | let rec find x = function 30 | | Node (_, d, lw, rw) -> (match compare_spec x d with 31 | | CompEqT -> Found 32 | | CompLtT -> find x lw 33 | | CompGtT -> find x rw) 34 | | Missing -> NotFound 35 | 36 | (** val setgap : wavltree -> bool -> wavltree **) 37 | 38 | let setgap w og = 39 | match w with 40 | | Node (_, d, lw, rw) -> Node (og, d, lw, rw) 41 | | Missing -> Missing 42 | 43 | (** val getgap : wavltree -> bool **) 44 | 45 | let getgap = function 46 | | Node (g0, _, _, _) -> g0 47 | | Missing -> false 48 | 49 | (** val isgap : wavltree -> bool -> bool **) 50 | 51 | let isgap w g' = 52 | match w with 53 | | Node (g0, _, _, _) -> (=) g' g0 54 | | Missing -> false 55 | 56 | (** val isMissing : wavltree -> bool **) 57 | 58 | let isMissing = function 59 | | Node (_, _, _, _) -> false 60 | | Missing -> true 61 | 62 | (** val irot1 : wavltree -> a -> wavltree -> bool -> wavltree **) 63 | 64 | let irot1 lw x rw g = 65 | match lw with 66 | | Node (_, d, lw0, rw0) -> 67 | (match rw0 with 68 | | Node (g1, d0, lw1, rw1) -> 69 | if g1 70 | then Node (g, d, lw0, (Node (false, x, (setgap rw0 false), (setgap rw false)))) 71 | else Node (g, d0, (Node (false, d, (setgap lw0 false), lw1)), (Node (false, x, rw1, (setgap rw false)))) 72 | | Missing -> Node (g, d, lw0, (Node (false, x, Missing, Missing)))) 73 | | Missing -> assert false (* absurd case *) 74 | 75 | (** val irot2 : wavltree -> a -> wavltree -> bool -> wavltree **) 76 | 77 | let irot2 lw x rw g = 78 | match rw with 79 | | Node (_, d, lw0, rw0) -> 80 | (match lw0 with 81 | | Node (g1, d0, lw1, rw1) -> 82 | if g1 83 | then Node (g, d, (Node (false, x, (setgap lw false), (setgap lw0 false))), rw0) 84 | else Node (g, d0, (Node (false, x, (setgap lw false), lw1)), (Node (false, d, rw1, (setgap rw0 false)))) 85 | | Missing -> Node (g, d, (Node (false, x, Missing, Missing)), rw0)) 86 | | Missing -> assert false (* absurd case *) 87 | 88 | type insertedHow = 89 | | ISameK 90 | | IWasMissing 91 | | IHigherK 92 | 93 | type insertResult = 94 | | Inserted of wavltree * insertedHow 95 | | FoundByInsert 96 | 97 | (** val insert : a -> wavltree -> insertResult **) 98 | 99 | let rec insert x = function 100 | | Node (g0, d, lw, rw) -> 101 | (match compare_spec x d with 102 | | CompEqT -> FoundByInsert 103 | | CompLtT -> 104 | (match insert x lw with 105 | | Inserted (ow, insertedHow0) -> 106 | (match insertedHow0 with 107 | | ISameK -> Inserted ((Node (g0, d, ow, rw)), ISameK) 108 | | IWasMissing -> 109 | if isMissing rw 110 | then Inserted ((Node (false, d, ow, Missing)), IHigherK) 111 | else Inserted ((Node (g0, d, ow, rw)), ISameK) 112 | | IHigherK -> 113 | if getgap lw 114 | then Inserted ((Node (g0, d, ow, rw)), ISameK) 115 | else if isgap rw false 116 | then Inserted ((Node (false, d, ow, (setgap rw true))), IHigherK) 117 | else Inserted ((irot1 ow d rw g0), ISameK)) 118 | | FoundByInsert -> FoundByInsert) 119 | | CompGtT -> 120 | (match insert x rw with 121 | | Inserted (ow, insertedHow0) -> 122 | (match insertedHow0 with 123 | | ISameK -> Inserted ((Node (g0, d, lw, ow)), ISameK) 124 | | IWasMissing -> 125 | if isMissing lw 126 | then Inserted ((Node (false, d, Missing, ow)), IHigherK) 127 | else Inserted ((Node (g0, d, lw, ow)), ISameK) 128 | | IHigherK -> 129 | if getgap rw 130 | then Inserted ((Node (g0, d, lw, ow)), ISameK) 131 | else if isgap lw false 132 | then Inserted ((Node (false, d, (setgap lw true), ow)), IHigherK) 133 | else Inserted ((irot2 lw d ow g0), ISameK)) 134 | | FoundByInsert -> FoundByInsert)) 135 | | Missing -> Inserted ((Node (false, x, Missing, Missing)), IWasMissing) 136 | 137 | type tryLoweringResult = 138 | | TLlowered of wavltree 139 | | TLtooLow 140 | 141 | (** val tryLowering : wavltree -> tryLoweringResult **) 142 | 143 | let tryLowering = function 144 | | Node (g0, d, lw, rw) -> 145 | if isgap lw true 146 | then if isgap rw true then TLlowered (Node (g0, d, (setgap lw false), (setgap rw false))) else TLtooLow 147 | else TLtooLow 148 | | Missing -> TLtooLow 149 | 150 | type deletedHow = 151 | | DSameK 152 | | DLowerK 153 | 154 | (** val drot1 : wavltree -> a -> wavltree -> bool -> ( * ) **) 155 | 156 | let drot1 lw x rw g = 157 | match rw with 158 | | Node (_, d, lw0, rw0) -> 159 | (match lw0 with 160 | | Node (_, d0, lw1, rw1) -> 161 | if isgap rw0 false 162 | then (DSameK, (Node (g, d, (Node (false, x, lw, lw0)), (setgap rw0 true)))) 163 | else (DSameK, (Node (g, d0, (Node (true, x, (setgap lw false), lw1)), (Node (true, d, rw1, 164 | (setgap rw0 false)))))) 165 | | Missing -> (DSameK, (Node (g, d, (Node (true, x, Missing, Missing)), (setgap rw0 true))))) 166 | | Missing -> assert false (* absurd case *) 167 | 168 | (** val drot2 : wavltree -> a -> wavltree -> bool -> ( * ) **) 169 | 170 | let drot2 lw x rw g = 171 | match lw with 172 | | Node (_, d, lw0, rw0) -> 173 | (match rw0 with 174 | | Node (_, d0, lw1, rw1) -> 175 | if isgap lw0 false 176 | then (DSameK, (Node (g, d, (setgap lw0 true), (Node (false, x, rw0, rw))))) 177 | else (DSameK, (Node (g, d0, (Node (true, d, (setgap lw0 false), lw1)), (Node (true, x, rw1, 178 | (setgap rw false)))))) 179 | | Missing -> (DSameK, (Node (g, d, (setgap lw0 true), (Node (true, x, Missing, Missing)))))) 180 | | Missing -> assert false (* absurd case *) 181 | 182 | (** val delmin : wavltree -> ( * ) **) 183 | 184 | let rec delmin = function 185 | | Node (g0, d, lw, rw) -> 186 | if isMissing lw 187 | then (d, (DLowerK, (setgap rw true))) 188 | else let (min, dp) = delmin lw in 189 | let (dh, ow) = dp in 190 | (match dh with 191 | | DSameK -> (min, (DSameK, (Node (g0, d, ow, rw)))) 192 | | DLowerK -> 193 | if isgap rw false 194 | then if isgap lw true 195 | then (match tryLowering rw with 196 | | TLlowered ow0 -> (min, (DLowerK, (Node (true, d, ow, ow0)))) 197 | | TLtooLow -> (min, (drot1 ow d rw g0))) 198 | else (min, (DSameK, (Node (g0, d, ow, rw)))) 199 | else (min, (DLowerK, (Node (true, d, (setgap ow (getgap lw)), (setgap rw false)))))) 200 | | Missing -> assert false (* absurd case *) 201 | 202 | (** val delmax : wavltree -> ( * ) **) 203 | 204 | let rec delmax = function 205 | | Node (g0, d, lw, rw) -> 206 | if isMissing rw 207 | then (d, (DLowerK, (setgap lw true))) 208 | else let (max, dp) = delmax rw in 209 | let (dh, ow) = dp in 210 | (match dh with 211 | | DSameK -> (max, (DSameK, (Node (g0, d, lw, ow)))) 212 | | DLowerK -> 213 | if isgap lw false 214 | then if isgap rw true 215 | then (match tryLowering lw with 216 | | TLlowered ow0 -> (max, (DLowerK, (Node (true, d, ow0, ow)))) 217 | | TLtooLow -> (max, (drot2 lw d ow g0))) 218 | else (max, (DSameK, (Node (g0, d, lw, ow)))) 219 | else (max, (DLowerK, (Node (true, d, (setgap lw false), (setgap ow (getgap rw))))))) 220 | | Missing -> assert false (* absurd case *) 221 | 222 | type deleteResult = 223 | | Deleted of ( * ) 224 | | DNotFound 225 | 226 | (** val delete : a -> wavltree -> deleteResult **) 227 | 228 | let rec delete x = function 229 | | Node (g0, d, lw, rw) -> 230 | (match compare_spec x d with 231 | | CompEqT -> 232 | if isMissing lw 233 | then Deleted (DLowerK, (setgap rw true)) 234 | else if isMissing rw 235 | then Deleted (DLowerK, (setgap lw true)) 236 | else if getgap lw 237 | then let (min, dp) = delmin rw in 238 | let (dh, ow) = dp in 239 | (match dh with 240 | | DSameK -> Deleted (DSameK, (Node (g0, min, lw, ow))) 241 | | DLowerK -> Deleted (DLowerK, (Node (true, min, (setgap lw false), (setgap ow (getgap rw)))))) 242 | else let (max, dp) = delmax lw in let (_, ow) = dp in Deleted (DSameK, (Node (g0, max, ow, rw))) 243 | | CompLtT -> 244 | (match delete x lw with 245 | | Deleted dp -> 246 | let (dh, ow) = dp in 247 | (match dh with 248 | | DSameK -> Deleted (DSameK, (Node (g0, d, ow, rw))) 249 | | DLowerK -> 250 | if getgap lw 251 | then if getgap rw 252 | then Deleted (DLowerK, (Node (true, d, ow, (setgap rw false)))) 253 | else (match tryLowering rw with 254 | | TLlowered ow0 -> Deleted (DLowerK, (Node (true, d, ow, ow0))) 255 | | TLtooLow -> Deleted (drot1 ow d rw g0)) 256 | else if isMissing rw 257 | then Deleted (DLowerK, (Node (true, d, (setgap ow false), Missing))) 258 | else Deleted (DSameK, (Node (g0, d, ow, rw)))) 259 | | DNotFound -> DNotFound) 260 | | CompGtT -> 261 | (match delete x rw with 262 | | Deleted dp -> 263 | let (dh, ow) = dp in 264 | (match dh with 265 | | DSameK -> Deleted (DSameK, (Node (g0, d, lw, ow))) 266 | | DLowerK -> 267 | if getgap rw 268 | then if getgap lw 269 | then Deleted (DLowerK, (Node (true, d, (setgap lw false), ow))) 270 | else (match tryLowering lw with 271 | | TLlowered ow0 -> Deleted (DLowerK, (Node (true, d, ow0, ow))) 272 | | TLtooLow -> Deleted (drot2 lw d ow g0)) 273 | else if isMissing lw 274 | then Deleted (DLowerK, (Node (true, d, Missing, (setgap ow false)))) 275 | else Deleted (DSameK, (Node (g0, d, lw, ow)))) 276 | | DNotFound -> DNotFound)) 277 | | Missing -> DNotFound 278 | -------------------------------------------------------------------------------- /wavl_noauto.mli: -------------------------------------------------------------------------------- 1 | 2 | type compareSpecT = 3 | | CompEqT 4 | | CompLtT 5 | | CompGtT 6 | 7 | type 'a sig0 = 'a 8 | (* singleton inductive, whose constructor was exist *) 9 | 10 | 11 | 12 | type a (* AXIOM TO BE REALIZED *) 13 | 14 | val compare_spec : a -> a -> compareSpecT 15 | 16 | type wavltree = 17 | | Node of bool * a * wavltree * wavltree 18 | | Missing 19 | 20 | type findResult = 21 | | Found 22 | | NotFound 23 | 24 | val find : a -> wavltree -> findResult 25 | 26 | val setgap : wavltree -> bool -> wavltree 27 | 28 | val getgap : wavltree -> bool 29 | 30 | val isgap : wavltree -> bool -> bool 31 | 32 | val isMissing : wavltree -> bool 33 | 34 | val irot1 : wavltree -> a -> wavltree -> bool -> wavltree 35 | 36 | val irot2 : wavltree -> a -> wavltree -> bool -> wavltree 37 | 38 | type insertedHow = 39 | | ISameK 40 | | IWasMissing 41 | | IHigherK 42 | 43 | type insertResult = 44 | | Inserted of wavltree * insertedHow 45 | | FoundByInsert 46 | 47 | val insert : a -> wavltree -> insertResult 48 | 49 | type tryLoweringResult = 50 | | TLlowered of wavltree 51 | | TLtooLow 52 | 53 | val tryLowering : wavltree -> tryLoweringResult 54 | 55 | type deletedHow = 56 | | DSameK 57 | | DLowerK 58 | 59 | val drot1 : wavltree -> a -> wavltree -> bool -> ( * ) 60 | 61 | val drot2 : wavltree -> a -> wavltree -> bool -> ( * ) 62 | 63 | val delmin : wavltree -> ( * ) 64 | 65 | val delmax : wavltree -> ( * ) 66 | 67 | type deleteResult = 68 | | Deleted of ( * ) 69 | | DNotFound 70 | 71 | val delete : a -> wavltree -> deleteResult 72 | -------------------------------------------------------------------------------- /wavl_noauto.v: -------------------------------------------------------------------------------- 1 | 2 | (*** Weak AVL Trees ***) 3 | 4 | (*+ 5 | See "Rank-Balanced Trees" by Haeupler, Sen, Tarjan 6 | [http://www.cs.princeton.edu/~sssix/papers/rb-trees-talg.pdf]. 7 | *) 8 | 9 | (* A non-automated (actually, semi-automated) version of wavl.v, with no 10 | tailored specific solver tactics. Note that the general "boom" and "ss" 11 | automation tactics are still used throughout. *) 12 | Set Ltac Profiling. 13 | Reset Ltac Profile. 14 | Require Import mindless.elist. 15 | Require Import mindless.ezbool. 16 | Require Import mindless.utils. 17 | Require Import mindless.hypiter. 18 | 19 | Generalizable All Variables. 20 | 21 | Set Default Goal Selector "all". 22 | 23 | Context {A : Set}. 24 | 25 | Context {ordA : Ordered A}. 26 | 27 | Context {compare : A -> A -> comparison}. 28 | 29 | Context {compare_spec : forall x y, CompareSpecT (eq x y) (lt x y) (lt y x) (compare x y)}. 30 | 31 | Notation "x =<> y" := (compare_spec x y) (at level 70, only parsing). 32 | 33 | Notation EL := ##(list A). 34 | Notation EZ := ##Z. 35 | Notation EB := ##bool. 36 | 37 | Open Scope E_scope. 38 | 39 | Inductive wavltree (k : EZ)(pg lg rg : EB)(c : EL) : Set := 40 | | Node(g : bool)(d : A) 41 | (_: #g = pg) 42 | `(_: c = lc++[d]++rc) 43 | `(lw : wavltree (k - #1 - ^lg) lg llg lrg lc) 44 | `(rw : wavltree (k - #1 - ^rg) rg rlg rrg rc) 45 | (leaf_rule: k = #1 -> lg = #false \/ rg = #false) 46 | (_: Esorted c) 47 | | Missing(_: c = [])(_: k = - #1)(_: lg = #false)(_: rg = #false). 48 | 49 | (**********************************************************************) 50 | 51 | (*Tactic notations to make the proofs more readable:*) 52 | 53 | Tactic Notation "??" constr(H) := 54 | (tryif (is_var H; try (clear H; 55 | fail 1)) 56 | then case_eq H 57 | else case H); 58 | dintros. 59 | 60 | Tactic Notation "??" constr(H) "on" constr(H') := 61 | case H with (1:=H'); dintros. 62 | 63 | Tactic Notation "just" tactic1(tac) := let x := tac in exact x. 64 | 65 | Ltac left_child w := 66 | lazymatch type of w with 67 | wavltree _ _ _ _ (?C++[_]++_) => 68 | lazymatch goal with 69 | L:wavltree _ _ _ _ C |- _ => L 70 | end 71 | end. 72 | 73 | Notation "'left_child' w" := ltac:(just left_child w) 74 | (at level 199, no associativity, only parsing). 75 | 76 | Ltac right_child w := 77 | lazymatch type of w with 78 | wavltree _ _ _ _ (_++[_]++?C) => 79 | lazymatch goal with 80 | R:wavltree _ _ _ _ C |- _ => R 81 | end 82 | end. 83 | 84 | Notation "'right_child' w" := ltac:(just right_child w) 85 | (at level 199, no associativity, only parsing). 86 | 87 | Ltac datum w := 88 | lazymatch type of w with 89 | wavltree _ _ _ _ (_++[?D]++_) => D 90 | end. 91 | 92 | Notation "'datum' w" := ltac:(just datum w) 93 | (at level 199, no associativity, only parsing). 94 | 95 | Ltac gap w := 96 | lazymatch type of w with 97 | wavltree _ # ?G _ _ _ => G 98 | end. 99 | 100 | Notation "'gap' w" := ltac:(just gap w) 101 | (at level 199, no associativity, only parsing). 102 | 103 | Notation "'pick' x" := ltac:(just pick x) 104 | (at level 199, no associativity, only parsing). 105 | 106 | (**********************************************************************) 107 | 108 | Section Lemmas. 109 | 110 | Lemma wavl_min_rank`(w : wavltree k g lg rg c) : k >= - #1. 111 | Proof. 112 | induction w. boom. 113 | Qed. 114 | 115 | Lemma wavl_node_min_rank`(w : wavltree k g lg rg c) : c <> [] -> k >= #0. 116 | Proof. 117 | ?? w. 1:pose proof (wavl_min_rank (left_child w)). boom. 118 | Qed. 119 | 120 | Lemma wavl_node_nonempty`(w : wavltree k g lg rg c) : k >= #0 -> c <> []. 121 | Proof. 122 | ?? w. boom. 123 | Qed. 124 | 125 | Lemma missing_contents`(w : wavltree (- #1) g lg rg c) : c = []. 126 | Proof. 127 | pose proof (wavl_node_min_rank w) as H. 128 | ?? w. boom. 129 | Qed. 130 | 131 | Lemma missing_rank`(w : wavltree k g lg rg []) : k = - #1. 132 | Proof. 133 | ?? w. 134 | - fnenil. 135 | - reflexivity. 136 | Qed. 137 | 138 | Lemma wavl_is_sorted`(w : wavltree k g lg rg c) : Esorted c. 139 | Proof. 140 | ?? w. 141 | - assumption. 142 | - repeat econstructor. 143 | Qed. 144 | 145 | End Lemmas. 146 | 147 | Ltac bang_setup_tactic ::= idtac; 148 | let f H := 149 | (lazymatch type of H with 150 | | wavltree _ _ _ _ _ => 151 | first [apply missing_rank in H 152 | |apply wavl_node_min_rank in H; [|assumption||fnenil] 153 | |apply wavl_min_rank in H] 154 | | _ => idtac 155 | end) in 156 | allhyps_introing f. 157 | 158 | Ltac ss_setup_tactic := idtac; 159 | let f H := (try apply wavl_is_sorted in H) in 160 | allhyps_introing f. 161 | 162 | Ltac ss := ss_setup_tactic; unerase; solve[solve_sorted]. 163 | 164 | (**********************************************************************) 165 | 166 | Section Check_Leaf_Rule. 167 | 168 | Local Set Asymmetric Patterns. 169 | 170 | Local Definition is_leaf`(w : wavltree k g lg rg c) : bool := 171 | match w with 172 | | Node _ _ _ _ _ _ _ _ (Missing _ _ _ _) _ _ (Missing _ _ _ _) _ _ => true 173 | | _ => false 174 | end. 175 | 176 | Local Ltac destruct_match := idtac; 177 | match goal with |- context[match ?X with _ => _ end] => destruct X end. 178 | 179 | Local Lemma leaf_rule_works`(w : wavltree k g lg rg c) : k = #0 <-> is_leaf w = true. 180 | Proof. 181 | unfold is_leaf. 182 | repeat destruct_match. 183 | boom. 184 | Qed. 185 | 186 | End Check_Leaf_Rule. 187 | 188 | (**********************************************************************) 189 | 190 | Section Find. 191 | 192 | Inductive findResult(x : A)(c : EL) : Set := 193 | | Found`(_: c = lc++[x]++rc) 194 | | NotFound(_: ENotIn x c). 195 | 196 | Fixpoint find(x : A)`(w : wavltree k g lg rg c) : findResult x c. 197 | Proof. 198 | ?? w. 199 | - ?? (x =<> (datum w)). 200 | + eapply Found. reflexivity. 201 | + ?? (find x) on (left_child w). 202 | * eapply Found. rootify x. reflexivity. 203 | * eapply NotFound. ss. 204 | + ?? (find x) on (right_child w). 205 | * eapply Found. rootify x. reflexivity. 206 | * eapply NotFound. ss. 207 | - eapply NotFound. ss. 208 | Qed. 209 | 210 | End Find. 211 | 212 | Section SetGap. 213 | 214 | Definition setgap`(w : wavltree k ig lg rg c)(og : bool) : wavltree k #og lg rg c. 215 | Proof. 216 | ?? w. 217 | - eapply Node. reflexivity + eassumption. 218 | - eapply Missing. reflexivity. 219 | Qed. 220 | 221 | End SetGap. 222 | 223 | Section GetGap. 224 | 225 | Definition getgap`(w : wavltree k g lg rg c) : { g' | c <> [] -> #g' = g}. 226 | Proof. 227 | ?? w. 228 | - eexists. reflexivity. 229 | - exists false. boom. 230 | Qed. 231 | 232 | Definition getgap2`(w : wavltree k g lg rg c) : { g' | k >= #0 -> #g' = g}. 233 | Proof. 234 | ?? w. 235 | - eexists. reflexivity. 236 | - exists false. boom. 237 | Qed. 238 | 239 | End GetGap. 240 | 241 | Section IsGap. 242 | 243 | Notation "x ?= y" := (Bool.bool_dec x y) (only parsing). 244 | 245 | Definition isgap`(w : wavltree k g lg rg c)(g' : bool) : {k >= #0 /\ #g' = g} + {k= - #1 \/ #g' <> g}. 246 | Proof. 247 | ?? w. 248 | - ?? (g' ?= (gap w)). 249 | + left. boom. 250 | + right. boom. 251 | - right. boom. 252 | Qed. 253 | 254 | End IsGap. 255 | 256 | Section IsMissing. 257 | 258 | Definition isMissing`(w : wavltree k g lg rg c) : {c = [] /\ k = - #1} + {c <> [] /\ k >= #0}. 259 | Proof. 260 | ?? w. 261 | - right. boom. 262 | - left. boom. 263 | Qed. 264 | 265 | End IsMissing. 266 | 267 | Ltac start_node := eapply Node; [reflexivity|reflexivity|..]. 268 | Ltac missing := eapply Missing; [reflexivity|boom|reflexivity|reflexivity]. 269 | Ltac use w := idtac; force refine w by boom. 270 | Ltac use_regap w := idtac; force refine (setgap w _) by boom. 271 | Ltac use_node := idtac; 272 | lazymatch goal with 273 | w: wavltree _ _ _ _ ?C |- wavltree _ _ _ _ ?C => use w + use_regap w 274 | end. 275 | Ltac finish := idtac; 276 | match goal with 277 | | |- Esorted _ => ss 278 | | _ => boom 279 | end. 280 | 281 | Section Insert_Rotations. 282 | 283 | Definition irot1`(lw : wavltree k #false llg lrg lc)(x : A)`(rw : wavltree (k - #2) #true rlg rrg rc) 284 | : llg = Enegb lrg -> Esorted(lc++[x]++rc) -> forall g, wavltree k #g #false #false (lc++[x]++rc). 285 | Proof. 286 | (* lw is higher than rw (k > k-2), so it makes sense to examine lw first *) 287 | ?? lw. 288 | - (* The right child of lw, rw0, needs to be combined somehow with rw. rw0 289 | might be at the same height or 1 above rw, so that needs to be 290 | determined first. But, if we first examine rw0 before examining its 291 | gap, we can eliminate the case when it is missing *) 292 | ?? (right_child lw). 293 | + (* rw0 is not missing, so examine its gap now *) 294 | ?? (gap (right_child lw)). 295 | * (* rw0 has a gap, so it is at k-2, the same as rw, which means the two 296 | can be combined easily with the result not havng a gap, so still 297 | fitting under k, rooted where lw already is *) 298 | rootify (datum lw). start_node. 299 | -- exact (left_child lw). 300 | -- rootify x. start_node. 301 | ++ use_regap (right_child lw). 302 | ++ use_regap rw. 303 | ++ finish. 304 | ++ finish. 305 | -- finish. 306 | -- finish. 307 | * (* rw0 has no gap, so we have to split it up with its left child lw1 308 | pairing with lw0, the regapped left child of lw, and its right 309 | child rw1 pairing with regapped rw, with the new root where rw0 310 | is *) 311 | rootify (datum (right_child lw)). start_node. 312 | -- start_node. 313 | ++ use_regap (left_child lw). 314 | ++ use (left_child (right_child lw)). 315 | ++ finish. 316 | ++ finish. 317 | -- start_node. 318 | ++ use (right_child (right_child lw)). 319 | ++ use_regap rw. 320 | ++ finish. 321 | ++ finish. 322 | -- finish. 323 | -- finish. 324 | + (* rw0 is missing - note that its sequence is now [] *) 325 | assert (k = #1) as -> by boom. rsimp. 326 | (* note that his implies rw is missing as well, because its height is -1 *) 327 | apply missing_contents in rw as ->. 328 | rootify (datum lw). start_node. 329 | * use (left_child lw). 330 | * start_node. 331 | -- missing. 332 | -- missing. 333 | -- finish. 334 | -- finish. 335 | * finish. 336 | * finish. 337 | - (* lw is missing, but that's not possible because rw is lower, so there is 338 | a contradiction *) 339 | boom. 340 | Qed. 341 | 342 | Definition irot2`(lw : wavltree (k - #2) #true llg lrg lc)(x : A)`(rw : wavltree k #false rlg rrg rc) 343 | : Enegb rlg = rrg -> Esorted(lc++[x]++rc) -> forall g, wavltree k #g #false #false (lc++[x]++rc). 344 | Proof. 345 | ?? rw. 346 | - ?? (left_child rw). 347 | + ?? (gap (left_child rw)). 348 | * rootify (datum rw). start_node. 349 | -- start_node. 350 | ++ use_node. (*use_regap lw.*) 351 | ++ use_node. (*use_regap (left_child rw).*) 352 | ++ finish. 353 | ++ finish. 354 | -- use_node. (*use (right_child rw).*) 355 | -- finish. 356 | -- finish. 357 | * rootify (datum (left_child rw)). start_node. 358 | -- start_node. 359 | ++ use_node. (*use_regap lw.*) 360 | ++ use_node. (*use (left_child (left_child rw)).*) 361 | ++ finish. 362 | ++ finish. 363 | -- start_node. 364 | ++ use_node. (*use (right_child (left_child rw)).*) 365 | ++ use_node. (*use_regap (right_child rw).*) 366 | ++ finish. 367 | ++ finish. 368 | -- finish. 369 | -- finish. 370 | + assert (k = #1) as -> by boom. rsimp. apply missing_contents in lw as ->. 371 | rootify (datum rw). start_node. 372 | * start_node. 373 | -- missing. 374 | -- missing. 375 | -- finish. 376 | -- finish. 377 | * use_node. (*use (right_child rw).*) 378 | * finish. 379 | * finish. 380 | - boom. 381 | Qed. 382 | 383 | End Insert_Rotations. 384 | 385 | Ltac unerase_gaps := 386 | subst; 387 | let f H := 388 | try 389 | lazymatch type of H with 390 | wavltree _ ?G _ _ _ => 391 | is_var G; 392 | case (getgap H); 393 | let X := fresh in 394 | let G' := fresh in 395 | intros G' X; 396 | first [specialize (X ltac:(assumption||fnenil)) 397 | |specialize (X (wavl_node_nonempty H ltac:(boom)))]; 398 | rewrite <-X in *; 399 | clear X G; 400 | rename G' into G 401 | end in 402 | allhyps_td f. (*cannot be allhyps_introing because of rewrite?*) 403 | 404 | Section Insert. 405 | 406 | Inductive insertedHow(ik ok : EZ)(ig og olg org : EB) : Set := 407 | | ISameK(_: ok = ik)(_: og = ig) 408 | | IWasMissing(_: ik = - #1)(_: ok = #0)(_: og = #false) 409 | | IHigherK(_: ik >= #0)(_: ok = ik + #1)(_: olg = Enegb org)(_: og = #false). 410 | 411 | Inductive insertResult(x: A)(k : EZ)(g lg rg : EB)(c : EL) : Set := 412 | | Inserted`(_: c = lc++rc) 413 | `(ow: wavltree ok og olg org (lc++[x]++rc)) 414 | `(_: insertedHow k ok g og olg org) 415 | | FoundByInsert`(_: c = lc++[x]++rc). 416 | 417 | Lemma nilnilnil : [] = [] ++ [] :> EL. 418 | Proof. 419 | rewrite Eapp_nil_l. 420 | reflexivity. 421 | Qed. 422 | 423 | Ltac tree_with x := idtac; 424 | match goal with 425 | H:wavltree _ _ _ _ ?C |- _ => 426 | lazymatch C with context[x] => H end 427 | end. 428 | 429 | Notation "'tree_with' x" := ltac:(just tree_with x) 430 | (at level 199, no associativity, only parsing). 431 | 432 | Fixpoint insert(x : A)`(w : wavltree k g lg rg c) : insertResult x k g lg rg c. 433 | Proof. 434 | ?? w. 435 | - ?? (x =<> (datum w)). 436 | + eapply FoundByInsert. reflexivity. 437 | + ?? (insert x) on (left_child w). 438 | * ?? (pick insertedHow). 439 | -- assoc 0. eapply Inserted. 440 | ++ reflexivity. 441 | ++ rootify (datum w). start_node. 442 | ** use_node. (*use (tree_with x).*) 443 | ** use_node. (*use (right_child w).*) 444 | ** finish. 445 | ** finish. 446 | ++ eapply ISameK. boom. 447 | -- ?? (isMissing (right_child w)). 448 | ++ assoc 0. eapply Inserted. 449 | ** reflexivity. 450 | ** rootify (datum w). start_node. 451 | --- use_node. (*use (tree_with x).*) 452 | --- missing. 453 | --- finish. 454 | --- finish. 455 | ** eapply IHigherK. boom. 456 | ++ assoc 0. eapply Inserted. 457 | ** reflexivity. 458 | ** rootify (datum w). start_node. 459 | --- use_node. (*use (tree_with x).*) 460 | --- use_node. (*use (right_child w).*) 461 | --- finish. 462 | --- finish. 463 | ** eapply ISameK. boom. 464 | -- unerase_gaps. ?? (gap (left_child w)). 465 | ++ assoc 0. eapply Inserted. 466 | ** reflexivity. 467 | ** rootify (datum w). start_node. 468 | --- use_node. (*use (tree_with x).*) 469 | --- use_node. (*use (right_child w).*) 470 | --- finish. 471 | --- finish. 472 | ** eapply ISameK. boom. 473 | ++ ?? (isgap (right_child w) false). 474 | ** assoc 0. eapply Inserted. 475 | --- reflexivity. 476 | --- rootify (datum w). start_node. 477 | +++ use_node. (*use (tree_with x).*) 478 | +++ use_node. (*use_regap (right_child w).*) 479 | +++ finish. 480 | +++ finish. 481 | --- eapply IHigherK. boom. 482 | ** assoc 0. eapply Inserted. 483 | --- reflexivity. 484 | --- rootify (datum w). eapply irot1. 485 | +++ use_node. (*use (tree_with x).*) 486 | +++ use_node. (*use (right_child w).*) 487 | +++ finish. 488 | +++ finish. 489 | --- eapply ISameK. boom. 490 | * rootify x. eapply FoundByInsert. reflexivity. 491 | + ?? (insert x) on (right_child w). 492 | * ?? (pick insertedHow). 493 | -- assoc 2. eapply Inserted. 494 | ++ reflexivity. 495 | ++ rootify (datum w). start_node. 496 | ** use_node. (*use (left_child w).*) 497 | ** use_node. (*use (tree_with x).*) 498 | ** finish. 499 | ** finish. 500 | ++ eapply ISameK. boom. 501 | -- ?? (isMissing (left_child w)). 502 | ++ assoc 2. eapply Inserted. 503 | ** reflexivity. 504 | ** rootify (datum w). start_node. 505 | --- missing. 506 | --- use_node. (*use (tree_with x).*) 507 | --- finish. 508 | --- finish. 509 | ** eapply IHigherK. boom. 510 | ++ assoc 2. eapply Inserted. 511 | ** reflexivity. 512 | ** rootify (datum w). start_node. 513 | --- use_node. (*use (left_child w).*) 514 | --- use_node. (*use (tree_with x).*) 515 | --- finish. 516 | --- finish. 517 | ** eapply ISameK. boom. 518 | -- unerase_gaps. ?? (gap (right_child w)). 519 | ++ assoc 2. eapply Inserted. 520 | ** reflexivity. 521 | ** rootify (datum w). start_node. 522 | --- use_node. (*use (left_child w).*) 523 | --- use_node. (*use (tree_with x).*) 524 | --- finish. 525 | --- finish. 526 | ** eapply ISameK. boom. 527 | ++ ?? (isgap (left_child w) false). 528 | ** assoc 2. eapply Inserted. 529 | --- reflexivity. 530 | --- rootify (datum w). start_node. all: [>use_node|use_node|..]. 531 | (* +++ use_regap (left_child w). 532 | +++ use (tree_with x). *) 533 | +++ finish. 534 | +++ finish. 535 | --- eapply IHigherK. boom. 536 | ** assoc 2. eapply Inserted. 537 | --- reflexivity. 538 | --- rootify (datum w). eapply irot2. 539 | +++ use_node. (*use (left_child w).*) 540 | +++ use_node. (*use (tree_with x).*) 541 | +++ finish. 542 | +++ finish. 543 | --- eapply ISameK. boom. 544 | * rootify x. eapply FoundByInsert. reflexivity. 545 | - eapply Inserted. 546 | + eapply nilnilnil. 547 | + start_node. 548 | * missing. 549 | * missing. 550 | * finish. 551 | * finish. 552 | + eapply IWasMissing. boom. 553 | Qed. 554 | 555 | End Insert. 556 | 557 | (**********************************************************************) 558 | 559 | Section TryLowering. 560 | 561 | Inductive tryLoweringResult(k : EZ)(g lg rg : EB)(c : EL) : Set := 562 | | TLlowered(_: lg = #true)(_: rg = #true)(ow: wavltree (k - #1) g #false #false c) 563 | | TLtooLow(_: lg = #false \/ rg = #false). 564 | 565 | Definition tryLowering`(w : wavltree k g lg rg c) : tryLoweringResult k g lg rg c. 566 | Proof. 567 | ?? w. 568 | - ?? (isgap (left_child w) true). 569 | + ?? (isgap (right_child w) true). 570 | * eapply TLlowered. 571 | -- reflexivity. 572 | -- reflexivity. 573 | -- start_node. 574 | ++ use_node. (*use_regap (left_child w).*) 575 | ++ use_node. (*use_regap (right_child w).*) 576 | ++ finish. 577 | ++ finish. 578 | * eapply TLtooLow. boom. 579 | + eapply TLtooLow. boom. 580 | - eapply TLtooLow. boom. 581 | Qed. 582 | 583 | End TryLowering. 584 | 585 | Inductive deletedHow(ik ok : EZ)(ig og : EB) : Set := 586 | | DSameK(_: ok = ik)(_: og = ig) 587 | | DLowerK(_: ok = ik - #1)(_: og = #true). 588 | 589 | Inductive delpair(k : EZ)(g : EB)(c : EL) : Set := 590 | | Delout`(dh : deletedHow k ok g og)`(ow : wavltree ok og olg org c). 591 | 592 | Section Delete_Rotations. 593 | 594 | Definition drot1`(lw : wavltree (k - #3) #true llg lrg lc)(x : A)`(rw : wavltree (k - #1) #false rlg rrg rc) 595 | : rlg = #false \/ rrg = #false -> Esorted(lc++[x]++rc) -> forall g, delpair k #g (lc++[x]++rc). 596 | Proof. 597 | ?? rw. 598 | - ?? (left_child rw). 599 | + ?? (isgap (right_child rw) false). 600 | * eapply Delout. 601 | -- apply DSameK. 602 | ++ reflexivity. 603 | ++ reflexivity. 604 | -- rootify (datum rw). start_node. 605 | ++ start_node. 606 | ** use_node. (*use lw.*) 607 | ** use_node. (*use (left_child rw).*) 608 | ** finish. 609 | ** finish. 610 | ++ use_node. (*use_regap (right_child rw).*) 611 | ++ finish. 612 | ++ finish. 613 | * eapply Delout. 614 | -- apply DSameK. 615 | ++ reflexivity. 616 | ++ reflexivity. 617 | -- rootify (datum (left_child rw)). start_node. 618 | ++ start_node. 1-2:use_node. 619 | (* ** use_node. (*use_regap lw.*) 620 | ** use_node. (*use (left_child (left_child rw)).*)*) 621 | ** finish. 622 | ** finish. 623 | ++ start_node. 624 | ** use_node. (*use (right_child (left_child rw)).*) 625 | ** use_node. (*use_regap (right_child rw).*) 626 | ** finish. 627 | ** finish. 628 | ++ finish. 629 | ++ finish. 630 | + assert (k = #2) as -> by boom. rsimp. apply missing_contents in lw as ->. 631 | eapply Delout. 632 | * apply DSameK. 633 | -- reflexivity. 634 | -- reflexivity. 635 | * rootify (datum rw). start_node. 636 | -- start_node. 637 | ++ missing. 638 | ++ missing. 639 | ++ finish. 640 | ++ finish. 641 | -- use_node. (*use_regap (right_child rw).*) 642 | -- finish. 643 | -- finish. 644 | - boom. 645 | Qed. 646 | 647 | Definition drot2`(lw : wavltree (k - #1) #false llg lrg lc)(x : A)`(rw : wavltree (k - #3) #true rlg rrg rc) 648 | : llg = #false \/ lrg = #false -> Esorted(lc++[x]++rc) -> forall g, delpair k #g (lc++[x]++rc). 649 | Proof. 650 | ?? lw. 651 | - ?? (right_child lw). 652 | + ?? (isgap (left_child lw) false). 653 | * eapply Delout. 654 | -- apply DSameK. 655 | ++ reflexivity. 656 | ++ reflexivity. 657 | -- rootify (datum lw). start_node. 658 | ++ use_node. (*use_regap (left_child lw).*) 659 | ++ rootify x. start_node. 660 | ** use_node. (*use (right_child lw).*) 661 | ** use_node. (*use rw.*) 662 | ** finish. 663 | ** finish. 664 | ++ finish. 665 | ++ finish. 666 | * eapply Delout. 667 | -- apply DSameK. 668 | ++ reflexivity. 669 | ++ reflexivity. 670 | -- rootify (datum (right_child lw)). start_node. 671 | ++ start_node. 1-2:use_node. 672 | (* ** use_node. (*use_regap (left_child lw).*) 673 | ** use_node. (*use (left_child (right_child lw)).*)*) 674 | ** finish. 675 | ** finish. 676 | ++ start_node. 677 | ** use_node. (*use (right_child (right_child lw)).*) 678 | ** use_node. (*use_regap rw.*) 679 | ** finish. 680 | ** finish. 681 | ++ finish. 682 | ++ finish. 683 | + assert (k = #2) as -> by boom. rsimp. apply missing_contents in rw as ->. 684 | eapply Delout. 685 | * apply DSameK. 686 | -- reflexivity. 687 | -- reflexivity. 688 | * rootify (datum lw). start_node. 689 | -- use_node. (*use_regap (left_child lw).*) 690 | -- start_node. 691 | ++ missing. 692 | ++ missing. 693 | ++ finish. 694 | ++ finish. 695 | -- finish. 696 | -- finish. 697 | - boom. 698 | Qed. 699 | 700 | End Delete_Rotations. 701 | 702 | Section Delete_Minimum. 703 | 704 | Inductive delminResult(k : EZ)(g : EB)(c : EL) : Set := 705 | MinDeleted(min : A)`(_: c = [min]++rc)(dp : delpair k g rc). 706 | 707 | Fixpoint delmin`(w : wavltree k g lg rg c) : k >= #0 -> delminResult k g c. 708 | Proof. 709 | ?? w. 710 | - ?? (isMissing (left_child w)). 711 | + eapply MinDeleted. 712 | * rewrite Eapp_nil_l. reflexivity. 713 | * eapply Delout. 714 | -- apply DLowerK. 715 | ++ reflexivity. 716 | ++ reflexivity. 717 | -- use_node. (*use_regap rw.*) 718 | + ?? delmin on (left_child w). 719 | * boom. 720 | * ?? (pick delpair). ?? (pick deletedHow). 721 | -- eapply MinDeleted. 722 | ++ assoc 0. reflexivity. 723 | ++ eapply Delout. 724 | ** apply DSameK. 725 | --- reflexivity. 726 | --- reflexivity. 727 | ** start_node. 728 | --- use_node. (*use ow.*) 729 | --- use_node. (*use rw.*) 730 | --- finish. 731 | --- finish. 732 | -- ?? (isgap (right_child w) false). 733 | ++ ?? (isgap (left_child w) true). 734 | ** ?? (tryLowering (right_child w)). 735 | --- eapply MinDeleted. 736 | +++ assoc 0. reflexivity. 737 | +++ eapply Delout. 738 | *** apply DLowerK. 739 | ---- reflexivity. 740 | ---- reflexivity. 741 | *** start_node. 742 | ---- use_node. (*use ow.*) 743 | ---- use_node. (*use ow0.*) 744 | ---- finish. 745 | ---- finish. 746 | --- eapply MinDeleted. 747 | +++ assoc 0. reflexivity. 748 | +++ eapply drot1. 749 | *** use_node. (*use ow.*) 750 | *** use_node. (*use rw.*) 751 | *** finish. 752 | *** finish. 753 | ** eapply MinDeleted. 754 | --- assoc 0. reflexivity. 755 | --- eapply Delout. 756 | +++ apply DSameK. 757 | *** reflexivity. 758 | *** reflexivity. 759 | +++ start_node. 760 | *** use_node. (*use ow.*) 761 | *** use_node. (*use rw.*) 762 | *** finish. 763 | *** finish. 764 | ++ unerase_gaps. eapply MinDeleted. 765 | ** assoc 0. reflexivity. 766 | ** eapply Delout. 767 | --- apply DLowerK. 768 | +++ reflexivity. 769 | +++ reflexivity. 770 | --- start_node. 771 | +++ use_node. (*use_regap ow.*) 772 | +++ use_node. (*use_regap rw.*) 773 | +++ finish. 774 | +++ finish. 775 | - boom. 776 | Qed. 777 | 778 | End Delete_Minimum. 779 | 780 | Section Delete_Maximum. 781 | 782 | Inductive delmaxResult(k : EZ)(g : EB)(c : EL) : Set := 783 | MaxDeleted(max : A)`(_: c = lc++[max])(dp : delpair k g lc). 784 | 785 | Fixpoint delmax`(w : wavltree k g lg rg c) : k >= #0 -> delmaxResult k g c. 786 | Proof. 787 | ?? w. 788 | - ?? (isMissing (right_child w)). 789 | + eapply MaxDeleted. 790 | * rewrite Eapp_nil_r. reflexivity. 791 | * eapply Delout. 792 | -- apply DLowerK. 793 | ++ reflexivity. 794 | ++ reflexivity. 795 | -- use_node. (*use_regap lw.*) 796 | + ?? delmax on (right_child w). 797 | * boom. 798 | * ?? (pick delpair). ?? (pick deletedHow). 799 | -- eapply MaxDeleted. 800 | ++ assoc 2. reflexivity. 801 | ++ eapply Delout. 802 | ** apply DSameK. 803 | --- reflexivity. 804 | --- reflexivity. 805 | ** start_node. 806 | --- use_node. (*use lw.*) 807 | --- use_node. (*use ow.*) 808 | --- finish. 809 | --- finish. 810 | -- ?? (isgap (left_child w) false). 811 | ++ ?? (isgap (right_child w) true). 812 | ** ?? (tryLowering (left_child w)). 813 | --- eapply MaxDeleted. 814 | +++ assoc 2. reflexivity. 815 | +++ eapply Delout. 816 | *** apply DLowerK. 817 | ---- reflexivity. 818 | ---- reflexivity. 819 | *** start_node. 820 | ---- use_node. (*use ow0.*) 821 | ---- use_node. (*use ow.*) 822 | ---- finish. 823 | ---- finish. 824 | --- eapply MaxDeleted. 825 | +++ assoc 2. reflexivity. 826 | +++ eapply drot2. 827 | *** use_node. (*use lw.*) 828 | *** use_node. (*use ow.*) 829 | *** finish. 830 | *** finish. 831 | ** eapply MaxDeleted. 832 | --- assoc 2. reflexivity. 833 | --- eapply Delout. 834 | +++ apply DSameK. 835 | *** reflexivity. 836 | *** reflexivity. 837 | +++ start_node. 838 | *** use_node. (*use lw.*) 839 | *** use_node. (*use ow.*) 840 | *** finish. 841 | *** finish. 842 | ++ unerase_gaps. eapply MaxDeleted. 843 | ** assoc 2. reflexivity. 844 | ** eapply Delout. 845 | --- apply DLowerK. 846 | +++ reflexivity. 847 | +++ reflexivity. 848 | --- start_node. 849 | +++ use_node. (*use_regap lw.*) 850 | +++ use_node. (*use_regap ow.*) 851 | +++ finish. 852 | +++ finish. 853 | - boom. 854 | Qed. 855 | 856 | End Delete_Maximum. 857 | 858 | Section Delete. 859 | 860 | Inductive deleteResult(x : A)(k : EZ)(g : EB)(c : EL) : Set := 861 | | Deleted`(_: c = lc++[x]++rc)(dp : delpair k g (lc++rc)) 862 | | DNotFound(_: ENotIn x c). 863 | 864 | Fixpoint delete(x : A)`(w : wavltree k g lg rg c) : deleteResult x k g c. 865 | Proof. 866 | ?? w. 867 | - ?? (x =<> (datum w)). 868 | + ?? (isMissing (left_child w)). 869 | * eapply Deleted. 870 | -- reflexivity. 871 | -- eapply Delout. 872 | ++ apply DLowerK. 873 | ** reflexivity. 874 | ** reflexivity. 875 | ++ rewrite Eapp_nil_l. use_node. (*use_regap rw.*) 876 | * ?? (isMissing (right_child w)). 877 | -- eapply Deleted. 878 | ++ reflexivity. 879 | ++ eapply Delout. 880 | ** apply DLowerK. 881 | --- reflexivity. 882 | --- reflexivity. 883 | ** rewrite Eapp_nil_r. use_node. (*use_regap lw.*) 884 | -- unerase_gaps. ?? (gap (left_child w)). 885 | ++ ?? (delmin (right_child w)). 886 | ** boom. 887 | ** ?? (pick delpair). ?? (pick deletedHow). 888 | --- eapply Deleted. 889 | +++ reflexivity. 890 | +++ eapply Delout. 891 | *** apply DSameK. 892 | ---- reflexivity. 893 | ---- reflexivity. 894 | *** start_node. 895 | ---- use_node. (*use lw.*) 896 | ---- use_node. (*use ow.*) 897 | ---- finish. 898 | ---- finish. 899 | --- eapply Deleted. 900 | +++ reflexivity. 901 | +++ eapply Delout. 902 | *** apply DLowerK. 903 | ---- reflexivity. 904 | ---- reflexivity. 905 | *** start_node. 906 | ---- use_node. (*use_regap lw.*) 907 | ---- use_node. (*use_regap ow.*) 908 | ---- finish. 909 | ---- finish. 910 | ++ ?? (delmax (left_child w)). 911 | ** boom. 912 | ** ?? (pick delpair). ?? (pick deletedHow). 913 | --- eapply Deleted. 914 | +++ reflexivity. 915 | +++ eapply Delout. 916 | *** apply DSameK. 917 | ---- reflexivity. 918 | ---- reflexivity. 919 | *** assoc 0. start_node. 920 | ---- use_node. (*use ow.*) 921 | ---- use_node. (*use rw.*) 922 | ---- finish. 923 | ---- finish. 924 | --- eapply Deleted. 925 | +++ reflexivity. 926 | +++ eapply Delout. 927 | *** apply DSameK. 928 | ---- reflexivity. 929 | ---- reflexivity. 930 | *** assoc 0. start_node. 931 | ---- use_node. (*use ow.*) 932 | ---- use_node. (*use rw.*) 933 | ---- finish. 934 | ---- finish. 935 | + ?? (delete x) on (left_child w). 936 | * ?? (pick delpair). ?? (pick deletedHow). 937 | -- eapply Deleted. 938 | ++ rootify x. reflexivity. 939 | ++ eapply Delout. 940 | ** apply DSameK. 941 | --- reflexivity. 942 | --- reflexivity. 943 | ** rootify d. start_node. 944 | --- use_node. (*use ow.*) 945 | --- use_node. (*use rw.*) 946 | --- finish. 947 | --- finish. 948 | -- unerase_gaps. ?? (gap (left_child w)). 949 | ++ unerase_gaps. ?? (gap (right_child w)). 950 | ** eapply Deleted. 951 | --- rootify x. reflexivity. 952 | --- eapply Delout. 953 | +++ apply DLowerK. 954 | *** reflexivity. 955 | *** reflexivity. 956 | +++ rootify d. start_node. 957 | *** use_node. (*use ow.*) 958 | *** use_node. (*use_regap rw.*) 959 | *** finish. 960 | *** finish. 961 | ** ?? (tryLowering (right_child w)). 962 | --- eapply Deleted. 963 | +++ rootify x. reflexivity. 964 | +++ eapply Delout. 965 | *** apply DLowerK. 966 | ---- reflexivity. 967 | ---- reflexivity. 968 | *** rootify d. start_node. 969 | ---- use_node. (*use ow.*) 970 | ---- use_node. (*use ow0.*) 971 | ---- finish. 972 | ---- finish. 973 | --- eapply Deleted. 974 | +++ rootify x. reflexivity. 975 | +++ rootify d. eapply drot1. 976 | *** use_node. (*use ow.*) 977 | *** use_node. (*use rw.*) 978 | *** finish. 979 | *** finish. 980 | ++ ?? (isMissing (right_child w)). 981 | ** eapply Deleted. 982 | --- rootify x. reflexivity. 983 | --- rootify d. eapply Delout. 984 | +++ apply DLowerK. 985 | *** reflexivity. 986 | *** reflexivity. 987 | +++ start_node. 988 | *** use_node. (*use_regap ow.*) 989 | *** missing. 990 | *** finish. 991 | *** finish. 992 | ** eapply Deleted. 993 | --- rootify x. reflexivity. 994 | --- eapply Delout. 995 | +++ apply DSameK. 996 | *** reflexivity. 997 | *** reflexivity. 998 | +++ rootify d. start_node. 999 | *** use_node. (*use ow.*) 1000 | *** use_node. (*use rw.*) 1001 | *** finish. 1002 | *** finish. 1003 | * eapply DNotFound. ss. 1004 | + ?? (delete x) on (right_child w). 1005 | * ?? (pick delpair). ?? (pick deletedHow). 1006 | -- eapply Deleted. 1007 | ++ rootify x. reflexivity. 1008 | ++ rootify d. eapply Delout. 1009 | ** apply DSameK. 1010 | --- reflexivity. 1011 | --- reflexivity. 1012 | ** start_node. 1013 | --- use_node. (*use lw.*) 1014 | --- use_node. (*use ow.*) 1015 | --- finish. 1016 | --- finish. 1017 | -- unerase_gaps. ?? (gap (right_child w)). 1018 | ++ unerase_gaps. ?? (gap (left_child w)). 1019 | ** eapply Deleted. 1020 | --- rootify x. reflexivity. 1021 | --- rootify d. eapply Delout. 1022 | +++ apply DLowerK. 1023 | *** reflexivity. 1024 | *** reflexivity. 1025 | +++ start_node. 1026 | *** use_node. (*use_regap lw.*) 1027 | *** use_node. (*use ow.*) 1028 | *** finish. 1029 | *** finish. 1030 | ** ?? (tryLowering (left_child w)). 1031 | --- eapply Deleted. 1032 | +++ rootify x. reflexivity. 1033 | +++ rootify d. eapply Delout. 1034 | *** apply DLowerK. 1035 | ---- reflexivity. 1036 | ---- reflexivity. 1037 | *** start_node. 1038 | ---- use_node. (*use ow0.*) 1039 | ---- use_node. (*use ow.*) 1040 | ---- finish. 1041 | ---- finish. 1042 | --- eapply Deleted. 1043 | +++ rootify x. reflexivity. 1044 | +++ rootify d. eapply drot2. 1045 | *** use_node. (*use lw.*) 1046 | *** use_node. (*use ow.*) 1047 | *** finish. 1048 | *** finish. 1049 | ++ ?? (isMissing (left_child w)). 1050 | ** eapply Deleted. 1051 | --- rootify x. reflexivity. 1052 | --- rootify d. eapply Delout. 1053 | +++ apply DLowerK. 1054 | *** reflexivity. 1055 | *** reflexivity. 1056 | +++ start_node. 1057 | *** missing. 1058 | *** use_node. (*use_regap ow.*) 1059 | *** finish. 1060 | *** finish. 1061 | ** eapply Deleted. 1062 | --- rootify x. reflexivity. 1063 | --- rootify d. eapply Delout. 1064 | +++ apply DSameK. 1065 | *** reflexivity. 1066 | *** reflexivity. 1067 | +++ start_node. 1068 | *** use_node. (*use lw.*) 1069 | *** use_node. (*use ow.*) 1070 | *** finish. 1071 | *** finish. 1072 | * eapply DNotFound. ss. 1073 | - eapply DNotFound. ss. 1074 | Qed. 1075 | 1076 | End Delete. 1077 | 1078 | Set Printing Width 120. 1079 | Show Ltac Profile CutOff 1. 1080 | 1081 | Require Import ExtrOcamlBasic. 1082 | 1083 | Extract Inductive delpair => "( * )" [ "" ]. 1084 | Extract Inductive delminResult => "( * )" [ "" ]. 1085 | Extract Inductive delmaxResult => "( * )" [ "" ]. 1086 | 1087 | Extraction Inline negb. 1088 | 1089 | Extract Inlined Constant Bool.bool_dec => "(=)". 1090 | 1091 | Extraction "wavl_noauto.ml" find insert delete. 1092 | 1093 | (* Local Variables: *) 1094 | (* company-coq-local-symbols: (("++" . ?⧺) ("Esorted" . ?⊿) ("#" . ?◻) ("wavltree" . ?🎄) ("[]" . ?∅) ("^" . ?⋄) ("^#" . ?⟎) ("Enegb" . ?¬) ("true" . ?Ṫ) ("false" . ?Ḟ) ("EL" . ?Ḷ) ("EB" . ?Ḅ) ("EZ" . ?Ẓ)) *) 1095 | (* End: *) 1096 | -------------------------------------------------------------------------------- /wavl_noninter.ml: -------------------------------------------------------------------------------- 1 | 2 | type compareSpecT = 3 | | CompEqT 4 | | CompLtT 5 | | CompGtT 6 | 7 | type 'a sig0 = 'a 8 | (* singleton inductive, whose constructor was exist *) 9 | 10 | 11 | 12 | type a (* AXIOM TO BE REALIZED *) 13 | 14 | (** val compare_spec : a -> a -> compareSpecT **) 15 | 16 | let compare_spec = 17 | failwith "AXIOM TO BE REALIZED" 18 | 19 | type wavltree = 20 | | Node of bool * a * wavltree * wavltree 21 | | Missing 22 | 23 | type findResult = 24 | | Found 25 | | NotFound 26 | 27 | (** val find : a -> wavltree -> findResult **) 28 | 29 | let rec find x = function 30 | | Node (_, d, lw, rw) -> (match compare_spec x d with 31 | | CompEqT -> Found 32 | | CompLtT -> find x lw 33 | | CompGtT -> find x rw) 34 | | Missing -> NotFound 35 | 36 | (** val setgap : wavltree -> bool -> wavltree **) 37 | 38 | let setgap w og = 39 | match w with 40 | | Node (_, d, lw, rw) -> Node (og, d, lw, rw) 41 | | Missing -> Missing 42 | 43 | (** val getgap : wavltree -> bool **) 44 | 45 | let getgap = function 46 | | Node (g, _, _, _) -> g 47 | | Missing -> false 48 | 49 | (** val isgap : wavltree -> bool -> bool **) 50 | 51 | let isgap w g' = 52 | match w with 53 | | Node (g, _, _, _) -> (=) g' g 54 | | Missing -> false 55 | 56 | (** val isMissing : wavltree -> bool **) 57 | 58 | let isMissing = function 59 | | Node (_, _, _, _) -> false 60 | | Missing -> true 61 | 62 | (** val irot1 : wavltree -> a -> wavltree -> bool -> wavltree **) 63 | 64 | let irot1 lw x rw g = 65 | match lw with 66 | | Node (_, d, llw, lrw) -> 67 | (match lrw with 68 | | Node (g0, d0, lw0, rw0) -> 69 | if g0 70 | then Node (g, d, llw, (Node (false, x, (setgap lrw false), (setgap rw false)))) 71 | else Node (g, d0, (Node (false, d, (setgap llw false), lw0)), (Node (false, x, rw0, (setgap rw false)))) 72 | | Missing -> Node (g, d, llw, (Node (false, x, Missing, (setgap rw false))))) 73 | | Missing -> assert false (* absurd case *) 74 | 75 | (** val irot2 : wavltree -> a -> wavltree -> bool -> wavltree **) 76 | 77 | let irot2 lw x rw g = 78 | match rw with 79 | | Node (_, d, rlw, rrw) -> 80 | (match rlw with 81 | | Node (g0, d0, lw0, rw0) -> 82 | if g0 83 | then Node (g, d, (Node (false, x, (setgap lw false), (setgap rlw false))), rrw) 84 | else Node (g, d0, (Node (false, x, (setgap lw false), lw0)), (Node (false, d, rw0, (setgap rrw false)))) 85 | | Missing -> Node (g, d, (Node (false, x, (setgap lw false), Missing)), rrw)) 86 | | Missing -> assert false (* absurd case *) 87 | 88 | type insertedHow = 89 | | ISameK 90 | | IWasMissing 91 | | IHigherK 92 | 93 | type insertResult = 94 | | Inserted of wavltree * insertedHow 95 | | FoundByInsert 96 | 97 | (** val insert : a -> wavltree -> insertResult **) 98 | 99 | let rec insert x = function 100 | | Node (g0, d, lw, rw) -> 101 | (match compare_spec x d with 102 | | CompEqT -> FoundByInsert 103 | | CompLtT -> 104 | (match insert x lw with 105 | | Inserted (ow, insertedHow0) -> 106 | (match insertedHow0 with 107 | | ISameK -> Inserted ((Node (g0, d, ow, rw)), ISameK) 108 | | IWasMissing -> 109 | if isMissing rw 110 | then Inserted ((Node (false, d, ow, Missing)), IHigherK) 111 | else Inserted ((Node (g0, d, ow, rw)), ISameK) 112 | | IHigherK -> 113 | if isgap lw true 114 | then Inserted ((Node (g0, d, ow, rw)), ISameK) 115 | else if isgap rw false 116 | then Inserted ((Node (false, d, ow, (setgap rw true))), IHigherK) 117 | else Inserted ((irot1 ow d rw g0), ISameK)) 118 | | FoundByInsert -> FoundByInsert) 119 | | CompGtT -> 120 | (match insert x rw with 121 | | Inserted (ow, insertedHow0) -> 122 | (match insertedHow0 with 123 | | ISameK -> Inserted ((Node (g0, d, lw, ow)), ISameK) 124 | | IWasMissing -> 125 | if isMissing lw 126 | then Inserted ((Node (false, d, Missing, ow)), IHigherK) 127 | else Inserted ((Node (g0, d, lw, ow)), ISameK) 128 | | IHigherK -> 129 | if isgap rw true 130 | then Inserted ((Node (g0, d, lw, ow)), ISameK) 131 | else if isgap lw false 132 | then Inserted ((Node (false, d, (setgap lw true), ow)), IHigherK) 133 | else Inserted ((irot2 lw d ow g0), ISameK)) 134 | | FoundByInsert -> FoundByInsert)) 135 | | Missing -> Inserted ((Node (false, x, Missing, Missing)), IWasMissing) 136 | 137 | type tryLoweringResult = 138 | | TLlowered of wavltree 139 | | TLtooLow 140 | 141 | (** val tryLowering : wavltree -> tryLoweringResult **) 142 | 143 | let tryLowering = function 144 | | Node (g0, d, lw, rw) -> 145 | if isgap lw true 146 | then if isgap rw true then TLlowered (Node (g0, d, (setgap lw false), (setgap rw false))) else TLtooLow 147 | else TLtooLow 148 | | Missing -> TLtooLow 149 | 150 | type deletedHow = 151 | | DSameK 152 | | DLowerK 153 | 154 | (** val drot1 : wavltree -> a -> wavltree -> bool -> ( * ) **) 155 | 156 | let drot1 lw x rw g = 157 | match rw with 158 | | Node (_, d, rlw, rrw) -> 159 | (match rlw with 160 | | Node (_, d0, lw0, rw0) -> 161 | if isgap rrw false 162 | then (DSameK, (Node (g, d, (Node (false, x, lw, rlw)), (setgap rrw true)))) 163 | else (DSameK, (Node (g, d0, (Node (true, x, (setgap lw false), lw0)), (Node (true, d, rw0, 164 | (setgap rrw false)))))) 165 | | Missing -> (DSameK, (Node (g, d, (Node (true, x, (setgap lw false), Missing)), (setgap rrw true))))) 166 | | Missing -> assert false (* absurd case *) 167 | 168 | (** val drot2 : wavltree -> a -> wavltree -> bool -> ( * ) **) 169 | 170 | let drot2 lw x rw g = 171 | match lw with 172 | | Node (_, d, llw, lrw) -> 173 | (match lrw with 174 | | Node (_, d0, lw0, rw0) -> 175 | if isgap llw false 176 | then (DSameK, (Node (g, d, (setgap llw true), (Node (false, x, lrw, rw))))) 177 | else (DSameK, (Node (g, d0, (Node (true, d, (setgap llw false), lw0)), (Node (true, x, rw0, 178 | (setgap rw false)))))) 179 | | Missing -> (DSameK, (Node (g, d, (setgap llw true), (Node (true, x, Missing, (setgap rw false))))))) 180 | | Missing -> assert false (* absurd case *) 181 | 182 | (** val delmin : wavltree -> ( * ) **) 183 | 184 | let rec delmin = function 185 | | Node (g0, d, lw, rw) -> 186 | if isMissing lw 187 | then (d, (DLowerK, (setgap rw true))) 188 | else let (min, dp) = delmin lw in 189 | let (dh, ow) = dp in 190 | (match dh with 191 | | DSameK -> (min, (DSameK, (Node (g0, d, ow, rw)))) 192 | | DLowerK -> 193 | if isgap rw false 194 | then if isgap lw true 195 | then (match tryLowering rw with 196 | | TLlowered ow0 -> (min, (DLowerK, (Node (true, d, ow, ow0)))) 197 | | TLtooLow -> (min, (drot1 ow d rw g0))) 198 | else (min, (DSameK, (Node (g0, d, ow, rw)))) 199 | else (min, (DLowerK, (Node (true, d, (setgap ow (getgap lw)), (setgap rw false)))))) 200 | | Missing -> assert false (* absurd case *) 201 | 202 | (** val delmax : wavltree -> ( * ) **) 203 | 204 | let rec delmax = function 205 | | Node (g0, d, lw, rw) -> 206 | if isMissing rw 207 | then (d, (DLowerK, (setgap lw true))) 208 | else let (max, dp) = delmax rw in 209 | let (dh, ow) = dp in 210 | (match dh with 211 | | DSameK -> (max, (DSameK, (Node (g0, d, lw, ow)))) 212 | | DLowerK -> 213 | if isgap lw false 214 | then if isgap rw true 215 | then (match tryLowering lw with 216 | | TLlowered ow0 -> (max, (DLowerK, (Node (true, d, ow0, ow)))) 217 | | TLtooLow -> (max, (drot2 lw d ow g0))) 218 | else (max, (DSameK, (Node (g0, d, lw, ow)))) 219 | else (max, (DLowerK, (Node (true, d, (setgap lw false), (setgap ow (getgap rw))))))) 220 | | Missing -> assert false (* absurd case *) 221 | 222 | type deleteResult = 223 | | Deleted of ( * ) 224 | | DNotFound 225 | 226 | (** val delete : a -> wavltree -> deleteResult **) 227 | 228 | let rec delete x = function 229 | | Node (g0, d, lw, rw) -> 230 | (match compare_spec x d with 231 | | CompEqT -> 232 | if isMissing lw 233 | then Deleted (DLowerK, (setgap rw true)) 234 | else if isMissing rw 235 | then Deleted (DLowerK, (setgap lw true)) 236 | else if isgap lw true 237 | then let (min, dp) = delmin rw in 238 | let (dh, ow) = dp in 239 | (match dh with 240 | | DSameK -> Deleted (DSameK, (Node (g0, min, lw, ow))) 241 | | DLowerK -> Deleted (DLowerK, (Node (true, min, (setgap lw false), (setgap ow (getgap rw)))))) 242 | else let (max, dp) = delmax lw in let (_, ow) = dp in Deleted (DSameK, (Node (g0, max, ow, rw))) 243 | | CompLtT -> 244 | (match delete x lw with 245 | | Deleted dp -> 246 | let (dh, ow) = dp in 247 | (match dh with 248 | | DSameK -> Deleted (DSameK, (Node (g0, d, ow, rw))) 249 | | DLowerK -> 250 | if isgap lw true 251 | then if isgap rw true 252 | then Deleted (DLowerK, (Node (true, d, ow, (setgap rw false)))) 253 | else (match tryLowering rw with 254 | | TLlowered ow0 -> Deleted (DLowerK, (Node (true, d, ow, ow0))) 255 | | TLtooLow -> Deleted (drot1 ow d rw g0)) 256 | else if isMissing rw 257 | then Deleted (DLowerK, (Node (true, d, (setgap ow false), Missing))) 258 | else Deleted (DSameK, (Node (g0, d, ow, rw)))) 259 | | DNotFound -> DNotFound) 260 | | CompGtT -> 261 | (match delete x rw with 262 | | Deleted dp -> 263 | let (dh, ow) = dp in 264 | (match dh with 265 | | DSameK -> Deleted (DSameK, (Node (g0, d, lw, ow))) 266 | | DLowerK -> 267 | if isgap rw true 268 | then if isgap lw true 269 | then Deleted (DLowerK, (Node (true, d, (setgap lw false), ow))) 270 | else (match tryLowering lw with 271 | | TLlowered ow0 -> Deleted (DLowerK, (Node (true, d, ow0, ow))) 272 | | TLtooLow -> Deleted (drot2 lw d ow g0)) 273 | else if isMissing lw 274 | then Deleted (DLowerK, (Node (true, d, Missing, (setgap ow false)))) 275 | else Deleted (DSameK, (Node (g0, d, lw, ow)))) 276 | | DNotFound -> DNotFound)) 277 | | Missing -> DNotFound 278 | -------------------------------------------------------------------------------- /wavl_noninter.mli: -------------------------------------------------------------------------------- 1 | 2 | type compareSpecT = 3 | | CompEqT 4 | | CompLtT 5 | | CompGtT 6 | 7 | type 'a sig0 = 'a 8 | (* singleton inductive, whose constructor was exist *) 9 | 10 | 11 | 12 | type a (* AXIOM TO BE REALIZED *) 13 | 14 | val compare_spec : a -> a -> compareSpecT 15 | 16 | type wavltree = 17 | | Node of bool * a * wavltree * wavltree 18 | | Missing 19 | 20 | type findResult = 21 | | Found 22 | | NotFound 23 | 24 | val find : a -> wavltree -> findResult 25 | 26 | val setgap : wavltree -> bool -> wavltree 27 | 28 | val getgap : wavltree -> bool 29 | 30 | val isgap : wavltree -> bool -> bool 31 | 32 | val isMissing : wavltree -> bool 33 | 34 | val irot1 : wavltree -> a -> wavltree -> bool -> wavltree 35 | 36 | val irot2 : wavltree -> a -> wavltree -> bool -> wavltree 37 | 38 | type insertedHow = 39 | | ISameK 40 | | IWasMissing 41 | | IHigherK 42 | 43 | type insertResult = 44 | | Inserted of wavltree * insertedHow 45 | | FoundByInsert 46 | 47 | val insert : a -> wavltree -> insertResult 48 | 49 | type tryLoweringResult = 50 | | TLlowered of wavltree 51 | | TLtooLow 52 | 53 | val tryLowering : wavltree -> tryLoweringResult 54 | 55 | type deletedHow = 56 | | DSameK 57 | | DLowerK 58 | 59 | val drot1 : wavltree -> a -> wavltree -> bool -> ( * ) 60 | 61 | val drot2 : wavltree -> a -> wavltree -> bool -> ( * ) 62 | 63 | val delmin : wavltree -> ( * ) 64 | 65 | val delmax : wavltree -> ( * ) 66 | 67 | type deleteResult = 68 | | Deleted of ( * ) 69 | | DNotFound 70 | 71 | val delete : a -> wavltree -> deleteResult 72 | -------------------------------------------------------------------------------- /wavl_noninter.v: -------------------------------------------------------------------------------- 1 | 2 | (*** Weak AVL Trees ***) 3 | 4 | (*+ 5 | See "Rank-Balanced Trees" by Haeupler, Sen, Tarjan 6 | [http://www.cs.princeton.edu/~sssix/papers/rb-trees-talg.pdf]. 7 | *) 8 | 9 | (* A non-interactive version of wavl.v, with all functions defined using ":=". 10 | Note that the leaves of all but the most trivial functions are still filled in 11 | using proof search. *) 12 | Set Ltac Profiling. 13 | Require Import elist. 14 | Require Import ezbool. 15 | Require Import utils. 16 | Require Import hypiter. 17 | 18 | Generalizable All Variables. 19 | Set Implicit Arguments. 20 | 21 | Context {A : Set}. 22 | 23 | Context {ordA : Ordered A}. 24 | 25 | Context {compare : A -> A -> comparison}. 26 | 27 | Context {compare_spec : forall x y, CompareSpecT (eq x y) (lt x y) (lt y x) (compare x y)}. 28 | 29 | Notation "x =<> y" := (compare_spec x y) (at level 70, only parsing). 30 | 31 | Notation EL := ##(list A). 32 | Notation EZ := ##Z. 33 | Notation EB := ##bool. 34 | 35 | Open Scope E_scope. 36 | 37 | Inductive wavltree (k : EZ)(pg lg rg : EB)(c : EL) : Set := 38 | | Node{g : bool}(d : A) 39 | {geq: #g = pg} 40 | `{ceq: c = lc++[d]++rc} 41 | `(lw : wavltree (k - #1 - ^lg) lg llg lrg lc) 42 | `(rw : wavltree (k - #1 - ^rg) rg rlg rrg rc) 43 | {leaf_rule: k = #1 -> lg = #false \/ rg = #false} 44 | {sc: Esorted c} 45 | | Missing{ceq: c = []}{keq: k = - #1}{lgeq: lg = #false}{rgeq: rg = #false}. 46 | 47 | Arguments Missing {_ _ _ _ _ _ _ _ _}. 48 | 49 | (**********************************************************************) 50 | 51 | Notation "!" := ltac:(bang) (only parsing). 52 | 53 | Section Lemmas. 54 | 55 | Definition wavl_min_rank`(w : wavltree k g lg rg c) : k >= - #1 := 56 | wavltree_ind (fun k _ _ _ _ _ => k >= - #1) ! ! w. 57 | 58 | Definition wavl_node_min_rank`(w : wavltree k g lg rg c) : c <> [] -> k >= #0 := 59 | match w with 60 | | Node _ lw _ => 61 | let _ := wavl_min_rank lw in ! 62 | | Missing => ! 63 | end. 64 | 65 | Definition wavl_node_nonempty`(w : wavltree k g lg rg c) : k >= #0 -> c <> [] := 66 | if w then ! else !. 67 | 68 | Definition missing_contents`(w : wavltree (- #1) g lg rg c) : c = [] := 69 | let _ := (wavl_node_min_rank w) in 70 | if w then ! else !. 71 | 72 | Definition missing_rank`(w : wavltree k g lg rg []) : k = - #1 := 73 | if w then ltac:(fnenil) else ltac:(tauto). 74 | 75 | Definition wavl_is_sorted`(w : wavltree k g lg rg c) : Esorted c := 76 | if w then ltac:(assumption) else ltac:(subst; repeat econstructor). 77 | 78 | End Lemmas. 79 | 80 | Ltac bang_setup_tactic ::= 81 | let f H := 82 | (lazymatch type of H with 83 | | wavltree _ _ _ _ _ => 84 | first [apply missing_rank in H 85 | |apply wavl_node_min_rank in H; [|assumption||fnenil] 86 | |apply wavl_min_rank in H] 87 | | _ => idtac 88 | end) in 89 | allhyps_td f. 90 | 91 | Ltac ss_setup_tactic := 92 | let f H := (try apply wavl_is_sorted in H) in 93 | allhyps_td f. 94 | 95 | Ltac ss := ss_setup_tactic; unerase; solve[solve_sorted]. 96 | 97 | (**********************************************************************) 98 | 99 | Section Check_Leaf_Rule. 100 | 101 | Local Definition is_leaf`(w : wavltree k g lg rg c) : bool := 102 | match w with 103 | | Node _ Missing Missing => true 104 | | _ => false 105 | end. 106 | 107 | Ltac destruct_match := 108 | match goal with |- context[match ?X with _ => _ end] => destruct X end. 109 | 110 | Local Lemma leaf_rule_works`(w : wavltree k g lg rg c) : k = #0 <-> is_leaf w = true. 111 | Proof. 112 | unfold is_leaf. 113 | repeat destruct_match. 114 | all: boom. 115 | Qed. 116 | 117 | End Check_Leaf_Rule. 118 | 119 | (**********************************************************************) 120 | 121 | (*notations to make these patterns short:*) 122 | Notation eqcase := (CompEqT _ _ _) (only parsing). 123 | Notation ltcase := (CompLtT _ _ _) (only parsing). 124 | Notation gtcast := (CompGtT _ _ _) (only parsing). 125 | 126 | Section Find. 127 | 128 | Inductive findResult(x : A)(c : EL) : Set := 129 | | Found`(_: c = lc++[x]++rc) 130 | | NotFound(_: ENotIn x c). 131 | 132 | Ltac solve_find := 133 | dintros; 134 | reassoc; 135 | ((eapply Found; reflexivity) || (eapply NotFound; ss)). 136 | 137 | Notation "!!" := ltac:(solve_find) (only parsing). 138 | 139 | Fixpoint find(x : A)`(w : wavltree k g lg rg c) : findResult x c := 140 | match w with 141 | | Node d lw rw => 142 | match x =<> d with 143 | | eqcase => !! 144 | | ltcase => if find x lw then !! else !! 145 | | gtcase => if find x rw then !! else !! 146 | end 147 | | Missing => !! 148 | end. 149 | 150 | End Find. 151 | 152 | Section SetGap. 153 | 154 | Notation "!!" := ltac:(econstructor; subst; try reflexivity; eassumption) (only parsing). 155 | 156 | Definition setgap`(w : wavltree k ig lg rg c)(og : bool) : wavltree k #og lg rg c := 157 | if w then !! else !!. 158 | 159 | End SetGap. 160 | 161 | Section GetGap. 162 | 163 | Notation "!!" := ltac:(unshelve eexists; [exact false + eassumption | boom]) (only parsing). 164 | 165 | Definition getgap`(w : wavltree k g lg rg c) : {g' | c <> [] -> #g' = g} := 166 | if w then !! else !!. 167 | 168 | End GetGap. 169 | 170 | Ltac unerase_var v := 171 | lazymatch goal with 172 | | _ : # ?x = v |- _ => exact x 173 | | _ : v = # ?x |- _ => exact x 174 | end. 175 | 176 | Notation "$ x" := ltac:(unerase_var x) (at level 10, only parsing). 177 | 178 | Section IsGap. 179 | 180 | Notation "!!" := ltac:(constructor;boom) (only parsing). 181 | 182 | Notation "x ?= y" := (Bool.bool_dec x y) (only parsing). 183 | 184 | Definition isgap`(w : wavltree k g lg rg c)(g' : bool) : {k >= #0 /\ #g' = g} + {k = - #1 \/ #g' <> g} := 185 | if w then (if g' ?= $ g then !! else !!) else !!. 186 | 187 | End IsGap. 188 | 189 | Notation "% w" := (isgap w true) (at level 20, only parsing). 190 | Notation "~% w" := (isgap w false) (at level 20, only parsing). 191 | 192 | Section IsMissing. 193 | 194 | Notation "!!" := ltac:(constructor;bang) (only parsing). 195 | 196 | Definition isMissing`(w : wavltree k g lg rg c) : {c = [] /\ k = - #1} + {c <> [] /\ k >= #0} := 197 | if w then !! else !!. 198 | 199 | End IsMissing. 200 | 201 | Notation "~ w" := (isMissing w) (only parsing). 202 | 203 | Ltac wavl_missing := 204 | eapply Missing; [reflexivity|boom..]. 205 | 206 | Ltac wavl_assumption := 207 | multimatch goal with W:wavltree _ _ _ _ ?C |- wavltree _ _ _ _ ?C' => 208 | replace C' with C by (rewrite ?Eapp_assoc; reflexivity); 209 | (force exact W + force refine (setgap W _)) 210 | end;[boom..]. 211 | 212 | Ltac solve_wavl := 213 | dintros; 214 | (wavl_missing + wavl_assumption + wavl_construction) 215 | with wavl_construction := 216 | reassoc; 217 | eapply Node; 218 | [reflexivity 219 | |reflexivity 220 | |solve_wavl 221 | |solve_wavl 222 | |boom 223 | |ss]. 224 | 225 | Section Insert_Rotations. 226 | 227 | Notation "!!" := ltac:(solve_wavl) (only parsing). 228 | Notation "* b" := (Bool.Sumbool.sumbool_of_bool ($ b)) (at level 10, only parsing). 229 | 230 | Definition irot1`(lw : wavltree k #false llg lrg lc)(x : A)`(rw : wavltree (k - #2) #true rlg rrg rc) 231 | : llg = Enegb lrg -> Esorted (lc++[x]++rc) -> forall g, wavltree k #g #false #false (lc++[x]++rc) := 232 | match lw with 233 | | Node _ llw lrw => 234 | if lrw then (if *lrg then !! else !!) else !! 235 | | Missing => ! 236 | end. 237 | 238 | Definition irot2`(lw : wavltree (k - #2) #true llg lrg lc)(x : A)`(rw : wavltree k #false rlg rrg rc) 239 | : Enegb rlg = rrg -> Esorted (lc++[x]++rc) -> forall g, wavltree k #g #false #false (lc++[x]++rc) := 240 | match rw with 241 | | Node _ rlw rrw => 242 | if rlw then (if *rlg then !! else !!) else !! 243 | | Missing => ! 244 | end. 245 | 246 | End Insert_Rotations. 247 | 248 | Ltac use_rotations r1 r2 := 249 | dintros; 250 | reassoc; 251 | (eapply r1 + eapply r2); 252 | [wavl_assumption 253 | |wavl_assumption 254 | |boom 255 | |ss]. 256 | 257 | Ltac unerase_gaps := 258 | subst; 259 | let f H := 260 | try 261 | lazymatch type of H with 262 | wavltree _ ?G _ _ _ => 263 | is_var G; 264 | case (getgap H); 265 | let X := fresh in 266 | let G' := fresh in 267 | intros G' X; 268 | first [specialize (X ltac:(assumption||fnenil)) 269 | |specialize (X (wavl_node_nonempty H ltac:(bang)))]; 270 | rewrite <-X in *; 271 | clear X G; 272 | rename G' into G 273 | end in 274 | allhyps_td f. 275 | 276 | Section Insert. 277 | 278 | Inductive insertedHow(ik ok : EZ)(ig og olg org : EB) : Set := 279 | | ISameK(_: ok = ik)(_: og = ig) 280 | | IWasMissing(_: ik = - #1)(_: ok = #0)(_: og = #false) 281 | | IHigherK(_: ik >= #0)(_: ok = ik + #1)(_: olg = Enegb org)(_: og = #false). 282 | 283 | Inductive insertResult(x: A)(k : EZ)(g lg rg : EB)(c : EL) : Set := 284 | | Inserted`(_: c = lc++rc) 285 | `(ow: wavltree ok og olg org (lc++[x]++rc)) 286 | `(ih: insertedHow k ok g og olg org) 287 | | FoundByInsert`(_: c = lc++[x]++rc). 288 | 289 | Notation subtree's_k_unchanged := 290 | (@Inserted _ _ _ _ _ _ _ _ _ _ _ _ _ _ (@ISameK _ _ _ _ _ _ _ _)) (only parsing). 291 | Notation subtree_was_missing := 292 | (@Inserted _ _ _ _ _ _ _ _ _ _ _ _ _ _ (@IWasMissing _ _ _ _ _ _ _ _ _)) (only parsing). 293 | Notation subtree's_k_increased := 294 | (@Inserted _ _ _ _ _ _ _ _ _ _ _ _ _ _ (@IHigherK _ _ _ _ _ _ _ _ _ _)) (only parsing). 295 | Notation found_not_inserted := 296 | (@FoundByInsert _ _ _ _ _ _ _ _ _) (only parsing). 297 | 298 | Ltac solve_wavl2 := use_rotations irot1 irot2 + solve_wavl. 299 | 300 | Definition nilnilnil : [] = [] ++ [] :> EL := 301 | eq_ind_r (fun e : EL => [] = e) eq_refl (Eapp_nil_l []). 302 | 303 | Ltac solve_insert := 304 | dintros; 305 | reassoc; 306 | ((eapply FoundByInsert; reflexivity) + 307 | (eapply Inserted; 308 | [reflexivity || eapply nilnilnil 309 | |solve_wavl2 310 | |econstructor;[boom..] 311 | ])). 312 | 313 | Notation "!!" := ltac:(solve_insert) (only parsing). 314 | 315 | Fixpoint insert(x : A)`(w : wavltree k g lg rg c) : insertResult x k g lg rg c := 316 | match w with 317 | | Node d lw rw => 318 | match x =<> d with 319 | | eqcase => !! 320 | | ltcase => 321 | match insert x lw with 322 | | subtree's_k_unchanged => !! 323 | | subtree_was_missing => if ~rw then !! else !! 324 | | subtree's_k_increased => if %lw then !! else if ~%rw then !! else !! 325 | | found_not_inserted => !! 326 | end 327 | | gtcase => 328 | match insert x rw with 329 | | subtree's_k_unchanged => !! 330 | | subtree_was_missing => if ~lw then !! else !! 331 | | subtree's_k_increased => if %rw then !! else if ~%lw then !! else !! 332 | | found_not_inserted => !! 333 | end 334 | end 335 | | Missing => !! 336 | end. 337 | 338 | End Insert. 339 | 340 | (**********************************************************************) 341 | 342 | Section TryLowering. 343 | 344 | Inductive tryLoweringResult(k : EZ)(g lg rg : EB)(c : EL) : Set := 345 | | TLlowered(_: lg = #true)(_: rg = #true)(ow: wavltree (k - #1) g #false #false c) 346 | | TLtooLow(_: lg = #false \/ rg = #false). 347 | 348 | Ltac solve_tl := 349 | dintros; 350 | ((eapply TLlowered; 351 | [reflexivity 352 | |reflexivity 353 | |solve_wavl 354 | ]) 355 | || (eapply TLtooLow; boom)). 356 | 357 | Notation "!!" := ltac:(solve_tl) (only parsing). 358 | 359 | Definition tryLowering`(w : wavltree k g lg rg c) : tryLoweringResult k g lg rg c := 360 | match w with 361 | | Node d lw rw => 362 | if %lw then (if %rw then !! else !!) else !! 363 | | Missing => !! 364 | end. 365 | 366 | End TryLowering. 367 | 368 | Notation "?↓ w" := (tryLowering w) (at level 10, only parsing). 369 | 370 | Inductive deletedHow(ik ok : EZ)(ig og : EB) : Set := 371 | | DSameK(_: ok = ik)(_: og = ig) 372 | | DLowerK(_: ok = ik - #1)(_: og = #true). 373 | 374 | Inductive delpair(k : EZ)(g : EB)(c : EL) : Set := 375 | | Delout`(dh : deletedHow k ok g og)`(ow : wavltree ok og olg org c). 376 | 377 | Ltac solve_delpair := 378 | dintros; 379 | eapply Delout; 380 | [constructor; [boom..] 381 | |solve_wavl 382 | ]. 383 | 384 | Section Delete_Rotations. 385 | 386 | Notation "!!" := ltac:(solve_delpair) (only parsing). 387 | 388 | Definition drot1 389 | `(lw : wavltree (k - #3) #true llg lrg lc) 390 | (x : A) 391 | `(rw : wavltree (k - #1) #false rlg rrg rc) 392 | : rlg = #false \/ rrg = #false -> Esorted (lc++[x]++rc) -> 393 | forall g, delpair k #g (lc++[x]++rc) := 394 | match rw with 395 | | Node d rlw rrw => if rlw then (if ~%rrw then !! else !!) else !! 396 | | Missing => ! 397 | end. 398 | 399 | Definition drot2 400 | `(lw : wavltree (k - #1) #false llg lrg lc) 401 | (x : A) 402 | `(rw : wavltree (k - #3) #true rlg rrg rc) 403 | : llg = #false \/ lrg = #false -> Esorted (lc++[x]++rc) -> 404 | forall g, delpair k #g (lc++[x]++rc) := 405 | match lw with 406 | | Node d llw lrw => if lrw then (if ~%llw then !! else !!) else !! 407 | | Missing => ! 408 | end. 409 | 410 | End Delete_Rotations. 411 | 412 | Ltac solve_delpair2 := use_rotations drot1 drot2 + solve_delpair. 413 | 414 | Inductive delminResult(k : EZ)(g : EB)(c : EL) : Set := 415 | MinDeleted(min : A)`(_: c = [min]++rc)(dp : delpair k g rc). 416 | 417 | Notation delmin_subtree's_k_unchanged := 418 | (@MinDeleted _ _ _ _ _ _ (@Delout _ _ _ _ _ (@DSameK _ _ _ _ _ _) _ _ _)) 419 | (only parsing). 420 | 421 | Notation delmin_subtree's_k_decreased := 422 | (@MinDeleted _ _ _ _ _ _ (@Delout _ _ _ _ _ (@DLowerK _ _ _ _ _ _) _ _ _)) 423 | (only parsing). 424 | 425 | Section Delete_Minimum. 426 | 427 | Ltac solve_delmin := 428 | dintros; 429 | reassoc; 430 | try rewrite Eapp_nil_l; 431 | eapply MinDeleted; 432 | [reflexivity|solve_delpair2]. 433 | 434 | Notation "!!" := ltac:(solve_delmin) (only parsing). 435 | Notation "%!!" := ltac:(unerase_gaps; solve_delmin) (only parsing). 436 | 437 | Fixpoint delmin`(w : wavltree k g lg rg c) : k >= #0 -> delminResult k g c := 438 | match w with 439 | | Node d lw rw => 440 | if (isMissing lw) then !! 441 | else 442 | match (delmin lw !) with 443 | | delmin_subtree's_k_unchanged => !! 444 | | delmin_subtree's_k_decreased => 445 | if ~%rw then (if %lw then (if ?↓rw then !! else !!) else !!) else %!! 446 | end 447 | | Missing => ! 448 | end. 449 | 450 | End Delete_Minimum. 451 | 452 | 453 | Inductive delmaxResult(k : EZ)(g : EB)(c : EL) : Set := 454 | MaxDeleted(max : A)`(_: c = lc++[max])(dp : delpair k g lc). 455 | 456 | Notation delmax_subtree's_k_unchanged := 457 | (@MaxDeleted _ _ _ _ _ _ (@Delout _ _ _ _ _ (@DSameK _ _ _ _ _ _) _ _ _)) 458 | (only parsing). 459 | 460 | Notation delmax_subtree's_k_decreased := 461 | (@MaxDeleted _ _ _ _ _ _ (@Delout _ _ _ _ _ (@DLowerK _ _ _ _ _ _) _ _ _)) 462 | (only parsing). 463 | 464 | Section Delete_Maximum. 465 | 466 | Ltac solve_delmax := 467 | dintros; 468 | reassoc; 469 | try rewrite Eapp_nil_r; 470 | eapply MaxDeleted; 471 | [reflexivity|solve_delpair2]. 472 | 473 | Notation "!!" := ltac:(solve_delmax) (only parsing). 474 | Notation "%!!" := ltac:(unerase_gaps; solve_delmax) (only parsing). 475 | 476 | Fixpoint delmax`(w : wavltree k g lg rg c) : k >= #0 -> delmaxResult k g c := 477 | match w with 478 | | Node d lw rw => 479 | if (isMissing rw) then !! 480 | else 481 | match (delmax rw !) with 482 | | delmax_subtree's_k_unchanged => !! 483 | | delmax_subtree's_k_decreased => 484 | if ~%lw then (if %rw then (if ?↓lw then !! else !!) else !!) else %!! 485 | end 486 | | Missing => ! 487 | end. 488 | 489 | End Delete_Maximum. 490 | 491 | Section Delete. 492 | 493 | Inductive deleteResult(x : A)(k : EZ)(g : EB)(c : EL) : Set := 494 | | Deleted`(_: c = lc++[x]++rc)(dp : delpair k g (lc++rc)) 495 | | DNotFound(_: ENotIn x c). 496 | 497 | Notation deleted_subtree's_k_unchanged := 498 | (@Deleted _ _ _ _ _ _ _ (@Delout _ _ _ _ _ (@DSameK _ _ _ _ _ _) _ _ _)) 499 | (only parsing). 500 | Notation deleted_subtree's_k_decreased := 501 | (@Deleted _ _ _ _ _ _ _ (@Delout _ _ _ _ _ (@DLowerK _ _ _ _ _ _) _ _ _)) 502 | (only parsing). 503 | Notation delete_target_not_found := 504 | (@DNotFound _ _ _ _ _) (only parsing). 505 | 506 | Ltac solve_delete := 507 | dintros; 508 | reassoc; 509 | ((eapply Deleted; 510 | [reflexivity (* c = lc++[x]++rc *) 511 | |(rewrite Eapp_nil_r + rewrite Eapp_nil_l + idtac); solve_delpair2 512 | ]) 513 | + (eapply DNotFound; ss)). 514 | 515 | Notation "!!" := ltac:(solve_delete) (only parsing). 516 | Notation "%!!" := ltac:(unerase_gaps; solve_delete) (only parsing). 517 | 518 | Fixpoint delete(x : A)`(w : wavltree k g lg rg c) : deleteResult x k g c := 519 | match w with 520 | | Node d lw rw => 521 | match x =<> d with 522 | | eqcase => 523 | if (isMissing lw) then !! 524 | else if (isMissing rw) then !! 525 | else if %lw 526 | then match (delmin rw !) with 527 | | delmin_subtree's_k_unchanged => !! 528 | | delmin_subtree's_k_decreased => %!! 529 | end 530 | else match (delmax lw !) with 531 | | delmax_subtree's_k_unchanged => !! 532 | | delmax_subtree's_k_decreased => !! 533 | end 534 | | ltcase => 535 | match (delete x lw) with 536 | | deleted_subtree's_k_unchanged => !! 537 | | deleted_subtree's_k_decreased => 538 | if %lw then (if %rw then !! else if ?↓rw then !! else !!) 539 | else if ~rw then !! else !! 540 | | delete_target_not_found => !! 541 | end 542 | | gtcase => 543 | match (delete x rw) with 544 | | deleted_subtree's_k_unchanged => !! 545 | | deleted_subtree's_k_decreased => 546 | if %rw then (if %lw then !! else if ?↓lw then !! else !!) 547 | else if ~lw then !! else !! 548 | | delete_target_not_found => !! 549 | end 550 | end 551 | | Missing => !! 552 | end. 553 | 554 | End Delete. 555 | Show Ltac Profile CutOff 1. 556 | Set Printing Width 120. 557 | 558 | Require Import ExtrOcamlBasic. 559 | 560 | Extract Inductive delpair => "( * )" [ "" ]. 561 | Extract Inductive delminResult => "( * )" [ "" ]. 562 | Extract Inductive delmaxResult => "( * )" [ "" ]. 563 | 564 | Extraction Inline negb. 565 | 566 | Extract Inlined Constant Bool.bool_dec => "(=)". 567 | 568 | Extraction Inline Bool.Sumbool.sumbool_of_bool. 569 | 570 | Extraction "wavl_noninter.ml" find insert delete. 571 | --------------------------------------------------------------------------------