├── MMaps ├── _CoqProject ├── MMaps.v ├── description ├── README.md ├── TODO.org ├── Makefile.conf ├── Utils.v ├── demo.v ├── Comparisons.v ├── Interface.v ├── Raw.v ├── RBTproofs.v ├── AVLproofs.v └── WeakList.v ├── .gitignore ├── _CoqProject ├── benchmark ├── Makefile ├── runbench.ml └── Runbench.v ├── Makefile ├── docs ├── coq2html.js └── coq2html.css ├── lib ├── PositiveOrder.v ├── String2pos.v ├── StringOrder.v └── AsciiOrder.v ├── LICENSE ├── README.md ├── Original.v ├── Node01.v ├── Sigma.v ├── GADT.v ├── CharTrie.v └── Patricia.v /MMaps/_CoqProject: -------------------------------------------------------------------------------- 1 | -R . MMaps 2 | Utils.v 3 | Comparisons.v 4 | Interface.v 5 | Facts.v 6 | Raw.v 7 | WeakList.v 8 | OrdList.v 9 | Positive.v 10 | GenTree.v 11 | AVL.v 12 | AVLproofs.v 13 | RBT.v 14 | RBTproofs.v 15 | MMaps.v 16 | demo.v 17 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Object files, in general 2 | *.vo 3 | *.vok 4 | *.vos 5 | *.glob 6 | *.o 7 | *.a 8 | *.cmi 9 | *.cmo 10 | *.cmx 11 | *.cma 12 | *.cmxa 13 | .*.aux 14 | *.cmti 15 | *.cmt 16 | # Emacs saves 17 | *~ 18 | # Executables 19 | *.exe 20 | # Other generated files 21 | CoqMakefile 22 | CoqMakefile.conf 23 | .CoqMakefile.d 24 | .lia.cache 25 | benchmark/benchmark.ml 26 | benchmark/benchmark.mli 27 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -R . Tries 2 | Original.v 3 | Canonical.v 4 | Sigma.v 5 | GADT.v 6 | Node01.v 7 | Patricia.v 8 | CharTrie.v 9 | lib/PositiveOrder.v 10 | lib/AsciiOrder.v 11 | lib/StringOrder.v 12 | lib/String2pos.v 13 | MMaps/Utils.v 14 | MMaps/Comparisons.v 15 | MMaps/Interface.v 16 | MMaps/Facts.v 17 | MMaps/Raw.v 18 | MMaps/WeakList.v 19 | MMaps/OrdList.v 20 | MMaps/GenTree.v 21 | MMaps/RBT.v 22 | benchmark/Benchmark.v 23 | -------------------------------------------------------------------------------- /MMaps/MMaps.v: -------------------------------------------------------------------------------- 1 | 2 | (** * Finite Modular Maps *) 3 | 4 | (** Author : Pierre Letouzey (Université de Paris - INRIA), 5 | adapted from earlier works in Coq Standard Library, see README.md. 6 | Licence : LGPL 2.1, see file LICENSE. *) 7 | 8 | From Coq Require Export Orders OrdersEx OrdersAlt Equalities. 9 | From Tries.MMaps Require Export Interface Facts WeakList OrdList Positive. 10 | From Tries.MMaps Require Export AVL RBT. 11 | -------------------------------------------------------------------------------- /benchmark/Makefile: -------------------------------------------------------------------------------- 1 | ALLBENCHS=$(foreach x,o c s n g p a r, $(foreach y,1 2 3, $(x)$(y))) \ 2 | as rs ct os cs ps 3 | 4 | runbench: runbench.exe 5 | for b in $(ALLBENCHS); do ./runbench.exe $$b; done 6 | 7 | MLFILES=benchmark.mli benchmark.ml runbench.ml 8 | 9 | runbench.exe: $(MLFILES) 10 | ocamlopt -o runbench.exe $(MLFILES) 11 | 12 | benchmark.ml: Benchmark.vo 13 | 14 | clean:: 15 | rm -f *.exe *.cm[iox] *.o 16 | rm -f benchmark.ml benchmark.mli 17 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: build 2 | 3 | CoqMakefile: _CoqProject 4 | coq_makefile -f _CoqProject -o CoqMakefile 5 | 6 | clean: 7 | $(MAKE) --no-print-directory -f CoqMakefile clean 8 | $(MAKE) -C benchmark clean 9 | rm -f CoqMakefile CoqMakefile.conf 10 | 11 | build: CoqMakefile 12 | @$(MAKE) --no-print-directory -f CoqMakefile 13 | 14 | coqbench: 15 | coqtop -R . Tries -R mmaps MMaps -batch -load-vernac-source benchmark/Runbench.v 16 | 17 | ocamlbench: 18 | @$(MAKE) --no-print-directory -C benchmark 19 | 20 | documentation: 21 | coq2html -base Tries -no-css -d docs *.glob *.v 22 | -------------------------------------------------------------------------------- /MMaps/description: -------------------------------------------------------------------------------- 1 | Name: MMaps 2 | Title: Finite Modular Maps over Ordered Types 3 | Author: Pierre Letouzey 4 | Institution: Université de Paris - INRIA 5 | Description: 6 | This contribution contains several implementations of finite maps over 7 | arbitrary ordered types using functors. This is an udpdated version of 8 | Coq Stdlib's FMaps. 9 | Keywords: Finite Sets, Sorted lists, Balanced trees, Red-black trees, AVL, 10 | Functors, data structures 11 | 12 | Category: Computer Science/Data Types and Data Structures 13 | Category: Miscellaneous/Extracted Programs/Data structures 14 | -------------------------------------------------------------------------------- /docs/coq2html.js: -------------------------------------------------------------------------------- 1 | 2 | function toggleDisplay(id) 3 | { 4 | var elt = document.getElementById(id); 5 | if (elt.style.display == 'none') { 6 | elt.style.display = 'block'; 7 | } else { 8 | elt.style.display = 'none'; 9 | } 10 | } 11 | 12 | function hideAll(cls) 13 | { 14 | var testClass = new RegExp("(^|s)" + cls + "(s|$)"); 15 | var tag = tag || "*"; 16 | var elements = document.getElementsByTagName("div"); 17 | var current; 18 | var length = elements.length; 19 | for(var i=0; i eq y x. 18 | Proof (@eq_sym t). 19 | Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. 20 | Proof (@eq_trans t). 21 | 22 | Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. 23 | Proof. unfold lt; lia. Qed. 24 | 25 | Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. 26 | Proof. 27 | unfold lt, eq; lia. 28 | Qed. 29 | 30 | Definition compare (x y : t) : Compare lt eq x y. 31 | Proof. 32 | destruct (Pos.compare x y) eqn:C. 33 | - apply EQ. apply Pos.compare_eq; auto. 34 | - apply LT. apply Pos.compare_lt_iff; auto. 35 | - apply GT. apply Pos.compare_nle_iff in C. red; lia. 36 | Defined. 37 | 38 | Definition eq_dec (x y : t) : {x = y} + {x <> y} := Pos.eq_dec x y. 39 | 40 | End OrderedPositive. 41 | 42 | -------------------------------------------------------------------------------- /lib/String2pos.v: -------------------------------------------------------------------------------- 1 | (** Convert strings to positive numbers. 2 | The encoding used is the trivial one (8 bits per character). *) 3 | 4 | From Coq Require Import String Ascii ZArith Extraction. 5 | 6 | Definition bool_cons_pos (b: bool) (n: positive) : positive := 7 | if b then xI n else xO n. 8 | 9 | Definition ascii_cons_pos (c: ascii) (n: positive) : positive := 10 | match c with 11 | | Ascii b0 b1 b2 b3 b4 b5 b6 b7 => 12 | bool_cons_pos b0 ( 13 | bool_cons_pos b1 ( 14 | bool_cons_pos b2 ( 15 | bool_cons_pos b3 ( 16 | bool_cons_pos b4 ( 17 | bool_cons_pos b5 ( 18 | bool_cons_pos b6 ( 19 | bool_cons_pos b7 n))))))) 20 | end. 21 | 22 | Extract Constant ascii_cons_pos => 23 | "(fun c n -> 24 | let c = Char.code c in 25 | let n1 = if c land 1 = 0 then XO n else XI n in 26 | let n2 = if c land 2 = 0 then XO n1 else XI n1 in 27 | let n3 = if c land 4 = 0 then XO n2 else XI n2 in 28 | let n4 = if c land 8 = 0 then XO n3 else XI n3 in 29 | let n5 = if c land 16 = 0 then XO n4 else XI n4 in 30 | let n6 = if c land 32 = 0 then XO n5 else XI n5 in 31 | let n7 = if c land 64 = 0 then XO n6 else XI n6 in 32 | if c land 128 = 0 then XO n7 else XI n7)". 33 | 34 | Fixpoint pos_of_string (s: string) : positive := 35 | match s with 36 | | EmptyString => xH 37 | | String c s => ascii_cons_pos c (pos_of_string s) 38 | end. 39 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2021, Andrew W. Appel and Institut National de Recherche en Informatique et en Automatique (Inria). 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Canonical Binary Trees, the Coq development 2 | 3 | This is the Coq development accompanying the paper [*Efficient Extensional Binary Trees*](https://hal.inria.fr/hal-03372247) by Andrew W. Appel and Xavier Leroy, 2021-2022. 4 | 5 | ## Implementations of binary tries (finite maps indexed by positive numbers) 6 | 7 | * [Canonical.v](https://xavierleroy.org/canonical-binary-tries/Tries.Canonical.html): the new, extensional implementation of binary tries, using a canonical first-order representation. 8 | * [Original.v](https://xavierleroy.org/canonical-binary-tries/Tries.Original.html): the simple, non-extensional implementation of binary tries used in CompCert 3.9 and earlier. 9 | * [Node01.v](https://xavierleroy.org/canonical-binary-tries/Tries.Node01.html): a minor variant of the Original implementation, slightly more compact but still not extensional, used mostly for benchmarking. 10 | * [Sigma.v](https://xavierleroy.org/canonical-binary-tries/Tries.Sigma.html): an extensional but not very efficient implementation of binary tries obtained by wrapping the Original implementation in a sigma-type. 11 | * [GADT.v](https://xavierleroy.org/canonical-binary-tries/Tries.GADT.html): another extensional but not very efficient implementation of binary tries that uses GADTs and dependent types. 12 | * [Patricia.v](https://xavierleroy.org/canonical-binary-tries/Tries.Patricia.html): binary Patricia trees from section 12.3 of [_Functional algorithms, verified!_](https://functional-algorithms-verified.org/) by T. Nipkow et al. About as efficient as the Canonical implementation but not extensional. 13 | 14 | ## Implementations of dictionaries (finite maps indexed by character strings) 15 | 16 | * [CharTrie.v](https://xavierleroy.org/canonical-binary-tries/Tries.CharTrie.html): a trie data structure with sparse, 256-degree nodes that branch on the next character of the string. 17 | 18 | ## Benchmarking 19 | 20 | Do `make coqbench` to measure the execution speed within Coq. 21 | 22 | Do `make ocamlbench` to measure execution speed after extraction to OCaml. 23 | 24 | See the paper for a description and analysis of the benchmarks. 25 | -------------------------------------------------------------------------------- /docs/coq2html.css: -------------------------------------------------------------------------------- 1 | 2 | /* Classes: 3 | h1.title the title of the page 4 | div.coq encloses all generated body 5 | div.doc contents of (** *) comments 6 | div.footer footer 7 | div.togglescript "Proof." line 8 | div.proofscript contents of proof script 9 | span.docright contents of (**r *) comments 10 | span.bracket contents of [ ] within comments 11 | span.comment contents of (* *) comments 12 | span.kwd Coq keyword 13 | span.tactic Coq tactic 14 | span.id any other identifier 15 | */ 16 | 17 | body { 18 | color: black; 19 | background: white; 20 | } 21 | 22 | h1.title { 23 | font-size: 2em; 24 | text-align: center 25 | } 26 | 27 | h1 { 28 | font-size: 1.5em; 29 | } 30 | h2 { 31 | font-size: 1.17em; 32 | } 33 | h3 { 34 | font-size: 1em; 35 | } 36 | 37 | h1, h2, h3 { 38 | font-family: sans-serif; 39 | margin-left: -5%; 40 | } 41 | 42 | div.coq { 43 | margin-left: 15%; 44 | margin-right: 5%; 45 | font-family: monospace, DejaVu Sans; 46 | } 47 | 48 | div.doc { 49 | margin-left: -5%; 50 | margin-top: 0.2em; 51 | margin-bottom: 0.5em; 52 | font-family: serif; 53 | } 54 | 55 | div.toggleproof { 56 | font-size: 0.8em; 57 | text-decoration: underline; 58 | } 59 | 60 | div.toggleproof:hover { 61 | cursor: pointer; 62 | } 63 | 64 | div.proofscript { 65 | font-size: 0.8em; 66 | } 67 | 68 | div.footer { 69 | margin-top: 1em; 70 | margin-bottom: 1em; 71 | font-size: 0.8em; 72 | font-style: italic; 73 | } 74 | 75 | span.docright { 76 | position: absolute; 77 | left: 50%; 78 | width: 50%; 79 | font-family: serif; 80 | } 81 | 82 | span.bracket { 83 | font-family: monospace; 84 | color: #008000; 85 | } 86 | 87 | span.kwd { 88 | color: #cf1d1d; 89 | } 90 | 91 | span.comment { 92 | color: #008000; 93 | } 94 | 95 | div.doc pre { 96 | color: Maroon; 97 | } 98 | 99 | a:visited {color : #416DFF; text-decoration : none; } 100 | a:link {color : #416DFF; text-decoration : none; } 101 | a:hover {text-decoration : none; } 102 | a:active {text-decoration : none; } 103 | -------------------------------------------------------------------------------- /MMaps/TODO.org: -------------------------------------------------------------------------------- 1 | 2 | * TODO opam package, see : 3 | ** https://coq.inria.fr/opam-packaging.html 4 | ** https://github.com/coq-community/manifesto 5 | 6 | * TODO extra ops 7 | ** DONE filter + partition + for_all + exists 8 | ** DONE singleton 9 | ** split ? 10 | ** min_binding, max_binding, choose ? 11 | ** remove_min, remove_max ? 12 | ** update (The one of OCaml, mixing find + add/remove) 13 | ** gmerge (as already in AVL) ? unsure 14 | ** mapo (from AVL and RBT) ? 15 | ** common merge instance, such as diff, inter, union ? Cf Facts 16 | ** of_list = fold add, of_sorted_list (cf treeify in RBT) ? 17 | 18 | * DONE add_cardinal_2 (cf PR Coq) 19 | ** DONE SameKeys another equivalence on maps (on keys only) --> here named Eqdom 20 | 21 | * DONE short filenames (MMap.Interface au lieu de MMapInterface) 22 | 23 | * TODO improve demo.v 24 | ** DONE Why ZM.Raw.key appears in Print map3 : "Definition key" was too early in Raw.Pack 25 | ** TODO do we want ZM.key or Z ? How to choose ? Weird : R.key becomes Z, not ZM.key ?! 26 | ** TODO R.empty without implicit elt ? 27 | ** TODO type of Mkt ? 28 | ** TODO test demo.v and Coq 8.11 29 | ** TODO avoid printing message during compilation ? 30 | 31 | * TODO Maps on unit + Eqdom --> an MSets implementation 32 | ** Issue : compare on sets ? 33 | 34 | * DONE : dilute Sord inside S, with a compare taking a elt_compare as argument ? 35 | ** DONE improve generic implem in AVL, RBT 36 | ** DONE improve generic implem in Positive 37 | ** DONE args order in equal_spec vs. compare_spec 38 | ** DONE facts : from compare_spec to compare_sym, compare_trans, StrictOrder, etc 39 | ** DONE Maps as OrderedTypes ? 40 | 41 | * TODO fix weird specs like merge_spec1 (?) 42 | 43 | * TODO unified spec of add and remove based on some key_eqb (cf. add_o) ? 44 | ** Not ideal since DecidableType K have K.eq_dec, not K.eqb 45 | 46 | * TODO AVL.gmerge could start by comparing height (better have the little map on the right) 47 | 48 | * TODO RBT could have ins_below, join, split, and merge via split+join ? 49 | ** check complexity in this case ? 50 | 51 | * DONE module AVLproofs with AVL invariant proofs 52 | * DONE module RBTproofs with RedBlack invariant proofs 53 | 54 | * DONE Interface Raw and module Raw.Pack 55 | ** Btw : why no need for apply ok in Raw.Pack.bindings_spec2 ??!! 56 | 57 | * TODO provide a MultiSets.v (and update it), cf Fset contrib 58 | 59 | * TODO document the expected complexities 60 | 61 | * TODO test extraction 62 | 63 | * DONE Reorganisation GenTree 64 | ** DONE better name for the T module 65 | ** DONE put MapsTo just after, instead of at the very end of (AVL/RBT).MakeRaw 66 | ** DONE directly use In0 instead of two version (inductive vs exists) ? 67 | 68 | * DONE warnings in Coq 8.11 69 | ** DONE Hints not in core 70 | 71 | #+STARTUP: showall 72 | -------------------------------------------------------------------------------- /MMaps/Makefile.conf: -------------------------------------------------------------------------------- 1 | # This configuration file was generated by running: 2 | # coq_makefile -f _CoqProject -o Makefile 3 | 4 | 5 | ############################################################################### 6 | # # 7 | # Project files. # 8 | # # 9 | ############################################################################### 10 | 11 | COQMF_VFILES = Utils.v Comparisons.v Interface.v Facts.v Raw.v WeakList.v OrdList.v Positive.v GenTree.v AVL.v AVLproofs.v RBT.v RBTproofs.v MMaps.v demo.v 12 | COQMF_MLIFILES = 13 | COQMF_MLFILES = 14 | COQMF_MLGFILES = 15 | COQMF_MLPACKFILES = 16 | COQMF_MLLIBFILES = 17 | COQMF_CMDLINE_VFILES = 18 | 19 | ############################################################################### 20 | # # 21 | # Path directives (-I, -R, -Q). # 22 | # # 23 | ############################################################################### 24 | 25 | COQMF_OCAMLLIBS = 26 | COQMF_SRC_SUBDIRS = 27 | COQMF_COQLIBS = -R . MMaps 28 | COQMF_COQLIBS_NOML = -R . MMaps 29 | COQMF_CMDLINE_COQLIBS = 30 | 31 | ############################################################################### 32 | # # 33 | # Coq configuration. # 34 | # # 35 | ############################################################################### 36 | 37 | COQMF_LOCAL=0 38 | COQMF_COQLIB=/home/estephe/xleroy/opam/4.12.0/lib/coq/ 39 | COQMF_DOCDIR=/home/estephe/xleroy/opam/4.12.0/doc/ 40 | COQMF_OCAMLFIND=/home/estephe/xleroy/opam/4.12.0/bin/ocamlfind 41 | COQMF_CAMLFLAGS=-thread -rectypes -w +a-4-9-27-41-42-44-45-48-58-67 -safe-string -strict-sequence 42 | COQMF_WARN=-warn-error +a-3 43 | COQMF_HASNATDYNLINK=true 44 | COQMF_COQ_SRC_SUBDIRS=config lib clib kernel library engine pretyping interp gramlib gramlib/.pack parsing proofs tactics toplevel printing ide stm vernac plugins/btauto plugins/cc plugins/derive plugins/extraction plugins/firstorder plugins/funind plugins/ltac plugins/micromega plugins/nsatz plugins/omega plugins/ring plugins/rtauto plugins/ssr plugins/ssrmatching plugins/ssrsearch plugins/syntax 45 | COQMF_COQ_NATIVE_COMPILER_DEFAULT=no 46 | COQMF_WINDRIVE= 47 | 48 | ############################################################################### 49 | # # 50 | # Extra variables. # 51 | # # 52 | ############################################################################### 53 | 54 | COQMF_OTHERFLAGS = 55 | COQMF_INSTALLCOQDOCROOT = MMaps 56 | -------------------------------------------------------------------------------- /benchmark/runbench.ml: -------------------------------------------------------------------------------- 1 | open Benchmark 2 | 3 | let time msg fn sz arg nrep = 4 | Gc.compact(); 5 | let start_alloc = Gc.allocated_bytes() in 6 | let start_time = Sys.time () in 7 | for _i = 1 to nrep do ignore (fn arg) done; 8 | let stop_time = Sys.time () in 9 | let stop_alloc = Gc.allocated_bytes() in 10 | let size = Obj.reachable_words (Obj.repr (sz arg)) * (Sys.word_size / 8) in 11 | Printf.printf "%.2e s %.2e b %.2e b %s\n%!" 12 | ((stop_time -. start_time) /. float nrep) 13 | ((stop_alloc -. start_alloc) /. float nrep) 14 | (float size) 15 | msg 16 | 17 | let nosize x = () 18 | 19 | let _ = 20 | let nrep = 21 | if Array.length Sys.argv > 2 then int_of_string Sys.argv.(2) else 500 in 22 | match Sys.argv.(1) with 23 | | "o1" -> 24 | time "Original (words)" TestOriginal.bench1 TestOriginal.dsize poswords nrep 25 | | "o2" -> 26 | time "Original (small numbers)" TestOriginal.bench1 TestOriginal.dsize smallnumbers (nrep * 10) 27 | | "o3" -> 28 | time "Original (repeated keys)" TestOriginal.bench2 nosize () nrep 29 | | "c1" -> 30 | time "Canonical (words)" TestCanonical.bench1 TestCanonical.dsize poswords nrep 31 | | "c2" -> 32 | time "Canonical (small numbers)" TestCanonical.bench1 TestCanonical.dsize smallnumbers (nrep * 10) 33 | | "c3" -> 34 | time "Canonical (repeated keys)" TestCanonical.bench2 nosize () nrep 35 | | "s1" -> 36 | time "Sigma (words)" TestSigma.bench1 TestSigma.dsize poswords nrep 37 | | "s2" -> 38 | time "Sigma (small numbers)" TestSigma.bench1 TestSigma.dsize smallnumbers (nrep * 10) 39 | | "s3" -> 40 | time "Sigma (repeated keys)" TestSigma.bench2 nosize () nrep 41 | | "n1" -> 42 | time "Node01 (words)" TestNode01.bench1 TestNode01.dsize poswords nrep 43 | | "n2" -> 44 | time "Node01 (small numbers)" TestNode01.bench1 TestNode01.dsize smallnumbers (nrep * 10) 45 | | "n3" -> 46 | time "Node01 (repeated keys)" TestNode01.bench2 nosize () nrep 47 | | "g1" -> 48 | time "GADT (words)" TestGADT.bench1 TestGADT.dsize poswords nrep 49 | | "g2" -> 50 | time "GADT (small numbers)" TestGADT.bench1 TestGADT.dsize smallnumbers (nrep * 10) 51 | | "g3" -> 52 | time "GADT (repeated keys)" TestGADT.bench2 nosize () nrep 53 | | "p1" -> 54 | time "Patricia (words)" TestPatricia.bench1 TestPatricia.dsize poswords nrep 55 | | "p2" -> 56 | time "Patricia (small numbers)" TestPatricia.bench1 TestPatricia.dsize smallnumbers (nrep * 10) 57 | | "p3" -> 58 | time "Patricia (repeated keys)" TestPatricia.bench2 nosize () nrep 59 | | "a1" -> 60 | time "AVLPositive (words)" TestAVLPositive.bench1 TestAVLPositive.dsize poswords nrep 61 | | "a2" -> 62 | time "AVLPositive (small numbers)" TestAVLPositive.bench1 TestAVLPositive.dsize smallnumbers (nrep * 10) 63 | | "a3" -> 64 | time "AVLPositive (repeated keys)" TestAVLPositive.bench2 nosize () (nrep / 10) 65 | | "as" -> 66 | time "AVLString (words)" TestAVLString.bench1 TestAVLString.dsize words nrep 67 | | "r1" -> 68 | time "RBPositive (words)" TestRBPositive.bench1 TestRBPositive.dsize poswords nrep 69 | | "r2" -> 70 | time "RBPositive (small numbers)" TestRBPositive.bench1 TestRBPositive.dsize smallnumbers (nrep * 10) 71 | | "r3" -> 72 | time "RBPositive (repeated keys)" TestRBPositive.bench2 nosize () (nrep / 10) 73 | | "rs" -> 74 | time "RBString (words)" TestRBString.bench1 TestRBString.dsize words nrep 75 | | "ct" -> 76 | time "CharTrie (words)" TestCharTrie.bench1 TestCharTrie.dsize words nrep 77 | | "os" -> 78 | time "Originalstring (words)" TestOriginalAsStringmap.bench1 TestOriginalAsStringmap.dsize words nrep 79 | | "cs" -> 80 | time "Canonicalstring (words)" TestCanonicalAsStringmap.bench1 TestCanonicalAsStringmap.dsize words nrep 81 | | "ps" -> 82 | time "Patriciastring (words)" TestPatriciaAsStringmap.bench1 TestPatriciaAsStringmap.dsize words nrep 83 | | s -> 84 | prerr_endline ("unknown test: " ^ s); exit 2 85 | 86 | -------------------------------------------------------------------------------- /lib/StringOrder.v: -------------------------------------------------------------------------------- 1 | (** * Ordering strings *) 2 | 3 | From Coq Require Import Ascii String Orders OrderedType. 4 | From Tries Require Import AsciiOrder. 5 | 6 | Fixpoint string_compare (x y: string) : comparison := 7 | match x, y with 8 | | EmptyString, EmptyString => Eq 9 | | EmptyString, String _ _ => Lt 10 | | String _ _, EmptyString => Gt 11 | | String x1 xs, String y1 ys => 12 | match ascii_compare x1 y1 with 13 | | Eq => string_compare xs ys 14 | | Lt => Lt 15 | | Gt => Gt 16 | end 17 | end. 18 | 19 | Lemma string_compare_refl: 20 | forall x, string_compare x x = Eq. 21 | Proof. 22 | induction x; simpl. auto. rewrite ascii_compare_refl. auto. 23 | Qed. 24 | 25 | Lemma string_compare_eq: 26 | forall x y, string_compare x y = Eq -> x = y. 27 | Proof. 28 | induction x; destruct y; simpl; intros. 29 | - auto. 30 | - discriminate. 31 | - discriminate. 32 | - destruct (ascii_compare a a0) eqn:E; try discriminate. 33 | apply ascii_compare_eq in E. apply IHx in H. congruence. 34 | Qed. 35 | 36 | Lemma string_compare_lt_trans: 37 | forall x y z, string_compare x y = Lt -> string_compare y z = Lt -> string_compare x z = Lt. 38 | Proof. 39 | induction x; destruct y, z; simpl; intros; try congruence. 40 | destruct (ascii_compare a a0) eqn:C1; try discriminate. 41 | - apply ascii_compare_eq in C1; subst a0. 42 | destruct (ascii_compare a a1); eauto. 43 | - destruct (ascii_compare a0 a1) eqn:C2; try discriminate. 44 | + apply ascii_compare_eq in C2; subst a0. rewrite C1. auto. 45 | + erewrite ascii_compare_lt_trans by eauto. auto. 46 | Qed. 47 | 48 | Lemma string_compare_antisym: 49 | forall x y, CompOpp (string_compare x y) = string_compare y x. 50 | Proof. 51 | induction x; destruct y; simpl; auto. 52 | rewrite <- (ascii_compare_antisym a0 a). 53 | destruct (ascii_compare a0 a); simpl; auto. 54 | Qed. 55 | 56 | (** Implementing the old [OrderedType] interface (for use with FSets and FMaps) *) 57 | 58 | Module OrderedString <: OrderedType. 59 | 60 | Definition t := string. 61 | Definition eq (x y: t) := x = y. 62 | Definition lt (x y: t) := string_compare x y = Lt. 63 | 64 | Lemma eq_refl : forall x : t, eq x x. 65 | Proof (@eq_refl t). 66 | Lemma eq_sym : forall x y : t, eq x y -> eq y x. 67 | Proof (@eq_sym t). 68 | Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. 69 | Proof (@eq_trans t). 70 | 71 | Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. 72 | Proof string_compare_lt_trans. 73 | 74 | Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. 75 | Proof. 76 | unfold lt, eq; intros; red; intros. subst y. 77 | rewrite string_compare_refl in H. discriminate. 78 | Qed. 79 | 80 | Definition compare (x y : t) : Compare lt eq x y. 81 | Proof. 82 | destruct (string_compare x y) eqn:AC. 83 | - apply EQ. apply string_compare_eq; auto. 84 | - apply LT. assumption. 85 | - apply GT. red. rewrite <- string_compare_antisym. rewrite AC; auto. 86 | Defined. 87 | 88 | Definition eq_dec (x y : t) : {x = y} + {x <> y}. 89 | Proof. 90 | destruct (string_compare x y) eqn:AC. 91 | - left. apply string_compare_eq; auto. 92 | - right; red; intros; subst y. rewrite string_compare_refl in AC; discriminate. 93 | - right; red; intros; subst y. rewrite string_compare_refl in AC; discriminate. 94 | Defined. 95 | 96 | End OrderedString. 97 | 98 | (** Implementing the new [OrderedType] interface (for use with MSets and MMaps) *) 99 | 100 | Module OrderedStringM <: Orders.OrderedType. 101 | 102 | Definition t := string. 103 | Definition eq := @eq string. 104 | Definition eq_equiv : Equivalence eq := eq_equivalence. 105 | Definition lt (x y: t) := string_compare x y = Lt. 106 | Lemma lt_strorder : StrictOrder lt. 107 | Proof. 108 | constructor. 109 | - intro x. hnf. unfold lt. rewrite string_compare_refl. congruence. 110 | - exact string_compare_lt_trans. 111 | Qed. 112 | Lemma lt_compat : Proper (eq ==> eq ==> iff) lt. 113 | Proof. 114 | constructor; unfold eq in *; congruence. 115 | Qed. 116 | Definition compare := string_compare. 117 | Lemma compare_spec : 118 | forall x y : t, CompareSpec (eq x y) (lt x y) (lt y x) (compare x y). 119 | Proof. 120 | intros. unfold eq, lt, compare. destruct (string_compare x y) eqn:E; constructor. 121 | - apply string_compare_eq; auto. 122 | - auto. 123 | - rewrite <- (string_compare_antisym x y), E. auto. 124 | Qed. 125 | Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. 126 | Proof. 127 | intros. unfold eq. destruct (string_compare x y) eqn:AC. 128 | - left. apply string_compare_eq; auto. 129 | - right; red; intros; subst y. rewrite string_compare_refl in AC; discriminate. 130 | - right; red; intros; subst y. rewrite string_compare_refl in AC; discriminate. 131 | Defined. 132 | 133 | End OrderedStringM. 134 | 135 | Require Import Extraction ExtrOcamlBasic ExtrOcamlString. 136 | 137 | Extract Constant ascii_compare => 138 | "fun (c1: char) (c2: char) -> if c1 = c2 then Eq else if c1 < c2 then Lt else Gt". 139 | -------------------------------------------------------------------------------- /benchmark/Runbench.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import String. 2 | From Tries Require Import Benchmark. 3 | 4 | Local Open Scope string_scope. 5 | 6 | Compute "AVLpositive (words, x100)". 7 | Time Eval vm_compute in (repeat 100 TestAVLPositive.bench1 poswords). 8 | Compute "AVLpositive (small numbers, x1000)". 9 | Time Eval vm_compute in (repeat 1000 TestAVLPositive.bench1 smallnumbers). 10 | Compute "AVLpositive (small numbers, cbv, x100)". 11 | Time Eval cbv in (repeat 100 TestAVLPositive.bench1 smallnumbers). 12 | Compute "AVLpositive (small numbers, lazy, x100)". 13 | Time Eval lazy in (repeat 100 TestAVLPositive.bench1 smallnumbers). 14 | Compute "AVLpositive (repeated keys, x10)". 15 | Time Eval vm_compute in (repeat 10 TestAVLPositive.bench2 tt). 16 | 17 | Compute "RBpositive (words, x100)". 18 | Time Eval vm_compute in (repeat 100 TestRBPositive.bench1 poswords). 19 | Compute "RBpositive (small numbers, x1000)". 20 | Time Eval vm_compute in (repeat 1000 TestRBPositive.bench1 smallnumbers). 21 | Compute "RBpositive (small numbers, cbv, x100)". 22 | Time Eval cbv in (repeat 100 TestRBPositive.bench1 smallnumbers). 23 | Compute "RBpositive (small numbers, lazy, x100)". 24 | Time Eval lazy in (repeat 100 TestRBPositive.bench1 smallnumbers). 25 | Compute "RBpositive (repeated keys, x10)". 26 | Time Eval vm_compute in (repeat 10 TestRBPositive.bench2 tt). 27 | 28 | Compute "Original (words, x100)". 29 | Time Eval vm_compute in (repeat 100 TestOriginal.bench1 poswords). 30 | Compute "Original (small numbers, x1000)". 31 | Time Eval vm_compute in (repeat 1000 TestOriginal.bench1 smallnumbers). 32 | Compute "Original (small numbers, cbv, x100)". 33 | Time Eval cbv in (repeat 100 TestOriginal.bench1 smallnumbers). 34 | Compute "Original (small numbers, lazy, x100)". 35 | Time Eval lazy in (repeat 100 TestOriginal.bench1 smallnumbers). 36 | Compute "Original (repeated keys, x10)". 37 | Time Eval vm_compute in (repeat 10 TestOriginal.bench2 tt). 38 | 39 | Compute "Canonical (words, x100)". 40 | Time Eval vm_compute in (repeat 100 TestCanonical.bench1 poswords). 41 | Compute "Canonical (small numbers, x1000)". 42 | Time Eval vm_compute in (repeat 1000 TestCanonical.bench1 smallnumbers). 43 | Compute "Canonical (small numbers, cbv, x100)". 44 | Time Eval cbv in (repeat 100 TestCanonical.bench1 smallnumbers). 45 | Compute "Canonical (small numbers, lazy, x100)". 46 | Time Eval lazy in (repeat 100 TestCanonical.bench1 smallnumbers). 47 | Compute "Canonical (repeated keys, x10)". 48 | Time Eval vm_compute in (repeat 10 TestCanonical.bench2 tt). 49 | 50 | Compute "Sigma (words, x100)". 51 | Time Eval vm_compute in (repeat 100 TestSigma.bench1 poswords). 52 | Compute "Sigma (small numbers, x1000)". 53 | Time Eval vm_compute in (repeat 1000 TestSigma.bench1 smallnumbers). 54 | Compute "Sigma (small numbers, cbv, x100)". 55 | Time Eval cbv in (repeat 100 TestSigma.bench1 smallnumbers). 56 | Compute "Sigma (small numbers, lazy, x100)". 57 | Time Eval lazy in (repeat 100 TestSigma.bench1 smallnumbers). 58 | Compute "Sigma (repeated keys, x10)". 59 | Time Eval vm_compute in (repeat 10 TestSigma.bench2 tt). 60 | 61 | Compute "Node01 (words, x100)". 62 | Time Eval vm_compute in (repeat 100 TestNode01.bench1 poswords). 63 | Compute "Node01 (small numbers, x1000)". 64 | Time Eval vm_compute in (repeat 1000 TestNode01.bench1 smallnumbers). 65 | Compute "Node01 (small numbers, cbv, x100)". 66 | Time Eval cbv in (repeat 100 TestNode01.bench1 smallnumbers). 67 | Compute "Node01 (small numbers, lazy, x100)". 68 | Time Eval lazy in (repeat 100 TestNode01.bench1 smallnumbers). 69 | Compute "Node01 (repeated keys, x10)". 70 | Time Eval vm_compute in (repeat 10 TestNode01.bench2 tt). 71 | 72 | Compute "GADT (words, x100)". 73 | Time Eval vm_compute in (repeat 100 TestGADT.bench1 poswords). 74 | Compute "GADT (small numbers, x1000)". 75 | Time Eval vm_compute in (repeat 1000 TestGADT.bench1 smallnumbers). 76 | Compute "GADT (small numbers, cbv, x100)". 77 | Time Eval cbv in (repeat 100 TestGADT.bench1 smallnumbers). 78 | Compute "GADT (small numbers, lazy, x100)". 79 | Time Eval lazy in (repeat 100 TestGADT.bench1 smallnumbers). 80 | Compute "GADT (repeated keys, x10)". 81 | Time Eval vm_compute in (repeat 10 TestGADT.bench2 tt). 82 | 83 | Compute "Patricia (words, x100)". 84 | Time Eval vm_compute in (repeat 100 TestPatricia.bench1 poswords). 85 | Compute "Patricia (small numbers, x1000)". 86 | Time Eval vm_compute in (repeat 1000 TestPatricia.bench1 smallnumbers). 87 | Compute "Patricia (small numbers, cbv, x100)". 88 | Time Eval cbv in (repeat 100 TestPatricia.bench1 smallnumbers). 89 | Compute "Patricia (small numbers, lazy, x100)". 90 | Time Eval lazy in (repeat 100 TestPatricia.bench1 smallnumbers). 91 | Compute "Patricia (repeated keys, x10)". 92 | Time Eval vm_compute in (repeat 10 TestPatricia.bench2 tt). 93 | 94 | Compute "AVLstring (words, x100)". 95 | Time Eval vm_compute in (repeat 100 TestAVLString.bench1 words). 96 | 97 | Compute "RBstring (words, x100)". 98 | Time Eval vm_compute in (repeat 100 TestRBString.bench1 words). 99 | 100 | Compute "CharTrie (words, x100)". 101 | Time Eval vm_compute in (repeat 100 TestCharTrie.bench1 words). 102 | 103 | Compute "Originalstring (words, x100)". 104 | Time Eval vm_compute in (repeat 100 TestOriginalAsStringmap.bench1 words). 105 | 106 | Compute "Canonicalstring (words, x100)". 107 | Time Eval vm_compute in (repeat 100 TestCanonicalAsStringmap.bench1 words). 108 | 109 | Compute "Patriciastring (words, x100)". 110 | Time Eval vm_compute in (repeat 100 TestPatriciaAsStringmap.bench1 words). 111 | -------------------------------------------------------------------------------- /lib/AsciiOrder.v: -------------------------------------------------------------------------------- 1 | (** * Ordering characters *) 2 | 3 | From Coq Require Import Ascii Orders OrderedType. 4 | 5 | 6 | Definition bool_compare_cont (b1 b2: bool) (k: comparison) : comparison := 7 | match b1, b2 with 8 | | false, true => Lt 9 | | true, false => Gt 10 | | _, _ => k 11 | end. 12 | 13 | Definition ascii_compare (x y: ascii) : comparison := 14 | match x, y with 15 | | Ascii x1 x2 x3 x4 x5 x6 x7 x8, Ascii y1 y2 y3 y4 y5 y6 y7 y8 => 16 | bool_compare_cont x8 y8 ( 17 | bool_compare_cont x7 y7 ( 18 | bool_compare_cont x6 y6 ( 19 | bool_compare_cont x5 y5 ( 20 | bool_compare_cont x4 y4 ( 21 | bool_compare_cont x3 y3 ( 22 | bool_compare_cont x2 y2 ( 23 | bool_compare_cont x1 y1 Eq))))))) 24 | end. 25 | 26 | (** Alternate presentation, using recursion over bitvectors. *) 27 | 28 | Fixpoint bitvect (n: nat) : Type := 29 | match n with O => bool | S n => (bitvect n * bool)%type end. 30 | 31 | Fixpoint bitvect_compare (n: nat) : bitvect n -> bitvect n -> comparison := 32 | match n with 33 | | O => (fun b1 b2 => bool_compare_cont b1 b2 Eq) 34 | | S n => (fun v1 v2 => bool_compare_cont (snd v1) (snd v2) (bitvect_compare n (fst v1) (fst v2))) 35 | end. 36 | 37 | Lemma ascii_bitvect_compare: 38 | forall x y, 39 | ascii_compare x y = 40 | match x, y with 41 | | Ascii x1 x2 x3 x4 x5 x6 x7 x8, Ascii y1 y2 y3 y4 y5 y6 y7 y8 => 42 | bitvect_compare 7%nat 43 | (x1, x2, x3, x4, x5, x6, x7, x8) 44 | (y1, y2, y3, y4, y5, y6, y7, y8) 45 | end. 46 | Proof. 47 | destruct x, y; reflexivity. 48 | Qed. 49 | 50 | Lemma bitvect_compare_refl: 51 | forall n x, bitvect_compare n x x = Eq. 52 | Proof. 53 | induction n; simpl. 54 | - destruct x; auto. 55 | - intros [x x1]; simpl. rewrite IHn. destruct x1; auto. 56 | Qed. 57 | 58 | Lemma bitvect_compare_eq: 59 | forall n x y, bitvect_compare n x y = Eq -> x = y. 60 | Proof. 61 | induction n; simpl. 62 | - destruct x, y; simpl; congruence. 63 | - intros [x x1] [y y1]; unfold bool_compare_cont; simpl; intros. 64 | destruct x1, y1; try discriminate; f_equal; eauto. 65 | Qed. 66 | 67 | Lemma bitvect_compare_lt_trans: 68 | forall n x y z, bitvect_compare n x y = Lt -> bitvect_compare n y z = Lt -> bitvect_compare n x z = Lt. 69 | Proof. 70 | induction n; simpl. 71 | - intros. destruct x, y; try discriminate. destruct z; discriminate. 72 | - intros [x x1] [y y1] [z z1]; simpl; intros. 73 | assert (A: forall b1 b2 k, bool_compare_cont b1 b2 k = Lt -> b1 = false /\ b2 = true \/ b1 = b2 /\ k = Lt). 74 | { intros. destruct b1, b2; auto; discriminate. } 75 | apply A in H. apply A in H0. 76 | destruct H as [[P1 P2] | [P1 P2]]; destruct H0 as [[Q1 Q2] | [Q1 Q2]]; subst; subst; auto. 77 | erewrite IHn by eauto. destruct z1; auto. 78 | Qed. 79 | 80 | Lemma bitvect_compare_antisym: 81 | forall n x y, CompOpp (bitvect_compare n x y) = bitvect_compare n y x. 82 | Proof. 83 | assert (A: forall b1 b2 k, CompOpp (bool_compare_cont b1 b2 k) = bool_compare_cont b2 b1 (CompOpp k)). 84 | { intros. destruct b1, b2; auto. } 85 | induction n; simpl. 86 | - destruct x, y; auto. 87 | - intros [x x1] [y y1]. simpl. rewrite A. f_equal; auto. 88 | Qed. 89 | 90 | Lemma ascii_compare_refl: 91 | forall x, ascii_compare x x = Eq. 92 | Proof. 93 | intros. rewrite ascii_bitvect_compare. destruct x. apply bitvect_compare_refl. 94 | Qed. 95 | 96 | Lemma ascii_compare_eq: 97 | forall x y, ascii_compare x y = Eq -> x = y. 98 | Proof. 99 | intros. rewrite ascii_bitvect_compare in H. destruct x, y. 100 | apply bitvect_compare_eq in H. congruence. 101 | Qed. 102 | 103 | Lemma ascii_compare_lt_trans: 104 | forall x y z, ascii_compare x y = Lt -> ascii_compare y z = Lt -> ascii_compare x z = Lt. 105 | Proof. 106 | intros. rewrite ascii_bitvect_compare in *. destruct x, y, z. 107 | eapply bitvect_compare_lt_trans; eauto. 108 | Qed. 109 | 110 | Lemma ascii_compare_antisym: 111 | forall x y, CompOpp (ascii_compare x y) = ascii_compare y x. 112 | Proof. 113 | intros. rewrite ! ascii_bitvect_compare. destruct x, y. 114 | apply bitvect_compare_antisym. 115 | Qed. 116 | 117 | (** Implementing the [OrderedType] interface *) 118 | 119 | Module OrderedAscii <: OrderedType. 120 | 121 | Definition t := ascii. 122 | Definition eq (x y: t) := x = y. 123 | Definition lt (x y: t) := ascii_compare x y = Lt. 124 | 125 | Lemma eq_refl : forall x : t, eq x x. 126 | Proof (@eq_refl t). 127 | Lemma eq_sym : forall x y : t, eq x y -> eq y x. 128 | Proof (@eq_sym t). 129 | Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. 130 | Proof (@eq_trans t). 131 | 132 | Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. 133 | Proof ascii_compare_lt_trans. 134 | 135 | Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. 136 | Proof. 137 | unfold lt, eq; intros; red; intros. subst y. 138 | rewrite ascii_compare_refl in H. discriminate. 139 | Qed. 140 | 141 | Definition compare (x y : t) : Compare lt eq x y. 142 | Proof. 143 | destruct (ascii_compare x y) eqn:AC. 144 | - apply EQ. apply ascii_compare_eq; auto. 145 | - apply LT. assumption. 146 | - apply GT. red. rewrite <- ascii_compare_antisym. rewrite AC; auto. 147 | Defined. 148 | 149 | Definition eq_dec (x y : t) : {x = y} + {x <> y}. 150 | Proof. 151 | destruct (ascii_compare x y) eqn:AC. 152 | - left. apply ascii_compare_eq; auto. 153 | - right; red; intros; subst y. rewrite ascii_compare_refl in AC; discriminate. 154 | - right; red; intros; subst y. rewrite ascii_compare_refl in AC; discriminate. 155 | Defined. 156 | 157 | End OrderedAscii. 158 | 159 | -------------------------------------------------------------------------------- /Original.v: -------------------------------------------------------------------------------- 1 | (** * The original, non-extensional binary tries *) 2 | 3 | (* Authors: Xavier Leroy and Damien Doligez, Inria. 4 | Copyright: Inria. 5 | License: BSD-3-Clause. *) 6 | 7 | (** This implementation of binary tries is taken from the Maps module 8 | of CompCert version 3.9, 9 | https://compcert.org/doc-3.9/html/compcert.lib.Maps.html 10 | Several operations were omitted, and some proofs were tightened. 11 | *) 12 | 13 | From Coq Require Import PArith. 14 | 15 | Set Implicit Arguments. 16 | 17 | Module PTree. 18 | 19 | (** ** Representation of tries *) 20 | 21 | Inductive tree (A: Type) : Type := 22 | | Leaf: tree A 23 | | Node: tree A -> option A -> tree A -> tree A. 24 | 25 | Arguments Leaf {A}. 26 | Arguments Node [A]. 27 | 28 | Definition t := tree. 29 | 30 | (** A smart constructor that avoids creating nodes that contain no data. *) 31 | 32 | Definition Node' {A} (l: tree A) (x: option A) (r: tree A): tree A := 33 | match l, x, r with 34 | | Leaf, None, Leaf => Leaf 35 | | _, _, _ => Node l x r 36 | end. 37 | 38 | (** ** Basic operations: [empty], [get], [set], [remove] *) 39 | 40 | Definition empty (A: Type) : tree A := Leaf. 41 | 42 | Fixpoint get (A: Type) (i: positive) (m: tree A) {struct m} : option A := 43 | match m with 44 | | Leaf => None 45 | | Node l o r => 46 | match i with 47 | | xH => o 48 | | xO ii => get ii l 49 | | xI ii => get ii r 50 | end 51 | end. 52 | 53 | Fixpoint set (A: Type) (i: positive) (v: A) (m: tree A) {struct i} : tree A := 54 | match m with 55 | | Leaf => 56 | match i with 57 | | xH => Node Leaf (Some v) Leaf 58 | | xO ii => Node (set ii v Leaf) None Leaf 59 | | xI ii => Node Leaf None (set ii v Leaf) 60 | end 61 | | Node l o r => 62 | match i with 63 | | xH => Node l (Some v) r 64 | | xO ii => Node (set ii v l) o r 65 | | xI ii => Node l o (set ii v r) 66 | end 67 | end. 68 | 69 | Fixpoint remove (A: Type) (i: positive) (m: tree A) {struct m} : tree A := 70 | match m with 71 | | Leaf => Leaf 72 | | Node l o r => 73 | match i with 74 | | xH => Node' l None r 75 | | xO ii => Node' (remove ii l) o r 76 | | xI ii => Node' l o (remove ii r) 77 | end 78 | end. 79 | 80 | (** ** Good variable properties for the basic operations *) 81 | 82 | (** The following equations specify the [empty], [set] and [remove] 83 | operations in terms of [get] queries. For example, 84 | [gempty] characterizes [empty] as the trie that always responds 85 | "not found" to a [get]. *) 86 | 87 | Theorem gempty: 88 | forall {A} (i: positive), get i (empty A) = None. 89 | Proof. 90 | auto. 91 | Qed. 92 | 93 | Theorem gss: 94 | forall {A} (i: positive) (x: A) (m: tree A), get i (set i x m) = Some x. 95 | Proof. 96 | induction i; destruct m; simpl; auto. 97 | Qed. 98 | 99 | Theorem gso: 100 | forall {A} (i j: positive) (x: A) (m: tree A), 101 | i <> j -> get i (set j x m) = get i m. 102 | Proof. 103 | induction i; intros; destruct j; destruct m; simpl; auto; try apply IHi; congruence. 104 | Qed. 105 | 106 | Lemma gNode': 107 | forall {A} (i: positive) (l: tree A) (x: option A) (r: tree A), 108 | get i (Node' l x r) = match i with xH => x | xO j => get j l | xI j => get j r end. 109 | Proof. 110 | intros. destruct l, x, r; simpl; auto. destruct i; auto. 111 | Qed. 112 | 113 | Theorem grs: 114 | forall {A} (i: positive) (m: tree A), get i (remove i m) = None. 115 | Proof. 116 | induction i; destruct m; simpl; auto; rewrite gNode'; simpl; auto. 117 | Qed. 118 | 119 | Theorem gro: 120 | forall {A} (i j: positive) (m: tree A), 121 | i <> j -> get i (remove j m) = get i m. 122 | Proof. 123 | induction i; destruct j, m; intros; simpl; auto; 124 | rewrite gNode'; simpl; auto; try apply IHi; congruence. 125 | Qed. 126 | 127 | (** ** Collective operations over tries *) 128 | 129 | (** The [map_filter] operation combines a "map" (apply a function to 130 | every value of a trie) and a "filter" (keep only the values 131 | that satisy a given predicate). The function [f] being mapped 132 | has type [A -> option B]. A value [a] in the input trie 133 | becomes a value [b] in the output trie if [f a = Some b] 134 | and is absent in the output trie if [f a = None]. *) 135 | 136 | Section MAP_FILTER. 137 | 138 | Variables A B: Type. 139 | 140 | Definition option_map (f: A -> option B) (o: option A): option B := 141 | match o with None => None | Some a => f a end. 142 | 143 | Fixpoint map_filter (f: A -> option B) (m: tree A) : tree B := 144 | match m with 145 | | Leaf => Leaf 146 | | Node l o r => Node' (map_filter f l) (option_map f o) (map_filter f r) 147 | end. 148 | 149 | Lemma gmap_filter: 150 | forall (f: A -> option B) (m: tree A) (i: positive), 151 | get i (map_filter f m) = option_map f (get i m). 152 | Proof. 153 | induction m; intros; simpl. 154 | - auto. 155 | - rewrite gNode'. destruct i; auto. 156 | Qed. 157 | 158 | End MAP_FILTER. 159 | 160 | (** The [combine] operation traverses two tries in parallel, 161 | applying a function [f: option A -> option B -> option C] 162 | at each node to build the resulting trie. *) 163 | 164 | Section COMBINE. 165 | 166 | Variables A B C: Type. 167 | Variable f: option A -> option B -> option C. 168 | Hypothesis f_None_None: f None None = None. 169 | 170 | Fixpoint combine (m1: tree A) (m2: tree B): tree C := 171 | match m1, m2 with 172 | | Leaf, _ => map_filter (fun b => f None (Some b)) m2 173 | | _, Leaf => map_filter (fun a => f (Some a) None) m1 174 | | Node l1 o1 r1, Node l2 o2 r2 => Node' (combine l1 l2) (f o1 o2) (combine r1 r2) 175 | end. 176 | 177 | Lemma gcombine: 178 | forall (m1: tree A) (m2: tree B) (i: positive), 179 | get i (combine m1 m2) = f (get i m1) (get i m2). 180 | Proof. 181 | Local Opaque map_filter. 182 | induction m1; intros. 183 | - simpl. rewrite gmap_filter. destruct (get i m2); auto. 184 | - destruct m2; simpl combine. 185 | + rewrite gmap_filter. destruct (get i (Node m1_1 o m1_2)); auto. 186 | + rewrite gNode'; simpl. destruct i; auto. 187 | Qed. 188 | 189 | End COMBINE. 190 | 191 | End PTree. 192 | -------------------------------------------------------------------------------- /MMaps/Utils.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import List SetoidList. 2 | Import ListNotations. 3 | 4 | Set Implicit Arguments. 5 | 6 | (** * Some complements on bool and lists *) 7 | 8 | Lemma eq_bool_alt b b' : b=b' <-> (b=true <-> b'=true). 9 | Proof. 10 | destruct b, b'; intuition. 11 | Qed. 12 | 13 | Lemma eq_option_alt {A}(o o':option A) : 14 | o=o' <-> (forall x, o=Some x <-> o'=Some x). 15 | Proof. 16 | split; intros. 17 | - now subst. 18 | - destruct o, o'; rewrite ?H; auto. 19 | symmetry; now apply H. 20 | Qed. 21 | 22 | Lemma option_map_some {A B}(f:A->B) o : 23 | option_map f o <> None <-> o <> None. 24 | Proof. 25 | destruct o; simpl. now split. split; now destruct 1. 26 | Qed. 27 | 28 | Definition option_bind {A B} o (f:A->option B) := 29 | match o with 30 | | None => None 31 | | Some a => f a 32 | end. 33 | 34 | (** An hybrid of [map] and [filter] *) 35 | 36 | Fixpoint mapfilter {A B} (f:A->option B) l := 37 | match l with 38 | | [] => [] 39 | | a::l => match f a with 40 | | Some b => b::mapfilter f l 41 | | None => mapfilter f l 42 | end 43 | end. 44 | 45 | Lemma mapfilter_app {A B} (f:A->option B) l l' : 46 | mapfilter f (l++l') = mapfilter f l ++ mapfilter f l'. 47 | Proof. 48 | induction l; simpl; auto. 49 | destruct f; simpl; auto; f_equal; auto. 50 | Qed. 51 | 52 | Global Instance mapfilter_ext {A B} : 53 | Proper ((eq ==> eq) ==> eq ==> eq) (@mapfilter A B). 54 | Proof. 55 | intros f f' E l l' <-. 56 | induction l; simpl; auto. 57 | rewrite <- (E a); auto. destruct f; auto. f_equal; auto. 58 | Qed. 59 | 60 | Lemma map_as_mapfilter {A B} (f:A->B) l : 61 | map f l = mapfilter (fun a => Some (f a)) l. 62 | Proof. 63 | induction l; simpl; f_equal; auto. 64 | Qed. 65 | 66 | Lemma filter_as_mapfilter {A} (f:A->bool) l : 67 | filter f l = mapfilter (fun a => if f a then Some a else None) l. 68 | Proof. 69 | induction l; simpl; auto. destruct f; simpl; auto. f_equal; auto. 70 | Qed. 71 | 72 | Lemma mapfilter_comp {A B C}(f:A->option B)(g:B->option C) l : 73 | mapfilter g (mapfilter f l) = mapfilter (fun a => option_bind (f a) g) l. 74 | Proof. 75 | induction l; simpl; auto. 76 | destruct f; simpl; auto. destruct g; simpl; auto. f_equal; auto. 77 | Qed. 78 | 79 | Lemma mapfilter_map {A B C} (f:A->B)(g:B->option C) l : 80 | mapfilter g (map f l) = mapfilter (fun a => g (f a)) l. 81 | Proof. 82 | now rewrite map_as_mapfilter, mapfilter_comp. 83 | Qed. 84 | 85 | Lemma map_mapfilter {A B C} (f:A->option B)(g:B->C) l : 86 | map g (mapfilter f l) = mapfilter (fun a => option_map g (f a)) l. 87 | Proof. 88 | rewrite map_as_mapfilter, mapfilter_comp. f_equiv. 89 | Qed. 90 | 91 | (** Properties of [List.filter] *) 92 | 93 | Lemma filter_app {A} (f:A->bool) l l' : 94 | filter f (l++l') = filter f l ++ filter f l'. 95 | Proof. 96 | induction l; simpl; auto. destruct (f a); simpl; f_equal; auto. 97 | Qed. 98 | 99 | Lemma filter_map {A B} (f:A->B)(h:B->bool) l : 100 | filter h (map f l) = map f (filter (fun x => h (f x)) l). 101 | Proof. 102 | induction l; simpl; auto. destruct (h (f a)); simpl; f_equal; auto. 103 | Qed. 104 | 105 | Global Instance filter_ext {A} : Proper ((eq==>eq)==>eq==>eq) (@filter A). 106 | Proof. 107 | intros f f' E l l' <-. 108 | induction l; simpl; auto. rewrite <- (E a); auto. 109 | destruct f; simpl; auto. f_equal; auto. 110 | Qed. 111 | 112 | Lemma filter_rev {A} (f:A->bool) l : 113 | rev (filter f l) = filter f (rev l). 114 | Proof. 115 | induction l; simpl; auto. 116 | rewrite filter_app, <- IHl. simpl. 117 | destruct (f a); simpl; auto using app_nil_r. 118 | Qed. 119 | 120 | Lemma NoDupA_filter {A} (eq:relation A) (f:A->bool) l : 121 | NoDupA eq l -> NoDupA eq (filter f l). 122 | Proof. 123 | induction 1; simpl; auto. 124 | destruct f; auto. constructor; auto. 125 | rewrite InA_alt in *. setoid_rewrite filter_In. firstorder. 126 | Qed. 127 | 128 | (** [List.partition] via [List.filter] *) 129 | 130 | Lemma partition_filter {A} (f:A->bool) l : 131 | partition f l = (filter f l, filter (fun a => negb (f a)) l). 132 | Proof. 133 | induction l; simpl; auto. rewrite IHl. now destruct f. 134 | Qed. 135 | 136 | (** More results about [List.forallb] and [List.existsb] *) 137 | 138 | Lemma forallb_map {A B} (f:A->B)(h:B->bool) l: 139 | forallb h (map f l) = forallb (fun a => h (f a)) l. 140 | Proof. 141 | induction l; simpl; auto. destruct h; simpl; auto. 142 | Qed. 143 | 144 | Lemma existsb_map {A B} (f:A->B)(h:B->bool) l: 145 | existsb h (map f l) = existsb (fun a => h (f a)) l. 146 | Proof. 147 | induction l; simpl; auto. destruct h; simpl; auto. 148 | Qed. 149 | 150 | Global Instance forallb_ext {A} : Proper ((eq==>eq)==>eq==>eq) (@forallb A). 151 | Proof. 152 | intros f f' E l l' <-. 153 | induction l; simpl; auto. rewrite <- (E a); auto. 154 | destruct f; simpl; auto. 155 | Qed. 156 | 157 | Global Instance existsb_ext {A} : Proper ((eq==>eq)==>eq==>eq) (@existsb A). 158 | Proof. 159 | intros f f' E l l' <-. 160 | induction l; simpl; auto. rewrite <- (E a); auto. 161 | destruct f; simpl; auto. 162 | Qed. 163 | 164 | Lemma forallb_rev {A} (f:A->bool) l : 165 | forallb f (rev l) = forallb f l. 166 | Proof. 167 | apply eq_bool_alt. rewrite !forallb_forall. 168 | now setoid_rewrite <- in_rev. 169 | Qed. 170 | 171 | Lemma existsb_rev {A} (f:A->bool) l : 172 | existsb f (rev l) = existsb f l. 173 | Proof. 174 | apply eq_bool_alt. rewrite !existsb_exists. 175 | now setoid_rewrite <- in_rev. 176 | Qed. 177 | 178 | (** [SetoidList.SortA_app] written via a [iff] *) 179 | 180 | Section MoreOnSortA. 181 | Context {A} eqA `{Equivalence A eqA}. 182 | Context ltA `{StrictOrder A ltA} `{!Proper (eqA==>eqA==>iff) ltA}. 183 | 184 | Lemma SortA_app_iff (l1 l2 : list A) : 185 | sort ltA (l1++l2) <-> 186 | sort ltA l1 /\ sort ltA l2 /\ 187 | forall a1 a2, In a1 l1 -> In a2 l2 -> ltA a1 a2. 188 | Proof. 189 | split. 190 | { induction l1 as [|a1 l1 IHl1]. 191 | - easy. 192 | - simpl. inversion_clear 1 as [ | ? ? Hs Hhd ]. 193 | destruct (IHl1 Hs) as (H1 & H2 & H3); clear IHl1. 194 | repeat split. 195 | * constructor; auto. 196 | destruct l1; simpl in *; auto; inversion_clear Hhd; auto. 197 | * trivial. 198 | * intros b1 b2 [->|Hb1] Hb2; eauto. 199 | eapply SortA_InfA_InA with (eqA:=eqA)(l:=l1++l2); auto. 200 | rewrite InA_app_iff. right. apply In_InA; auto with *. } 201 | { intros (U & V & W); eapply SortA_app; eauto. 202 | intros x y. rewrite !InA_alt. 203 | intros (x' & -> & Hx) (y' & -> & Hy); auto. } 204 | Qed. 205 | 206 | End MoreOnSortA. 207 | -------------------------------------------------------------------------------- /MMaps/demo.v: -------------------------------------------------------------------------------- 1 | 2 | (** MMaps Library : the demo *) 3 | 4 | (** Author : Pierre Letouzey (Université de Paris - INRIA), 5 | adapted from earlier works in Coq Standard Library, see README.md. 6 | Licence : LGPL 2.1, see file LICENSE. *) 7 | 8 | From Coq Require Import ZArith String Orders List. 9 | From Tries.MMaps Require Import Tries.MMaps. 10 | 11 | Set Implicit Arguments. 12 | Open Scope string. 13 | Open Scope Z. 14 | Import ListNotations. 15 | 16 | (** This MMaps library provides finite maps (e.g. key/value structure). 17 | It is an improved version of the former FMaps library, which is 18 | itself derived from the OCaml Map library. 19 | The "M" in the current name is for Module (and to be different 20 | from FMaps), nothing to see with the unix system call "mmap". *) 21 | 22 | (** In these maps, we associate keys to values. 23 | The key type is rigidly fixed at the creation of the module 24 | (usually by giving an OrderedType module to the creating functor). 25 | while the value type is polymorphic and may vary from map to map, 26 | even in the same MMaps instance. *) 27 | 28 | (** The OrderedType notion is the one of Coq Stdlib, 29 | already used in [MSets]. The main function is [compare], 30 | which has a ternary [comparison] output, and is specified 31 | w.r.t. an equivalence [eq] and a strict order [lt]. *) 32 | 33 | Print Orders.OrderedType. 34 | Print comparison. 35 | Print CompareSpec. 36 | 37 | (** Many datatype modules of Coq are already implementing OrderedType. 38 | For instance, let's build some maps with [nat] numbers as keys, 39 | and then maps with [Z] numbers as keys. *) 40 | 41 | Module NatMaps := Tries.MMaps.RBT.Make(Nat). 42 | Module ZM := Tries.MMaps.RBT.Make(Z). 43 | 44 | (* Let's play with them : *) 45 | 46 | Definition map1 := 47 | ZM.add 3 "yes" (ZM.add 0 "no" (ZM.add 2 "foo" ZM.empty)). 48 | Definition map2 := 49 | ZM.add 3 [1;2] (ZM.add 0 [3;4;5] (ZM.add 7 [] ZM.empty)). 50 | 51 | Compute ZM.find 3 map1. 52 | Compute ZM.find 3 map2. 53 | Compute ZM.bindings map1. 54 | Compute ZM.bindings (ZM.remove 0 map1). 55 | 56 | (* Some examples of more advanced operations : *) 57 | 58 | Compute ZM.fold (fun _ => String.append) map1 "". 59 | 60 | Compute ZM.bindings (ZM.map (@List.length Z) map2). 61 | 62 | Definition reconciliate(z:Z)(o:option string)(o':option (list Z)) := 63 | match o,o' with None, Some _ => Some "new" | _,_ => o end. 64 | 65 | Definition map3 := ZM.merge reconciliate map1 map2. 66 | Compute ZM.bindings map3. 67 | 68 | (* ZM also provides some basic properties, for instance: *) 69 | 70 | Check (ZM.cardinal_spec map1). 71 | (* The number of bindings in [map1] is the length of [bindings map1]. *) 72 | 73 | Check (ZM.bindings_spec2 map1). 74 | (* bindings always returns a sorted list 75 | with respect to the underlying order on keys. *) 76 | 77 | (* The ZM.t type for maps is meant to be used as an abstract type 78 | since it will vary among the different implementations of Tries.MMaps. 79 | An ZM.t can and should always be inspected by using [find], 80 | [bindings], etc. 81 | But for once, let's have a look at the raw aspect of a map: *) 82 | Compute map1. 83 | (* Here for RBT (Red-Black-Tree), a map is a record combining 84 | a tree (field ZM.this) and a proof (field ZM.ok). *) 85 | 86 | (* Note that the proof part will grow at each operation of the map. 87 | In order to avoid that, we can work on the underlying "raw" 88 | datatype (i.e. without built-in invariants). *) 89 | 90 | Module R:=ZM.Raw. 91 | 92 | Definition raw1 := R.add 3 "yes" (R.add 0 "no" (R.add 2 "foo" (R.empty _))). 93 | 94 | Compute raw1. 95 | Compute (R.bindings raw1). 96 | 97 | (* But then proving properties is a bit more complex. *) 98 | 99 | Check (@R.bindings_spec2 _ raw1 _). 100 | 101 | (* The second "_" is a proof that raw1 is "Ok". Fortunately, the system 102 | has infered it here via some class resolution, and it should be 103 | the case when using the provided operations. If you have built 104 | your own map without using the provided operations, you could 105 | consider the "isok" boolean function to check it, and [Mkt_bool] 106 | to "repack" it into a map with correctness proof. *) 107 | 108 | Compute R.isok raw1. 109 | Check (eq_refl : R.isok raw1 = true). 110 | Check (@ZM.Mkt_bool _ raw1 eq_refl). 111 | 112 | (** * Some more intense tests. *) 113 | 114 | Fixpoint multiples (m:Z)(start:Z)(n:nat) {struct n} : list Z := 115 | match n with 116 | | O => nil 117 | | S n => start::(multiples m (m+start) n) 118 | end. 119 | 120 | Eval compute in (multiples 2 0 200%nat). 121 | 122 | Definition bigmap1 := 123 | fold_right (fun z => ZM.add z z) ZM.empty (multiples 2 0 400%nat). 124 | Definition bigmap2 := 125 | fold_right (fun z => ZM.add z z) ZM.empty (multiples 3 0 400%nat). 126 | 127 | Definition both (z:Z)(o:option Z)(o':option Z) := 128 | match o,o' with Some _, Some _ => o | _,_=>None end. 129 | Time Compute ZM.bindings (ZM.merge both bigmap1 bigmap2). 130 | 131 | Definition bigmap3 := 132 | fold_right (fun z => ZM.add z z) ZM.empty (multiples 2 0 (100*100)%nat). 133 | Definition bigmap4 := 134 | fold_right (fun z => ZM.add z z) ZM.empty (multiples 3 0 (100*100)%nat). 135 | Time Compute ZM.bindings (ZM.merge both bigmap3 bigmap4). 136 | 137 | 138 | (** * the Facts *) 139 | 140 | (* The properties provided by ZM are deliberately minimalistic. 141 | They correspond to the minimal specifications present in Interface.S. 142 | This way, building new implementations is relatively simple. 143 | Now, lots of additional facts can be derived from this common interface. *) 144 | 145 | Module ZMF := Tries.MMaps.Facts.Properties Z ZM. 146 | 147 | (* It contains mainly rephrasing of the specifications. *) 148 | Check ZMF.add_1. 149 | Check ZMF.add_b. 150 | 151 | (* And some basic things about the operations. *) 152 | Check ZMF.cardinal_notin_add. 153 | 154 | (* Also useful: induction principles *) 155 | Check ZMF.map_induction. 156 | 157 | (* And lot of stuff concerning the hard-to-handle [fold] function *) 158 | Check ZMF.fold_add. 159 | 160 | (* Concerning [compare], we need a ternary decidable comparison 161 | over datas. We hence diverge slightly apart from Ocaml, by placing 162 | this [compare] in a separate functor requiring 2 [OrderedType], 163 | one for the keys and one for the datas, see Interface.Sord 164 | and for instance RBT.Make_ord *) 165 | 166 | 167 | (** * The Weak Maps *) 168 | 169 | (* Sometimes, one may need finite sets and maps over a base type 170 | that does not come with a decidable order. As long as this type 171 | can still be equipped with a decidable equality, the weak 172 | interface [Interface.WS] and its implementation [Tries.MMaps.WeakList] 173 | provide such structures. 174 | *) 175 | 176 | Module W := Tries.MMaps.WeakList.Make(Z). 177 | 178 | (* Of course, we cannot provide efficient functions anymore : the 179 | underlying structure is unsorted lists (but without redundancies). *) 180 | 181 | Compute W.bindings (W.add 1 "yes" (W.add 3 "no" (W.add 2 "foo" W.empty))). 182 | 183 | (* For now, [Interface.WS] provides the same operations as [Interface.S] 184 | (minus [compare]), and the only different specification concerns [bindings], 185 | which isn't sorted, but only without redundancies. *) 186 | -------------------------------------------------------------------------------- /Node01.v: -------------------------------------------------------------------------------- 1 | (** * A variant on the original, non-extensional binary tries *) 2 | 3 | (* Authors: Xavier Leroy and Damien Doligez, Inria. 4 | Copyright: Inria. 5 | License: BSD-3-Clause. *) 6 | 7 | (** This is a variant of the [Original] implementation of binary tries, 8 | differing only in the way tree nodes are represented: 9 | instead of a single [Node] constructor carrying an optional value, 10 | we have two constructors, [Node0] carrying no value and [Node1] 11 | carrying a value. This provides minor performance improvements 12 | over the [Original] implementation, but not as much as the [Canonical] 13 | implementation. The lack of extensionality is still there. *) 14 | 15 | From Coq Require Import PArith. 16 | 17 | Set Implicit Arguments. 18 | 19 | Module PTree. 20 | 21 | (** ** Representation of tries *) 22 | 23 | Inductive tree (A: Type) : Type := 24 | | Leaf: tree A 25 | | Node0: tree A -> tree A -> tree A 26 | | Node1: tree A -> A -> tree A -> tree A. 27 | 28 | Arguments Leaf {A}. 29 | Arguments Node0 [A]. 30 | Arguments Node1 [A]. 31 | 32 | Definition t := tree. 33 | 34 | (** Smart constructor that avoids creating nodes that contain no data. *) 35 | 36 | Definition Node0' {A} (l: tree A) (r: tree A): tree A := 37 | match l, r with 38 | | Leaf, Leaf => Leaf 39 | | _, _ => Node0 l r 40 | end. 41 | 42 | Definition Node {A} (l: tree A) (x: option A) (r: tree A): tree A := 43 | match x, l, r with 44 | | None, Leaf, Leaf => Leaf 45 | | None, _, _ => Node0 l r 46 | | Some v, _, _ => Node1 l v r 47 | end. 48 | 49 | (** ** Basic operations: [empty], [get], [set], [remove] *) 50 | 51 | Definition empty (A: Type) : tree A := Leaf. 52 | 53 | Fixpoint get (A: Type) (i: positive) (m: tree A) {struct m} : option A := 54 | match m with 55 | | Leaf => None 56 | | Node0 l r => 57 | match i with 58 | | xH => None 59 | | xO ii => get ii l 60 | | xI ii => get ii r 61 | end 62 | | Node1 l x r => 63 | match i with 64 | | xH => Some x 65 | | xO ii => get ii l 66 | | xI ii => get ii r 67 | end 68 | end. 69 | 70 | Fixpoint set (A: Type) (i: positive) (v: A) (m: tree A) {struct i} : tree A := 71 | match m with 72 | | Leaf => 73 | match i with 74 | | xH => Node1 Leaf v Leaf 75 | | xO ii => Node0 (set ii v Leaf) Leaf 76 | | xI ii => Node0 Leaf (set ii v Leaf) 77 | end 78 | | Node0 l r => 79 | match i with 80 | | xH => Node1 l v r 81 | | xO ii => Node0 (set ii v l) r 82 | | xI ii => Node0 l (set ii v r) 83 | end 84 | | Node1 l x r => 85 | match i with 86 | | xH => Node1 l v r 87 | | xO ii => Node1 (set ii v l) x r 88 | | xI ii => Node1 l x (set ii v r) 89 | end 90 | end. 91 | 92 | Fixpoint remove (A: Type) (i: positive) (m: tree A) {struct m} : tree A := 93 | match m with 94 | | Leaf => Leaf 95 | | Node0 l r => 96 | match i with 97 | | xH => Node0 l r 98 | | xO ii => Node0' (remove ii l) r 99 | | xI ii => Node0' l (remove ii r) 100 | end 101 | | Node1 l x r => 102 | match i with 103 | | xH => Node0' l r 104 | | xO ii => Node1 (remove ii l) x r 105 | | xI ii => Node1 l x (remove ii r) 106 | end 107 | end. 108 | 109 | (** ** Good variable properties for the basic operations *) 110 | 111 | (** The following equations specify the [empty], [set] and [remove] 112 | operations in terms of [get] queries. For example, 113 | [gempty] characterizes [empty] as the trie that always responds 114 | "not found" to a [get]. *) 115 | 116 | Theorem gempty: 117 | forall {A} (i: positive), get i (empty A) = None. 118 | Proof. 119 | auto. 120 | Qed. 121 | 122 | Theorem gss: 123 | forall {A} (i: positive) (x: A) (m: tree A), get i (set i x m) = Some x. 124 | Proof. 125 | induction i; destruct m; simpl; auto. 126 | Qed. 127 | 128 | Theorem gso: 129 | forall {A} (i j: positive) (x: A) (m: tree A), 130 | i <> j -> get i (set j x m) = get i m. 131 | Proof. 132 | induction i; intros; destruct j; destruct m; simpl; auto; try apply IHi; congruence. 133 | Qed. 134 | 135 | Lemma gNode0': 136 | forall {A} (i: positive) (l: tree A) (r: tree A), 137 | get i (Node0' l r) = match i with xH => None | xO j => get j l | xI j => get j r end. 138 | Proof. 139 | intros. destruct l, r; simpl; auto. destruct i; auto. 140 | Qed. 141 | 142 | Lemma gNode: 143 | forall {A} (i: positive) (l: tree A) (x: option A) (r: tree A), 144 | get i (Node l x r) = match i with xH => x | xO j => get j l | xI j => get j r end. 145 | Proof. 146 | intros. destruct l, x, r; simpl; auto. destruct i; auto. 147 | Qed. 148 | 149 | Theorem grs: 150 | forall {A} (i: positive) (m: tree A), get i (remove i m) = None. 151 | Proof. 152 | induction i; destruct m; simpl; auto; rewrite gNode0'; simpl; auto. 153 | Qed. 154 | 155 | Theorem gro: 156 | forall {A} (i j: positive) (m: tree A), 157 | i <> j -> get i (remove j m) = get i m. 158 | Proof. 159 | induction i; destruct j, m; intros; simpl; auto; 160 | rewrite ? gNode0'; simpl; auto; try apply IHi; congruence. 161 | Qed. 162 | 163 | (** ** Collective operations over tries *) 164 | 165 | Section MAP_FILTER. 166 | 167 | Variables A B: Type. 168 | 169 | Definition option_map (f: A -> option B) (o: option A): option B := 170 | match o with None => None | Some a => f a end. 171 | 172 | Fixpoint map_filter (f: A -> option B) (m: tree A) : tree B := 173 | match m with 174 | | Leaf => Leaf 175 | | Node0 l r => Node0' (map_filter f l) (map_filter f r) 176 | | Node1 l x r => Node (map_filter f l) (f x) (map_filter f r) 177 | end. 178 | 179 | Lemma gmap_filter: 180 | forall (f: A -> option B) (m: tree A) (i: positive), 181 | get i (map_filter f m) = option_map f (get i m). 182 | Proof. 183 | induction m; intros; simpl. 184 | - auto. 185 | - rewrite gNode0'. destruct i; auto. 186 | - rewrite gNode. destruct i; auto. 187 | Qed. 188 | 189 | End MAP_FILTER. 190 | 191 | Section COMBINE. 192 | 193 | Variables A B C: Type. 194 | Variable f: option A -> option B -> option C. 195 | Hypothesis f_None_None: f None None = None. 196 | 197 | Fixpoint combine (m1: tree A) (m2: tree B): tree C := 198 | match m1, m2 with 199 | | Leaf, _ => map_filter (fun b => f None (Some b)) m2 200 | | _, Leaf => map_filter (fun a => f (Some a) None) m1 201 | | Node0 l1 r1, Node0 l2 r2 => Node0' (combine l1 l2) (combine r1 r2) 202 | | Node0 l1 r1, Node1 l2 x2 r2 => Node (combine l1 l2) (f None (Some x2)) (combine r1 r2) 203 | | Node1 l1 x1 r1, Node0 l2 r2 => Node (combine l1 l2) (f (Some x1) None) (combine r1 r2) 204 | | Node1 l1 x1 r1, Node1 l2 x2 r2 => Node (combine l1 l2) (f (Some x1) (Some x2)) (combine r1 r2) 205 | end. 206 | 207 | Lemma gcombine: 208 | forall (m1: tree A) (m2: tree B) (i: positive), 209 | get i (combine m1 m2) = f (get i m1) (get i m2). 210 | Proof. 211 | assert (L: forall i m, get i (map_filter (fun a => f (Some a) None) m) = f (get i m) None). 212 | { intros. rewrite gmap_filter. destruct (get i m); auto. } 213 | assert (R: forall i m, get i (map_filter (fun b => f None (Some b)) m) = f None (get i m)). 214 | { intros. rewrite gmap_filter. destruct (get i m); auto. } 215 | Local Opaque map_filter. 216 | induction m1; intros; simpl; auto; destruct m2; rewrite ? L; auto; 217 | rewrite ? gNode0', ? gNode; destruct i; simpl; auto. 218 | Qed. 219 | 220 | End COMBINE. 221 | 222 | End PTree. 223 | -------------------------------------------------------------------------------- /MMaps/Comparisons.v: -------------------------------------------------------------------------------- 1 | 2 | From Coq Require Import List. 3 | Import ListNotations. 4 | 5 | (** * Some complements on [comparison] *) 6 | 7 | Set Implicit Arguments. 8 | 9 | (** lexicographic product, defined using a notation to keep things lazy *) 10 | 11 | Notation lex u v := match u with Eq => v | Lt => Lt | Gt => Gt end. 12 | 13 | Lemma lex_Eq u v : lex u v = Eq <-> u=Eq /\ v=Eq. 14 | Proof. now destruct u. Qed. 15 | 16 | (** The comparison function in OrderedType are symmetric and 17 | transitive in the following sense: *) 18 | 19 | Definition Sym {A} (cmp:A->A->comparison) := 20 | forall x y, cmp y x = CompOpp (cmp x y). 21 | 22 | Definition Trans {A} (cmp:A->A->comparison) := 23 | forall c x y z, cmp x y = c -> cmp y z = c -> cmp x z = c. 24 | 25 | Class SymTrans {A} (cmp:A->A->comparison) := { 26 | sym :> Sym cmp; 27 | tra :> Trans cmp 28 | }. 29 | 30 | (** [SymTrans] implies the following compatibility rules *) 31 | 32 | Definition CompatR {A} (cmp:A->A->comparison) := 33 | forall x y y', cmp y y' = Eq -> cmp x y = cmp x y'. 34 | 35 | Definition CompatL {A} (cmp:A->A->comparison) := 36 | forall x x' y, cmp x x' = Eq -> cmp x y = cmp x' y. 37 | 38 | Ltac flipcmp H := 39 | match type of H with ?cmp _ _ = _ => 40 | match goal with 41 | | Sy : Sym cmp |- _ => rewrite Sy, CompOpp_iff in H; simpl in H 42 | | Sy : SymTrans cmp |- _ => rewrite sym, CompOpp_iff in H; simpl in H 43 | end 44 | end. 45 | 46 | Lemma SymTrans_CompatR {A} (cmp:A->A->comparison) : 47 | SymTrans cmp -> CompatR cmp. 48 | Proof. 49 | intros (Sy,Tr) x y y' Hy. 50 | destruct (cmp x y) eqn:E, (cmp x y') eqn:E'; trivial. 51 | - erewrite Tr in E'; eauto. 52 | - erewrite Tr in E'; eauto. 53 | - erewrite Tr in E; eauto. now flipcmp Hy. 54 | - flipcmp E. erewrite Tr in Hy; eauto. easy. 55 | - flipcmp Hy. erewrite Tr in E; eauto. 56 | - flipcmp E. erewrite Tr in Hy; eauto. easy. 57 | Qed. 58 | 59 | Lemma SymTrans_CompatL {A} (cmp:A->A->comparison) : 60 | SymTrans cmp -> CompatL cmp. 61 | Proof. 62 | intros ST x x' y Hx. rewrite (sym y x), (sym y x'). f_equal. 63 | apply SymTrans_CompatR; auto. 64 | Qed. 65 | 66 | (** Lexicographic comparison on pairs *) 67 | 68 | Section PairComp. 69 | Variable A B : Type. 70 | Variable cmpA : A -> A -> comparison. 71 | Variable cmpB : B -> B -> comparison. 72 | Definition pair_compare '(a,b) '(a',b') := lex (cmpA a a') (cmpB b b'). 73 | 74 | Lemma pair_compare_sym : Sym cmpA -> Sym cmpB -> Sym pair_compare. 75 | Proof. 76 | intros HA HB (x,x') (y,y'). simpl. 77 | rewrite HA, HB. destruct cmpA; simpl; auto. 78 | Qed. 79 | 80 | Lemma pair_compare_trans : 81 | SymTrans cmpA -> Trans cmpB -> Trans pair_compare. 82 | Proof. 83 | intros HA HB c (x,x') (y,y') (z,z') Hxy Hyz. simpl in *. 84 | destruct (cmpA x y) eqn:Cxy; simpl. 85 | - rewrite SymTrans_CompatL; eauto. 86 | destruct (cmpA y z) eqn:Cyz; simpl; eauto. 87 | - subst c. 88 | destruct (cmpA y z) eqn:Cyz; simpl; try easy. 89 | + flipcmp Cyz. rewrite SymTrans_CompatR, Cxy; eauto. 90 | + rewrite tra; eauto. easy. 91 | - subst c. 92 | destruct (cmpA y z) eqn:Cyz; simpl; try easy. 93 | + flipcmp Cyz. rewrite SymTrans_CompatR, Cxy; eauto. 94 | + rewrite tra; eauto. easy. 95 | Qed. 96 | 97 | Global Instance pair_compare_st : 98 | SymTrans cmpA -> SymTrans cmpB -> SymTrans pair_compare. 99 | Proof. 100 | constructor. 101 | - apply pair_compare_sym; apply sym. 102 | - apply pair_compare_trans; auto. apply tra. 103 | Qed. 104 | 105 | Lemma pair_compare_eq a a' b b' : 106 | pair_compare (a,b) (a',b') = Eq <-> cmpA a a' = Eq /\ cmpB b b' = Eq. 107 | Proof. 108 | apply lex_Eq. 109 | Qed. 110 | 111 | End PairComp. 112 | 113 | (** Comparison on lists *) 114 | 115 | Section ListComp. 116 | Variable A : Type. 117 | Variable cmp : A -> A -> comparison. 118 | Fixpoint list_compare (l1 l2 : list A) := 119 | match l1, l2 with 120 | | [], [] => Eq 121 | | [], _ => Lt 122 | | _, [] => Gt 123 | | x1::l1', x2::l2' => lex (cmp x1 x2) (list_compare l1' l2') 124 | end. 125 | 126 | Lemma list_compare_sym : Sym cmp -> Sym list_compare. 127 | Proof. 128 | intros HA. red. induction x as [|a x IH]; destruct y as [|a' y]; auto. 129 | simpl. rewrite HA. destruct cmp; simpl; auto. 130 | Qed. 131 | 132 | Lemma list_compare_trans : 133 | SymTrans cmp -> Trans list_compare. 134 | Proof. 135 | intros HA c. 136 | induction x as [|a x IH]; destruct y as [|a' y], z as [|a'' z]; 137 | simpl; auto; try congruence. 138 | destruct (cmp a a') eqn:E, (cmp a' a'') eqn:E'; simpl; try congruence. 139 | - rewrite tra; eauto. simpl; eauto. 140 | - intros _ <-. rewrite SymTrans_CompatL, E'; eauto. 141 | - intros _ <-. rewrite SymTrans_CompatL, E'; eauto. 142 | - intros <- _. rewrite SymTrans_CompatR, E; eauto. now flipcmp E'. 143 | - intros <- _. rewrite tra; eauto. easy. 144 | - intros <- _. rewrite SymTrans_CompatR, E; eauto. now flipcmp E'. 145 | - intros <- _. rewrite tra; eauto. easy. 146 | Qed. 147 | 148 | Global Instance list_compare_st : SymTrans cmp -> SymTrans list_compare. 149 | Proof. 150 | constructor. apply list_compare_sym, sym. now apply list_compare_trans. 151 | Qed. 152 | 153 | Lemma list_compare_eq l l' : 154 | list_compare l l' = Eq <-> Forall2 (fun a a' => cmp a a' = Eq) l l'. 155 | Proof. 156 | split. 157 | - revert l'. 158 | induction l as [|a l IH]; destruct l' as [|b l']; simpl; try easy. 159 | rewrite lex_Eq; intuition. 160 | - induction 1; simpl; now rewrite ?lex_Eq. 161 | Qed. 162 | 163 | End ListComp. 164 | 165 | (** Extended comparisons on lists (used in [Tries.MMaps.Positive.compare]). 166 | An extra flag indicates whether the comparison between two lists 167 | ended : 168 | - because (at least) one list was emptied (EOL). 169 | - or because disequal elements where found (Early). 170 | In the second case, extending the lists on the right will not 171 | change the result of the comparison, while the first case is more 172 | delicate. *) 173 | 174 | Inductive flag := EOL | Early. 175 | 176 | Notation elex u v := 177 | match u with Eq => v | Lt => (Lt,Early) | Gt => (Gt,Early) end. 178 | 179 | Section ListExtComp. 180 | Variable A : Type. 181 | Variable cmp : A -> A -> comparison. 182 | Fixpoint list_ecompare (l1 l2 : list A) : comparison*flag := 183 | match l1, l2 with 184 | | [], [] => (Eq,EOL) 185 | | [], _ => (Lt,EOL) 186 | | _, [] => (Gt,EOL) 187 | | x1::l1', x2::l2' => elex (cmp x1 x2) (list_ecompare l1' l2') 188 | end. 189 | 190 | Lemma list_ecompare_fst l1 l2 : 191 | fst (list_ecompare l1 l2) = list_compare cmp l1 l2. 192 | Proof. 193 | revert l2. 194 | induction l1; destruct l2; simpl; auto. case cmp; auto. 195 | Qed. 196 | 197 | Lemma list_ecompare_eq_snd l1 l2 b : 198 | list_ecompare l1 l2 = (Eq,b) -> b = EOL. 199 | Proof. 200 | revert l2. 201 | induction l1; destruct l2; simpl; auto; try congruence. 202 | case cmp; try easy. eauto. 203 | Qed. 204 | 205 | Lemma list_ecompare_eq_app u v u' v' b : 206 | list_ecompare u u' = (Eq,b) -> 207 | list_ecompare (u++v) (u'++v') = list_ecompare v v'. 208 | Proof. 209 | revert u'; induction u; destruct u'; simpl; try easy. 210 | destruct cmp; now auto. 211 | Qed. 212 | 213 | Lemma list_ecompare_app u v u' v' : 214 | (forall x y, List.In x u' -> List.In y v -> cmp y x = Gt) -> 215 | (forall x y, List.In x u -> List.In y v' -> cmp x y = Lt) -> 216 | list_ecompare (u++v) (u'++v') = 217 | match list_ecompare u u' with 218 | | (Eq,_) => list_ecompare v v' 219 | | (c,Early) => (c,Early) 220 | | (Lt,EOL) => if v then (Lt,EOL) else (Gt,Early) 221 | | (Gt,EOL) => if v' then (Gt,EOL) else (Lt,Early) 222 | end. 223 | Proof. 224 | revert u'. 225 | induction u; destruct u'; intros GT LT; cbn; auto. 226 | - destruct v; simpl in *; auto. rewrite GT; auto. 227 | - destruct v'; simpl in *; auto. rewrite LT; auto. 228 | - case cmp; intuition. 229 | Qed. 230 | 231 | End ListExtComp. 232 | -------------------------------------------------------------------------------- /Sigma.v: -------------------------------------------------------------------------------- 1 | (** * Binary tries wrapped in a sigma type to enforce extensionality *) 2 | 3 | (* Author: Xavier Leroy, Collège de France and Inria. 4 | Copyright: Inria. 5 | License: BSD-3-Clause. *) 6 | 7 | From Coq Require Import PArith Program.Equality. 8 | From Tries Require Original. 9 | 10 | Set Implicit Arguments. 11 | 12 | Module PTree. 13 | 14 | Import Original.PTree. 15 | 16 | (** ** Representation of tries *) 17 | 18 | (** We start with the two-constructor representation of binary tries 19 | from module [Original] and work out a well-formedness criterion 20 | that, in the end, suffices to ensures extensionality. *) 21 | 22 | (** A trivially empty node is the subtree [Node Leaf None Leaf]. 23 | It contains no values, and is extensionally equivalent to [Leaf], 24 | but structurally different. Well-formed trees are those that 25 | contain no trivially empty nodes. *) 26 | 27 | Definition not_trivially_empty {A} (l: tree A) (o: option A) (r: tree A) := 28 | match l, o, r with 29 | | Leaf, None, Leaf => False 30 | | _, _, _ => True 31 | end. 32 | 33 | Lemma not_trivially_empty_left: forall A (l: tree A) (o: option A) (r: tree A), 34 | l <> Leaf -> not_trivially_empty l o r. 35 | Proof. 36 | intros; red. destruct l; auto. congruence. 37 | Qed. 38 | 39 | Lemma not_trivially_empty_val: forall A (l: tree A) (a: A) (r: tree A), 40 | not_trivially_empty l (Some a) r. 41 | Proof. 42 | intros; red. destruct l; auto. 43 | Qed. 44 | 45 | Lemma not_trivially_empty_right: forall A (l: tree A) (o: option A) (r: tree A), 46 | r <> Leaf -> not_trivially_empty l o r. 47 | Proof. 48 | intros; red. destruct l; auto. destruct o; auto. destruct r; auto. 49 | Qed. 50 | 51 | (** The [wf m] predicate states that the tree [m] is well formed, 52 | in the sense that all nodes it contains are not trivially empty. *) 53 | 54 | Inductive wf {A} : tree A -> Prop := 55 | | wf_leaf: wf Leaf 56 | | wf_node: forall l o r, 57 | wf l -> wf r -> not_trivially_empty l o r -> 58 | wf (Node l o r). 59 | 60 | (** Our type [t A] of extensional tries is a sigma type: 61 | it consists of pairs of an original trie [m] and a proof of [wf m]. *) 62 | 63 | Definition t (A: Type) := { m : tree A | wf m }. 64 | 65 | (** ** Basic operations: [empty], [get], [set], [remove] *) 66 | 67 | (** The operations over the sigma type [t A] are derived from those of the 68 | original implementation of binary tries, complemented with proofs 69 | of well-formedness. *) 70 | 71 | Definition empty (A: Type) : t A := 72 | exist _ (Original.PTree.empty A) wf_leaf. 73 | 74 | Definition get (A: Type) (i: positive) (m: t A) : option A := 75 | Original.PTree.get i (proj1_sig m). 76 | 77 | (** We prove that well-formedness is preserved by the [set] operation: 78 | it cannot create a trivially empty node. *) 79 | 80 | Lemma set_not_leaf: forall (A: Type) (v: A) i m, Original.PTree.set i v m <> Leaf. 81 | Proof. 82 | destruct i, m; simpl; congruence. 83 | Qed. 84 | 85 | Lemma wf_set: forall (A: Type) (v: A) i m, wf m -> wf (Original.PTree.set i v m). 86 | Proof. 87 | induction i; destruct 1; simpl; 88 | auto using wf_leaf, wf_node, not_trivially_empty_left, not_trivially_empty_right, not_trivially_empty_val, set_not_leaf. 89 | Qed. 90 | 91 | Definition set (A: Type) (i: positive) (v: A) (m: t A) : t A := 92 | exist _ (Original.PTree.set i v (proj1_sig m)) 93 | (wf_set v i (proj2_sig m)). 94 | 95 | (** The [Node'] smart constructor never creates a trivially empty node 96 | either. *) 97 | 98 | Lemma wf_Node': forall A (l: tree A) (o: option A) (r: tree A), 99 | wf l -> wf r -> wf (Node' l o r). 100 | Proof. 101 | destruct l, o, r; intros; simpl; constructor; simpl; auto. 102 | Qed. 103 | 104 | (** It follows that the [remove] operation preserves well-formedness. *) 105 | 106 | Lemma wf_remove: 107 | forall (A: Type) (m: tree A), wf m -> forall i, wf (Original.PTree.remove i m). 108 | Proof. 109 | induction 1; intros; simpl. 110 | - constructor. 111 | - destruct i; auto using wf_Node'. 112 | Qed. 113 | 114 | Definition remove (A: Type) (i: positive) (m: t A) : t A := 115 | exist _ (Original.PTree.remove i (proj1_sig m)) 116 | (wf_remove (proj2_sig m) i). 117 | 118 | (** ** Good variable properties for the basic operations *) 119 | 120 | (** The characterizations of [empty], [set] and [remove] in terms of 121 | [get] queries carry over directly from those of the 122 | original implementation. *) 123 | 124 | Theorem gempty: 125 | forall (A: Type) (i: positive), get i (empty A) = None. 126 | Proof. reflexivity. Qed. 127 | 128 | Theorem gss: 129 | forall (A: Type) (i: positive) (x: A) (m: t A), get i (set i x m) = Some x. 130 | Proof. 131 | intros; destruct m as [m wf]. apply Original.PTree.gss. 132 | Qed. 133 | 134 | Theorem gso: 135 | forall (A: Type) (i j: positive) (x: A) (m: t A), 136 | i <> j -> get i (set j x m) = get i m. 137 | Proof. 138 | intros; destruct m as [m wf]. apply Original.PTree.gso; auto. 139 | Qed. 140 | 141 | Theorem grs: 142 | forall (A: Type) (i: positive) (m: t A), get i (remove i m) = None. 143 | Proof. 144 | intros; destruct m as [m wf]. apply Original.PTree.grs. 145 | Qed. 146 | 147 | Theorem gro: 148 | forall (A: Type) (i j: positive) (m: t A), 149 | i <> j -> get i (remove j m) = get i m. 150 | Proof. 151 | intros; destruct m as [m wf]. apply Original.PTree.gro; auto. 152 | Qed. 153 | 154 | (** ** Extensionality property *) 155 | 156 | (** We first show that for well-formed tries, equivalence implies equality. 157 | In other words, the well-formedness criterion rules out all the cases 158 | where the original implementation of tries fails the extensionality property. *) 159 | 160 | Lemma extensionality_empty: 161 | forall A (m: tree A), 162 | wf m -> (forall i, Original.PTree.get i m = None) -> m = Leaf. 163 | Proof. 164 | induction 1; simpl; intros E. 165 | - auto. 166 | - assert (l = Leaf). { apply IHwf1. intros. apply (E (xO i)). } 167 | assert (r = Leaf). { apply IHwf2. intros. apply (E (xI i)). } 168 | destruct o eqn:O. 169 | specialize (E xH). discriminate. 170 | subst l r. simpl in H1. tauto. 171 | Qed. 172 | 173 | Lemma extensionality_rec: 174 | forall A (m1: tree A), wf m1 -> forall (m2: tree A), wf m2 -> 175 | (forall i, Original.PTree.get i m1 = Original.PTree.get i m2) -> 176 | m1 = m2. 177 | Proof. 178 | induction 1. 179 | - intros m2 WF2 E. symmetry. apply extensionality_empty; auto. 180 | intros. symmetry. apply E. 181 | - destruct 1; intros E. 182 | + apply extensionality_empty. constructor; auto. 183 | intros. apply E. 184 | + f_equal. 185 | * apply IHwf1; auto. intros. apply (E (xO i)). 186 | * apply (E xH). 187 | * apply IHwf2; auto. intros. apply (E (xI i)). 188 | Qed. 189 | 190 | (** To show that two values of type [t A] are equal, it is not enough to show that 191 | their data parts (first projections [proj1_sig]) are equal, which follows 192 | from the [extensionality_rec] lemma above: we must also show that their proof parts 193 | (second projections [proj2_sig]) are equal too. 194 | 195 | To this end, we need to show the unique proof property for the [wf m] predicate: 196 | two proofs of [wf m] are always equal. We could just assert 197 | the proof irrelevance axiom and the result would follow trivially. 198 | However, we also have a proof without axioms. *) 199 | 200 | Lemma not_trivially_empty_unique_proofs: 201 | forall A (l: tree A) (o: option A) (r: tree A) (p1 p2: not_trivially_empty l o r), 202 | p1 = p2. 203 | Proof. 204 | unfold not_trivially_empty; intros. 205 | destruct l, o, r, p1, p2; auto. 206 | Qed. 207 | 208 | Lemma wf_unique_proofs: 209 | forall A (m: tree A) (p1 p2: wf m), p1 = p2. 210 | Proof. 211 | induction m; intros; dependent destruction p1; dependent destruction p2. 212 | - auto. 213 | - f_equal; auto using not_trivially_empty_unique_proofs. 214 | Qed. 215 | 216 | (** The desired extensionality property follows. *) 217 | 218 | Theorem extensionality: 219 | forall A (m1 m2: t A), 220 | (forall i, get i m1 = get i m2) -> m1 = m2. 221 | Proof. 222 | intros A [m1 p1] [m2 p2] E. 223 | assert (m1 = m2) by (apply extensionality_rec; auto). 224 | subst m2. 225 | assert (p1 = p2) by (apply wf_unique_proofs). 226 | subst p2. 227 | auto. 228 | Qed. 229 | 230 | End PTree. 231 | -------------------------------------------------------------------------------- /GADT.v: -------------------------------------------------------------------------------- 1 | (** * Binary tries using a GADT to enforce extensionality *) 2 | 3 | (* Author: Xavier Leroy, Collège de France and Inria. 4 | Copyright: Inria. 5 | License: BSD-3-Clause. *) 6 | 7 | From Coq Require Import PArith. 8 | 9 | Set Implicit Arguments. 10 | 11 | Module PTree. 12 | 13 | (** ** Representation of tries *) 14 | 15 | (** We start with the two-constructor representation of binary tries 16 | from module [Original] and add a parameter of type [kind] to the datatype, 17 | indicating whether the binary trie is empty or nonempty. *) 18 | 19 | Inductive kind : Type := Empty | Nonempty. 20 | 21 | (** As in the [Sigma] implementation, we want to exclude trivially empty nodes 22 | [Node l None r] where both subtrees [l] and [r] are empty. 23 | Unlike in the [Sigma] implementation, we express this criterion 24 | indirectly, using the kinds [kl] of [l] and [kr] of [r]. *) 25 | 26 | Definition not_trivially_empty {A} (kl: kind) (o: option A) (kr: kind) := 27 | match kl, o, kr with 28 | | Empty, None, Empty => False 29 | | _, _, _ => True 30 | end. 31 | 32 | Lemma not_trivially_empty_left: forall A (o: option A) (kr: kind), 33 | not_trivially_empty Nonempty o kr. 34 | Proof. 35 | intros; red; auto. 36 | Qed. 37 | 38 | Lemma not_trivially_empty_val: forall A (kl: kind) (a: A) (kr: kind), 39 | not_trivially_empty kl (Some a) kr. 40 | Proof. 41 | intros; red. destruct kl; auto. 42 | Qed. 43 | 44 | Lemma not_trivially_empty_right: forall A (kl: kind) (o: option A), 45 | not_trivially_empty kl o Nonempty. 46 | Proof. 47 | intros; red. destruct kl; auto. destruct o; auto. 48 | Qed. 49 | 50 | (** The representation type for tries, with the extra parameter of 51 | type kind that classifies tries as empty or nonempty. In the 52 | [Node] case, we add a proof that the node is not trivially empty. *) 53 | 54 | Inductive tree (A : Type) : kind -> Type := 55 | | Leaf : tree A Empty 56 | | Node : forall (kl kr: kind) (l: tree A kl) (o: option A) (r: tree A kr), 57 | not_trivially_empty kl o kr -> tree A Nonempty. 58 | 59 | Arguments Leaf {A}. 60 | Arguments Node [A kl kr]. 61 | 62 | (** The type of tries (empty or nonempty) is a dependent sum of 63 | an empty/nonempty kind and a representation of that kind. 64 | In other words, we quantify existentially over the kind. *) 65 | 66 | Definition t (A: Type) := { k : kind & tree A k }. 67 | 68 | (** ** Basic operations: [empty], [get], [set], [remove] *) 69 | 70 | Definition empty (A : Type) : t A := existT _ Empty (@Leaf A). 71 | 72 | (** Operations such as [get] are typically split in two functions: 73 | a function [get'] that works over type [tree A k] and is polymorphic 74 | over the kind [k], and a wrapper function [get] that deals with the 75 | existential quantification over the kind [k]. *) 76 | 77 | Fixpoint get' (A : Type) (k: kind) (i : positive) (m : tree A k) {struct i} : option A := 78 | match m with 79 | | Leaf => None 80 | | Node l o r _ => 81 | match i with 82 | | xH => o 83 | | xO ii => get' ii l 84 | | xI ii => get' ii r 85 | end 86 | end. 87 | 88 | Definition get (A: Type) (i : positive) (m : t A) : option A := 89 | match m with existT _ k m => get' i m end. 90 | 91 | (** [set'] has a lovely result type [tree A Nonempty], proving that the result 92 | is never the empty trie. *) 93 | 94 | Fixpoint set' (A : Type) (k: kind) (i : positive) (v : A) (m : tree A k) {struct i} : tree A Nonempty := 95 | match m with 96 | | Leaf => 97 | match i with 98 | | xH => Node Leaf (Some v) Leaf (not_trivially_empty_val _ _ _) 99 | | xO ii => Node (set' ii v Leaf) None Leaf (not_trivially_empty_left _ _) 100 | | xI ii => Node Leaf None (set' ii v Leaf) (not_trivially_empty_right _ _) 101 | end 102 | | Node l o r _ => 103 | match i with 104 | | xH => Node l (Some v) r (not_trivially_empty_val _ _ _) 105 | | xO ii => Node (set' ii v l) o r (not_trivially_empty_left _ _) 106 | | xI ii => Node l o (set' ii v r) (not_trivially_empty_right _ _) 107 | end 108 | end. 109 | 110 | Definition set (A: Type) (i: positive) (v: A) (m: t A) : t A := 111 | match m with existT _ _ m => existT _ Nonempty (set' i v m) end. 112 | 113 | (** This is the smart constructor [Node'] that combines any two subtrees 114 | and optional value into a well-formed value of type [t A]. *) 115 | 116 | Definition Node' (A: Type) (kl kr: kind) (l: tree A kl) (o: option A) (r: tree A kr) : t A := 117 | match o with 118 | | Some v as o' => existT _ Nonempty (Node l o' r (not_trivially_empty_val _ _ _)) 119 | | None => 120 | match l with 121 | | Node _ _ _ _ as l' => 122 | existT _ Nonempty (Node l' None r (not_trivially_empty_left _ _)) 123 | | Leaf => 124 | match r with 125 | | Node _ _ _ _ as r' => 126 | existT _ Nonempty (Node Leaf None r' (not_trivially_empty_right _ _)) 127 | | Leaf => 128 | existT _ Empty Leaf 129 | end 130 | end 131 | end. 132 | 133 | (** Sometimes, one of the subtrees has type [t A] instead of [tree A k]. *) 134 | 135 | Definition Node'l (A: Type) kr (l: t A) (o: option A) (r: tree A kr) : t A := 136 | match l with existT _ _ ll => Node' ll o r end. 137 | 138 | Definition Node'r (A: Type) kl (l: tree A kl) (o: option A) (r: t A) : t A := 139 | match r with existT _ _ rr => Node' l o rr end. 140 | 141 | (** The [remove] function makes good use of these smart constructors. *) 142 | 143 | Fixpoint remove' (A : Type) (k: kind) (i : positive) (m : tree A k) {struct i} : t A := 144 | match i with 145 | | xH => 146 | match m with 147 | | Leaf => empty A 148 | | Node l o r _ => Node' l None r 149 | end 150 | | xO ii => 151 | match m with 152 | | Leaf => empty A 153 | | Node l o r _ => Node'l (remove' ii l) o r 154 | end 155 | | xI ii => 156 | match m with 157 | | Leaf => empty A 158 | | Node l o r _ => Node'r l o (remove' ii r) 159 | end 160 | end. 161 | 162 | Definition remove (A : Type) (i : positive) (m : t A) : t A := 163 | match m with existT _ _ m => remove' i m end. 164 | 165 | (** ** Good variable properties for the basic operations *) 166 | 167 | Lemma gleaf: 168 | forall (A : Type) (i : positive), get' i (Leaf : tree A Empty) = None. 169 | Proof. destruct i; auto. Qed. 170 | 171 | Theorem gempty: 172 | forall (A: Type) (i: positive), get i (empty A) = None. 173 | Proof. intros. apply gleaf. Qed. 174 | 175 | Lemma gss': 176 | forall (A: Type) (i: positive) (x: A) (k: kind) (m: tree A k), 177 | get' i (set' i x m) = Some x. 178 | Proof. 179 | induction i; destruct m; simpl; auto. 180 | Qed. 181 | 182 | Theorem gss: 183 | forall (A: Type) (i: positive) (x: A) (m: t A), get i (set i x m) = Some x. 184 | Proof. 185 | intros. destruct m as [k m]; simpl. apply gss'. 186 | Qed. 187 | 188 | Lemma gso': 189 | forall (A: Type) (i j: positive) (x: A) k (m: tree A k), 190 | i <> j -> get' i (set' j x m) = get' i m. 191 | Proof. 192 | induction i; intros; destruct j; destruct m; simpl; 193 | try rewrite <- (gleaf A i); auto; try apply IHi; congruence. 194 | Qed. 195 | 196 | Theorem gso: 197 | forall (A: Type) (i j: positive) (x: A) (m: t A), 198 | i <> j -> get i (set j x m) = get i m. 199 | Proof. 200 | intros. destruct m as [k m]; simpl. apply gso'; auto. 201 | Qed. 202 | 203 | Lemma gnode': 204 | forall (A: Type) kl (l: tree A kl) kr (r: tree A kr) o i, 205 | get i (Node' l o r) = 206 | match i with xH => o | xO i => get' i l | xI i => get' i r end. 207 | Proof. 208 | intros. unfold Node'. 209 | destruct o; [ | destruct l; [ destruct r | ]]; 210 | destruct i; simpl; rewrite ? gleaf; auto. 211 | Qed. 212 | 213 | Lemma gnode'l: 214 | forall (A: Type) (l: t A) kr (r: tree A kr) o i, 215 | get i (Node'l l o r) = 216 | match i with xH => o | xO i => get i l | xI i => get' i r end. 217 | Proof. 218 | intros. destruct l as [kl l]; simpl. apply gnode'. 219 | Qed. 220 | 221 | Lemma gnode'r: 222 | forall (A: Type) kl (l: tree A kl) (r: t A) o i, 223 | get i (Node'r l o r) = 224 | match i with xH => o | xO i => get' i l | xI i => get i r end. 225 | Proof. 226 | intros. destruct r as [kr r]; simpl. apply gnode'. 227 | Qed. 228 | 229 | Lemma grs': 230 | forall (A: Type) (i: positive) k (m: tree A k), get i (remove' i m) = None. 231 | Proof. 232 | Local Opaque Node'. 233 | induction i; destruct m; simpl remove'; auto; rewrite ?gleaf, ?gnode', ?gnode'l, ?gnode'r; auto. 234 | Qed. 235 | 236 | Theorem grs: 237 | forall (A: Type) (i: positive) (m: t A), get i (remove i m) = None. 238 | Proof. 239 | intros. destruct m as [k m]. apply grs'. 240 | Qed. 241 | 242 | Lemma gro': 243 | forall (A: Type) (i j: positive) k (m: tree A k), 244 | i <> j -> get i (remove' j m) = get' i m. 245 | Proof. 246 | induction i; intros; destruct j; destruct m; simpl remove'; 247 | rewrite ?gnode', ?gnode'l, ?gnode'r, ?gleaf; auto; simpl. 248 | apply IHi; congruence. 249 | apply IHi; congruence. 250 | congruence. 251 | Qed. 252 | 253 | Theorem gro: 254 | forall (A: Type) (i j: positive) (m: t A), 255 | i <> j -> get i (remove j m) = get i m. 256 | Proof. 257 | intros. destruct m as [k m]. apply gro'; auto. 258 | Qed. 259 | 260 | (** ** The extensionality property *) 261 | 262 | (** This is the key lemma to show extensionality: a value of type [tree A k] 263 | that contains no data (all [get'] queries return [None]) 264 | is equal to [Leaf], and moreover its kind [k] is [Empty]. *) 265 | 266 | Lemma extensionality_empty: 267 | forall (A: Type) k (m: tree A k), 268 | (forall i, get' i m = None) -> 269 | exists E: k = Empty, eq_rect _ _ m _ E = Leaf. 270 | Proof. 271 | induction m; intros G. 272 | - exists refl_equal; auto. 273 | - destruct IHm1 as (E1 & F1). { intros; apply (G (xO i)). } 274 | destruct IHm2 as (E2 & F2). { intros; apply (G (xI i)). } 275 | assert (o = None). { apply (G xH). } 276 | subst kl kr o. elim n. 277 | Qed. 278 | 279 | (** As in the [Sigma] implementation, we also need the "uniqueness of 280 | proofs" property for the [not_trivially_empty] predicate. We 281 | could assume the proof irrelevance axiom and get it for free, but 282 | it's not hard to show the property without using axioms. *) 283 | 284 | Lemma not_trivially_empty_unique_proofs: 285 | forall A kl (o: option A) kr (p1 p2: not_trivially_empty kl o kr), 286 | p1 = p2. 287 | Proof. 288 | unfold not_trivially_empty; intros. 289 | destruct kl, o, kr, p1, p2; auto. 290 | Qed. 291 | 292 | (** It follows that two trees that are equivalent (all [get'] queries agree) 293 | have the same kind and are equal. The subtle point here is that the 294 | two trees cannot be assumed to have the same kind, otherwise the 295 | induction does not go through. *) 296 | 297 | Lemma extensionality_rec: 298 | forall (A: Type) k1 (m1: tree A k1) k2 (m2: tree A k2), 299 | (forall i, get' i m1 = get' i m2) -> 300 | exists E: k1 = k2, eq_rect _ _ m1 _ E = m2. 301 | Proof. 302 | induction m1 as [ | kl1 kr1 l1 LREC o1 r1 RREC NT1]. 303 | - intros. destruct (extensionality_empty m2) as (E1 & E2). 304 | { intros. rewrite <- H. apply gleaf. } 305 | subst k2. simpl in E2. subst m2. exists refl_equal; auto. 306 | - destruct m2 as [ | kl2 kr2 l2 o2 r2 NT2]; intros SAME. 307 | + apply extensionality_empty. 308 | intros. rewrite SAME. apply gleaf. 309 | + destruct (LREC kl2 l2) as (EL & FL). { intros. apply (SAME (xO i)). } 310 | destruct (RREC kr2 r2) as (ER & FR). { intros. apply (SAME (xI i)). } 311 | assert (o1 = o2). { apply (SAME xH). } 312 | subst kl2 kr2. simpl in FL. simpl in FR. subst l2 o2 r2. 313 | assert (NT1 = NT2). { apply not_trivially_empty_unique_proofs. } 314 | subst NT2. 315 | exists refl_equal; auto. 316 | Qed. 317 | 318 | Theorem extensionality: 319 | forall (A: Type) (m1: t A) (m2: t A), 320 | (forall i, get i m1 = get i m2) -> 321 | m1 = m2. 322 | Proof. 323 | intros. destruct m1 as [k1 m1], m2 as [k2 m2]; simpl in *. 324 | destruct (extensionality_rec m1 m2) as (E1 & E2). auto. 325 | subst k2. simpl in E2. subst m2. auto. 326 | Qed. 327 | 328 | End PTree. 329 | -------------------------------------------------------------------------------- /CharTrie.v: -------------------------------------------------------------------------------- 1 | (** * Dictionaries implemented as character-based tries *) 2 | 3 | (* Author: Xavier Leroy, Collège de France and Inria. 4 | Copyright: Inria. 5 | License: BSD-3-Clause. *) 6 | 7 | From Coq Require Import Ascii String OrderedType. 8 | From Tries Require Import AsciiOrder. 9 | 10 | Module AO := OrderedAscii. 11 | Module AOF := OrderedTypeFacts AO. 12 | 13 | Ltac inv H := inversion H; subst; clear H. 14 | 15 | Module Stringmap. 16 | 17 | Module Raw. 18 | 19 | Section STRINGMAP. 20 | 21 | Context {A: Type}. 22 | 23 | (** ** Representation of tries *) 24 | 25 | (** The data structure is a trie where each node carries a mapping from 26 | characters (Coq type [ascii]) to subtrees. In other words, this is 27 | a trie with a branching factor of 256 at each node. 28 | The mapping from characters to subtrees is represented sparsely 29 | as a sorted association list, with type [forest] below. *) 30 | 31 | Inductive tree := 32 | | Empty: tree 33 | | Node : option A -> forest -> tree 34 | with forest : Type := 35 | | Nil : forest 36 | | Cons: ascii -> tree -> forest -> forest. 37 | 38 | Fixpoint In_forest (x: ascii) (f: forest) : Prop := 39 | match f with 40 | | Nil => False 41 | | Cons k t f => x = k \/ In_forest x f 42 | end. 43 | 44 | (** The well-formedness invariant states that the association lists 45 | are sorted, i.e. characters occur in increasing order. *) 46 | 47 | Inductive wf: tree -> Prop := 48 | | wf_Empty: wf Empty 49 | | wf_Node: forall ov f, wff f -> wf (Node ov f) 50 | with wff: forest -> Prop := 51 | | wff_Nil: wff Nil 52 | | wff_Cons: forall k t f, 53 | wf t -> wff f -> 54 | (forall x, In_forest x f -> AO.lt k x) -> 55 | wff (Cons k t f). 56 | 57 | (** ** Basic operations: [empty], [get], [set], [remove] *) 58 | 59 | Fixpoint get (s: string) (m: tree) {struct m} : option A := 60 | match m, s with 61 | | Empty, _ => None 62 | | Node v _, EmptyString => v 63 | | Node _ cl, String x s => getf x s cl 64 | end 65 | with getf (x: ascii) (s: string) (f: forest) : option A := 66 | match f with 67 | | Nil => None 68 | | Cons k t f => 69 | match AO.compare x k with 70 | | LT _ => None 71 | | EQ _ => get s t 72 | | GT _ => getf x s f 73 | end 74 | end. 75 | 76 | Fixpoint singleton (s: string) (v: A) : tree := 77 | match s with 78 | | EmptyString => Node (Some v) Nil 79 | | String x s => Node None (Cons x (singleton s v) Nil) 80 | end. 81 | 82 | Fixpoint set (s: string) (v: A) (m: tree) {struct m} : tree := 83 | match m, s with 84 | | Empty, _ => singleton s v 85 | | Node _ cl, EmptyString => Node (Some v) cl 86 | | Node v0 cl, String x s => Node v0 (setf x s v cl) 87 | end 88 | with setf (x: ascii) (s: string) (v: A) (f: forest) {struct f} : forest := 89 | match f with 90 | | Nil => Cons x (singleton s v) Nil 91 | | Cons k c f' => 92 | match AO.compare x k with 93 | | LT _ => Cons x (singleton s v) f 94 | | EQ _ => Cons k (set s v c) f' 95 | | GT _ => Cons k c (setf x s v f') 96 | end 97 | end. 98 | 99 | (** Smart constructors for [Node] and [Cons] that avoid the creation 100 | of trivially empty trees or forests. *) 101 | 102 | Definition Node' (ov: option A) (f: forest) : tree := 103 | match ov, f with 104 | | None, Nil => Empty 105 | | _, _ => Node ov f 106 | end. 107 | 108 | Definition Cons' (x: ascii) (t: tree) (f: forest) : forest := 109 | match t with Empty => f | _ => Cons x t f end. 110 | 111 | Fixpoint remove (s: string) (m: tree) {struct m} : tree := 112 | match m, s with 113 | | Empty, _ => Empty 114 | | Node _ cl, EmptyString => Node' None cl 115 | | Node v0 cl, String x s => Node' v0 (removef x s cl) 116 | end 117 | with removef (x: ascii) (s: string) (f: forest) {struct f} : forest := 118 | match f with 119 | | Nil => Nil 120 | | Cons k c f' => 121 | match AO.compare x k with 122 | | LT _ => f 123 | | EQ _ => Cons' k (remove s c) f' 124 | | GT _ => Cons k c (removef x s f') 125 | end 126 | end. 127 | 128 | (** ** Well-formedness properties for the basic operations *) 129 | 130 | Lemma getf_In: 131 | forall x s v f, getf x s f = Some v -> In_forest x f. 132 | Proof. 133 | induction f; simpl; intros. 134 | - discriminate. 135 | - destruct (AO.compare x a). 136 | + discriminate. 137 | + red in e; auto. 138 | + auto. 139 | Qed. 140 | 141 | Lemma getf_notIn: 142 | forall x s f, ~(In_forest x f) -> getf x s f = None. 143 | Proof. 144 | intros. destruct (getf x s f) as [v|] eqn:G; auto. elim H. eapply getf_In; eauto. 145 | Qed. 146 | 147 | Lemma wf_singleton: forall v s, wf (singleton s v). 148 | Proof. 149 | induction s as [ | x s]; simpl. 150 | - repeat constructor. 151 | - repeat constructor. auto. simpl; tauto. 152 | Qed. 153 | 154 | Remark In_setf: 155 | forall k x s v f, In_forest k (setf x s v f) <-> k = x \/ In_forest k f. 156 | Proof. 157 | induction f; simpl. 158 | - tauto. 159 | - destruct (AO.compare x a); simpl. 160 | + tauto. 161 | + red in e; subst x. tauto. 162 | + rewrite IHf. tauto. 163 | Qed. 164 | 165 | Lemma wf_set: forall m, wf m -> forall s v, wf (set s v m) 166 | with wf_setf: forall f, wff f -> forall x s v, wff (setf x s v f). 167 | Proof. 168 | - destruct 1; simpl; intros. 169 | + apply wf_singleton. 170 | + destruct s as [ | x s]. constructor; auto. constructor; apply wf_setf; auto. 171 | - destruct 1; simpl; intros. 172 | + repeat constructor. apply wf_singleton. simpl; tauto. 173 | + destruct (AO.compare x k). 174 | * constructor. apply wf_singleton. constructor; auto. 175 | simpl; intros y [E|E]. subst; auto. eapply AO.lt_trans; eauto. 176 | * constructor. apply wf_set; auto. auto. auto. 177 | * constructor. auto. apply wf_setf; auto. 178 | intros y I. rewrite In_setf in I; destruct I as [I|I]. 179 | subst; auto. auto. 180 | Qed. 181 | 182 | Lemma wf_Node': forall ov f, wff f -> wf (Node' ov f). 183 | Proof. 184 | unfold Node'; intros; destruct ov, f; constructor; auto. 185 | Qed. 186 | 187 | Lemma get_Node': forall s ov f, 188 | get s (Node' ov f) = get s (Node ov f). 189 | Proof. 190 | intros. unfold Node'; destruct ov, f; auto. simpl. destruct s; auto. 191 | Qed. 192 | 193 | Lemma wf_Cons': forall k t f, 194 | wff (Cons k t f) -> wff (Cons' k t f). 195 | Proof. 196 | unfold Cons'; intros. destruct t; auto. inv H; auto. 197 | Qed. 198 | 199 | Lemma In_Cons': forall x k t f, 200 | In_forest x (Cons' k t f) -> x = k \/ In_forest x f. 201 | Proof. 202 | unfold Cons'; intros. destruct t; auto. 203 | Qed. 204 | 205 | Lemma getf_Cons': forall x s k t f, 206 | wff (Cons k t f) -> 207 | getf x s (Cons' k t f) = getf x s (Cons k t f). 208 | Proof. 209 | unfold Cons'; intros. destruct t; auto. simpl. inv H. 210 | assert (P: ~AO.lt k x -> getf x s f = None). 211 | { intros. apply getf_notIn. red; intros; elim H; auto. } 212 | destruct (AO.compare x k); auto. 213 | apply P. apply AOF.lt_not_gt; auto. 214 | apply P. apply AOF.eq_not_gt; auto. 215 | Qed. 216 | 217 | Remark In_removef: 218 | forall k x s f, In_forest k (removef x s f) -> In_forest k f. 219 | Proof. 220 | induction f; simpl. 221 | - tauto. 222 | - destruct (AO.compare x a); simpl. 223 | + tauto. 224 | + red in e; subst x. intros. eapply In_Cons'; eauto. 225 | + tauto. 226 | Qed. 227 | 228 | Lemma wf_remove: forall m, wf m -> forall s, wf (remove s m) 229 | with wf_removef: forall f, wff f -> forall x s, wff (removef x s f). 230 | Proof. 231 | Local Opaque Node'. 232 | - destruct 1; simpl; intros. 233 | + constructor. 234 | + destruct s as [ | x s]; apply wf_Node'; auto. 235 | - destruct 1; simpl; intros. 236 | + constructor. 237 | + destruct (AO.compare x k). 238 | * constructor; auto. 239 | * apply wf_Cons'. constructor; auto. 240 | * constructor; auto. intros. apply H1. eapply In_removef; eauto. 241 | Qed. 242 | 243 | (** ** Good variable properties for the basic operations *) 244 | 245 | Lemma gsings: forall v s, get s (singleton s v) = Some v. 246 | Proof. 247 | induction s as [ | x s]; simpl. 248 | - auto. 249 | - AOF.elim_comp_eq x x. auto. 250 | Qed. 251 | 252 | Lemma gsingo: forall v s s', s' <> s -> get s' (singleton s v) = None. 253 | Proof. 254 | induction s as [ | x s]; destruct s' as [ | x' s']; intros; simpl. 255 | - congruence. 256 | - auto. 257 | - auto. 258 | - destruct (AO.compare x' x); auto. 259 | apply IHs. red in e; congruence. 260 | Qed. 261 | 262 | Lemma gss: forall m, wf m -> forall v s, get s (set s v m) = Some v 263 | with gssf: forall f, wff f -> forall x s v, getf x s (setf x s v f) = Some v. 264 | Proof. 265 | - destruct 1; simpl; intros. 266 | + apply gsings. 267 | + destruct s as [ | x s]. auto. apply gssf; auto. 268 | - destruct 1; simpl; intros. 269 | + AOF.elim_comp_eq x x. apply gsings. 270 | + destruct (AO.compare x k); simpl. 271 | * AOF.elim_comp_eq x x. apply gsings. 272 | * AOF.elim_comp_eq x k. apply gss; auto. 273 | * AOF.elim_comp_gt x k. apply gssf; auto. 274 | Qed. 275 | 276 | Lemma gso: 277 | forall m, wf m -> 278 | forall v s s', 279 | s' <> s -> get s' (set s v m) = get s' m 280 | with gsof: 281 | forall f, wff f -> 282 | forall x s v x' s', 283 | String x' s' <> String x s -> getf x' s' (setf x s v f) = getf x' s' f. 284 | Proof. 285 | - destruct 1; simpl; intros. 286 | + apply gsingo; auto. 287 | + destruct s as [ | x s]; destruct s' as [ | x' s']; simpl. 288 | * congruence. 289 | * auto. 290 | * auto. 291 | * apply gsof; auto. 292 | - destruct 1; intros; simpl. 293 | + destruct (AO.compare x' x); auto. 294 | red in e. apply gsingo; congruence. 295 | + destruct (AO.compare x k); simpl. 296 | * destruct (AO.compare x' x). 297 | ** AOF.elim_comp_lt x' k. auto. eapply AO.lt_trans; eauto. 298 | ** red in e; subst x'. AOF.elim_comp_lt x k. apply gsingo. congruence. 299 | ** auto. 300 | * destruct (AO.compare x' k); auto. apply gso; auto. red in e; red in e0; congruence. 301 | * destruct (AO.compare x' k); auto. 302 | Qed. 303 | 304 | Lemma grs: forall m, wf m -> forall s, get s (remove s m) = None 305 | with grsf: forall f, wff f -> forall x s, getf x s (removef x s f) = None. 306 | Proof. 307 | - destruct 1; intros; simpl. 308 | + auto. 309 | + destruct s as [ | x s]; rewrite get_Node'. auto. apply grsf; auto. 310 | - destruct 1; intros; simpl. 311 | + auto. 312 | + destruct (AO.compare x k); simpl. 313 | * AOF.elim_comp_lt x k. auto. 314 | * rewrite getf_Cons'. simpl. AOF.elim_comp_eq x k. apply grs; auto. 315 | constructor; auto using wf_remove. 316 | * AOF.elim_comp_gt x k. apply grsf; auto. 317 | Qed. 318 | 319 | Lemma gro: forall m, wf m -> forall s s', s' <> s -> get s' (remove s m) = get s' m 320 | with grof: forall f, wff f -> forall x s x' s', String x' s' <> String x s -> getf x' s' (removef x s f) = getf x' s' f. 321 | Proof. 322 | - destruct 1; intros; simpl. 323 | + auto. 324 | + destruct s as [ | x s]; destruct s' as [ | x' s']; subst; rewrite get_Node'; simpl. 325 | * congruence. 326 | * auto. 327 | * auto. 328 | * apply grof; auto. 329 | - destruct 1; intros; simpl. 330 | + auto. 331 | + destruct (AO.compare x k); simpl. 332 | * auto. 333 | * rewrite getf_Cons'. simpl. destruct (AO.compare x' k); auto. 334 | apply gro; auto. red in e; red in e0; congruence. 335 | constructor; auto using wf_remove. 336 | * destruct (AO.compare x' k); auto. 337 | Qed. 338 | 339 | End STRINGMAP. 340 | 341 | Arguments tree: clear implicits. 342 | 343 | End Raw. 344 | 345 | (** ** Wrapping the data type and its well-formedness invariant in a sigma type *) 346 | 347 | Definition t (A: Type) := { m: Raw.tree A | Raw.wf m }. 348 | 349 | Definition empty (A: Type) : t A := exist _ Raw.Empty Raw.wf_Empty. 350 | 351 | Definition get {A: Type} (s: string) (m: t A) : option A := 352 | Raw.get s (proj1_sig m). 353 | 354 | Definition set {A: Type} (s: string) (v: A) (m: t A) : t A := 355 | exist _ (Raw.set s v (proj1_sig m)) (Raw.wf_set (proj1_sig m) (proj2_sig m) s v). 356 | 357 | Definition remove {A: Type} (s: string) (m: t A) : t A := 358 | exist _ (Raw.remove s (proj1_sig m)) (Raw.wf_remove (proj1_sig m) (proj2_sig m) s). 359 | 360 | Theorem gempty: forall (A: Type) s, get s (empty A) = None. 361 | Proof. intros; reflexivity. Qed. 362 | 363 | Theorem gss: forall (A: Type) s v (m: t A), get s (set s v m) = Some v. 364 | Proof. intros; apply Raw.gss. apply proj2_sig. Qed. 365 | 366 | Theorem gso: forall (A: Type) s s' v (m: t A), s' <> s -> get s' (set s v m) = get s' m. 367 | Proof. intros; apply Raw.gso; auto. apply proj2_sig. Qed. 368 | 369 | Theorem gsspec: forall (A: Type) s s' v (m: t A), 370 | get s' (set s v m) = if string_dec s' s then Some v else get s' m. 371 | Proof. intros. destruct (string_dec s' s). subst; apply gss. apply gso; auto. Qed. 372 | 373 | Theorem grs: forall (A: Type) s (m: t A), get s (remove s m) = None. 374 | Proof. intros; apply Raw.grs. apply proj2_sig. Qed. 375 | 376 | Theorem gro: forall (A: Type) s s' (m: t A), s' <> s -> get s' (remove s m) = get s' m. 377 | Proof. intros; apply Raw.gro; auto. apply proj2_sig. Qed. 378 | 379 | Theorem grspec: forall (A: Type) s s' (m: t A), 380 | get s' (remove s m) = if string_dec s' s then None else get s' m. 381 | Proof. intros. destruct (string_dec s' s). subst; apply grs. apply gro; auto. Qed. 382 | 383 | End Stringmap. 384 | -------------------------------------------------------------------------------- /MMaps/Interface.v: -------------------------------------------------------------------------------- 1 | 2 | (** * Finite Modular Maps : Main Interface *) 3 | 4 | (** Author : Pierre Letouzey (Université de Paris - INRIA), 5 | adapted from earlier works in Coq Standard Library, see README.md. 6 | Licence : LGPL 2.1, see file LICENSE. *) 7 | 8 | From Coq Require Export Bool Equalities Orders SetoidList. 9 | From Tries.MMaps Require Import Comparisons. 10 | Set Implicit Arguments. 11 | Unset Strict Implicit. 12 | 13 | (** This MMap library of finite modular maps aims at associating keys 14 | to data efficiently. It is strongly inspired by the OCaml Map library. 15 | When compared with OCaml, the main signature is here split in two: 16 | 17 | - The first part [WS] proposes a signature for "weak" maps, 18 | i.e. maps with no ordering on the key type nor the data type. 19 | For obtaining an instance of this interface, a decidable equality 20 | on keys in enough, see for example [Tries.MMaps.WeakList]. 21 | This signature contains the usual operators: [add], [find]... 22 | Note that the [equal] function on maps expects as first argument 23 | a boolean comparison on data, as in OCaml. More details about map 24 | equalities and comparison at the bottom of this file. 25 | 26 | - Then comes signature [S], that extends [WS] to the case where 27 | the key type is ordered. The main novelty is that [bindings] is 28 | required to produce sorted lists. A ternary [compare] function 29 | on maps is also provided, whose first argument should be a ternary 30 | comparison on data. 31 | 32 | If unsure, what you're looking for is probably [S], and one 33 | of its implementation such as [Tries.MMaps.RBT]. 34 | 35 | Some additional differences with OCaml: 36 | 37 | - No [iter] function, useless since Coq is purely functional 38 | 39 | - [option] types are used instead of [Not_found] exceptions. 40 | Said otherwise, [find] below is OCaml's recent [find_opt] function. 41 | *) 42 | 43 | Definition Cmp {elt:Type}(cmp:elt->elt->bool) e1 e2 := cmp e1 e2 = true. 44 | 45 | Definition Fst {A B}(R:relation A) : relation (A*B) := 46 | fun p p' => R (fst p) (fst p'). 47 | 48 | Definition Duo {A B}(RA:relation A)(RB:relation B) : relation (A*B) := 49 | fun p p' => RA (fst p) (fst p') /\ RB (snd p) (snd p'). 50 | 51 | Definition prodmap {A B} (f:A->B) '(a1,a2) := (f a1, f a2). 52 | 53 | (** ** Weak signature for maps 54 | 55 | No requirements for an ordering on keys nor elements, only decidability 56 | of equality on keys [K]. *) 57 | 58 | Module Type WS (K : DecidableType). 59 | 60 | Definition key := K.t. 61 | 62 | Parameter t : Type -> Type. 63 | (** the abstract type of maps *) 64 | 65 | Section Ops. 66 | Parameter empty : forall {elt}, t elt. 67 | (** The empty map. *) 68 | 69 | Variable elt:Type. 70 | 71 | Parameter is_empty : t elt -> bool. 72 | (** Test whether a map is empty or not. *) 73 | 74 | Parameter singleton : key -> elt -> t elt. 75 | (** [singleton x y] returns the one-element map that contains 76 | a binding of [x] to [y]. *) 77 | 78 | Parameter add : key -> elt -> t elt -> t elt. 79 | (** [add x y m] returns a map containing the same bindings as [m], 80 | plus a binding of [x] to [y]. If [x] was already bound in [m], 81 | its previous binding disappears. *) 82 | 83 | Parameter find : key -> t elt -> option elt. 84 | (** [find x m] returns the current binding of [x] in [m], 85 | or [None] if no such binding exists. *) 86 | 87 | Parameter remove : key -> t elt -> t elt. 88 | (** [remove x m] returns a map containing the same bindings as [m], 89 | except for [x] which is unbound in the returned map. *) 90 | 91 | Parameter mem : key -> t elt -> bool. 92 | (** [mem x m] returns [true] if [m] contains a binding for [x], 93 | and [false] otherwise. *) 94 | 95 | Parameter bindings : t elt -> list (key*elt). 96 | (** [bindings m] returns an assoc list corresponding to the bindings 97 | of [m], in any order. *) 98 | 99 | Parameter cardinal : t elt -> nat. 100 | (** [cardinal m] returns the number of bindings in [m]. *) 101 | 102 | Parameter fold : forall A: Type, (key -> elt -> A -> A) -> t elt -> A -> A. 103 | (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], 104 | where [k1] ... [kN] are the keys of all bindings in [m] 105 | (in any order), and [d1] ... [dN] are the associated data. *) 106 | 107 | Parameter equal : (elt -> elt -> bool) -> t elt -> t elt -> bool. 108 | (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, 109 | that is, contain equal keys and associate them with equal data. 110 | [cmp] is the boolean equality used to compare the data associated 111 | with the keys. *) 112 | 113 | Parameter filter : (key -> elt -> bool) -> t elt -> t elt. 114 | (** [filter f m] returns the map with all the bindings in [m] that 115 | satisfy [f]. *) 116 | 117 | Parameter partition : (key -> elt -> bool) -> t elt -> t elt * t elt. 118 | (** [partition f m] returns a pair of maps [(m1, m2)], where [m1] contains 119 | all the bindings of [m] that satisfy [f], and [m2] is the map 120 | with all the bindings of [m] that do not satisfy [f]. *) 121 | 122 | Parameter for_all : (key -> elt -> bool) -> t elt -> bool. 123 | (** [for_all f m] checks if all the bindings of the map satisfy [f]. *) 124 | 125 | Parameter exists_ : (key -> elt -> bool) -> t elt -> bool. 126 | (** [exists_ f m] checks if at least one binding of the map satisfies [f]. *) 127 | 128 | Variable elt' elt'' : Type. 129 | 130 | Parameter map : (elt -> elt') -> t elt -> t elt'. 131 | (** [map f m] returns a map with same domain as [m], where the associated 132 | value a of all bindings of [m] has been replaced by the result of the 133 | application of [f] to [a]. Since Coq is purely functional, the order 134 | in which the bindings are passed to [f] is irrelevant. *) 135 | 136 | Parameter mapi : (key -> elt -> elt') -> t elt -> t elt'. 137 | (** Same as [map], but the function receives as arguments both the 138 | key and the associated value for each binding of the map. *) 139 | 140 | Parameter merge : (key -> option elt -> option elt' -> option elt'') -> 141 | t elt -> t elt' -> t elt''. 142 | (** [merge f m m'] creates a new map whose keys are a subset of keys of 143 | [m] and [m']. The presence of each such binding, and the corresponding 144 | value, is determined with the function [f]. More precisely, for 145 | a key [k], if its optional bindings [oe] in [m] and [oe'] in [m'] 146 | are not both [None], then the presence and value of key [k] in the 147 | merged map is determined by [f k oe oe']. Note that [f k None None] 148 | will never be considered, and may differ from [None]. *) 149 | 150 | End Ops. 151 | Section FirstSpecs. 152 | Variable elt:Type. 153 | 154 | Parameter MapsTo : key -> elt -> t elt -> Prop. 155 | 156 | Definition In (k:key)(m: t elt) : Prop := exists e:elt, MapsTo k e m. 157 | 158 | Global Declare Instance MapsTo_compat : 159 | Proper (K.eq==>Logic.eq==>Logic.eq==>iff) MapsTo. 160 | 161 | Variable m : t elt. 162 | Variable x y : key. 163 | Variable e : elt. 164 | 165 | Parameter find_spec : find x m = Some e <-> MapsTo x e m. 166 | Parameter mem_spec : mem x m = true <-> In x m. 167 | Parameter empty_spec : find x (@empty elt) = None. 168 | Parameter is_empty_spec : is_empty m = true <-> forall x, find x m = None. 169 | Parameter add_spec1 : find x (add x e m) = Some e. 170 | Parameter add_spec2 : ~K.eq x y -> find y (add x e m) = find y m. 171 | Parameter remove_spec1 : find x (remove x m) = None. 172 | Parameter remove_spec2 : ~K.eq x y -> find y (remove x m) = find y m. 173 | 174 | Parameter bindings_spec1 : 175 | InA (Duo K.eq Logic.eq) (x,e) (bindings m) <-> MapsTo x e m. 176 | (** When compared with ordered maps, here comes the only 177 | property that is really weaker: *) 178 | Parameter bindings_spec2w : NoDupA (Fst K.eq) (bindings m). 179 | 180 | (* A few functions are now specified in term of [bindings]. 181 | If [K.eq] is setoid, this is slightly stronger than using [find] 182 | or [MapsTo]. See functor [Facts.Properties] for other statements. *) 183 | 184 | Parameter singleton_spec : bindings (singleton x e) = (x,e)::nil. 185 | Parameter cardinal_spec : cardinal m = length (bindings m). 186 | 187 | Parameter fold_spec : 188 | forall {A} (i : A) (f : key -> elt -> A -> A), 189 | fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. 190 | 191 | End FirstSpecs. 192 | 193 | Section FilterSpecs. 194 | Variable elt : Type. 195 | Variable f : key -> elt -> bool. 196 | Variable m : t elt. 197 | Local Notation f' := (fun '(k,e) => f k e). 198 | 199 | Parameter filter_spec : bindings (filter f m) = List.filter f' (bindings m). 200 | Parameter partition_spec : 201 | prodmap (@bindings _) (partition f m) = List.partition f' (bindings m). 202 | Parameter for_all_spec : for_all f m = List.forallb f' (bindings m). 203 | Parameter exists_spec : exists_ f m = List.existsb f' (bindings m). 204 | End FilterSpecs. 205 | 206 | Section EqualSpec. 207 | Variable elt : Type. 208 | 209 | (** More details about map equalities and comparison in the last comment 210 | of this file. *) 211 | 212 | Definition Equal (m m':t elt) := forall y, find y m = find y m'. 213 | Definition Eqdom (m m':t elt) := forall y, In y m <-> In y m'. 214 | Definition Equiv (R:elt->elt->Prop) m m' := 215 | Eqdom m m' /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> R e e'). 216 | Definition Equivb (cmp: elt->elt->bool) := Equiv (Cmp cmp). 217 | 218 | Parameter equal_spec : forall (cmp : elt -> elt -> bool)(m m':t elt), 219 | equal cmp m m' = true <-> Equivb cmp m m'. 220 | End EqualSpec. 221 | Section MapsSpecs. 222 | Variable elt elt' elt'' : Type. 223 | 224 | (** Specifications of [map] and [mapi], now via [bindings]. In the case 225 | of [mapi], the function [f] need not be a morphism w.r.t. [K.eq]. 226 | Earlier weaker specs via [find] could be found in the [Properties] 227 | functor, see for instance [map_find] and [mapi_find]. *) 228 | 229 | Parameter map_spec : forall (f:elt->elt') m, 230 | bindings (map f m) = List.map (fun '(k,e) => (k,f e)) (bindings m). 231 | 232 | Parameter mapi_spec : forall (f:key->elt->elt') m, 233 | bindings (mapi f m) = List.map (fun '(k,e) => (k,f k e)) (bindings m). 234 | 235 | (** Note : the specifications for [merge] below are 236 | general enough to work even when [f] is not a morphism w.r.t. 237 | [K.eq]. For [merge], we could also have [f k None None <> None]. 238 | Alas, this leads to relatively awkward statements. 239 | See the [Properties] functor for more usual and pratical statements, 240 | for instance [merge_spec1mn]. *) 241 | 242 | Parameter merge_spec1 : 243 | forall (f:key->option elt->option elt'->option elt'') m m' x, 244 | In x m \/ In x m' -> 245 | exists y:key, K.eq y x /\ find x (merge f m m') = f y (find x m) (find x m'). 246 | 247 | Parameter merge_spec2 : 248 | forall (f:key->option elt->option elt'->option elt'') m m' x, 249 | In x (merge f m m') -> In x m \/ In x m'. 250 | 251 | End MapsSpecs. 252 | End WS. 253 | 254 | 255 | (** ** Maps on ordered keys. *) 256 | 257 | Module Type S (K : OrderedType). 258 | Include WS K. 259 | 260 | (** Additional specification of [bindings] *) 261 | 262 | Parameter bindings_spec2 : 263 | forall {elt}(m : t elt), sort (Fst K.lt) (bindings m). 264 | 265 | (** Remark: since [fold] is specified via [bindings], this stronger 266 | specification of [bindings] has an indirect impact on [fold], 267 | which can now be proved to receive bindings in increasing order. *) 268 | 269 | Parameter compare : 270 | forall {elt}, (elt -> elt -> comparison) -> t elt -> t elt -> comparison. 271 | (** [compare cmp m m'] compares the maps [m] and [m'], in a way compatible 272 | with a lexicographic ordering of [bindings m] and [bindings m'], 273 | using [K.compare] on keys and [cmp] on values. *) 274 | 275 | Parameter compare_spec : 276 | forall {elt} (cmp : elt -> elt -> comparison) (m m':t elt), 277 | compare cmp m m' = 278 | list_compare (pair_compare K.compare cmp) (bindings m) (bindings m'). 279 | 280 | End S. 281 | 282 | (** Note: Equalities of maps 283 | 284 | Only one [equal] function on maps is provided, but several 285 | equivalence predicates on maps are considered, for different purposes: 286 | 287 | Predicate | On keys | On datas | Decided by 288 | ---------------------------------------------------------------- 289 | Equal | K.eq | Logic.eq | equal eqb, if eqb decides (@Logic.eq elt) 290 | Equivb | K.eq | a test cmp | equal cmp 291 | Equiv | K.eq | a relation R | equal cmp, if cmp decides R 292 | Eqdom | K.eq | True | equal (fun _ _ => true) 293 | 294 | If [R] is an equivalence on datas, and [cmp] implements it, then we have 295 | the following implications: 296 | [m = m' -> Equal m m' -> Equiv R m m' <-> Equivb cmp m m' -> Eqdom m m'] 297 | 298 | - In general, Leibniz equality on maps is not adequate here, 299 | since it is frequent that several maps may encode the same 300 | bindings, even when [K.eq] is Leibniz (think of tree re-balancing). 301 | 302 | - [Equal] is then the most precise predicate, and probably the most 303 | natural, corresponding to an observational equivalence : [Equal] 304 | maps will give (Leibniz) equal results by [find]. 305 | 306 | - [Equivb] and [Equiv] are somewhat ad-hoc, but necessary to fully 307 | specify the [equal] function. [Equivb] is parametrized by a boolean 308 | test [cmp] on datas, and its logical counterpart [Equiv] is parametrized 309 | by some relation on datas (possibly not an equivalence nor decidable). 310 | 311 | - [Eqdom] is only comparing the map domains. Said otherwise, it only 312 | considers the keys (via [K.eq]) but ignore datas altogether. Some 313 | properties are already shared amongst [Eqdom] maps, for instance 314 | they have the same cardinal. 315 | 316 | Finally, for maps with ordered keys, the [compare] function is specified 317 | via a different approach, i.e. referring to the lexicographic comparison 318 | of [bindings] lists. In this case, [equal] can be seen as a particular 319 | case of [compare], see [compare_equiv] in [Tries.MMaps.Facts]. 320 | *) 321 | -------------------------------------------------------------------------------- /MMaps/Raw.v: -------------------------------------------------------------------------------- 1 | 2 | (** * Finite Modular Maps : Raw Interface *) 3 | 4 | (** Author : Pierre Letouzey (Université de Paris - INRIA), 5 | adapted from earlier works in Coq Standard Library, see README.md. 6 | Licence : LGPL 2.1, see file LICENSE. *) 7 | 8 | (** This "raw" interface isn't meant for general use, see rather the 9 | [Interface] file for that. The "raw" version has two interests : 10 | 11 | - Internally, as an intermediate step during the implementations 12 | [WeakList] [OrdList], [AVL] and [RBT] proposed in this library. 13 | Actually, only the [Positive] implementation does not use it. 14 | 15 | - For advanced users, access to a "raw" map datatype allows 16 | smaller memory footprint during Coq computations (no proof 17 | parts) and hence slightly faster operations, at the expense of 18 | more complex reasoning when proving properties later. 19 | 20 | Raw means here that no proof part is stored along the map 21 | datatypes, while the type of maps used here is too large to be 22 | directly a implementation of [Interface.S] : among all inhabitants 23 | of this type of maps, only the ones fulfilling some adequacy 24 | predicate [Ok] should be considered (think for instance of lists 25 | that are sorted or trees that are binary search trees). Almost all 26 | operations here will have [Ok] pre-conditions, and all operations 27 | answering new maps will maintain this adequacy. 28 | 29 | A implementation of the usual [Interface.S] can then be obtained 30 | by restricting the type of maps, and then wrapping all operations. 31 | In functors [WPack] and [Pack] below, this is done via a record 32 | combining a map and a adequacy proof. These functors are used as 33 | the final steps in [OrdList], [AVL] and [RBT]. 34 | 35 | See [Interface] for the documentation of all these operations and 36 | extra explanations. *) 37 | 38 | From Tries.MMaps Require Export Comparisons Interface. 39 | Set Implicit Arguments. 40 | Unset Strict Implicit. 41 | (* No induction principles for the records below *) 42 | Local Unset Elimination Schemes. 43 | 44 | Definition Cmp {elt:Type}(cmp:elt->elt->bool) e1 e2 := cmp e1 e2 = true. 45 | 46 | Module Type WS (K : DecidableType). 47 | 48 | Definition key := K.t. 49 | 50 | Definition eq_key {elt} (p p':key*elt) := K.eq (fst p) (fst p'). 51 | 52 | Definition eq_key_elt {elt} (p p':key*elt) := 53 | K.eq (fst p) (fst p') /\ (snd p) = (snd p'). 54 | 55 | Parameter t : Type -> Type. 56 | (** the abstract type of maps *) 57 | 58 | (** Is a set well-formed or ill-formed ? *) 59 | 60 | Parameter IsOk : forall {elt}, t elt -> Prop. 61 | Class Ok {elt}(m:t elt) : Prop := ok : IsOk m. 62 | 63 | (** In order to be able to validate (at least some) particular maps as 64 | well-formed, we ask for a boolean function for (semi-)deciding 65 | predicate [Ok]. If [Ok] isn't decidable, [isok] may be the 66 | always-false function. *) 67 | Parameter isok : forall {elt}, t elt -> bool. 68 | Parameter isok_Ok : forall {elt} (m:t elt), isok m = true -> Ok m. 69 | 70 | Section Ops. 71 | Parameter empty : forall {elt}, t elt. 72 | Variable elt:Type. 73 | Parameter is_empty : t elt -> bool. 74 | Parameter find : key -> t elt -> option elt. 75 | Parameter singleton : key -> elt -> t elt. 76 | Parameter add : key -> elt -> t elt -> t elt. 77 | Parameter remove : key -> t elt -> t elt. 78 | Parameter mem : key -> t elt -> bool. 79 | Parameter bindings : t elt -> list (key*elt). 80 | Parameter cardinal : t elt -> nat. 81 | Parameter fold : forall A: Type, (key -> elt -> A -> A) -> t elt -> A -> A. 82 | Parameter equal : (elt -> elt -> bool) -> t elt -> t elt -> bool. 83 | Parameter filter : (key -> elt -> bool) -> t elt -> t elt. 84 | Parameter partition : (key -> elt -> bool) -> t elt -> t elt * t elt. 85 | Parameter for_all : (key -> elt -> bool) -> t elt -> bool. 86 | Parameter exists_ : (key -> elt -> bool) -> t elt -> bool. 87 | Variable elt' elt'' : Type. 88 | Parameter map : (elt -> elt') -> t elt -> t elt'. 89 | Parameter mapi : (key -> elt -> elt') -> t elt -> t elt'. 90 | Parameter merge : (key -> option elt -> option elt' -> option elt'') -> 91 | t elt -> t elt' -> t elt''. 92 | End Ops. 93 | 94 | Global Declare Instance empty_ok {elt} : Ok (@empty elt). 95 | Global Declare Instance singleton_ok {elt} x (e:elt) : Ok (singleton x e). 96 | Global Declare Instance add_ok {elt} (m:t elt) x e `(!Ok m) : 97 | Ok (add x e m). 98 | Global Declare Instance remove_ok {elt} (m:t elt) x `(!Ok m) : 99 | Ok (remove x m). 100 | Global Declare Instance filter_ok {elt} f (m:t elt) `(!Ok m) : 101 | Ok (filter f m). 102 | Global Declare Instance partition_ok1 {elt} f (m:t elt) `(!Ok m) : 103 | Ok (fst (partition f m)). 104 | Global Declare Instance partition_ok2 {elt} f (m:t elt) `(!Ok m) : 105 | Ok (snd (partition f m)). 106 | Global Declare Instance map_ok {elt elt'}(f:elt->elt') m `(!Ok m) : 107 | Ok (map f m). 108 | Global Declare Instance mapi_ok {elt elt'}(f:key->elt->elt') m `(!Ok m) : 109 | Ok (mapi f m). 110 | Global Declare Instance merge_ok {elt elt' elt''} 111 | (f:key -> option elt -> option elt' -> option elt'') m m' 112 | `(!Ok m, !Ok m') : 113 | Ok (merge f m m'). 114 | 115 | Parameter MapsTo : forall {elt}, key -> elt -> t elt -> Prop. 116 | Definition In {elt}(k:key)(m: t elt) : Prop := exists e, MapsTo k e m. 117 | 118 | Section Specs. 119 | Context {elt elt' elt'' : Type}. 120 | Global Declare Instance MapsTo_compat : 121 | Proper (K.eq==>Logic.eq==>Logic.eq==>iff) (@MapsTo elt). 122 | 123 | Variable m m' : t elt. 124 | Variable x y : key. 125 | Variable e : elt. 126 | Parameter find_spec : forall `{!Ok m}, 127 | find x m = Some e <-> MapsTo x e m. 128 | Parameter mem_spec : forall `{!Ok m}, mem x m = true <-> In x m. 129 | Parameter empty_spec : find x (@empty elt) = None. 130 | Parameter is_empty_spec : 131 | is_empty m = true <-> forall x, find x m = None. 132 | Parameter add_spec1 : forall `{!Ok m}, find x (add x e m) = Some e. 133 | Parameter add_spec2 : forall `{!Ok m}, 134 | ~K.eq x y -> find y (add x e m) = find y m. 135 | Parameter remove_spec1 : forall `{!Ok m}, find x (remove x m) = None. 136 | Parameter remove_spec2 : forall `{!Ok m}, 137 | ~K.eq x y -> find y (remove x m) = find y m. 138 | Parameter bindings_spec1 : 139 | InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m. 140 | Parameter bindings_spec2w : forall `{!Ok m}, 141 | NoDupA eq_key (bindings m). 142 | Parameter singleton_spec : bindings (singleton x e) = (x,e)::nil. 143 | Parameter cardinal_spec : cardinal m = length (bindings m). 144 | Parameter fold_spec : 145 | forall {A} (i : A) (f : key -> elt -> A -> A), 146 | fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. 147 | 148 | Parameter filter_spec : forall (f:key->elt->bool) m `{!Ok m}, 149 | bindings (filter f m) = List.filter (fun '(k,e) => f k e) (bindings m). 150 | Parameter partition_spec : forall (f:key->elt->bool) m `{!Ok m}, 151 | prodmap (@bindings _) (partition f m) = 152 | List.partition (fun '(k,e) => f k e) (bindings m). 153 | Parameter for_all_spec : forall (f:key->elt->bool) m, 154 | for_all f m = List.forallb (fun '(k,e) => f k e) (bindings m). 155 | Parameter exists_spec : forall (f:key->elt->bool) m, 156 | exists_ f m = List.existsb (fun '(k,e) => f k e) (bindings m). 157 | 158 | Definition Equal (m m':t elt) := forall y, find y m = find y m'. 159 | Definition Eqdom (m m':t elt) := forall y, In y m <-> In y m'. 160 | Definition Equiv (R:elt->elt->Prop) m m' := 161 | Eqdom m m' /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> R e e'). 162 | Definition Equivb (cmp: elt->elt->bool) := Equiv (Cmp cmp). 163 | 164 | Parameter equal_spec : 165 | forall (cmp : elt -> elt -> bool) m m' `{!Ok m, !Ok m'}, 166 | equal cmp m m' = true <-> Equivb cmp m m'. 167 | 168 | Parameter map_spec : forall (f:elt->elt') m, 169 | bindings (map f m) = List.map (fun '(k,e) => (k,f e)) (bindings m). 170 | Parameter mapi_spec : forall (f:key->elt->elt') m, 171 | bindings (mapi f m) = List.map (fun '(k,e) => (k,f k e)) (bindings m). 172 | 173 | Implicit Types f : key->option elt->option elt'->option elt''. 174 | 175 | Parameter merge_spec1 : 176 | forall f m m' x `{!Ok m, !Ok m'}, 177 | In x m \/ In x m' -> 178 | exists y:key, K.eq y x /\ 179 | find x (merge f m m') = f y (find x m) (find x m'). 180 | 181 | Parameter merge_spec2 : 182 | forall f m m' x `{!Ok m, !Ok m'}, 183 | In x (merge f m m') -> In x m \/ In x m'. 184 | 185 | End Specs. 186 | End WS. 187 | 188 | (** ** Raw Maps on ordered keys. *) 189 | 190 | Module Type S (K : OrderedType). 191 | Include WS K. 192 | 193 | Definition lt_key {elt} (p p':key*elt) := K.lt (fst p) (fst p'). 194 | 195 | Parameter bindings_spec2 : 196 | forall {elt}(m : t elt)`{!Ok m}, sort lt_key (bindings m). 197 | 198 | Parameter compare : 199 | forall {elt}, (elt -> elt -> comparison) -> t elt -> t elt -> comparison. 200 | 201 | Parameter compare_spec : 202 | forall {elt} (cmp : elt -> elt -> comparison)(m m':t elt)`{!Ok m, !Ok m'}, 203 | compare cmp m m' = 204 | list_compare (pair_compare K.compare cmp) (bindings m) (bindings m'). 205 | 206 | End S. 207 | 208 | (** ** From Raw.WS to Interface.WS 209 | 210 | A record packs the datatype and the adequacy proof. 211 | The rest is a wrapper around the raw functions. *) 212 | 213 | Module WPack (K : DecidableType) (R : WS K) <: Interface.WS K. 214 | Import R. (** The raw datatype for maps *) 215 | Definition key := K.t. 216 | 217 | (** The map structure with adequacy proofs attached *) 218 | 219 | Record t_ (elt:Type) := Mkt {this :> R.t elt; ok : Ok this}. 220 | Definition t := t_. 221 | 222 | Global Existing Instance ok. 223 | Arguments Mkt {elt} this {ok}. 224 | 225 | (** By default, the adequacy proof attached to a map [m] will have 226 | a size proportional to the number of operations used 227 | to build this map (one extra [add_ok] for each [add] operation, 228 | etc). If we have a proof [b : isok m = true], then the 229 | following function [Mkt_bool] builds a map with proof part 230 | [@isok_Ok m b]. When [b] is obtained by computation, this 231 | leads to a constant-size proof part (assuming that all occurrences 232 | of [m] are properly shared in memory). This is a typical 233 | time/memory trade-off. *) 234 | 235 | Definition Mkt_bool {elt} (m : R.t elt)(b : isok m = true) : t elt := 236 | @Mkt _ m (isok_Ok b). 237 | 238 | Section Elt. 239 | Context {elt elt' elt'': Type}. 240 | 241 | Implicit Types m : t elt. 242 | Implicit Types x y : key. 243 | Implicit Types e : elt. 244 | 245 | Definition empty : t elt := Mkt (@empty elt). 246 | Definition is_empty m : bool := is_empty m. 247 | Definition singleton x e : t elt := Mkt (singleton x e). 248 | Definition add x e m : t elt := Mkt (add x e m). 249 | Definition remove x m : t elt := Mkt (remove x m). 250 | Definition mem x m : bool := mem x m. 251 | Definition find x m : option elt := find x m. 252 | Definition map f m : t elt' := Mkt (map f m). 253 | Definition mapi (f:key->elt->elt') m : t elt' := Mkt (mapi f m). 254 | Definition merge f m (m':t elt') : t elt'' := Mkt (merge f m m'). 255 | Definition bindings m : list (key*elt) := bindings m. 256 | Definition cardinal m := cardinal m. 257 | Definition fold {A} (f:key->elt->A->A) m i := fold f m i. 258 | Definition equal cmp m m' : bool := equal cmp m m'. 259 | Definition filter (f:key->elt->bool) m := Mkt (filter f m). 260 | Definition partition (f:key->elt->bool) m := 261 | let p := partition f m in (Mkt (fst p), Mkt (snd p)). 262 | Definition for_all (f:key->elt->bool) m : bool := for_all f m. 263 | Definition exists_ (f:key->elt->bool) m : bool := exists_ f m. 264 | 265 | Definition MapsTo x e m : Prop := MapsTo x e m. 266 | Definition In x m : Prop := In x m. 267 | 268 | Definition eq_key {elt} (p p':key*elt) := K.eq (fst p) (fst p'). 269 | 270 | Definition eq_key_elt {elt} (p p':key*elt) := 271 | K.eq (fst p) (fst p') /\ (snd p) = (snd p'). 272 | 273 | Instance MapsTo_compat : 274 | Proper (K.eq==>Logic.eq==>Logic.eq==>iff) MapsTo. 275 | Proof. 276 | intros k k' Hk e e' <- m m' <-. unfold MapsTo; simpl. now rewrite Hk. 277 | Qed. 278 | 279 | Lemma find_spec m x e : find x m = Some e <-> MapsTo x e m. 280 | Proof. apply find_spec, ok. Qed. 281 | 282 | Lemma mem_spec m x : mem x m = true <-> In x m. 283 | Proof. apply mem_spec, ok. Qed. 284 | 285 | Lemma empty_spec x : find x empty = None. 286 | Proof. apply empty_spec. Qed. 287 | 288 | Lemma is_empty_spec m : is_empty m = true <-> forall x, find x m = None. 289 | Proof. apply is_empty_spec. Qed. 290 | 291 | Lemma add_spec1 m x e : find x (add x e m) = Some e. 292 | Proof. apply add_spec1, ok. Qed. 293 | Lemma add_spec2 m x y e : ~ K.eq x y -> find y (add x e m) = find y m. 294 | Proof. apply add_spec2, ok. Qed. 295 | 296 | Lemma remove_spec1 m x : find x (remove x m) = None. 297 | Proof. apply remove_spec1, ok. Qed. 298 | Lemma remove_spec2 m x y : ~K.eq x y -> find y (remove x m) = find y m. 299 | Proof. apply remove_spec2, ok. Qed. 300 | 301 | Lemma bindings_spec1 m x e : 302 | InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m. 303 | Proof. apply bindings_spec1. Qed. 304 | 305 | Lemma bindings_spec2w m : NoDupA eq_key (bindings m). 306 | Proof. apply bindings_spec2w, ok. Qed. 307 | 308 | Lemma cardinal_spec m : cardinal m = length (bindings m). 309 | Proof. apply cardinal_spec. Qed. 310 | 311 | Lemma singleton_spec x e : bindings (singleton x e) = (x,e)::nil. 312 | Proof. apply singleton_spec. Qed. 313 | 314 | Lemma fold_spec m {A} (i : A) (f : key -> elt -> A -> A) : 315 | fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. 316 | Proof. apply fold_spec. Qed. 317 | 318 | Lemma filter_spec (f:key->elt->bool) m : 319 | bindings (filter f m) = List.filter (fun '(k,e) => f k e) (bindings m). 320 | Proof. apply filter_spec, ok. Qed. 321 | Lemma partition_spec (f:key->elt->bool) m : 322 | prodmap bindings (partition f m) = 323 | List.partition (fun '(k,e) => f k e) (bindings m). 324 | Proof. 325 | unfold bindings. rewrite <- partition_spec by apply ok. 326 | unfold partition; simpl. now destruct R.partition. 327 | Qed. 328 | Lemma for_all_spec (f:key->elt->bool) m : 329 | for_all f m = List.forallb (fun '(k,e) => f k e) (bindings m). 330 | Proof. apply for_all_spec. Qed. 331 | Lemma exists_spec (f:key->elt->bool) m : 332 | exists_ f m = List.existsb (fun '(k,e) => f k e) (bindings m). 333 | Proof. apply exists_spec. Qed. 334 | 335 | Definition Equal m m' := forall y, find y m = find y m'. 336 | Definition Eqdom (m m':t elt) := forall y, In y m <-> In y m'. 337 | Definition Equiv (R:elt->elt->Prop) m m' := 338 | Eqdom m m' /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> R e e'). 339 | Definition Equivb cmp := Equiv (Cmp cmp). 340 | 341 | Lemma Equivb_Equivb cmp m m' : 342 | Equivb cmp m m' <-> R.Equivb cmp m m'. 343 | Proof. 344 | unfold Equivb, Equiv, R.Equivb, R.Equiv. intuition. 345 | Qed. 346 | 347 | Lemma equal_spec cmp m m' : 348 | equal cmp m m' = true <-> Equivb cmp m m'. 349 | Proof. rewrite Equivb_Equivb. apply equal_spec; apply ok. Qed. 350 | 351 | End Elt. 352 | 353 | Lemma map_spec {elt elt'} (f:elt->elt') m : 354 | bindings (map f m) = List.map (fun '(k,e) => (k,f e)) (bindings m). 355 | Proof. apply map_spec. Qed. 356 | 357 | Lemma mapi_spec {elt elt'} (f:key->elt->elt') m : 358 | bindings (mapi f m) = List.map (fun '(k,e) => (k,f k e)) (bindings m). 359 | Proof. apply mapi_spec. Qed. 360 | 361 | Lemma merge_spec1 {elt elt' elt''} 362 | (f:key->option elt->option elt'->option elt'') m m' x : 363 | In x m \/ In x m' -> 364 | exists y:key, K.eq y x /\ 365 | find x (merge f m m') = f y (find x m) (find x m'). 366 | Proof. apply merge_spec1; apply ok. Qed. 367 | 368 | Lemma merge_spec2 {elt elt' elt''} 369 | (f:key -> option elt->option elt'->option elt'') m m' x : 370 | In x (merge f m m') -> In x m \/ In x m'. 371 | Proof. apply merge_spec2; apply ok. Qed. 372 | 373 | End WPack. 374 | 375 | Module Pack (K : OrderedType) (R : S K) <: Interface.S K. 376 | Include WPack K R. 377 | 378 | Definition lt_key {elt} (p p':key*elt) := K.lt (fst p) (fst p'). 379 | 380 | Lemma bindings_spec2 {elt}(m : t elt) : sort lt_key (bindings m). 381 | Proof. apply R.bindings_spec2. Qed. 382 | 383 | Definition compare {elt} cmp (m m' : t elt) := R.compare cmp m m'. 384 | 385 | Lemma compare_spec {elt} cmp (m m' : t elt) : 386 | compare cmp m m' = 387 | list_compare (pair_compare K.compare cmp) (bindings m) (bindings m'). 388 | Proof. apply R.compare_spec; apply ok. Qed. 389 | 390 | End Pack. 391 | -------------------------------------------------------------------------------- /Patricia.v: -------------------------------------------------------------------------------- 1 | (** * Binary Patricia tries *) 2 | 3 | (* Author: Xavier Leroy, Collège de France and Inria. 4 | Copyright: Inria. 5 | License: BSD-3-Clause. *) 6 | 7 | (** Inspired by section 12.3 of "Functional algorithms, verified!" 8 | by T. Nipkow et al. *) 9 | 10 | From Coq Require Import PArith. 11 | From Tries Require Original. 12 | 13 | Module O := Original.PTree. 14 | 15 | Set Implicit Arguments. 16 | 17 | (** ** Operations on positive numbers viewed as lists of bits *) 18 | 19 | (** Concatenation. *) 20 | 21 | Fixpoint app (p q: positive) : positive := 22 | match p with 23 | | xH => q 24 | | xO p => xO (app p q) 25 | | xI p => xI (app p q) 26 | end. 27 | 28 | Lemma app_xH: forall p, app p xH = p. 29 | Proof. 30 | induction p; simpl; congruence. 31 | Qed. 32 | 33 | Lemma app_assoc: forall p q r, app (app p q) r = app p (app q r). 34 | Proof. 35 | induction p; intros; simpl; auto; rewrite IHp; auto. 36 | Qed. 37 | 38 | Lemma app_inj: forall p q1 q2, app p q1 = app p q2 -> q1 = q2. 39 | Proof. 40 | induction p; simpl; intros; auto; apply IHp; congruence. 41 | Qed. 42 | 43 | (** Viewing positive numbers as lists of bits, check that p is a prefix of q, 44 | and if so return the remainder of q. *) 45 | 46 | Fixpoint prefix (p q: positive) {struct p} : option positive := 47 | match p, q with 48 | | xH, _ => Some q 49 | | xO p, xO q => prefix p q 50 | | xI p, xI q => prefix p q 51 | | _, _ => None 52 | end. 53 | 54 | Lemma prefix_charact: forall p q r, 55 | prefix p q = Some r <-> q = app p r. 56 | Proof. 57 | induction p; intros; simpl. 58 | - split; intros. 59 | + destruct q; try discriminate. apply IHp in H. congruence. 60 | + subst q. apply IHp. auto. 61 | - split; intros. 62 | + destruct q; try discriminate. apply IHp in H. congruence. 63 | + subst q. apply IHp. auto. 64 | - intuition congruence. 65 | Qed. 66 | 67 | Lemma prefix_app: forall p1 p2 i, 68 | prefix (app p1 p2) i = 69 | match prefix p1 i with 70 | | None => None 71 | | Some i1 => prefix p2 i1 72 | end. 73 | Proof. 74 | intros. destruct (prefix p1 i) as [i1 | ] eqn:P1. 75 | - apply prefix_charact in P1. 76 | destruct (prefix (app p1 p2) i) as [i2 | ] eqn:P2. 77 | + apply prefix_charact in P2. 78 | symmetry. apply prefix_charact. apply app_inj with p1. 79 | rewrite <- app_assoc. congruence. 80 | + destruct (prefix p2 i1) as [i2 | ] eqn:P3; auto. 81 | apply prefix_charact in P3. subst i1. rewrite <- app_assoc in P1. apply prefix_charact in P1. congruence. 82 | - destruct (prefix (app p1 p2) i) as [i1 | ] eqn: P; auto. 83 | apply prefix_charact in P. rewrite app_assoc in P. apply prefix_charact in P. congruence. 84 | Qed. 85 | 86 | (** Viewing positive numbers as lists of bits, find the longest common prefix 87 | between p and q. Also return the suffixes. *) 88 | 89 | Fixpoint common (p q: positive) {struct p} : positive * positive * positive := 90 | match p, q with 91 | | xO p, xO q => let '(c, p', q') := common p q in (xO c, p', q') 92 | | xI p, xI q => let '(c, p', q') := common p q in (xI c, p', q') 93 | | _, _ => (xH, p, q) 94 | end. 95 | 96 | Definition disagree (p q: positive) : Prop := 97 | match p, q with 98 | | xO _, xO _ => False 99 | | xI _, xI _ => False 100 | | _, _ => True 101 | end. 102 | 103 | Lemma common_charact: forall p q, 104 | let '(c, p', q') := common p q in 105 | p = app c p' /\ q = app c q' /\ disagree p' q'. 106 | Proof. 107 | induction p; destruct q; simpl; auto. 108 | - specialize (IHp q). destruct (common p q) as [[c p'] q']. simpl. intuition congruence. 109 | - specialize (IHp q). destruct (common p q) as [[c p'] q']. simpl. intuition congruence. 110 | Qed. 111 | 112 | Module PTree. 113 | 114 | (** ** Representation of Patricia tries *) 115 | 116 | Inductive tree (A: Type) : Type := 117 | | Leaf: tree A 118 | | Node: positive -> tree A -> option A -> tree A -> tree A. 119 | 120 | (** In [Node p l x r], the [p] argument represents the list of bits that 121 | lead to this node. The node is, then, a branch point, with 122 | an optional value [x] and a left subtree [l] and a right subtree [r], 123 | as in the other binary tries. *) 124 | 125 | Arguments Leaf {A}. 126 | Arguments Node [A]. 127 | 128 | Definition t := tree. 129 | 130 | (** Smart constructor: avoids creating empty nodes and nodes where the 131 | prefix is not maximal. *) 132 | 133 | Definition Node' (A: Type) (p: positive) (l: tree A) (x: option A) (r: tree A) : tree A := 134 | match l, x, r with 135 | | Leaf, None, Leaf => Leaf 136 | | Node p1 l1 x1 r1, None, Leaf => Node (app p (xO p1)) l1 x1 r1 137 | | Leaf, None, Node p2 l2 x2 r2 => Node (app p (xI p2)) l2 x2 r2 138 | | _, _, _ => Node p l x r 139 | end. 140 | 141 | (** ** Basic operations: [empty], [get], [set], [remove] *) 142 | 143 | Definition empty (A: Type) : tree A := Leaf. 144 | 145 | Fixpoint get (A: Type) (i: positive) (m: tree A) {struct m} : option A := 146 | match m with 147 | | Leaf => None 148 | | Node p l x r => 149 | match prefix p i with 150 | | None => None 151 | | Some xH => x 152 | | Some (xO ii) => get ii l 153 | | Some (xI ii) => get ii r 154 | end 155 | end. 156 | 157 | Definition singleton (A: Type) (i: positive) (v: A) : tree A := 158 | Node i Leaf (Some v) Leaf. 159 | 160 | Fixpoint set (A: Type) (i: positive) (v: A) (m: tree A) {struct m} : tree A := 161 | match m with 162 | | Leaf => singleton i v 163 | | Node p l x r => 164 | match common p i with 165 | | (_, xH, xH) => Node p l (Some v) r 166 | | (_, xH, xO ii) => Node p (set ii v l) x r 167 | | (_, xH, xI ii) => Node p l x (set ii v r) 168 | | (c, xO pp, xH) => Node c (Node pp l x r) (Some v) Leaf 169 | | (c, xI pp, xH) => Node c Leaf (Some v) (Node pp l x r) 170 | | (c, xO pp, xI ii) => Node c (Node pp l x r) None (singleton ii v) 171 | | (c, xI pp, xO ii) => Node c (singleton ii v) None (Node pp l x r) 172 | | _ => Leaf (*r never happens *) 173 | end 174 | end. 175 | 176 | Fixpoint remove (A: Type) (i: positive) (m: tree A) {struct m} : tree A := 177 | match m with 178 | | Leaf => Leaf 179 | | Node p l x r => 180 | match prefix p i with 181 | | None => m 182 | | Some xH => Node' p l None r 183 | | Some (xO ii) => Node' p (remove ii l) x r 184 | | Some (xI ii) => Node' p l x (remove ii r) 185 | end 186 | end. 187 | 188 | (** ** Relating Patricia trees with binary tries *) 189 | 190 | (** As in "Functional algorithms, verified!", we transport some of the 191 | results for plain binary tries to Patricia binary tries via the 192 | following translation functions. *) 193 | 194 | (** [transl m] produces the plain trie equivalent to the given Patricia 195 | trie. No attempt is made to eliminate redundant nodes. *) 196 | 197 | Fixpoint addpref {A: Type} (p: positive) (m: O.tree A) : O.tree A := 198 | match p with 199 | | xH => m 200 | | xO pp => O.Node (addpref pp m) None O.Leaf 201 | | xI pp => O.Node O.Leaf None (addpref pp m) 202 | end. 203 | 204 | Fixpoint transl {A: Type} (m: tree A) : O.tree A := 205 | match m with 206 | | Leaf => O.Leaf 207 | | Node p l x r => addpref p (O.Node (transl l) x (transl r)) 208 | end. 209 | 210 | (** [transl' m] is similar but replaces empty nodes by leaves. *) 211 | 212 | Fixpoint addpref' {A: Type} (p: positive) (m: O.tree A) : O.tree A := 213 | match p with 214 | | xH => m 215 | | xO pp => O.Node' (addpref' pp m) None O.Leaf 216 | | xI pp => O.Node' O.Leaf None (addpref' pp m) 217 | end. 218 | 219 | Fixpoint transl' {A: Type} (m: tree A) : O.tree A := 220 | match m with 221 | | Leaf => O.Leaf 222 | | Node p l x r => addpref' p (O.Node' (transl' l) x (transl' r)) 223 | end. 224 | 225 | (** We now show commutation diagrams between the operations over Patricia tries 226 | and the same operations over the corresponding binary tries. *) 227 | 228 | Lemma transl_get: 229 | forall {A: Type} (m: tree A) i, 230 | get i m = O.get i (transl m). 231 | Proof. 232 | induction m; simpl. 233 | - intros. auto. 234 | - induction p as [ pp | pp | ]; simpl; intros; destruct i; auto. 235 | Qed. 236 | 237 | Lemma transl_singleton: forall {A: Type} (v: A) i, 238 | transl (singleton i v) = O.set i v O.Leaf. 239 | Proof. 240 | unfold singleton; induction i; simpl; auto; f_equal; auto. 241 | Qed. 242 | 243 | Remark o_set_app: forall {A} (v: A) c i p t, 244 | O.set (app c i) v (addpref (app c p) t) = addpref c (O.set i v (addpref p t)). 245 | Proof. 246 | induction c; simpl; intros; auto; f_equal; auto. 247 | Qed. 248 | 249 | Lemma transl_set: 250 | forall {A: Type} (v: A) (m: tree A) i, 251 | transl (set i v m) = O.set i v (transl m). 252 | Proof. 253 | induction m; simpl. 254 | - intros. apply transl_singleton. 255 | - intros i. 256 | generalize (common_charact p i). destruct (common p i) as [[c pp] ii] eqn:C. 257 | intros (E1 & E2 & DIS). rewrite E1, E2. 258 | rewrite o_set_app. 259 | destruct pp as [ pp | pp | ]; destruct ii as [ ii | ii | ]; simpl; try (elim DIS); auto. 260 | + f_equal. f_equal. apply transl_singleton. 261 | + f_equal. f_equal. apply transl_singleton. 262 | + rewrite app_xH. f_equal. f_equal. apply IHm2. 263 | + rewrite app_xH. f_equal. f_equal. apply IHm1. 264 | + rewrite app_xH. auto. 265 | Qed. 266 | 267 | Lemma gNode': forall {A} i p l (x: option A) r, 268 | get i (Node' p l x r) = 269 | match prefix p i with 270 | | None => None 271 | | Some xH => x 272 | | Some (xO ii) => get ii l 273 | | Some (xI ii) => get ii r 274 | end. 275 | Proof. 276 | intros. destruct l, x, r; auto. 277 | - destruct (prefix p i) as [[] | ]; auto. 278 | - simpl. rewrite prefix_app. destruct (prefix p i) as [ii | ]; auto. 279 | simpl. destruct ii; auto. 280 | - simpl. rewrite prefix_app. destruct (prefix p i) as [ii | ]; auto. 281 | simpl. destruct ii; auto. 282 | Qed. 283 | 284 | Lemma transl'_get: 285 | forall {A: Type} (m: tree A) i, 286 | get i m = O.get i (transl' m). 287 | Proof. 288 | Local Opaque O.Node'. 289 | induction m; simpl. 290 | - intros. auto. 291 | - induction p as [ pp | pp | ]; simpl; intros; rewrite O.gNode'; destruct i; auto. 292 | Qed. 293 | 294 | Lemma o_remove_node': forall {A: Type} i (l: O.tree A) x r, 295 | O.remove i (O.Node' l x r) = 296 | match i with 297 | | xH => O.Node' l None r 298 | | xO i => O.Node' (O.remove i l) x r 299 | | xI i => O.Node' l x (O.remove i r) 300 | end. 301 | Proof. 302 | intros. 303 | assert (E: l = O.Leaf /\ x = None /\ r = O.Leaf \/ O.Node' l x r = O.Node l x r). 304 | { destruct l, x, r; auto. } 305 | destruct E as [(E1 & E2 & E3) | E]. 306 | - subst l x r. simpl. destruct i; auto. 307 | - rewrite E; destruct i; simpl; auto. 308 | Qed. 309 | 310 | Lemma o_remove_notpref: forall {A} (m: O.tree A) p i, 311 | prefix p i = None -> O.remove i (addpref' p m) = addpref' p m. 312 | Proof. 313 | Local Opaque O.Node'. 314 | induction p; intros. 315 | - destruct i; simpl in *; rewrite o_remove_node'; f_equal; auto. 316 | - destruct i; simpl in *; rewrite o_remove_node'; f_equal; auto. 317 | - discriminate. 318 | Qed. 319 | 320 | Lemma o_remove_app: forall {A} p i (m: O.tree A), 321 | O.remove (app p i) (addpref' p m) = addpref' p (O.remove i m). 322 | Proof. 323 | induction p; simpl; intros. 324 | - rewrite o_remove_node'. f_equal; auto. 325 | - rewrite o_remove_node'. f_equal; auto. 326 | - auto. 327 | Qed. 328 | 329 | Lemma addpref'_app: forall {A} p q (m: O.tree A), 330 | addpref' (app p q) m = addpref' p (addpref' q m). 331 | Proof. 332 | induction p; simpl; intros. 333 | - f_equal; auto. 334 | - f_equal; auto. 335 | - auto. 336 | Qed. 337 | 338 | Lemma transl'_node': forall {A} p (l: tree A) x r, 339 | transl' (Node' p l x r) = addpref' p (O.Node' (transl' l) x (transl' r)). 340 | Proof. 341 | intros. destruct l, x, r; auto. 342 | - simpl. induction p; simpl; rewrite <- ? IHp; auto. 343 | - simpl. rewrite addpref'_app. auto. 344 | - simpl. rewrite addpref'_app. auto. 345 | Qed. 346 | 347 | Lemma transl_remove: 348 | forall {A: Type} (m: tree A) i, 349 | transl' (remove i m) = O.remove i (transl' m). 350 | Proof. 351 | induction m; simpl; intros. 352 | - auto. 353 | - destruct (prefix p i) as [ii | ] eqn:P. 354 | + apply prefix_charact in P. subst i. rewrite o_remove_app. 355 | destruct ii; rewrite transl'_node', o_remove_node'; f_equal; auto; f_equal; auto. 356 | + rewrite o_remove_notpref by auto. auto. 357 | Qed. 358 | 359 | (** ** Good variable properties for the basic operations *) 360 | 361 | (** Obtained by transporting the good variable properties for 362 | plain binary tries. *) 363 | 364 | Theorem gempty: 365 | forall {A} (i: positive), get i (empty A) = None. 366 | Proof. 367 | auto. 368 | Qed. 369 | 370 | Theorem gss: 371 | forall {A} (i: positive) (x: A) (m: tree A), get i (set i x m) = Some x. 372 | Proof. 373 | intros. rewrite transl_get, transl_set. apply O.gss. 374 | Qed. 375 | 376 | Theorem gso: 377 | forall {A} (i j: positive) (x: A) (m: tree A), i <> j -> get i (set j x m) = get i m. 378 | Proof. 379 | intros. rewrite ! transl_get, transl_set. apply O.gso; auto. 380 | Qed. 381 | 382 | Theorem grs: 383 | forall {A} (i: positive) (m: tree A), get i (remove i m) = None. 384 | Proof. 385 | intros. rewrite transl'_get, transl_remove. apply O.grs. 386 | Qed. 387 | 388 | Theorem gro: 389 | forall {A} (i j: positive) (m: tree A), 390 | i <> j -> get i (remove j m) = get i m. 391 | Proof. 392 | intros. rewrite ! transl'_get, transl_remove. apply O.gro; auto. 393 | Qed. 394 | 395 | (** ** Collective operations over tries *) 396 | 397 | (** The [map_filter] operation combines a "map" (apply a function to 398 | every value of a trie) and a "filter" (keep only the values 399 | that satisy a given predicate). The function [f] being mapped 400 | has type [A -> option B]. A value [a] in the input trie 401 | becomes a value [b] in the output trie if [f a = Some b] 402 | and is absent in the output trie if [f a = None]. *) 403 | 404 | Section MAP_FILTER. 405 | 406 | Variables A B: Type. 407 | 408 | Definition option_map (f: A -> option B) (o: option A): option B := 409 | match o with None => None | Some a => f a end. 410 | 411 | Fixpoint map_filter (f: A -> option B) (m: tree A) : tree B := 412 | match m with 413 | | Leaf => Leaf 414 | | Node p l o r => Node' p (map_filter f l) (option_map f o) (map_filter f r) 415 | end. 416 | 417 | Lemma gmap_filter: 418 | forall (f: A -> option B) (m: tree A) (i: positive), 419 | get i (map_filter f m) = option_map f (get i m). 420 | Proof. 421 | induction m; intros; simpl. 422 | - auto. 423 | - rewrite gNode'. destruct (prefix p i) as [i'|]; auto. destruct i'; auto. 424 | Qed. 425 | 426 | End MAP_FILTER. 427 | 428 | (** The [combine] operation traverses two tries in parallel, 429 | applying a function [f: option A -> option B -> option C] 430 | at each node to build the resulting trie. *) 431 | 432 | Section COMBINE. 433 | 434 | Variables A B C: Type. 435 | Variable f: option A -> option B -> option C. 436 | Hypothesis f_None_None: f None None = None. 437 | 438 | Let combine_r := map_filter (fun b => f None (Some b)). 439 | Let combine_l := map_filter (fun a => f (Some a) None). 440 | 441 | Fixpoint combine (m1: tree A) (m2: tree B): tree C := 442 | match m1 with 443 | | Leaf => combine_r m2 444 | | Node p1 l1 o1 r1 => 445 | let fix combi (p1: positive) (m2: tree B) : tree C := 446 | match m2, p1 with 447 | | Leaf, _ => combine_l (Node p1 l1 o1 r1) 448 | | Node xH l2 o2 r2, xH => Node' xH (combine l1 l2) (f o1 o2) (combine r1 r2) 449 | | Node xH l2 o2 r2, xO p1 => Node' xH (combi p1 l2) (f None o2) (combine_r r2) 450 | | Node xH l2 o2 r2, xI p1 => Node' xH (combine_r l2) (f None o2) (combi p1 r2) 451 | | Node (xO p2) l2 o2 r2, xH => Node' xH (combine l1 (Node p2 l2 o2 r2)) (f o1 None) (combine_l r1) 452 | | Node (xO p2) l2 o2 r2, xO p1 => Node' xH (combi p1 (Node p2 l2 o2 r2)) None Leaf 453 | | Node (xO p2) l2 o2 r2, xI p1 => Node' xH (combine_r (Node p2 l2 o2 r2)) None (combine_l (Node p1 l1 o1 r1)) 454 | | Node (xI p2) l2 o2 r2, xH => Node' xH (combine_l l1) (f o1 None) (combine r1 (Node p2 l2 o2 r2)) 455 | | Node (xI p2) l2 o2 r2, xO p1 => Node' xH (combine_l (Node p1 l1 o1 r1)) None (combine_r (Node p2 l2 o2 r2)) 456 | | Node (xI p2) l2 o2 r2, xI p1 => Node' xH Leaf None (combi p1 (Node p2 l2 o2 r2)) 457 | end 458 | in combi p1 m2 459 | end. 460 | 461 | Lemma gcombine_l: forall i m1, get i (combine_l m1) = f (get i m1) None. 462 | Proof. 463 | unfold combine_l; intros. rewrite gmap_filter. destruct (get i m1); auto. 464 | Qed. 465 | 466 | Lemma gcombine_r: forall i m2, get i (combine_r m2) = f None (get i m2). 467 | Proof. 468 | unfold combine_r; intros. rewrite gmap_filter. destruct (get i m2); auto. 469 | Qed. 470 | 471 | Lemma gNode'1: forall {A} i l (x: option A) r, 472 | get i (Node' xH l x r) = 473 | match i with xH => x | xO ii => get ii l | xI ii => get ii r end. 474 | Proof. 475 | intros. rewrite gNode'. auto. 476 | Qed. 477 | 478 | Lemma gcombine: 479 | forall (m1: tree A) (m2: tree B) (i: positive), 480 | get i (combine m1 m2) = f (get i m1) (get i m2). 481 | Proof. 482 | Local Opaque map_filter. 483 | Local Opaque Node'. 484 | induction m1; simpl; intros. 485 | - apply gcombine_r. 486 | - rename m1_1 into l1, o into o1, m1_2 into r1. revert m2 i. 487 | induction p; destruct m2 as [ | p2 l2 o2 r2]; intros; try (apply gcombine_l); destruct p2 as [ p2 | p2 | ]; rewrite ? gNode'1. 488 | + destruct i; auto. rewrite IHp; auto. 489 | + destruct i; rewrite ? gcombine_l, ? gcombine_r; auto. 490 | + destruct i; rewrite ? gcombine_r; auto. rewrite IHp; auto. 491 | + destruct i; rewrite ? gcombine_l, ? gcombine_r; auto. 492 | + destruct i; auto. rewrite IHp; auto. 493 | + destruct i; rewrite ? gcombine_r; auto. rewrite IHp; auto. 494 | + destruct i; rewrite ? gcombine_l; auto. rewrite IHm1_2; auto. 495 | + destruct i; rewrite ? gcombine_l; auto. rewrite IHm1_1; auto. 496 | + destruct i; auto. rewrite IHm1_2; auto. rewrite IHm1_1; auto. 497 | Qed. 498 | 499 | End COMBINE. 500 | 501 | End PTree. 502 | 503 | -------------------------------------------------------------------------------- /MMaps/RBTproofs.v: -------------------------------------------------------------------------------- 1 | 2 | (** * Finite Modular Maps : RBT Proofs *) 3 | 4 | (** This is a complement to [Tries.MMaps.RBT], proving the Red/Black balancing 5 | invariants for the code in [Tries.MMaps.RBT], and hence the logarithmic 6 | depth bound. These extra proofs are not even loaded during a regular 7 | usage of [Tries.MMaps.RBT], which already provides proofs of observational 8 | correctness (the binary search tree invariants). 9 | 10 | This is an adapation of Coq [MSetRBT.BalanceProps] to maps. *) 11 | 12 | From Coq Require Import Bool BinPos Pnat Setoid SetoidList Arith. 13 | From Coq Require Import Orders OrdersFacts OrdersLists. 14 | From Tries.MMaps Require Import Interface GenTree RBT. 15 | 16 | Local Set Implicit Arguments. 17 | Local Unset Strict Implicit. 18 | Import ListNotations. 19 | 20 | (* For nicer extraction, we create inductive principles 21 | only when needed *) 22 | Local Unset Elimination Schemes. 23 | 24 | Module BalanceProps(K:OrderedType). 25 | Include Tries.MMaps.RBT.MakeRaw K. 26 | Import GenTree.PairNotations. (* #1 and #2 for fst and snd *) 27 | Local Open Scope lazy_bool_scope. 28 | Local Notation color := Color.t. 29 | Local Arguments Leaf {elt}. 30 | Local Notation Rd := (@Node _ Red). 31 | Local Notation Bk := (@Node _ Black). 32 | 33 | (** ** Red-Black invariants *) 34 | 35 | (** In a red-black tree : 36 | - a red node has no red children 37 | - the black depth at each node is the same along all paths. 38 | The black depth is here an argument of the predicate. *) 39 | 40 | Inductive rbt elt : nat -> tree elt -> Prop := 41 | | RB_Leaf : rbt 0 Leaf 42 | | RB_Rd n l k e r : 43 | notred l -> notred r -> rbt n l -> rbt n r -> rbt n (Rd l k e r) 44 | | RB_Bk n l k e r : rbt n l -> rbt n r -> rbt (S n) (Bk l k e r). 45 | 46 | (** A red-red tree is almost a red-black tree, except that it has 47 | a _red_ root node which _may_ have red children. Note that a 48 | red-red tree is hence non-empty, and all its strict subtrees 49 | are red-black. *) 50 | 51 | Inductive rrt elt (n:nat) : tree elt -> Prop := 52 | | RR_Rd l k e r : rbt n l -> rbt n r -> rrt n (Rd l k e r). 53 | 54 | (** An almost-red-black tree is almost a red-black tree, except that 55 | it's permitted to have two red nodes in a row at the very root (only). 56 | We implement this notion by saying that a quasi-red-black tree 57 | is either a red-black tree or a red-red tree. *) 58 | 59 | Inductive arbt elt (n:nat)(t:tree elt) : Prop := 60 | | ARB_RB : rbt n t -> arbt n t 61 | | ARB_RR : rrt n t -> arbt n t. 62 | 63 | (** The main exported invariant : being a red-black tree for some 64 | black depth. *) 65 | 66 | Class Rbt elt (t:tree elt) := RBT : exists d, rbt d t. 67 | 68 | (** ** Basic tactics and results about red-black *) 69 | 70 | Scheme rbt_ind := Induction for rbt Sort Prop. 71 | Local Hint Constructors rbt rrt arbt : map. 72 | Local Hint Extern 0 (notred _) => (exact I) : map. 73 | Ltac invrb := intros; inv rrt; inv rbt; try contradiction. 74 | Ltac descolor := destruct_all Color.t. 75 | Ltac destree t := destruct t as [|[|] ? ? ? ?]. 76 | Ltac desarb := match goal with H:arbt _ _ |- _ => destruct H end. 77 | Ltac nonzero n := destruct n as [|n]; [try split; invrb|]. 78 | 79 | Notation notredred := (rrcase (fun _ _ _ _ _ _ _ => False) (fun _ => True)). 80 | 81 | Section Elt. 82 | Variable elt : Type. 83 | Implicit Type t s l r : tree elt. 84 | Implicit Type e v : elt. 85 | 86 | Lemma rr_nrr_rb n t : 87 | rrt n t -> notredred t -> rbt n t. 88 | Proof. 89 | destruct 1 as [l x e r Hl Hr]. 90 | unfold rrcase; destmatch; now autom. 91 | Qed. 92 | 93 | Local Hint Resolve rr_nrr_rb : map. 94 | 95 | Lemma arb_nrr_rb n t : 96 | arbt n t -> notredred t -> rbt n t. 97 | Proof. 98 | destruct 1; autom. 99 | Qed. 100 | 101 | Lemma arb_nr_rb n t : 102 | arbt n t -> notred t -> rbt n t. 103 | Proof. 104 | destruct 1; destruct t; descolor; invrb; autom. 105 | Qed. 106 | 107 | Local Hint Resolve arb_nrr_rb arb_nr_rb : map. 108 | 109 | (** ** A Red-Black tree has indeed a logarithmic depth *) 110 | 111 | Definition redcarac s := 112 | rcase (elt:=elt) (fun _ _ _ _ => 1) (fun _ => 0) s. 113 | 114 | Lemma rb_maxdepth s n : rbt n s -> maxdepth s <= 2*n + redcarac s. 115 | Proof. 116 | induction 1. 117 | - simpl; auto. 118 | - replace (redcarac l) with 0 in * by now destree l. 119 | replace (redcarac r) with 0 in * by now destree r. 120 | simpl maxdepth. simpl redcarac. 121 | rewrite Nat.add_succ_r, <- Nat.succ_le_mono. 122 | now apply Nat.max_lub. 123 | - simpl. rewrite <- Nat.succ_le_mono. 124 | apply Nat.max_lub; eapply Nat.le_trans; eauto; 125 | [destree l | destree r]; simpl; 126 | rewrite !Nat.add_0_r, ?Nat.add_1_r; auto with arith. 127 | Qed. 128 | 129 | Lemma rb_mindepth s n : rbt n s -> n + redcarac s <= mindepth s. 130 | Proof. 131 | induction 1; simpl. 132 | - trivial. 133 | - rewrite Nat.add_succ_r. 134 | apply -> Nat.succ_le_mono. 135 | replace (redcarac l) with 0 in * by now destree l. 136 | replace (redcarac r) with 0 in * by now destree r. 137 | now apply Nat.min_glb. 138 | - apply -> Nat.succ_le_mono. rewrite Nat.add_0_r. 139 | apply Nat.min_glb; eauto with arith. 140 | Qed. 141 | 142 | Lemma maxdepth_upperbound s : Rbt s -> 143 | maxdepth s <= 2 * Nat.log2 (S (cardinal s)). 144 | Proof. 145 | intros (n,H). 146 | eapply Nat.le_trans; [eapply rb_maxdepth; eauto|]. 147 | transitivity (2*(n+redcarac s)). 148 | - rewrite Nat.mul_add_distr_l. apply Nat.add_le_mono_l. 149 | rewrite <- Nat.mul_1_l at 1. apply Nat.mul_le_mono_r. 150 | auto with arith. 151 | - apply Nat.mul_le_mono_l. 152 | transitivity (mindepth s). 153 | + now apply rb_mindepth. 154 | + apply mindepth_log_cardinal. 155 | Qed. 156 | 157 | Lemma maxdepth_lowerbound s : s<>Leaf -> 158 | Nat.log2 (cardinal s) < maxdepth s. 159 | Proof. 160 | apply maxdepth_log_cardinal. 161 | Qed. 162 | 163 | 164 | (** ** Singleton *) 165 | 166 | Lemma singleton_rb x e : Rbt (singleton x e). 167 | Proof. 168 | unfold singleton. exists 1; autom. 169 | Qed. 170 | 171 | (** ** [makeBlack] and [makeRed] *) 172 | 173 | Lemma makeBlack_rb n t : arbt n t -> Rbt (makeBlack t). 174 | Proof. 175 | destruct t as [|[|] l x e r]. 176 | - exists 0; simpl; autom. 177 | - destruct 1; invrb; exists (S n); simpl; autom. 178 | - exists n; autom. 179 | Qed. 180 | 181 | Lemma makeRed_rr t n : 182 | rbt (S n) t -> notred t -> rrt n (makeRed t). 183 | Proof. 184 | destruct t as [|[|] l x e r]; invrb; simpl; autom. 185 | Qed. 186 | 187 | (** ** Balancing *) 188 | 189 | Lemma lbal_rb n l k e r : 190 | arbt n l -> rbt n r -> rbt (S n) (lbal l k e r). 191 | Proof. 192 | case lbal_match; intros; desarb; invrb; autom. 193 | Qed. 194 | 195 | Lemma rbal_rb n l k e r : 196 | rbt n l -> arbt n r -> rbt (S n) (rbal l k e r). 197 | Proof. 198 | case rbal_match; intros; desarb; invrb; autom. 199 | Qed. 200 | 201 | Lemma rbal'_rb n l k e r : 202 | rbt n l -> arbt n r -> rbt (S n) (rbal' l k e r). 203 | Proof. 204 | case rbal'_match; intros; desarb; invrb; autom. 205 | Qed. 206 | 207 | Lemma lbalS_rb n l x e r : 208 | arbt n l -> rbt (S n) r -> notred r -> rbt (S n) (lbalS l x e r). 209 | Proof. 210 | intros Hl Hr Hr'. 211 | destruct r as [|[|] rl rx rv rr]; invrb. clear Hr'. 212 | revert Hl. 213 | case lbalS_match. 214 | - destruct 1; invrb; autom. 215 | - intros. apply rbal'_rb; autom. 216 | Qed. 217 | 218 | Lemma lbalS_arb n l x e r : 219 | arbt n l -> rbt (S n) r -> arbt (S n) (lbalS l x e r). 220 | Proof. 221 | case lbalS_match. 222 | - destruct 1; invrb; autom. 223 | - clear l. intros l Hl Hl' Hr. 224 | destruct r as [|[|] rl rx rv rr]; invrb. 225 | * destruct rl as [|[|] rll rlx rlv rlr]; invrb. 226 | right; auto using rbal'_rb, makeRed_rr with map. 227 | * left; apply rbal'_rb; autom. 228 | Qed. 229 | 230 | Lemma rbalS_rb n l x e r : 231 | rbt (S n) l -> notred l -> arbt n r -> rbt (S n) (rbalS l x e r). 232 | Proof. 233 | intros Hl Hl' Hr. 234 | destruct l as [|[|] ll lx lv lr]; invrb. clear Hl'. 235 | revert Hr. 236 | case rbalS_match. 237 | - destruct 1; invrb; autom. 238 | - intros. apply lbal_rb; autom. 239 | Qed. 240 | 241 | Lemma rbalS_arb n l x e r : 242 | rbt (S n) l -> arbt n r -> arbt (S n) (rbalS l x e r). 243 | Proof. 244 | case rbalS_match. 245 | - destruct 2; invrb; autom. 246 | - clear r. intros r Hr Hr' Hl. 247 | destruct l as [|[|] ll lx lv lr]; invrb. 248 | * destruct lr as [|[|] lrl lrx lrv lrr]; invrb. 249 | right; auto using lbal_rb, makeRed_rr with map. 250 | * left; apply lbal_rb; autom. 251 | Qed. 252 | 253 | 254 | (** ** Insertion *) 255 | 256 | (** The next lemmas combine simultaneous results about rbt and arbt. 257 | A first solution here: statement with [if ... then ... else] *) 258 | 259 | Definition ifred s (A B:Prop) := rcase (fun _ _ _ _ => A) (fun _ => B) s. 260 | 261 | Lemma ifred_notred s A B : notred s -> (ifred s A B <-> B). 262 | Proof. 263 | destruct s; descolor; simpl; intuition. 264 | Qed. 265 | 266 | Lemma ifred_or s A B : ifred s A B -> A\/B. 267 | Proof. 268 | destruct s; descolor; simpl; intuition. 269 | Qed. 270 | 271 | Lemma ins_rr_rb x e s n : rbt n s -> 272 | ifred s (rrt n (ins x e s)) (rbt n (ins x e s)). 273 | Proof. 274 | induction 1 as [ | n l k v r | n l k v r Hl IHl Hr IHr ]. 275 | - simpl; autom. 276 | - simpl. rewrite ifred_notred in * by trivial. 277 | destmatch; autom. 278 | - rewrite ifred_notred by autom. 279 | cbn. destmatch; intro. 280 | * autom. 281 | * apply lbal_rb; trivial. apply ifred_or in IHl; intuition. 282 | * apply rbal_rb; trivial. apply ifred_or in IHr; intuition. 283 | Qed. 284 | 285 | Lemma ins_arb x e s n : rbt n s -> arbt n (ins x e s). 286 | Proof. 287 | intros H. apply (ins_rr_rb x e), ifred_or in H. intuition. 288 | Qed. 289 | 290 | Instance add_rb x e s : Rbt s -> Rbt (add x e s). 291 | Proof. 292 | intros (n,H). unfold add. now apply (@makeBlack_rb n), ins_arb. 293 | Qed. 294 | 295 | (** ** Deletion *) 296 | 297 | (*TODO: share with RBT *) 298 | 299 | Ltac append_tac l r := 300 | induction l as [| lc ll _ lx lv lr IHlr]; 301 | [intro r; simpl 302 | |induction r as [| rc rl IHrl rx rv rr _]; 303 | [simpl 304 | |destruct lc, rc; 305 | [specialize (IHlr rl); clear IHrl 306 | |simpl; 307 | assert (Hr:notred (Bk rl rx rv rr)) by (simpl; trivial); 308 | set (r:=Bk rl rx rv rr) in *; clearbody r; clear IHrl rl rx rv rr; 309 | specialize (IHlr r) 310 | |change (append _ _) with (Rd (append (Bk ll lx lv lr) rl) rx rv rr); 311 | assert (Hl:notred (Bk ll lx lv lr)) by (simpl; trivial); 312 | set (l:=Bk ll lx lv lr) in *; clearbody l; clear IHlr ll lx lv lr 313 | |specialize (IHlr rl); clear IHrl]]]. 314 | 315 | Fact append_rr_match ll lx lv lr rl rx rv rr : 316 | rspec 317 | (fun a x e b => Rd (Rd ll lx lv a) x e (Rd b rx rv rr)) 318 | (fun t => Rd ll lx lv (Rd t rx rv rr)) 319 | (append lr rl) 320 | (append (Rd ll lx lv lr) (Rd rl rx rv rr)). 321 | Proof. 322 | exact (rmatch _ _ _). 323 | Qed. 324 | 325 | Fact append_bb_match ll lx lv lr rl rx rv rr : 326 | rspec 327 | (fun a x e b => Rd (Bk ll lx lv a) x e (Bk b rx rv rr)) 328 | (fun t => lbalS ll lx lv (Bk t rx rv rr)) 329 | (append lr rl) 330 | (append (Bk ll lx lv lr) (Bk rl rx rv rr)). 331 | Proof. 332 | exact (rmatch _ _ _). 333 | Qed. 334 | 335 | (** A second approach here: statement with ... /\ ... *) 336 | 337 | Lemma append_arb_rb n l r : rbt n l -> rbt n r -> 338 | (arbt n (append l r)) /\ 339 | (notred l -> notred r -> rbt n (append l r)). 340 | Proof. 341 | revert r n. 342 | append_tac l r. 343 | - split; autom. 344 | - split; autom. 345 | - (* Red / Red *) 346 | intros n. invrb. 347 | case (IHlr n); auto; clear IHlr. 348 | case append_rr_match. 349 | + intros a x v b _ H; split; invrb. 350 | assert (rbt n (Rd a x v b)) by autom. invrb. autom. 351 | + split; invrb; autom. 352 | - (* Red / Black *) 353 | split; invrb. destruct (IHlr n) as (_,IH); autom. 354 | - (* Black / Red *) 355 | split; invrb. destruct (IHrl n) as (_,IH); autom. 356 | - (* Black / Black *) 357 | nonzero n. 358 | invrb. 359 | destruct (IHlr n) as (IH,_); auto; clear IHlr. 360 | revert IH. 361 | case append_bb_match. 362 | + intros a x v b IH; split; destruct IH; invrb; autom. 363 | + split; [left | invrb]; auto using lbalS_rb with map. 364 | Qed. 365 | 366 | Ltac induct' m := 367 | induction m as [|c l IHl x' vx' r IHr]; simpl; intros; 368 | [|case K.compare_spec; intros]. 369 | 370 | (** A third approach : Lemma ... with ... *) 371 | 372 | Lemma del_arb s x n : rbt (S n) s -> isblack s -> arbt n (del x s) 373 | with del_rb s x n : rbt n s -> notblack s -> rbt n (del x s). 374 | Proof. 375 | { revert n. 376 | induct' s; descolor; try easy; invrb. 377 | - apply append_arb_rb; assumption. 378 | - assert (IHl' := del_rb l x). clear IHr del_arb del_rb. 379 | destruct l as [|[|] ll lx lv lr]; autom. 380 | nonzero n. apply lbalS_arb; autom. 381 | - assert (IHr' := del_rb r x). clear IHl del_arb del_rb. 382 | destruct r as [|[|] rl rx rv rr]; autom. 383 | nonzero n. apply rbalS_arb; auto. } 384 | { revert n. 385 | induct' s; descolor; try easy; invrb. 386 | - apply append_arb_rb; assumption. 387 | - assert (IHl' := del_arb l x). clear IHr del_arb del_rb. 388 | destruct l as [|[|] ll lx lv lr]; autom. 389 | nonzero n. destruct n as [|n]; [invrb|]; apply lbalS_rb; autom. 390 | - assert (IHr' := del_arb r x). clear IHl del_arb del_rb. 391 | destruct r as [|[|] rl rx rv rr]; autom. 392 | nonzero n. apply rbalS_rb; auto. } 393 | Qed. 394 | 395 | Instance remove_rb s x : Rbt s -> Rbt (remove x s). 396 | Proof. 397 | intros (n,H). unfold remove. 398 | destruct s as [|[|] l y v r]. 399 | - apply (@makeBlack_rb n). autom. 400 | - apply (@makeBlack_rb n). left. apply del_rb; simpl; autom. 401 | - nonzero n. apply (@makeBlack_rb n). apply del_arb; simpl; autom. 402 | Qed. 403 | 404 | (** ** Treeify *) 405 | 406 | Local Notation ifpred p n := (if p then pred n else n%nat). 407 | Local Notation treeify_t := (klist elt -> tree elt * klist elt). 408 | 409 | Definition treeify_rb_invariant size depth (f:treeify_t) := 410 | forall acc, 411 | size <= length acc -> 412 | rbt depth (fst (f acc)) /\ 413 | size + length (snd (f acc)) = length acc. 414 | 415 | Lemma treeify_zero_rb : treeify_rb_invariant 0 0 (@treeify_zero elt). 416 | Proof. 417 | intros acc _; simpl; autom. 418 | Qed. 419 | 420 | Lemma treeify_one_rb : treeify_rb_invariant 1 0 (@treeify_one elt). 421 | Proof. 422 | intros [|(x,e) acc]; simpl; autom; inversion 1. 423 | Qed. 424 | 425 | Lemma treeify_cont_rb f g size1 size2 size d : 426 | treeify_rb_invariant size1 d f -> 427 | treeify_rb_invariant size2 d g -> 428 | size = S (size1 + size2) -> 429 | treeify_rb_invariant size (S d) (treeify_cont f g). 430 | Proof. 431 | intros Hf Hg H acc Hacc. 432 | unfold treeify_cont. 433 | specialize (Hf acc). 434 | destruct (f acc) as (l, acc1). simpl in *. 435 | destruct Hf as (Hf1, Hf2). { subst. eauto with arith. } 436 | destruct acc1 as [|(x,e) acc2]; simpl in *. 437 | - exfalso. revert Hacc. apply Nat.lt_nge. rewrite H, <- Hf2. 438 | auto with arith. 439 | - specialize (Hg acc2). 440 | destruct (g acc2) as (r, acc3). simpl in *. 441 | destruct Hg as (Hg1, Hg2). 442 | { revert Hacc. 443 | rewrite H, <- Hf2, Nat.add_succ_r, <- Nat.succ_le_mono. 444 | apply Nat.add_le_mono_l. } 445 | split; autom. 446 | now rewrite H, <- Hf2, <- Hg2, Nat.add_succ_r, Nat.add_assoc. 447 | Qed. 448 | 449 | Lemma treeify_aux_rb n : 450 | exists d, forall (b:bool), 451 | treeify_rb_invariant (ifpred b (Pos.to_nat n)) d (treeify_aux b n). 452 | Proof. 453 | induction n as [n (d,IHn)|n (d,IHn)| ]. 454 | - exists (S d). intros b. 455 | eapply treeify_cont_rb; [ apply (IHn false) | apply (IHn b) | ]. 456 | rewrite Pos2Nat.inj_xI. 457 | assert (H := Pos2Nat.is_pos n). apply Nat.neq_0_lt_0 in H. 458 | destruct b; simpl; intros; rewrite Nat.add_0_r; trivial. 459 | now rewrite <- Nat.add_succ_r, Nat.succ_pred; trivial. 460 | - exists (S d). intros b. 461 | eapply treeify_cont_rb; [ apply (IHn b) | apply (IHn true) | ]. 462 | rewrite Pos2Nat.inj_xO. 463 | assert (H := Pos2Nat.is_pos n). apply Nat.neq_0_lt_0 in H. 464 | rewrite <- Nat.add_succ_r, Nat.succ_pred by trivial. 465 | destruct b; simpl; intros; rewrite Nat.add_0_r; trivial. 466 | symmetry. now apply Nat.add_pred_l. 467 | - exists 0; destruct b; 468 | [ apply treeify_zero_rb | apply treeify_one_rb ]. 469 | Qed. 470 | 471 | (** The black depth of [treeify l] is actually a log2, but 472 | we don't need to mention that. *) 473 | 474 | Instance treeify_rb (l:klist elt) : Rbt (treeify l). 475 | Proof. 476 | unfold treeify. 477 | destruct (treeify_aux_rb (plength l)) as (d,H). 478 | exists d. 479 | apply H. 480 | now rewrite plength_spec. 481 | Qed. 482 | 483 | Instance filter_rb (f:key->elt->bool) m : Rbt m -> Rbt (filter f m). 484 | Proof. 485 | unfold filter. intros. apply treeify_rb. 486 | Qed. 487 | 488 | Instance partition_rb1 (f:key->elt->bool) m : 489 | Rbt m -> Rbt (fst (partition f m)). 490 | Proof. 491 | unfold partition. intros. destruct partition_aux. apply treeify_rb. 492 | Qed. 493 | 494 | Instance partition_rb2 (f:key->elt->bool) m : 495 | Rbt m -> Rbt (snd (partition f m)). 496 | Proof. 497 | unfold partition. intros. destruct partition_aux. apply treeify_rb. 498 | Qed. 499 | 500 | End Elt. 501 | 502 | Instance map_rb {elt elt'}(f:elt->elt') m : Rbt m -> Rbt (map f m). 503 | Proof. 504 | intros (n,H). exists n. induction H; simpl; constructor; auto. 505 | destruct l; auto. 506 | destruct r; auto. 507 | Qed. 508 | 509 | Instance mapi_rb {elt elt'}(f:key->elt->elt') m : Rbt m -> Rbt (mapi f m). 510 | Proof. 511 | intros (n,H). exists n. induction H; simpl; constructor; auto. 512 | destruct l; auto. 513 | destruct r; auto. 514 | Qed. 515 | 516 | Instance merge_rb {elt elt' elt''} 517 | (f:key -> option elt -> option elt' -> option elt'') m m' : 518 | Rbt m -> Rbt m' -> Rbt (merge f m m'). 519 | Proof. 520 | unfold merge. intros. apply treeify_rb. 521 | Qed. 522 | 523 | End BalanceProps. 524 | 525 | (** We could hence define [Ok m] as [Bst m /\ Rbt m] and re-validate 526 | the [Raw.S] signature. This would be more robust in case new ops 527 | are added in the signature. But that would be yet another wrapper, 528 | so we don't do it for the moment. *) 529 | -------------------------------------------------------------------------------- /MMaps/AVLproofs.v: -------------------------------------------------------------------------------- 1 | 2 | (** * Finite Modular Maps : AVL Proofs *) 3 | 4 | (** Author : Pierre Letouzey (Université de Paris - INRIA), 5 | adapted from earlier works in Coq Standard Library, see README.md. 6 | Licence : LGPL 2.1, see file LICENSE. *) 7 | 8 | (** This is a complement to [Tries.MMaps.AVL], proving the AVL balancing 9 | invariants for the code in [Tries.MMaps.AVL], and hence the logarithmic 10 | depth bound. These extra proofs are not even loaded during a regular 11 | usage of [Tries.MMaps.AVL], which already provides proofs of observational 12 | correctness (the binary search tree invariants). 13 | 14 | This is an adapation of Coq [MSetFullAVL] to maps. *) 15 | 16 | From Coq Require Import ZArith Int Lia PeanoNat FunInd Orders. 17 | From Tries.MMaps Require Import GenTree AVL. 18 | 19 | Set Implicit Arguments. 20 | 21 | Module AvlProofs (Import I:Int)(X:OrderedType). 22 | Include Tries.MMaps.AVL.MakeRaw I X. 23 | Module Import II := MoreInt I. 24 | Local Open Scope Int_scope. 25 | Import GenTree.PairNotations. (* #1 and #2 for fst and snd *) 26 | 27 | Ltac lia_max := i2z_refl; lia. 28 | Ltac mysubst := 29 | match goal with 30 | | E : _=_ |- _ => rewrite E in *; clear E; mysubst 31 | | _ => idtac 32 | end. 33 | 34 | (** * AVL trees *) 35 | 36 | (** [avl s] : [s] is a properly balanced AVL tree, 37 | i.e. for any node the heights of the two children 38 | differ by at most 2 *) 39 | 40 | Inductive avl elt : tree elt -> Prop := 41 | | RBLeaf : avl (Leaf _) 42 | | RBNode : forall x e l r h, avl l -> avl r -> 43 | -(2) <= height l - height r <= 2 -> 44 | h = max (height l) (height r) + 1 -> 45 | avl (Node h l x e r). 46 | 47 | Class Avl elt (t:tree elt) : Prop := mkAvl : avl t. 48 | 49 | Instance avl_Avl elt (s:tree elt) (Hs : avl s) : Avl s := Hs. 50 | 51 | (** * Automation and dedicated tactics *) 52 | 53 | Local Hint Constructors avl : map. 54 | 55 | (** A tactic for cleaning hypothesis after use of functional induction. *) 56 | 57 | Ltac clearf := 58 | match goal with 59 | | H : (@Logic.eq (sumbool _ _) _ _) |- _ => clear H; clearf 60 | | H : (_ =? _) = true |- _ => rewrite II.eqb_eq in H; clearf 61 | | H : (_ rewrite II.ltb_lt in H; clearf 62 | | H : (_ <=? _) = true |- _ => rewrite II.leb_le in H; clearf 63 | | H : (_ =? _) = false |- _ => rewrite II.eqb_neq in H; clearf 64 | | H : (_ rewrite II.ltb_nlt in H; clearf 65 | | H : (_ <=? _) = false |- _ => rewrite II.leb_nle in H; clearf 66 | | _ => idtac 67 | end. 68 | 69 | Ltac avl2Avl := change avl with Avl in *. 70 | Ltac Avl2avl := change Avl with avl in *. 71 | Ltac inv_avl := Avl2avl; inv avl; avl2Avl. 72 | (* Similar, but non-recursive *) 73 | Ltac inv_avl' := 74 | match goal with H : Avl (Node _ _ _ _ _) |- _ => 75 | inversion_clear H; avl2Avl 76 | end. 77 | 78 | (** * AVL trees have indeed logarithmic depth *) 79 | 80 | Module LogDepth. 81 | 82 | Local Open Scope nat_scope. 83 | 84 | (** The minimal cardinal of an AVL tree of a given height. 85 | NB: this minimal cardinal is optimal, i.e. for any height, 86 | we could build an AVL tree of this cardinal. *) 87 | 88 | Fixpoint mincard n := 89 | match n with 90 | | O => O 91 | | 1 => 1 92 | | 2 => 2 93 | | S (S (S n) as p) => S (mincard n + mincard p) 94 | end. 95 | 96 | (** First, some basic properties of [mincard] *) 97 | 98 | Lemma mincard_eqn n : 99 | mincard (S (S (S n))) = S (mincard n + mincard (2+n)). 100 | Proof. 101 | reflexivity. 102 | Qed. 103 | 104 | Lemma mincard_incr n : mincard n < mincard (S n). 105 | Proof. 106 | induction n using lt_wf_ind. 107 | do 3 (destruct n; auto). 108 | rewrite 2 mincard_eqn. 109 | apply -> Nat.succ_lt_mono. 110 | apply Nat.add_lt_mono; eauto. 111 | Qed. 112 | 113 | Lemma mincard_lt_mono n m : n < m -> mincard n < mincard m. 114 | Proof. 115 | induction m; inversion_clear 1. 116 | - apply mincard_incr. 117 | - transitivity (mincard m); auto using mincard_incr. 118 | Qed. 119 | 120 | Lemma mincard_le_mono n m : n <= m -> mincard n <= mincard m. 121 | Proof. 122 | induction 1; auto. 123 | transitivity (mincard m); auto using mincard_incr with arith. 124 | Qed. 125 | 126 | Lemma mincard_bound n m : m <= 2+n -> 127 | mincard (S m) <= S (mincard n + mincard m). 128 | Proof. 129 | intros H. 130 | destruct m as [|[|m]]. 131 | - simpl. auto with arith. 132 | - simpl. auto with arith. 133 | - rewrite mincard_eqn. 134 | apply -> Nat.succ_le_mono. 135 | apply Nat.add_le_mono; eauto. 136 | apply mincard_le_mono; lia. 137 | Qed. 138 | 139 | (** [mincard] has an exponential behavior *) 140 | 141 | Lemma mincard_twice n : 2 * mincard n < mincard (2+n). 142 | Proof. 143 | induction n as [n IH] using lt_wf_ind. 144 | do 3 (destruct n; [simpl; auto with arith|]). 145 | change (2 + S (S (S n))) with (S (S (S (2+n)))). 146 | rewrite 2 mincard_eqn. 147 | generalize (IH n) (IH (2+n)). lia. 148 | Qed. 149 | 150 | Lemma mincard_even n : n<>0 -> 2^n <= mincard (2*n). 151 | Proof. 152 | induction n. 153 | - now destruct 1. 154 | - intros _. 155 | destruct (Nat.eq_dec n 0). 156 | * subst; simpl; auto. 157 | * rewrite Nat.pow_succ_r', Nat.mul_succ_r, Nat.add_comm. 158 | transitivity (2 * mincard (2*n)). 159 | + apply Nat.mul_le_mono_l; auto. 160 | + apply Nat.lt_le_incl. apply mincard_twice. 161 | Qed. 162 | 163 | Lemma mincard_odd n : 2^n <= mincard (2*n+1). 164 | Proof. 165 | destruct (Nat.eq_dec n 0). 166 | - subst; auto. 167 | - transitivity (mincard (2*n)). 168 | * now apply mincard_even. 169 | * apply mincard_le_mono. lia. 170 | Qed. 171 | 172 | Lemma mincard_log n : n <= 2 * Nat.log2 (mincard n) + 1. 173 | Proof. 174 | rewrite (Nat.div2_odd n). 175 | set (m := Nat.div2 n); clearbody m. 176 | destruct (Nat.odd n); simpl Nat.b2n; rewrite ?Nat.add_0_r; clear n. 177 | + apply Nat.add_le_mono_r, Nat.mul_le_mono_l. 178 | apply Nat.log2_le_pow2. 179 | apply (@mincard_lt_mono 0); auto with arith. 180 | apply mincard_odd. 181 | + destruct (Nat.eq_dec m 0); [subst; simpl; auto|]. 182 | transitivity (2*Nat.log2 (mincard (2*m))); [|lia]. 183 | apply Nat.mul_le_mono_l. 184 | apply Nat.log2_le_pow2. 185 | apply (@mincard_lt_mono 0); lia. 186 | now apply mincard_even. 187 | Qed. 188 | 189 | (** We now prove that [mincard] gives indeed a lower bound 190 | of the cardinal of AVL trees. *) 191 | 192 | Lemma maxdepth_heigth elt (s:t elt) : Avl s -> 193 | Z.of_nat (maxdepth s) = i2z (height s). 194 | Proof. 195 | induction 1. 196 | simpl. lia_max. 197 | simpl maxdepth. simpl height. subst h. 198 | rewrite Nat2Z.inj_succ, Nat2Z.inj_max. lia_max. 199 | Qed. 200 | 201 | Lemma mincard_maxdepth elt (s:t elt) : 202 | Avl s -> mincard (maxdepth s) <= cardinal s. 203 | Proof. 204 | induction 1. 205 | - simpl; auto. 206 | - simpl maxdepth. simpl cardinal. subst h. 207 | destruct (Nat.max_spec (maxdepth l) (maxdepth r)) as [(U,->)|(U,->)]. 208 | * rewrite mincard_bound. 209 | apply -> Nat.succ_le_mono. 210 | apply Nat.add_le_mono; eauto. 211 | apply Nat2Z.inj_le. rewrite Nat2Z.inj_add. 212 | rewrite 2 maxdepth_heigth by auto. simpl Z.of_nat. 213 | i2z. lia. 214 | * rewrite Nat.add_comm, mincard_bound. 215 | apply -> Nat.succ_le_mono. 216 | apply Nat.add_le_mono; eauto. 217 | apply Nat2Z.inj_le. rewrite Nat2Z.inj_add. 218 | rewrite 2 maxdepth_heigth by auto. simpl Z.of_nat. 219 | i2z. lia. 220 | Qed. 221 | 222 | (** We can now prove that the depth of an AVL tree is 223 | logarithmic in its size. *) 224 | 225 | Lemma maxdepth_upperbound elt (s:t elt) : Avl s -> 226 | maxdepth s <= 2 * Nat.log2 (cardinal s) + 1. 227 | Proof. 228 | intros. 229 | transitivity (2 * Nat.log2 (mincard (maxdepth s)) + 1). 230 | apply mincard_log. 231 | apply Nat.add_le_mono_r, Nat.mul_le_mono_l, Nat.log2_le_mono. 232 | now apply mincard_maxdepth. 233 | Qed. 234 | 235 | Lemma maxdepth_lowerbound elt (s:t elt) : s<>Leaf _ -> 236 | Nat.log2 (cardinal s) < maxdepth s. 237 | Proof. 238 | apply maxdepth_log_cardinal. 239 | Qed. 240 | 241 | End LogDepth. 242 | 243 | Section Elt. 244 | Variable elt : Type. 245 | Implicit Type t s l r : tree elt. 246 | Implicit Type e v : elt. 247 | 248 | (** Tactics about [avl] *) 249 | 250 | Lemma height_non_negative : forall s `{!Avl s}, height s >= 0. 251 | Proof. 252 | induction s; simpl; intros; auto with zarith. 253 | inv_avl; intuition; lia_max. 254 | Qed. 255 | 256 | (** When [H:Avl r], typing [avl_nn H] adds [height r >= 0] *) 257 | 258 | Ltac avl_nn H := 259 | let nz := fresh "nz" in assert (nz := @height_non_negative _ H). 260 | 261 | (* Repeat the previous tactic, clearing the [Avl _] hyps *) 262 | 263 | Ltac avl_nns := 264 | match goal with 265 | | H:Avl _ |- _ => avl_nn H; clear H; avl_nns 266 | | _ => idtac 267 | end. 268 | 269 | (** Results about [height] *) 270 | 271 | Lemma height_0 : forall s `{!Avl s}, height s = 0 -> s = Leaf _. 272 | Proof. 273 | destruct 1; avl2Avl; intuition; simpl in *. 274 | avl_nns. simpl in *; exfalso; lia_max. 275 | Qed. 276 | 277 | (** Results about [avl] *) 278 | 279 | Lemma avl_node : 280 | forall x e l r `{!Avl l, !Avl r}, 281 | -(2) <= height l - height r <= 2 -> 282 | Avl (Node (max (height l) (height r) + 1) l x e r). 283 | Proof. 284 | autok. 285 | Qed. 286 | Local Hint Resolve avl_node : map. 287 | 288 | (** * The AVL invariant is preserved by set operations *) 289 | 290 | (** empty *) 291 | 292 | Instance empty_avl : Avl (empty elt). 293 | Proof. 294 | autok. 295 | Qed. 296 | 297 | (** singleton *) 298 | 299 | Instance singleton_avl x e : Avl (singleton x e). 300 | Proof. 301 | unfold singleton. constructor; autom; simpl; lia_max. 302 | Qed. 303 | 304 | (** create *) 305 | 306 | Lemma create_avl : 307 | forall l x e r `{!Avl l, !Avl r}, 308 | -(2) <= height l - height r <= 2 -> 309 | Avl (create l x e r). 310 | Proof. 311 | unfold create; autom. 312 | Qed. 313 | 314 | Lemma create_height : 315 | forall l x e r `{!Avl l, !Avl r}, 316 | -(2) <= height l - height r <= 2 -> 317 | height (create l x e r) = max (height l) (height r) + 1. 318 | Proof. 319 | unfold create; autom. 320 | Qed. 321 | 322 | (** bal *) 323 | 324 | Ltac when f := 325 | match goal with |- context [f] => idtac | _ => fail end. 326 | 327 | Lemma bal_avl : 328 | forall l x e r `{!Avl l, !Avl r}, 329 | -(3) <= height l - height r <= 3 -> 330 | Avl (bal l x e r). 331 | Proof. 332 | intros l x e r; functional induction (bal l x e r); intros; clearf; 333 | inv_avl; simpl in *; try (when assert_false; avl_nns); 334 | repeat apply create_avl; simpl in *; auto; lia_max. 335 | Qed. 336 | 337 | Lemma bal_height_1 : 338 | forall l x e r `{!Avl l, !Avl r}, 339 | -(3) <= height l - height r <= 3 -> 340 | 0 <= height (bal l x e r) - max (height l) (height r) <= 1. 341 | Proof. 342 | intros l x e r; functional induction (bal l x e r); intros; clearf; 343 | inv_avl; avl_nns; simpl in *; lia_max. 344 | Qed. 345 | 346 | Lemma bal_height_2 : 347 | forall l x e r `{!Avl l, !Avl r}, 348 | -(2) <= height l - height r <= 2 -> 349 | height (bal l x e r) == max (height l) (height r) +1. 350 | Proof. 351 | intros l x e r; functional induction (bal l x e r); intros; clearf; 352 | inv_avl; simpl in *; lia_max. 353 | Qed. 354 | 355 | Ltac lia_bal := match goal with 356 | | Hl:Avl ?l, Hr:Avl ?r |- context [ bal ?l ?x ?e ?r ] => 357 | generalize (@bal_height_1 l x e r Hl Hr) (@bal_height_2 l x e r Hl Hr); 358 | lia_max 359 | end. 360 | 361 | (** add *) 362 | 363 | Ltac induct m := 364 | induction m as [|i l IHl x' e' r IHr]; simpl; intros; 365 | [|case X.compare_spec; intros]. 366 | 367 | Lemma add_avl_1 : forall s x e `{!Avl s}, 368 | Avl (add x e s) /\ 0 <= height (add x e s) - height s <= 1. 369 | Proof. 370 | induct s; inv_avl. 371 | - intuition; try constructor; simpl; autom; lia_max. 372 | - (* Eq *) 373 | simpl. intuition; lia_max. 374 | - (* Lt *) 375 | destruct (IHl x e); trivial. 376 | split. 377 | * apply bal_avl; trivial; lia_max. 378 | * lia_bal. 379 | - (* Gt *) 380 | destruct (IHr x e); trivial. 381 | split. 382 | * apply bal_avl; trivial; lia_max. 383 | * lia_bal. 384 | Qed. 385 | 386 | Instance add_avl s x e `{!Avl s} : Avl (add x e s). 387 | Proof. 388 | now destruct (@add_avl_1 s x e). 389 | Qed. 390 | 391 | (** join *) 392 | 393 | Ltac remtree t s := 394 | match t with Node ?h _ _ _ _ => 395 | assert (height t = h) by trivial; 396 | set (s := t) in *; clearbody s 397 | end. 398 | 399 | Lemma join_avl_1 l x e r : forall `{!Avl l, !Avl r}, 400 | Avl (join l x e r) /\ 401 | 0<= height (join l x e r) - max (height l) (height r) <= 1. 402 | Proof. 403 | join_tac l x e r; clearf. 404 | 405 | - simpl. destruct (@add_avl_1 r x e); auto. split; trivial. 406 | avl_nns; lia_max. 407 | 408 | - remtree (Node lh ll lx ld lr) l. 409 | split; autok. 410 | destruct (@add_avl_1 l x e); auto. 411 | simpl. avl_nns; lia_max. 412 | 413 | - remtree (Node rh rl rx rd rr) r. 414 | inv_avl. 415 | destruct (Hlr x e r); trivial; clear Hrl Hlr. 416 | set (j := join lr x e r) in *; clearbody j. 417 | simpl. 418 | assert (-(3) <= height ll - height j <= 3) by lia_max. 419 | split. 420 | * apply bal_avl; trivial. 421 | * lia_bal. 422 | 423 | - remtree (Node lh ll lx ld lr) l. 424 | inv_avl. 425 | destruct Hrl; trivial; clear Hlr. 426 | set (j := join l x e rl) in *; clearbody j. 427 | simpl. 428 | assert (-(3) <= height j - height rr <= 3) by lia_max. 429 | split. 430 | * apply bal_avl; trivial. 431 | * lia_bal. 432 | 433 | - clear Hrl Hlr. 434 | remtree (Node lh ll lx ld lr) l. 435 | remtree (Node rh rl rx rd rr) r. 436 | assert (-(2) <= height l - height r <= 2) by lia_max. 437 | split. 438 | * apply create_avl; trivial. 439 | * rewrite create_height; trivial; lia_max. 440 | Qed. 441 | 442 | Instance join_avl l x e r `{!Avl l, !Avl r} : Avl (join l x e r). 443 | Proof. 444 | now destruct (@join_avl_1 l x e r). 445 | Qed. 446 | 447 | (** remove_min *) 448 | 449 | Lemma remove_min_avl_1 : forall l x e r h `{!Avl (Node h l x e r)}, 450 | Avl (remove_min l x e r)#1 /\ 451 | 0 <= height (Node h l x e r) - height (remove_min l x e r)#1 <= 1. 452 | Proof. 453 | intros l x e r; functional induction (remove_min l x e r); 454 | subst; simpl in *; intros. 455 | - inv_avl; simpl in *; split; auto. avl_nns; lia_max. 456 | - mysubst. inv_avl'; simpl in *. 457 | edestruct IHp; clear IHp; [eauto|]. 458 | split. 459 | * apply bal_avl; trivial; lia_max. 460 | * lia_bal. 461 | Qed. 462 | 463 | Instance remove_min_avl l x e r h `{!Avl (Node h l x e r)} : 464 | Avl (remove_min l x e r)#1. 465 | Proof. 466 | now destruct (@remove_min_avl_1 l x e r h). 467 | Qed. 468 | 469 | (** append *) 470 | 471 | Lemma append_avl_1 : forall s1 s2 `{!Avl s1, !Avl s2}, 472 | -(2) <= height s1 - height s2 <= 2 -> 473 | Avl (append s1 s2) /\ 474 | 0<= height (append s1 s2) - max (height s1) (height s2) <=1. 475 | Proof. 476 | intros s1 s2; functional induction (append s1 s2); intros; 477 | try (factornode s1). 478 | - simpl; split; auto; avl_nns; lia_max. 479 | - simpl; split; auto; avl_nns; simpl in *; lia_max. 480 | - generalize (@remove_min_avl_1 l2 x2 d2 r2 _ _). 481 | mysubst. destruct 1; simpl in *. 482 | split. 483 | * apply bal_avl; trivial. simpl; lia_max. 484 | * lia_bal. 485 | Qed. 486 | 487 | Lemma append_avl s1 s2 `{!Avl s1, !Avl s2} : 488 | -(2) <= height s1 - height s2 <= 2 -> Avl (append s1 s2). 489 | Proof. 490 | intros; now destruct (@append_avl_1 s1 s2). 491 | Qed. 492 | 493 | 494 | (** remove *) 495 | 496 | Lemma remove_avl_1 : forall s x `{!Avl s}, 497 | Avl (remove x s) /\ 0 <= height s - height (remove x s) <= 1. 498 | Proof. 499 | induct s; inv_avl. 500 | - intuition; lia_max. 501 | - (* Eq *) 502 | generalize (@append_avl_1 l r). 503 | intuition lia_max. 504 | - (* Lt *) 505 | destruct (IHl x); trivial. 506 | split. 507 | * apply bal_avl; trivial; lia_max. 508 | * lia_bal. 509 | - (* Gt *) 510 | destruct (IHr x); trivial. 511 | split. 512 | * apply bal_avl; trivial; lia_max. 513 | * lia_bal. 514 | Qed. 515 | 516 | Instance remove_avl s x `{!Avl s} : Avl (remove x s). 517 | Proof. 518 | now destruct (@remove_avl_1 s x). 519 | Qed. 520 | 521 | (** concat *) 522 | 523 | Instance concat_avl s1 s2 `{!Avl s1, !Avl s2} : Avl (concat s1 s2). 524 | Proof. 525 | functional induction (concat s1 s2); auto. 526 | apply join_avl; auto. 527 | generalize (@remove_min_avl l2 x2 d2 r2 _ _). now mysubst. 528 | Qed. 529 | 530 | (** split *) 531 | 532 | Lemma split_avl : forall s x `{!Avl s}, 533 | Avl (t_left (split x s)) /\ Avl (t_right (split x s)). 534 | Proof. 535 | intros s x. functional induction (split x s); simpl; auto. 536 | - intros. inv_avl; auto. 537 | - mysubst; simpl in *; inversion_clear 1; intuition. 538 | - mysubst; simpl in *; inversion_clear 1; intuition. 539 | Qed. 540 | 541 | (** filter *) 542 | 543 | Instance filter_avl (f:key->elt->bool) m `{!Avl m} : Avl (filter f m). 544 | Proof. 545 | induction m; simpl; auto. inv_avl. 546 | destruct f; [apply join_avl | apply concat_avl ]; auto. 547 | Qed. 548 | 549 | Instance partition_avl1 (f:key->elt->bool) m `{!Avl m} : 550 | Avl (fst (partition f m)). 551 | Proof. 552 | induction m; simpl; auto. inv_avl. 553 | destruct partition, partition, f; simpl in *; 554 | [apply join_avl | apply concat_avl]; auto. 555 | Qed. 556 | 557 | Instance partition_avl2 (f:key->elt->bool) m `{!Avl m} : 558 | Avl (snd (partition f m)). 559 | Proof. 560 | induction m; simpl; auto. inv_avl. 561 | destruct partition, partition, f; simpl in *; 562 | [apply concat_avl | apply join_avl]; auto. 563 | Qed. 564 | 565 | End Elt. 566 | 567 | Lemma map_height {elt elt'}(f:elt->elt') m : height (map f m) = height m. 568 | Proof. 569 | induction m; simpl; auto. 570 | Qed. 571 | 572 | Instance map_avl {elt elt'}(f:elt->elt') m `(!Avl m) : Avl (map f m). 573 | Proof. 574 | induction m; simpl; inv_avl; intuition. 575 | constructor; intuition; rewrite ?map_height; auto. 576 | Qed. 577 | 578 | Lemma mapi_height {elt elt'}(f:key->elt->elt') m : 579 | height (mapi f m) = height m. 580 | Proof. 581 | induction m; simpl; auto. 582 | Qed. 583 | 584 | Instance mapi_avl {elt elt'}(f:key->elt->elt') m `(!Avl m) : Avl (mapi f m). 585 | Proof. 586 | induction m; simpl; inv_avl; intuition. 587 | constructor; intuition; rewrite ?mapi_height; auto. 588 | Qed. 589 | 590 | Instance mapo_avl {elt elt'}(f:key->elt->option elt') m `{!Avl m} : 591 | Avl (mapo f m). 592 | Proof. 593 | induction m; simpl; inv_avl; intuition. 594 | destruct f. 595 | - apply join_avl; auto. 596 | - apply concat_avl; auto. 597 | Qed. 598 | 599 | Section Gmerge. 600 | Variable elt elt' elt'' : Type. 601 | Variable f : key -> elt -> option elt' -> option elt''. 602 | Variable mapl : t elt -> t elt''. 603 | Variable mapr : t elt' -> t elt''. 604 | Hypothesis mapl_avl : forall m, Avl m -> Avl (mapl m). 605 | Hypothesis mapr_avl : forall m', Avl m' -> Avl (mapr m'). 606 | 607 | Instance gmerge_avl m m' `{!Avl m, !Avl m'} : 608 | Avl (gmerge f mapl mapr m m'). 609 | Proof. 610 | functional induction (gmerge f mapl mapr m m'); 611 | auto; factornode m2; inv_avl; 612 | apply join_avl || apply concat_avl; auto; 613 | apply IHt0 || apply IHt2; auto; cleansplit; apply split_avl; auto. 614 | Qed. 615 | End Gmerge. 616 | 617 | Instance merge_avl {elt elt' elt''} 618 | (f:key -> option elt -> option elt' -> option elt'') m m' 619 | `(!Avl m, !Avl m') : 620 | Avl (merge f m m'). 621 | Proof. 622 | apply gmerge_avl; auto using mapo_avl. 623 | Qed. 624 | 625 | End AvlProofs. 626 | 627 | (** We could hence define [Ok m] as [Bst m /\ Avl m] and re-validate 628 | the [Raw.S] signature. This would be more robust in case new ops 629 | are added in the signature. But that would be yet another wrapper, 630 | so we don't do it for the moment. *) 631 | -------------------------------------------------------------------------------- /MMaps/WeakList.v: -------------------------------------------------------------------------------- 1 | 2 | (** * Finite Modular Maps : Unordered Lists *) 3 | 4 | (** Author : Pierre Letouzey (Université de Paris - INRIA), 5 | adapted from earlier works in Coq Standard Library, see README.md. 6 | Licence : LGPL 2.1, see file LICENSE. *) 7 | 8 | (** This file proposes an implementation of the interface 9 | [Tries.MMaps.Interface.WS] using lists of pairs, unordered but without 10 | redundancy. Most operations are linear, with the notable exception 11 | of [merge] which is quadratic. *) 12 | 13 | From Coq Require Import EqualitiesFacts. 14 | From Tries.MMaps Require Interface Raw. 15 | Import Interface. 16 | 17 | Set Implicit Arguments. 18 | Unset Strict Implicit. 19 | 20 | Module MakeRaw (K:DecidableType) <: Raw.WS K. 21 | 22 | Module Import P := KeyDecidableType K. 23 | 24 | Definition key := K.t. 25 | Definition t (elt:Type) := list (K.t * elt). 26 | 27 | Definition eq_key {elt} := @P.eqk elt. 28 | Definition eq_key_elt {elt} := @P.eqke elt. 29 | Definition IsOk {elt} := NoDupA (@eqk elt). 30 | Class Ok {elt}(m:t elt) : Prop := ok : NoDupA eqk m. 31 | 32 | Ltac chok := 33 | match goal with 34 | | H : context [NoDupA (@eqk ?elt)] |- _ => 35 | change (NoDupA (@eqk elt)) with (@Ok elt) in H; chok 36 | | |- context [NoDupA (@eqk ?elt)] => 37 | change (NoDupA (@eqk elt)) with (@Ok elt); chok 38 | | _ => idtac 39 | end. 40 | 41 | Ltac autok := chok; auto with typeclass_instances. 42 | 43 | Ltac dec := match goal with 44 | | |- context [ K.eq_dec ?x ?x ] => 45 | let E := fresh "E" in destruct (K.eq_dec x x) as [E|E]; [ | now elim E] 46 | | H : K.eq ?x ?y |- context [ K.eq_dec ?x ?y ] => 47 | let E := fresh "E" in destruct (K.eq_dec x y) as [_|E]; [ | now elim E] 48 | | H : ~K.eq ?x ?y |- context [ K.eq_dec ?x ?y ] => 49 | let E := fresh "E" in destruct (K.eq_dec x y) as [E|_]; [ now elim H | ] 50 | | |- context [ K.eq_dec ?x ?y ] => 51 | let E := fresh "E" in destruct (K.eq_dec x y) as [E|E] 52 | end. 53 | 54 | Section Elt. 55 | 56 | Variable elt : Type. 57 | 58 | (** * [find] *) 59 | 60 | Fixpoint find (k:key) (s: t elt) : option elt := 61 | match s with 62 | | nil => None 63 | | (k',x)::s' => if K.eq_dec k k' then Some x else find k s' 64 | end. 65 | 66 | Lemma find_spec m x e {Hm:Ok m} : 67 | find x m = Some e <-> MapsTo x e m. 68 | Proof. 69 | unfold P.MapsTo. 70 | induction m as [ | (k,v) m IH]; simpl. 71 | - split; inversion 1. 72 | - rewrite InA_cons. 73 | change (eqke (x,e) (k,v)) with (K.eq x k /\ e = v). 74 | inversion_clear Hm. dec. 75 | + setoid_replace (Some v = Some e) with (v = e) by (split; congruence). 76 | intuition. elim H. apply InA_eqk with (x,e); auto. 77 | + rewrite IH; intuition. 78 | Qed. 79 | 80 | (** * [mem] *) 81 | 82 | Fixpoint mem (k : key) (s : t elt) : bool := 83 | match s with 84 | | nil => false 85 | | (k',_) :: l => if K.eq_dec k k' then true else mem k l 86 | end. 87 | 88 | Lemma mem_spec m x {Hm:Ok m} : mem x m = true <-> In x m. 89 | Proof. 90 | induction m as [ | (k,e) m IH]; simpl. 91 | - split. discriminate. inversion_clear 1. inversion H0. 92 | - inversion_clear Hm. rewrite P.In_cons; simpl. 93 | rewrite <- IH by trivial. 94 | dec; intuition. 95 | Qed. 96 | 97 | Fixpoint isok (m: t elt) : bool := 98 | match m with 99 | | nil => true 100 | | (k,_)::m' => negb (mem k m') && isok m' 101 | end. 102 | 103 | Lemma isok_spec (m: t elt) : isok m = true <-> Ok m. 104 | Proof. 105 | induction m as [|(x,e) m IH]; simpl. 106 | - split; constructor. 107 | - rewrite andb_true_iff, IH. split. 108 | + intros (H,O). constructor; auto. 109 | rewrite <- In_alt', <- mem_spec; auto. now destruct mem. 110 | + inversion 1; subst; split; auto. 111 | rewrite <- In_alt', <- mem_spec in H2; auto. now destruct mem. 112 | Qed. 113 | 114 | Lemma isok_Ok (m:t elt) : isok m = true -> Ok m. 115 | Proof. apply isok_spec. Qed. 116 | 117 | (** * [empty] *) 118 | 119 | Definition empty : t elt := nil. 120 | 121 | Lemma empty_spec x : find x empty = None. 122 | Proof. 123 | reflexivity. 124 | Qed. 125 | 126 | Global Instance empty_ok : Ok empty. 127 | Proof. 128 | unfold empty; red; auto. 129 | Qed. 130 | 131 | (** * [is_empty] *) 132 | 133 | Definition is_empty (l : t elt) : bool := if l then true else false. 134 | 135 | Lemma is_empty_spec m : is_empty m = true <-> forall x, find x m = None. 136 | Proof. 137 | destruct m as [|(x,e) m]; simpl; intuition; try discriminate. 138 | specialize (H x). 139 | revert H. now dec. 140 | Qed. 141 | 142 | (* Not part of the exported specifications, used later for [merge]. *) 143 | 144 | Lemma find_eq : forall m (Hm:Ok m) x x', 145 | K.eq x x' -> find x m = find x' m. 146 | Proof. 147 | induction m; simpl; auto; destruct a; intros. 148 | inversion_clear Hm. 149 | rewrite (IHm H1 x x'); auto. 150 | dec; dec; trivial. 151 | elim E0. now transitivity x. 152 | elim E. now transitivity x'. 153 | Qed. 154 | 155 | (** * [add] *) 156 | 157 | Fixpoint add (k : key) (x : elt) (s : t elt) : t elt := 158 | match s with 159 | | nil => (k,x) :: nil 160 | | (k',y) :: l => if K.eq_dec k k' then (k,x)::l else (k',y)::add k x l 161 | end. 162 | 163 | Lemma add_spec1' m x e : find x (add x e m) = Some e. 164 | Proof. 165 | induction m as [ | (k,e') m IH]; simpl. 166 | - now dec. 167 | - dec; simpl; now dec. 168 | Qed. 169 | 170 | Lemma add_spec2' m x y e : ~K.eq x y -> find y (add x e m) = find y m. 171 | Proof. 172 | intros N. 173 | assert (N' : ~K.eq y x) by now contradict N. 174 | induction m as [ | (k,e') m IH]; simpl. 175 | - dec; trivial. 176 | - repeat (dec; simpl); trivial. elim N. now transitivity k. 177 | Qed. 178 | 179 | Lemma add_spec1 m x e `{!Ok m} : find x (add x e m) = Some e. 180 | Proof. apply add_spec1'. Qed. 181 | Lemma add_spec2 m x y e `{!Ok m} : ~K.eq x y -> find y (add x e m) = find y m. 182 | Proof. apply add_spec2'. Qed. 183 | 184 | Lemma add_InA : forall m x y e e', 185 | ~ K.eq x y -> InA eqk (y,e) (add x e' m) -> InA eqk (y,e) m. 186 | Proof. 187 | induction m as [ | (k,e') m IH]; simpl; intros. 188 | - inversion_clear H0. elim H. symmetry; apply H1. inversion_clear H1. 189 | - revert H0; dec; rewrite !InA_cons. 190 | + rewrite E. intuition. 191 | + intuition. right; eapply IH; eauto. 192 | Qed. 193 | 194 | Global Instance add_ok m x e (Hm:Ok m) : Ok (add x e m). 195 | Proof. 196 | induction m as [ | (k,e') m IH]; simpl. 197 | - constructor; auto. now inversion 1. 198 | - inversion_clear Hm. dec; constructor; autok. 199 | + contradict H. apply InA_eqk with (x,e); auto. 200 | + contradict H; apply add_InA with x e; auto. 201 | Qed. 202 | 203 | (** * [remove] *) 204 | 205 | Fixpoint remove (k : key) (s : t elt) : t elt := 206 | match s with 207 | | nil => nil 208 | | (k',x) :: l => if K.eq_dec k k' then l else (k',x) :: remove k l 209 | end. 210 | 211 | Lemma remove_spec1 m x {Hm: Ok m} : find x (remove x m) = None. 212 | Proof. 213 | induction m as [ | (k,e') m IH]; simpl; trivial. 214 | inversion_clear Hm. 215 | repeat (dec; simpl); auto. 216 | destruct (find x m) eqn:F; trivial. 217 | apply find_spec in F; trivial. 218 | elim H. apply InA_eqk with (x,e); auto. 219 | Qed. 220 | 221 | Lemma remove_spec2 m x y {Hm: Ok m} : ~K.eq x y -> 222 | find y (remove x m) = find y m. 223 | Proof. 224 | induction m as [ | (k,e') m IH]; simpl; trivial; intros E. 225 | inversion_clear Hm. 226 | repeat (dec; simpl); auto. 227 | elim E. now transitivity k. 228 | Qed. 229 | 230 | Lemma remove_InA : forall m (Hm:Ok m) x y e, 231 | InA eqk (y,e) (remove x m) -> InA eqk (y,e) m. 232 | Proof. 233 | induction m as [ | (k,e') m IH]; simpl; trivial; intros. 234 | inversion_clear Hm. 235 | revert H; dec; rewrite !InA_cons; intuition. 236 | right; eapply H; eauto. 237 | Qed. 238 | 239 | Global Instance remove_ok m x (Hm:Ok m) : Ok (remove x m). 240 | Proof. 241 | induction m. 242 | simpl; intuition. 243 | intros. 244 | inversion_clear Hm. 245 | destruct a as (x',e'). 246 | simpl; case (K.eq_dec x x'); auto. 247 | constructor; autok. 248 | contradict H; apply remove_InA with x; auto. 249 | Qed. 250 | 251 | (** * [bindings] *) 252 | 253 | Definition bindings (m : t elt) := m. 254 | 255 | Lemma bindings_spec1 m x e : InA eqke (x,e) (bindings m) <-> MapsTo x e m. 256 | Proof. 257 | reflexivity. 258 | Qed. 259 | 260 | Lemma bindings_spec2w m (Hm:Ok m) : Ok (bindings m). 261 | Proof. 262 | trivial. 263 | Qed. 264 | 265 | (** * [fold] *) 266 | 267 | Fixpoint fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc : A) : A := 268 | match m with 269 | | nil => acc 270 | | (k,e)::m' => fold f m' (f k e acc) 271 | end. 272 | 273 | Lemma fold_spec : forall m (A:Type)(i:A)(f:key->elt->A->A), 274 | fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. 275 | Proof. 276 | induction m as [ | (k,e) m IH]; simpl; auto. 277 | Qed. 278 | 279 | (** * [singleton] *) 280 | 281 | Definition singleton k (e:elt) : t elt := (k,e)::nil. 282 | 283 | Lemma singleton_spec x e : bindings (singleton x e) = (x,e)::nil. 284 | Proof. reflexivity. Qed. 285 | 286 | Global Instance singleton_ok x e : Ok (singleton x e). 287 | Proof. 288 | constructor; auto. inversion 1. 289 | Qed. 290 | 291 | (** * [equal] *) 292 | 293 | Definition check (cmp : elt -> elt -> bool)(k:key)(e:elt)(m': t elt) := 294 | match find k m' with 295 | | None => false 296 | | Some e' => cmp e e' 297 | end. 298 | 299 | Definition submap (cmp : elt -> elt -> bool)(m m' : t elt) : bool := 300 | fold (fun k e b => andb (check cmp k e m') b) m true. 301 | 302 | Definition equal (cmp : elt -> elt -> bool)(m m' : t elt) : bool := 303 | andb (submap cmp m m') (submap (fun e' e => cmp e e') m' m). 304 | 305 | Definition Submap (cmp:elt->elt->bool) m m' := 306 | (forall k, In k m -> In k m') /\ 307 | (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). 308 | 309 | Definition Equal m m' := forall y, find y m = find y m'. 310 | Definition Eqdom m m' := forall y, @In elt y m <-> @In elt y m'. 311 | Definition Equiv (R:elt->elt->Prop) m m' := 312 | Eqdom m m' /\ 313 | (forall k e e', MapsTo k e m -> MapsTo k e' m' -> R e e'). 314 | Definition Equivb (cmp:elt->elt->bool) := Equiv (Cmp cmp). 315 | 316 | Lemma submap_1 : forall m (Hm:Ok m) m' (Hm': Ok m') cmp, 317 | Submap cmp m m' -> submap cmp m m' = true. 318 | Proof. 319 | unfold Submap, submap. 320 | induction m. 321 | simpl; auto. 322 | destruct a; simpl; intros. 323 | destruct H. 324 | inversion_clear Hm. 325 | assert (H3 : In t0 m'). 326 | { apply H; exists e; auto with *. } 327 | destruct H3 as (e', H3). 328 | assert (H4 : find t0 m' = Some e') by now apply find_spec. 329 | unfold check at 2. rewrite H4. 330 | rewrite (H0 t0); simpl; auto with *. 331 | eapply IHm; auto. 332 | split; intuition. 333 | apply H. 334 | destruct H6 as (e'',H6); exists e''; auto. 335 | apply H0 with k; auto. 336 | Qed. 337 | 338 | Lemma submap_2 : forall m (Hm:Ok m) m' (Hm': Ok m') cmp, 339 | submap cmp m m' = true -> Submap cmp m m'. 340 | Proof. 341 | unfold Submap, submap. 342 | induction m. 343 | simpl; auto. 344 | intuition. 345 | destruct H0; inversion H0. 346 | inversion H0. 347 | 348 | destruct a; simpl; intros. 349 | inversion_clear Hm. 350 | rewrite andb_b_true in H. 351 | assert (check cmp t0 e m' = true). 352 | clear H1 H0 Hm' IHm. 353 | set (b:=check cmp t0 e m') in *. 354 | generalize H; clear H; generalize b; clear b. 355 | induction m; simpl; auto; intros. 356 | destruct a; simpl in *. 357 | destruct (andb_prop _ _ (IHm _ H)); auto. 358 | rewrite H2 in H. 359 | destruct (IHm H1 m' Hm' cmp H); auto. 360 | unfold check in H2. 361 | case_eq (find t0 m'); [intros e' H5 | intros H5]; 362 | rewrite H5 in H2; try discriminate. 363 | split; intros. 364 | destruct H6 as (e0,H6); inversion_clear H6. 365 | compute in H7; destruct H7; subst. 366 | exists e'. 367 | apply P.MapsTo_eq with t0; auto with *. 368 | apply find_spec; auto. 369 | apply H3. 370 | exists e0; auto. 371 | inversion_clear H6. 372 | compute in H8; destruct H8; subst. 373 | assert (H8 : MapsTo t0 e'0 m'). { eapply P.MapsTo_eq; eauto. } 374 | apply find_spec in H8; trivial. congruence. 375 | apply H4 with k; auto. 376 | Qed. 377 | 378 | (** Specification of [equal] *) 379 | 380 | Lemma equal_spec cmp m m' {Hm:Ok m}{Hm': Ok m'} : 381 | equal cmp m m' = true <-> Equivb cmp m m'. 382 | Proof. 383 | unfold equal. 384 | split. 385 | - intros. 386 | destruct (andb_prop _ _ H); clear H. 387 | generalize (submap_2 Hm Hm' H0). 388 | generalize (submap_2 Hm' Hm H1). 389 | firstorder. 390 | - intuition. 391 | apply andb_true_intro; split; apply submap_1; unfold Submap; firstorder. 392 | Qed. 393 | End Elt. 394 | Section Elt2. 395 | Variable elt elt' : Type. 396 | 397 | (** * [map] and [mapi] *) 398 | 399 | Definition map (f:elt -> elt') (m:t elt) : t elt' := 400 | List.map (fun '(k,e) => (k,f e)) m. 401 | 402 | Definition mapi (f: key -> elt -> elt') (m:t elt) : t elt' := 403 | List.map (fun '(k,e) => (k,f k e)) m. 404 | 405 | (** Specification of [map] *) 406 | 407 | Lemma map_spec (f:elt->elt')(m:t elt) : 408 | bindings (map f m) = List.map (fun '(k,e) => (k,f e)) (bindings m). 409 | Proof. 410 | reflexivity. 411 | Qed. 412 | 413 | Lemma map_InA (f:elt->elt')(m:t elt) x e : 414 | InA eqk (x,f e) (map f m) <-> InA eqk (x,e) m. 415 | Proof. 416 | induction m as [|(k,v) m IH]; simpl; rewrite ?InA_nil, ?InA_cons; 417 | intuition. 418 | Qed. 419 | 420 | Global Instance map_ok (f:elt->elt') m (Hm : Ok m) : Ok (map f m). 421 | Proof. 422 | induction m as [|(x,e) m IH]; simpl. red; constructor. 423 | inversion_clear Hm. constructor; autok. now rewrite map_InA. 424 | Qed. 425 | 426 | (** Specification of [mapi] *) 427 | 428 | Lemma mapi_spec (f:key->elt->elt')(m:t elt) : 429 | bindings (mapi f m) = List.map (fun '(k,e) => (k,f k e)) (bindings m). 430 | Proof. 431 | reflexivity. 432 | Qed. 433 | 434 | Global Instance mapi_ok (f: key->elt->elt') m (Hm:Ok m) : Ok (mapi f m). 435 | Proof. 436 | induction m as [|(x,e) m IH]; simpl. red; constructor. 437 | inversion_clear Hm; auto. 438 | constructor; autok. 439 | contradict H. clear IH H0. 440 | induction m as [|(y,v) m IH]; simpl in *; inversion H; auto. 441 | Qed. 442 | 443 | End Elt2. 444 | 445 | Lemma mapfst_InA {elt}(m:t elt) x : 446 | InA K.eq x (List.map fst m) <-> In x m. 447 | Proof. 448 | induction m as [| (k,e) m IH]; simpl; auto. 449 | - split; inversion 1. inversion H0. 450 | - rewrite InA_cons, In_cons. simpl. now rewrite IH. 451 | Qed. 452 | 453 | Lemma mapfst_ok {elt}(m:t elt) : 454 | NoDupA K.eq (List.map fst m) <-> NoDupA eqk m. 455 | Proof. 456 | induction m as [| (k,e) m IH]; simpl. 457 | - split; constructor. 458 | - split; inversion_clear 1; constructor; try apply IH; trivial. 459 | + contradict H0. rewrite mapfst_InA. eapply In_alt'; eauto. 460 | + rewrite mapfst_InA. contradict H0. now apply In_alt'. 461 | Qed. 462 | 463 | Lemma list_filter_ok f (m:list key) : 464 | NoDupA K.eq m -> NoDupA K.eq (List.filter f m). 465 | Proof. 466 | induction 1; simpl. 467 | - constructor. 468 | - destruct (f x); trivial. constructor; trivial. 469 | contradict H. rewrite InA_alt in *. destruct H as (y,(Hy,H)). 470 | exists y; split; trivial. now rewrite filter_In in H. 471 | Qed. 472 | 473 | Lemma NoDupA_unique_repr (l:list key) x y : 474 | NoDupA K.eq l -> K.eq x y -> List.In x l -> List.In y l -> x = y. 475 | Proof. 476 | intros H E Hx Hy. 477 | induction H; simpl in *. 478 | - inversion Hx. 479 | - intuition; subst; trivial. 480 | elim H. apply InA_alt. now exists y. 481 | elim H. apply InA_alt. now exists x. 482 | Qed. 483 | 484 | Section Elt3. 485 | 486 | Variable elt elt' elt'' : Type. 487 | 488 | Definition restrict (m:t elt)(k:key) := 489 | match find k m with 490 | | None => true 491 | | Some _ => false 492 | end. 493 | 494 | Definition domains (m:t elt)(m':t elt') := 495 | List.map fst m ++ List.filter (restrict m) (List.map fst m'). 496 | 497 | Lemma domains_InA m m' (Hm : Ok m) x : 498 | InA K.eq x (domains m m') <-> In x m \/ In x m'. 499 | Proof. 500 | unfold domains. 501 | assert (Proper (K.eq==>eq) (restrict m)). 502 | { intros k k' Hk. unfold restrict. now rewrite (find_eq Hm Hk). } 503 | rewrite InA_app_iff, filter_InA, !mapfst_InA; intuition. 504 | unfold restrict. 505 | destruct (find x m) eqn:F. 506 | - left. apply find_spec in F; trivial. now exists e. 507 | - now right. 508 | Qed. 509 | 510 | Lemma domains_ok m m' : NoDupA eqk m -> NoDupA eqk m' -> 511 | NoDupA K.eq (domains m m'). 512 | Proof. 513 | intros Hm Hm'. unfold domains. 514 | apply NoDupA_app; auto with *. 515 | - now apply mapfst_ok. 516 | - now apply list_filter_ok, mapfst_ok. 517 | - intros x. 518 | rewrite mapfst_InA. intros (e,H). 519 | apply find_spec in H; trivial. 520 | rewrite InA_alt. intros (y,(Hy,H')). 521 | rewrite (find_eq Hm Hy) in H. 522 | rewrite filter_In in H'. destruct H' as (_,H'). 523 | unfold restrict in H'. now rewrite H in H'. 524 | Qed. 525 | 526 | Fixpoint fold_keys (f:key->option elt'') l := 527 | match l with 528 | | nil => nil 529 | | k::l => 530 | match f k with 531 | | Some e => (k,e)::fold_keys f l 532 | | None => fold_keys f l 533 | end 534 | end. 535 | 536 | Lemma fold_keys_In f l x e : 537 | List.In (x,e) (fold_keys f l) <-> List.In x l /\ f x = Some e. 538 | Proof. 539 | induction l as [|k l IH]; simpl. 540 | - intuition. 541 | - destruct (f k) eqn:F; simpl; rewrite IH; clear IH; intuition; 542 | try left; congruence. 543 | Qed. 544 | 545 | Lemma fold_keys_ok f l : 546 | NoDupA K.eq l -> Ok (fold_keys f l). 547 | Proof. 548 | induction 1; simpl. 549 | - constructor. 550 | - destruct (f x); trivial. 551 | constructor; trivial. contradict H. 552 | apply InA_alt in H. destruct H as ((k,e'),(E,H)). 553 | rewrite fold_keys_In in H. 554 | apply InA_alt. exists k. now split. 555 | Qed. 556 | 557 | Variable f : key -> option elt -> option elt' -> option elt''. 558 | 559 | Definition merge m m' : t elt'' := 560 | fold_keys (fun k => f k (find k m) (find k m')) (domains m m'). 561 | 562 | Global Instance merge_ok m m' (Hm:Ok m)(Hm':Ok m') : Ok (merge m m'). 563 | Proof. 564 | now apply fold_keys_ok, domains_ok. 565 | Qed. 566 | 567 | Lemma merge_spec1 m m' x {Hm:Ok m}{Hm':Ok m'} : 568 | In x m \/ In x m' -> 569 | exists y:key, K.eq y x /\ 570 | find x (merge m m') = f y (find x m) (find x m'). 571 | Proof. 572 | assert (Hmm' : Ok (merge m m')) by now apply merge_ok. 573 | rewrite <- domains_InA; trivial. 574 | rewrite InA_alt. intros (y,(Hy,H)). 575 | exists y; split; [easy|]. 576 | rewrite (find_eq Hm Hy), (find_eq Hm' Hy). 577 | destruct (f y (find y m) (find y m')) eqn:F. 578 | - apply find_spec; trivial. 579 | red. apply InA_alt. exists (y,e). split. now split. 580 | unfold merge. apply fold_keys_In. now split. 581 | - destruct (find x (merge m m')) eqn:F'; trivial. 582 | rewrite <- F; clear F. symmetry. 583 | apply find_spec in F'; trivial. 584 | red in F'. rewrite InA_alt in F'. 585 | destruct F' as ((y',e'),(E,F')). 586 | unfold merge in F'; rewrite fold_keys_In in F'. 587 | destruct F' as (H',F'). 588 | compute in E; destruct E as (Hy',<-). 589 | replace y with y'; trivial. 590 | apply (@NoDupA_unique_repr (domains m m')); auto. 591 | now apply domains_ok. 592 | now transitivity x. 593 | Qed. 594 | 595 | Lemma merge_spec2 m m' x {Hm:Ok m}{Hm':Ok m'} : 596 | In x (merge m m') -> In x m \/ In x m'. 597 | Proof. 598 | rewrite <- domains_InA; trivial. 599 | intros (e,H). red in H. rewrite InA_alt in H. destruct H as ((k,e'),(E,H)). 600 | unfold merge in H; rewrite fold_keys_In in H. destruct H as (H,_). 601 | apply InA_alt. exists k. split; trivial. now destruct E. 602 | Qed. 603 | 604 | End Elt3. 605 | 606 | Definition cardinal {elt} (m:t elt) := length m. 607 | Lemma cardinal_spec {elt} (m:t elt) : cardinal m = length (bindings m). 608 | Proof. reflexivity. Qed. 609 | 610 | Definition MapsTo {elt} := @P.MapsTo elt. 611 | Definition In {elt} := @P.In elt. 612 | 613 | Global Instance MapsTo_compat {elt} : 614 | Proper (K.eq==>Logic.eq==>Logic.eq==>iff) (@MapsTo elt). 615 | Proof. 616 | intros x x' Hx e e' <- m m' <-. unfold MapsTo. now rewrite Hx. 617 | Qed. 618 | 619 | Definition filter {elt} (f:key->elt->bool) := 620 | List.filter (fun '(k,e) => f k e). 621 | 622 | Definition partition {elt} (f:key->elt->bool) := 623 | List.partition (fun '(k,e) => f k e). 624 | 625 | Definition for_all {elt} (f:key->elt->bool) := 626 | List.forallb (fun '(k,e) => f k e). 627 | 628 | Definition exists_ {elt} (f:key->elt->bool) := 629 | List.existsb (fun '(k,e) => f k e). 630 | 631 | Lemma filter_spec {elt} (f:key->elt->bool) m `{!Ok m} : 632 | bindings (filter f m) = List.filter (fun '(k,e) => f k e) (bindings m). 633 | Proof. reflexivity. Qed. 634 | 635 | Global Instance filter_ok {elt} f (m:t elt) : Ok m -> Ok (filter f m). 636 | Proof. 637 | induction 1; simpl. 638 | - constructor. 639 | - destruct x as (k,e). 640 | destruct (f k e); trivial. constructor; trivial. 641 | contradict H. rewrite InA_alt in *. destruct H as (y,(Hy,H)). 642 | exists y; split; trivial. unfold filter in *. 643 | now rewrite filter_In in H. 644 | Qed. 645 | 646 | Lemma partition_spec {elt} (f:key->elt->bool) m `{!Ok m} : 647 | prodmap (@bindings _) (partition f m) = 648 | List.partition (fun '(k,e) => f k e) (bindings m). 649 | Proof. unfold bindings, partition. now destruct List.partition. Qed. 650 | 651 | Lemma partition_fst {elt} f (m:t elt) : fst (partition f m) = filter f m. 652 | Proof. 653 | induction m; simpl; auto. 654 | rewrite <- IHm. now destruct (partition f m), a, f. 655 | Qed. 656 | 657 | Lemma partition_snd {elt} f (m:t elt) : 658 | snd (partition f m) = filter (fun k e => negb (f k e)) m. 659 | Proof. 660 | induction m; simpl; auto. 661 | rewrite <- IHm. now destruct (partition f m), a, f. 662 | Qed. 663 | 664 | Global Instance partition_ok1 {elt} f (m:t elt) : Ok m -> Ok (fst (partition f m)). 665 | Proof. 666 | rewrite partition_fst; eauto with *. 667 | Qed. 668 | 669 | Global Instance partition_ok2 {elt} f (m:t elt) : Ok m -> Ok (snd (partition f m)). 670 | Proof. 671 | rewrite partition_snd; eauto with *. 672 | Qed. 673 | 674 | Lemma for_all_spec {elt}(f:key->elt->bool) m : 675 | for_all f m = List.forallb (fun '(k,e) => f k e) (bindings m). 676 | Proof. reflexivity. Qed. 677 | 678 | Lemma exists_spec {elt}(f:key->elt->bool) m : 679 | exists_ f m = List.existsb (fun '(k,e) => f k e) (bindings m). 680 | Proof. reflexivity. Qed. 681 | 682 | End MakeRaw. 683 | 684 | Module Make (K:DecidableType) <: Interface.WS K. 685 | Module Raw := MakeRaw K. 686 | Include Raw.WPack K Raw. 687 | End Make. 688 | --------------------------------------------------------------------------------