├── .github └── workflows │ └── docker-action.yml ├── .gitignore ├── LICENSE ├── Makefile ├── Makefile.common ├── README.md ├── _CoqProject ├── coq-htt-core.opam ├── coq-htt.opam ├── dune-project ├── examples ├── Make ├── Makefile ├── array.v ├── bintree.v ├── bst.v ├── bubblesort.v ├── congmath.v ├── congprog.v ├── counter.v ├── cyclic.v ├── dlist.v ├── dune ├── exploit.v ├── gcd.v ├── hashtab.v ├── kvmaps.v ├── llist.v ├── queue.v ├── quicksort.v ├── stack.v ├── tree.v └── union_find.v ├── htt ├── Make ├── Makefile ├── domain.v ├── dune ├── heapauto.v ├── model.v └── options.v ├── meta.yml ├── regenerate.sh └── theories └── dune /.github/workflows/docker-action.yml: -------------------------------------------------------------------------------- 1 | # This file was generated from `meta.yml`, please do not edit manually. 2 | # Follow the instructions on https://github.com/coq-community/templates to regenerate. 3 | name: Docker CI 4 | 5 | on: 6 | push: 7 | branches: 8 | - master 9 | pull_request: 10 | branches: 11 | - '**' 12 | 13 | jobs: 14 | build: 15 | # the OS must be GNU/Linux to be able to use the docker-coq-action 16 | runs-on: ubuntu-latest 17 | strategy: 18 | matrix: 19 | image: 20 | - 'mathcomp/mathcomp:2.2.0-coq-8.19' 21 | - 'mathcomp/mathcomp:2.3.0-coq-8.20' 22 | - 'mathcomp/mathcomp:2.4.0-rocq-prover-9.0' 23 | - 'mathcomp/mathcomp-dev:rocq-prover-dev' 24 | fail-fast: false 25 | steps: 26 | - uses: actions/checkout@v4 27 | - uses: coq-community/docker-coq-action@v1 28 | with: 29 | opam_file: 'coq-htt-core.opam' 30 | custom_image: ${{ matrix.image }} 31 | 32 | 33 | # See also: 34 | # https://github.com/coq-community/docker-coq-action#readme 35 | # https://github.com/erikmd/docker-coq-github-action-demo 36 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # ----------------------------------------------------------------------------- 2 | # generic generated file patterns 3 | 4 | Thumbs.db 5 | .DS_Store 6 | .svn 7 | 8 | *~ 9 | #*# 10 | *.bak 11 | *.BAK 12 | *.orig 13 | *.prof 14 | *.rej 15 | 16 | 17 | *.hi 18 | *.hi-boot 19 | *.o-boot 20 | *.p_o 21 | *.t_o 22 | *.debug_o 23 | *.thr_o 24 | *.thr_p_o 25 | *.thr_debug_o 26 | *.o 27 | *.vo 28 | *.a 29 | *.o.cmd 30 | *.depend* 31 | .#* 32 | log 33 | tags 34 | 35 | # ----------------------------------------------------------------------------- 36 | # Emacs-generated TeX files 37 | _region_.* 38 | cv/*.out 39 | *.rel 40 | *.log 41 | *.blg 42 | *.aux 43 | *.bbl 44 | *.synctex.gz 45 | *.out.ps 46 | .#* 47 | 48 | # ----------------------------------------------------------------------------- 49 | # Local VSCode settings 50 | .vscode 51 | 52 | # ----------------------------------------------------------------------------- 53 | # Coq-generated stuff 54 | 55 | \#*\# 56 | **/*.vo 57 | **/*.v.d 58 | **/*.glob 59 | **/*.vok 60 | **/*.vos 61 | 62 | # ----------------------------------------------------------------------------- 63 | # HTT specific stuff 64 | .Makefile.coq.d 65 | Makefile.coq 66 | Makefile.coq.conf 67 | CoqMakefile.conf 68 | loadpath.v 69 | 70 | _build/ 71 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "[]" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright [yyyy] [name of copyright owner] 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # -*- Makefile -*- 2 | 3 | # -------------------------------------------------------------------- 4 | include Makefile.common 5 | -------------------------------------------------------------------------------- /Makefile.common: -------------------------------------------------------------------------------- 1 | # -*- Makefile -*- 2 | 3 | ###################################################################### 4 | # USAGE: # 5 | # The rules this-config::, this-build::, this-distclean::, # 6 | # pre-makefile::, this-clean:: and __always__:: may be extended # 7 | # Additionally, the following variables may be customized: # 8 | SUBDIRS?= 9 | COQBIN?=$(dir $(shell which coqtop)) 10 | COQMAKEFILE?=$(COQBIN)coq_makefile 11 | COQDEP?=$(COQBIN)coqdep 12 | COQPROJECT?=_CoqProject 13 | COQMAKEOPTIONS?= 14 | COQMAKEFILEOPTIONS?= 15 | V?= 16 | VERBOSE?=V 17 | ###################################################################### 18 | 19 | # local context: ----------------------------------------------------- 20 | .PHONY: all config build clean distclean __always__ 21 | .SUFFIXES: 22 | 23 | H:= $(if $(VERBOSE),,@) # not used yet 24 | TOP = $(dir $(lastword $(MAKEFILE_LIST))) 25 | COQMAKE = $(MAKE) -f Makefile.coq $(COQMAKEOPTIONS) 26 | BRANCH_coq:= $(shell $(COQBIN)coqtop -v | head -1 | grep -E '(trunk|master)' \ 27 | | wc -l | sed 's/ *//g') 28 | 29 | # coq version: 30 | ifneq "$(BRANCH_coq)" "0" 31 | COQVVV:= dev 32 | else 33 | COQVVV:=$(shell $(COQBIN)coqtop --print-version | cut -d" " -f1) 34 | endif 35 | 36 | COQV:= $(shell echo $(COQVVV) | cut -d"." -f1) 37 | COQVV:= $(shell echo $(COQVVV) | cut -d"." -f1-2) 38 | 39 | # all: --------------------------------------------------------------- 40 | all: config build 41 | 42 | # Makefile.coq: ------------------------------------------------------ 43 | .PHONY: pre-makefile 44 | 45 | Makefile.coq: pre-makefile $(COQPROJECT) Makefile 46 | $(COQMAKEFILE) $(COQMAKEFILEOPTIONS) -f $(COQPROJECT) -o Makefile.coq 47 | 48 | # Global config, build, clean and distclean -------------------------- 49 | config: sub-config this-config 50 | 51 | build: sub-build this-build 52 | 53 | clean: sub-clean this-clean 54 | 55 | distclean: sub-distclean this-distclean 56 | 57 | # Local config, build, clean and distclean --------------------------- 58 | .PHONY: this-config this-build this-distclean this-clean 59 | 60 | this-config:: __always__ 61 | 62 | this-build:: this-config Makefile.coq 63 | +$(COQMAKE) 64 | 65 | this-distclean:: this-clean 66 | rm -f Makefile.coq Makefile.coq.conf Makefile.coq 67 | 68 | this-clean:: __always__ 69 | @if [ -f Makefile.coq ]; then $(COQMAKE) cleanall; fi 70 | 71 | # Install target ----------------------------------------------------- 72 | .PHONY: install 73 | 74 | install: __always__ Makefile.coq 75 | $(COQMAKE) install 76 | # counting lines of Coq code ----------------------------------------- 77 | .PHONY: count 78 | 79 | COQFILES = $(shell grep '.v$$' $(COQPROJECT)) 80 | 81 | count: 82 | @coqwc $(COQFILES) | tail -1 | \ 83 | awk '{printf ("%d (spec=%d+proof=%d)\n", $$1+$$2, $$1, $$2)}' 84 | # Additionally cleaning backup (*~) files ---------------------------- 85 | this-distclean:: 86 | rm -f $(shell find . -name '*~') 87 | 88 | # Make in SUBDIRS ---------------------------------------------------- 89 | ifdef SUBDIRS 90 | sub-%: __always__ 91 | @set -e; for d in $(SUBDIRS); do +$(MAKE) -C $$d $(@:sub-%=%); done 92 | else 93 | sub-%: __always__ 94 | @true 95 | endif 96 | 97 | # Make of individual .vo --------------------------------------------- 98 | %.vo: __always__ Makefile.coq 99 | +$(COQMAKE) $@ 100 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 5 | # Hoare Type Theory 6 | 7 | [![Docker CI][docker-action-shield]][docker-action-link] 8 | 9 | [docker-action-shield]: https://github.com/imdea-software/htt/actions/workflows/docker-action.yml/badge.svg?branch=master 10 | [docker-action-link]: https://github.com/imdea-software/htt/actions/workflows/docker-action.yml 11 | 12 | 13 | 14 | 15 | Hoare Type Theory (HTT) is a verification system for reasoning about sequential heap-manipulating 16 | programs based on Separation logic. 17 | 18 | HTT incorporates Hoare-style specifications via preconditions and postconditions into types. A 19 | Hoare type `ST P (fun x : A => Q)` denotes computations with a precondition `P` and postcondition 20 | `Q`, returning a value `x` of type `A`. Hoare types are a dependently typed version of monads, 21 | as used in the programming language Haskell. Monads hygienically combine the language features 22 | for pure functional programming, with those for imperative programming, such as state or 23 | exceptions. In this sense, HTT establishes a formal connection in the style of Curry-Howard 24 | isomorphism between monads and (functional programming variant of) Separation logic. Every 25 | effectful command in HTT has a type that corresponds to the appropriate non-structural inference 26 | rule in Separation logic, and vice versa, every non-structural inference rule corresponds to a 27 | command in HTT that has that rule as the type. The type for monadic bind is the Hoare rule for 28 | sequential composition, and the type for monadic unit combines the Hoare rules for the idle 29 | program (in a small-footprint variant) and for variable assignment (adapted for functional 30 | variables). The connection reconciles dependent types with effects of state and exceptions and 31 | establishes Separation logic as a type theory for such effects. In implementation terms, it means 32 | that HTT implements Separation logic as a shallow embedding in Coq. 33 | 34 | ## Meta 35 | 36 | - Author(s): 37 | - Aleksandar Nanevski (initial) 38 | - Germán Andrés Delbianco 39 | - Alexander Gryzlov 40 | - Marcos Grandury 41 | - License: [Apache-2.0](LICENSE) 42 | - Compatible Coq versions: 8.19 or later 43 | - Additional dependencies: 44 | - [Hierarchy Builder 1.7.0 or later](https://github.com/math-comp/hierarchy-builder) 45 | - [MathComp ssreflect 2.2 or later](https://math-comp.github.io) 46 | - [MathComp algebra](https://math-comp.github.io) 47 | - [MathComp fingroup](https://math-comp.github.io) 48 | - [FCSL-PCM 2.1](https://github.com/imdea-software/fcsl-pcm) 49 | - [Dune](https://dune.build) 3.6 or later 50 | - Coq namespace: `htt` 51 | - Related publication(s): 52 | - [Structuring the verification of heap-manipulating programs](https://software.imdea.org/~aleks/papers/reflect/reflect.pdf) doi:[10.1145/1706299.1706331](https://doi.org/10.1145/1706299.1706331) 53 | 54 | ## Building and installation instructions 55 | 56 | The easiest way to install the latest released version of Hoare Type Theory 57 | is via [OPAM](https://opam.ocaml.org/doc/Install.html): 58 | 59 | ```shell 60 | opam repo add coq-released https://coq.inria.fr/opam/released 61 | opam install coq-htt 62 | ``` 63 | 64 | To instead build and install manually, do: 65 | 66 | ``` shell 67 | git clone https://github.com/imdea-software/htt.git 68 | cd htt 69 | dune build 70 | dune install htt 71 | ``` 72 | 73 | If you also want to build the examples, run `make` instead of `dune`. 74 | 75 | 76 | ## History 77 | 78 | The original version of HTT can be found [here](https://software.imdea.org/~aleks/htt/). 79 | 80 | ## References 81 | 82 | * [Dependent Type Theory of Stateful Higher-Order Functions](https://software.imdea.org/~aleks/papers/hoarelogic/depstate.pdf) 83 | 84 | Aleksandar Nanevski and Greg Morrisett. Technical report TR-24-05, Harvard University, 2005. 85 | 86 | * [Polymorphism and Separation in Hoare Type Theory](http://software.imdea.org/~aleks/htt/icfp06.pdf) 87 | 88 | Aleksandar Nanevski, Greg Morrisett and Lars Birkedal. ICFP 2006. 89 | 90 | The first paper containing a (very impoverished) definition of HTT. 91 | 92 | * [Hoare Type Theory, Polymorphism and Separation](http://software.imdea.org/~aleks/htt/jfpsep07.pdf) 93 | 94 | Aleksandar Nanevski, Greg Morrisett and Lars Birkedal. JFP 2007. 95 | 96 | Journal version of the ICFP 2006 paper. 97 | 98 | * [Abstract Predicates and Mutable ADTs in Hoare Type Theory](http://software.imdea.org/~aleks/htt/esop07.pdf) 99 | 100 | Aleksandar Nanevski, Amal Ahmed, Greg Morrisett, Lars Birkedal. ESOP 2007. 101 | 102 | Adding abstract predicates to HTT. 103 | 104 | * [A Realizability Model for Impredicative Hoare Type Theory](http://software.imdea.org/~aleks/htt/esop08.pdf) 105 | 106 | Rasmus L. Petersen, Lars Birkedal, Aleksandar Nanevski, Greg Morrisett. ESOP 2008. 107 | 108 | A semantic model for HTT, but without large sigma types. 109 | 110 | * [Ynot: Dependent Types for Imperative Programs](http://software.imdea.org/~aleks/htt/ynot08.pdf) 111 | 112 | Aleksandar Nanevski, Greg Morrisett, Avi Shinnar, Paul Govereau, Lars Birkedal. ICFP 2008. 113 | 114 | First implementation of HTT as a DSL in Coq, and a number of examples. 115 | 116 | * [Structuring the Verification of Heap-Manipulating Programs](http://software.imdea.org/~aleks/htt/reflect.pdf) 117 | 118 | Aleksandar Nanevski, Viktor Vafeiadis and Josh Berfine. POPL 2010. 119 | 120 | This paper introduces what is closest to the current structure of the implementation of HTT. 121 | It puts emphasis on structuring programs and proofs together, rather than on attacking the 122 | verification problem using proof automation. It carries out a large case study, verifying the 123 | congruence closure algorithm of the Barcelogic SAT solver. 124 | 125 | The current implementation differs from what's explained in this paper, in that it uses unary, 126 | rather than binary postconditions. 127 | 128 | * [Partiality, State and Dependent Types](http://software.imdea.org/~aleks/htt/tlca11.pdf) 129 | 130 | Kasper Svendsen, Lars Birkedal and Aleksandar Nanevski. TLCA 2011. 131 | 132 | A semantic model for HTT, with large sigma types. 133 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -Q examples htt 2 | -Q htt htt 3 | -docroot docs # where the documentation should go 4 | 5 | -arg -w -arg -notation-overridden 6 | -arg -w -arg -redundant-canonical-projection 7 | 8 | # release-specific arguments 9 | -arg -w -arg -notation-incompatible-prefix # specific to coq8.20.0 10 | -arg -w -arg -deprecated-from-Coq # specific to coq8.21 11 | -arg -w -arg -deprecated-dirpath-Coq # specific to coq8.21 12 | 13 | htt/options.v 14 | htt/domain.v 15 | htt/model.v 16 | htt/heapauto.v 17 | examples/exploit.v 18 | examples/gcd.v 19 | examples/counter.v 20 | examples/llist.v 21 | examples/dlist.v 22 | examples/array.v 23 | examples/queue.v 24 | examples/cyclic.v 25 | examples/stack.v 26 | examples/bintree.v 27 | examples/bst.v 28 | examples/kvmaps.v 29 | examples/hashtab.v 30 | examples/bubblesort.v 31 | examples/quicksort.v 32 | examples/congmath.v 33 | examples/congprog.v 34 | examples/tree.v 35 | examples/union_find.v 36 | -------------------------------------------------------------------------------- /coq-htt-core.opam: -------------------------------------------------------------------------------- 1 | # This file was generated from `meta.yml`, please do not edit manually. 2 | # Follow the instructions on https://github.com/coq-community/templates to regenerate. 3 | 4 | opam-version: "2.0" 5 | maintainer: "fcsl@software.imdea.org" 6 | version: "2.1.0" 7 | 8 | homepage: "https://github.com/imdea-software/htt" 9 | dev-repo: "git+https://github.com/imdea-software/htt.git" 10 | bug-reports: "https://github.com/imdea-software/htt/issues" 11 | license: "Apache-2.0" 12 | 13 | synopsis: "Hoare Type Theory" 14 | description: """ 15 | Hoare Type Theory (HTT) is a verification system for reasoning about sequential heap-manipulating 16 | programs based on Separation logic. 17 | 18 | HTT incorporates Hoare-style specifications via preconditions and postconditions into types. A 19 | Hoare type `ST P (fun x : A => Q)` denotes computations with a precondition `P` and postcondition 20 | `Q`, returning a value `x` of type `A`. Hoare types are a dependently typed version of monads, 21 | as used in the programming language Haskell. Monads hygienically combine the language features 22 | for pure functional programming, with those for imperative programming, such as state or 23 | exceptions. In this sense, HTT establishes a formal connection in the style of Curry-Howard 24 | isomorphism between monads and (functional programming variant of) Separation logic. Every 25 | effectful command in HTT has a type that corresponds to the appropriate non-structural inference 26 | rule in Separation logic, and vice versa, every non-structural inference rule corresponds to a 27 | command in HTT that has that rule as the type. The type for monadic bind is the Hoare rule for 28 | sequential composition, and the type for monadic unit combines the Hoare rules for the idle 29 | program (in a small-footprint variant) and for variable assignment (adapted for functional 30 | variables). The connection reconciles dependent types with effects of state and exceptions and 31 | establishes Separation logic as a type theory for such effects. In implementation terms, it means 32 | that HTT implements Separation logic as a shallow embedding in Coq.""" 33 | 34 | build: [make "-C" "htt" "-j%{jobs}%"] 35 | install: [make "-C" "htt" "install"] 36 | depends: [ 37 | "dune" {>= "3.6"} 38 | "coq" { (>= "8.19" & < "9.1~") | (= "dev") } 39 | "coq-hierarchy-builder" { (>= "1.7.0" & < "1.10~") | (= "dev") } 40 | "coq-mathcomp-ssreflect" { (>= "2.2.0" & < "2.5~") | (= "dev") } 41 | "coq-mathcomp-algebra" 42 | "coq-mathcomp-fingroup" 43 | "coq-fcsl-pcm" { (>= "2.1.0" & < "2.2~") | (= "dev") } 44 | ] 45 | 46 | tags: [ 47 | "category:Computer Science/Data Types and Data Structures" 48 | "keyword:partial commutative monoids" 49 | "keyword:separation logic" 50 | "logpath:htt" 51 | ] 52 | authors: [ 53 | "Aleksandar Nanevski" 54 | "Germán Andrés Delbianco" 55 | "Alexander Gryzlov" 56 | "Marcos Grandury" 57 | ] 58 | -------------------------------------------------------------------------------- /coq-htt.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "fcsl@software.imdea.org" 3 | version: "2.1.0" 4 | 5 | homepage: "https://github.com/imdea-software/htt" 6 | dev-repo: "git+https://github.com/imdea-software/htt.git" 7 | bug-reports: "https://github.com/imdea-software/htt/issues" 8 | license: "Apache-2.0" 9 | 10 | synopsis: "Hoare Type Theory" 11 | description: """ 12 | Hoare Type Theory (HTT) is a verification system for reasoning about sequential heap-manipulating 13 | programs based on Separation logic. 14 | 15 | HTT incorporates Hoare-style specifications via preconditions and postconditions into types. A 16 | Hoare type `ST P (fun x : A => Q)` denotes computations with a precondition `P` and postcondition 17 | `Q`, returning a value `x` of type `A`. Hoare types are a dependently typed version of monads, 18 | as used in the programming language Haskell. Monads hygienically combine the language features 19 | for pure functional programming, with those for imperative programming, such as state or 20 | exceptions. In this sense, HTT establishes a formal connection in the style of Curry-Howard 21 | isomorphism between monads and (functional programming variant of) Separation logic. Every 22 | effectful command in HTT has a type that corresponds to the appropriate non-structural inference 23 | rule in Separation logic, and vice versa, every non-structural inference rule corresponds to a 24 | command in HTT that has that rule as the type. The type for monadic bind is the Hoare rule for 25 | sequential composition, and the type for monadic unit combines the Hoare rules for the idle 26 | program (in a small-footprint variant) and for variable assignment (adapted for functional 27 | variables). The connection reconciles dependent types with effects of state and exceptions and 28 | establishes Separation logic as a type theory for such effects. In implementation terms, it means 29 | that HTT implements Separation logic as a shallow embedding in Coq.""" 30 | 31 | build: [make "-C" "examples" "-j%{jobs}%"] 32 | install: [make "-C" "examples" "install"] 33 | depends: [ 34 | "dune" {>= "3.6"} 35 | "coq" { (>= "8.19" & < "9.1~") | (= "dev") } 36 | "coq-mathcomp-ssreflect" { (>= "2.2.0" & < "2.5~") | (= "dev") } 37 | "coq-mathcomp-algebra" 38 | "coq-mathcomp-fingroup" 39 | "coq-fcsl-pcm" { (>= "2.1.0" & < "2.2~") | (= "dev") } 40 | "coq-htt-core" {= version} 41 | ] 42 | 43 | tags: [ 44 | "category:Computer Science/Data Types and Data Structures" 45 | "keyword:partial commutative monoids" 46 | "keyword:separation logic" 47 | "logpath:htt" 48 | ] 49 | authors: [ 50 | "Aleksandar Nanevski" 51 | "Germán Andrés Delbianco" 52 | "Alexander Gryzlov" 53 | "Marcos Grandury" 54 | ] 55 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.6) 2 | (using coq 0.6) 3 | (name htt) 4 | -------------------------------------------------------------------------------- /examples/Make: -------------------------------------------------------------------------------- 1 | -Q . htt 2 | 3 | -arg -w -arg -notation-overridden 4 | -arg -w -arg -redundant-canonical-projection 5 | 6 | # release-specific arguments 7 | -arg -w -arg -notation-incompatible-prefix # specific to coq8.20.0 8 | -arg -w -arg -deprecated-from-Coq # specific to coq8.21 9 | -arg -w -arg -deprecated-dirpath-Coq # specific to coq8.21 10 | 11 | exploit.v 12 | gcd.v 13 | counter.v 14 | llist.v 15 | dlist.v 16 | array.v 17 | queue.v 18 | cyclic.v 19 | stack.v 20 | bintree.v 21 | bst.v 22 | kvmaps.v 23 | hashtab.v 24 | bubblesort.v 25 | quicksort.v 26 | congmath.v 27 | congprog.v 28 | tree.v 29 | union_find.v 30 | -------------------------------------------------------------------------------- /examples/Makefile: -------------------------------------------------------------------------------- 1 | # -*- Makefile -*- 2 | 3 | # setting variables 4 | COQPROJECT?=Make 5 | 6 | # Main Makefile 7 | include ../Makefile.common 8 | -------------------------------------------------------------------------------- /examples/array.v: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2010 IMDEA Software Institute 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | http://www.apache.org/licenses/LICENSE-2.0 7 | Unless required by applicable law or agreed to in writing, software 8 | distributed under the License is distributed on an "AS IS" BASIS, 9 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 10 | See the License for the specific language governing permissions and 11 | limitations under the License. 12 | *) 13 | 14 | From Coq Require Import ssreflect ssrbool ssrfun. 15 | From mathcomp Require Import ssrnat eqtype seq path fintype tuple finfun finset. 16 | From pcm Require Import options axioms prelude pred. 17 | From pcm Require Import pcm unionmap heap. 18 | From htt Require Import options model heapauto. 19 | 20 | (*********************************) 21 | (* Arrays indexed by finite type *) 22 | (*********************************) 23 | 24 | (* array is (pointer to) a contiguous memory region *) 25 | (* holding the array values *) 26 | 27 | Record array (I : finType) (T : Type) : Set := Array {orig :> ptr}. 28 | Arguments Array {I T}. 29 | 30 | Definition array_for (I : finType) (T : Type) of phant (I -> T) := array I T. 31 | Identity Coercion array_for_array : array_for >-> array. 32 | Notation "{ 'array' aT }" := (array_for (Phant aT)) 33 | (at level 0, format "{ 'array' '[hv' aT ']' }") : type_scope. 34 | 35 | Module Type ArraySig. 36 | Parameter shape : forall {I : finType} {T : Type}, 37 | {array I -> T} -> {ffun I -> T} -> Pred heap. 38 | 39 | (* build new array with all cells initialized to x *) 40 | Parameter new : forall {I : finType} {T : Type} (x : T), 41 | STsep (emp, [vfun (a : {array I -> T}) h => h \In shape a [ffun => x]]). 42 | 43 | (* build new array with cells initialized by finite function f *) 44 | Parameter newf : forall {I : finType} {T : Type} (f : {ffun I -> T}), 45 | STsep (emp, [vfun a h => h \In shape a f]). 46 | 47 | (* free the array *) 48 | Parameter free : forall {I : finType} {T : Type} (a : {array I -> T}), 49 | STsep (fun i => exists f, i \In shape a f, [vfun _ : unit => emp]). 50 | 51 | (* read k-th cell *) 52 | Parameter read : forall {I : finType} {T : Type} (a : {array I -> T}) (k : I), 53 | STsep {f h} (fun i => i = h /\ i \In shape a f, 54 | [vfun (y : T) m => m = h /\ y = f k]). 55 | 56 | (* write k-th cell *) 57 | Parameter write : forall {I : finType} {T : Type} (a : {array I -> T}) k x, 58 | STsep {f} (shape a f, 59 | [vfun (_ : unit) h => h \In shape a (finfun [eta f with k |-> x])]). 60 | End ArraySig. 61 | 62 | 63 | Module Array : ArraySig. 64 | Section Array. 65 | Context {I : finType} {T : Type}. 66 | Notation array := {array I -> T}. 67 | 68 | (* array is specified by finite function *) 69 | Definition shape (a : array) (f : {ffun I -> T}) : Pred heap := 70 | [Pred h | h = updi a (fgraph f)]. 71 | 72 | (* main methods *) 73 | 74 | (* new empty array preallocates all cells for all possible index values *) 75 | (* initializing all of them to `x` *) 76 | Program Definition new (x : T) : 77 | STsep (emp, [vfun a => shape a [ffun => x]]) := 78 | Do (x <-- allocb x #|I|; 79 | ret (Array x)). 80 | Next Obligation. 81 | (* pull out ghost vars, run the program *) 82 | move=>x [] _ /= ->; step=>y; step. 83 | (* simplify *) 84 | rewrite unitR=>_; congr updi; rewrite /= codomE cardE. 85 | by elim: (enum I)=>[|t ts] //= ->; rewrite (ffunE _ _). 86 | Qed. 87 | 88 | (* new array corresponding to a domain of a finite function f *) 89 | 90 | (* loop invariant: *) 91 | (* partially filled array corresponds to finite function g *) 92 | (* acting as prefix of f *) 93 | Definition fill_loop a (f : {ffun I -> T}) : Type := 94 | forall s : seq I, STsep (fun i => exists g s', 95 | [/\ i \In shape a g, 96 | s' ++ s = enum I & 97 | forall x, x \in s' -> g x = f x], 98 | [vfun a => shape a f]). 99 | 100 | Program Definition newf (f : {ffun I -> T}) : 101 | STsep (emp, [vfun a => shape a f]) := 102 | (* `return` helps to avoid extra obligations *) 103 | (* test I for emptiness *) 104 | Do (if [pick x in I] is Some v return _ then 105 | (* preallocate a new array *) 106 | x <-- new (f v); 107 | (* fill it with values of f on I *) 108 | let fill := ffix (fun (loop : fill_loop x f) s => 109 | Do (if s is k::t return _ then 110 | x .+ (indx k) ::= f k;; 111 | loop t 112 | else ret x)) 113 | in fill (enum I) 114 | else ret (Array null)). 115 | (* first the loop *) 116 | Next Obligation. 117 | (* pull out preconditions (note that there are no ghost vars), split *) 118 | move=>f v x loop s [] /= _ [g][s'][->]; case: s=>[|k t] /= H1 H2. 119 | - (* we've reached the end, return the array *) 120 | (* g spans the whole f *) 121 | rewrite cats0 in H1; step=>_; rewrite (_ : g = f) // -ffunP=>y. 122 | by apply: H2; rewrite H1 mem_enum. 123 | (* run the loop iteration, split the heap and save its validity *) 124 | rewrite (updi_split x k); step; apply: vrfV=>V; apply: [gE]=>//=. 125 | (* add the new index+value to g *) 126 | exists (finfun [eta g with k |-> f k]), (s' ++ [:: k]). 127 | (* massage the heap, simplify *) 128 | rewrite /shape (updi_split x k) takeord dropord (ffunE _ _) /= eq_refl -catA. 129 | split=>// y; rewrite ffunE /= mem_cat inE /=. 130 | (* the new g is still a prefix of f *) 131 | by case: eqP=>[->|_] //; rewrite orbF; apply: H2. 132 | Qed. 133 | (* now the outer program *) 134 | Next Obligation. 135 | (* pull out params, check if I is empty *) 136 | move=>f [] _ ->; case: fintype.pickP=>[v|] H /=. 137 | - (* run the `new` subroutine, simplify *) 138 | apply: [stepE]=>//= a _ ->. 139 | (* invoke the loop, construct g from the first value of f *) 140 | by apply: [gE]=>//=; exists [ffun => f v], nil. 141 | (* I is empty, so should be the resulting heap *) 142 | step; rewrite /shape /= codom_ffun. 143 | suff L: #|I| = 0 by case: (fgraph f)=>/=; rewrite L; case. 144 | by rewrite cardE; case: (enum I)=>[|x s] //; move: (H x). 145 | Qed. 146 | 147 | (* freeing an array by deallocating all of its cells *) 148 | 149 | (* the loop invariant: *) 150 | (* a partially freed array still contains valid #|I| - k cells *) 151 | (* corresponding to some suffix xs of the original array's spec *) 152 | Definition free_loop (a : ptr) : Type := 153 | forall k, STsep (fun i => exists xs: seq T, 154 | [/\ i = updi (a .+ k) xs, 155 | valid i & 156 | size xs + k = #|I|], 157 | [vfun _ : unit => emp]). 158 | 159 | Program Definition free (a : array) : 160 | STsep (fun i => exists f, i \In shape a f, 161 | [vfun _ : unit => emp]) := 162 | Do (let go := ffix (fun (loop : free_loop a) k => 163 | Do (if k == #|I| then ret tt 164 | else dealloc a.+k;; 165 | loop k.+1)) 166 | in go 0). 167 | (* first the loop *) 168 | Next Obligation. 169 | (* pull out params, if the remaining suffix xs is empty, we're done *) 170 | move=>a loop k [] i /= [[|v xs]][->] /= _; first by rewrite add0n=>/eqP ->; step. 171 | (* the suffix is non-empty so k < #|I| *) 172 | case: eqP=>[->|_ H]; first by move/eqP; rewrite -{2}(add0n #|I|) eqn_add2r. 173 | (* run the program, simplify *) 174 | step; apply: vrfV=>V; apply: [gE]=>//=; exists xs. 175 | by rewrite V unitL -addSnnS H -addnS. 176 | Qed. 177 | (* now the outer program *) 178 | Next Obligation. 179 | (* pull out params, invoke the loop *) 180 | move=>a [] /= _ [f ->]; apply: vrfV=>V; apply: [gE]=>//=. 181 | (* the suffix xs is the whole codomain of f *) 182 | exists (tval (fgraph f))=>/=. 183 | by rewrite ptr0 V {3}codomE size_map -cardE addn0. 184 | Qed. 185 | 186 | (* reading from an array, doesn't modify the heap *) 187 | Program Definition read (a : array) (k : I) : 188 | STsep {f h} (fun i => i = h /\ i \In shape a f, 189 | [vfun (y : T) m => m = h /\ y = f k]) := 190 | Do (!a .+ (indx k)). 191 | Next Obligation. 192 | (* pull out ghost vars *) 193 | move=>a k [f][_][] _ [->->]. 194 | (* split the heap and run the program *) 195 | by rewrite (updi_split a k); step. 196 | Qed. 197 | 198 | (* writing to an array, updates the spec function with a new value *) 199 | Program Definition write (a : array) (k : I) (x : T) : 200 | STsep {f} (shape a f, 201 | [vfun _ : unit => shape a (finfun [eta f with k |-> x])]) := 202 | Do (a .+ (indx k) ::= x). 203 | Next Obligation. 204 | (* pull out ghost vars, split the heap *) 205 | move=>a k x [f][] _ -> /=; rewrite /shape !(updi_split a k). 206 | (* run the program, simplify *) 207 | by step; rewrite takeord dropord ffunE /= eq_refl. 208 | Qed. 209 | 210 | End Array. 211 | End Array. 212 | 213 | 214 | (* Tabulating a finite function over another one *) 215 | (* Useful in building linked data structures that are pointed to by *) 216 | (* array elements, such as hashtables *) 217 | 218 | Section Table. 219 | Variables (I : finType) (T S : Type) (x : ptr) 220 | (Ps : T -> S -> Pred heap). 221 | 222 | Definition table (t : I -> T) (b : I -> S) (i : I) : Pred heap := 223 | Ps (t i) (b i). 224 | 225 | Lemma tableP (s : {set I}) t1 t2 b1 b2 h : 226 | (forall x, x \in s -> t1 x = t2 x) -> 227 | (forall x, x \in s -> b1 x = b2 x) -> 228 | h \In sepit s (table t1 b1) -> 229 | h \In sepit s (table t2 b2). 230 | Proof. 231 | move=>H1 H2 H. 232 | apply/(sepitF (f1 := table t1 b1))=>//. 233 | by move=>y R; rewrite /table (H1 _ R) (H2 _ R). 234 | Qed. 235 | 236 | Lemma tableP2 (s1 s2 : {set I}) t1 t2 b1 b2 h : 237 | s1 =i s2 -> 238 | (forall x, s1 =i s2 -> x \in s1 -> t1 x = t2 x) -> 239 | (forall x, s1 =i s2 -> x \in s1 -> b1 x = b2 x) -> 240 | h \In sepit s1 (table t1 b1) -> 241 | h \In sepit s2 (table t2 b2). 242 | Proof. 243 | move=>H1 H2 H3; rewrite (eq_sepit _ H1). 244 | by apply: tableP=>y; rewrite -H1=>R; [apply: H2 | apply: H3]. 245 | Qed. 246 | 247 | End Table. 248 | 249 | Prenex Implicits table. 250 | -------------------------------------------------------------------------------- /examples/bintree.v: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2021 IMDEA Software Institute 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | http://www.apache.org/licenses/LICENSE-2.0 7 | Unless required by applicable law or agreed to in writing, software 8 | distributed under the License is distributed on an "AS IS" BASIS, 9 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 10 | See the License for the specific language governing permissions and 11 | limitations under the License. 12 | *) 13 | 14 | From Coq Require Import ssreflect ssrbool ssrfun. 15 | From mathcomp Require Import eqtype seq ssrnat. 16 | From pcm Require Import options axioms pred. 17 | From pcm Require Import pcm unionmap heap autopcm automap. 18 | From htt Require Import options model heapauto. 19 | From htt Require Import llist. 20 | 21 | (* Binary tree specification *) 22 | 23 | Inductive tree A := Leaf | Node of tree A & A & tree A. 24 | 25 | Definition leaf {A} : tree A := @Leaf A. 26 | 27 | Fixpoint size_tree {A} (t : tree A) : nat := 28 | if t is Node l _ r 29 | then (size_tree l + size_tree r).+1 30 | else 0. 31 | 32 | Fixpoint inorder {A} (t : tree A) : seq A := 33 | if t is Node l x r 34 | then inorder l ++ x :: inorder r 35 | else [::]. 36 | 37 | (* Add an element to the rightmost branch *) 38 | Fixpoint addr {A} (y : A) (t : tree A) : tree A := 39 | if t is Node l x r 40 | then Node l x (addr y r) 41 | else Node leaf y leaf. 42 | 43 | (* Tree heap predicate: *) 44 | (* [left branch pointer, value, right branch pointer] *) 45 | Fixpoint shape {A} (p : ptr) (t : tree A) := 46 | if t is Node l a r then 47 | [Pred h | exists l' r' h', 48 | h = p :-> l' \+ (p.+1 :-> a \+ (p.+2 :-> r' \+ h')) 49 | /\ h' \In shape l' l # shape r' r] 50 | else [Pred h | p = null /\ h = Unit]. 51 | 52 | (* Null pointer represents a leaf *) 53 | Lemma shape_null {A} (t : tree A) h : 54 | valid h -> 55 | h \In shape null t -> 56 | t = leaf /\ h = Unit. 57 | Proof. 58 | move=>V; case: t=>/= [|l a r]; first by case=>_->. 59 | by case=>?[?][?][E]; rewrite E validPtUn in V. 60 | Qed. 61 | 62 | (* Non-null pointer represents a node *) 63 | Lemma shape_cont {A} (t : tree A) p h : 64 | p != null -> 65 | h \In shape p t -> 66 | exists l a r l' r' h', 67 | [/\ t = Node l a r, 68 | h = p :-> l' \+ (p.+1 :-> a \+ (p.+2 :-> r' \+ h')) 69 | & h' \In shape l' l # shape r' r]. 70 | Proof. 71 | move=>E; case: t=>/= [|l a r]. 72 | - by case=>E0; rewrite E0 in E. 73 | case=>l' [r'][h'][E1 E2]. 74 | by exists l, a, r, l', r', h'. 75 | Qed. 76 | 77 | Section Tree. 78 | Variable A : Type. 79 | 80 | (* Node creation *) 81 | Program Definition mknode (x : A) : 82 | STsep (emp, 83 | [vfun p => shape p (Node leaf x leaf)]) := 84 | Do (n <-- allocb null 3; 85 | n.+1 ::= x;; 86 | ret n). 87 | Next Obligation. 88 | (* the starting heap is empty *) 89 | move=>x [] _ /= ->. 90 | (* run all the steps *) 91 | step=>n; rewrite !unitR; step; step=>_. 92 | (* the postcondition is satisfied *) 93 | by exists null, null, Unit; vauto; rewrite unitR. 94 | Qed. 95 | 96 | (* Recursive tree disposal *) 97 | 98 | (* Start from a well-formed tree, and arrive at empty heap *) 99 | Definition disposetreeT : Type := 100 | forall p, STsep {t : tree A} (shape p t, [vfun _ : unit => emp]). 101 | 102 | Program Definition disposetree : disposetreeT := 103 | ffix (fun (loop : disposetreeT) p => 104 | Do (if p == null then ret tt 105 | else l <-- !p; 106 | r <-- !p.+2; 107 | loop l;; 108 | loop r;; 109 | dealloc p;; 110 | dealloc p.+1;; 111 | dealloc p.+2 112 | )). 113 | Next Obligation. 114 | (* pull out ghost var + precondition, branch on null check *) 115 | move=>loop p [t][] i /= H; case: eqP H=>[{p}->|/eqP E] H. 116 | - (* null pointer is an empty tree, so the heap is empty *) 117 | by apply: vrfV=>V; step=>_; case: (shape_null V H). 118 | (* non-null pointer is a node, deconstruct it, read branch pointers *) 119 | case: (shape_cont E H)=>l[a][r][l'][r'][_][{t H E}_ {i}-> [hl][hr][-> Hl Hr]]. 120 | do 2!step. 121 | (* recursive calls vacate left+right subheaps *) 122 | apply: [stepX l]@hl=>//= _ _ ->; rewrite unitL. 123 | apply: [stepX r]@hr=>//= _ _ ->; rewrite unitR. 124 | (* deallocating the node vacates the remainder *) 125 | by do 3!step; rewrite !unitL. 126 | Qed. 127 | 128 | (* Calculate tree size *) 129 | 130 | (* loop invariant: *) 131 | (* the subtree size is added to the accumulator *) 132 | Definition treesizeT : Type := forall (ps : ptr * nat), 133 | STsep {t : tree A} (shape ps.1 t, 134 | [vfun s h => s == ps.2 + size_tree t /\ shape ps.1 t h]). 135 | 136 | Program Definition treesize p : 137 | STsep {t : tree A} (shape p t, 138 | [vfun s h => s == size_tree t /\ shape p t h]) := 139 | Do (let len := ffix (fun (go : treesizeT) '(p, s) => 140 | Do (if p == null then ret s 141 | else l <-- !p; 142 | r <-- !p.+2; 143 | ls <-- go (l, s); 144 | go (r, ls.+1))) 145 | in len (p, 0)). 146 | Next Obligation. 147 | (* pull out ghost var + precondition, branch on null check *) 148 | move=>_ go _ p s /= [t][] i /= H; case: eqP H=>[{p}->|/eqP Ep] H. 149 | (* empty tree has size 0 *) 150 | - by step=>V; case: (shape_null V H)=>->->/=; rewrite addn0. 151 | (* non-null pointer is a node, deconstruct it, read branch pointers *) 152 | case: (shape_cont Ep H)=>l[a][r][l'][r'][_][{t H}-> {i}-> [hl][hr][-> Hl Hr]]. 153 | do 2!step. 154 | (* calculate left branch size, update the accumulator *) 155 | apply: [stepX l]@hl=>//= _ hl' [/eqP -> Hl']. 156 | (* add 1 to accumulator and calculate right branch size *) 157 | apply: [gX r]@hr=>//= _ hr' [/eqP -> Hr'] _. 158 | (* finish with simple arithmetic and heap manipulation *) 159 | by split; [rewrite addnS addSn addnA | vauto]. 160 | Qed. 161 | Next Obligation. 162 | (* pull out ghost var + precondition, start loop with empty accumulator *) 163 | by move=>/= p [t][] i /= H; apply: [gE t]. 164 | Qed. 165 | 166 | (* Tree in-order traversal, storing the values in a linked list *) 167 | 168 | (* loop invariant: *) 169 | (* the subtree is unchanged, its values are prepended to the accumulator list *) 170 | Definition inordertravT : Type := forall (ps : ptr * ptr), 171 | STsep {(t : tree A) (l : seq A)} 172 | (shape ps.1 t # lseq ps.2 l, 173 | [vfun s h => h \In shape ps.1 t # lseq s (inorder t ++ l)]). 174 | 175 | Program Definition inordertrav p : 176 | STsep {t : tree A} (shape p t, 177 | [vfun s h => h \In shape p t # lseq s (inorder t)]) := 178 | Do (let loop := ffix (fun (go : inordertravT) '(p, s) => 179 | Do (if p == null then ret s 180 | else l <-- !p; 181 | a <-- !p.+1; 182 | r <-- !p.+2; 183 | s1 <-- go (r, s); 184 | s2 <-- insert s1 (a : A); 185 | go (l, s2))) 186 | in n <-- new A; 187 | loop (p, n)). 188 | Next Obligation. 189 | (* pull out ghosts + precondition, destruct heap, branch on null check *) 190 | move=>_ go _ p s /= [t][xs][] _ /= [h1][h2][-> H1 H2]. 191 | case: eqP H1=>[{p}->|/eqP Ep] H1. 192 | (* return the accumulated list - empty tree has no values *) 193 | - by step=>V; case: (shape_null (validL V) H1)=>->->/=; vauto. 194 | (* non-empty tree is a node *) 195 | (* deconstruct the node, read the pointers and the value *) 196 | case: (shape_cont Ep H1)=>l[a][r][l'][r'][_][{t H1}-> {h1}-> 197 | [hl][hr][-> Hl Hr]] /=; do 3!step. 198 | (* run traversal on the right branch first *) 199 | (* (it's cheaper to grow a linked list to the left) *) 200 | apply: [stepX r, xs]@(hr \+ h2)=>//=; first by vauto. 201 | (* subheaps exist corresponding to left/right branches and updated list *) 202 | move=>s1 _ [hr'][hs][-> Hr' Hs]. 203 | (* prepend the node value to the list *) 204 | apply: [stepX (inorder r ++ xs)]@hs=>//= pa _ [s2][h'][-> H']. 205 | (* run the traversal on the left branch with updated list *) 206 | apply: [gX l, (a::inorder r ++ xs)]@(hl \+ pa :-> a \+ pa.+1 :-> s2 \+ h')=>//=. 207 | (* the precondition is satisfied by simple heap manipulation *) 208 | - exists hl, (pa :-> a \+ (pa.+1 :-> s2 \+ h')). 209 | by split=>//=; [rewrite !joinA | vauto]. 210 | (* the postcondition is also satisfied by simple massaging *) 211 | move=>s3 _ [hl''][hs'][-> Hl'' Hs'] _. 212 | exists (p :-> l' \+ (p.+1 :-> a \+ (p.+2 :-> r' \+ (hl'' \+ hr')))), hs'. 213 | split; try by hhauto. 214 | by rewrite -catA. 215 | Qed. 216 | Next Obligation. 217 | (* pull out ghost var + precondition *) 218 | move=>/= p [t][] i /= H. 219 | (* make an empty list by framing on Unit *) 220 | (* this just sets n to null, but we stick to the list API *) 221 | apply: [stepU]=>//= _ _ [->->]; rewrite unitL. 222 | (* start the loop, conditions are satisfied by simple massaging *) 223 | apply: [gE t, [::]]=>//=. 224 | - by exists i, Unit; split=>//; rewrite unitR. 225 | by move=>s m; rewrite cats0. 226 | Qed. 227 | 228 | (* Expanding the tree to the right *) 229 | 230 | (* loop invariant: the value is added to the rightmost branch *) 231 | Definition expandrightT x : Type := forall (p : ptr), 232 | STsep {t : tree A} (shape p t, 233 | [vfun p' => shape p' (addr x t)]). 234 | 235 | Program Definition expandright x : expandrightT x := 236 | ffix (fun (go : expandrightT x) p => 237 | Do (if p == null 238 | then n <-- mknode x; 239 | ret n 240 | else pr <-- !p.+2; 241 | p' <-- go pr; 242 | p.+2 ::= p';; 243 | ret p)). 244 | Next Obligation. 245 | (* pull out ghost + precondition, branch on null check *) 246 | move=>x go p [t []] i /= H; case: eqP H=>[{p}->|/eqP Ep] H. 247 | - (* tree is empty, make a new node and return it *) 248 | apply: vrfV=>V; case: (shape_null V H)=>{t H}->{i V}->. 249 | by apply: [stepE]=>//= n m H; step. 250 | (* tree is non-empty, i.e. a node, deconstruct it *) 251 | case: (shape_cont Ep H)=>l[z][r][pl][pr][_][{t H}->{i}->][hl][hr][-> Hl Hr]. 252 | (* run the rest of the program on the right branch + subheap *) 253 | by step; apply: [stepX r]@hr=>//= p' h' H'; do 2!step; vauto. 254 | Qed. 255 | 256 | End Tree. 257 | -------------------------------------------------------------------------------- /examples/bst.v: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2021 IMDEA Software Institute 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | http://www.apache.org/licenses/LICENSE-2.0 7 | Unless required by applicable law or agreed to in writing, software 8 | distributed under the License is distributed on an "AS IS" BASIS, 9 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 10 | See the License for the specific language governing permissions and 11 | limitations under the License. 12 | *) 13 | 14 | From Coq Require Import ssreflect ssrbool ssrfun. 15 | From mathcomp Require Import eqtype ssrnat seq path. 16 | From pcm Require Import options axioms pred ordtype seqext. 17 | From pcm Require Import pcm unionmap heap autopcm automap. 18 | From htt Require Import options model heapauto bintree. 19 | 20 | Section BST. 21 | Context {T : ordType}. 22 | 23 | (* Binary _search_ tree is a binary tree structurally, plus: *) 24 | (* 1. its elements have an ordering defined on them *) 25 | (* 2. the following recursive invariant is satisfied: *) 26 | (* - all left branch elements are smaller than the node value & *) 27 | (* - all right branch elements are larger than the node value *) 28 | 29 | (* Search tree operations *) 30 | 31 | Fixpoint insert x (t : tree T) : tree T := 32 | if t is Node l a r then 33 | if x == a then Node l a r 34 | else if ord x a then Node (insert x l) a r 35 | else Node l a (insert x r) 36 | else Node leaf x leaf. 37 | 38 | Fixpoint search (t : tree T) x : bool := 39 | if t is Node l a r then 40 | if x == a then true 41 | else if ord x a then search l x 42 | else search r x 43 | else false. 44 | 45 | (* Search tree invariant & its interaction with operations *) 46 | 47 | Fixpoint bst (t : tree T) : bool := 48 | if t is Node l a r then 49 | [&& all (ord^~ a) (inorder l), all (ord a) (inorder r), bst l & bst r] 50 | else true. 51 | 52 | (* BSTs and sorted lists can both be used to implement lookup structures *) 53 | (* but trees are more efficient computationally, while lists are simpler *) 54 | (* to reason about, since the operations on them are associative and *) 55 | (* commute in many cases. One can switch between two specification styles *) 56 | (* via in-order traversal. *) 57 | 58 | Lemma bst_to_sorted (t : tree T) : 59 | bst t = sorted ord (inorder t). 60 | Proof. 61 | elim: t=>//=l -> a r ->. 62 | by rewrite sorted_cat_cons_cat /= cats1 sorted_rconsE //= 63 | (path_sortedE (@trans T)) andbACA -andbA. 64 | Qed. 65 | 66 | (* In-order specification for insertion *) 67 | Lemma inorder_insert x (t : tree T) : 68 | bst t -> 69 | perm_eq (inorder (insert x t)) 70 | (if x \in inorder t then inorder t else x :: inorder t). 71 | Proof. 72 | elim: t=>//=l IHl a r IHr /and4P [Hal Har /IHl Hl /IHr Hr] {IHl IHr}. 73 | rewrite mem_cat inE; case: (ifP [|| _, _ | _]). 74 | - case/or3P=>H. 75 | - rewrite H in Hl; move/allP: Hal=>/(_ x H) /[dup] Hxa /ord_neq/negbTE ->. 76 | by rewrite Hxa; apply/permEl/perm_catr. 77 | - by rewrite H. 78 | rewrite H in Hr; move/allP: Har=>/(_ x H) /[dup] /nsym/negP/negbTE ->. 79 | move/ord_neq; rewrite eq_sym =>/negbTE -> /=. 80 | by apply/permEl/perm_catl; rewrite perm_cons. 81 | move/negbT; rewrite !negb_or; case/and3P=>/negbTE Hxl /negbTE -> /negbTE Hxr. 82 | rewrite {}Hxl in Hl; rewrite {}Hxr in Hr. 83 | case: ifP=>/= H; first by rewrite -cat_cons; apply/permEl/perm_catr. 84 | rewrite -(cat1s x) -(cat1s a) -(cat1s a (inorder r)). 85 | rewrite perm_sym perm_catC -!catA catA perm_sym catA. 86 | apply/permEl/perm_catl; apply: (perm_trans Hr). 87 | by rewrite cats1 -perm_rcons. 88 | Qed. 89 | 90 | (* Corollary: insertion preserves the tree invariant *) 91 | Lemma bst_insert x (t : tree T) : bst t -> bst (insert x t). 92 | Proof. 93 | elim: t=>//=l IHl a r IHr /and4P [Hal Har Hl Hr]. 94 | case: ifP; first by move=>_ /=; rewrite Hal Har Hl Hr. 95 | move=>Hx; case: ifP=>Ho /=. 96 | - rewrite Har (IHl Hl) Hr /= andbT (perm_all _ (inorder_insert x Hl)). 97 | by case: ifP=>//= _; rewrite Ho. 98 | rewrite Hal Hl (IHr Hr) /= andbT (perm_all _ (inorder_insert x Hr)). 99 | case: ifP=>//= _; rewrite Har andbT. 100 | by case: ordP=>//; [rewrite Ho| rewrite Hx]. 101 | Qed. 102 | 103 | (* Insertion commutes on in-order representation *) 104 | Lemma insert_insert_perm x1 x2 (t : tree T) : 105 | bst t -> 106 | perm_eq (inorder (insert x1 (insert x2 t))) 107 | (inorder (insert x2 (insert x1 t))). 108 | Proof. 109 | move=>H. 110 | have H1: (bst (insert x1 t)) by apply: bst_insert. 111 | have H2: (bst (insert x2 t)) by apply: bst_insert. 112 | apply: (perm_trans (inorder_insert x1 H2)); rewrite perm_sym. 113 | apply: (perm_trans (inorder_insert x2 H1)). 114 | move: (inorder_insert x1 H)=>{H1}Hi1. 115 | move: (inorder_insert x2 H)=>{H2}Hi2. 116 | rewrite (perm_mem Hi1 x2) (perm_mem Hi2 x1). 117 | case Hx1: (x1 \in inorder t); case Hx2: (x2 \in inorder t). 118 | - apply: (perm_trans Hi1); rewrite Hx1 perm_sym. 119 | by apply: (perm_trans Hi2); rewrite Hx2. 120 | - rewrite inE Hx1 orbT perm_sym. 121 | apply: (perm_trans Hi2); rewrite Hx2 perm_cons perm_sym. 122 | by apply: (perm_trans Hi1); rewrite Hx1. 123 | - rewrite Hx1 inE Hx2 orbT. 124 | apply: (perm_trans Hi1); rewrite Hx1 perm_cons perm_sym. 125 | by apply: (perm_trans Hi2); rewrite Hx2. 126 | rewrite !inE Hx2 Hx1 !orbF; case: ifP. 127 | - by move/eqP=>->; rewrite eq_refl. 128 | rewrite eq_sym =>->. 129 | move: Hi1; rewrite -(perm_cons x2) Hx1=>H'; apply: (perm_trans H'). 130 | rewrite -cat1s -(cat1s x1) perm_catCA /= perm_cons perm_sym. 131 | by apply: (perm_trans Hi2); rewrite Hx2. 132 | Qed. 133 | 134 | (* Moreover, such representations are equal *) 135 | Lemma insert_insert x1 x2 (t : tree T) : 136 | bst t -> 137 | inorder (insert x1 (insert x2 t)) = 138 | inorder (insert x2 (insert x1 t)). 139 | Proof. 140 | move=>H; apply: ord_sorted_eq. 141 | - by rewrite -bst_to_sorted; do 2!apply: bst_insert. 142 | - by rewrite -bst_to_sorted; do 2!apply: bst_insert. 143 | by apply/perm_mem/insert_insert_perm. 144 | Qed. 145 | 146 | (* Lookup in the tree is equivalent to lookup in the in-order *) 147 | Lemma inorder_search (t : tree T) : 148 | bst t -> 149 | search t =i inorder t. 150 | Proof. 151 | move=>+ x; elim: t=>//=l IHl a r IHr /and4P [Hal Har /IHl Hl /IHr Hr] {IHl IHr}. 152 | rewrite -topredE /= in Hl; rewrite -topredE /= in Hr. 153 | rewrite -topredE /= mem_cat inE {}Hl {}Hr. 154 | case: ifP=>_ /=; first by rewrite orbT. 155 | case: ifP=>Hx. 156 | - suff: x \notin inorder r by move/negbTE=>->/=; rewrite orbF. 157 | by apply: (all_notin Har); apply/negP/nsym. 158 | suff: x \notin inorder l by move/negbTE=>->. 159 | by apply: (all_notin Hal)=>/=; rewrite Hx. 160 | Qed. 161 | 162 | (* Pointer-based procedures *) 163 | 164 | (* Inserting into the BST *) 165 | 166 | Definition inserttreeT x : Type := 167 | forall p, 168 | STsep {t : tree T} (shape p t, 169 | [vfun p' => shape p' (insert x t)]). 170 | 171 | Program Definition inserttree x : inserttreeT x := 172 | ffix (fun (go : inserttreeT x) p => 173 | Do (if p == null 174 | then n <-- mknode x; 175 | ret n 176 | else a <-- !p.+1; 177 | if x == a then ret p 178 | else 179 | if ord x a then 180 | l <-- !p; 181 | l' <-- go l; 182 | p ::= l';; 183 | ret p 184 | else 185 | r <-- !p.+2; 186 | r' <-- go r; 187 | p.+2 ::= r';; 188 | ret p)). 189 | Next Obligation. 190 | (* pull out ghost + precondition, branch on null check *) 191 | move=>x go p [t][] i /= H; case: eqP H=>[{p}->|/eqP E] H. 192 | (* the tree is empty, make a new node *) 193 | - apply: vrfV=>V; case: (shape_null V H)=>{t H}->{i V}->. 194 | by apply: [stepE]=>// n m H; step. 195 | (* the tree is a node, deconstruct it *) 196 | case: (shape_cont E H)=>l[z][r][pl][pr][_][{t H}->{i}->][hl][hr][-> Hl Hr]. 197 | (* read the value, if the element is equal to it, just exit *) 198 | (* the tree shouldn't have duplicates *) 199 | step; case: eqP=>_; first by step; vauto. 200 | (* branch on comparison, read corresponding pointer *) 201 | case: ifP=>Ho; step. 202 | (* insert in the left branch, update the left pointer *) 203 | - apply: [stepX l]@hl=>//= p' h' H'. 204 | by do 2!step; vauto. 205 | (* insert in the right branch, update the right pointer *) 206 | apply: [stepX r]@hr=>//= p' h' H'. 207 | by do 2!step; vauto. 208 | Qed. 209 | 210 | (* Lookup in the BST *) 211 | 212 | (* lopp invariant: the tree is unchanged, return true if the element is found *) 213 | Definition searchtreeT x : Type := 214 | forall p, 215 | STsep {t : tree T} (shape p t, 216 | [vfun b h => shape p t h /\ b == search t x]). 217 | 218 | Program Definition searchtree x : searchtreeT x := 219 | ffix (fun (go : searchtreeT x) p => 220 | Do (if p == null then ret false 221 | else a <-- !p.+1; 222 | if x == a then ret true 223 | else if ord x a then 224 | l <-- !p; 225 | go l 226 | else 227 | r <-- !p.+2; 228 | go r)). 229 | Next Obligation. 230 | (* pull out ghost + precondition, branch on null check *) 231 | move=>x go p [t][] i /= H; case: eqP H=>[{p}->|/eqP E] H. 232 | (* tree is empty, it can't contain anything *) 233 | - by apply: vrfV=>V; case: (shape_null V H)=>{t H}->{i V}->; step. 234 | (* the tree is a node, deconstruct it *) 235 | case: (shape_cont E H)=>l[z][r][pl][pr][_][{t H}->{i}->][hl][hr][-> Hl Hr]. 236 | (* read the value, compare it to the element, return true if it matches *) 237 | step; case: eqP=>_; first by step; vauto. 238 | (* branch on comparison, read corresponding pointer *) 239 | case: ifP=>Ho; step. 240 | (* loop on the left branch *) 241 | - by apply: [gX l]@hl=>//= b h' [H' E'] _; vauto. 242 | (* loop on the right branch *) 243 | by apply: [gX r]@hr=>//= b h' [H' E'] _; vauto. 244 | Qed. 245 | 246 | (* test that the API is consistent, i.e. BST invariant is preserved *) 247 | (* and lookup finds previously inserted elements *) 248 | Program Definition test p x1 x2 : 249 | STsep {t : tree T} (fun h => shape p t h /\ bst t, 250 | [vfun (pb : ptr * bool) h => 251 | let t' := insert x2 (insert x1 t) in 252 | [/\ shape pb.1 t' h, bst t' & pb.2]]) := 253 | Do (p1 <-- inserttree x1 p; 254 | p2 <-- inserttree x2 p1; 255 | b <-- searchtree x1 p2; 256 | ret (p2, b)). 257 | Next Obligation. 258 | (* pull out ghost + precondition *) 259 | move=>p x1 x2 [t][] i /= [Ht Hi]. 260 | (* run the subroutines, return the final tree and the lookup result *) 261 | apply: [stepE t]=>//= {p i Ht} p1 h1 H1. 262 | apply: [stepE (insert x1 t)]=>//= {p1 h1 H1} p2 h2 H2. 263 | apply: [stepE (insert x2 (insert x1 t))]=>//= {h2 H2} b h3 [H3 /eqP Hb]. 264 | step=>_. 265 | (* insertions preserve the invariant *) 266 | have Hi2: bst (insert x2 t) by apply: bst_insert. 267 | have Hi21: bst (insert x2 (insert x1 t)) by do 2!apply: bst_insert. 268 | (* separation logic part (i.e. part about mutable state) is done *) 269 | (* the only remaining non-trivial goal is showing that *) 270 | (* search is consistent with insert *) 271 | split=>//{p2 h3 H3}; rewrite {b}Hb. 272 | (* switch to in-order lookup *) 273 | move: (inorder_search Hi21 x1); rewrite -topredE /= =>->. 274 | (* use the insertion commutativity, unroll the insertion spec *) 275 | rewrite (insert_insert _ _ Hi) (perm_mem (inorder_insert x1 Hi2) x1). 276 | (* the goal is now trivially solved by case *) 277 | by case: ifP=>// _; rewrite inE eq_refl. 278 | Qed. 279 | 280 | End BST. 281 | -------------------------------------------------------------------------------- /examples/counter.v: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2010 IMDEA Software Institute 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | http://www.apache.org/licenses/LICENSE-2.0 7 | Unless required by applicable law or agreed to in writing, software 8 | distributed under the License is distributed on an "AS IS" BASIS, 9 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 10 | See the License for the specific language governing permissions and 11 | limitations under the License. 12 | *) 13 | 14 | From mathcomp Require Import ssreflect ssrbool ssrfun. 15 | From mathcomp Require Import ssrnat eqtype. 16 | From pcm Require Import options axioms prelude pred. 17 | From pcm Require Import pcm unionmap heap. 18 | From htt Require Import options model heapauto. 19 | 20 | (* counter that hides local state with an abstract predicate *) 21 | 22 | Prenex Implicits exist. 23 | 24 | Record cnt : Type := 25 | Counter {inv : nat -> Pred heap; 26 | method : STsep {v : nat} (inv v, 27 | [vfun y m => y = v /\ m \In inv v.+1])}. 28 | 29 | Program Definition new : STsep (emp, [vfun y m => m \In inv y 0]) := 30 | Do (x <-- alloc 0; 31 | ret (@Counter (fun v => [Pred h | h = x :-> v]) 32 | (Do (y <-- !x; 33 | x ::= y.+1;; 34 | ret y)))). 35 | Next Obligation. 36 | by move=>x [v][] _ /= ->; do 3!step. 37 | Qed. 38 | Next Obligation. 39 | move=>[] _ /= ->. 40 | (* ordinarily step should work here *) 41 | (* but it doesn't; we suspect because universe levels are off *) 42 | (* but error messages aren't helpful *) 43 | (* one can still finish the step manually *) 44 | apply/vrf_bnd/vrf_alloc=>x; rewrite unitR=>_. 45 | (* after which, automation proceeds to work *) 46 | by step. 47 | Qed. 48 | 49 | (* Hiding local state with an abstract predicate is logically expensive, *) 50 | (* as the resulting abstract package must have a large type (since it *) 51 | (* includes a heap predicate). Hence, the package cannot be stored into *) 52 | (* the heap. *) 53 | (* *) 54 | (* This is not particularly hurtful in the current model, since the model *) 55 | (* assigns large types to computations anyway. But the later can easily *) 56 | (* be changed using the Petersen-Birkedal denotational model. *) 57 | (* *) 58 | (* Once we switch to the new model, we can hide the local state of the *) 59 | (* object by abstracting over the "representation" of the inv predicate, *) 60 | (* as follows. *) 61 | 62 | Inductive rep : Type := Rep of ptr & nat. 63 | Definition rptr r := let: Rep l _ := r in l. 64 | Definition rval r := let: Rep _ v := r in v. 65 | Definition interp (r : rep) : Pred heap := [Pred h | h = rptr r :-> rval r]. 66 | 67 | Record scnt : Type := 68 | SCount {sinv : nat -> rep; 69 | smethod : STsep {v : nat} 70 | (interp (sinv v), 71 | [vfun y m => y = v /\ m \In interp (sinv v.+1)])}. 72 | 73 | Program Definition snew : STsep (emp, 74 | [vfun y m => m \In interp (sinv y 0)]) := 75 | Do (x <-- alloc 0; 76 | ret (@SCount (fun v => Rep x v) 77 | (Do (y <-- !x; 78 | x ::= y.+1;; 79 | ret y)))). 80 | Next Obligation. 81 | move=>x [v][] i; rewrite /interp /= => {i}->. 82 | by do 3!step. 83 | Qed. 84 | Next Obligation. 85 | move=>[] _ /= ->. 86 | apply/vrf_bnd/vrf_alloc=>x; rewrite unitR=>_. 87 | by step. 88 | Qed. 89 | 90 | (* This solution replaces the abstract predicate inv with a type of *) 91 | (* representations, and a semantic function that interprets the *) 92 | (* representation into a predicate. We will typically want to prevent *) 93 | (* clients from looking at the representation, which can be done either *) 94 | (* by making the type rep abstract, or by using some kind of *) 95 | (* computational irrelevance to make the sinv component of scnd *) 96 | (* inaccessible to programs. One possible solution for the later is to *) 97 | (* add new irrelevance constructors into type theory, as *) 98 | (* suggested by Pfenning, or Barras. *) 99 | (* *) 100 | (* Or, one can choose inv to have the type nat -> rep -> Prop, as shown *) 101 | (* below. The type nat -> rep -> Prop is still a small type (it doesn't *) 102 | (* quantify over heaps). So a package containing such an invariant will *) 103 | (* be storable in the heap. *) 104 | 105 | Definition pinterp (R : rep -> Prop) : Pred heap := 106 | [Pred h | forall r, R r -> h = rptr r :-> rval r]. 107 | 108 | Record pcnt : Type := 109 | PCount {pinv : nat -> rep -> Prop; 110 | pmethod : STsep {v : nat} 111 | (pinterp (pinv v), 112 | [vfun y m => y = v /\ m \In pinterp (pinv v.+1)])}. 113 | 114 | Program Definition pnew : STsep (emp, 115 | [vfun y m => m \In pinterp (pinv y 0)]) := 116 | Do (x <-- alloc 0; 117 | ret (@PCount (fun v r => r = Rep x v) 118 | (Do (y <-- !x; 119 | x ::= y.+1;; 120 | ret y)))). 121 | Next Obligation. 122 | move=>x [v][] i /=; rewrite /pinterp /= => /(_ _ erefl) {i}-> /=. 123 | by do 3!step; move=>?; split=>// _ ->. 124 | Qed. 125 | Next Obligation. 126 | move=>[] _ /= ->. 127 | apply/vrf_bnd/vrf_alloc=>x; rewrite unitR=>_. 128 | by step=>_ /= _ ->. 129 | Qed. 130 | 131 | (* Of course, the solution is still not quite abstract, since one cannot *) 132 | (* store the interpretation function together with the package, but that *) 133 | (* seems unavoidable due to the restrictions of impredicativity. We have *) 134 | (* still gained something by using representations, however; we have made *) 135 | (* programs with local state storable -- something that is not possible *) 136 | (* if we use abstraction over heap predicates. *) 137 | (* *) 138 | (* An altogether different approach is to define heaps as storing not *) 139 | (* types, but type representations, with a global interpretation *) 140 | (* function. The later, being global, will not need to be stored into *) 141 | (* heaps. Then heaps will be a small type, and we can freely abstract over *) 142 | (* them. This lifts the representation approach to a global level, making *) 143 | (* it potentially more uniform, but it also makes it seemingly much more *) 144 | (* difficult. *) 145 | -------------------------------------------------------------------------------- /examples/cyclic.v: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2021 IMDEA Software Institute 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | http://www.apache.org/licenses/LICENSE-2.0 7 | Unless required by applicable law or agreed to in writing, software 8 | distributed under the License is distributed on an "AS IS" BASIS, 9 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 10 | See the License for the specific language governing permissions and 11 | limitations under the License. 12 | *) 13 | 14 | From Coq Require Import ssreflect ssrbool ssrfun. 15 | From mathcomp Require Import eqtype seq ssrnat. 16 | From pcm Require Import options axioms pred seqext. 17 | From pcm Require Import pcm unionmap heap auto automap autopcm. 18 | From htt Require Import options model heapauto. 19 | From htt Require Import llist. 20 | 21 | (* queue variant with fixed capacity *) 22 | (* that overwrites data in a circular way *) 23 | 24 | (* the structure is a pair of pointers: *) 25 | (* a mutable length and immutable capacity *) 26 | Record buffer (T : Type) : Type := 27 | Buf {active: ptr; inactive: ptr; len: ptr; capacity: nat}. 28 | 29 | Definition BufferFull : exn := exn_from_nat 10. 30 | Definition BufferEmpty : exn := exn_from_nat 20. 31 | 32 | Module Buffer. 33 | Section Buffer. 34 | Variable T : Type. 35 | Notation buffer := (buffer T). 36 | 37 | (* the active part of the buffer is specified by a given list *) 38 | (* the inactive part by another arbitrary list *) 39 | (* length is the size of the active part, capacity is the sum *) 40 | (* the two parts are joined head-to-tail forming the titular cycle *) 41 | Definition is_buffer (a i : ptr) (m n : nat) (xs : seq T) := 42 | [Pred h | exists (ys : seq T) ha hi, 43 | [/\ h = ha \+ hi, 44 | n = size xs + size ys, 45 | m = size xs, 46 | ha \In lseg a i xs & 47 | hi \In lseg i a ys]]. 48 | 49 | (* the structure itself requires three extra memory cells *) 50 | Definition shape (b : buffer) (xs : seq T) := 51 | [Pred h | exists a i m h', 52 | [/\ valid (active b :-> a \+ (inactive b :-> i \+ (len b :-> m \+ h'))), 53 | h = active b :-> a \+ (inactive b :-> i \+ (len b :-> m \+ h')) & 54 | h' \In is_buffer a i m (capacity b) xs]]. 55 | 56 | (* main methods *) 57 | 58 | (* initializing a new buffer *) 59 | 60 | (* loop invariant for allocating the inner structure *) 61 | Definition new_loopT (n : nat) (init : T) : Type := 62 | forall (pk : ptr * nat), 63 | STsep {q} (fun h => pk.2 < n /\ h \In lseg pk.1 q (nseq pk.2 init), 64 | [vfun p' => lseg p' q (nseq n.-1 init)]). 65 | 66 | (* allocate the buffer with capacity n prefilled by init *) 67 | Program Definition new (n : nat) (init : T) : 68 | STsep (emp, [vfun v => shape v [::]]) := 69 | (* allocate the buffer in a loop *) 70 | Do (let run := ffix (fun (go : new_loopT n init) '(r,k) => 71 | Do (if k < n.-1 then 72 | p' <-- allocb r 2; 73 | p' ::= init;; 74 | go (p', k.+1) 75 | else ret r)) in 76 | if 0 < n then 77 | (* we allocate the initial node separately *) 78 | (* so we have something to "tie" the cycle to *) 79 | p <-- allocb null 2; 80 | p ::= init;; 81 | (* allocate the remaining n-1 nodes by prepending to it *) 82 | q <-- run (p, 0); 83 | (* form the cycle *) 84 | p.+1 ::= q;; 85 | (* allocate the structure *) 86 | m <-- alloc 0; 87 | pi <-- alloc q; 88 | pa <-- alloc q; 89 | ret (Buf T pa pi m n) 90 | else m <-- alloc 0; 91 | pi <-- alloc null; 92 | pa <-- alloc null; 93 | ret (Buf T pa pi m 0)). 94 | (* first the loop *) 95 | Next Obligation. 96 | (* pull out the ghost (the initial node) + preconditions, match on k *) 97 | move=>n init go _ r k [q][] i /= [Hk H]; case: ltnP=>Hk1. 98 | - (* k < n.-1, allocate new node *) 99 | step=>p'; step; rewrite unitR. 100 | (* do the recursive call, both preconditions hold *) 101 | apply: [gE q]=>//=; split; first by rewrite -ltn_predRL. 102 | by exists r, i; rewrite joinA. 103 | (* deduce k = n.-1 from n.-1 <= k < n *) 104 | move: Hk=>/[dup]/ltn_predK=>{1}<-; rewrite ltnS=>Hk. 105 | by step=>_; have/eqP <-: (k == n.-1) by rewrite eqn_leq Hk1 Hk. 106 | Qed. 107 | (* now the outer program *) 108 | Next Obligation. 109 | (* simplify, match on n *) 110 | move=>n init [] _ /= ->; case: ifP=>[N0|_]. 111 | - (* 0 < n, allocate the initial node *) 112 | step=>p; step; rewrite !unitR. 113 | (* run the loop by framing on an empty heap *) 114 | apply: [stepU p]=>//= q h H. 115 | (* run the rest of the program *) 116 | step; step=>m; step=>pi; step=>pa; step=>V. 117 | (* the structure is well-formed if the buffer is *) 118 | exists q, q, 0, (h \+ (p :-> init \+ p.+1 :-> q)); split=>//. 119 | (* most of the conditions hold trivially or by simple arithmetics *) 120 | exists (nseq n init), Unit, (h \+ (p :-> init \+ p.+1 :-> q)); split=>//=. 121 | - by rewrite unitL. 122 | - by rewrite add0n size_nseq. 123 | (* the cycle is well-formed *) 124 | by rewrite -(ltn_predK N0) -rcons_nseq; apply/lseg_rcons; exists p, h. 125 | (* n = 0, allocate a trivial structure with a null buffer *) 126 | step=>m; step=>pi; step=>pa; step=>V. 127 | (* it is well-formed *) 128 | exists null, null, 0, Unit=>/=; split=>//. 129 | by exists [::], Unit, Unit; split=>//; rewrite unitR. 130 | Qed. 131 | 132 | (* "polite" write, checks the buffer length, throws an exception on overflow *) 133 | Program Definition write (x : T) (b : buffer) : 134 | STsep {xs} (shape b xs, 135 | fun y h => match y with 136 | | Val _ => h \In shape b (rcons xs x) 137 | | Exn e => e = BufferFull /\ h \In shape b xs 138 | end) := 139 | Do (m <-- !len b; 140 | if m < capacity b then 141 | i <-- !inactive b; 142 | i ::= x;; 143 | r <-- !i.+1; 144 | inactive b ::= (r : ptr);; 145 | len b ::= m.+1 146 | else throw BufferFull). 147 | Next Obligation. 148 | (* pull out ghost, destructure the precondition *) 149 | move=>x b [xs []] _ /= [a][i][_][h][_ -> [ys][ha][hi][E Ec -> Ha Hi]]. 150 | (* read length, match on it *) 151 | rewrite Ec; step; case: ltnP. 152 | - (* buffer is not full, so the inactive part is non-empty *) 153 | rewrite {h}E -{1}(addn0 (size xs)) ltn_add2l => Hys. 154 | (* read the inactive pointer, unroll the inactive heap so that we can proceed *) 155 | step; case/(lseg_lt0n Hys): Hi=>y [r][h][_ {hi}-> H]; do 4![step]=>{y}V. 156 | (* the new structure is well-formed if the buffer is *) 157 | exists a, r, (size xs).+1, (ha \+ (i :-> x \+ (i.+1 :-> r \+ h))); split=>//. 158 | (* most of the conditions hold trivially or by simple arithmetics *) 159 | exists (behead ys), (ha \+ (i :-> x \+ i.+1 :-> r)), h; split=>//. 160 | - by rewrite !joinA. 161 | - by rewrite Ec size_rcons size_behead -subn1 addnABC // subn1. 162 | - by rewrite size_rcons. 163 | (* the new segment is well-formed *) 164 | by apply/lseg_rcons; exists i, ha. 165 | (* the buffer is full and the inactive part is empty *) 166 | rewrite -{2}(addn0 (size xs)) leq_add2l leqn0 => /nilP Eys. 167 | (* throw the exception *) 168 | step=>V; split=>//. 169 | (* the buffer is unchanged *) 170 | exists a, i, (size xs), h; split=>//. 171 | by exists [::], ha, hi; rewrite Eys in Ec Hi. 172 | Qed. 173 | 174 | (* version that overwrites data in a cyclic fashion *) 175 | (* checking that capacity != 0 is the client's problem *) 176 | (* so it can be dealt with globally *) 177 | Program Definition overwrite (x : T) (b : buffer) : 178 | STsep {xs} (fun h => 0 < capacity b /\ h \In shape b xs, 179 | [vfun _ => shape b (drop ((size xs).+1 - capacity b) 180 | (rcons xs x))]) := 181 | Do (i <-- !inactive b; 182 | i ::= x;; 183 | r <-- !i.+1; 184 | inactive b ::= (r : ptr);; 185 | m <-- !len b; 186 | if m < capacity b then 187 | len b ::= m.+1 188 | else 189 | active b ::= r). 190 | Next Obligation. 191 | (* pull out ghost, destructure the preconditions *) 192 | move=>x b [xs []] _ /= [Hc][a][i][_][_][_ -> [ys][ha][hi][-> Ec -> Ha Hi]]. 193 | (* read the inactive pointer, case split on inactive part *) 194 | (* we do this early on because we need to unroll the heap to proceed *) 195 | rewrite Ec in Hc *; step; case: ys Ec Hi Hc=>/=. 196 | (* inactive part is empty, so the buffer is full *) 197 | (* and the active part is the whole cycle *) 198 | - rewrite addn0=>Ec [Ei {hi}->] Hxs; rewrite unitR; rewrite {i}Ei in Ha *. 199 | (* unroll the (active) heap *) 200 | case/(lseg_lt0n Hxs): Ha=>z[r][h'][Exs {ha}-> H']. 201 | (* run the rest of the program *) 202 | (* the postcondition simplifies to beheading the extended xs *) 203 | do 4!step; rewrite ltnn subSnn drop1; step=>V. 204 | (* the new structure is well-formed if the buffer is *) 205 | exists r, r, (size xs), (a :-> x \+ (a.+1 :-> r \+ h')); split=>//. 206 | (* most of the conditions hold trivially or by simple arithmetics *) 207 | exists [::], (a :-> x \+ (a.+1 :-> r \+ h')), Unit; split=>//=. 208 | - by rewrite unitR. 209 | - by rewrite addn0 size_behead size_rcons. 210 | - by rewrite size_behead size_rcons. 211 | (* xs is non-empty so behead commutes with rcons *) 212 | rewrite behead_rcons //; apply/lseg_rcons. 213 | (* the segment is well-formed *) 214 | by exists a, h'; split=>//; rewrite [in RHS]joinC joinA. 215 | (* inactive part is non-empty, unroll the inactive heap *) 216 | move=>y ys Ec [r][h'][{hi}-> H'] _. 217 | (* run the rest of the program *) 218 | (* the postcondition simplifies to just the extended xs *) 219 | do 4![step]=>{y}; rewrite -{1}(addn0 (size xs)) ltn_add2l /=; step=>V. 220 | rewrite addnS subSS subnDA subnn sub0n drop0. 221 | (* the new structure is well-formed if the buffer is *) 222 | exists a, r, (size xs).+1, (ha \+ (i :-> x \+ (i.+1 :-> r \+ h'))); split=>//. 223 | (* the buffer is well-formed by simple arithmetics *) 224 | exists ys, (ha \+ (i :-> x \+ i.+1 :-> r)), h'; split=>//. 225 | - by rewrite !joinA. 226 | - by rewrite Ec size_rcons addnS addSn. 227 | - by rewrite size_rcons. 228 | by apply/lseg_rcons; exists i, ha. 229 | Qed. 230 | 231 | (* reading (popping) a value from the buffer *) 232 | Program Definition read (b : buffer) : 233 | STsep {xs} (shape b xs, 234 | fun y h => match y with 235 | | Val x => h \In shape b (behead xs) /\ ohead xs = Some x 236 | | Exn e => e = BufferEmpty /\ xs = [::] 237 | end) := 238 | Do (m <-- !len b; 239 | if 0 < m then 240 | a <-- !active b; 241 | x <-- !a; 242 | r <-- !a.+1; 243 | active b ::= (r : ptr);; 244 | len b ::= m.-1;; 245 | ret x 246 | else throw BufferEmpty). 247 | Next Obligation. 248 | (* pull out ghost, destructure precondition *) 249 | move=>b [xs []] _ /= [a][i][_][_][_ -> [ys][ha][hi][-> Hc -> Ha Hi]]. 250 | (* read the length, match on it *) 251 | step; case: ltnP. 252 | (* buffer is non-empty, read the active pointer *) 253 | - move=>Hxs; step. 254 | (* unroll the active heap to proceed *) 255 | case/(lseg_lt0n Hxs): Ha=>x[r][h'][Exs {ha}-> H']. 256 | (* run the rest of the program *) 257 | do 5![step]=>V; split; last by rewrite Exs. 258 | (* the new structure is well-formed if the buffer is *) 259 | exists r, i, (size xs).-1, (a :-> x \+ (a.+1 :-> r \+ h') \+ hi); split=>//. 260 | (* the buffer is well-formed by simple arithmetics *) 261 | exists (rcons ys x), h', (hi \+ (a :-> x \+ a.+1 :-> r)); split=>//. 262 | - by rewrite [LHS](pullX (h' \+ hi)) !joinA. 263 | - by rewrite size_rcons Hc {1}Exs /= addnS addSn. 264 | - by rewrite size_behead. 265 | by apply/lseg_rcons; exists a, hi. 266 | (* throw the exception, buffer is empty and so is the spec *) 267 | by rewrite leqn0=>/nilP->; step. 268 | Qed. 269 | 270 | (* deallocating the buffer *) 271 | (* check that capacity = 0 here, since this should be a rare operation *) 272 | (* of course, it could also be moved into the precondition as for overwrite *) 273 | 274 | (* loop invariant for deallocating the inner structure *) 275 | Definition free_loopT (n : nat) : Type := 276 | forall (pk : ptr * nat), 277 | STsep {q (xs : seq T)} (fun h => h \In lseg pk.1 q xs /\ size xs = n - pk.2, 278 | [vfun _ : unit => emp]). 279 | 280 | Program Definition free (b : buffer) : 281 | STsep {xs} (fun h => h \In shape b xs, 282 | [vfun _ => emp]) := 283 | Do (let run := ffix (fun (go : free_loopT (capacity b)) '(r,k) => 284 | Do (if k < capacity b then 285 | p' <-- !r.+1; 286 | dealloc r;; 287 | dealloc r.+1;; 288 | go (p', k.+1) 289 | else ret tt)) in 290 | (if 0 < capacity b then 291 | a <-- !active b; 292 | run (a, 0);; 293 | skip 294 | else skip);; 295 | dealloc (active b);; 296 | dealloc (inactive b);; 297 | dealloc (len b)). 298 | (* first the loop *) 299 | Next Obligation. 300 | (* pull out ghosts, destructure the preconditions, match on k *) 301 | move=>b go _ r k [q][xs][] h /= [H Hs]; case: ltnP. 302 | (* k < capacity, so the spec is still non-empty *) 303 | - move=>Hk; have {Hk}Hxs: 0 < size xs by rewrite Hs subn_gt0. 304 | (* unroll the heap *) 305 | case/(lseg_lt0n Hxs): H=>x[p][h'][E {h}-> H']. 306 | (* save the next node pointer and deallocate the node *) 307 | do 3!step; rewrite !unitL. 308 | (* run the recursive call, simplify *) 309 | apply: [gE q, behead xs]=>//=; split=>//. 310 | by rewrite subnS; move: Hs; rewrite {1}E /= =><-. 311 | (* k = capacity, so the spec is empty *) 312 | rewrite -subn_eq0=>/eqP Hc; rewrite {}Hc in Hs. 313 | (* this means the heap is empty *) 314 | by step=>_; move: H; move/eqP/nilP: Hs=>->/=; case. 315 | Qed. 316 | (* now the program *) 317 | Next Obligation. 318 | (* pull out ghost, destructure the precondition, match on capacity *) 319 | move=>b [xs][] _ /= [a][i][m][_][_ -> [ys][ha][hi][-> Hc -> Ha Hi]]; case: ltnP. 320 | (* 0 < capacity, first apply vrf_bind to "step into" the `if` block *) 321 | (* run the loop starting from the active part, frame the corresponding heaps *) 322 | - move=>_; apply/vrf_bnd; step; apply: [stepX a, xs++ys]@(ha \+ hi)=>//=. 323 | (* concatenate the active and inactive parts to satisfy the loop precondition *) 324 | - move=>_; split; last by rewrite size_cat subn0. 325 | by apply/lseg_cat; exists i, ha, hi. 326 | (* by deallocating the structure, the heap is emptied *) 327 | by move=>_ _ ->; rewrite unitR; step=>V; do 3![step]=>_; rewrite !unitR. 328 | (* capacity = 0, so just deallocate the structure *) 329 | rewrite leqn0=>/eqP E; do 4!step; rewrite !unitL=>_. 330 | (* both parts of the spec are empty and so are the corresponding heaps *) 331 | move: Hc; rewrite E =>/eqP; rewrite eq_sym addn_eq0=>/andP [/nilP Ex /nilP Ey]. 332 | move: Ha; rewrite Ex /=; case=>_->; move: Hi; rewrite Ey /=; case=>_->. 333 | by rewrite unitR. 334 | Qed. 335 | 336 | End Buffer. 337 | End Buffer. 338 | -------------------------------------------------------------------------------- /examples/dlist.v: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2021 IMDEA Software Institute 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | http://www.apache.org/licenses/LICENSE-2.0 7 | Unless required by applicable law or agreed to in writing, software 8 | distributed under the License is distributed on an "AS IS" BASIS, 9 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 10 | See the License for the specific language governing permissions and 11 | limitations under the License. 12 | *) 13 | 14 | From Coq Require Import ssreflect ssrbool ssrfun. 15 | From mathcomp Require Import ssrnat eqtype seq. 16 | From pcm Require Import options axioms pred. 17 | From pcm Require Import pcm unionmap heap autopcm. 18 | From htt Require Import options model heapauto. 19 | 20 | (* Doubly-linked lists, follows the same structure as singly-linked *) 21 | (* lists, adding a second pointer pointing backwards. *) 22 | 23 | (* The arguments are: preceding node, first node, last node, succeeding node *) 24 | (* Internally we use three cells for a node: value, next node, last node *) 25 | Fixpoint dseg {A} (pp p q qn : ptr) (xs : seq A) := 26 | if xs is hd::tl then 27 | [Pred h | exists r h', 28 | h = p :-> hd \+ (p.+1 :-> r \+ (p.+2:-> pp \+ h')) 29 | /\ h' \In dseg p r q qn tl] 30 | else [Pred h | [/\ p = qn, pp = q & h = Unit]]. 31 | 32 | Section DSeg. 33 | Variable A : Type. 34 | 35 | (* structure of a list segment with appended node *) 36 | 37 | (* adding the predecessor pointer breaks the symmetry with inductive lists *) 38 | (* so we rely on this lemma to manually restructure the spec *) 39 | Lemma dseg_rcons (xs : seq A) x pp p q qn h : 40 | h \In dseg pp p q qn (rcons xs x) <-> 41 | exists r h', 42 | h = h' \+ (q :-> x \+ (q.+1 :-> qn \+ q.+2 :-> r)) 43 | /\ h' \In dseg pp p r q xs. 44 | Proof. 45 | elim: xs pp p h => [|y xs IH] pp p h/=. 46 | - split; case=>r[h'][-> [->->->]]; rewrite ?unitR ?unitL. 47 | - by exists pp, Unit; rewrite unitL. 48 | by exists qn, Unit; rewrite unitR. 49 | split. 50 | - case=>r[_][-> /IH][s][h'][-> H']. 51 | exists s, (p :-> y \+ (p.+1 :-> r \+ (p.+2 :-> pp \+ h'))). 52 | rewrite !joinA; split=>//. 53 | by exists r, h'; rewrite !joinA. 54 | case=>r[_][->][s][h'][-> H']. 55 | exists s, (h' \+ (q :-> x \+ (q.+1 :-> qn \+ q.+2 :-> r))). 56 | rewrite !joinA; split=>//; apply/IH. 57 | by exists r, h'; rewrite !joinA. 58 | Qed. 59 | 60 | (* if first node is null, then list is empty *) 61 | Lemma dseg_nullL (xs : seq A) pp q qn h : 62 | valid h -> 63 | h \In dseg pp null q qn xs -> 64 | [/\ qn = null, pp = q, xs = [::] & h = Unit]. 65 | Proof. 66 | case: xs=>[|x xs] /= D H; first by case: H. 67 | by case: H D=>r[h'][-> _]; rewrite validPtUn eq_refl. 68 | Qed. 69 | 70 | (* if last node is null, then list is empty *) 71 | Lemma dseg_nullR (xs : seq A) pp p qn h : 72 | valid h -> 73 | h \In dseg pp p null qn xs -> 74 | [/\ p = qn, pp = null, xs = [::] & h = Unit]. 75 | Proof. 76 | case/lastP: xs=>[|xs x] D /=; first by case. 77 | case/dseg_rcons=>r[h'][]; move: D=>/[swap]->/validR. 78 | by rewrite validPtUn. 79 | Qed. 80 | 81 | (* deconstruct non-trivial segment from the left *) 82 | Lemma dseg_neqL (xs : seq A) (pp p q qn : ptr) h : 83 | p != qn -> 84 | h \In dseg pp p q qn xs -> 85 | exists x r h', 86 | [/\ xs = x :: behead xs, 87 | h = p :-> x \+ (p.+1 :-> r \+ (p.+2 :-> pp \+ h')) & 88 | h' \In dseg p r q qn (behead xs)]. 89 | Proof. 90 | case: xs=>[|x xs] /= H; last first. 91 | - by case=>r[h'][-> H']; exists x, r, h'. 92 | by case=>E; rewrite E eq_refl in H. 93 | Qed. 94 | 95 | (* deconstruct non-trivial segment from the right *) 96 | Lemma dseg_neqR (xs : seq A) (pp p q qn : ptr) h : 97 | pp != q -> 98 | h \In dseg pp p q qn xs -> 99 | exists s x r h', 100 | [/\ xs = rcons s x, 101 | h = h' \+ (q :-> x \+ (q.+1 :-> qn \+ q.+2 :-> r)) & 102 | h' \In dseg pp p r q s]. 103 | Proof. 104 | case/lastP: xs=>[|xs x] /= H. 105 | - by case=>_ E; rewrite E eq_refl in H. 106 | case/dseg_rcons=>r[h'][{h}-> H']. 107 | by exists xs, x, r, h'. 108 | Qed. 109 | 110 | (* concatenating/splitting lists = concatenating/splitting heaps *) 111 | Lemma dseg_cat (xs ys : seq A) pp p q qn h : 112 | h \In dseg pp p q qn (xs ++ ys) <-> 113 | exists jn j, h \In dseg pp p j jn xs # dseg j jn q qn ys. 114 | Proof. 115 | elim: xs pp p h=>/=. 116 | - move=>pp p h; split; first by move=>H; exists p, pp, Unit, h; rewrite unitL. 117 | by case=>jn [j][h1][h2][{h}-> [->->->]]; rewrite unitL. 118 | move=>x xs IH pp p h; split. 119 | - case=>r [_][{h}-> /IH][jn][j][h1][h2][-> H1 H2]. 120 | exists jn, j, (p :-> x \+ p.+1 :-> r \+ p.+2 :-> pp \+ h1), h2. 121 | by rewrite !joinA; split=>//; exists r, h1; rewrite !joinA. 122 | case=>jn[j][_][h2][{h}->][r][h1][-> H1 H2]. 123 | exists r, (h1 \+ h2); rewrite !joinA; split=>//. 124 | by apply/IH; exists jn, j, h1, h2. 125 | Qed. 126 | 127 | End DSeg. 128 | 129 | (* Special case when pp = null and qn = null, *) 130 | (* i.e. a self-contained doubly-linked list *) 131 | Definition dseq {A} p q (xs : seq A) := dseg null p q null xs. 132 | 133 | Section DList. 134 | Variable A : Type. 135 | 136 | (* specializing the segment lemmas *) 137 | 138 | Lemma dseq_nullL (xs : seq A) q h : 139 | valid h -> 140 | h \In dseq null q xs -> 141 | [/\ q = null, xs = [::] & h = Unit]. 142 | Proof. by move=>D; case/(dseg_nullL D). Qed. 143 | 144 | Lemma dseq_nullR (xs : seq A) p h : 145 | valid h -> 146 | h \In dseq p null xs -> 147 | [/\ p = null, xs = [::] & h = Unit]. 148 | Proof. by move=>D; case/(dseg_nullR D). Qed. 149 | 150 | Lemma dseq_posL (xs : seq A) p q h : 151 | p != null -> 152 | h \In dseq p q xs -> 153 | exists x r h', 154 | [/\ xs = x :: behead xs, 155 | h = p :-> x \+ (p.+1 :-> r \+ (p.+2 :-> null \+ h')) & 156 | h' \In dseg p r q null (behead xs)]. 157 | Proof. by apply: dseg_neqL. Qed. 158 | 159 | Lemma dseq_posR (xs : seq A) p q h : 160 | q != null -> 161 | h \In dseq p q xs -> 162 | exists s x r h', 163 | [/\ xs = rcons s x, 164 | h = h' \+ (q :-> x \+ (q.+1 :-> null \+ q.+2 :-> r)) & 165 | h' \In dseg null p r q s]. 166 | Proof. by rewrite eq_sym=>Hq /(dseg_neqR Hq). Qed. 167 | 168 | (* main methods *) 169 | 170 | (* prepend value x, return pointers to new first and last nodes *) 171 | Program Definition insertL p q (x : A) : 172 | STsep {l} (dseq p q l, [vfun pq => dseq pq.1 pq.2 (x :: l)]) := 173 | Do (r <-- allocb x 3; 174 | r.+1 ::= p;; 175 | r.+2 ::= null;; 176 | if p == null then ret (r,r) 177 | else p.+2 ::= r;; 178 | ret (r,q)). 179 | Next Obligation. 180 | (* pull out ghost + precondition *) 181 | move=>p q x [l][] i /= H. 182 | (* create a new node in first 3 steps (+ rearrange pointer arith), branch *) 183 | step=>r; rewrite unitR; do 2!step; case: ifP H=>[/eqP ->|/negbT N]. 184 | - (* the list is empty, so new first node = last node *) 185 | move/dseq_nullL=>H; step; rewrite joinA=>/validR/H [_->->] /=. 186 | by exists null, Unit; rewrite !joinA. 187 | (* deconstruct non-empty list, run the rest *) 188 | case/(dseq_posL N)=>y[z][h'][E {i}-> H']; do 2![step]=>V. 189 | (* massage the heap to fit the goal *) 190 | exists p, (p :-> y \+ (p.+1 :-> z \+ (p.+2 :-> r \+ h'))). 191 | by rewrite !joinA; split=>//; rewrite E /=; exists z, h'; rewrite !joinA. 192 | Qed. 193 | 194 | (* append value x, return pointers to new first and last nodes *) 195 | Program Definition insertR p q (x : A) : 196 | STsep {l} (dseq p q l, [vfun pq => dseq pq.1 pq.2 (rcons l x)]) := 197 | Do (r <-- allocb x 3; 198 | r.+1 ::= null;; 199 | r.+2 ::= q;; 200 | if q == null then ret (r,r) 201 | else q.+1 ::= r;; 202 | ret (p,r)). 203 | Next Obligation. 204 | (* pull out ghost + precondition *) 205 | move=>p q x [l []] i /= H. 206 | (* create a new node in first 3 steps (+ rearrange pointer arith), branch *) 207 | step=>r; rewrite unitR; do 2!step; case: ifP H=>[/eqP->|/negbT N]. 208 | - (* the list is empty, so new first node = last node *) 209 | move/dseq_nullR=>H; step; rewrite joinA=>/validR/H [_->->] /=. 210 | by exists null, Unit; rewrite !joinA. 211 | (* deconstruct non-empty list, run the rest, restructure the goal *) 212 | case/(dseq_posR N)=>s[y][z][h'][{l}-> {i}-> H']; do 2![step]=>_; apply/dseg_rcons. 213 | (* massage the heap and simplify *) 214 | exists q, (h' \+ (q :-> y \+ (q.+1 :-> r \+ q.+2 :-> z))). 215 | split; first by rewrite joinC. 216 | (* restructure the goal once more *) 217 | by apply/dseg_rcons; vauto. 218 | Qed. 219 | 220 | (* travers the dlist backwards and cons all elements *) 221 | (* reifies the specification *) 222 | 223 | (* loop invariant: *) 224 | (* 1. heap is unchanged *) 225 | (* 2. result = remainder + accumulator *) 226 | (* carry the pointer to the accumulator as a logical var *) 227 | Definition traverse_backT (p : ptr) : Type := 228 | forall (qs : ptr * seq A), 229 | STsep {l nx} (dseg null p qs.1 nx l, 230 | [vfun r h => h \In dseg null p qs.1 nx l /\ 231 | r = l ++ qs.2]). 232 | 233 | Program Definition traverse_back p q : 234 | STsep {l} (dseq p q l, 235 | [vfun r h => h \In dseq p q l /\ r = l]) := 236 | Do (let tb := 237 | ffix (fun (go : traverse_backT p) '(r, acc) => 238 | Do (if r == null then ret acc 239 | else x <-- !r; 240 | rnxt <-- !r.+2; 241 | go (rnxt, x :: acc))) 242 | in tb (q, [::])). 243 | (* first, the loop *) 244 | Next Obligation. 245 | (* pull out ghosts + precondition, branch *) 246 | move=>p _ go _ r acc [l][nx][] i /= H; case: ifP H=>[/eqP->|/negbT]. 247 | - (* remainder is empty, return accumulator *) 248 | by move/dseg_nullR=>H; step=>/H [->_->->]. 249 | (* deconstruct non-empty remainder *) 250 | rewrite eq_sym=>Hr /(dseg_neqR Hr) [xs][x][z][h'][{l}-> {i}-> H']{Hr}. 251 | (* run the rest, feed remainder, acc pointer and subheap to recursive call *) 252 | do 2!step; apply: [gX xs, r]@h'=>//= _ m [Hm ->] _ /=. 253 | (* simplify and restructure the goal *) 254 | split; last by rewrite -cats1 -catA. 255 | by apply/dseg_rcons; vauto. 256 | Qed. 257 | Next Obligation. 258 | (* pull out ghost var *) 259 | move=>p q [xs][] i /= H. 260 | (* feed it and the null pointer (the accumulator is empty) to the loop *) 261 | by apply: [gE xs, null]=>//= y m; rewrite cats0. 262 | Qed. 263 | 264 | End DList. 265 | -------------------------------------------------------------------------------- /examples/dune: -------------------------------------------------------------------------------- 1 | (coq.theory 2 | (name htt) 3 | (package coq-htt) 4 | (synopsis "Hoare Type Theory with examples") 5 | (flags :standard 6 | -w -notation-overridden 7 | -w -local-declaration 8 | -w -redundant-canonical-projection 9 | -w -projection-no-head-constant)) 10 | -------------------------------------------------------------------------------- /examples/exploit.v: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2009 IMDEA Software Institute 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | http://www.apache.org/licenses/LICENSE-2.0 7 | Unless required by applicable law or agreed to in writing, software 8 | distributed under the License is distributed on an "AS IS" BASIS, 9 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 10 | See the License for the specific language governing permissions and 11 | limitations under the License. 12 | *) 13 | 14 | From Coq Require Import ssreflect ssrbool Logic.Hurkens. 15 | 16 | (* This file shows the unsoundness of the axiom pack_injective assumed in *) 17 | (* the implementation of Ynot2.0. The proof relies on the lemma of *) 18 | (* Coquand shown in his 'Mathematical Investigations of a Calculus of *) 19 | (* Constructions'. Coquand's paper is available at *) 20 | (* http://www.cs.chalmers.se/~coquand/meta.pdf. The lemma is stated in *) 21 | (* several forms on page 15. The proof reduces in a few steps to *) 22 | (* unsoundness of Girard's system U. *) 23 | 24 | (* A simplification of Girard's paradox is given by Hurkens, who ultimately *) 25 | (* proves the same lemma as Coquand. The nice thing is that his proof is *) 26 | (* available as a Coq library in Coq.Logic.Hurkens, so we can directly use *) 27 | (* it here. *) 28 | 29 | Definition pack_injective := forall T (x y : T), inhabits x = inhabits y -> x = y. 30 | 31 | Lemma coquand : forall (B : Prop) (E : B -> Prop) (e : Prop -> B) 32 | (H : forall A : Prop, A <-> E (e A)), False. 33 | Proof. 34 | by move=>B E e H; apply: (NoRetractFromSmallPropositionToProp.paradox B e E)=>A; move: (H A)=>[H1] H2. 35 | Qed. 36 | 37 | Lemma pack_noninjective : pack_injective -> False. 38 | Proof. 39 | pose B := inhabited Prop. 40 | pose e := @inhabits Prop. 41 | pose E x := exists A, (e A = x) /\ A. 42 | move/(_ Prop)=>H. 43 | by apply: (@coquand B E e)=>A; split; [move=>x; exists A | move=>[A'][]; move/H=>->]. 44 | Qed. 45 | -------------------------------------------------------------------------------- /examples/gcd.v: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2021 IMDEA Software Institute 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | http://www.apache.org/licenses/LICENSE-2.0 7 | Unless required by applicable law or agreed to in writing, software 8 | distributed under the License is distributed on an "AS IS" BASIS, 9 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 10 | See the License for the specific language governing permissions and 11 | limitations under the License. 12 | *) 13 | 14 | From Coq Require Import ssreflect ssrbool ssrfun. 15 | From mathcomp Require Import ssrnat eqtype div. 16 | From pcm Require Import axioms pred ordtype pcm heap. 17 | From htt Require Import options model heapauto. 18 | 19 | (* classical mutable Euclid's algorithm for computing GCD with subtractions *) 20 | 21 | (* two memory cells holding intermediate values *) 22 | Definition shape (p q : ptr) (x y : nat) := 23 | [Pred h | exists h', h = p :-> x \+ (q :-> y \+ h')]. 24 | 25 | (* GCD loop invariant: at the end both cells contain the answer *) 26 | (* (`unit` is needed because `Fix` always requires a single parameter) *) 27 | Definition gcd_loopT (p q : ptr) : Type := 28 | unit -> 29 | STsep {x y : nat} (shape p q x y, 30 | [vfun (_ : unit) h => 31 | h \In shape p q (gcdn x y) (gcdn x y)]). 32 | 33 | Program Definition gcd_loop (p q : ptr) := 34 | ffix (fun (go : gcd_loopT p q) _ => 35 | Do (x <-- !p; 36 | y <-- !q; 37 | if (x : nat) != y then 38 | if x < y then q ::= y - x;; 39 | go tt 40 | else p ::= x - y;; 41 | go tt 42 | else skip)). 43 | Next Obligation. 44 | (* pull out ghosts + precondition (the shape of the heap) *) 45 | move=>p q go _ [x [y _]] /= _ [h' ->]. 46 | (* read the numbers, do a 3-way comparison, run one more step in each branch *) 47 | do 2!step; case: ltngtP=>/= [H|H|->]; step; last first. 48 | - (* x=y, the program is finished because GCD(y,y) = y *) 49 | by move=>_; rewrite gcdnn; vauto. 50 | - (* y//=; first by eauto. 52 | move=>{h'} _ _ [m ->] _; exists m. 53 | (* use the difference property of GCD *) 54 | suff {p q go m}: gcdn (x - y) y = gcdn x y by move=>->. 55 | (* mathcomp's GCD theory uses addition, so we do a bit of arithmetical reasoning *) 56 | by rewrite gcdnC -gcdnDr gcdnC subnK //; apply: ltnW. 57 | (* x//=; first by eauto. 59 | move=>{h'}_ _ [m ->] _; exists m. 60 | suff {p q go m}: gcdn x (y - x) = gcdn x y by move=>->. 61 | by rewrite -gcdnDr subnK //; apply: ltnW. 62 | Qed. 63 | 64 | (* There's no guarantee on termination, as this is partial correctness. *) 65 | (* The algorithm loops if u = 0 /\ v != 0 or vice versa *) 66 | Program Definition gcd u v : 67 | STsep (PredT, [vfun r _ => r = gcdn u v]) := 68 | (* allocate in the reverse order because the symbolic heap behaves as a stack *) 69 | (* this way it'll match the specification perfectly, removing a bit of bureaucracy *) 70 | Do (q <-- alloc v; 71 | p <-- alloc u; 72 | gcd_loop p q tt;; 73 | x <-- !p; 74 | dealloc p;; 75 | dealloc q;; 76 | ret x). 77 | Next Obligation. 78 | (* simplify *) 79 | move=>u v _ m /= _. 80 | (* initialize the two cells, run the loop, deconstruct the shape *) 81 | step=>q; step=>p; apply: [stepE u, v]=>//=; first by eauto. 82 | move=>_ _ [h' ->]. 83 | (* run the rest of the program *) 84 | by do 4!step; rewrite !unitL. 85 | Qed. 86 | -------------------------------------------------------------------------------- /examples/hashtab.v: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2010 IMDEA Software Institute 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | http://www.apache.org/licenses/LICENSE-2.0 7 | Unless required by applicable law or agreed to in writing, software 8 | distributed under the License is distributed on an "AS IS" BASIS, 9 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 10 | See the License for the specific language governing permissions and 11 | limitations under the License. 12 | *) 13 | 14 | From HB Require Import structures. 15 | From Coq Require Import ssreflect ssrbool ssrfun. 16 | From mathcomp Require Import ssrnat eqtype seq fintype tuple finfun finset. 17 | From pcm Require Import options axioms prelude pred ordtype finmap. 18 | From pcm Require Import pcm unionmap heap autopcm. 19 | From htt Require Import options model heapauto. 20 | From htt Require Import array kvmaps. 21 | 22 | (* hash table is array of buckets, i.e. KV maps *) 23 | (* bucket indices are provided by the hash function *) 24 | (* using dynaming kv-maps for buckets *) 25 | 26 | Module Type Hashtab_sig. 27 | Parameter root : forall {K : ordType} {V : Type} (buckets : dkvm K V) 28 | {n : nat} (hash : K -> 'I_n), Set. 29 | Section HashTab. 30 | Context {K : ordType} {V : Type} {buckets : dkvm K V}. 31 | Context {n : nat} {hash : K -> 'I_n}. 32 | Parameter null_root : root buckets hash. 33 | Parameter shape : root buckets hash -> {finMap K -> V} -> Pred heap. 34 | Parameter new : 35 | STsep (emp, [vfun (x : root buckets hash) h => h \In shape x nil]). 36 | Parameter free : forall x : root buckets hash, 37 | STsep {s} (shape x s, [vfun _ : unit => emp]). 38 | Parameter insert : forall (x : root buckets hash) k v, 39 | STsep {s} (shape x s, [vfun (_ : unit) h => h \In shape x (ins k v s)]). 40 | Parameter remove : forall (x : root buckets hash) k, 41 | STsep {s} (shape x s, [vfun (_ : unit) h => h \In shape x (rem k s)]). 42 | Parameter lookup : forall (x : root buckets hash) k, 43 | STsep {s} (shape x s, [vfun y h => h \In shape x s /\ y = fnd k s]). 44 | End HashTab. 45 | End Hashtab_sig. 46 | 47 | Module HashTab : Hashtab_sig. 48 | Definition root K V (buckets : dkvm K V) n (hash : K -> 'I_n) : 49 | Set := {array 'I_n -> buckets}. 50 | Definition null_root K V buckets n hash : 51 | @root K V buckets n hash := Array null. 52 | Section HashTab. 53 | Context (K : ordType) (V : Type) {buckets : dkvm K V} 54 | {n : nat} {hash : K -> 'I_n}. 55 | Notation KVshape := (@dkvm_shape _ _ buckets). 56 | Notation table := (table KVshape). 57 | Notation root := (root buckets hash). 58 | 59 | (* hash table is specified by a single finMap *) 60 | (* which is the "flattening" of all buckets *) 61 | Definition shape (x : root) (s : finMap K V) : Pred heap := 62 | [Pred h | exists (tab : {ffun 'I_n -> buckets}) (* array spec *) 63 | (bucket : 'I_n -> {finMap K -> V}), (* buckets spec *) 64 | [/\ forall k, fnd k s = fnd k (bucket (hash k)), 65 | forall i k, k \in supp (bucket i) -> hash k = i & 66 | h \In Array.shape x tab # sepit setT (table tab bucket)] ]. 67 | 68 | (* new hash map is an array of `n` empty buckets *) 69 | 70 | (* bucket initialization loop invariant: *) 71 | (* at iteration k, the heap holds the array and k empty buckets *) 72 | Definition new_loopinv x := forall k, 73 | STsep (fun h => k <= n /\ exists tab, 74 | h \In Array.shape x tab # 75 | sepit [set x:'I_n | x < k] (table tab (fun=>nil)), 76 | [vfun y => shape y nil]). 77 | 78 | Program Definition new : STsep (emp, [vfun y => shape y nil]) := 79 | Do (t <-- Array.new dkvm_null; 80 | let go := ffix (fun (loop : new_loopinv t) k => 81 | Do (if decP (b := k < n) idP is left pf then 82 | b <-- dkvm_new buckets; 83 | Array.write t (Ordinal pf) b;; 84 | loop k.+1 85 | else ret t)) 86 | in go 0). 87 | (* first the bucket initialization loop *) 88 | Next Obligation. 89 | (* pull out preconditions, branch on k comparison *) 90 | move=>/= arr loop k [] _ /= [Eleq][tab][h1][h2][-> H1]. 91 | case: decP=>[{Eleq}pf H2|]; last first. 92 | (* k = n, return the array pointer *) 93 | - case: ltnP Eleq (eqn_leq k n)=>// _ -> /= /eqP Ek _ H; step=>_. 94 | (* pass through the constructed table, aggregated finmap is empty *) 95 | exists tab, (fun => nil); split=>//; exists h1, h2; split=>//{h1 H1}. 96 | (* h2 holds the table *) 97 | by apply/tableP2: H=>//= x; rewrite Ek !in_set ltn_ord. 98 | (* k < n, allocate an empty bucket by framing on Unit *) 99 | apply: [stepU]=>//= b m Hm. 100 | (* write its id to the array under index k *) 101 | apply: [stepX tab] @ h1=>{h1 H1}//= _ m2 E2. 102 | (* invoke the loop *) 103 | apply: [gE]=>//=; split=>//; rewrite joinCA. 104 | (* extend the table by the new index/bucket pair, simplify *) 105 | exists [ffun z => if z == Ordinal pf then b else tab z], m2, (m \+ h2). 106 | split=>//{m2 E2}. 107 | (* remove the new bucket from the heap *) 108 | rewrite (sepitS (Ordinal pf)) in_set leqnn {1}/table ffunE eq_refl. 109 | exists m, h2; do!split=>{m Hm}//; apply: tableP2 H2=>{h2}//. 110 | - case=>x Hx; rewrite !in_set in_set1 -val_eqE /= ltnS (leq_eqVlt x). 111 | by case: ltngtP. 112 | (* removing k from the domain of the new table gives the old table back *) 113 | by move=>x _; rewrite in_set ffunE; case: eqP=>//->; rewrite ltnn. 114 | Qed. 115 | (* the outer function *) 116 | Next Obligation. 117 | (* simplify *) 118 | move=>/= [] _ ->. 119 | (* allocate the array *) 120 | apply: [stepE]=>//= y m Hm. 121 | (* invoke the loop with index 0 *) 122 | apply: [gE]=>//=; split=>//. 123 | (* the table is empty *) 124 | exists [ffun => dkvm_null], m, Unit; split=>//=. 125 | - by rewrite unitR. 126 | (* there are no buckets in the heap yet *) 127 | by rewrite (eq_sepit (s2 := set0)) // sepit0. 128 | Qed. 129 | 130 | (* freeing hashtable = freeing the array + buckets *) 131 | 132 | (* loop invariant: *) 133 | (* at iteration k, the heap still holds the array and n-k buckets *) 134 | Definition free_loopinv x := forall k, 135 | STsep (fun h => k <= n /\ exists t b, 136 | h \In Array.shape x t # 137 | sepit [set x:'I_n | x >= k] (table t b), 138 | [vfun _ : unit => emp]). 139 | 140 | Program Definition free x : STsep {s} (shape x s, 141 | [vfun _ : unit => emp]) := 142 | (* the extra Do here enables deriving precondition from the loop *) 143 | Do (ffix (fun (loop : free_loopinv x) k => 144 | Do (if decP (b := k < n) idP is left pf then 145 | b <-- Array.read x (Ordinal pf); 146 | dkvm_free b;; 147 | loop k.+1 148 | else Array.free x)) 0). 149 | (* first the loop *) 150 | Next Obligation. 151 | (* pull out the ghost + preconditions, branch on k comparison *) 152 | move=>/= x loop k [] _ /= [Eleq][tf][bf][h1][h2][-> H1]. 153 | case: decP=>[pf H|]; last first. 154 | (* k = n *) 155 | - case: ltnP Eleq (eqn_leq k n)=>// _ -> /= /eqP Ek _ H. 156 | (* free the array *) 157 | apply: [gE]=>//=; exists tf. 158 | (* h2 is empty *) 159 | move: H; rewrite (eq_sepit (s2 := set0)). 160 | - by rewrite sepit0=>->; rewrite unitR. 161 | by move=>y; rewrite Ek in_set in_set0 leqNgt ltn_ord. 162 | (* k < n, read from array *) 163 | apply: [stepX tf, h1] @ h1=>//= _ _ [->->]. 164 | (* split out the the k-th bucket *) 165 | move: H; rewrite (sepitS (Ordinal pf)) in_set leqnn. 166 | case=>h3[h4][{h2}-> H3 H4]. 167 | (* free it *) 168 | apply: [stepX (bf (Ordinal pf))] @ h3=>{h3 H3}//= _ _ ->; rewrite unitL. 169 | (* invoke loop, simplify *) 170 | apply: [gE]=>//=; split=>//; exists tf, bf, h1, h4; split=>//. 171 | (* drop the k-th entry from the table *) 172 | apply/tableP2/H4=>//. 173 | move=>z; rewrite !in_set in_set1; case: eqP=>/=. 174 | - by move=>->/=; rewrite ltnn. 175 | by move/eqP; rewrite -val_eqE /=; case: ltngtP. 176 | Qed. 177 | Next Obligation. 178 | (* pull out ghost+preconditions *) 179 | move=>/= x [fm][] h /= [tf][bf][_ _ H]. 180 | (* invoke the loop *) 181 | by apply: [gE]=>//=; eauto. 182 | Qed. 183 | 184 | (* inserting into hashmap is inserting into *) 185 | (* corresponding bucket + updating the array *) 186 | (* returning the pointer is not needed *) 187 | (* as the array is not moved *) 188 | Program Definition insert x k v : 189 | STsep {s} (shape x s, [vfun _ : unit => shape x (ins k v s)]) := 190 | Do (let hk := hash k in 191 | b <-- Array.read x hk; 192 | b' <-- dkvm_insert b k v; 193 | Array.write x hk b'). 194 | Next Obligation. 195 | (* pull out ghost + deconstruct precondition *) 196 | move=>/= x k v [fm][] _ /= [tf][bf][Hf Hh [h1][h2][-> /= H1 H2]]. 197 | (* read the bucket from array *) 198 | apply/[stepX tf, h1] @ h1=>//= _ _ [->->]. 199 | (* split out the bucket in the heap *) 200 | move: H2; rewrite (sepitT1 (hash k)) /table; case=>h3[h4][{h2}-> H3 H4]. 201 | (* insert into the bucket *) 202 | apply/[stepX (bf (hash k))] @ h3=>{h3 H3}//= b' m2 H2. 203 | (* write the bucket to the array, return the pointer *) 204 | apply: [gX tf]@h1=>{h1 H1} //= _ m3 E3 _. 205 | (* update the array and buckets' specs *) 206 | exists [ffun z => if z == hash k then b' else tf z], 207 | (fun b => if b == hash k then ins k v (bf b) else bf b); split=>/=. 208 | (* the new buckets spec is still a flattening *) 209 | - move=>k0; rewrite fnd_ins; case: eqP=>[->|/eqP Ek]. 210 | (* if the bucket was touched, we get the same value *) 211 | - by rewrite eq_refl fnd_ins eq_refl. 212 | (* if not, we get the old spec back *) 213 | by case: ifP=>_ //; rewrite fnd_ins (negbTE Ek). 214 | (* the new buckets spec respects the hash *) 215 | - move=>i0 k0; case: eqP; last by move=>_; apply: Hh. 216 | by move=>->; rewrite supp_ins inE=>/orP; case; [move/eqP=>->|apply: Hh]. 217 | (* the shape is respected: first, the array fits *) 218 | exists m3, (m2 \+ h4); split=>{Hf Hh m3 E3}//. 219 | (* split out the modified bucket *) 220 | rewrite (sepitT1 (hash k)) /table /= ffunE eq_refl. 221 | exists m2, h4; split=>{m2 H2} //. 222 | (* the table fits too *) 223 | apply/tableP/H4=>/= x0; 224 | by rewrite !in_set in_set1 andbT ?ffunE =>/negbTE->. 225 | Qed. 226 | 227 | (* removing from hashmap is removing from *) 228 | (* corresponding bucket + updating the array *) 229 | (* returning the pointer is again not needed *) 230 | Program Definition remove x k : 231 | STsep {s} (shape x s, 232 | [vfun _ : unit => shape x (rem k s)]) := 233 | Do (let hk := hash k in 234 | b <-- Array.read x hk; 235 | b' <-- dkvm_remove b k; 236 | Array.write x hk b'). 237 | Next Obligation. 238 | (* pull out ghost + destructure precondition *) 239 | move=>/= x k [fm][] _ /= [tf][bf][Hf Hh [h1][h2][-> /= H1 H2]]. 240 | (* read the bucket from array *) 241 | apply/[stepX tf, h1] @ h1=>//= _ _ [->->]. 242 | (* split out the bucket in the heap *) 243 | move: H2; rewrite (sepitT1 (hash k)); case=>h3[h4][{h2}-> H3 H4]. 244 | (* insert into the bucket *) 245 | apply/[stepX (bf (hash k))] @ h3=>{h3 H3}//= b' m2 H2. 246 | (* write the bucket to the array, return the pointer *) 247 | apply/[gX tf] @ h1=>{H1}//= _ m3 E3 _. 248 | (* update the array and buckets' specs *) 249 | exists [ffun z => if z == hash k then b' else tf z], 250 | (fun b => if b == hash k then rem k (bf b) else bf b); split=>/=. 251 | (* the new buckets spec is still a flattening *) 252 | - move=>k0; rewrite fnd_rem; case: eqP. 253 | (* if the bucket was touched, the value is gone *) 254 | - by move=>->; rewrite eq_refl fnd_rem eq_refl. 255 | (* if not, we get the old spec back *) 256 | by move/eqP=>Ek; case: ifP=>_ //; rewrite fnd_rem (negbTE Ek). 257 | (* the new buckets spec respects the hash *) 258 | - move=>i0 k0; case: eqP; last by move=>_; apply: Hh. 259 | by move=>->; rewrite supp_rem !inE=>/andP [] _; apply: Hh. 260 | (* the shape is respected: first, the array fits *) 261 | exists m3, (m2\+ h4); split=>{m3 E3 Hf Hh}//. 262 | (* split out the modified bucket *) 263 | rewrite (sepitT1 (hash k)) /table /= ffunE eq_refl. 264 | exists m2, h4; split=>{m2 H2} //. 265 | (* the table fits too *) 266 | apply/tableP/H4=>/= x0; 267 | by rewrite !in_set in_set1 andbT ?ffunE => /negbTE->. 268 | Qed. 269 | 270 | (* looking up in a hashmap is looking up in the corresponging bucket *) 271 | Program Definition lookup x k : 272 | STsep {s} (shape x s, 273 | [vfun y m => m \In shape x s /\ y = fnd k s]) := 274 | Do (b <-- Array.read x (hash k); 275 | dkvm_lookup b k). 276 | Next Obligation. 277 | (* pull out ghost + destructure precondition *) 278 | move=>/= x k [fm][] _ /= [tf][bf][Hf Hh [h1][h2][-> H1 H2]]. 279 | (* read the bucket from array *) 280 | apply/[stepX tf, h1] @ h1=>//= _ _ [->->]. 281 | (* split out the bucket in the heap *) 282 | move: H2; rewrite (sepitT1 (hash k)); case=>h3[h4][{h2}-> H3 H4]. 283 | (* look up in the bucket, simplify *) 284 | apply/[gX (bf (hash k))] @ h3=>{h3 H3}//= r m2 [H2 Hr] _. 285 | split; last by rewrite Hf. 286 | (* the shape is preserved, as nothing was modified *) 287 | exists tf, bf; split=>//=; exists h1, (m2 \+ h4); split=>{h1 H1} //. 288 | by rewrite (sepitT1 (hash k)); vauto. 289 | Qed. 290 | 291 | End HashTab. 292 | End HashTab. 293 | 294 | (* hash table is (static) KV map *) 295 | Notation hashtab := HashTab.root. 296 | HB.instance Definition _ K V (buckets : dkvm K V) n (hash : K -> 'I_n) := 297 | isKVM.Build K V (hashtab buckets hash) HashTab.null_root 298 | HashTab.new HashTab.free HashTab.insert HashTab.remove HashTab.lookup. 299 | 300 | (* htab is specific simple hash tab where buckets are association lists *) 301 | Definition htab {K} V {n} hash := @hashtab K V (dalist K V) n hash. 302 | HB.instance Definition _ K V n hash := KVM.on (@htab K V n hash). 303 | 304 | 305 | -------------------------------------------------------------------------------- /examples/llist.v: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2010 IMDEA Software Institute 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | http://www.apache.org/licenses/LICENSE-2.0 7 | Unless required by applicable law or agreed to in writing, software 8 | distributed under the License is distributed on an "AS IS" BASIS, 9 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 10 | See the License for the specific language governing permissions and 11 | limitations under the License. 12 | *) 13 | 14 | From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq. 15 | From pcm Require Import options axioms pred. 16 | From pcm Require Import pcm unionmap heap autopcm automap. 17 | From htt Require Import options model heapauto. 18 | 19 | (* Linked lists, storing a value and next pointer in consecutive locations. *) 20 | (* We start with a more general "segment" definition, where the last node's *) 21 | (* next pointer is an arbitrary q *) 22 | (* NOTE: already defined in heap.v under the name llist, but repeated here *) 23 | (* to make the file self-contained. *) 24 | 25 | Fixpoint lseg {A} (p q : ptr) (xs : seq A) := 26 | if xs is hd::tl then 27 | [Pred h | exists r h', 28 | h = p :-> hd \+ (p.+1 :-> r \+ h') /\ h' \In lseg r q tl] 29 | else [Pred h | p = q /\ h = Unit]. 30 | 31 | Definition EmptyList : exn := exn_from_nat 15. 32 | 33 | Section LSeg. 34 | Variable A : Type. 35 | 36 | (* appending value to list segment *) 37 | Lemma lseg_rcons (xs : seq A) x p r h : 38 | h \In lseg p r (rcons xs x) <-> 39 | exists q h', h = h' \+ (q :-> x \+ q.+1 :-> r) /\ 40 | h' \In lseg p q xs. 41 | Proof. 42 | move: xs x p r h; elim=>[|x xs IH] y p r h /=. 43 | - by split; case=>x [h'][->][<- ->]; [exists p | exists r]; hhauto. 44 | split. 45 | - case=>z [h1][->]; case/IH=>w [h2][->] H1. 46 | by exists w, (p :-> x \+ (p.+1 :-> z \+ h2)); hhauto. 47 | case=>q [h1][->][z][h2][->] H1. 48 | exists z, (h2 \+ q :-> y \+ q.+1 :-> r). 49 | by rewrite -!joinA; split=>//; apply/IH; eauto. 50 | Qed. 51 | 52 | (* null pointer represents empty segment *) 53 | Lemma lseg_null (xs : seq A) q h : 54 | valid h -> 55 | h \In lseg null q xs -> 56 | [/\ q = null, xs = [::] & h = Unit]. 57 | Proof. 58 | case: xs=>[|x xs] D /= H; first by case: H=><- ->. 59 | case: H D=>r [h'][->] _; rewrite validPtUn; hhauto. 60 | Qed. 61 | 62 | (* empty heap represents empty segment *) 63 | Lemma lseg_empty (xs : seq A) p q : 64 | Unit \In lseg p q xs -> 65 | p = q /\ xs = [::]. 66 | Proof. 67 | by case: xs=>[|x xs][] //= r [h][/esym/join0I][/unitbP]; rewrite um_unitbU. 68 | Qed. 69 | 70 | (* reformulation of the specification *) 71 | Lemma lseg_case (xs : seq A) p q h : 72 | h \In lseg p q xs -> 73 | [/\ p = q, xs = [::] & h = Unit] \/ 74 | exists x r h', 75 | [/\ xs = x :: behead xs, 76 | h = p :-> x \+ (p.+1 :-> r \+ h') & 77 | h' \In lseg r q (behead xs)]. 78 | Proof. 79 | case: xs=>[|x xs] /=; first by case=>->->; left. 80 | by case=>r [h'][->] H; right; hhauto. 81 | Qed. 82 | 83 | (* non-trivial segment represents a non-empty list *) 84 | Lemma lseg_neq (xs : seq A) p q h : 85 | p != q -> h \In lseg p q xs -> 86 | exists x r h', 87 | [/\ xs = x :: behead xs, 88 | h = p :-> x \+ (p.+1 :-> r \+ h') & 89 | h' \In lseg r q (behead xs)]. 90 | Proof. 91 | move=>H /lseg_case; case=>//; case=>E. 92 | by rewrite E eq_refl in H. 93 | Qed. 94 | 95 | (* non-empty list is represented by a non-trivial segment *) 96 | Lemma lseg_lt0n (xs : seq A) p q h : 97 | 0 < size xs -> h \In lseg p q xs -> 98 | exists x r h', 99 | [/\ xs = x :: behead xs, 100 | h = p :-> x \+ (p.+1 :-> r \+ h') & 101 | h' \In lseg r q (behead xs)]. 102 | Proof. 103 | move=>H /lseg_case; case=>//; case=>_ E. 104 | by rewrite E in H. 105 | Qed. 106 | 107 | (* splitting the list corresponds to splitting the heap *) 108 | Lemma lseg_cat (xs ys : seq A) p q h : 109 | h \In lseg p q (xs++ys) <-> 110 | exists j, h \In lseg p j xs # lseg j q ys. 111 | Proof. 112 | elim: xs h p=>/=. 113 | - move=>h p; split; first by move=>H; exists p, Unit, h; rewrite unitL. 114 | by case=>j[_][h2][{h}-> [->->]]; rewrite unitL. 115 | move=>x xs IH h p; split. 116 | - case=>r[_][{h}-> /IH][j][h1][h2][-> H1 H2]. 117 | exists j, (p :-> x \+ p.+1 :-> r \+ h1), h2; rewrite !joinA; split=>//. 118 | by exists r, h1; rewrite joinA. 119 | case=>j[_][h2][{h}-> [r][h1][-> H1 H2]]. 120 | exists r, (h1 \+ h2); rewrite !joinA; split=>//. 121 | by apply/IH; exists j, h1, h2. 122 | Qed. 123 | 124 | End LSeg. 125 | 126 | (* Special case when q = null, i.e. the list is self-contained *) 127 | Definition lseq {A} p (xs : seq A) := lseg p null xs. 128 | 129 | Section LList. 130 | Variable (A : Type). 131 | 132 | (* specializing the null and neq lemmas *) 133 | 134 | Lemma lseq_null (xs : seq A) h : 135 | valid h -> 136 | h \In lseq null xs -> 137 | xs = [::] /\ h = Unit. 138 | Proof. by move=>D; case/(lseg_null D)=>_ ->. Qed. 139 | 140 | Lemma lseq_pos (xs : seq A) p h : 141 | p != null -> 142 | h \In lseq p xs -> 143 | exists x r h', 144 | [/\ xs = x :: behead xs, 145 | h = p :-> x \+ (p.+1 :-> r \+ h') & 146 | h' \In lseq r (behead xs)]. 147 | Proof. by apply: lseg_neq. Qed. 148 | 149 | (* valid heap cannot match two different specs *) 150 | 151 | Lemma lseq_func (l1 l2 : seq A) p h : 152 | valid h -> 153 | h \In lseq p l1 -> 154 | h \In lseq p l2 -> 155 | l1 = l2. 156 | Proof. 157 | elim: l1 l2 p h => [|x1 xt IH] /= l2 p h V. 158 | - by case=>->->; case/lseq_null. 159 | case=>q1 /= [h1][E] H; rewrite {}E in H V *. 160 | case/(lseq_pos (defPt_nullO V))=>x2 [q2][h2][->] /=. 161 | do 2![case/(cancel V)=>/dynE/jmE<-{}V]. 162 | by move=><- /(IH (behead l2) _ _ V H)=>->. 163 | Qed. 164 | 165 | (* main methods *) 166 | 167 | (* creating an empty list (a no-op) *) 168 | 169 | Program Definition new : STsep (emp, [vfun x => lseq x (@nil A)]) := 170 | Do (ret null). 171 | Next Obligation. by move=>[] /= _ ->; step. Qed. 172 | 173 | (* prepending a value *) 174 | Program Definition insert p (x : A) : 175 | STsep {l} (lseq p l, [vfun p' => lseq p' (x::l)]) := 176 | Do (q <-- allocb p 2; 177 | q ::= x;; 178 | ret q). 179 | Next Obligation. 180 | (* pull out ghost var + precondition, run the first step *) 181 | move=>p x [l][] i /= H; step=>q. 182 | (* run the last 2 steps, guess the final pointer and heap from the goal *) 183 | by rewrite unitR -joinA; heval. 184 | Qed. 185 | 186 | (* getting the head element *) 187 | (* an example of a partial program, doesn't modify the heap *) 188 | Program Definition head p : 189 | STsep {l} (lseq p l, 190 | fun (y : ans A) h => h \In lseq p l /\ 191 | match y with Val v => l = v :: behead l 192 | | Exn e => e = EmptyList /\ l = [::] end) := 193 | Do (if p == null then throw EmptyList 194 | else v <-- !p; 195 | ret v). 196 | Next Obligation. 197 | (* pull out ghost + precondition, branch *) 198 | move=>p [l][] i /= H; case: ifP H=>[/eqP-> H|/negbT Hp]. 199 | - (* there is no head element, abort *) 200 | step=>V; do!split=>//. 201 | (* the only non-trivial goal is the list being empty *) 202 | by case/lseq_null: H. 203 | (* deconstruct non-empty list, run the rest *) 204 | case/(lseq_pos Hp)=>v [r][h1][E {i}-> H1]. 205 | by do 2![step]=>_; split=>//; rewrite E; hhauto. 206 | Qed. 207 | 208 | (* removing the head element, no-op for an empty list *) 209 | Program Definition remove p : 210 | STsep {xs : seq A} (lseq p xs, [vfun p' => lseq p' (behead xs)]) := 211 | Do (if p == null then ret p 212 | else pnext <-- !p.+1; 213 | dealloc p;; 214 | dealloc p.+1;; 215 | ret pnext). 216 | Next Obligation. 217 | (* pull out ghost + precondition, branch *) 218 | move=>p [xs][] i /= H; case: ifP H=>[/eqP-> H|/negbT Ep]. 219 | - (* the list must be empty *) 220 | by step=>V; case/lseq_null: H=>//->->. 221 | (* deconstruct non-empty list, run the rest *) 222 | case/(lseq_pos Ep)=>x [q][h][-> {i}-> /= H1]. 223 | by heval; rewrite 2!unitL. 224 | Qed. 225 | 226 | (* calculating the list length *) 227 | 228 | (* loop invariant: *) 229 | (* 1. heap is unchanged *) 230 | (* 2. total length is accumulator + the length of unprocessed list *) 231 | Definition lenT : Type := forall (pl : ptr * nat), 232 | STsep {xs : seq A} (lseq pl.1 xs, 233 | [vfun l h => l == pl.2 + length xs /\ lseq pl.1 xs h]). 234 | 235 | Program Definition len p : 236 | STsep {xs : seq A} (lseq p xs, 237 | [vfun l h => l == length xs /\ lseq p xs h]) := 238 | Do (let len := ffix (fun (go : lenT) '(p, l) => 239 | Do (if p == null then ret l 240 | else pnext <-- !p.+1; 241 | go (pnext, l + 1))) 242 | in len (p, 0)). 243 | (* first, the loop *) 244 | Next Obligation. 245 | (* pull out ghosts+precondition, branch *) 246 | move=>_ go _ p l /= [xs][] i /= H; case: eqP H=>[->|/eqP Ep] H. 247 | - (* the end is reached *) 248 | by step=>V; case/(lseq_null V): H=>->->/=; rewrite addn0. 249 | (* deconstruct non-empty list, run one step *) 250 | case/lseq_pos: H=>// x0 [r][h'][-> {i}-> /= H1]; step. 251 | apply: [gX (behead xs)]@h'=>//= _ h2 [/eqP -> Hl] /= _. 252 | rewrite -addnA add1n; eauto. 253 | Qed. 254 | Next Obligation. 255 | (* pull out the ghost var and immediately feed it to the loop *) 256 | by move=>/= p [xs []] i /= H; apply: [gE xs]. 257 | Qed. 258 | 259 | (* concatenation: modifies the first list, returning nothing *) 260 | 261 | (* loop invariant: *) 262 | (* first list isn't empty and doesn't overlap with the second *) 263 | Definition catT (p2 : ptr) : Type := 264 | forall (p1 : ptr), STsep {xs1 xs2 : seq A} 265 | (fun h => p1 != null /\ (lseq p1 xs1 # lseq p2 xs2) h, 266 | [vfun _ : unit => lseq p1 (xs1 ++ xs2)]). 267 | 268 | Program Definition concat p1 p2 : 269 | STsep {xs1 xs2 : seq A} (lseq p1 xs1 # lseq p2 xs2, 270 | [vfun a => lseq a (xs1 ++ xs2)]) := 271 | Do (let cat := ffix (fun (go : catT p2) q => 272 | Do (next <-- !q.+1; 273 | if (next : ptr) == null 274 | then q.+1 ::= p2;; 275 | ret tt 276 | else go next)) 277 | in if p1 == null 278 | then ret p2 279 | else cat p1;; 280 | ret p1). 281 | (* first, the loop *) 282 | Next Obligation. 283 | (* pull out ghosts + preconditions *) 284 | move=>_ p2 go q [xs1][xs2][] _ /= [Hq][i1][i2][-> H1 H2]. 285 | (* deconstruct the first non-empty list, branch *) 286 | case/(lseq_pos Hq): H1=>x [r][i][E {i1}-> H1]; step. 287 | case: ifP H1=>[/eqP ->{r}|/negbT N] H1. 288 | - (* we've reached the last node of the first list *) 289 | (* make it point to the second list *) 290 | do 2![step]=>V. 291 | (* the remaining heap for the first list is empty *) 292 | case/(lseq_null (validX V)): H1 E=>/=->->->/=. 293 | (* the rest is just the second list *) 294 | by rewrite unitR -joinA; eauto. 295 | (* feed new ghosts and subheap to the recursive call *) 296 | (* we use a generalized ghost autolemma here *) 297 | apply: [gX (behead xs1), xs2]@(i \+ i2)=>//= _. 298 | - (* the tail is not null so the precondition is satisfied *) 299 | by split=>//; vauto. 300 | (* assemble the concatenation from head and tail *) 301 | by move=>m H _; rewrite E /=; eauto. 302 | Qed. 303 | (* next, the initial call *) 304 | Next Obligation. 305 | (* pull out ghosts + preconditions, branch on null check *) 306 | move=>p1 p2 [xs1][xs2][] /= _ [i1][i2][-> H1 H2]. 307 | case: ifP H1=>[/eqP ->|/negbT N] H1. 308 | - (* first list is empty, the result simplifies to the second list *) 309 | by step=>V; case/(lseq_null (validL V)): H1=>->->; rewrite unitL. 310 | (* otherwise, feed everything to the loop *) 311 | by apply: [stepE xs1, xs2]=>//= [|_ m Hm]; heval. 312 | Qed. 313 | 314 | (* in-place reversal by pointer swinging *) 315 | 316 | (* loop invariant: *) 317 | (* 1. processed and remaining parts don't overlap *) 318 | (* 2. result = processed part + reversal of remainder *) 319 | Definition revT : Type := forall (p : ptr * ptr), 320 | STsep {i done : seq A} (lseq p.1 i # lseq p.2 done, 321 | [vfun y => lseq y (catrev i done)]). 322 | 323 | Program Definition reverse p : 324 | STsep {xs : seq A} (lseq p xs, [vfun p' => lseq p' (rev xs)]) := 325 | Do (let reverse := ffix (fun (go : revT) '(i, done) => 326 | Do (if i == null then ret done 327 | else next <-- !i.+1; 328 | i.+1 ::= done;; 329 | go (next, i))) 330 | in reverse (p, null)). 331 | (* first, the loop *) 332 | Next Obligation. 333 | (* pull out ghosts + preconditions, branch *) 334 | move=>_ go _ i done [x1][x2][] _ /= [i1][i2][-> H1 H2]. 335 | case: eqP H1=>[->|/eqP E] H1. 336 | - (* nothing left to reverse, return the accumulator *) 337 | by step=>/validL V1; case/(lseq_null V1): H1=>->->/=; rewrite unitL. 338 | (* deconstruct non-empty remainder *) 339 | case/lseq_pos: H1=>// xd [xn][h'][-> {i1}-> /= H1]. 340 | (* swing the pointer, feed shifted ghosts to recursive call *) 341 | do 2!step; apply: [gE (behead x1), xd::x2]=>//=. 342 | (* rearrange the heap to match context *) 343 | rewrite !(pull h') -!joinA; vauto. 344 | Qed. 345 | Next Obligation. 346 | (* pull out ghost, feed it + empty accumulator to the loop *) 347 | move=>p [xs][] /= i H; apply: [gE xs, [::]]=>//=; exists i; hhauto. 348 | Qed. 349 | 350 | Variable B : Type. 351 | 352 | (* list mapping, an example of a higher-order function *) 353 | 354 | (* the loop invariant: *) 355 | (* the result is a mapped list *) 356 | Definition lmapT (f : A -> B) := 357 | forall (p : ptr), 358 | STsep {xs : seq A} (lseq p xs, 359 | [vfun _ : unit => lseq p (map f xs)]). 360 | 361 | Program Definition lmap f : lmapT f := 362 | ffix (fun (lmap : lmapT f) p => 363 | Do (if p == null 364 | then ret tt 365 | else t <-- !p; 366 | p ::= f t;; 367 | nxt <-- !p.+1; 368 | lmap nxt)). 369 | Next Obligation. 370 | (* pull out ghost + precondition, branch *) 371 | move=>f lmap p [xs][] h /= H; case: ifP H=>[/eqP ->|/negbT N] H. 372 | - (* the list is empty *) 373 | by step=>V; case/(lseq_null V): H=>->->. 374 | (* deconstruct non-empty list, run the rest *) 375 | case/(lseq_pos N): H=>t [nxt][h'][-> {h}-> /= H]; heval. 376 | (* feed the tail as a ghost var + subheap to recursive call *) 377 | apply/[gX (behead xs)]@h'=>//= _ h2 Q V'; eauto. 378 | Qed. 379 | 380 | End LList. 381 | 382 | Arguments head {A}. 383 | Arguments remove {A}. 384 | -------------------------------------------------------------------------------- /examples/queue.v: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2021 IMDEA Software Institute 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | http://www.apache.org/licenses/LICENSE-2.0 7 | Unless required by applicable law or agreed to in writing, software 8 | distributed under the License is distributed on an "AS IS" BASIS, 9 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 10 | See the License for the specific language governing permissions and 11 | limitations under the License. 12 | *) 13 | 14 | From Coq Require Import ssreflect ssrbool ssrfun. 15 | From mathcomp Require Import eqtype ssrnat seq. 16 | From pcm Require Import options axioms pred. 17 | From pcm Require Import pcm unionmap heap automap. 18 | From htt Require Import options model heapauto. 19 | From htt Require Import llist. 20 | 21 | Record queue (T : Type) : Type := Queue {front: ptr; back: ptr}. 22 | Definition EmptyQueue : exn := exn_from_nat 100. 23 | 24 | Module Queue. 25 | Section Queue. 26 | Variable T : Type. 27 | Notation queue := (queue T). 28 | 29 | (* queue is singly-linked list split into *) 30 | (* the initial segment and the last node *) 31 | Definition is_queue (fr bq : ptr) (xs : seq T) := 32 | if fr == null then [Pred h | [/\ bq = null, xs = [::] & h = Unit]] 33 | else [Pred h | exists xt x h', 34 | [/\ xs = rcons xt x, 35 | valid (h' \+ (bq :-> x \+ bq.+1 :-> null)), 36 | h = h' \+ (bq :-> x \+ bq.+1 :-> null) & 37 | h' \In lseg fr bq xt]]. 38 | 39 | (* queue structure is a pair of pointers to body + last node *) 40 | (* insertion happens at the last node, removal at the head *) 41 | Definition shape (q : queue) (xs : seq T) := 42 | [Pred h | exists fr bq h', 43 | [/\ valid (front q :-> fr \+ (back q :-> bq \+ h')), 44 | h = front q :-> fr \+ (back q :-> bq \+ h') & 45 | h' \In is_queue fr bq xs]]. 46 | 47 | (* well-formed queue is a valid heap *) 48 | Lemma shapeD q xs h : h \In shape q xs -> valid h. 49 | Proof. by case=>h1[bq][h'] [] D ->. Qed. 50 | 51 | (* empty queue is a pair of null pointers *) 52 | Lemma is_queue_nil fr bq h : 53 | h \In is_queue fr bq [::] -> 54 | [/\ fr = null, bq = null & h = Unit]. 55 | Proof. 56 | by rewrite /is_queue; case: eqP=>[->[-> _ ->] | _ [[|y xt][x][h'][]]]. 57 | Qed. 58 | 59 | (* restructuring the specification for combined list *) 60 | Lemma is_queue_rcons fr bq xt x h : 61 | h \In is_queue fr bq (rcons xt x) <-> 62 | (exists h', [/\ valid (h' \+ (bq :-> x \+ bq.+1 :-> null)), 63 | h = h' \+ (bq :-> x \+ bq.+1 :-> null) & 64 | h' \In lseg fr bq xt]). 65 | Proof. 66 | rewrite /is_queue; split. 67 | - case: eqP; first by move=>-> []; case: xt. 68 | by move=>N [xt'][x'][h'][/rcons_inj [->->] ???]; exists h'. 69 | case=>h' [D -> H]; case: eqP H=>[->|_ H]; last by vauto. 70 | move: (D)=>/[swap]; case/(lseg_null (validL D))=>->->->. 71 | by rewrite unitL validPtUn. 72 | Qed. 73 | 74 | (* pointers agree in a well-formed queue *) 75 | Lemma backfront fr bq xs h : 76 | h \In is_queue fr bq xs -> 77 | (fr == null) = (bq == null). 78 | Proof. 79 | rewrite /is_queue; case: ifP=>[E [->]_ _| E [xt][x][h'][_] D] //. 80 | by case: eqP D=>// -> /validR; rewrite validPtUn. 81 | Qed. 82 | 83 | (* main methods *) 84 | 85 | (* new queue is a pair of pointers to an empty segment *) 86 | Program Definition new : 87 | STsep (emp, [vfun v => shape v [::]]) := 88 | Do (x <-- alloc null; 89 | y <-- alloc null; 90 | ret (Queue T x y)). 91 | Next Obligation. 92 | (* run the complete program *) 93 | move=>[] _ /= ->; step=>x; step=>y; step=>V. 94 | (* massage the heap to fit the postcondition *) 95 | by exists null, null, Unit; rewrite !unitR /= in V *; rewrite joinC. 96 | Qed. 97 | 98 | (* freeing a queue, possible only when it's empty *) 99 | Program Definition free (q : queue) : 100 | STsep (shape q [::], [vfun _ h => h = Unit]) := 101 | Do (dealloc (front q);; 102 | dealloc (back q)). 103 | Next Obligation. 104 | (* pull out ghosts and precondition *) 105 | move=>q [_][fr][bq][h][/[swap] -> /[swap]]. 106 | (* both pointers are null *) 107 | case/is_queue_nil=>->->->; rewrite unitR=>V. 108 | (* run the program *) 109 | by do 2![step]=>_; rewrite unitR. 110 | Qed. 111 | 112 | (* enqueue/dequeue manipulate the underlying segment directly *) 113 | 114 | (* enqueuing = adding a node at the end *) 115 | Program Definition enq (q : queue) (x : T) : 116 | STsep {xs} (shape q xs, 117 | [vfun _ => shape q (rcons xs x)]) := 118 | Do (next <-- allocb null 2; 119 | next ::= x;; 120 | ba <-- !back q; 121 | back q ::= next;; 122 | (if (ba : ptr) == null 123 | then front q 124 | else ba.+1) ::= next). 125 | Next Obligation. 126 | (* pull out ghosts + precondition *) 127 | move=>q x [xs][] _ /= [fr][bq][h'][D -> H]. 128 | (* create the new last node and change the back pointer *) 129 | step=>next; do 3!step. 130 | (* as the pointers agree, test the front one to reason structurally *) 131 | rewrite -(backfront H) unitR; case: ifP H=>Ef; rewrite /is_queue ?Ef. 132 | - (* the queue was empty, set the front pointer to new node *) 133 | case=>_->->; step; rewrite unitR=>V. 134 | (* massage the heap and restructure the goal *) 135 | exists next, next, (next :-> x \+ next.+1 :-> null). 136 | rewrite joinA joinC; split=>//; apply/(@is_queue_rcons _ _ [::]). 137 | by exists Unit; rewrite unitL; split=>//; exact: (validL V). 138 | (* the queue wasn't empty, link the new node to the last one *) 139 | case=>s2[x2][i2][->] {}D -> H2; step=>V. 140 | (* massage the heap and simplify the goal *) 141 | exists fr, next, (i2 \+ bq :-> x2 \+ bq.+1 :-> next \+ 142 | next :-> x \+ next.+1 :-> null). 143 | split; first by apply: (validX V). 144 | - by rewrite joinC !joinA. 145 | (* the new node conforms to the queue spec *) 146 | apply/is_queue_rcons; exists (i2 \+ bq :-> x2 \+ bq.+1 :-> next). 147 | rewrite joinA; split=>//; first by apply: (validX V). 148 | (* assemble the old queue back *) 149 | by apply/lseg_rcons; exists bq, i2; rewrite joinA. 150 | Qed. 151 | 152 | (* dequeuing = removing the head node and adjusting pointers *) 153 | Program Definition deq (q : queue) : 154 | STsep {xs} (shape q xs, 155 | fun y h => shape q (behead xs) h /\ 156 | match y with Val v => xs = v :: behead xs 157 | | Exn e => e = EmptyQueue /\ xs = [::] end) := 158 | Do (fr <-- !front q; 159 | if (fr : ptr) == null then throw EmptyQueue 160 | else 161 | x <-- !fr; 162 | next <-- !fr.+1; 163 | front q ::= next;; 164 | dealloc fr;; 165 | dealloc fr.+1;; 166 | if (next : ptr) == null 167 | then back q ::= null;; 168 | ret x 169 | else ret x). 170 | Next Obligation. 171 | (* pull out ghosts + precondition *) 172 | move=>q [xs][] _ /= [fr][bq][h][D -> H]. 173 | (* read the list, branch *) 174 | step; case: ifP H=>Ef; rewrite /is_queue Ef. 175 | - (* list is empty, throw an exception *) 176 | case=>->->->/=; step=>V; split=>//. 177 | (* massage and simplify *) 178 | exists fr, null, Unit; rewrite unitR in V *; split=>//. 179 | by rewrite Ef. 180 | (* deconstruct the initial segment *) 181 | case=>[[|y xt]][x][h'][->] {}D {h}-> /=. 182 | - (* segment is empty, so dequeuing returns the last node *) 183 | case=>->->; do 7!step; rewrite !unitR=>V; split=>//. 184 | by exists null, null, Unit; rewrite unitR. 185 | (* segment is non-empty, run up to the branching point *) 186 | case=>next [h2][->] H; do 5!step; rewrite !unitL. 187 | case: ifP H=>[/eqP ->|N] H. 188 | - (* null pointer is in the middle of the segment *) 189 | do 2![step]=>V2. 190 | (* this contradicts heap validity *) 191 | case/(lseg_null (validX V2)): H D=>/=-> _ _ /validR. 192 | by rewrite validPtUn. 193 | (* return the segment head and simplify *) 194 | step=>V; split=>//; exists next, bq, (h2 \+ (bq :-> x \+ bq.+1 :-> null)). 195 | by rewrite N; split=>//; vauto; apply: (validX V). 196 | Qed. 197 | 198 | End Queue. 199 | End Queue. 200 | -------------------------------------------------------------------------------- /examples/quicksort.v: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2022 IMDEA Software Institute 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | http://www.apache.org/licenses/LICENSE-2.0 7 | Unless required by applicable law or agreed to in writing, software 8 | distributed under the License is distributed on an "AS IS" BASIS, 9 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 10 | See the License for the specific language governing permissions and 11 | limitations under the License. 12 | *) 13 | 14 | From mathcomp Require Import ssreflect ssrbool ssrfun. 15 | From mathcomp Require Import ssrnat eqtype seq path fintype tuple finfun. 16 | From mathcomp Require Import finset fingroup perm order interval. 17 | From pcm Require Import options axioms prelude seqext pred ordtype slice. 18 | From pcm Require Import pcm unionmap heap. 19 | From htt Require Import options model heapauto array. 20 | Import Order.NatOrder Order.TTheory. 21 | Local Open Scope order_scope. 22 | Local Open Scope nat_scope. 23 | 24 | (* Brief mathematics of quickorting *) 25 | (* There is some overlap with mathematics developed for bubblesort *) 26 | (* but the development is repeated here to make the files *) 27 | (* self-contained *) 28 | 29 | Lemma leq_choose a b : 30 | a < b -> 31 | sumbool (a.+1 == b) (a.+1 < b). 32 | Proof. 33 | move=>H. 34 | case: (decP (b:=a.+1 < b) idP)=>[H2|/negP H2]; first by right. 35 | by left; rewrite eqn_leq H /= leqNgt. 36 | Qed. 37 | 38 | (* TODO copied from bubble *) 39 | 40 | Fact ord_trans {n} (j : 'I_n) (i : 'I_n) (Hi : i < j) : (i.+1 < n)%N. 41 | Proof. 42 | case: j Hi=>j Hj /= Hi. 43 | by apply/leq_trans/Hj. 44 | Qed. 45 | 46 | Section OrdArith. 47 | 48 | (* increase by 1 within the bound *) 49 | Definition Sbo n (i : 'I_n) (prf : (i.+1 < n)%N) : 'I_n. 50 | Proof. case: i prf=>/= m Hm; apply: Ordinal. Defined. 51 | 52 | Lemma Sbo_eq n (i : 'I_n) (prf : (i.+1 < n)%N) : 53 | nat_of_ord (Sbo prf) = i.+1. 54 | Proof. by case: i prf. Qed. 55 | 56 | Lemma Sbo_lift n (i j : 'I_n) (H1 : i < j) : 57 | i.+1 < j -> 58 | Sbo (ord_trans H1) < j. 59 | Proof. by case: i H1. Qed. 60 | 61 | Lemma Sbo_leq n (i j k : 'I_n) (H1 : i <= j) (H2 : j < k) : 62 | Sbo (ord_trans (leq_ltn_trans H1 H2)) <= Sbo (ord_trans H2). 63 | Proof. by case: j H1 H2; case: i. Qed. 64 | 65 | Lemma Sbo_lt n (i j k : 'I_n) (H1 : i <= j) (H2 : j < k) : 66 | i <= Sbo (ord_trans H2). 67 | Proof. by case: j H1 H2; case: i=>/=x Hx y Hy Hxy Hyk; apply/ltnW. Qed. 68 | 69 | (* increase by 1 with saturation *) 70 | Definition Sso n (i : 'I_n) : 'I_n. 71 | Proof. 72 | case: i=>/= m Hm; case: (ltnP m.+1 n)=>[H|_]. 73 | - by apply: (@Ordinal _ m.+1 H). 74 | by apply: (@Ordinal _ m Hm). 75 | Defined. 76 | 77 | Lemma Sso_eq n (i : 'I_n) : 78 | nat_of_ord (Sso i) = if (i.+1 < n)%N then i.+1 else i. 79 | Proof. by case: i=>/= m prf; case: ltnP. Qed. 80 | 81 | (* decrease by 1 *) 82 | Definition Po n : 'I_n -> 'I_n := 83 | fun '(@Ordinal _ m prf) => @Ordinal n m.-1 (leq_ltn_trans (leq_pred _) prf). 84 | 85 | Lemma Po_eq n (i : 'I_n) : nat_of_ord (Po i) = i.-1. 86 | Proof. by case: i. Qed. 87 | 88 | End OrdArith. 89 | 90 | Section PermFgraph. 91 | Variables (n : nat) (A : Type). 92 | 93 | Lemma perm_on_notin (f : {ffun 'I_n -> A}) (p : 'S_n) 94 | (s : {set 'I_n}) (i : interval nat) : 95 | perm_on s p -> 96 | [disjoint s & [set x : 'I_n | (x : nat) \in i]] -> 97 | &:(fgraph (pffun p f)) i = &:(fgraph f) i. 98 | Proof. 99 | move=>Hp Hd. 100 | suff E: {in &:(enum 'I_n) i, f =1 pffun p f}. 101 | - by rewrite !fgraph_codom /= !codomE /= -2!slice_map /=; move/eq_in_map: E. 102 | move=>/= y Hy; rewrite ffunE (@out_perm _ s) //. 103 | apply/negbT/(disjointFl Hd); rewrite inE in_itv. 104 | case: {Hd}i Hy=>i j; rewrite slice_memE1 /=; last first. 105 | - by rewrite count_uniq_mem; [exact: leq_b1|exact: enum_uniq]. 106 | case/and3P=>_; rewrite size_enum_ord index_enum_ord. 107 | case: j=>[[] jx|[]]; case: i=>[[] ix|[]]; 108 | rewrite ?andbF ?andbT /= ?addn0 ?addn1 // leEnat ltEnat /=. 109 | - by move=>->. 110 | - by move=>->. 111 | - by rewrite leqNgt (ltn_ord y). 112 | - by move=>->. 113 | - by move=>->. 114 | - by rewrite leqNgt (ltn_ord y). 115 | by rewrite leqNgt (ltn_ord y). 116 | Qed. 117 | 118 | Lemma tperm_notin (f : {ffun 'I_n -> A}) (x y : 'I_n) (i : interval nat) : 119 | (x : nat) \notin i -> (y : nat) \notin i -> 120 | &:(fgraph (pffun (tperm x y) f)) i = &:(fgraph f) i. 121 | Proof. 122 | move=>Hx0 Hx1. 123 | apply: perm_on_notin; first by exact: tperm_on. 124 | rewrite disjoint_subset; apply/subsetP=>/= z; rewrite 6!inE. 125 | by case/orP=>/eqP->. 126 | Qed. 127 | 128 | End PermFgraph. 129 | 130 | Section PermFgraphEq. 131 | Variables (n : nat) (A : eqType). 132 | 133 | Lemma perm_fgraph (p : 'S_n) (f : {ffun 'I_n -> A}) : 134 | perm_eq (fgraph (pffun p f)) 135 | (fgraph f). 136 | Proof. 137 | apply/tuple_permP. 138 | exists (cast_perm (esym (card_ord n)) p). 139 | congr val; apply/eq_from_tnth=>/= i. 140 | by rewrite tnth_fgraph tnth_map tnth_fgraph ffunE /= tnth_ord_tuple 141 | !enum_val_ord cast_permE cast_ordKV esymK. 142 | Qed. 143 | 144 | Lemma perm_on_fgraph (i : interval nat) (p : 'S_n) (f : {ffun 'I_n -> A}) : 145 | perm_on [set x : 'I_n | (x : nat) \in i] p -> 146 | perm_eq &:(fgraph (pffun p f)) i 147 | &:(fgraph f ) i. 148 | Proof. 149 | case: i=>i j H. 150 | case/boolP: (Order.lt i j)=>[Hij|]; last first. 151 | - by rewrite -leNgt => H12; rewrite !itv_swapped_bnd. 152 | move: (perm_fgraph p f). 153 | rewrite {1}(slice_extrude (fgraph (pffun p f)) (i:=Interval i j)) //=. 154 | rewrite {1}(slice_extrude (fgraph f) (i:=Interval i j)) //=. 155 | rewrite (perm_on_notin (i:=Interval -oo i) f H); last first. 156 | - rewrite disjoint_subset; apply/subsetP=>/= z. 157 | rewrite inE=>Hz; rewrite 2!inE; apply/negP=>Hz2. 158 | suff: (z : nat) \notin order.Order.meet (Interval -oo i) (Interval i j). 159 | - by move/negP; apply; rewrite in_itvI Hz2. 160 | rewrite /order.Order.meet /= /order.Order.join /= /order.Order.meet /=. 161 | move/ltW: Hij; rewrite bound_leEmeet=>/eqP->. 162 | by rewrite itv_ge // -leNgt. 163 | rewrite (perm_on_notin (i:=Interval j +oo) f H); last first. 164 | - rewrite disjoint_subset; apply/subsetP=>/= z. 165 | rewrite inE=>Hz; rewrite 3!inE; apply/negP=>Hz2. 166 | suff: (z : nat) \notin order.Order.meet (Interval i j) (Interval j +oo). 167 | - by move/negP; apply; rewrite in_itvI Hz. 168 | rewrite /order.Order.meet /= /order.Order.meet /=. 169 | move: (bound_lex1 j); rewrite bound_leEmeet=>/eqP->. 170 | move/ltW: Hij; rewrite leEjoin=>/eqP->. 171 | by rewrite itv_ge // -leNgt. 172 | by rewrite /= perm_cat2l perm_cat2r. 173 | Qed. 174 | 175 | End PermFgraphEq. 176 | 177 | 178 | (*****************) 179 | (*****************) 180 | (* Verifications *) 181 | (*****************) 182 | (*****************) 183 | 184 | Section Lomuto. 185 | Variable (n : nat) (A : ordType). 186 | 187 | (***************************************************) 188 | (* pseudocode in idealized effectful ML-like lang *) 189 | (* assuming size a >= 1 *) 190 | (* *) 191 | (* let swap (a : array A) (i j : nat) : unit = *) 192 | (* if i == j then () else *) 193 | (* let x = array.read a i; *) 194 | (* let y = array.read a j; *) 195 | (* array.write a i y; *) 196 | (* array.write a j x *) 197 | (* *) 198 | (* let partition_lm_pass (a : array A) (pivot : A) *) 199 | (* (lo hi : nat) : nat = *) 200 | (* let go (i j : nat) : nat = { *) 201 | (* let x = array.read a j; *) 202 | (* if x <= pivot then { *) 203 | (* swap a i j; *) 204 | (* if j+1 < hi then go (i+1) (j+1) else i+1 *) 205 | (* } else if j+1 < hi then go i (j+1) else i *) 206 | (* }; *) 207 | (* go lo lo *) 208 | (* *) 209 | (* let partition_lm (a : array A) *) 210 | (* (lo hi : nat) : nat = *) 211 | (* let pivot = array.read a hi; *) 212 | (* let v = partition_lm_pass a pivot lo hi; *) 213 | (* swap a v hi; *) 214 | (* v *) 215 | (* *) 216 | (* let quick_sort (a : array A) : unit = *) 217 | (* let go (i j : nat) : unit = *) 218 | (* if j <= i then () else *) 219 | (* let v = partition_lm a i j; *) 220 | (* loop (l, v-1); *) 221 | (* loop (v+1, h) *) 222 | (* }; *) 223 | (* go 0 (size a)-1 *) 224 | (***************************************************) 225 | 226 | Program Definition swap (a : {array 'I_n -> A}) (i j : 'I_n) : 227 | STsep {f : {ffun 'I_n -> A}} 228 | (Array.shape a f, 229 | [vfun _ h => 230 | h \In Array.shape a (pffun (tperm i j) f)]) := 231 | Do (if i == j then skip else 232 | x <-- Array.read a i; 233 | y <-- Array.read a j; 234 | Array.write a i y;; 235 | Array.write a j x). 236 | Next Obligation. 237 | move=>a i j /= [f][] h /= H. 238 | case: ifP=>[/eqP->|Hij]. 239 | - by step=>_; rewrite tperm1 pffunE1. 240 | do 2!apply: [stepE f, h]=>//= _ _ [->->]. 241 | apply: [stepE f]=>//= _ {H}h H; set f1 := (finfun _) in H. 242 | apply: [gE f1]=>//= _ {H}h H; set f2 := (finfun _) in H. 243 | suff {H}: f2 = pffun (tperm i j) f by move=><-. 244 | rewrite {}/f2 {}/f1; apply/ffunP=>/= x; rewrite !ffunE /= ffunE /=. 245 | by case: tpermP=>[->|->|/eqP/negbTE->/eqP/negbTE->] {x}//; rewrite eqxx // Hij. 246 | Qed. 247 | 248 | Definition partition_lm_loop (a : {array 'I_n -> A}) (pivot : A) 249 | (lo hi : 'I_n) := 250 | forall ij : sigT (fun i : 'I_n => sig (fun j : 'I_n => i <= j /\ j < hi)), 251 | let i := projT1 ij in 252 | let j := proj1_sig (projT2 ij) in 253 | STsep {f : {ffun 'I_n -> A}} 254 | (fun h => [/\ h \In Array.shape a f, 255 | lo <= i, 256 | all (oleq^~ pivot) (&:(fgraph f) `[lo : nat, i : nat[) & 257 | all (ord pivot) (&:(fgraph f) `[i : nat, j : nat[)], 258 | [vfun (v : 'I_n) h => 259 | i <= v <= hi /\ 260 | exists p, let f' := pffun p f in 261 | [/\ perm_on [set ix : 'I_n | i <= ix < hi] p, 262 | h \In Array.shape a f', 263 | all (oleq^~ pivot) (&:(fgraph f') `[lo : nat, v : nat[) & 264 | all (ord pivot) (&:(fgraph f') `[v : nat, hi : nat[)]]). 265 | 266 | Program Definition partition_lm_pass (a : {array 'I_n -> A}) (pivot : A) 267 | (lo hi : 'I_n) (Hlo : lo < hi): 268 | STsep {f : {ffun 'I_n -> A}} 269 | (Array.shape a f, 270 | [vfun (v : 'I_n) h => 271 | lo <= v <= hi /\ 272 | exists p, let f' := pffun p f in 273 | [/\ perm_on [set ix : 'I_n | lo <= ix < hi] p, 274 | h \In Array.shape a f', 275 | all (oleq^~ pivot) (&:(fgraph f') `[lo : nat, v : nat[) & 276 | all (ord pivot) (&:(fgraph f') `[v : nat, hi : nat[)]]) := 277 | Do (let go := 278 | ffix (fun (loop : partition_lm_loop a pivot lo hi) 279 | '(existT i (exist j (conj Hi Hj))) => 280 | Do (x <-- Array.read a j; 281 | if oleq x pivot then 282 | swap a i j;; 283 | let i1 := Sbo (ord_trans (leq_ltn_trans Hi Hj)) in (* i+1 *) 284 | let j1 := Sbo (ord_trans Hj) in (* j+1 *) 285 | if leq_choose Hj is right pf then 286 | loop (@existT _ _ i1 (@exist _ _ j1 287 | (conj (Sbo_leq Hi Hj) (Sbo_lift Hj pf)))) 288 | else ret i1 289 | else if leq_choose Hj is right pf then 290 | let j1 := Sbo (ord_trans Hj) in (* j+1 *) 291 | loop (@existT _ _ i (@exist _ _ j1 292 | (conj (Sbo_lt Hi Hj) (Sbo_lift Hj pf)))) 293 | else ret i)) 294 | in go (@existT _ _ lo (@exist _ _ lo (conj (leqnn lo) Hlo)))). 295 | Next Obligation. 296 | move=>a pivot lo hi Hlo loop _ i _ j _ Hi Hj [f][] h /= [H Oli Ai Aj]. 297 | apply: [stepE f, h]=>//= _ _ [->->]. 298 | case: oleqP=>Hfp. 299 | (* a[j] <= pivot, make swap *) 300 | - apply: [stepE f]=>//= _ m Hm. 301 | case: (leq_choose Hj)=>Hj1. 302 | (* j+1 = hi, exit *) 303 | - step=>_; split. 304 | - rewrite Sbo_eq; apply/andP; split=>//. 305 | by apply/leq_ltn_trans/Hj. 306 | exists (tperm i j); rewrite Sbo_eq; split=>//. 307 | - rewrite -(eqP Hj1). 308 | apply/(subset_trans (tperm_on i j))/subsetP=>/= x; rewrite !inE ltnS. 309 | by case/orP=>/eqP->; rewrite leqnn // andbT. 310 | - rewrite slice_oSR slice_xR; last by rewrite bnd_simp. 311 | rewrite onth_codom ffunE tpermL /= all_rcons Hfp /=. 312 | rewrite tperm_notin // in_itv /= negb_and leEnat ltEnat /= -leqNgt. 313 | - by rewrite leqnn orbT. 314 | by rewrite Hi orbT. 315 | rewrite -(eqP Hj1) /= slice_oSR. 316 | move: Hi; rewrite leq_eqVlt; case/orP=>[/eqP->|Hi]. 317 | - by rewrite itv_swapped_bnd // bnd_simp ltEnat /= ltnS. 318 | rewrite slice_xR; last by rewrite bnd_simp. 319 | move: Aj; rewrite slice_xL; last by rewrite bnd_simp. 320 | rewrite !onth_codom /=; case/andP=>Hpi Aj. 321 | rewrite all_rcons; apply/andP; split. 322 | - by rewrite ffunE tpermR. 323 | by rewrite tperm_notin ?slice_oSL // 324 | in_itv /= negb_and leEnat ltEnat /= -!leqNgt leqnn // orbT. 325 | (* j+1 < hi, loop *) 326 | apply: [gE (pffun (tperm i j) f)]=>//=. 327 | - split=>//; rewrite !Sbo_eq; first by apply/ltnW. 328 | - rewrite slice_oSR slice_xR; last by rewrite bnd_simp. 329 | rewrite onth_codom ffunE tpermL /= all_rcons Hfp /=. 330 | rewrite tperm_notin // in_itv /= negb_and leEnat ltEnat /= -leqNgt. 331 | - by rewrite leqnn orbT. 332 | by rewrite Hi orbT. 333 | rewrite slice_oSR. 334 | move: Hi; rewrite leq_eqVlt; case/orP=>[/eqP->|Hi]. 335 | - by rewrite itv_swapped_bnd // bnd_simp ltEnat /= ltnS. 336 | rewrite slice_xR; last by rewrite bnd_simp. 337 | move: Aj; rewrite slice_xL; last by rewrite bnd_simp. 338 | rewrite !onth_codom /=; case/andP=>Hpi Aj. 339 | rewrite all_rcons; apply/andP; split. 340 | - by rewrite ffunE tpermR. 341 | by rewrite tperm_notin ?slice_oSL // 342 | in_itv /= negb_and leEnat ltEnat /= -!leqNgt leqnn // orbT. 343 | move=>z k [Hz][p'][Pk Hk Al Ah] Vk; split. 344 | - by move: Hz; rewrite Sbo_eq; case/andP=>/ltnW->->. 345 | exists (p' * tperm i j)%g; rewrite pffunEM; split=>//. 346 | rewrite Sbo_eq in Pk; apply: perm_onM. 347 | - apply/(subset_trans Pk)/subsetP=>x; rewrite !inE. 348 | by case/andP=>/ltnW->->. 349 | apply/(subset_trans (tperm_on i j))/subsetP=>/= x; rewrite !inE /=. 350 | case/orP=>/eqP->; last by apply/andP. 351 | by rewrite leqnn /=; apply/leq_ltn_trans/Hj. 352 | (* pivot < a[j] *) 353 | case: (leq_choose Hj)=>Hj1. 354 | - (* j+1 = hi, exit *) 355 | step=>_; split. 356 | - by rewrite leqnn /= -(eqP Hj1); apply: ltnW. 357 | exists 1%g; rewrite pffunE1; split=>//; first by exact: perm_on1. 358 | rewrite -(eqP Hj1) slice_oSR slice_xR; last by rewrite bnd_simp. 359 | by rewrite onth_codom /= all_rcons Hfp. 360 | (* j+1 < hi, loop *) 361 | apply: [gE f]=>//=; split=>//. 362 | rewrite Sbo_eq slice_oSR slice_xR; last by rewrite bnd_simp. 363 | by rewrite onth_codom /= all_rcons Hfp. 364 | Qed. 365 | Next Obligation. 366 | move=>/= a pivot lo hi Hlo [f][] i /= H. 367 | by apply: [gE f]=>//=; split=>//; rewrite slice_kk. 368 | Qed. 369 | 370 | Program Definition partition_lm (a : {array 'I_n -> A}) 371 | (lo hi : 'I_n) (Hlo : lo < hi): 372 | STsep {f : {ffun 'I_n -> A}} 373 | (Array.shape a f, 374 | [vfun (v : 'I_n) h => 375 | lo <= v <= hi /\ 376 | exists p, let f' := pffun p f in 377 | [/\ perm_on [set ix : 'I_n | lo <= ix <= hi] p, 378 | h \In Array.shape a f', 379 | all (oleq^~ (f' v)) (&:(fgraph f') `[lo : nat, v : nat[) & 380 | all (ord (f' v)) (&:(fgraph f') `]v : nat, hi : nat])]]) := 381 | Do (pivot <-- Array.read a hi; 382 | v <-- partition_lm_pass a pivot Hlo; 383 | swap a v hi;; 384 | ret v). 385 | Next Obligation. 386 | move=> a lo hi Hlo /= [f][] h /= E. 387 | apply: [stepE f, h]=>//= _ _ [->->]. 388 | apply: [stepE f]=>//= v m [Hi][p][Pm Hm Al Ah]. 389 | apply: [stepE (pffun p f)]=>//= _ k Hj. 390 | step=>Vk; split=>//. 391 | exists (tperm v hi * p)%g; split=>//. 392 | - apply: perm_onM. 393 | apply/(subset_trans (tperm_on v hi))/subsetP=>/= x; rewrite !inE /=. 394 | by case/orP=>/eqP->//; rewrite leqnn andbT; apply/ltnW. 395 | apply/(subset_trans Pm)/subsetP=>x; rewrite !inE. 396 | by case/andP=>->/ltnW->. 397 | - by rewrite pffunEM. 398 | - rewrite pffunEM ffunE tpermL ffunE (out_perm Pm); last first. 399 | - by rewrite inE negb_and -!ltnNge leqnn orbT. 400 | rewrite tperm_notin // in_itv negb_and /= leEnat ltEnat /= -leqNgt. 401 | - by rewrite leqnn orbT. 402 | by case/andP: Hi=>_ ->; rewrite orbT. 403 | rewrite pffunEM ffunE tpermL ffunE (out_perm Pm); last first. 404 | - by rewrite inE negb_and -!ltnNge leqnn orbT. 405 | case/andP: Hi=>_; rewrite leq_eqVlt; case/orP=>[/eqP->|Hi]. 406 | - by rewrite slice_kk. 407 | move: Ah; rewrite slice_xL; last by rewrite bnd_simp. 408 | rewrite onth_codom /=; case/andP=>Hg Ha. 409 | rewrite slice_xR; last by rewrite bnd_simp. 410 | rewrite onth_codom /= all_rcons; apply/andP; split. 411 | - by rewrite ffunE tpermR. 412 | by rewrite tperm_notin // in_itv negb_and /= ltEnat /= -!leqNgt leqnn // orbT. 413 | Qed. 414 | 415 | End Lomuto. 416 | 417 | Section LomutoQsort. 418 | Variable (n : nat) (A : ordType). 419 | 420 | Definition quicksort_lm_loop (a : {array 'I_n.+1 -> A}) := 421 | forall (lohi : 'I_n.+1 * 'I_n.+1), 422 | let lo := lohi.1 in 423 | let hi := lohi.2 in 424 | STsep {f : {ffun 'I_n.+1 -> A}} 425 | (Array.shape a f, 426 | [vfun (_ : unit) h => 427 | exists p, let f' := pffun p f in 428 | [/\ perm_on [set ix : 'I_n.+1 | lo <= ix <= hi] p, 429 | h \In Array.shape a f' & 430 | sorted oleq (&:(fgraph f') `[lo : nat, hi : nat])]]). 431 | 432 | Program Definition quicksort_lm (a : {array 'I_n.+1 -> A}) : 433 | STsep {f : {ffun 'I_n.+1 -> A}} 434 | (Array.shape a f, 435 | [vfun (_ : unit) h => 436 | exists p, let f' := pffun p f in 437 | h \In Array.shape a f' /\ 438 | sorted oleq (fgraph f')]) := 439 | Do (let go := 440 | ffix (fun (loop : quicksort_lm_loop a) '(l,h) => 441 | Do (if decP (b:=(l : nat) < h) idP isn't left pf then skip 442 | else v <-- partition_lm a pf; 443 | loop (l, Po v);; 444 | (* we use saturating increment to stay under n+1 *) 445 | (* and keep the classical form of the algorithm *) 446 | (* the overflow case will exit on next call *) 447 | (* because v = h = n-1 *) 448 | loop (Sso v, h))) 449 | in go (ord0, ord_max)). 450 | Next Obligation. 451 | move=>a loop _ l h [f][] i /= Hi. 452 | case: decP=>[Olh|/negP]; last first. 453 | - rewrite -leqNgt => Ohl. 454 | step=>_; exists 1%g; rewrite pffunE1; split=>//. 455 | - by apply: perm_on1. 456 | move: Ohl; rewrite leq_eqVlt; case/orP=>[/eqP->|Ohl]. 457 | - by rewrite slice_kk /= onth_codom. 458 | by rewrite itv_swapped_bnd. 459 | apply: [stepE f]=>//= v m [/andP [Hvl Hvh]][p][Hp Hm Al Ah]. 460 | apply: [stepE (pffun p f)]=>//= _ ml [pl][]. 461 | rewrite Po_eq -pffunEM => Hpl Hml Sl. 462 | apply: [gE (pffun (pl * p) f)]=>//= _ mr [pr][]. 463 | rewrite Sso_eq ltnS -pffunEM => Hpr Hmr Sr _. 464 | exists (pr * (pl * p))%g; split=>//. 465 | - apply: perm_onM. 466 | - apply/(subset_trans Hpr)/subsetP=>/= z; rewrite !inE. 467 | case/andP=>+ ->; rewrite andbT; case: ltnP=>_ Hz. 468 | - by apply/ltnW/leq_ltn_trans/Hz. 469 | by apply/leq_trans/Hz. 470 | apply: perm_onM=>//. 471 | apply/(subset_trans Hpl)/subsetP=>/= z; rewrite !inE. 472 | case/andP=>->/= Hz. 473 | apply/leq_trans/Hvh/(leq_trans Hz). 474 | by exact: leq_pred. 475 | (* need to handle two edge cases: v=0 and v=n *) 476 | case: (eqVneq v ord0)=>[Ev|Nv0]. 477 | (* if v=0, then l=0 and left partition is empty *) 478 | - have El: l = ord0. 479 | - by move: Hvl; rewrite Ev leqn0 => /eqP El; apply/ord_inj. 480 | rewrite Ev El /= in Hpl. 481 | have Epl: pl = 1%g. 482 | - apply: (perm_on_id Hpl). 483 | have ->: (1 = #|[set (@ord0 n)]|) by rewrite cards1. 484 | apply/subset_leqif_cards/subsetP=>/= z. 485 | by rewrite !inE leqn0 =>/eqP E; apply/eqP/ord_inj. 486 | move: Sr Hpr; rewrite El Ev Epl mul1g; case: ifP=>// H Sr Hpr. 487 | rewrite slice_xL // onth_codom /= -slice_oSL path_sortedE // Sr andbT. 488 | move: Ah; rewrite Ev slice_oSL /=. 489 | have ->: pffun (pr * p) f ord0 = pffun p f ord0. 490 | - by rewrite !ffunE permM (out_perm Hpr) // inE negb_and ltnn. 491 | have HS: subpred (ord (pffun p f ord0)) (oleq (pffun p f ord0)). 492 | - by move=>z /ordW. 493 | move/(sub_all HS); congr (_ = _); apply: perm_all. 494 | rewrite pffunEM perm_sym -!slice_oSL (_ : 0 = (ord0 : 'I_n.+1)) //. 495 | by apply: perm_on_fgraph. 496 | move: (ltn_ord v); rewrite ltnS leq_eqVlt; case/orP=>[/eqP Ev|Nv]. 497 | (* if v=n, then h=n and right partition is empty *) 498 | - have Eh: (h : nat) = n. 499 | - apply/eqP; rewrite eqn_leq; move: Hvh; rewrite Ev=>->; rewrite andbT. 500 | by move: (ltn_ord h); rewrite ltnS. 501 | rewrite Ev Eh /= ltnn in Hpr. 502 | have Epr: pr = 1%g. 503 | - apply: (perm_on_id Hpr). 504 | have ->: (1 = #|[set (@ord_max n)]|) by rewrite cards1. 505 | apply/subset_leqif_cards/subsetP=>/= z. 506 | by rewrite !inE -eqn_leq =>/eqP E; apply/eqP/ord_inj. 507 | move: Sl Hpl; rewrite Eh Ev Epr mul1g => Sl Hpl. 508 | rewrite slice_xR; last by rewrite bnd_simp leEnat; move: Hvl; rewrite Ev. 509 | rewrite {22}(_ : n = (ord_max : 'I_n.+1)) // onth_codom /= sorted_rconsE //=. 510 | move: Sl; rewrite slice_oPR /Order.lt/= lt0n -{1}Ev Nv0. 511 | move=>->; rewrite andbT; move: Al; rewrite Ev. 512 | have ->: pffun (pl * p) f ord_max = pffun p f ord_max. 513 | - rewrite !ffunE permM (out_perm Hpl) // inE negb_and -!ltnNge /=. 514 | by rewrite ltn_predL lt0n -{3}Ev Nv0 orbT. 515 | have ->: v = ord_max by apply/ord_inj. 516 | rewrite [in X in X -> _] 517 | (perm_all (s2:=&:(codom (pffun (pl * p) f)) `[l: nat, n[)) //. 518 | rewrite pffunEM perm_sym. 519 | rewrite {8 15}(_ : n = (ord_max : 'I_n.+1)) //; apply: perm_on_fgraph. 520 | apply/(subset_trans Hpl)/subsetP=>/= z. 521 | rewrite 2!inE in_itv /= leEnat ltEnat /=. 522 | by case/andP=>->/= Hz; apply: (leq_ltn_trans Hz); rewrite ltn_predL lt0n -Ev. 523 | (* the general case *) 524 | rewrite Nv in Hpr Sr. 525 | rewrite (slice_split _ true (x:=v) (i:=`[l : nat, h : nat])) /=; last first. 526 | - by rewrite in_itv /= leEnat; apply/andP. 527 | rewrite (slice_xL (x:=v)) // onth_codom /=. 528 | have -> : pffun (pr * (pl * p)) f v = pffun p f v. 529 | - rewrite !ffunE mulgA; suff ->: (pr * pl * p)%g v = p v by []. 530 | rewrite permM. 531 | have Hmul : perm_on [set ix : 'I_n.+1| (l <= ix <= v.-1) || (v < ix <= h)] 532 | (pr * pl)%g. 533 | - apply: perm_onM. 534 | - by apply/(subset_trans Hpr)/subsetP=>/= z; rewrite !inE=>->; rewrite orbT. 535 | by apply/(subset_trans Hpl)/subsetP=>/= z; rewrite !inE=>->. 536 | rewrite (out_perm Hmul) // inE negb_or !negb_and -leqNgt -!ltnNge leqnn /=. 537 | by rewrite andbT ltn_predL lt0n Nv0 orbT. 538 | rewrite {1}pffunEM (perm_on_notin _ Hpr); last first. 539 | - rewrite disjoint_subset; apply/subsetP=>/= z. 540 | rewrite 3!inE in_itv /= negb_and leEnat ltEnat /= -leqNgt -ltnNge. 541 | by case/andP=>/ltnW-> _; rewrite orbT. 542 | rewrite slice_oSL in Sr. 543 | rewrite mulgA (perm_onC Hpr Hpl) in Sr *; last first. 544 | - rewrite disjoint_subset; apply/subsetP=>/= z; rewrite !inE negb_and -!ltnNge. 545 | case/andP=>Hz _; apply/orP; right. 546 | by apply/leq_ltn_trans/Hz; exact: leq_pred. 547 | rewrite -mulgA (pffunEM _ (pr * p)%g) (perm_on_notin _ Hpl) in Sr *; last first. 548 | - rewrite disjoint_subset; apply/subsetP=>/= z. 549 | rewrite 3!inE in_itv /= negb_and leEnat /= -leqNgt -ltnNge. 550 | case/andP=>_ Hz; apply/orP; left; apply: (leq_trans Hz). 551 | exact: leq_pred. 552 | rewrite sorted_pairwise // pairwise_cat /=. 553 | rewrite allrel_consr -andbA -!sorted_pairwise //. 554 | apply/and5P; split=>//. 555 | - move: Al; congr (_ = _); apply/esym/perm_all; rewrite pffunEM. 556 | apply/perm_on_fgraph/(subset_trans Hpl)/subsetP=>/= z. 557 | rewrite 2!inE in_itv /= leEnat ltEnat /=. 558 | by case/andP=>->/= Hz; apply: (leq_ltn_trans Hz); rewrite ltn_predL lt0n. 559 | - apply/allrelP=>x y Hx Hy; apply: (otrans (y:=pffun p f v)). 560 | - move/allP: Al=>/(_ x); apply. 561 | move: Hx; congr (_ = _); move: x; apply: perm_mem. 562 | rewrite pffunEM; apply: perm_on_fgraph. 563 | apply/(subset_trans Hpl)/subsetP=>/= z. 564 | rewrite 2!inE in_itv /= leEnat ltEnat /=. 565 | by case/andP=>->/= Hz; apply: (leq_ltn_trans Hz); rewrite ltn_predL lt0n. 566 | apply/ordW; move/allP: Ah=>/(_ y); apply. 567 | move: Hy; congr (_ = _); move: y; apply: perm_mem. 568 | by rewrite pffunEM; apply: perm_on_fgraph. 569 | - by rewrite slice_oPR /Order.lt/= lt0n Nv0 in Sl. 570 | have HS: subpred (ord (pffun p f v)) (oleq (pffun p f v)). 571 | - by move=>z /ordW. 572 | move/(sub_all HS): Ah; congr (_ = _); apply/esym/perm_all. 573 | by rewrite pffunEM; apply/perm_on_fgraph. 574 | Qed. 575 | Next Obligation. 576 | move=>a [f][] i /= H; apply: [gE f]=>//= _ m [p][Hp Hm Hs] _. 577 | exists p; split=>//; rewrite -(slice_uu (codom _)) slice_0L. 578 | by rewrite slice_FR size_codom card_ord slice_oSR. 579 | Qed. 580 | 581 | End LomutoQsort. 582 | 583 | 584 | -------------------------------------------------------------------------------- /examples/stack.v: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2022 IMDEA Software Institute 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | http://www.apache.org/licenses/LICENSE-2.0 7 | Unless required by applicable law or agreed to in writing, software 8 | distributed under the License is distributed on an "AS IS" BASIS, 9 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 10 | See the License for the specific language governing permissions and 11 | limitations under the License. 12 | *) 13 | 14 | From Coq Require Import ssreflect ssrbool ssrfun. 15 | From mathcomp Require Import eqtype seq. 16 | From pcm Require Import options axioms pred. 17 | From pcm Require Import pcm unionmap heap autopcm. 18 | From htt Require Import model heapauto. 19 | From htt Require Import llist. 20 | 21 | Definition stack (T : Type) := ptr. 22 | Definition EmptyStack := exn_from_nat 25. 23 | 24 | Module Stack. 25 | Section Stack. 26 | Variable T : Type. 27 | Notation stack := (stack T). 28 | 29 | (* stack is a pointer to a singly-linked list *) 30 | Definition shape s (xs : seq T) := 31 | [Pred h | exists p h', [ /\ h = s :-> p \+ h' & 32 | h' \In lseq p xs]]. 33 | 34 | (* heap cannot match two different specs *) 35 | Lemma shape_inv s xs1 xs2 h : 36 | valid h -> 37 | h \In shape s xs1 -> 38 | h \In shape s xs2 -> 39 | xs1 = xs2. 40 | Proof. 41 | move=>V [p][h1][E S][x][h'][]; rewrite {h}E in V *. 42 | case/(cancelO _ V)=><- _; rewrite !unitL=><-. 43 | by apply: lseq_func=>//; move/validR: V. 44 | Qed. 45 | 46 | (* main methods *) 47 | 48 | (* new stack is a pointer to an empty heap/list *) 49 | Program Definition new : STsep (emp, [vfun y => shape y [::]]) := 50 | Do (alloc null). 51 | Next Obligation. by move=>/= [] i ?; step=>??; vauto. Qed. 52 | 53 | (* freeing a stack, possible only when it's empty *) 54 | Program Definition free s : STsep (shape s [::], 55 | [vfun _ h => h = Unit]) := 56 | Do (dealloc s). 57 | Next Obligation. 58 | by case=>i [?][?][->][_ ->]; step=>_; rewrite unitR. 59 | Qed. 60 | 61 | (* pushing to the stack is inserting into the list and updating the pointer *) 62 | Program Definition push s x : STsep {xs} (shape s xs, 63 | [vfun _ => shape s (x :: xs)]) := 64 | Do (l <-- !s; 65 | l' <-- insert l x; 66 | s ::= l'). 67 | Next Obligation. 68 | (* pull out ghost + precondition, get the list *) 69 | case=>xs [] _ /= [l][h][-> H]; step. 70 | (* run the insert procedure with the ghost, deconstruct the new list *) 71 | apply: [stepX xs]@h=>//= l' _ [r][h'][-> H']. 72 | (* store the new list *) 73 | by step=>V'; hhauto. 74 | Qed. 75 | 76 | (* popping from the stack is: *) 77 | (* 1. trying to get the head *) 78 | (* 2. removing it from the list and updating the pointer on success *) 79 | Program Definition pop s : 80 | STsep {xs} (shape s xs, 81 | fun y h => shape s (behead xs) h /\ 82 | match y with Val v => xs = v :: behead xs 83 | | Exn e => e = EmptyStack /\ xs = [::] end) := 84 | Do (l <-- !s; 85 | try (head l) 86 | (fun x => 87 | l' <-- @remove T l; 88 | s ::= l';; 89 | ret x) 90 | (fun _ => throw EmptyStack)). 91 | Next Obligation. 92 | (* pull out ghost vars and precondition *) 93 | case=>xs [] _ /= [p][h0][-> H]. 94 | (* get the list and invoke head on it, deal with exception first *) 95 | step; apply/[tryX xs]@h0=>//= [x|ex] m [Hm]; last first. 96 | - (* throw the stack exception *) 97 | case=>{ex}_ E /=; step=>Vm; split=>//. 98 | by rewrite E /= in Hm *; vauto. 99 | (* invoke remove and run the rest of the program *) 100 | move=>E; apply: [stepX xs]@m=>//= p' m' H'. 101 | by do 2![step]=>V'; split=>//; vauto. 102 | Qed. 103 | 104 | End Stack. 105 | End Stack. 106 | -------------------------------------------------------------------------------- /examples/tree.v: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2023 IMDEA Software Institute 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | http://www.apache.org/licenses/LICENSE-2.0 7 | Unless required by applicable law or agreed to in writing, software 8 | distributed under the License is distributed on an "AS IS" BASIS, 9 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 10 | See the License for the specific language governing permissions and 11 | limitations under the License. 12 | *) 13 | 14 | From HB Require Import structures. 15 | From mathcomp Require Import ssreflect ssrbool ssrfun. 16 | From mathcomp Require Import eqtype ssrnat seq bigop choice. 17 | From pcm Require Import pred prelude seqext. 18 | 19 | (* arbitrarily branching tree *) 20 | Inductive tree A := TNode of A & seq (tree A). 21 | Arguments TNode {A}. 22 | 23 | Section Tree. 24 | Context {A : Type}. 25 | 26 | Definition rt (t : tree A) := let: TNode r _ := t in r. 27 | Definition ch (t : tree A) := let: TNode _ ts := t in ts. 28 | 29 | Lemma tree_ext (t : tree A) : TNode (rt t) (ch t) = t. 30 | Proof. by case: t. Qed. 31 | 32 | (* leaf is a node with an empty list *) 33 | Definition lf a : tree A := TNode a [::]. 34 | 35 | Lemma tree_ind' (P : tree A -> Prop) : 36 | (forall a l, All P l -> P (TNode a l)) -> 37 | forall t, P t. 38 | Proof. by move=>indu; fix H 1; elim => a l; apply indu; elim: l. Qed. 39 | 40 | Lemma tree_rec' (P : tree A -> Type) : 41 | (forall a l, AllT P l -> P (TNode a l)) -> 42 | forall t, P t. 43 | Proof. by move=>indu; fix H 1; elim => a l; apply: indu; elim: l. Qed. 44 | 45 | (* custom induction principles *) 46 | 47 | Lemma tree_ind1 (P : tree A -> Prop) : 48 | (forall a ts, (forall t, t \In ts -> P t) -> P (TNode a ts)) -> 49 | forall t, P t. 50 | Proof. 51 | move=>H; apply: tree_ind'=>a [_|x xs] /=; first by apply: H. 52 | case=>H1 /AllP H2; apply: H=>t; rewrite InE; case=>[->|] //. 53 | by apply: H2. 54 | Qed. 55 | 56 | Fixpoint preorder (t : tree A) : seq A := 57 | let: TNode a ts := t in 58 | foldl (fun s t => s ++ preorder t) [::a] ts. 59 | 60 | Lemma foldl_cat {B C} z (fs : seq B) (a : B -> seq C): 61 | foldl (fun s t => s ++ a t) z fs = 62 | z ++ foldl (fun s t => s ++ a t) [::] fs. 63 | Proof. 64 | apply/esym/fusion_foldl; last by rewrite cats0. 65 | by move=>x y; rewrite catA. 66 | Qed. 67 | 68 | Lemma preorderE t : 69 | preorder t = 70 | rt t :: \big[cat/[::]]_(c <- ch t) (preorder c). 71 | Proof. 72 | case: t=>a cs /=; rewrite foldl_cat /=; congr (_ :: _). 73 | elim: cs=>/= [| c cs IH]; first by rewrite big_nil. 74 | by rewrite big_cons foldl_cat; rewrite IH. 75 | Qed. 76 | 77 | End Tree. 78 | 79 | Arguments tree_ind1 [A P]. 80 | 81 | Section EncodeDecodeTree. 82 | Variable A : Type. 83 | 84 | Fixpoint encode_tree (t : tree A) : GenTree.tree A := 85 | match t with 86 | | TNode a [::] => GenTree.Leaf a 87 | | TNode a l => GenTree.Node O(*dummy*) (GenTree.Leaf a :: map encode_tree l) 88 | end. 89 | 90 | Fixpoint decode_tree (t : GenTree.tree A) : option (tree A) := 91 | match t with 92 | | GenTree.Leaf a => Some (TNode a [::]) 93 | | GenTree.Node _ (GenTree.Leaf h :: l) => Some (TNode h (pmap decode_tree l)) 94 | | GenTree.Node _ _ => None 95 | end. 96 | 97 | Lemma pcancel_tree : pcancel encode_tree decode_tree. 98 | Proof. 99 | elim/(@tree_ind' A) => a [//|b s /= [-> H2 /=]]; congr (Some (TNode _ (_ :: _))). 100 | elim: s H2 => // c s IH /= [-> K2 /=]; by rewrite IH. 101 | Qed. 102 | 103 | End EncodeDecodeTree. 104 | 105 | HB.instance Definition _ (A : eqType) := 106 | Equality.copy (tree A) (pcan_type (pcancel_tree A)). 107 | 108 | Section TreeEq. 109 | Context {A : eqType}. 110 | 111 | Fixpoint mem_tree (t : tree A) : pred A := 112 | let: TNode x l := t in 113 | fun a => (a == x) || has (mem_tree^~ a) l. 114 | 115 | Definition tree_eqclass := tree A. 116 | Identity Coercion tree_of_eqclass : tree_eqclass >-> tree. 117 | Coercion pred_of_tree (t : tree_eqclass) : {pred A} := mem_tree t. 118 | Canonical tree_predType := ssrbool.PredType (pred_of_tree : tree A -> pred A). 119 | 120 | Lemma in_tnode a t ts : 121 | (t \in TNode a ts) = 122 | (t == a) || has (fun q => t \in q) ts. 123 | Proof. by []. Qed. 124 | 125 | (* frequently used facts about membership in a tree *) 126 | 127 | Lemma in_tnode1 a (ts : seq (tree A)) : a \in TNode a ts. 128 | Proof. by rewrite in_tnode eq_refl. Qed. 129 | 130 | Lemma in_tnode2 x y a (ts : seq (tree A)) : 131 | x \In ts -> y \in x -> y \in TNode a ts. 132 | Proof. 133 | move=>X Y; rewrite in_tnode; apply/orP; right; apply/hasP=>/=. 134 | by exists x=>//; apply/mem_seqP. 135 | Qed. 136 | 137 | Lemma rt_in (t : tree A) : rt t \in t. 138 | Proof. by case: t=>/= a ts; exact: in_tnode1. Qed. 139 | 140 | Lemma in_preorder t : preorder t =i t. 141 | Proof. 142 | elim/tree_ind1: t=>t cs IH x. 143 | rewrite preorderE in_tnode /= inE; case: eqVneq=>//= N. 144 | rewrite big_cat_mem_has; apply: eq_in_has=>z Hz. 145 | by rewrite IH //; apply/mem_seqP. 146 | Qed. 147 | 148 | Lemma tallP (p : pred A) t : 149 | reflect {in t, forall x, p x} (all p (preorder t)). 150 | Proof. 151 | by apply: (iffP allP)=>H x Hx; apply: H; 152 | [rewrite in_preorder | rewrite -in_preorder]. 153 | Qed. 154 | 155 | End TreeEq. 156 | 157 | Arguments in_tnode2 {A x y a ts}. 158 | #[export] Hint Resolve in_tnode1 : core. 159 | 160 | (* a simplified induction principle for eq types *) 161 | (* to avoid switching with mem_seqP all the time *) 162 | Lemma tree_ind2 (A : eqType) (P : tree A -> Prop) : 163 | (forall a ts, (forall t, t \in ts -> P t) -> P (TNode a ts)) -> 164 | forall t, P t. 165 | Proof. 166 | move=>H; apply: tree_ind1=>a ts IH. 167 | by apply: H=>t /mem_seqP; apply: IH. 168 | Qed. 169 | 170 | Arguments tree_ind2 [A P]. 171 | 172 | -------------------------------------------------------------------------------- /examples/union_find.v: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2023 IMDEA Software Institute 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | http://www.apache.org/licenses/LICENSE-2.0 7 | Unless required by applicable law or agreed to in writing, software 8 | distributed under the License is distributed on an "AS IS" BASIS, 9 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 10 | See the License for the specific language governing permissions and 11 | limitations under the License. 12 | *) 13 | 14 | From mathcomp Require Import ssreflect ssrbool ssrfun fintype. 15 | From mathcomp Require Import eqtype ssrnat seq bigop choice. 16 | From pcm Require Import options axioms pred seqext. 17 | From pcm Require Import prelude pcm unionmap natmap heap autopcm automap. 18 | From htt Require Import options model heapauto tree. 19 | 20 | (**************) 21 | (**************) 22 | (* Union-find *) 23 | (**************) 24 | (**************) 25 | 26 | (******************) 27 | (* inverted trees *) 28 | (******************) 29 | 30 | (* the layout of a tree in the heap and the map of set reps of the tree *) 31 | (* should lock to avoid exposing the folds upon simplification *) 32 | (* as they make the lemmas unreadable *) 33 | (* will provide the explicit big equations for rewriting *) 34 | 35 | Fixpoint tlay (t : tree ptr) (r : ptr) : heap := 36 | foldr (fun x h => h \+ tlay x (rt t)) (rt t :-> r) (ch t). 37 | 38 | Fixpoint tset (t : tree ptr) (r : ptr) : umap ptr ptr := 39 | foldr (fun t h => h \+ tset t r) (rt t \\-> r) (ch t). 40 | 41 | (* explicit equations for expanding the defs of tlayout and tset *) 42 | (* Ideally, these should have been the actual fixed point defs *) 43 | (* but Coq can't see that such defs are well-founded *) 44 | 45 | Lemma tlayE t r : 46 | tlay t r = 47 | rt t :-> r \+ \big[join/Unit]_(x <- ch t) (tlay x (rt t)). 48 | Proof. 49 | case: t=>a ts /=; rewrite foldr_join; congr (_ \+ _). 50 | elim: ts=>[|t ts IH] /=; first by rewrite big_nil. 51 | by rewrite big_cons IH joinC. 52 | Qed. 53 | 54 | Lemma tsetE t r : 55 | tset t r = 56 | rt t \\-> r \+ \big[join/Unit]_(x <- ch t) (tset x r). 57 | Proof. 58 | case: t=>a ts /=; rewrite foldr_join; congr (_ \+ _). 59 | elim: ts=>[|t ts IH] /=; first by rewrite big_nil. 60 | by rewrite big_cons IH joinC. 61 | Qed. 62 | 63 | 64 | (*******************) 65 | (* dom/valid/range *) 66 | (* inverted trees *) 67 | (*******************) 68 | 69 | Lemma valid_dom_tset (t : tree ptr) r : 70 | (valid (tset t r) = uniq (preorder t)) * 71 | (dom (tset t r) =i 72 | if valid (tset t r) then preorder t else [::]). 73 | Proof. 74 | elim/tree_ind2: t r=>a ts IH r. rewrite tsetE preorderE. 75 | rewrite validPtUn !big_valid_dom_seq /= big_cat_mem_has. 76 | case: allP=>H /=; last first. 77 | - split=>[|x]; last first. 78 | - by rewrite domUn inE validPtUn !big_valid_dom_seq; case: allP. 79 | rewrite andbC; case: uniq_big_catE=>//=; case=>H1 _ _. 80 | by case: H=>t T; rewrite IH // H1. 81 | case U1: (uniq _)=>/=; last first. 82 | - rewrite andbC; case U2: (uniq _)=>/=; last first. 83 | - by split=>// x; rewrite domPtUn inE validPtUn /= !big_valid_dom_seq U1 andbF. 84 | case/uniq_big_catE: U2=>H1 H2 H3. 85 | case: uniq_big_catE U1=>//; case; split. 86 | - by move=>i; rewrite uniq_dom. 87 | - move=>i k X D; apply: (H2 i k X). 88 | by rewrite (IH i X r) H in D. 89 | move=>i j k X Y Di Dj. 90 | apply: (H3 i j k)=>//; first by rewrite (IH i X r) H in Di. 91 | by rewrite (IH j Y r) H in Dj. 92 | rewrite big_cat_mem_has andbC; case: uniq_big_catE=>/=; last first. 93 | - case/uniq_big_catE: U1=>H1 H2 H3; case; split. 94 | - by move=>i X; rewrite -(IH i X r) H. 95 | - by move=>i k X D; apply: (H2 i k X); rewrite (IH i X r) H. 96 | move=>i j k X Y Di Dj; apply: (H3 i j k X Y); first by rewrite (IH i X r) H. 97 | by rewrite (IH j Y r) H. 98 | case=>K1 K2 K3; split=>[|x]. 99 | - by rewrite -!all_predC; apply: eq_in_all=>i X; rewrite /= IH ?H. 100 | rewrite domPtUn inE validPtUn /= !big_valid_dom_seq U1 andbT. 101 | case: allP=>//= _; rewrite !big_cat_mem_has -all_predC. 102 | case: allP=>//= A; rewrite inE big_cat_mem_has eq_sym. 103 | by case: (x =P a)=>//= _; apply: eq_in_has=>i X; rewrite IH ?H. 104 | Qed. 105 | 106 | Lemma valid_tset (t : tree ptr) r : 107 | valid (tset t r) = uniq (preorder t). 108 | Proof. by rewrite valid_dom_tset. Qed. 109 | 110 | Lemma dom_tset_ord (t : tree ptr) r : 111 | dom (tset t r) =i 112 | if valid (tset t r) then preorder t else [::]. 113 | Proof. by move=>x; rewrite valid_dom_tset. Qed. 114 | 115 | Lemma dom_tset (t : tree ptr) r : 116 | valid (tset t r) -> dom (tset t r) =i t. 117 | Proof. by move=>V x; rewrite dom_tset_ord V in_preorder. Qed. 118 | 119 | Lemma dom_tsetE (t : tree ptr) r : 120 | dom (tset t r) =i [pred x | valid (tset t r) && (x \in t)]. 121 | Proof. by move=>x; rewrite inE dom_tset_ord -in_preorder; case: ifP. Qed. 122 | 123 | Lemma size_dom_tset (t : tree ptr) r : 124 | valid (tset t r) -> 125 | size (dom (tset t r)) = size (preorder t). 126 | Proof. 127 | move=>V; apply/eqP; rewrite -uniq_size_uniq ?uniq_dom -?(valid_tset t r) //. 128 | by move=>x; rewrite dom_tset_ord V. 129 | Qed. 130 | 131 | Lemma range_tset (t : tree ptr) r : 132 | valid (tset t r) -> range (tset t r) =i [:: r]. 133 | Proof. 134 | elim/tree_ind2: t=>a ts IH. rewrite tsetE /= => V x. 135 | rewrite rangePtUn inE validPtUn (validX V) (validPtUnD V) inE /= eq_sym. 136 | case: eqVneq=>//= N; apply/negP=>/mem_rangeX [k]. 137 | case/bigInX=>i /[dup] X /mem_seqP X' /mem_range. rewrite IH //. 138 | - by rewrite inE (negbTE N). 139 | by apply: big_validV (validX V) X. 140 | Qed. 141 | 142 | Lemma domeq_tlay_tset (t : tree ptr) r1 r2 : 143 | {in t, forall x, x != null} -> 144 | dom_eq (tlay t r1) (tset t r2). 145 | Proof. 146 | elim/tree_ind1: t r1 r2=>a ts IH r1 r2 Tn. 147 | rewrite tlayE tsetE /= domeqPtUn ?Tn // big_domeqUn //. 148 | by move=>x X; apply: IH=>// z Z; apply: Tn (in_tnode2 X Z). 149 | Qed. 150 | 151 | Lemma valid_tlayE (t : tree ptr) r : 152 | valid (tlay t r) -> {in t, forall x, x != null}. 153 | Proof. 154 | elim/tree_ind1: t r=>a ts IH r; rewrite tlayE /= => V x; rewrite in_tnode. 155 | case/orP=>[/eqP ->|]; first by rewrite (validPtUn_cond V). 156 | case/hasPIn=>y Y; apply: IH =>//; apply: (big_validV (validX V) Y). 157 | Qed. 158 | 159 | Lemma valid_tlay (t : tree ptr) r : 160 | valid (tlay t r) = 161 | valid (tset t r) && all (fun x => x != null) (preorder t). 162 | Proof. 163 | apply/idP/idP; last first. 164 | - by case/andP=>V /tallP W; rewrite (domeqVE (domeq_tlay_tset r r W)). 165 | move/[dup]=>V /valid_tlayE /[dup] N /tallP ->. 166 | by rewrite -(domeqVE (domeq_tlay_tset r r N)) V. 167 | Qed. 168 | 169 | Lemma valid_tlayN (t : tree ptr) r : 170 | valid (tlay t r) -> valid (tset t r). 171 | Proof. by rewrite valid_tlay=>/andP []. Qed. 172 | 173 | Lemma dom_tlay (t : tree ptr) r : 174 | valid (tlay t r) -> dom (tlay t r) =i t. 175 | Proof. 176 | rewrite valid_tlay=>/andP [V /tallP A] x. 177 | by rewrite -(dom_tset V) (domeqDE (domeq_tlay_tset r r A)). 178 | Qed. 179 | 180 | Lemma dom_tlayE (t : tree ptr) r : 181 | dom (tlay t r) =i [pred x | valid (tlay t r) && (x \in t)]. 182 | Proof. 183 | move=>x; apply/idP/idP; last by rewrite inE; case/andP=>V; rewrite dom_tlay. 184 | by move=>D; rewrite inE (dom_valid D) -(dom_tlay (dom_valid D)). 185 | Qed. 186 | 187 | Lemma size_dom_tlay (t : tree ptr) r : 188 | valid (tlay t r) -> 189 | size (dom (tlay t r)) = size (preorder t). 190 | Proof. 191 | move=>V; apply/eqP; rewrite -uniq_size_uniq ?uniq_dom //. 192 | - by rewrite -(valid_tset t r) (valid_tlayN V). 193 | by move=>x; rewrite dom_tlay // in_preorder. 194 | Qed. 195 | 196 | (* no strong range_tlay lemma; weak one below *) 197 | 198 | (***********************************) 199 | (* parent-child relation and roots *) 200 | (* for inverted trees *) 201 | (***********************************) 202 | 203 | Lemma find_tset x r t : 204 | find x (tset t r) = 205 | if valid (tset t r) && (x \in t) then Some r else None. 206 | Proof. 207 | case V : (valid (tset t r))=>/=; last first. 208 | - by move/invalidE: (negbT V)=>->; rewrite find_undef. 209 | rewrite -(dom_tset V); case: dom_find=>// v E _. 210 | elim/tree_ind1: t V E=>a ts IH; rewrite tsetE /= => V. 211 | rewrite !findPtUn2 //; case: (x =P a)=>//= _. 212 | case/big_find_someX=>i X /[dup] D /In_find/In_valid W. 213 | by apply: IH X W (D). 214 | Qed. 215 | 216 | Lemma In_tsetP x r t: 217 | reflect ((x, r) \In tset t (rt t)) 218 | [&& valid (tset t (rt t)), x \in t & r == rt t]. 219 | Proof. 220 | apply/(iffP idP); rewrite In_find find_tset. 221 | - by case/and3P=>->-> /eqP ->. 222 | by case: ifP=>// /andP [->->][->] /=. 223 | Qed. 224 | 225 | Lemma find_tlayTp (x : ptr) (t : tree ptr) (p : dynamic id) r : 226 | find x (tlay t r) = Some p -> 227 | exists x : ptr, p = idyn x. 228 | Proof. 229 | elim/tree_ind1: t r=>a t IH r; rewrite tlayE /=. 230 | move/[dup]=>/In_find/In_valid V; rewrite findPtUn2 //. 231 | case: eqP=>[_ [<-]|_]; first by exists r. 232 | by case/big_find_someX=>z Z /(IH _ Z). 233 | Qed. 234 | 235 | Lemma tlay_rt x (p : ptr) t r : 236 | find x (tlay t r) = Some (idyn p) -> 237 | if x == rt t then p = r else (p != x) && (p \in t). 238 | Proof. 239 | elim/tree_ind1: t r=>a ts IH r; rewrite tlayE /= => /[dup]/In_find/In_valid V. 240 | rewrite findPtUn2 // in_tnode; case: eqVneq=>[_ [/inj_pair2]|N] //. 241 | case/big_find_someX=>t T /(IH _ T) H; case: ifP H N=>[_ ->|_]. 242 | - by rewrite eqxx // eq_sym =>->. 243 | by case/andP=>-> H _; case: orP=>//; elim; right; apply/hasPIn; exists t. 244 | Qed. 245 | 246 | Lemma tlay_rt_loop t x : 247 | find x (tlay t (rt t)) = Some (idyn x) -> x = rt t. 248 | Proof. by move/tlay_rt; rewrite eqxx /=; case: eqP. Qed. 249 | 250 | Lemma tlay_rt_rt (p : ptr) t r : 251 | find (rt t) (tlay t r) = Some (idyn p) -> p = r. 252 | Proof. by move/tlay_rt; rewrite eqxx. Qed. 253 | 254 | 255 | (********************) 256 | (********************) 257 | (* inverted forests *) 258 | (********************) 259 | (********************) 260 | 261 | Definition flay ts := foldr (fun t h => tlay t (rt t) \+ h) Unit ts. 262 | Definition fset ts := foldr (fun t h => tset t (rt t) \+ h) Unit ts. 263 | 264 | Lemma flayE ts : flay ts = \big[join/Unit]_(t <- ts) (tlay t (rt t)). 265 | Proof. by elim: ts=>[|t ts IH] /=; [rewrite big_nil|rewrite big_cons IH]. Qed. 266 | 267 | Lemma fsetE ts : fset ts = \big[join/Unit]_(t <- ts) (tset t (rt t)). 268 | Proof. by elim: ts=>[|t ts IH] /=; [rewrite big_nil|rewrite big_cons IH]. Qed. 269 | 270 | Lemma find_flayTp (x : ptr) (ts : seq (tree ptr)) (p : dynamic id) : 271 | find x (flay ts) = Some p -> 272 | exists y : ptr, p = idyn y. 273 | Proof. 274 | elim: ts=>[|t ts IH] //= /[dup] /In_find/In_valid V; rewrite findUnL //. 275 | by case: ifP=>_; [apply: find_tlayTp | apply: IH]. 276 | Qed. 277 | 278 | Lemma In_fsetP x r ts : 279 | reflect ((x, r) \In fset ts) 280 | (valid (fset ts) && has (fun t => (x \in t) && (r == rt t)) ts). 281 | Proof. 282 | rewrite fsetE; apply/(iffP idP). 283 | - case/andP=>V /hasP [i] /mem_seqP X /andP [H1 H2]. 284 | by apply: bigIn (V) (X) _; apply/In_tsetP; rewrite H1 H2 (big_validV V). 285 | move/[dup]/In_valid=>-> /bigInX [i] /mem_seqP X /In_tsetP /andP [V H]. 286 | by apply/hasP; exists i. 287 | Qed. 288 | 289 | Lemma dom_fset (ts : seq (tree ptr)) x : 290 | valid (fset ts) -> 291 | x \in dom (fset ts) = has (fun t => x \in t) ts. 292 | Proof. 293 | elim: ts=>[|t ts IH] //= V. 294 | by rewrite domUn V inE /= IH ?dom_tset ?(validX V). 295 | Qed. 296 | 297 | Lemma dom_fsetE (ts : seq (tree ptr)) : 298 | dom (fset ts) =i 299 | [pred x | valid (fset ts) && has (fun t => x \in t) ts]. 300 | Proof. 301 | move=>x; rewrite inE. 302 | case V : (valid (fset ts))=>/=; first by apply: dom_fset. 303 | by move/invalidE: (negbT V)=>->; rewrite dom_undef. 304 | Qed. 305 | 306 | Lemma range_fsetE ts : 307 | range (fset ts) =i 308 | [pred x | valid (fset ts) && has (fun t => x == rt t) ts]. 309 | Proof. 310 | elim: ts=>[|t ts IH] //= x. 311 | rewrite rangeUn inE; case V : (valid _)=>//=. 312 | by rewrite range_tset ?inE ?IH ?(validX V). 313 | Qed. 314 | 315 | Lemma range_fset ts x : 316 | valid (fset ts) -> 317 | x \in range (fset ts) = has (fun t => x == rt t) ts. 318 | Proof. by move=>V; rewrite range_fsetE V inE. Qed. 319 | 320 | 321 | Lemma valid_fset_tset (ts : seq (tree ptr)) : 322 | valid (fset ts) -> 323 | {in ts, forall i, valid (tset i (rt i))}. 324 | Proof. by move=>+ i Hi; rewrite fsetE big_valid_seq=>/andP [/allP /(_ i Hi)]. Qed. 325 | 326 | Lemma valid_flay_tlay (ts : seq (tree ptr)) : 327 | valid (flay ts) -> 328 | {in ts, forall i, valid (tlay i (rt i))}. 329 | Proof. by move=>+ i Hi; rewrite flayE big_valid_seq=>/andP [/allP /(_ i Hi)]. Qed. 330 | 331 | Lemma dom_flay (ts : seq (tree ptr)) x : 332 | valid (flay ts) -> 333 | x \in dom (flay ts) = has (fun t => x \in t) ts. 334 | Proof. 335 | move=>V; rewrite flayE big_domUn inE -flayE V; apply: eq_in_has=>i H. 336 | by rewrite dom_tlay // (valid_flay_tlay V). 337 | Qed. 338 | 339 | Lemma dom_flayE (ts : seq (tree ptr)) : 340 | dom (flay ts) =i 341 | [pred x | valid (flay ts) && has (fun t => x \in t) ts]. 342 | Proof. 343 | move=>x; case V : (valid _)=>/=; last first. 344 | - by move/invalidE: (negbT V)=>->; rewrite dom_undef. 345 | by rewrite inE dom_flay. 346 | Qed. 347 | 348 | Lemma valid_flay_fset (ts : seq (tree ptr)) : 349 | valid (flay ts) = valid (fset ts) && 350 | all (fun t => all (fun i => i != null) (preorder t)) ts. 351 | Proof. 352 | elim: ts=>[|t ts IH] //=. 353 | rewrite !validUnAE IH -!andbA valid_tlay /=. 354 | case V1 : (valid _)=>//=. 355 | case V2 : (valid _)=>/=; last by rewrite andbF. 356 | case A1 : (all _)=>/=; last by rewrite andbF. 357 | case A2 : (all _)=>/=; last by rewrite andbF. 358 | rewrite andbT !all_predC; rewrite V2 A2 /= in IH; congr (~~ _). 359 | have /eq_has -> : dom (tlay t (rt t)) =i dom (tset t (rt t)). 360 | - by move=>x; rewrite dom_tlay ?valid_tlay ?V1 ?A1 ?dom_tset. 361 | by apply: eq_has_r=>x; rewrite dom_flay // dom_fset. 362 | Qed. 363 | 364 | Lemma dom_flay_fset (ts : seq (tree ptr)) : 365 | all (fun t => all (fun i => i != null) (preorder t)) ts -> 366 | dom (flay ts) = dom (fset ts). 367 | Proof. 368 | move=>A; apply/domE=>x; rewrite dom_flayE dom_fsetE !inE valid_flay_fset A /=. 369 | by rewrite andbT. 370 | Qed. 371 | 372 | Lemma subvalid_flay (ts : seq (tree ptr)) : 373 | valid (flay ts) -> valid (fset ts). 374 | Proof. by rewrite valid_flay_fset=>/andP []. Qed. 375 | 376 | Lemma subdom_flay (ts : seq (tree ptr)) : 377 | {subset dom (flay ts) <= dom (fset ts)}. 378 | Proof. 379 | move=>x /[dup] /dom_valid; rewrite valid_flay_fset=>/andP [V A]. 380 | by rewrite dom_flay_fset. 381 | Qed. 382 | 383 | Lemma valid_flayN2 t (ts : seq (tree ptr)) : 384 | valid (tlay t (rt t) \+ flay ts) -> 385 | valid (tset t (rt t) \+ fset ts). 386 | Proof. 387 | by rewrite (_ : valid _ = valid (flay (t :: ts))) // => /subvalid_flay. 388 | Qed. 389 | 390 | Lemma flay_rt x (p : ptr) ts : 391 | find x (flay ts) = Some (idyn p) -> 392 | if x \in range (fset ts) then p == x 393 | else (p != x) && has (fun t => (x \in t) && (p \in t)) ts. 394 | Proof. 395 | elim: ts=>[|t ts IH] /=; first by rewrite find0E. 396 | move/[dup]=>/In_find/In_valid V. 397 | rewrite findUnL // rangeUn inE (valid_flayN2 V) /=. 398 | rewrite dom_tlayE inE (validX V) /=. 399 | rewrite range_tset ?(valid_tlayN (validX V)) // inE. 400 | case: eqVneq=>[->|N] /=; first by rewrite rt_in=>/tlay_rt_rt ->; rewrite eqxx. 401 | case: ifP=>X // /tlay_rt; rewrite (negbTE N)=>/andP [P1 P2]. 402 | rewrite {P1}(negbTE P1) range_fset ?(subvalid_flay (validX V)) // ifN ?P2 //. 403 | apply/hasPn=>y Ty; apply: contra N=>/eqP ?; subst x; exfalso. 404 | apply: (dom_inNLX (k:=rt y) V). 405 | - by rewrite dom_tlayE inE (validX V). 406 | by rewrite dom_flayE inE (validX V); apply/hasP; exists y=>//; rewrite rt_in. 407 | Qed. 408 | 409 | Lemma flay_rt_domL x (p : ptr) ts : 410 | find x (flay ts) = Some (idyn p) -> x \in dom (fset ts). 411 | Proof. by move=>H; apply: subdom_flay (find_some H). Qed. 412 | 413 | Lemma flay_rt_domR x (p : ptr) ts : 414 | find x (flay ts) = Some (idyn p) -> p \in dom (fset ts). 415 | Proof. 416 | move/[dup]=>/In_find/In_dom /= H /flay_rt. 417 | case: ifP=>[_ /eqP ->|_]; first by apply: subdom_flay. 418 | case/andP=>_ H1; rewrite dom_fset; first by apply: sub_has H1=>z /andP []. 419 | by apply: subvalid_flay (dom_valid H). 420 | Qed. 421 | 422 | Lemma size_dom_flay ts : 423 | valid (flay ts) -> 424 | size (dom (flay ts)) = \sum_(t <- ts) size (preorder t). 425 | Proof. 426 | elim: ts=>[|t ts IH /=]; first by rewrite big_nil. 427 | move=>V; rewrite big_cons size_domUn //. 428 | by rewrite -IH ?(validX V) // -(size_dom_tlay (validX V)). 429 | Qed. 430 | 431 | Lemma dom_flay_big (ts : seq (tree ptr)) : 432 | valid (flay ts) -> 433 | dom (flay ts) =i \big[cat/[::]]_(t <- ts) preorder t. 434 | Proof. 435 | move=>V x; rewrite flayE big_domUn inE -flayE V big_cat_mem_has /=. 436 | by apply: eq_in_has=>i H; rewrite dom_tlay ?in_preorder ?(valid_flay_tlay V H). 437 | Qed. 438 | 439 | Lemma flay_uniq ts : 440 | valid (flay ts) -> 441 | uniq (\big[cat/[::]]_(t <- ts) preorder t). 442 | Proof. 443 | move=>V; rewrite -(eq_uniq _ (dom_flay_big V)) ?uniq_dom //. 444 | by rewrite size_dom_flay ?size_big_cat. 445 | Qed. 446 | 447 | Lemma flay_mem_eq x i j ts : 448 | valid (flay ts) -> 449 | x \in i -> i \in ts -> 450 | x \in j -> j \in ts -> i = j. 451 | Proof. 452 | move=>V Xi /[dup] Ti /mem_seqP Ti' Xj /[dup] Tj /mem_seqP Tj'. 453 | apply: big_cat_uniq_pairwise (flay_uniq V) Ti' Tj' _. 454 | by apply/hasP; exists x=>/=; rewrite in_preorder. 455 | Qed. 456 | 457 | Lemma fset_pts_rev x r ts : 458 | valid (flay ts) -> 459 | (x, r) \In fset ts -> 460 | exists2 p, [pcm x :-> p <= flay ts] & (p, r) \In fset ts. 461 | Proof. 462 | move=>V /[dup] H /In_fsetP /andP [Vs] /hasP [i] Ti /andP [Xi /eqP E]. 463 | have : x \in dom (flay ts) by rewrite dom_flay // -dom_fset // (In_dom H). 464 | case/In_domX=>_ /In_find/[dup] /find_flayTp [p -> F]. 465 | exists p; first by exists (free (flay ts) x); apply: um_eta2. 466 | move/flay_rt: F. case: ifP=>[_ /eqP ->|_] //. 467 | case/andP=>N /hasP [j Tj] /andP [Xj P]. 468 | apply/In_fsetP; rewrite Vs; apply/hasP; exists j=>//. 469 | by rewrite P E (flay_mem_eq V Xi Ti Xj Tj) eqxx. 470 | Qed. 471 | 472 | Lemma froot_loop x r ts : 473 | (x, r) \In fset ts -> 474 | find x (flay ts) = Some (idyn x) -> 475 | x = r. 476 | Proof. 477 | elim: ts r=>[|t ts IH] r //= /In_find H1 H2. 478 | move: (dom_valid (find_some H1)) (dom_valid (find_some H2))=>V1 V2. 479 | move: H1 H2; rewrite !findUnL ?(dom_tset,dom_tlay,validL V1,validL V2) //. 480 | case A: (x \in t). 481 | - rewrite find_tset ifT; first by case=>E; move/tlay_rt_loop=>K; rewrite K -E. 482 | apply/andP; split=>//; first by apply: validL V1. 483 | by rewrite -In_find; apply: IH. 484 | Qed. 485 | 486 | Definition change_ts (ts : seq (tree ptr)) (a b : tree ptr) := 487 | if a == b then ts 488 | else TNode (rt b) (a :: ch b) :: 489 | filter (fun x => (x != a) && (x != b)) ts. 490 | 491 | Lemma flay_cons (a : tree ptr) b : flay (a :: b) = flay [:: a] \+ flay b. 492 | Proof. by rewrite !flayE !big_cons !big_nil unitR. Qed. 493 | 494 | Lemma flay_tree (a: tree ptr): 495 | flay ([:: a]) = tlay a (rt a). 496 | Proof. by rewrite flayE big_cons big_nil unitR. Qed. 497 | 498 | Lemma flay_uniq_ts ts : valid (flay ts) -> uniq ts. 499 | Proof. 500 | move=>/flay_uniq/uniq_big_catE [_ H _]; apply: count_mem_uniq=>t. 501 | case T : (t \in ts); last by apply/count_memPn; apply: negbT. 502 | by apply: (H t (rt t))=>//; rewrite in_preorder rt_in. 503 | Qed. 504 | 505 | Lemma nochange_mapv (K : ordType) (V : eqType) (m : umap K V) b x : 506 | valid m -> 507 | x \notin range m -> 508 | mapv [fun v => v with x |-> b] m = m. 509 | Proof. 510 | move=>W /negP R; apply: umem_eq=>[|//|[k v]]; first by rewrite pfV. 511 | rewrite In_omapX /=; split=>[[w]|H]. 512 | - by case: (w =P x)=>[->{w} /mem_range/R|_ /[swap][[]->]//]. 513 | by exists v=>//; case: (v =P x) H=>// -> /mem_range/R. 514 | Qed. 515 | 516 | Lemma change_tset ta a b: 517 | valid (tset ta a) -> 518 | mapv [fun v => v with a |-> b] (tset ta a) = tset ta b. 519 | Proof. 520 | elim/tree_ind2: ta a=>c ts IH a //; rewrite !tsetE /= => V. 521 | rewrite omapVUn omapPt /= eq_refl big_omapVUn !(validX V). 522 | congr (_ \+ _); apply: eq_big_seq=>i /[dup] K /mem_seqP K'. 523 | by rewrite IH // (big_validV (validX V) K'). 524 | Qed. 525 | 526 | (*******************) 527 | (* Shape predicate *) 528 | (*******************) 529 | 530 | Definition shape rs h := exists ts, [/\ h = flay ts, rs = fset ts & valid h]. 531 | 532 | Lemma shapeV rs h : shape rs h -> valid rs. 533 | Proof. by case=>ts [->->]; rewrite valid_flay_fset=>/andP []. Qed. 534 | 535 | (*******) 536 | (* NEW *) 537 | (*******) 538 | 539 | (* Creates a new equivalence class with a single element *) 540 | 541 | Program Definition newT : 542 | STsep {m} (shape m, [vfun r => shape (r \\-> r \+ m)]) := 543 | Do (p <-- alloc null; 544 | p ::= p;; 545 | ret p). 546 | Next Obligation. 547 | case=>m [] h [ts] [->-> V]. step=>p. do !step. move=>V2. 548 | by exists (TNode p nil :: ts); split. 549 | Qed. 550 | 551 | (********) 552 | (* FIND *) 553 | (********) 554 | 555 | (* Returns the canonical representative of the equivalence class of an element*) 556 | 557 | Definition find_tp (x : ptr) := 558 | STsep {rs r} (fun h => shape rs h /\ (x, r) \In rs, 559 | [vfun res h => shape rs h /\ res = r]). 560 | 561 | Program Definition find1 (x : ptr) : find_tp x := 562 | Do (let root := ffix (fun (go : forall x, find_tp x) (x : ptr) => 563 | Do (p <-- !x; 564 | if x == p then ret p else go p)) 565 | in root x). 566 | Next Obligation. 567 | move=>_ go x [rs][r] [] h //= [[ts [->-> V]] H]. 568 | case/(fset_pts_rev V): (H)=>p [j E] K. rewrite E in V; rewrite E; step. 569 | case: (x =P p) E =>[->|N] E; apply: vrfV=>V1. 570 | - step=>_. split=>//; first by exists ts; split=>//=. 571 | by apply: froot_loop K _; rewrite E findPtUn. 572 | apply: [gE fset ts, r] => //=; first by do !split=>//=; exists ts; split. 573 | Qed. 574 | Next Obligation. 575 | move=>x [rs][r][] h //= [[ts [->-> V]] H]. 576 | apply: [gE fset ts, r]=>//=. 577 | by do !split=>//=; exists ts; split. 578 | Qed. 579 | 580 | (*********) 581 | (* UNION *) 582 | (*********) 583 | 584 | (* Joins the equivalence classes of the two arguments *) 585 | 586 | Definition union_tp (x y : ptr) := STsep {rx ry m} 587 | (fun h => [/\ shape m h, (x, rx) \In m & (y, ry) \In m], 588 | [vfun res h => shape (mapv [fun v => v with rx |-> ry] m) h /\ 589 | res = ry]). 590 | 591 | Program Definition union (x y : ptr) : union_tp x y := 592 | Do (x_rt <-- find1 x; 593 | y_rt <-- find1 y; 594 | x_rt ::= y_rt;; 595 | ret y_rt). 596 | Next Obligation. 597 | move=>x y [a][b][_] [] _ /= [[ts [->-> Vh]] Hx Hy]. 598 | apply: [stepE fset ts, a]=>//=; first by do !split=>//; exists ts; split. 599 | move=>_ _ [[ts1] [-> Eq1 V1] ->]; rewrite Eq1 in Hy Hx {Vh}. 600 | apply: [stepE fset ts1, b]=>//=; first by split=>//; exists ts1; by do !split. 601 | move=>_ _ [[ts2] [-> Eq2 V2] ->]; rewrite Eq2 in Hy Hx {V1}. 602 | move/In_fsetP: (Hx) => /andP [V] /hasP [ta J] /andP [X /eqP rtA]. 603 | move/In_fsetP: (Hy) => /andP [_] /hasP [tb K] /andP [Y /eqP rtB]. 604 | have B: a \in ta by rewrite rtA rt_in. 605 | have C: b \in tb by rewrite rtB rt_in. 606 | have: has (fun t => a \in t) ts2 by apply/hasP; exists ta. 607 | rewrite -dom_flay //. 608 | case/In_domX=>_ /[dup] /In_find/find_flayTp [v] -> /In_find Da. 609 | move/flay_rt: (Da); move/In_range: (Hx)=>/mem_seqP U; rewrite ifT; last by []. 610 | move/eqP=>EqV; rewrite EqV in Da; clear EqV v. 611 | move/heap_eta2: (Da)=>Hts; rewrite Hts; do 2!step; move=>Hv. 612 | split=>//; exists (change_ts ts2 ta tb); split=>//=. 613 | (*CASE 1: a :-> b \+ free (flay ts) a = flay (change_ts ts ta tb) *) 614 | - rewrite /change_ts /=; case: eqP. 615 | - by move=>E; rewrite rtB -E -rtA. 616 | move=>N; rewrite flay_cons flay_tree tlayE /= big_cons tlayE /= -rtB. 617 | rewrite -rtA -!joinA joinCA; congr (_ \+ _); move:(V2). 618 | rewrite flayE (bigD1_seq ta) //=; last by apply: flay_uniq_ts. 619 | rewrite -big_filter (bigD1_seq tb) =>//=; last first. 620 | by rewrite filter_uniq //; apply: flay_uniq_ts. 621 | by rewrite mem_filter K andbT; case: eqP=>// E; rewrite E in N. 622 | rewrite tlayE -rtA -!joinA => Vh'. 623 | rewrite freePtUn // tlayE -rtB -joinCA -!joinA; congr (_ \+ _). 624 | rewrite joinCA; do 2!congr (_ \+ _); rewrite -big_filter -filter_predI. 625 | by rewrite seqext.filter_predIC big_filter //= flayE -big_filter. 626 | (*CASE 2: mapv [fun v => v with a |-> b] c = fset (change_ts ts ta tb) *) 627 | move: (V); rewrite Eq1 Eq2 !fsetE /change_ts; case: eqP. 628 | - move=>E; subst tb; rewrite rtA rtB -rtA (_ : fun_of_simpl _ = id). 629 | - by rewrite mapv_id. 630 | by apply: fext=>z /=; case: eqP. 631 | move=>N; rewrite big_cons tsetE /= -rtB big_cons (bigD1_seq ta) //=; last first. 632 | - by apply: flay_uniq_ts. 633 | simpl; rewrite -big_filter (bigD1_seq tb)=>//=; last first. 634 | - by rewrite filter_uniq //; apply: flay_uniq_ts. 635 | - by rewrite mem_filter K andbT; case: eqP N=>// ->. 636 | (*Case 2.1: mapv tset a = tset b *) 637 | rewrite -rtA -rtB big_filter_cond; move=>V'. 638 | move/validL: (V'); move/validR: (V'); move/[dup]=>/validL Vb /validR Vc Va. 639 | rewrite omapUn // change_tset // -!joinA joinCA; congr (_ \+ _). 640 | rewrite omapUn; last by rewrite (validX V'). 641 | (*Case 2.2: tset of bigger tree doesn't change *) 642 | rewrite nochange_mapv //; last first. 643 | rewrite range_tset // mem_seq1; case: eqP =>// eqAB. 644 | - have: ta = tb by rewrite -eqAB in C; rewrite (flay_mem_eq V2 B J C K). 645 | by move/eqP: N => /eqP eqF eqT; rewrite eqT in eqF. 646 | rewrite tsetE -rtB joinA big_filter //; congr (_ \+ _). 647 | (*Case 2.3: tset of trees different than a and b don't change *) 648 | apply: nochange_mapv =>//; apply/negP; move/mem_rangeX; case=>k H. 649 | case: (bigInXP H)=>j [/mem_seqP X1 /andP [X2 X3]]. 650 | move/mem_range; rewrite range_tset //; last by apply: valid_fset_tset X1. 651 | rewrite inE => /eqP X4; move/negP: X2; apply; apply/eqP. 652 | by apply: flay_mem_eq X1 B J=>//; rewrite X4 rt_in. 653 | Qed. 654 | 655 | (*********) 656 | (* Tests *) 657 | (*********) 658 | 659 | Program Definition test1: 660 | STsep (fun h => shape Unit h, 661 | [vfun y h => exists x, shape (x \\-> y \+ y \\-> y) h]) := 662 | Do (x <-- newT; 663 | y <-- newT; 664 | res <-- union x y; 665 | ret res). 666 | Next Obligation. 667 | case=>i H. 668 | apply: [stepE Unit]=>//= x j; rewrite unitR=>X. 669 | apply: [stepE x \\-> x]=>//= y k {X} /[dup]X [ts [A m V]]. 670 | rewrite A in V; move: (V); rewrite valid_flay_fset. 671 | move=> /andP [ V1 _] //; rewrite -m in V1. 672 | apply: [stepE x, y, y \\-> y \+ x \\-> x]=>//=. 673 | move=>a h [B ->]; step=>Vh; exists x; move: B. 674 | rewrite omapUn // nochange_mapv; first by rewrite omapPt //= ifT // joinC. 675 | - by apply: validX V1. 676 | rewrite rangePt //; apply/eqP=>N; rewrite N in X. 677 | by move/shapeV: X; rewrite invalidX. 678 | Qed. 679 | 680 | Program Definition test2 (x: ptr): 681 | STsep {y} (fun h => shape (x \\-> y \+ y \\-> y) h, 682 | [vfun res h => shape (x \\-> y \+ y \\-> y) h /\ res = y]) := 683 | Do (res <-- find1 x; 684 | ret res). 685 | Next Obligation. 686 | move=>a [b []] _ [ts][-> B C]. 687 | apply: [stepE fset ts, b]=>//=; last first. 688 | - by move=>p h [H ->]; step=>_; split=>//; rewrite B. 689 | move: (C); rewrite valid_flay_fset; move=>/andP [V1 _]. 690 | split=>//; first by exists ts; split. 691 | rewrite -B; apply: InL; first by rewrite B. 692 | by apply: In_condPt. 693 | Qed. 694 | -------------------------------------------------------------------------------- /htt/Make: -------------------------------------------------------------------------------- 1 | -Q . htt 2 | 3 | -arg -w -arg -notation-overridden 4 | -arg -w -arg -redundant-canonical-projection 5 | 6 | # release-specific arguments 7 | -arg -w -arg -notation-incompatible-prefix # specific to coq8.20.0 8 | -arg -w -arg -deprecated-from-Coq # specific to coq8.21 9 | -arg -w -arg -deprecated-dirpath-Coq # specific to coq8.21 10 | 11 | options.v 12 | domain.v 13 | model.v 14 | heapauto.v 15 | -------------------------------------------------------------------------------- /htt/Makefile: -------------------------------------------------------------------------------- 1 | # -*- Makefile -*- 2 | 3 | # setting variables 4 | COQPROJECT?=Make 5 | 6 | # Main Makefile 7 | include ../Makefile.common 8 | -------------------------------------------------------------------------------- /htt/dune: -------------------------------------------------------------------------------- 1 | ; This file was generated from `meta.yml`, please do not edit manually. 2 | 3 | (coq.theory 4 | (name htt) 5 | (package coq-htt-core) 6 | (synopsis "Hoare Type Theory") 7 | (flags :standard 8 | -w -notation-overridden 9 | -w -local-declaration 10 | -w -redundant-canonical-projection 11 | -w -projection-no-head-constant)) 12 | -------------------------------------------------------------------------------- /htt/options.v: -------------------------------------------------------------------------------- 1 | (* turn off the automation of Program *) 2 | #[export] Obligation Tactic := auto. 3 | (* turn off other Program extensions *) 4 | #[export] Unset Program Cases. 5 | (* commenting this out allows a bit more convenience *) 6 | (* when working with tuples, as one can pass a proof *) 7 | (* of a "wrong" fact, and Program would emit obligation *) 8 | (* that wrong fact equals the right fact. *) 9 | (* If left uncommented, the equality will have to be *) 10 | (* witnessed manually in the program *) 11 | (* #[export] Unset Program Generalized Coercion. *) 12 | #[export] Unset Program Mode. 13 | -------------------------------------------------------------------------------- /meta.yml: -------------------------------------------------------------------------------- 1 | fullname: Hoare Type Theory 2 | shortname: htt 3 | organization: imdea-software 4 | opam_name: coq-htt-core 5 | community: false 6 | action: true 7 | dune: true 8 | coqdoc: false 9 | 10 | synopsis: >- 11 | Hoare Type Theory 12 | description: |- 13 | Hoare Type Theory (HTT) is a verification system for reasoning about sequential heap-manipulating 14 | programs based on Separation logic. 15 | 16 | HTT incorporates Hoare-style specifications via preconditions and postconditions into types. A 17 | Hoare type `ST P (fun x : A => Q)` denotes computations with a precondition `P` and postcondition 18 | `Q`, returning a value `x` of type `A`. Hoare types are a dependently typed version of monads, 19 | as used in the programming language Haskell. Monads hygienically combine the language features 20 | for pure functional programming, with those for imperative programming, such as state or 21 | exceptions. In this sense, HTT establishes a formal connection in the style of Curry-Howard 22 | isomorphism between monads and (functional programming variant of) Separation logic. Every 23 | effectful command in HTT has a type that corresponds to the appropriate non-structural inference 24 | rule in Separation logic, and vice versa, every non-structural inference rule corresponds to a 25 | command in HTT that has that rule as the type. The type for monadic bind is the Hoare rule for 26 | sequential composition, and the type for monadic unit combines the Hoare rules for the idle 27 | program (in a small-footprint variant) and for variable assignment (adapted for functional 28 | variables). The connection reconciles dependent types with effects of state and exceptions and 29 | establishes Separation logic as a type theory for such effects. In implementation terms, it means 30 | that HTT implements Separation logic as a shallow embedding in Coq. 31 | 32 | build: |- 33 | ## Building and installation instructions 34 | 35 | The easiest way to install the latest released version of Hoare Type Theory 36 | is via [OPAM](https://opam.ocaml.org/doc/Install.html): 37 | 38 | ```shell 39 | opam repo add coq-released https://coq.inria.fr/opam/released 40 | opam install coq-htt 41 | ``` 42 | 43 | To instead build and install manually, do: 44 | 45 | ``` shell 46 | git clone https://github.com/imdea-software/htt.git 47 | cd htt 48 | dune build 49 | dune install htt 50 | ``` 51 | 52 | If you also want to build the examples, run `make` instead of `dune`. 53 | 54 | authors: 55 | - name: Aleksandar Nanevski 56 | initial: true 57 | - name: Germán Andrés Delbianco 58 | initial: false 59 | - name: Alexander Gryzlov 60 | initial: false 61 | - name: Marcos Grandury 62 | initial: false 63 | 64 | publications: 65 | - pub_url: https://software.imdea.org/~aleks/papers/reflect/reflect.pdf 66 | pub_title: Structuring the verification of heap-manipulating programs 67 | pub_doi: 10.1145/1706299.1706331 68 | 69 | maintainers: 70 | - name: Alexander Gryzlov 71 | nickname: clayrat 72 | 73 | opam-file-maintainer: fcsl@software.imdea.org 74 | 75 | opam-file-version: 2.1.0 76 | 77 | license: 78 | fullname: Apache-2.0 79 | identifier: Apache-2.0 80 | file: LICENSE 81 | 82 | supported_coq_versions: 83 | text: 8.19 or later 84 | opam: '{ (>= "8.19" & < "9.1~") | (= "dev") }' 85 | 86 | tested_coq_opam_versions: 87 | - version: '2.2.0-coq-8.19' 88 | repo: 'mathcomp/mathcomp' 89 | - version: '2.3.0-coq-8.20' 90 | repo: 'mathcomp/mathcomp' 91 | - version: '2.4.0-rocq-prover-9.0' 92 | repo: 'mathcomp/mathcomp' 93 | - version: 'rocq-prover-dev' 94 | repo: 'mathcomp/mathcomp-dev' 95 | 96 | 97 | dependencies: 98 | - opam: 99 | name: coq-hierarchy-builder 100 | version: '{ (>= "1.7.0" & < "1.10~") | (= "dev") }' 101 | description: |- 102 | [Hierarchy Builder 1.7.0 or later](https://github.com/math-comp/hierarchy-builder) 103 | - opam: 104 | name: coq-mathcomp-ssreflect 105 | version: '{ (>= "2.2.0" & < "2.5~") | (= "dev") }' 106 | description: |- 107 | [MathComp ssreflect 2.2 or later](https://math-comp.github.io) 108 | - opam: 109 | name: coq-mathcomp-algebra 110 | description: |- 111 | [MathComp algebra](https://math-comp.github.io) 112 | - opam: 113 | name: coq-mathcomp-fingroup 114 | description: |- 115 | [MathComp fingroup](https://math-comp.github.io) 116 | - opam: 117 | name: coq-fcsl-pcm 118 | version: '{ (>= "2.1.0" & < "2.2~") | (= "dev") }' 119 | description: |- 120 | [FCSL-PCM 2.1](https://github.com/imdea-software/fcsl-pcm) 121 | 122 | namespace: htt 123 | 124 | keywords: 125 | - name: partial commutative monoids 126 | - name: separation logic 127 | 128 | categories: 129 | - name: Computer Science/Data Types and Data Structures 130 | 131 | documentation: |- 132 | 133 | ## History 134 | 135 | The original version of HTT can be found [here](https://software.imdea.org/~aleks/htt/). 136 | 137 | ## References 138 | 139 | * [Dependent Type Theory of Stateful Higher-Order Functions](https://software.imdea.org/~aleks/papers/hoarelogic/depstate.pdf) 140 | 141 | Aleksandar Nanevski and Greg Morrisett. Technical report TR-24-05, Harvard University, 2005. 142 | 143 | * [Polymorphism and Separation in Hoare Type Theory](http://software.imdea.org/~aleks/htt/icfp06.pdf) 144 | 145 | Aleksandar Nanevski, Greg Morrisett and Lars Birkedal. ICFP 2006. 146 | 147 | The first paper containing a (very impoverished) definition of HTT. 148 | 149 | * [Hoare Type Theory, Polymorphism and Separation](http://software.imdea.org/~aleks/htt/jfpsep07.pdf) 150 | 151 | Aleksandar Nanevski, Greg Morrisett and Lars Birkedal. JFP 2007. 152 | 153 | Journal version of the ICFP 2006 paper. 154 | 155 | * [Abstract Predicates and Mutable ADTs in Hoare Type Theory](http://software.imdea.org/~aleks/htt/esop07.pdf) 156 | 157 | Aleksandar Nanevski, Amal Ahmed, Greg Morrisett, Lars Birkedal. ESOP 2007. 158 | 159 | Adding abstract predicates to HTT. 160 | 161 | * [A Realizability Model for Impredicative Hoare Type Theory](http://software.imdea.org/~aleks/htt/esop08.pdf) 162 | 163 | Rasmus L. Petersen, Lars Birkedal, Aleksandar Nanevski, Greg Morrisett. ESOP 2008. 164 | 165 | A semantic model for HTT, but without large sigma types. 166 | 167 | * [Ynot: Dependent Types for Imperative Programs](http://software.imdea.org/~aleks/htt/ynot08.pdf) 168 | 169 | Aleksandar Nanevski, Greg Morrisett, Avi Shinnar, Paul Govereau, Lars Birkedal. ICFP 2008. 170 | 171 | First implementation of HTT as a DSL in Coq, and a number of examples. 172 | 173 | * [Structuring the Verification of Heap-Manipulating Programs](http://software.imdea.org/~aleks/htt/reflect.pdf) 174 | 175 | Aleksandar Nanevski, Viktor Vafeiadis and Josh Berfine. POPL 2010. 176 | 177 | This paper introduces what is closest to the current structure of the implementation of HTT. 178 | It puts emphasis on structuring programs and proofs together, rather than on attacking the 179 | verification problem using proof automation. It carries out a large case study, verifying the 180 | congruence closure algorithm of the Barcelogic SAT solver. 181 | 182 | The current implementation differs from what's explained in this paper, in that it uses unary, 183 | rather than binary postconditions. 184 | 185 | * [Partiality, State and Dependent Types](http://software.imdea.org/~aleks/htt/tlca11.pdf) 186 | 187 | Kasper Svendsen, Lars Birkedal and Aleksandar Nanevski. TLCA 2011. 188 | 189 | A semantic model for HTT, with large sigma types. 190 | -------------------------------------------------------------------------------- /regenerate.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | TMP=$(mktemp -d); git clone https://github.com/coq-community/templates.git $TMP 4 | $TMP/generate.sh README.md coq-htt-core.opam dune-project 5 | 6 | echo "Proceeding with customized generation..." 7 | 8 | srcdir="templates-extra" 9 | 10 | get_yaml() { 11 | # Arg 1: the meta.yml path 12 | # STDIN: the mustache code 13 | local meta="$1" temp 14 | temp=$(mktemp template-XXX) 15 | cat > "$temp" 16 | mustache "$meta" "$temp" 17 | rm -f -- "$temp" 18 | } 19 | 20 | for f in "$srcdir"/*.mustache; do 21 | target=$(basename "$f" .mustache) 22 | case "$target" in 23 | dune) 24 | mustache='{{ dune }}' 25 | bool=$(get_yaml meta.yml <<<"$mustache") 26 | if [ -n "$bool" ] && [ "$bool" != false ]; then 27 | mkdir -p -v htt && target="htt/$target" 28 | else 29 | continue 30 | fi 31 | ;; 32 | docker-action.yml) 33 | mustache='{{ action }}' 34 | bool=$(get_yaml meta.yml <<<"$mustache") 35 | if [ -n "$bool" ] && [ "$bool" != false ]; then 36 | mkdir -p -v .github/workflows && target=".github/workflows/$target" 37 | else 38 | continue 39 | fi 40 | ;; 41 | esac 42 | listed=false 43 | for specified_target in "$@"; do 44 | if [ "$specified_target" == "$target" ]; then 45 | listed=true 46 | fi 47 | done 48 | if [ $# -gt 0 ] && [ $listed != true ]; then 49 | continue 50 | fi 51 | echo "Generating $target..." 52 | mustache meta.yml "$f" > "$target" 53 | done 54 | 55 | -------------------------------------------------------------------------------- /theories/dune: -------------------------------------------------------------------------------- 1 | ; This file was generated from `meta.yml`, please do not edit manually. 2 | ; Follow the instructions on https://github.com/coq-community/templates to regenerate. 3 | 4 | (coq.theory 5 | (name htt) 6 | (package coq-htt-core) 7 | (synopsis "Hoare Type Theory")) 8 | --------------------------------------------------------------------------------