├── .github └── workflows │ └── build.yml ├── .gitignore ├── CHANGES.md ├── Dockerfile ├── LICENSE.txt ├── README.md ├── TODO.md ├── dune-project ├── kmt.opam └── src ├── addition.ml ├── boolean.ml ├── common.ml ├── decide.ml ├── driver.ml ├── dune ├── hashcons.ml ├── hashcons.mli ├── incnat.ml ├── input.ml ├── input.mli ├── kat.ml ├── kmt.ml ├── kmt_eval.ml ├── lexer.mll ├── network.ml ├── parser.mly ├── product.ml ├── range.ml ├── range.mli ├── syntax.ml ├── test_equivalence.ml ├── test_word.ml └── word.ml /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: Main workflow 2 | 3 | on: 4 | - pull_request 5 | - push 6 | 7 | jobs: 8 | build: 9 | strategy: 10 | fail-fast: false 11 | matrix: 12 | os: 13 | - macos-10.15 14 | - macos-latest 15 | - ubuntu-latest 16 | ocaml-compiler: 17 | - 4.13.x 18 | 19 | runs-on: ${{ matrix.os }} 20 | 21 | steps: 22 | - name: Checkout code 23 | uses: actions/checkout@v2 24 | 25 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 26 | uses: avsm/setup-ocaml@v2 27 | with: 28 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 29 | 30 | - name: System dependencies 31 | run: | 32 | if [ "$RUNNER_OS" = "Linux" ]; then 33 | sudo apt-get install -y libgmp-dev python3 34 | elif [ "$RUNNER_OS" = "macOS" ]; then 35 | brew install gmp python3 36 | sudo mkdir -p /opt/local/lib 37 | else 38 | echo Unsupported OS: $RUNNER_OS 39 | exit 1 40 | fi 41 | 42 | - name: Install via OPAM 43 | run: | 44 | opam install -t . 45 | eval $(opam env) 46 | 47 | - name: KMT evaluation 48 | run: opam exec -- kmt_eval 49 | 50 | docker: 51 | runs-on: ubuntu-latest 52 | 53 | steps: 54 | - name: Checkout code 55 | uses: actions/checkout@v2 56 | 57 | - name: Build Docker container 58 | run: docker build -t kmt . 59 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.native 2 | _build 3 | *~ 4 | .merlin 5 | *.exe 6 | .DS_Store 7 | \#* 8 | .\#* 9 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | # 0.1 - 2022-06-23 2 | 3 | Initial release. 4 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam 2 | 3 | RUN sudo apt-get install -y libgmp-dev python3 4 | 5 | COPY --chown=opam:opam . kmt 6 | 7 | WORKDIR /home/opam/kmt 8 | 9 | RUN mkdir -p /home/opam/.config/dune && printf "(lang dune 3.0)\n(display short)\n" >/home/opam/.config/dune/config 10 | 11 | RUN opam install -t . 12 | 13 | RUN opam exec -- kmt_eval 14 | 15 | RUN echo 'eval $(opam env)' >>~/.bashrc 16 | 17 | ENTRYPOINT [ "opam", "exec", "--" ] 18 | CMD [ "bash" ] 19 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2022 Michael Greenberg and Ryan Beckett 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Main workflow](https://github.com/mgree/kmt/actions/workflows/build.yml/badge.svg)](https://github.com/mgree/kmt/actions/workflows/build.yml) 2 | [![DOI](https://zenodo.org/badge/149648258.svg)](https://zenodo.org/badge/latestdoi/149648258) 3 | 4 | This repository implements [Kleene algebra modulo 5 | theories](https://arxiv.org/abs/1707.02894) (KMT), a framework for 6 | deriving _concrete_ Kleene algebras with tests (KATs), an algebraic 7 | framework for While-like programs with decidable program equivalence. 8 | 9 | More plainly: KMT is a framework for building simple programming 10 | languages with structured control (if, while, etc.) where we can 11 | algorithmically decide whether or not two programs are equivalent. You 12 | can use equivalence to verify programs. If `a` is a nice property to 13 | have after running your program, then if `p;a == p`, you know that `p` 14 | satisfies `a`. Kleene algebra with tests subsumes Hoare logic: if 15 | `a;p;~b == 0` then all runs starting from `a` either diverge or end 16 | with `b`, i.e., that equation corresponds to the partial correctness 17 | specification `{a} p {b}`. While prior work on KAT often focuses on 18 | _abstract_ properties, we write programs over theories that assign 19 | _concrete_ meanings to primitive tests and actions. 20 | 21 | In addition to providing an OCaml library for defining KMTs over your 22 | own theories, we offer a command-line tool for testing equivalence in 23 | a variety of pre-defined theories. 24 | 25 | # Getting Started Guide 26 | 27 | ## How do I build it? 28 | 29 | KMT is [available on OPAM](https://opam.ocaml.org/packages/kmt/); if you have OCaml and [OPAM](https://opam.ocaml.org/) installed, œyou should be able to simply run: 30 | 31 | ```ShellSession 32 | $ opam install kmt 33 | ``` 34 | 35 | But you can also build a Docker container from the root of the repo: 36 | 37 | ```ShellSession 38 | $ docker build -t kmt . # build KMT, run tests and evaluation 39 | ``` 40 | 41 | If your `docker build` command exits with status 137, that indicates 42 | that the build ran out of memory (typically when building Z3). We find 43 | that 12GB of RAM is sufficient, but more may be necessary on your 44 | machine. You might have to reconfigure Docker to have sufficient memory. 45 | 46 | Building the image will automatically run unit tests as well as the 47 | PLDI 2022 evaluation. When running the image, you can use the `kmt` 48 | executable to test equivalence of various terms directly: 49 | 50 | ```ShellSession 51 | $ docker run -it kmt # enter a shell 52 | opam@b3043b7dca44:~/kmt$ kmt --boolean 'x=T' 'x=T + x=F;set(x,F);x=T' 53 | [x=T parsed as x=T] 54 | nf time: 0.000004s 55 | lunf time: 0.000022s 56 | [x=T + x=F;set(x,F);x=T parsed as x=T + x=F;set(x,F)[1];x=T] 57 | nf time: 0.000008s 58 | lunf time: 0.000006s 59 | [1 equivalence class] 60 | 1: { x=T + x=F;set(x,F);x=T, x=T } 61 | ``` 62 | 63 | The message `1 equivalence class` indicates that all terms given as 64 | command-line arguments form a single equivalence class, i.e., the two 65 | terms are equivalent. Each equivalence class is printed after: 66 | 67 | ```ShellSession 68 | opam@b3043b7dca44:~/kmt$ kmt --boolean 'x=T' 'x=T + x=F;set(x,T)' 69 | [x=T parsed as x=T] 70 | nf time: 0.000003s 71 | lunf time: 0.000016s 72 | [x=T + x=F;set(x,T) parsed as x=T + x=F;set(x,T)[1]] 73 | nf time: 0.000007s 74 | lunf time: 0.000010s 75 | [2 equivalence classes] 76 | 1: { x=T + x=F;set(x,T) } 77 | 2: { x=T } 78 | ``` 79 | 80 | Note that `b3043b7dca44` will be replaced by some new hash each time 81 | you run `docker run -it kmt`. 82 | 83 | Running `run_eval` inside the Docker container will reproduce the 84 | evaluation from our paper. You can run the regression tests by running 85 | `test_word` (for regular expression word equivalence, part of our 86 | decision procedure) and `test_equivalence` (for KMT term 87 | equivalence). All of these steps are performed automatically during 88 | `docker build`. 89 | 90 | The source code for all of these is in the `src` directory; see 91 | `src/dune` for the build script. 92 | 93 | # How do I use the `kmt` executable? 94 | 95 | The default way of using the `kmt` executable is to give it a theory (here `--boolean`) and 2 or more KMT programs in that theory. It will give you the equivalence classes of those terms. The `-v` flag is useful when many terms are given: 96 | 97 | ```ShellSession 98 | opam@3ce9eaca9fb1:~/kmt$ kmt -v --boolean 'x=T' 'x=F' 'x=T + x=F' 'x=T + x=F;x=T' 99 | [x=T parsed as x=T] 100 | kmt: [INFO] nf = {(x=T,true)} 101 | nf time: 0.000004s 102 | kmt: [INFO] lunf = {(x=T,true), (x=F,false)} 103 | lunf time: 0.000015s 104 | [x=F parsed as x=F] 105 | kmt: [INFO] nf = {(x=F,true)} 106 | nf time: 0.000003s 107 | kmt: [INFO] lunf = {(x=T,false), (x=F,true)} 108 | lunf time: 0.000008s 109 | [x=T + x=F parsed as true] 110 | kmt: [INFO] nf = {(true,true)} 111 | nf time: 0.000003s 112 | kmt: [INFO] lunf = {(true,true)} 113 | lunf time: 0.000014s 114 | [x=T + x=F;x=T parsed as x=T] 115 | kmt: [INFO] nf = {(x=T,true)} 116 | nf time: 0.000003s 117 | kmt: [INFO] lunf = {(x=T,true), (x=F,false)} 118 | lunf time: 0.000006s 119 | [3 equivalence classes] 120 | kmt: [INFO] 1: {(x=T,true), (x=F,false)}; {(x=T,true), (x=F,false)} 121 | kmt: [INFO] 2: {(true,true)} 122 | kmt: [INFO] 3: {(x=T,false), (x=F,true)} 123 | ``` 124 | 125 | The last three lines identify the three equivalence classes in terms 126 | of their normal forms. 127 | 128 | If you don't specify a theory, the default will be the theory of 129 | booleans. 130 | 131 | If you give just one term, `kmt` will normalize it for you. 132 | 133 | Run `kmt --help` for command-line help in a manpage-like format. 134 | 135 | ## What is the syntax? 136 | 137 | A Kleene algebra with tests breaks syntax into two parts: tests (or prediates) and actions. Actions are in some sense the 'top level', as every test is an action. 138 | 139 | We use the following syntax, where `a` and `b` are tests and `p` and 140 | `q` are actions. The following is the core KAT notation; individual 141 | theories introduce their own notations. 142 | 143 | | Tests | Interpretation | 144 | | :-----: | :--------------- | 145 | | `false` | always fails | 146 | | `true` | always succeeds | 147 | | `not a` | negation | 148 | | `a + b` | or, disjunction | 149 | | `a ; b` | and, conjunction | 150 | 151 | | Actions | Interpretation | 152 | | :-----: | :--------------- | 153 | | `false` | failed trace | 154 | | `true` | noop trace | 155 | | `a` | filter traces by test | 156 | | `p + q` | parallel composition | 157 | | `p ; q` | sequential composition | 158 | | `p*` | Kleene star; iteration | 159 | 160 | Whitespace is ignored, and comments are written with `/* ... */`. 161 | 162 | ### Theory-specific forms 163 | 164 | On its own, the Kleene algebra with tests above doesn't let you 165 | express any interesting programs: we need a notion of concrete 166 | predicates and actions. KMT builds a concrete KAT around a _theory_, 167 | which defines a predicates and actions. Our implementation has several 168 | predefined, and [the library itself lets you define new theories](#what-do-I-have-to-provide-to-write-my-own-theory). 169 | 170 | Theories add predicates and actions of the form `NAME(ARGS,...)` and 171 | `ARG1 OP ARG2`. Each theory specificies its own language: an `ARG` 172 | will be a variable or a theory-specific constant of some kind; `NAME` 173 | will be a conventional function symbol name, like `set`; `OP` takes a 174 | variety of forms, like `<` or `=`. 175 | 176 | #### Booleans 177 | 178 | You can use the booleans by specifying `--boolean` on the `kmt` 179 | command line. It is the default theory, so you can also leave it 180 | off. The theory of booleans adds two forms, where `x` and `y` are 181 | variables. We write `T` and `F` for the boolean _values_ true and 182 | false, which should not be confused with the KAT terms `true` and 183 | `false`. 184 | 185 | - `x=T` and `y=F` are tests that are true when `x` is true and `y` 186 | is false, respectively 187 | - `set(x,T)` and `set(y,F)` are actions that set `x` to true and `y` 188 | to false, respectively 189 | 190 | #### Monotonic naturals 191 | 192 | You can use the monotonically increasing naturals by specifying 193 | `--incnat` on the command line. Monotonic naturals have several 194 | theory-specific forms, where variables `x`, `y`, and `z` range over 195 | natural numbers; we write `n` to mean a _constant_ natural number. 196 | 197 | - `x > n` is a test that is true when the variable `x`'s value is greater than `n` 198 | - `inc(y)` is an action that increments the variable `y` 199 | - `set(z, n)` is an action that sets the variable `z` to `n` 200 | 201 | #### Other theories 202 | 203 | We have several other theories built in: 204 | 205 | - `--addition` is a theory of naturals with both `<` and `>`, along with `inc(x,n)` 206 | - `--network` is a theory of tracing NetKAT over natural-valued 207 | fields `src`, `dst`, `pt`, and `sw`; use `FIELD <- n` for 208 | assignment 209 | - `--product` is a product theory of booleans and monotonic naturals 210 | - `--product-addition` is a product theory of booleans and the 211 | `--addition` theory of naturals 212 | 213 | You can [add new 214 | theories](#what-do-I-have-to-provide-to-write-my-own-theory) to the 215 | `kmt` tool by updating the `modes` in `src/kmt.ml`. 216 | 217 | # Step-by-Step 218 | 219 | The paper makes three core claims about the implementation. 220 | 221 | 1. It is extensible. 222 | 2. We have implemented some optimizations. 223 | 3. The benchmarks according to our evaluation in Section 5. 224 | 225 | ## How can I tell that the implementation is extensible? 226 | 227 | Look at `src/kat.ml`. It defines several modules. 228 | 229 | - The `KAT_IMPL` signature characterizes what a KAT has. Here `A` is 230 | for theory tests and `P` is for theory actions. (The `Test` and 231 | `Term` modules are for defining comparison and hashing operations 232 | on the hashconsed KMT terms.) 233 | - The `THEORY` signature characterizes what a client theory must 234 | define to generate a KMT. 235 | - The `KAT` module is a functor that takes a `THEORY` and produces a 236 | `KAT_IMPL`. 237 | 238 | That is, we use OCaml functors to transform a `THEORY` into a `KAT`. 239 | 240 | You can see this process in action in `src/boolean.ml`. After some 241 | base definitions (outside the module to simplify things), we define 242 | the module `Boolean` recursively as a `THEORY`... where we use `K = 243 | KAT (Boolean)` inside our definition. That is, `Boolean.K` is the KMT 244 | over booleans. You can see that there is very little boilerplate: 245 | parsing is just a few lines; we define `push_back` in just a few 246 | lines. The satisfiability checker is somewhat complicated by our use 247 | of a 'fast' path in the `satisfiable` function, where we discharge 248 | simple queries (with just conjunction and negation of theory 249 | predicates, but no disjunction---see `can_use_fast_solver`) without 250 | calling Z3 at all. 251 | 252 | ## What optimizations are implemented? 253 | 254 | All KAT terms are hashconsed. The library for that is in 255 | `src/hashcons.ml`; KAT terms are hashconsed using `'a pred`/`'a 256 | pred_hons` and `('a, 'p) kat` and `('a, 'p) kat_hons` in 257 | `src/kat.ml`. We use smart constructors extensively in the `KAT` 258 | module (see `not`, `ppar`, `pseq`, etc.). 259 | 260 | When we check word equivalence of actions in `src/decide.ml` (see 261 | `same_actions`), we use the `equivalent_words` function in 262 | `src/word.ml`. That method uses the Brzozowski derivative to generate 263 | word automata lazily during checking (see `derivative` and `accepting` in that 264 | `src/word.ml`). 265 | 266 | Finally, several theories implement custom satisfiability checkers 267 | that don't merely defer to Z3: `boolean.ml`, `incnat.ml`, and 268 | `addition.ml`. 269 | 270 | ## How do I reproduce the paper's evaluation? 271 | 272 | By default, the [Docker build](#how-do-i-build-it) will run the 273 | evaluation from Section 5, using a 30s timeout. Here is sample output 274 | (your hash and exact times will differ): 275 | 276 | ``` 277 | Step 14/18 : RUN opam exec -- dune exec -- src/kmt_eval 278 | ---> Running in f609aca22e92 279 | test time (seconds) 280 | 30s timeout 281 | ---------------------------------------- 282 | a* != a (10 random `a`s) 0.0399 283 | count twice 0.0006 284 | count order 0.0008 285 | parity loop 0.0003 286 | boolean tree 0.0004 287 | population count 0.3677 288 | toggle three bits timeout 289 | ``` 290 | 291 | These numbers are slightly higher than those in the paper, which 292 | reports numbers from a local installation. Times will of course vary: 293 | machines differ (the original eval is on a 2014 MacBook Pro with 16GB 294 | of RAM); Docker on macOS is really a VM, and will be substantially 295 | slower than Docker on Linux; Docker will always be slower than [a 296 | local installation](#building-locally). It _should_, however, be the 297 | case that these benchmarks will have the same relative performance. 298 | 299 | You can change the evaluation timeout by passing `-t SECONDS` or 300 | `--timeout SECONDS` to `kmt_eval`. In Docker on macOS 10.13 on the 301 | 2014 MacBook Pro, we find a high timeout is necessary to get the last 302 | benchmark to terminate: 303 | 304 | ```ShellSession 305 | opam@6792c093ed91:~/kmt$ kmt_eval -t 3600 306 | test time (seconds) 307 | 3600s timeout 308 | ---------------------------------------- 309 | a* != a (10 random `a`s) 0.0682 310 | count twice 0.0006 311 | count order 0.0008 312 | parity loop 0.0005 313 | boolean tree 0.0008 314 | population count 0.4311 315 | toggle three bits 1175.1909 316 | ``` 317 | 318 | ## What _isn't_ evaluated? 319 | 320 | Not every theory described in the paper is completely implemented in 321 | KMT. Namely: 322 | 323 | - The implementation of the tracing NetKAT theory uses restricted 324 | fields and natural numbers as values, rather than the richer 325 | domain NetKAT enjoys. 326 | - LTLf is not implemented, and neither is Temporal NetKAT. (But the 327 | [PLDI 2016 implementation is available on 328 | GitHub](https://github.com/rabeckett/Temporal-NetKAT).) 329 | - Sets and maps are not implemented. 330 | 331 | ## Building locally 332 | 333 | The simplest way to play with KMT right away is to [use 334 | Docker](#how-do-i-build-it). If for some reason you would prefer to 335 | run KMT on your own Linux machine, run the following commands from a clone 336 | of the repo: 337 | 338 | ```ShellSession 339 | $ sudo apt-get install -y libgmp-dev python3 340 | $ opam install ocamlfind ppx_deriving batteries ANSIterminal fmt alcotest cmdliner logs zarith z3 dune 341 | $ eval $(opam env) 342 | $ dune build -- src/kmt # build the CLI 343 | $ dune test # unit tests on regex word equivalence and KMT equivalence 344 | $ dune exec -- src/kmt_eval # PLDI2022 eval 345 | ``` 346 | 347 | On macOS, `brew install gmp python3 ; sudo mkdir -p 348 | /opt/local/lib` should replace the call to `apt-get`. 349 | 350 | If the above fails, the CI automation is a good guide for manual installation: see the `Dockerfile` and `.github/workflows/build.yml`. 351 | 352 | ## What do I have to provide to write my own theory? 353 | 354 | The source code in `src/incnat.ml` is a nice example. You have to provide: 355 | 356 | - sub-modules `P` and `A` for the primitive parts of your language 357 | - a `parse` function to indicate how to parse the syntax of your 358 | primitives; return `Left` for tests and `Right` for actions 359 | - a `push_back` operation that calculates weakest preconditions on a 360 | pair of a primitive and a predicate 361 | - a `satisfiable` function to test whether a predicate is satisfiable 362 | 363 | To use the Z3 backend, your theory can describe how it extracts to Z3 using functions `variable`, `variable_test`, `create_z3_var`, and `theory_to_z3_expr`. 364 | 365 | Note that `incnat.ml`'s theory solver in `satisfiable` has two cases: a fast path that need not use Z3, and a more general decision procedure in Z3. 366 | 367 | ### Which example theories should I look at first? 368 | 369 | The code in `src/boolean.ml` is for a simple language with boolean-valued variables. 370 | 371 | Check out `src/incnat.ml` for a simple language with increment and assignment operations. It defines types `a` and `p` for the primitive parts of the language (one predicate, which tests whether a variable is greater than a number, and two actions, which increment and set variables). 372 | 373 | The code in `src/product.ml` is for a _higher-order theory_, combining 374 | two theories into one. You can see it in action using the `--product` 375 | and `--product-addition` flags for KMT. 376 | 377 | ## How is equivalence decided? 378 | 379 | We decide equivalence via _normalization_. We convert KMT terms to a normal form using the novel `push_back` operation; to compare two such normal forms, we disambiguate the tests and compare the terms pointwise. When this procedure is fast, it's _quite_ fast... but deeply nested loops or loops with lots of conditionals slow it down severely. 380 | 381 | In more detail, see `src/decide.ml`. The top-level function is: 382 | 383 | ```OCaml 384 | let equivalent (p: K.Term.t) (q: K.Term.t) : bool = 385 | let nx = normalize_term 0 p in 386 | let ny = normalize_term 0 q in 387 | equivalent_nf nx ny 388 | ``` 389 | 390 | That is, we normalize and then compare normal forms. 391 | 392 | ```OCaml 393 | let equivalent_nf (nx: nf) (ny: nf) : bool = 394 | (* optimization: just if syntactically equal first *) 395 | if PSet.equal nx ny 396 | then 397 | begin 398 | Log.debug (fun m -> m "syntactic equality on %s" (show_nf nx)); 399 | true 400 | end 401 | else begin 402 | Log.debug (fun m -> m 403 | "running cross product on %s and %s" 404 | (show_nf nx) (show_nf ny)); 405 | let xhat = locally_unambiguous_form nx in 406 | Log.debug (fun m -> m "%s is locally unambiguous as %s" (show_nf nx) (show_nf xhat)); 407 | let yhat = locally_unambiguous_form ny in 408 | Log.debug (fun m -> m "%s is locally unambiguous as %s" (show_nf ny) (show_nf yhat)); 409 | equivalent_lunf xhat yhat 410 | end 411 | ``` 412 | 413 | It may be easier to understand without the logging/optimization: 414 | 415 | ```OCaml 416 | let equivalent_nf (nx: nf) (ny: nf) : bool = 417 | let xhat = locally_unambiguous_form nx in 418 | let yhat = locally_unambiguous_form ny in 419 | equivalent_lunf xhat yhat 420 | ``` 421 | 422 | Given normal forms `nx` and `ny`, we first compute locally unambiguous 423 | forms `xhat` and `yhat`; we then check _those_ for equivalence. 424 | 425 | To generate locally unambiguous forms, suppose the normal form `nx` is 426 | equal to `a1;m1 + a2;m2 + ... + an;mj`. We generate `xhat` by 427 | considering every possibly combination of the tests `ai`, which 428 | engender every possibly combination of the actions `mi`. That is: 429 | 430 | ``` 431 | xhat = a1 ; a2 ; ... ; aj ; (m1 + m2 + ... + mj) 432 | + not a1 ; a2 ; ... ; aj ; ( m2 + ... + mj) 433 | + a1 ; not a2 ; ... ; aj ; (m1 + ... + mj) 434 | + ... 435 | + not a1 ; not a2 ; ... ; aj ; ( mj) 436 | + not a1 ; not a2 ; ... ; not aj ; false 437 | ``` 438 | 439 | We build `yhat` from `y = b1;n1 + ... + bk;nk` similarly: 440 | 441 | ``` 442 | yhat = b1 ; b2 ; ... ; bk ; (n1 + n2 + ... + nk) 443 | + not b1 ; b2 ; ... ; bk ; ( n2 + ... + nk) 444 | + b1 ; not b2 ; ... ; bk ; (n1 + ... + nk) 445 | + ... 446 | + not b1 ; not b2 ; ... ; bk ; ( nk) 447 | + not b1 ; not b2 ; ... ; not bk ; false 448 | ``` 449 | 450 | We call these `hat`ted forms "locally unambiguous" because each possible test in `xhat` is syntactically unambiguous. 451 | 452 | Now we can compare `xhat` and `yhat` (in `equivalent_lunf`): consider 453 | every pair of a predicates from `xhat` and `yhat`. If the combination 454 | of the predicates is unsatisfiable, then we can ignore that case. If 455 | it's satisfiable, then for `xhat` and `yhat` to be equivalent, the 456 | actions on both sides must be equivalent. We can decide _that_ 457 | equivalence using the Hopcroft-Karp algorithm (see `equivalent_words` 458 | in `src/word.ml`). 459 | 460 | Congratulations, you read the whole thing! 😁 461 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | - Logging 2 | + Tagging of topics (e.g., sat, other stuff...) 3 | 4 | - Change normalization routine to use minterms 5 | 6 | - SMT module 7 | - Commonality in `satisfiable`? 8 | 9 | - fancy OCaml modules to dynamically generate KMT theories? 10 | (can you define a recursive function with a module return type?) 11 | 12 | - Break off word stuff as a separate library? 13 | - OPAM package? 14 | 15 | - Heuristic optimizations 16 | + `p*p` ~~> `pp*` 17 | + "normal" order for +? 18 | + x>3; not (x > 2) ~~> 0 19 | 20 | - LTLf (pull from a57688c089eaae5388d7153d69338358b114409f) 21 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.0) 2 | (name kmt) 3 | (version 0.1) -------------------------------------------------------------------------------- /kmt.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: "Framework for deriving Kleene Algebras with Tests (KAT)" 3 | maintainer: "Michael Greenberg " 4 | authors: "Michael Greenberg " 5 | license: "MIT" 6 | homepage: "https://github.com/mgree/kmt" 7 | bug-reports: "https://github.com/mgree/kmt/issues" 8 | depends: [ 9 | "ocaml" {>= "4.12"} 10 | "z3" {>= "4.8"} 11 | "batteries" {>= "3.5"} 12 | "ANSITerminal" {>= "0.8"} 13 | "fmt" {>= "0.9"} 14 | "alcotest" {>= "1.5"} 15 | "logs" {>= "0.7"} 16 | "cmdliner" {>= "1.1"} 17 | "ppx_deriving" {>= "5.2"} 18 | "dune" {>= "3.0"} 19 | ] 20 | build: ["dune" "build" "-p" name "-j" jobs] 21 | dev-repo: "git+https:///github.com/mgree/kmt" 22 | url { 23 | src: "https://github.com/mgree/kmt/archive/refs/tags/0.1.tar.gz" 24 | } 25 | 26 | -------------------------------------------------------------------------------- /src/addition.ml: -------------------------------------------------------------------------------- 1 | open Kat 2 | open Syntax 3 | open Common 4 | open Hashcons 5 | 6 | type a = Lt of string * int | Gt of string * int [@@deriving eq] 7 | 8 | type p = Increment of string * int [@@deriving eq] 9 | 10 | let get_name_a = function Lt (x, _) -> x | Gt (x, _) -> x 11 | 12 | let get_name_p (Increment (x, _)) = x 13 | 14 | let get_value = function Lt (_, v) -> v | Gt (_, v) -> v 15 | 16 | let to_int = function Lt _ -> 0 | Gt _ -> 1 17 | 18 | let compare_a a b = 19 | let cmp = StrType.compare (get_name_a a) (get_name_a b) in 20 | if cmp <> 0 then cmp 21 | else 22 | let cmp = get_value a - get_value b in 23 | if cmp <> 0 then cmp else to_int a - to_int b 24 | 25 | 26 | let compare_p p q = 27 | match (p, q) with Increment (x, i), Increment (y, j) -> 28 | let cmp = StrType.compare x y in 29 | if cmp <> 0 then cmp else i - j 30 | 31 | 32 | module rec Addition : THEORY with type A.t = a and type P.t = p = struct 33 | module K = KAT (Addition) 34 | module Test = K.Test 35 | module Term = K.Term 36 | 37 | module P : CollectionType with type t = p = struct 38 | type t = p 39 | let compare = compare 40 | let hash = Hashtbl.hash 41 | let equal = equal_p 42 | let show (Increment (x, i)) = x ^ "+=" ^ string_of_int i 43 | end 44 | 45 | module A : CollectionType with type t = a = struct 46 | type t = a 47 | let compare = compare_a 48 | let hash = Hashtbl.hash 49 | let equal = equal_a 50 | let show = function 51 | | Lt (x, v) -> x ^ "<" ^ string_of_int v 52 | | Gt (x, v) -> x ^ ">" ^ string_of_int v 53 | end 54 | 55 | let name () = "addition" 56 | module Log = (val logger (name ()) : Logs.LOG) 57 | 58 | let variable = get_name_p 59 | 60 | let variable_test = get_name_a 61 | 62 | let parse name es = 63 | match (name, es) with 64 | | "inc", [(EId s1); (EId s2)] -> Right (Increment (s1, int_of_string s2)) 65 | | ">", [(EId s1); (EId s2)] -> Left (Gt (s1, int_of_string s2)) 66 | | "<", [(EId s1); (EId s2)] -> Left (Lt (s1, int_of_string s2)) 67 | | _, _ -> 68 | failwith 69 | ("Cannot create theory object from (" ^ name ^ ") and parameters") 70 | 71 | 72 | open BatSet 73 | 74 | let push_back (Increment (x, i)) a = 75 | match a with 76 | | Lt (y, j) when x = y -> if i >= j 77 | then PSet.create K.Test.compare 78 | else PSet.singleton ~cmp:K.Test.compare (K.theory (Lt (y, j - i))) 79 | | Gt (y, j) when x = y -> if i > j 80 | then PSet.singleton ~cmp:K.Test.compare (K.one ()) 81 | else PSet.singleton ~cmp:K.Test.compare (K.theory (Gt (y, j - i))) 82 | | _ -> PSet.singleton ~cmp:K.Test.compare (K.theory a) 83 | 84 | 85 | let simplify_and a b = 86 | match (a, b) with 87 | | Gt (x, v1), Gt (y, v2) when x = y -> Some (K.theory (Gt (x, max v1 v2))) 88 | | Lt (x, v1), Lt (y, v2) when x = y -> Some (K.theory (Lt (x, min v1 v2))) 89 | | (Gt (x, v1), Lt (y, v2) | Lt (y, v2), Gt (x, v1)) when x = y && v2 <= v1 -> 90 | Some (K.zero ()) 91 | | _, _ -> None 92 | 93 | 94 | let simplify_not a = 95 | match a with 96 | | Gt (x, v) -> Some (K.theory (Lt (x, v + 1))) 97 | | Lt (_x, 0) -> Some (K.one ()) 98 | | Lt (x, v) -> Some (K.theory (Gt (x, v - 1))) 99 | 100 | 101 | let simplify_or _a _b = None 102 | 103 | let merge (p1: P.t) (p2: P.t) : P.t = 104 | match (p1, p2) with 105 | Increment (x, i), Increment (_y, j) -> Increment (x, i + j) 106 | 107 | 108 | let reduce _a p = Some p 109 | 110 | let create_z3_var (str,_a) (ctx : Z3.context) (solver : Z3.Solver.solver) : Z3.Expr.expr = 111 | let sym = Z3.Symbol.mk_string ctx str in 112 | let int_sort = Z3.Arithmetic.Integer.mk_sort ctx in 113 | let xc = Z3.Expr.mk_const ctx sym int_sort in 114 | let is_nat = 115 | Z3.Arithmetic.mk_ge ctx xc (Z3.Arithmetic.Integer.mk_numeral_i ctx 0) 116 | in 117 | Z3.Solver.add solver [is_nat]; 118 | xc 119 | 120 | let theory_to_z3_expr (a : A.t) (ctx : Z3.context) (map : Z3.Expr.expr StrMap.t) : Z3.Expr.expr = 121 | match a with 122 | | Lt (x, v) -> 123 | let var = StrMap.find x map in 124 | let value = Z3.Arithmetic.Integer.mk_numeral_i ctx v in 125 | Z3.Arithmetic.mk_lt ctx var value 126 | | Gt (x, v) -> 127 | let var = StrMap.find x map in 128 | let value = Z3.Arithmetic.Integer.mk_numeral_i ctx v in 129 | Z3.Arithmetic.mk_gt ctx var value 130 | 131 | module H = Hashtbl.Make (K.Test) 132 | 133 | let tbl = H.create 2048 134 | 135 | let rec can_use_fast_solver (a: K.Test.t) = 136 | match a.node with 137 | | One | Zero | Placeholder _ | Theory _ -> true 138 | | PPar _ -> false 139 | | PSeq (b, c) -> can_use_fast_solver b && can_use_fast_solver c 140 | | Not {node=Theory _; _} -> true 141 | | Not _ -> false 142 | 143 | let satisfiable (a: K.Test.t) = 144 | try H.find tbl a with _ -> 145 | if not (can_use_fast_solver a) then ( 146 | Log.debug (fun m -> m "%s taking SLOW path" (K.Test.show a)); 147 | let ret = K.z3_satisfiable a in 148 | H.add tbl a ret ; ret ) 149 | else ( 150 | Log.debug (fun m -> m "%s taking FAST path" (K.Test.show a)); 151 | let mergeOp map1 map2 op = 152 | StrMap.merge 153 | (fun _ v1 v2 -> 154 | match (v1, v2) with 155 | | None, _ -> v2 156 | | _, None -> v1 157 | | Some x, Some y -> Some (op x y) ) 158 | map1 map2 159 | in 160 | let rec aux (a: K.Test.t) : Range.t StrMap.t = 161 | match a.node with 162 | | One | Zero | Placeholder _ -> failwith "Increment: satisfiability" 163 | | Not b -> StrMap.map Range.negate (aux b) 164 | | PPar (b, c) -> mergeOp (aux b) (aux c) Range.union 165 | | PSeq (b, c) -> mergeOp (aux b) (aux c) Range.inter 166 | | Theory Gt (x, v) -> 167 | StrMap.singleton x (Range.from_range (v + 1, max_int)) 168 | | Theory Lt (x, v) -> 169 | let p = 170 | if v = 0 then Range.bot else Range.from_range (0, v - 1) 171 | in 172 | StrMap.singleton x p 173 | in 174 | match a.node with 175 | | One -> true 176 | | Zero -> false 177 | | _ -> 178 | let result = aux a in 179 | let ret = 180 | StrMap.for_all (fun _ r -> not (Range.is_false r)) result 181 | in 182 | H.add tbl a ret ; ret) 183 | end 184 | -------------------------------------------------------------------------------- /src/boolean.ml: -------------------------------------------------------------------------------- 1 | open Kat 2 | open Syntax 3 | open Common 4 | open Hashcons 5 | 6 | type a = Bool of string * bool [@@deriving eq] 7 | 8 | type p = Assign of string * bool [@@deriving eq] 9 | 10 | let get_name_a = function Bool (x, _) -> x 11 | 12 | let get_name_p (Assign (x, _)) = x 13 | 14 | let get_value = function Bool (_, v) -> v 15 | 16 | let get_value_int = function Bool (_, v) -> if v then 1 else 0 17 | 18 | let compare_a a b = 19 | let cmp = StrType.compare (get_name_a a) (get_name_a b) in 20 | if cmp <> 0 then cmp else get_value_int a - get_value_int b 21 | 22 | let compare_p p q = 23 | match (p, q) with Assign (x, i), Assign (y, j) -> 24 | let cmp = StrType.compare x y in 25 | if cmp <> 0 then cmp else (if i then 1 else 0) - if j then 1 else 0 26 | 27 | module rec Boolean : THEORY with type A.t = a and type P.t = p = struct 28 | module K = KAT (Boolean) 29 | module Test = K.Test 30 | module Term = K.Term 31 | 32 | module P : CollectionType with type t = p = struct 33 | type t = p 34 | let compare = compare 35 | let hash = Hashtbl.hash 36 | let equal = equal_p 37 | let show (Assign (x, i)) = "set(" ^ x ^ "," ^ (if i then "T" else "F") ^ ")" 38 | end 39 | 40 | module A : CollectionType with type t = a = struct 41 | type t = a 42 | let compare = compare_a 43 | let hash = Hashtbl.hash 44 | let equal = equal_a 45 | let show = function Bool (x, v) -> x ^ "=" ^ if v then "T" else "F" 46 | end 47 | 48 | let name () = "boolean" 49 | module Log = (val logger (name ()) : Logs.LOG) 50 | 51 | let variable = get_name_p 52 | 53 | let variable_test = get_name_a 54 | 55 | let get_bool s = 56 | match s with 57 | | "T" -> true 58 | | "F" -> false 59 | | _ -> failwith ("invalid boolean value: " ^ s) 60 | 61 | 62 | let parse name es = 63 | match (name, es) with 64 | | "set", [(EId s1); (EId s2)] -> Right (Assign (s1, get_bool s2)) 65 | | "=", [(EId s1); (EId s2)] -> Left (Bool (s1, get_bool s2)) 66 | | _, _ -> 67 | failwith 68 | ("Cannot create theory object from (" ^ name ^ ") and parameters") 69 | 70 | open BatSet 71 | 72 | let push_back (Assign (x, i)) a = 73 | match a with 74 | | Bool (v, j) when x = v && i <> j -> PSet.create K.Test.compare 75 | | Bool (v, j) when x = v && i = j -> 76 | PSet.singleton ~cmp:K.Test.compare (K.one ()) 77 | | _ -> PSet.singleton ~cmp:K.Test.compare (K.theory a) 78 | 79 | let simplify_and (Bool (x, v1)) (Bool (y, v2)) = 80 | if x = y && v1 <> v2 then Some (K.zero ()) else None 81 | 82 | let simplify_or (Bool (x, v1)) (Bool (y, v2)) = 83 | if x = y && v1 <> v2 then Some (K.one ()) else None 84 | 85 | let simplify_not (Bool (x, v)) = Some (K.theory (Bool (x, not v))) 86 | 87 | let merge (_p1: P.t) (p2: P.t) : P.t = p2 88 | 89 | let reduce _a p = Some p 90 | 91 | let theory_to_z3_expr (a : A.t) (ctx : Z3.context) (map : Z3.Expr.expr StrMap.t) = 92 | match a with Bool (x, v) -> 93 | let var = StrMap.find x map in 94 | let value = Z3.Boolean.mk_val ctx v in 95 | Z3.Boolean.mk_eq ctx var value 96 | 97 | let create_z3_var (str,_a) (ctx : Z3.context) (_solver : Z3.Solver.solver) : Z3.Expr.expr = 98 | let sym = Z3.Symbol.mk_string ctx str in 99 | let bool_sort = Z3.Boolean.mk_sort ctx in 100 | Z3.Expr.mk_const ctx sym bool_sort 101 | 102 | module H = Hashtbl.Make (K.Test) 103 | 104 | let tbl = H.create 2048 105 | 106 | let rec can_use_fast_solver (a: K.Test.t) = 107 | match a.node with 108 | | One | Zero | Placeholder _ | Theory _ -> true 109 | | PPar _ -> false 110 | | PSeq (b, c) -> can_use_fast_solver b && can_use_fast_solver c 111 | | Not {node=Theory _; _} -> true 112 | | Not _ -> false 113 | 114 | let satisfiable (a: K.Test.t) = 115 | try H.find tbl a with _ -> 116 | if not (can_use_fast_solver a) then ( 117 | Log.debug (fun m -> m "%s taking SLOW path" (K.Test.show a)); 118 | let ret = K.z3_satisfiable a in 119 | H.add tbl a ret ; ret ) 120 | else ( 121 | Log.debug (fun m -> m "%s taking FAST path" (K.Test.show a)) ; 122 | let mergeOp map1 map2 op = 123 | StrMap.merge 124 | (fun _ v1 v2 -> 125 | match (v1, v2) with 126 | | None, _ -> v2 127 | | _, None -> v1 128 | | Some x, Some y -> Some (op x y) ) 129 | map1 map2 130 | in 131 | let rec aux (a: K.Test.t) : Range.t StrMap.t = 132 | match a.node with 133 | | One | Zero | Placeholder _ -> failwith "Increment: satisfiability" 134 | | Not b -> StrMap.map Range.negate (aux b) 135 | | PPar (b, c) -> mergeOp (aux b) (aux c) Range.union 136 | | PSeq (b, c) -> mergeOp (aux b) (aux c) Range.inter 137 | | Theory Bool (x, true) -> 138 | StrMap.singleton x (Range.from_range (1, max_int)) 139 | | Theory Bool (x, false) -> 140 | StrMap.singleton x (Range.from_range (0, 0)) 141 | in 142 | match a.node with 143 | | One -> true 144 | | Zero -> false 145 | | _ -> 146 | let result = aux a in 147 | let ret = 148 | StrMap.for_all (fun _ r -> not (Range.is_false r)) result 149 | in 150 | H.add tbl a ret ; ret ) 151 | end 152 | -------------------------------------------------------------------------------- /src/common.ml: -------------------------------------------------------------------------------- 1 | (*******************************************************************) 2 | (* *) 3 | (* A collection of commonly useful functions *) 4 | (* *) 5 | (*******************************************************************) 6 | 7 | let uncurry (f: 'a -> 'b -> 'c) ((a, b): 'a * 'b) : 'c = f a b 8 | 9 | module type CollectionType = sig 10 | type t 11 | val equal : t -> t -> bool 12 | val compare : t -> t -> int 13 | val hash : t -> int 14 | val show : t -> string 15 | end 16 | 17 | type ('a, 'b) either = Left of 'a | Right of 'b 18 | 19 | (* Helper functions for dealing with 20 | the standard library option type *) 21 | 22 | module Option = struct 23 | (* Creating collection types of pairs *) 24 | module Make (X : CollectionType) = struct 25 | type t = X.t option 26 | 27 | let compare a b = 28 | match (a, b) with 29 | | None, None -> 0 30 | | Some x, Some y -> X.compare x y 31 | | None, Some _ -> -1 32 | | Some _, None -> 1 33 | 34 | let equal x y = compare x y = 0 35 | let hash = function None -> 1 | Some x -> 2 + X.hash x 36 | let show = function 37 | | None -> "None" 38 | | Some x -> Printf.sprintf "Some(%s)" (X.show x) 39 | end 40 | 41 | let unwrap o = match o with None -> failwith "unwrap" | Some v -> v 42 | 43 | let is_none o = match o with None -> true | Some _ -> false 44 | 45 | let is_some o = match o with None -> false | Some _ -> true 46 | 47 | let get o = 48 | match o with None -> failwith "[Option.get]: None value" | Some v -> v 49 | end 50 | 51 | module Either = struct 52 | (* Creating collection types of pairs *) 53 | module Make (X : CollectionType) (Y : CollectionType) = struct 54 | type t = (X.t, Y.t) either 55 | 56 | let compare a b = 57 | match (a, b) with 58 | | Left x, Left y -> X.compare x y 59 | | Right x, Right y -> Y.compare x y 60 | | Left _, Right _ -> -1 61 | | Right _, Left _ -> 1 62 | 63 | let equal x y = compare x y = 0 64 | let hash = function Left x -> 5 + X.hash x | Right y -> 7 + Y.hash y 65 | let show = function 66 | | Left x -> "Left(" ^ X.show x ^ ")" 67 | | Right y -> "Right(" ^ Y.show y ^ ")" 68 | end 69 | end 70 | 71 | (* Pair helper functions *) 72 | 73 | module Pair = struct 74 | (* Creating collection types of pairs *) 75 | module Make (X : CollectionType) (Y : CollectionType) = struct 76 | type t = X.t * Y.t 77 | let compare (a, b) (c, d) = 78 | let cmp = X.compare a c in 79 | if cmp <> 0 then cmp else Y.compare b d 80 | let equal x y = compare x y = 0 81 | let hash (a, b) = 31 * X.hash a + Y.hash b 82 | let show (a, b) = Printf.sprintf "(%s,%s)" (X.show a) (Y.show b) 83 | end 84 | 85 | let map_fst f (a, b) = (f a, b) 86 | let map_snd f (a, b) = (a, f b) 87 | end 88 | 89 | module Memoize (A : CollectionType) = struct 90 | let cache_size = 2048 91 | 92 | module NP = Hashtbl.Make (A) 93 | 94 | let memoize f = 95 | let tbl = NP.create (cache_size * 2) in 96 | let rec aux x = 97 | try NP.find tbl x with _ -> 98 | let res = f aux x in 99 | if NP.length tbl > cache_size then NP.clear tbl ; 100 | NP.add tbl x res ; 101 | res 102 | in 103 | aux 104 | end 105 | 106 | let rec concat_map (f: 'a -> 'b list) (l: 'a list) : 'b list = 107 | match l with 108 | | [] -> [] 109 | | (a::l') -> f a @ concat_map f l' 110 | 111 | let rec insert_everywhere (x: 'a) (l: 'a list) : ('a list) list = 112 | match l with 113 | | [] -> [[x]] 114 | | y::l' -> (x::l) :: List.map (fun l'' -> y::l'') (insert_everywhere x l') 115 | 116 | let rec permutations l = 117 | match l with 118 | | [] -> [[]] 119 | | x::l' -> concat_map (insert_everywhere x) (permutations l') 120 | 121 | let cartesian_product (l1: 'a list) (l2: 'b list) : ('a * 'b) list = 122 | concat_map (fun a -> List.map (fun b -> (a,b)) l2) l1 123 | 124 | let all_pairs l = cartesian_product l 125 | 126 | let unique_pairs (l: 'a list) : ('a * 'a) list = 127 | let rec loop l acc = 128 | match l with 129 | | [] -> acc 130 | | a::l' -> loop l' (List.map (fun b -> (a,b)) l' @ acc) 131 | in 132 | loop l [] 133 | 134 | let cross_product x y base f = 135 | BatSet.PSet.fold 136 | (fun a' acc1 -> 137 | BatSet.PSet.fold (fun b' acc2 -> BatSet.PSet.add (f a' b') acc2) y acc1 138 | ) 139 | x base 140 | 141 | let equivalence_classes (eq_dec: 'a -> 'a -> bool) (l: 'a list) : ('a list) list = 142 | let rec add (x: 'a) (eqs: ('a list) list) : ('a list) list = 143 | match eqs with 144 | | [] -> [[x]] 145 | | cls::eqs -> 146 | begin match cls with 147 | | [] -> add x eqs (* should never happen *) 148 | | (rep::_) -> (* TODO MMG 2020-03-27 heuristic for selecting representative? *) 149 | if eq_dec x rep 150 | then (x::cls)::eqs 151 | else cls::add x eqs 152 | end 153 | in 154 | List.fold_right add l [] 155 | 156 | let unreachable () = failwith "unreachable" 157 | 158 | (* Convenience functions that help for 159 | debugging various collection types *) 160 | 161 | let debug_enabled = 162 | Sys.argv |> 163 | Array.exists (fun flag -> flag = "--debug") 164 | 165 | let quiet_enabled = 166 | Sys.argv |> 167 | Array.exists (fun flag -> flag = "--quiet") 168 | 169 | let rec repeat n str = 170 | match n with x when x <= 0 -> "" | 1 -> str | _ -> str ^ repeat (n - 1) str 171 | 172 | let time f x = 173 | let t = Sys.time () in 174 | let fx = f x in 175 | let time = Sys.time () -. t in 176 | (fx, time) 177 | 178 | let timeout limit f x = 179 | let (r,w) = Unix.pipe () in 180 | let pid = Unix.fork () in 181 | if pid = 0 182 | then 183 | begin 184 | (* child *) 185 | begin 186 | if limit > 0 then ignore (Unix.alarm limit) 187 | end; 188 | let start = Sys.time () in 189 | ignore (Sys.opaque_identity (f x)); 190 | let finish = Sys.time () in 191 | let oc = Unix.out_channel_of_descr w in 192 | output_value oc (finish -. start); 193 | close_out oc; 194 | exit 0 195 | end 196 | else 197 | begin 198 | (* parent *) 199 | let _,status = Unix.waitpid [] pid in 200 | match status with 201 | | Unix.WEXITED 0 -> 202 | let ic = Unix.in_channel_of_descr r in 203 | let time = input_value ic in 204 | close_in ic; 205 | Some time 206 | | _ -> None 207 | end 208 | 209 | let add_sep sep acc = if acc = "" then acc else sep ^ acc 210 | 211 | let intercalate sep l = 212 | let rec loop l acc first = 213 | match l with 214 | | [] -> acc 215 | | s::l' -> loop l' (acc ^ (if first then "" else sep) ^ s) false 216 | in 217 | loop l "" true 218 | 219 | let show_set f fold set = 220 | let elts = fold (fun x acc -> f x ^ add_sep "," acc) set "" in 221 | "{" ^ elts ^ "}" 222 | 223 | let show_list f lst = "[" ^ intercalate "," (List.map f lst) ^ "]" 224 | 225 | let show_map fkey fval fold map = 226 | let aux k v acc = fkey k ^ "==>" ^ fval v ^ add_sep "," acc in 227 | "{" ^ fold aux map "" ^ "}" 228 | 229 | (* Set default seed value to make 230 | randomized tests deterministic *) 231 | 232 | let _ = Random.init 17 233 | 234 | let _hash x acc = acc lsr 5 - 1 + x 235 | 236 | (* Specialize Maps and Sets for commonly used 237 | int and string types. Provides more efficient 238 | comparison/hash/equality functions than using 239 | polymorphic compare. Since natural numbers are used 240 | often, we use subtraction for comparison without 241 | worrying about overflow. *) 242 | 243 | module IntType = struct 244 | type t = int 245 | let equal i j = i = j 246 | let compare (i: int) j = if i < j then -1 else if i > j then 1 else 0 247 | let hash i = i land max_int 248 | let show = string_of_int 249 | end 250 | 251 | module IntType2 = struct 252 | type t = int * int 253 | let equal x y = compare x y = 0 254 | let compare (a, b) (c, d) = 255 | let cmp = IntType.compare a c in 256 | if cmp = 0 then IntType.compare b d else cmp 257 | let hash (i, j) = i land max_int + j land max_int 258 | let show (i, j) = "(" ^ string_of_int i ^ "," ^ string_of_int j ^ ")" 259 | end 260 | 261 | module NatType = struct 262 | type t = int 263 | let compare i j = i - j 264 | let equal i j = i = j 265 | let hash i = i land max_int 266 | let show = string_of_int 267 | end 268 | 269 | module NatType2 = struct 270 | type t = int * int 271 | let equal x y = compare x y = 0 272 | let compare (a, b) (c, d) = 273 | let cmp = a - c in 274 | if cmp = 0 then b - d else cmp 275 | let hash (i, j) = (i + j) land max_int 276 | let show (i, j) = "(" ^ string_of_int i ^ "," ^ string_of_int j ^ ")" 277 | end 278 | 279 | module StrType = struct 280 | type t = string 281 | let compare = String.compare 282 | let equal i j = String.compare i j = 0 283 | let hash s = 284 | let h = ref 0 in 285 | for i = 0 to String.length s - 1 do h := !h lsr 5 - 1 + Char.code s.[i] 286 | done ; 287 | !h 288 | let show x = x 289 | end 290 | 291 | module NatSet = struct 292 | module S = Set.Make (NatType) 293 | include S 294 | let hash x = S.fold (fun y acc -> _hash y acc) x 0 295 | end 296 | 297 | module StrSet = Set.Make (StrType) 298 | module StrMap = Map.Make (StrType) 299 | module NatMap = Map.Make (NatType) 300 | -------------------------------------------------------------------------------- /src/decide.ml: -------------------------------------------------------------------------------- 1 | open Kat 2 | open BatSet 3 | open Hashcons 4 | open Word 5 | 6 | (* Decision procedure based on rewriting via normalization *) 7 | 8 | let decide_log_src = Logs.Src.create "kmt.decide" 9 | ~doc:"logs KMT equivalence via normalization" 10 | module Log = (val Logs.src_log decide_log_src : Logs.LOG) 11 | 12 | 13 | module Decide (T : THEORY) = struct 14 | module K = T.K 15 | 16 | (* module C = CompleteTheory(T) *) 17 | 18 | type nf_elt = K.Test.t * K.Term.t 19 | 20 | type nf = nf_elt PSet.t 21 | 22 | (* locally unambiguous... same type, but useful as documentation *) 23 | type lunf = nf 24 | 25 | let compare_test (a: K.Test.t) (b: K.Test.t) = a.tag - b.tag 26 | 27 | let compare_nf_elt (a, b) (c, d) = 28 | let cmp = a.tag - c.tag in 29 | if cmp <> 0 then cmp else b.tag - d.tag 30 | 31 | let empty () = PSet.create compare_nf_elt 32 | 33 | let singleton x = PSet.singleton ~cmp:compare_nf_elt x 34 | 35 | let spaces i = Stdlib.String.make (4 * i) ' ' 36 | 37 | let show_nf (x: nf) : string = 38 | let ret = 39 | PSet.fold 40 | (fun (test, term) acc -> 41 | let x = if acc = "" then acc else acc ^ ", " in 42 | x ^ "(" ^ K.Test.show test ^ "," ^ K.Term.show term ^ ")" ) 43 | x "" 44 | in 45 | "{" ^ ret ^ "}" 46 | 47 | let rec flatten (a: K.Test.t) : K.Test.t PSet.t = 48 | match a.node with 49 | | Theory _ | PPar _ | One | Zero | Not _ -> PSet.singleton ~cmp:compare_test a 50 | | PSeq (b, c) -> PSet.union (flatten b) (flatten c) 51 | | Placeholder _ -> failwith "impossible flatten of placeholder" 52 | 53 | let rec size (a: K.Test.t) = 54 | match a.node with 55 | | Zero | One -> 0 56 | | Theory _ -> 1 57 | | PPar (b, c) | PSeq (b, c) -> 1 + size b + size c 58 | | Not b -> 1 + size b 59 | | Placeholder _ -> failwith "impossible size of placeholder" 60 | 61 | let seq_all (x: K.Test.t PSet.t) = 62 | PSet.fold (fun test acc -> K.pseq test acc) x (K.one ()) 63 | 64 | let split (a: K.Test.t) (x: nf) : nf * nf = 65 | if PSet.is_empty x then (empty (), empty ()) 66 | else 67 | let flat = PSet.map (fun (test, term) -> (flatten test, term)) x in 68 | let contains, missing = 69 | PSet.partition (fun (tests, _) -> PSet.mem a tests) flat 70 | in 71 | let contains = 72 | PSet.map 73 | (fun (tests, term) -> (PSet.remove a tests |> seq_all, term)) 74 | contains 75 | in 76 | let missing = 77 | PSet.map (fun (tests, term) -> (seq_all tests, term)) missing 78 | in 79 | (contains, missing) 80 | 81 | let pick_mt (x: nf) : K.Test.t = 82 | let choices = 83 | PSet.fold 84 | (fun (test, _) acc -> PSet.union (flatten test) acc) 85 | x (PSet.create compare_test) 86 | in 87 | let choices = PSet.to_list choices in 88 | let choices = List.map (fun a -> (a, size a)) choices in 89 | let pick = 90 | List.fold_left 91 | (fun acc (a, size) -> 92 | match acc with 93 | | None -> Some (a, size) 94 | | Some (_b, sizeb) -> if size > sizeb then Some (a, size) else acc ) 95 | None choices 96 | in 97 | match pick with None -> failwith "impossible pick_mt of empty" | Some (a, _) -> a 98 | 99 | let zero = K.zero () 100 | 101 | let one = K.one () 102 | 103 | let stitch (a: K.Test.t) (x: nf) : nf = 104 | PSet.map (fun (test, term) -> (K.pseq a test, term)) x 105 | |> PSet.filter (fun (test, _) -> test.node <> Zero) 106 | 107 | (* nf insert *) 108 | (* MMG changing to this everywhere severely slows down Boolean-tree-ordering *) 109 | let nf_add ((a,m) : nf_elt) (x: nf) : nf = 110 | let (same, rest) = PSet.partition (fun (b, _n) -> a.tag = b.tag) x in 111 | let ns = PSet.map snd same in 112 | PSet.add (a, PSet.fold K.par ns m) rest 113 | 114 | (* nf union *) 115 | let nf_union (x: nf) (y: nf) : nf = 116 | PSet.fold nf_add x y 117 | 118 | let rec normalize (p: K.Term.t) : K.Term.t = 119 | let nf = normalize_term 0 p in 120 | Log.debug (fun m -> m "Full NF: %s" (show_nf nf)) ; 121 | let nf = nf |> PSet.to_list |> List.sort compare_nf_elt in 122 | let base = K.pred zero in 123 | List.fold_left 124 | (fun acc (test, term) -> K.par acc (K.seq (K.pred test) term)) 125 | base nf 126 | 127 | and normalize_term (i: int) (p: K.Term.t) : nf = 128 | Log.debug (fun m -> m "%snormalize_term: %s" (spaces i) (K.Term.show p) ) ; 129 | match p.node with 130 | | Action _ -> singleton (one, p) 131 | | Pred a -> singleton (a, K.pred one) 132 | | Par (a, b) -> 133 | nf_union (normalize_term (i + 1) a) (normalize_term (i + 1) b) 134 | | Seq (a, b) -> 135 | push_back_j (i + 1) 136 | (normalize_term (i + 1) a) 137 | (normalize_term (i + 1) b) 138 | | Star a -> push_back_star (i + 1) (normalize_term (i + 1) a) 139 | 140 | 141 | and push_back_j (i: int) (x: nf) (y: nf) : nf = 142 | Log.debug (fun m -> m "%spush_back_j: %s and %s" (spaces i) (show_nf x) 143 | (show_nf y) ) ; 144 | let ret = 145 | PSet.fold 146 | (fun (test1, term1) acc -> 147 | PSet.fold 148 | (fun (test2, term2) acc2 -> 149 | let elts : nf = push_back_dot (i + 1) term1 test2 in 150 | let elts : nf = 151 | PSet.map 152 | (fun (test, term) -> (K.pseq test1 test, K.seq term term2)) 153 | elts 154 | in 155 | let elts : nf = 156 | PSet.filter (fun (test, _) -> test.node <> Zero) elts 157 | in 158 | nf_union elts acc2 ) 159 | y acc ) 160 | x (empty ()) 161 | in 162 | Log.debug (fun m -> m "%sresult: %s" (spaces i) (show_nf ret)) ; 163 | ret 164 | 165 | 166 | and push_back_dot (i: int) (m: K.Term.t) (a: K.Test.t) : nf = 167 | Log.debug (fun f -> f "%spush_back_dot: %s and %s" (spaces i) (K.Term.show m) 168 | (K.Test.show a) ) ; 169 | let ret = 170 | match (m.node, a.node) with 171 | | _, Zero -> singleton (zero, K.pred one) 172 | | _, One -> singleton (one, m) 173 | | Action (_, p), Theory a -> 174 | let x = K.push_back p a in 175 | PSet.map (fun t -> (t, m)) x 176 | | Action (_, _p), Not a -> 177 | let nf = push_back_dot (i + 1) m a in 178 | let sum = 179 | PSet.fold (fun (test, _term) acc -> K.ppar test acc) nf zero 180 | in 181 | let b = nnf (K.not sum) in 182 | singleton (b, m) 183 | | _, PSeq (a, b) -> 184 | let y = push_back_dot (i + 1) m a in 185 | let z = push_back_t (i + 1) y b in 186 | z 187 | | Seq (m, n), _ -> 188 | let x = push_back_dot (i + 1) n a in 189 | let y = push_back_r (i + 1) m x in 190 | y 191 | | _, PPar (a, b) -> 192 | nf_union (push_back_dot (i + 1) m a) (push_back_dot (i + 1) m b) 193 | | Par (m, n), _ -> 194 | 195 | nf_union (push_back_dot (i + 1) m a) (push_back_dot (i + 1) n a) 196 | | Star m', _ -> 197 | let x = push_back_dot (i + 1) m' a in 198 | let t, u = split a x in 199 | if PSet.is_empty t then 200 | let x = u in 201 | let y = push_back_r (i + 1) m x in 202 | PSet.add (a, K.pred one) y 203 | else 204 | let x = push_back_r (i + 1) m u in 205 | let y = push_back_star (i + 1) t in 206 | let z = push_back_j (i + 1) x y in 207 | let y = stitch a y in 208 | nf_union y z 209 | | _, Placeholder _ -> failwith "impossible pushback_dot of placeholder" 210 | | Pred b, _ -> singleton (K.pseq b a, K.pred one) 211 | in 212 | Log.debug (fun m -> m "%sresult:%s" (spaces i) (show_nf ret)) ; 213 | ret 214 | 215 | 216 | and push_back_t (i: int) (x: nf) (a: K.Test.t) : nf = 217 | Log.debug (fun m -> m "%spush_back_t: %s and %s" (spaces i) (show_nf x) 218 | (K.Test.show a) ) ; 219 | let ret = 220 | PSet.fold 221 | (fun (test, term) acc -> 222 | let elts = push_back_dot (i + 1) term a in 223 | let elts : nf = PSet.map (fun (b, m') -> (K.pseq test b, m')) elts in 224 | nf_union elts acc ) 225 | x (empty ()) 226 | in 227 | Log.debug (fun m -> m "%sresult: %s" (spaces i) (show_nf ret)) ; 228 | ret 229 | 230 | 231 | and push_back_r (i: int) (m: K.Term.t) (x: nf) : nf = 232 | Log.debug (fun f -> f "%spush_back_t: %s and %s" (spaces i) (K.Term.show m) 233 | (show_nf x) ) ; 234 | let ret = PSet.fold 235 | (fun (test, term) acc -> 236 | let elts : nf = push_back_dot (i + 1) m test in 237 | let elts : nf = PSet.map (fun (a, p) -> (a, K.seq p term)) elts in 238 | nf_union elts acc ) 239 | x (empty ()) 240 | in 241 | Log.debug (fun m -> m "%sresult: %s" (spaces i) (show_nf ret)) ; 242 | ret 243 | 244 | and push_back_star (i: int) (x: nf) : nf = 245 | Log.debug (fun m -> m "%spush_back_star: %s" (spaces i) (show_nf x) ) ; 246 | let ret = 247 | if PSet.is_empty x then singleton (one, K.pred one) (* StarZero *) 248 | else 249 | let a = pick_mt x in 250 | Log.debug (fun m -> m "%sMaximal test:%s" (spaces i) (K.Test.show a) ) ; 251 | let x, y = split a x in 252 | if PSet.is_empty y then 253 | if a.node == One then (* some weird optimization? MMG *) begin 254 | Log.debug (fun m -> m "%sHit a.node = One optimization" (spaces i)); 255 | let term = 256 | PSet.fold 257 | (fun (_test, term) acc -> K.par acc term) 258 | x 259 | (K.pred (K.zero ())) 260 | in 261 | singleton (a, K.star term) 262 | end 263 | else 264 | let y = push_back_t (i + 1) x a in 265 | let t, u = split a y in 266 | match PSet.is_empty t with 267 | | true -> (* Slide *) 268 | let y = u in 269 | let y' = push_back_star (i + 1) y in 270 | let z = push_back_j (i + 1) y' x in 271 | let z = stitch a z in 272 | PSet.add (one, K.pred one) z 273 | | false -> (* Expand *) 274 | begin 275 | Log.debug (fun m -> m "%sEXPAND %s!" (spaces i) (show_nf x)); 276 | let x' = y in 277 | let t, u = split a x' in 278 | let stitched = nf_union t u in 279 | Log.debug (fun m -> m "%sEXPAND %s calls PB^* %s" (spaces i) (show_nf x) (show_nf stitched)); 280 | let y = push_back_star (i + 1) stitched in 281 | Log.debug (fun m -> m "%sEXPAND %s calls PB^J %s;%s" (spaces i) (show_nf x) (show_nf y) (show_nf x)); 282 | let z = push_back_j (i + 1) y x in 283 | PSet.add (one, K.pred one) (stitch a z) 284 | end 285 | else (* Denest *) 286 | begin 287 | Log.debug (fun m -> m "%sDENEST %s!" (spaces i) (show_nf x)); 288 | Log.debug (fun m -> m "%sDENEST %s calls PB^* %s" (spaces i) (show_nf x) (show_nf y)); 289 | let y' = push_back_star (i + 1) y in 290 | Log.debug (fun m -> m "%sDENEST %s calls PB^J %s" (spaces i) (show_nf x) (show_nf y')); 291 | let x' = push_back_j (i + 1) x y' in 292 | let stitched = stitch a x' in 293 | Log.debug (fun m -> m "%sDENEST %s calls PB^* %s" (spaces i) (show_nf x) (show_nf stitched)); 294 | let z = push_back_star (i + 1) stitched in 295 | Log.debug (fun m -> m "%sDENEST %s calls PB^J %s;%s" (spaces i) (show_nf x) (show_nf y') (show_nf z)); 296 | push_back_j (i + 1) y' z 297 | end 298 | in 299 | Log.debug (fun m -> m "%sresult: %s" (spaces i) (show_nf ret)) ; 300 | ret 301 | 302 | 303 | and fix (_i: int) (nf: nf) : nf * int * int = 304 | let eq curr (prev, _) = PSet.equal curr prev in 305 | let rec aux prevs = 306 | let prev, i = List.hd prevs in 307 | let k = i + 1 in 308 | let curr = push_back_j i prev nf in 309 | match List.find_opt (eq curr) prevs with 310 | | None -> aux ((curr, k) :: prevs) 311 | | Some (_, i) -> (curr, i, k - i) 312 | in 313 | aux [(nf, 0)] 314 | 315 | 316 | (* returns 1 + x + x;x + x;x;x + ... + x^count *) 317 | and repeatSeq (i: int) (x: nf) (count: int) : nf = 318 | let xs : nf ref = ref (singleton (one, K.pred one)) in 319 | let acc : nf ref = xs in 320 | for _j = 1 to count do 321 | xs := push_back_j i !xs x ; 322 | acc := nf_union !xs !acc 323 | done ; 324 | !acc 325 | 326 | 327 | and nnf (a: K.Test.t) : K.Test.t = 328 | match a.node with 329 | | Zero -> zero 330 | | One -> one 331 | | Theory _ -> a 332 | | PSeq (a, b) -> K.pseq (nnf a) (nnf b) 333 | | PPar (a, b) -> K.ppar (nnf a) (nnf b) 334 | | Not a -> nnfNeg a 335 | | Placeholder _ -> failwith "nnf placeholder undefined" 336 | 337 | 338 | and nnfNeg (a: K.Test.t) : K.Test.t = 339 | match a.node with 340 | | Zero -> one 341 | | One -> zero 342 | | Theory _ -> K.not a 343 | | Not a -> a 344 | | PPar (a, b) -> K.ppar (nnfNeg a) (nnfNeg b) 345 | | PSeq (a, b) -> K.pseq (nnfNeg a) (nnfNeg b) 346 | | Placeholder _ -> failwith "nnf placeholder undefined" 347 | 348 | (* general outline 349 | 350 | 1. explosion into disjoint form (local unambiguity) 351 | prune obviously impossible cases (no SMT use at present) 352 | 2. cross product (global unambiguity) 353 | prune impossible cases with SMT 354 | 3. word comparison on like cases 355 | *) 356 | 357 | module Bits = BatBitSet 358 | 359 | let all_possible_selections (n: int) : Bits.t list = 360 | let rec go ss i = 361 | if i = n 362 | then ss 363 | else let ss_without_i = List.map Bits.copy ss in 364 | List.iter (fun s -> Bits.set s i) ss; (* ss_with_i = ss *) 365 | go (ss_without_i @ ss) (i+1) 366 | in 367 | go [Bits.create n] 0 (* |> List.filter (fun s -> Bits.count s > 0) *) 368 | 369 | let array_select (x: nf_elt array) (n: int) (sel: Bits.t) : nf_elt PSet.t = 370 | let rec go i acc = 371 | if i = n 372 | then acc 373 | else 374 | let clause = 375 | if Bits.mem sel i 376 | then x.(i) 377 | else let (a,_p) = x.(i) in 378 | (K.not a, K.pred (K.zero ())) 379 | in 380 | (* no pruning here---if a=0, leave it in and we'll clear it up in the locally_unambiguous form *) 381 | go (i+1) (PSet.add clause acc) 382 | in 383 | go 0 (empty ()) 384 | 385 | let locally_unambiguous_form (x: nf) : lunf = 386 | let summands = PSet.to_array x in 387 | let n = Array.length summands in 388 | Log.debug (fun m -> m "translating %d summands in locally unambiguous form for %s" n (show_nf x)); 389 | let sels = all_possible_selections n |> List.map (array_select summands n) in 390 | Log.debug (fun m -> m "got %d disjunctions" (List.length sels)); 391 | List.fold_right (fun (disj: nf) (xhat: nf) -> 392 | let (preds, acts) = List.split (PSet.to_list disj) in 393 | Log.debug (fun m -> m "disjunction: %s" (show_nf disj)); 394 | let a = List.fold_right K.pseq preds (K.one ()) in 395 | (* if a is contradictory (i.e., 0 or unsat) we must drop it here *) 396 | if a.node = Zero || not (T.satisfiable a) 397 | then xhat 398 | else 399 | let p = List.fold_right K.par acts (K.pred (K.zero ())) in 400 | let clause = (a, p) in 401 | (* match p.node with 402 | | Pred pa when pa.node = Zero -> xhat 403 | | _ -> *) PSet.add clause xhat) 404 | sels (empty ()) 405 | 406 | (* deciding equivalence of restricted actions *) 407 | 408 | (* PLAN: given two words of restricted actions, we need to test regex equality 409 | 410 | 1. compute alphabets (if different, no way they're equal) 411 | 2. intern each action as a pair of unique id and numeric entry in the alphabet 412 | 3. generate the automata on the fly, using derivatives 413 | 4. run the Hopcroft/Karp union-find algorithm to check equivalence 414 | 415 | *) 416 | 417 | type ra = K.Term.t 418 | type pi = (int * K.P.t) 419 | 420 | type alphabet = pi PSet.t 421 | let empty_alphabet () : alphabet = 422 | PSet.create 423 | (fun (i1,pi1) (i2,pi2) -> 424 | if i1 = i2 425 | then K.P.compare pi1 pi2 426 | else Stdlib.compare i1 i2) 427 | 428 | let alphabet_of (m: ra) : alphabet = 429 | let rec loop (m: ra) (sigma: alphabet) : alphabet = 430 | match m.node with 431 | | Action (i, pi) -> PSet.add (i, pi) sigma 432 | | Pred _ -> sigma 433 | | Par (n, o) -> loop n (loop o sigma) 434 | | Seq (n, o) -> loop n (loop o sigma) 435 | | Star n -> loop n sigma 436 | in 437 | loop m (empty_alphabet ()) 438 | 439 | let word_of (m: ra) (sigma: alphabet) : word = 440 | let tbl = PSet.to_array sigma in 441 | let lookup (pi: pi) : int = 442 | let rec loop (i: int) : int = 443 | if i = Array.length tbl 444 | then raise Not_found 445 | else if tbl.(i) = pi 446 | then i 447 | else loop (i + 1) 448 | in 449 | loop 0 450 | in 451 | let rec word_of (m: ra) : word = 452 | match m.node with 453 | | Action (i, p) -> ltr (lookup (i, p)) 454 | | Pred a -> 455 | begin match a.node with 456 | | Zero -> emp 457 | | One -> eps 458 | | _ -> failwith ("Unexpected predicate in word: " ^ K.Test.show a) 459 | end 460 | | Par (n, o) -> alt (word_of n) (word_of o) 461 | | Seq (n, o) -> cat (word_of n) (word_of o) 462 | | Star n -> str (word_of n) 463 | in 464 | word_of m 465 | 466 | let same_actions (m: K.Term.t) (n: K.Term.t) : bool = 467 | let sigma_m = alphabet_of m in 468 | let sigma_n = alphabet_of n in 469 | if PSet.equal sigma_m sigma_n 470 | then begin 471 | let sigma = sigma_m in 472 | let r = word_of m sigma in 473 | let s = word_of n sigma in 474 | Log.debug (fun f -> f "%s ~w~> %s" (K.Term.show m) (Word.show r)); 475 | Log.debug (fun m -> m "%s ~w~> %s" (K.Term.show n) (Word.show s)); 476 | if r.tag = s.tag 477 | then begin 478 | Log.debug (fun m -> m "same_tag = true (same tag)"); 479 | true 480 | end 481 | else begin 482 | let same_words = equivalent_words r s (PSet.cardinal sigma) in 483 | Log.debug (fun m -> m "same_words = %b" same_words); 484 | same_words 485 | end 486 | end 487 | else begin 488 | Log.debug (fun m -> m "different alphabets, can't be equal"); 489 | false 490 | end 491 | 492 | 493 | (* ACTUAL EQUIVALENCE ROUTINE STARTS HERE *) 494 | 495 | let equivalent_lunf (xhat: lunf) (yhat: lunf) : bool = 496 | if PSet.equal xhat yhat 497 | then 498 | begin 499 | Log.debug (fun m -> m "syntactic equality on locally unambiguous forms"); 500 | true 501 | end 502 | else if PSet.is_empty xhat || PSet.is_empty yhat (* handle emptiness! *) 503 | then 504 | begin 505 | Log.debug (fun m -> m "empty NF, checking for emptiness of both"); 506 | PSet.is_empty xhat && PSet.is_empty yhat 507 | end 508 | else 509 | PSet.fold 510 | (fun (a1, m1) acc -> 511 | PSet.fold (fun (a2, m2) acc2 -> 512 | let adots = K.pseq a1 a2 in 513 | Log.debug (fun m -> m "checking adots=%s (from %s and %s)...%!" (K.Test.show adots) (K.Test.show a1) (K.Test.show a2)); 514 | (* if the conjunction is 0 or unsat, we drop it *) 515 | if adots.node = Zero || not (T.satisfiable adots) 516 | then 517 | begin 518 | Log.debug (fun m -> m "skipping unsatisfiable case"); 519 | acc2 520 | end 521 | else 522 | begin 523 | acc2 && same_actions m1 m2 524 | end) yhat acc) 525 | xhat true 526 | 527 | let equivalent_nf (nx: nf) (ny: nf) : bool = 528 | (* optimization: just if syntactically equal first *) 529 | if PSet.equal nx ny 530 | then 531 | begin 532 | Log.debug (fun m -> m "syntactic equality on %s" (show_nf nx)); 533 | true 534 | end 535 | else begin 536 | Log.debug (fun m -> m 537 | "running cross product on %s and %s" 538 | (show_nf nx) (show_nf ny)); 539 | let xhat = locally_unambiguous_form nx in 540 | Log.debug (fun m -> m "%s is locally unambiguous as %s" (show_nf nx) (show_nf xhat)); 541 | let yhat = locally_unambiguous_form ny in 542 | Log.debug (fun m -> m "%s is locally unambiguous as %s" (show_nf ny) (show_nf yhat)); 543 | equivalent_lunf xhat yhat 544 | end 545 | 546 | let equivalent (p: K.Term.t) (q: K.Term.t) : bool = 547 | let nx = normalize_term 0 p in 548 | let ny = normalize_term 0 q in 549 | equivalent_nf nx ny 550 | 551 | end 552 | -------------------------------------------------------------------------------- /src/driver.ml: -------------------------------------------------------------------------------- 1 | open Kat 2 | open Decide 3 | open Common 4 | 5 | let is_flag (s: string) : bool = 6 | String.length s > 2 && String.get s 0 = '-' && String.get s 1 = '-' 7 | 8 | let driver_log_src = Logs.Src.create "kmt.driver" 9 | ~doc:"logs KMT equivalence class driver" 10 | module Log = (val Logs.src_log driver_log_src : Logs.LOG) 11 | 12 | module Driver(T : THEORY) = struct 13 | module K = T.K 14 | module D = Decide(T) 15 | 16 | let parse_and_show (s: string) : K.Term.t = 17 | let p = K.parse s in 18 | 19 | Log.app (fun m -> m "[%s parsed as %s]" s (K.Term.show p)); 20 | p 21 | 22 | let parse_normalize_and_show (s: string) : string * D.lunf = 23 | let p = parse_and_show s in 24 | 25 | (* normalization and lunf *) 26 | let (x, nf_time) = time (D.normalize_term 0) p in 27 | Log.info (fun m -> m "nf = %s" (D.show_nf x)); 28 | Log.app (fun m -> m "nf time: %fs" nf_time); 29 | 30 | let (xhat, lunf_time) = time D.locally_unambiguous_form x in 31 | Log.info (fun m -> m "lunf = %s" (D.show_nf xhat)); 32 | Log.app (fun m -> m "lunf time: %fs" lunf_time); 33 | flush stdout; 34 | (s, xhat) 35 | 36 | let show_equivalence_classes (eq_dec: 'a -> 'a -> bool) (show: 'a -> string) (ps: 'a list) = 37 | let eqs = equivalence_classes eq_dec ps in 38 | let num_eqs = List.length eqs in 39 | 40 | (* header *) 41 | Log.app (fun m -> 42 | m "[%d equivalence class%s]" num_eqs (if num_eqs > 1 then "es" else "")); 43 | 44 | (* classes *) 45 | eqs |> List.iteri 46 | (fun i cls -> 47 | Log.app (fun m -> 48 | m "%d: { %s }" (i+1) 49 | (List.fold_left 50 | (fun acc x -> show x ^ Common.add_sep ", " acc) "" cls))) 51 | 52 | let run ss = 53 | let go parse eq_dec show ss = 54 | let xs = List.map parse ss in 55 | if List.length xs > 1 56 | then show_equivalence_classes eq_dec show xs 57 | in 58 | go parse_normalize_and_show (fun x y -> D.equivalent_lunf (snd x) (snd y)) (fun x -> fst x) ss 59 | 60 | end 61 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name kmt) 3 | (public_name kmt) 4 | (modules kmt) 5 | (libraries z3 kmt fmt fmt.cli fmt.tty logs logs.fmt logs.cli cmdliner) 6 | (preprocess (pps ppx_deriving.show ppx_deriving.eq ppx_deriving.ord)) 7 | (flags -thread (-cclib -lstdc++))) 8 | 9 | (executable 10 | (name kmt_eval) 11 | (public_name kmt_eval) 12 | (modules kmt_eval) 13 | (libraries z3 kmt ANSITerminal fmt fmt.cli fmt.tty logs logs.fmt logs.cli cmdliner) 14 | (preprocess (pps ppx_deriving.show ppx_deriving.eq ppx_deriving.ord)) 15 | (flags -thread (-cclib -lstdc++))) 16 | 17 | (test 18 | (name test_equivalence) 19 | (modules test_equivalence) 20 | (libraries z3 kmt alcotest) 21 | (preprocess (pps ppx_deriving.show ppx_deriving.eq ppx_deriving.ord)) 22 | (flags -thread (-cclib -lstdc++))) 23 | 24 | (test 25 | (name test_word) 26 | (modules test_word) 27 | (libraries kmt alcotest) 28 | (preprocess (pps ppx_deriving.show ppx_deriving.eq ppx_deriving.ord)) 29 | (flags -thread (-cclib -lstdc++))) 30 | 31 | (library 32 | (name kmt) 33 | (wrapped false) 34 | (modules (:standard \ kmt test_equivalence test_word kmt_eval)) 35 | (preprocess (pps ppx_deriving.show ppx_deriving.eq ppx_deriving.ord)) 36 | (libraries batteries str unix ANSITerminal fmt fmt.cli fmt.tty 37 | alcotest logs logs.fmt logs.cli cmdliner z3)) 38 | 39 | (ocamllex lexer) 40 | (ocamlyacc parser) 41 | 42 | (env 43 | (dev 44 | (flags (:standard -warn-error +A-9-32)))) 45 | -------------------------------------------------------------------------------- /src/hashcons.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Copyright (C) Jean-Christophe Filliatre *) 4 | (* *) 5 | (* This software is free software; you can redistribute it and/or *) 6 | (* modify it under the terms of the GNU Library General Public *) 7 | (* License version 2.1, with the special exception on linking *) 8 | (* described in file LICENSE. *) 9 | (* *) 10 | (* This software is distributed in the hope that it will be useful, *) 11 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 12 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | (*s Hash tables for hash-consing. (Some code is borrowed from the ocaml 16 | standard library, which is copyright 1996 INRIA.) *) 17 | 18 | type +'a hash_consed = {hkey: int; tag: int; node: 'a} 19 | 20 | let gentag = 21 | let r = ref 0 in 22 | fun () -> incr r ; !r 23 | 24 | 25 | type 'a t = 26 | { mutable table: 'a hash_consed Weak.t array 27 | ; mutable totsize: int 28 | ; (* sum of the bucket sizes *) 29 | mutable limit: int 30 | (* max ratio totsize/table length *) } 31 | 32 | let create sz = 33 | let sz = if sz < 7 then 7 else sz in 34 | let sz = if sz > Sys.max_array_length then Sys.max_array_length else sz in 35 | let emptybucket = Weak.create 0 in 36 | {table= Array.make sz emptybucket; totsize= 0; limit= 3} 37 | 38 | 39 | let clear t = 40 | let emptybucket = Weak.create 0 in 41 | for i = 0 to Array.length t.table - 1 do t.table.(i) <- emptybucket done ; 42 | t.totsize <- 0 ; 43 | t.limit <- 3 44 | 45 | 46 | let fold f t init = 47 | let rec fold_bucket i b accu = 48 | if i >= Weak.length b then accu 49 | else 50 | match Weak.get b i with 51 | | Some v -> fold_bucket (i + 1) b (f v accu) 52 | | None -> fold_bucket (i + 1) b accu 53 | in 54 | Array.fold_right (fold_bucket 0) t.table init 55 | 56 | 57 | let iter f t = 58 | let rec iter_bucket i b = 59 | if i >= Weak.length b then () 60 | else 61 | match Weak.get b i with 62 | | Some v -> 63 | f v ; 64 | iter_bucket (i + 1) b 65 | | None -> iter_bucket (i + 1) b 66 | in 67 | Array.iter (iter_bucket 0) t.table 68 | 69 | 70 | let count t = 71 | let rec count_bucket i b accu = 72 | if i >= Weak.length b then accu 73 | else count_bucket (i + 1) b (accu + if Weak.check b i then 1 else 0) 74 | in 75 | Array.fold_right (count_bucket 0) t.table 0 76 | 77 | 78 | let next_sz n = min (3 * n / 2 + 3) (Sys.max_array_length - 1) 79 | 80 | let rec resize t = 81 | let oldlen = Array.length t.table in 82 | let newlen = next_sz oldlen in 83 | if newlen > oldlen then ( 84 | let newt = create newlen in 85 | newt.limit <- t.limit + 100 ; 86 | (* prevent resizing of newt *) 87 | fold (fun d () -> add newt d) t () ; 88 | t.table <- newt.table ; 89 | t.limit <- t.limit + 2 ) 90 | 91 | 92 | and add t d = 93 | let index = d.hkey mod Array.length t.table in 94 | let bucket = (t.table).(index) in 95 | let sz = Weak.length bucket in 96 | let rec loop i = 97 | if i >= sz then ( 98 | let newsz = min (sz + 3) (Sys.max_array_length - 1) in 99 | if newsz <= sz then 100 | failwith "Hashcons.Make: hash bucket cannot grow more" ; 101 | let newbucket = Weak.create newsz in 102 | Weak.blit bucket 0 newbucket 0 sz ; 103 | Weak.set newbucket i (Some d) ; 104 | t.table.(index) <- newbucket ; 105 | t.totsize <- t.totsize + (newsz - sz) ; 106 | if t.totsize > t.limit * Array.length t.table then resize t ) 107 | else if Weak.check bucket i then loop (i + 1) 108 | else Weak.set bucket i (Some d) 109 | in 110 | loop 0 111 | 112 | 113 | let hashcons hash equal t d = 114 | let hkey = hash d land max_int in 115 | let index = hkey mod Array.length t.table in 116 | let bucket = (t.table).(index) in 117 | let sz = Weak.length bucket in 118 | let rec loop i = 119 | if i >= sz then ( 120 | let hnode = {hkey; tag= gentag (); node= d} in 121 | add t hnode ; hnode ) 122 | else 123 | match Weak.get_copy bucket i with 124 | | Some v when equal v.node d -> ( 125 | match Weak.get bucket i with Some v -> v | None -> loop (i + 1) ) 126 | | _ -> loop (i + 1) 127 | in 128 | loop 0 129 | 130 | 131 | let stats t = 132 | let len = Array.length t.table in 133 | let lens = Array.map Weak.length t.table in 134 | Array.sort compare lens ; 135 | let totlen = Array.fold_left ( + ) 0 lens in 136 | (len, count t, totlen, lens.(0), lens.(len / 2), lens.(len - 1)) 137 | 138 | 139 | let int i = {node= i; hkey= i; tag= i} 140 | -------------------------------------------------------------------------------- /src/hashcons.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Copyright (C) Jean-Christophe Filliatre *) 4 | (* *) 5 | (* This software is free software; you can redistribute it and/or *) 6 | (* modify it under the terms of the GNU Library General Public *) 7 | (* License version 2.1, with the special exception on linking *) 8 | (* described in file LICENSE. *) 9 | (* *) 10 | (* This software is distributed in the hope that it will be useful, *) 11 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 12 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (*s Hash tables for hash consing. 17 | 18 | The technique is described in this paper: 19 | Sylvain Conchon and Jean-Christophe Filliâtre. 20 | Type-Safe Modular Hash-Consing. 21 | In ACM SIGPLAN Workshop on ML, Portland, Oregon, September 2006. 22 | https://www.lri.fr/~filliatr/ftp/publis/hash-consing2.pdf 23 | 24 | Note: a different, more elaborated hash-consing library 25 | can be found in Why3 sources at http://why3.lri.fr/ 26 | 27 | Hash consed values are of the 28 | following type [hash_consed]. The field [tag] contains a unique 29 | integer (for values hash consed with the same table). The field 30 | [hkey] contains the hash key of the value (without modulo) for 31 | possible use in other hash tables (and internally when hash 32 | consing tables are resized). The field [node] contains the value 33 | itself. 34 | 35 | Hash consing tables are using weak pointers, so that values that are no 36 | more referenced from anywhere else can be erased by the GC. 37 | 38 | slightly modified to help with polymorphism: hashcons takes the 39 | hashing and equality function as parameters, and we removed the 40 | module based interface 41 | 42 | *) 43 | 44 | type +'a hash_consed = private { 45 | hkey : int; 46 | tag : int; 47 | node : 'a } 48 | 49 | (*s Generic part, using ocaml generic equality and hash function. *) 50 | 51 | type 'a t 52 | 53 | val create : int -> 'a t 54 | (** [create n] creates an empty table of initial size [n]. The table 55 | will grow as needed. *) 56 | 57 | val clear : 'a t -> unit 58 | (** Removes all elements from the table. *) 59 | 60 | val hashcons : ('a -> int) -> ('a -> 'a -> bool) -> 'a t -> 'a -> 'a hash_consed 61 | (** [hashcons t n] hash-cons the value [n] using table [t] i.e. returns 62 | any existing value in [t] equal to [n], if any; otherwise, allocates 63 | a new one hash-consed value of node [n] and returns it. 64 | As a consequence the returned value is physically equal to 65 | any equal value already hash-consed using table [t]. *) 66 | 67 | val iter : ('a hash_consed -> unit) -> 'a t -> unit 68 | (** [iter f t] iterates [f] over all elements of [t]. *) 69 | 70 | val stats : 'a t -> int * int * int * int * int * int 71 | (** Return statistics on the table. The numbers are, in order: 72 | table length, number of entries, sum of bucket lengths, 73 | smallest bucket length, median bucket length, biggest bucket length. *) 74 | 75 | val int: int -> int hash_consed 76 | (** `hashed' int *) 77 | -------------------------------------------------------------------------------- /src/incnat.ml: -------------------------------------------------------------------------------- 1 | open Kat 2 | open Syntax 3 | open Common 4 | open Hashcons 5 | 6 | type a = Gt of string * int [@@deriving eq] 7 | 8 | type p = Increment of string | Assign of string * int [@@deriving eq] 9 | 10 | let compare_a (Gt (x,n)) (Gt (y,m)) = 11 | let cmp = StrType.compare x y in 12 | if cmp <> 0 then cmp 13 | else n - m 14 | 15 | let compare_p p q = 16 | match (p, q) with 17 | | Increment x, Increment y -> StrType.compare x y 18 | | Assign (x,i), Assign (y,j) -> 19 | let cmp = StrType.compare x y in 20 | if cmp <> 0 then cmp 21 | else i - j 22 | | Increment _, Assign _ -> -1 23 | | Assign _, Increment _ -> 1 24 | 25 | 26 | module rec IncNat : THEORY with type A.t = a and type P.t = p = struct 27 | module K = KAT (IncNat) 28 | module Test = K.Test 29 | module Term = K.Term 30 | 31 | module P : CollectionType with type t = p = struct 32 | type t = p 33 | let compare = compare_p 34 | let hash = Hashtbl.hash 35 | let equal = equal_p 36 | let show = function 37 | | Increment x -> "inc (" ^ x ^ ")" 38 | | Assign (x,i) -> "set (" ^ x ^ "," ^ string_of_int i ^ ")" 39 | end 40 | 41 | module A : CollectionType with type t = a = struct 42 | type t = a 43 | let compare = compare_a 44 | let hash = Hashtbl.hash 45 | let equal = equal_a 46 | let show = function 47 | | Gt (x, n) -> x ^ ">" ^ string_of_int n 48 | end 49 | 50 | let name () = "incnat" 51 | module Log = (val logger (name ()) : Logs.LOG) 52 | 53 | let variable = function 54 | | Increment x -> x 55 | | Assign (x,_) -> x 56 | 57 | let variable_test (Gt (x,_)) = x 58 | 59 | let parse name es = 60 | match (name, es) with 61 | | "inc", [(EId s1)] -> Right (Increment s1) 62 | | "set", [(EId s1);EId s2] -> Right (Assign (s1, int_of_string s2)) 63 | | ">", [(EId s1); (EId s2)] -> Left (Gt (s1, int_of_string s2)) 64 | | _, _ -> 65 | failwith ("Cannot create theory object from (" ^ name ^ ") and parameters") 66 | 67 | open BatSet 68 | 69 | let push_back p a = 70 | match (p,a) with 71 | | (Increment _x, Gt (_, j)) when 1 > j -> PSet.singleton ~cmp:K.Test.compare (K.one ()) 72 | | (Increment x, Gt (y, j)) when x = y -> 73 | PSet.singleton ~cmp:K.Test.compare (K.theory (Gt (y, j - 1))) 74 | | (Assign (x,i), Gt (y,j)) when x = y -> PSet.singleton ~cmp:K.Test.compare (if i > j then K.one () else K.zero ()) 75 | | _ -> PSet.singleton ~cmp:K.Test.compare (K.theory a) 76 | 77 | 78 | let simplify_and a b = 79 | match (a, b) with 80 | | Gt (x, v1), Gt (y, v2) when x = y -> Some (K.theory (Gt (x, max v1 v2))) 81 | | _, _ -> None 82 | 83 | let simplify_not _a = None 84 | 85 | let simplify_or _a _b = None 86 | 87 | let merge (_p1: P.t) (p2: P.t) : P.t = p2 88 | 89 | let reduce _a p = Some p 90 | 91 | let create_z3_var (str,_a) (ctx : Z3.context) (solver : Z3.Solver.solver) : Z3.Expr.expr = 92 | let sym = Z3.Symbol.mk_string ctx str in 93 | let int_sort = Z3.Arithmetic.Integer.mk_sort ctx in 94 | let xc = Z3.Expr.mk_const ctx sym int_sort in 95 | let is_nat = 96 | Z3.Arithmetic.mk_ge ctx xc (Z3.Arithmetic.Integer.mk_numeral_i ctx 0) 97 | in 98 | Z3.Solver.add solver [is_nat]; 99 | xc 100 | 101 | let theory_to_z3_expr (a : A.t) (ctx : Z3.context) (map : Z3.Expr.expr StrMap.t) : Z3.Expr.expr = 102 | match a with 103 | | Gt (x, v) -> 104 | let var = StrMap.find x map in 105 | let value = Z3.Arithmetic.Integer.mk_numeral_i ctx v in 106 | Z3.Arithmetic.mk_gt ctx var value 107 | 108 | module H = Hashtbl.Make (K.Test) 109 | 110 | let tbl = H.create 2048 111 | 112 | let rec can_use_fast_solver (a: K.Test.t) = 113 | match a.node with 114 | | One | Zero | Placeholder _ | Theory _ -> true 115 | | PPar _ -> false 116 | | PSeq (b, c) -> can_use_fast_solver b && can_use_fast_solver c 117 | | Not {node= Theory _; _} -> true 118 | | Not _ -> false 119 | 120 | let satisfiable (a: K.Test.t) = 121 | try H.find tbl a with _ -> 122 | if not (can_use_fast_solver a) 123 | then 124 | begin 125 | Log.debug (fun m -> m "%s taking SLOW path" (K.Test.show a)); 126 | let ret = K.z3_satisfiable a in 127 | H.add tbl a ret ; ret 128 | end 129 | else begin 130 | Log.debug (fun m -> m "%s taking FAST path" (K.Test.show a)) ; 131 | let mergeOp map1 map2 op = 132 | StrMap.merge 133 | (fun _ v1 v2 -> 134 | match (v1, v2) with 135 | | None, _ -> v2 136 | | _, None -> v1 137 | | Some x, Some y -> Some (op x y) ) 138 | map1 map2 139 | in 140 | let rec aux (a: K.Test.t) : Range.t StrMap.t = 141 | match a.node with 142 | | One | Zero | Placeholder _ -> failwith "IncNat: satisfiability" 143 | | Not b -> StrMap.map Range.negate (aux b) 144 | | PPar (b, c) -> mergeOp (aux b) (aux c) Range.union 145 | | PSeq (b, c) -> mergeOp (aux b) (aux c) Range.inter 146 | | Theory Gt (x, v) -> 147 | StrMap.singleton x (Range.from_range (v + 1, max_int)) 148 | in 149 | match a.node with 150 | | One -> true 151 | | Zero -> false 152 | | _ -> 153 | let result = aux a in 154 | let ret = 155 | StrMap.for_all (fun _ r -> not (Range.is_false r)) result 156 | in 157 | (* Printf.printf "Actual Result: %b\n" ret; *) 158 | H.add tbl a ret ; ret 159 | end 160 | end 161 | -------------------------------------------------------------------------------- /src/input.ml: -------------------------------------------------------------------------------- 1 | let read lexbuf = 2 | let get_info () = 3 | let curr = lexbuf.Lexing.lex_curr_p in 4 | let line = curr.Lexing.pos_lnum in 5 | let cnum = curr.Lexing.pos_cnum - curr.Lexing.pos_bol in 6 | let tok = Lexing.lexeme lexbuf in 7 | (tok, line, cnum) 8 | in 9 | try Parser.expr Lexer.token lexbuf with 10 | | Parsing.Parse_error -> 11 | let tok, line, cnum = get_info () in 12 | Printf.printf "[Parse Error] token: %s, line: %s, char: %s\n" tok 13 | (string_of_int line) (string_of_int cnum) ; 14 | exit 0 15 | | Failure x -> 16 | Printf.printf "[Parse Error] %s\n" x ; 17 | exit 0 18 | | End_of_file -> 19 | Printf.printf "[Parse Error] end of file in comment\n" ; 20 | exit 0 21 | 22 | 23 | let read_from_in cin = 24 | let res = read (Lexing.from_channel cin) in 25 | close_in cin ; res 26 | 27 | 28 | let read_from_str str = Lexing.from_string str |> read 29 | 30 | let read_from_file fname = 31 | let cin = open_in fname in 32 | let res = read (Lexing.from_channel cin) in 33 | close_in cin ; res 34 | -------------------------------------------------------------------------------- /src/input.mli: -------------------------------------------------------------------------------- 1 | val read_from_in: in_channel -> Syntax.expr 2 | (** Read a term from an input stream *) 3 | 4 | val read_from_str: string -> Syntax.expr 5 | (** Read a term from a string *) 6 | 7 | val read_from_file: string -> Syntax.expr 8 | (** Read a term from a file *) -------------------------------------------------------------------------------- /src/kat.ml: -------------------------------------------------------------------------------- 1 | open Syntax 2 | open Common 3 | open Hashcons 4 | 5 | let merge = false 6 | 7 | type 'a pred = 'a pred_hons hash_consed 8 | 9 | and 'a pred_hons = 10 | | Placeholder of int 11 | | Theory of 'a 12 | | Zero 13 | | One 14 | | Not of 'a pred 15 | | PPar of 'a pred * 'a pred 16 | | PSeq of 'a pred * 'a pred 17 | 18 | type ('a, 'p) kat = ('a, 'p) kat_hons hash_consed 19 | 20 | and ('a, 'p) kat_hons = 21 | | Action of int * 'p 22 | | Pred of 'a pred 23 | | Par of ('a, 'p) kat * ('a, 'p) kat 24 | | Seq of ('a, 'p) kat * ('a, 'p) kat 25 | | Star of ('a, 'p) kat 26 | 27 | let logger (name: string) = 28 | let src = Logs.Src.create ("kmt." ^ name) ~doc:("logs " ^ name ^ " theory operations") in 29 | Logs.src_log src 30 | 31 | module type KAT_IMPL = sig 32 | module A : CollectionType 33 | module P : CollectionType 34 | module Test : CollectionType with type t = A.t pred 35 | module Term : CollectionType with type t = (A.t, P.t) kat 36 | 37 | (* Theory functions *) 38 | val push_back : P.t -> A.t -> Test.t BatSet.PSet.t 39 | val push_back_test : P.t -> Test.t -> Test.t BatSet.PSet.t 40 | val satisfiable : Test.t -> bool 41 | val z3_satisfiable : Test.t -> bool 42 | val implies : Test.t -> Test.t -> bool 43 | 44 | (* Smart constructors *) 45 | val placeholder : int -> Test.t 46 | val theory : A.t -> Test.t 47 | val zero : unit -> Test.t 48 | val one : unit -> Test.t 49 | val not : Test.t -> Test.t 50 | val ppar : Test.t -> Test.t -> Test.t 51 | val pseq : Test.t -> Test.t -> Test.t 52 | val action : P.t -> Term.t 53 | val action_i : int -> P.t -> Term.t 54 | val pred : Test.t -> Term.t 55 | val par : Term.t -> Term.t -> Term.t 56 | val seq : Term.t -> Term.t -> Term.t 57 | val star : Term.t -> Term.t 58 | 59 | (* TODO MMG 2020-02-28 predicates for zero/one testing *) 60 | 61 | (* Utility functions *) 62 | val test_of_expr : Syntax.expr -> Test.t 63 | val term_of_expr : Syntax.expr -> Term.t 64 | val parse : string -> Term.t 65 | end 66 | 67 | module type THEORY = sig 68 | module A : CollectionType 69 | module P : CollectionType 70 | module Test : CollectionType with type t = A.t pred 71 | module Term : CollectionType with type t = (A.t, P.t) kat 72 | 73 | module K : 74 | KAT_IMPL 75 | with module A = A 76 | and module P = P 77 | and module Test = Test 78 | and module Term = Term 79 | 80 | val name : unit -> string 81 | 82 | val parse : string -> expr list -> (A.t, P.t) either 83 | val push_back : P.t -> A.t -> Test.t BatSet.PSet.t 84 | val simplify_not : A.t -> Test.t option 85 | val simplify_and : A.t -> A.t -> Test.t option 86 | val simplify_or : A.t -> A.t -> Test.t option 87 | val merge : P.t -> P.t -> P.t 88 | val reduce : A.t -> P.t -> P.t option 89 | val variable : P.t -> string 90 | val variable_test : A.t -> string 91 | val satisfiable : Test.t -> bool 92 | val create_z3_var: string * A.t -> Z3.context -> Z3.Solver.solver -> Z3.Expr.expr 93 | val theory_to_z3_expr: A.t -> Z3.context -> Z3.Expr.expr StrMap.t -> Z3.Expr.expr 94 | end 95 | 96 | module KAT (T : THEORY) : KAT_IMPL with module A = T.A and module P = T.P = struct 97 | type test = T.A.t pred 98 | type term = (T.A.t, T.P.t) kat 99 | 100 | module A = T.A 101 | module P = T.P 102 | 103 | let rec show_test_sum a = 104 | match a.node with 105 | | PPar (a1, a2) -> show_test_sum a1 ^ " + " ^ show_test_sum a2 106 | | _ -> show_test_prod a 107 | 108 | and show_test_prod a = 109 | match a.node with 110 | | PSeq (a1, a2) -> show_test_prod a1 ^ ";" ^ show_test_prod a2 111 | | _ -> show_test_neg a 112 | 113 | and show_test_neg a = 114 | match a.node with 115 | | Not a -> "not " ^ show_test_atom a 116 | | _ -> show_test_atom a 117 | 118 | and show_test_atom a = 119 | match a.node with 120 | | Placeholder i -> "placeholder(" ^ string_of_int i ^ ")" 121 | | Theory t -> T.A.show t 122 | | Zero -> "false" 123 | | One -> "true" 124 | | _ -> "(" ^ show_test_sum a ^ ")" 125 | 126 | let rec show_term_sum (p:term) = 127 | match p.node with 128 | | Par (p1, p2) -> show_term_sum p1 ^ " + " ^ show_term_sum p2 129 | | Pred a -> show_test_sum a 130 | | _ -> show_term_prod p 131 | 132 | and show_term_prod p = 133 | match p.node with 134 | | Seq (p1, p2) -> show_term_prod p1 ^ ";" ^ show_term_prod p2 135 | | Pred a -> show_test_prod a 136 | | _ -> show_term_star p 137 | 138 | and show_term_star p = 139 | match p.node with 140 | | Star p1 -> show_term_atom p1 ^ "*" 141 | | _ -> show_term_atom p 142 | 143 | and show_term_atom p = 144 | match p.node with 145 | | Action (i, p) -> T.P.show p ^ "[" ^ string_of_int i ^ "]" 146 | | Pred a -> "(" ^ show_test_atom a ^ ")" 147 | | _ -> "(" ^ show_term_sum p ^ ")" 148 | 149 | let show_test = show_test_sum 150 | 151 | let show_term = show_term_sum 152 | 153 | let equal_pred x y = 154 | match (x, y) with 155 | | Theory a, Theory b -> T.A.equal a b 156 | | Zero, Zero -> true 157 | | One, One -> true 158 | | Not a, Not b -> a.tag = b.tag 159 | | PPar (a, b), PPar (c, d) | PSeq (a, b), PSeq (c, d) -> 160 | a.tag = c.tag && b.tag = d.tag 161 | | _, _ -> false 162 | 163 | 164 | let hash_pred x = 165 | let ret = 166 | match x with 167 | | Placeholder i -> i 168 | | Theory a -> 2 + T.A.hash a 169 | | Zero -> 3 170 | | One -> 5 171 | | Not a -> 7 * a.hkey + 11 172 | | PPar (a, b) -> 13 * (b.hkey + (17 * a.hkey + 7)) 173 | | PSeq (a, b) -> 23 * (b.hkey + (31 * a.hkey + 11)) 174 | in 175 | ret 176 | 177 | 178 | module Test : CollectionType with type t = T.A.t pred = struct 179 | type t = T.A.t pred 180 | let equal x y = x.tag = y.tag 181 | let compare x y = x.tag - y.tag 182 | let hash x = x.hkey 183 | let show = show_test 184 | end 185 | 186 | let equal_kat x y = 187 | match (x, y) with 188 | | Action (_, a), Action (_, b) -> T.P.equal a b 189 | | Pred a, Pred b -> a.tag = b.tag 190 | | Par (a, b), Par (c, d) | Seq (a, b), Seq (c, d) -> 191 | a.tag = c.tag && b.tag = d.tag 192 | | Star a, Star b -> a.tag = b.tag 193 | | _, _ -> false 194 | 195 | 196 | let hash_kat x = 197 | match x with 198 | | Action (i, a) -> 2 + 31 * i + T.P.hash a 199 | | Pred a -> 3 + Test.hash a 200 | | Par (a, b) -> 31 * (b.hkey + (31 * a.hkey + 5)) 201 | | Seq (a, b) -> 31 * (b.hkey + (31 * a.hkey + 7)) 202 | | Star a -> 31 * a.hkey + 11 203 | 204 | 205 | module Term : CollectionType with type t = (T.A.t, T.P.t) kat = struct 206 | type t = (T.A.t, T.P.t) kat 207 | let equal x y = x.tag = y.tag 208 | let compare x y = x.tag - y.tag 209 | let hash x = x.hkey 210 | let show = show_term 211 | end 212 | 213 | let tbl_pred = Hashcons.create 8 214 | 215 | let tbl_kat = Hashcons.create 8 216 | 217 | let hashcons_pred = Hashcons.hashcons hash_pred equal_pred tbl_pred 218 | 219 | let hashcons_kat = Hashcons.hashcons hash_kat equal_kat tbl_kat 220 | 221 | let theory x = hashcons_pred (Theory x) 222 | 223 | let zero () = hashcons_pred Zero 224 | 225 | let one () = hashcons_pred One 226 | 227 | let placeholder i = hashcons_pred (Placeholder i) 228 | 229 | let not x = 230 | match x.node with 231 | | Not y -> y 232 | | One -> zero () 233 | | Zero -> one () 234 | | Theory a -> ( 235 | match T.simplify_not a with None -> hashcons_pred (Not x) | Some t -> t ) 236 | | _ -> hashcons_pred (Not x) 237 | 238 | 239 | let ppar x y = 240 | match (x.node, y.node) with 241 | | _, Zero -> x 242 | | Zero, _ -> y 243 | | One, _ -> x 244 | | _, One -> y 245 | | Theory a, Theory b -> ( 246 | match T.simplify_or a b with 247 | | None -> hashcons_pred (PPar (x, y)) 248 | | Some t -> t ) 249 | | _, _ -> hashcons_pred (PPar (x, y)) 250 | 251 | 252 | let c_ord x y = 253 | match (x.node, y.node) with 254 | | Theory a, Theory b -> T.A.compare a b 255 | | _, _ -> x.tag - y.tag 256 | 257 | 258 | let rec pseq x y = 259 | if x.tag = y.tag then x 260 | else 261 | match (x.node, y.node) with 262 | | _, Zero -> y 263 | | Zero, _ -> x 264 | | _, One -> x 265 | | One, _ -> y 266 | (* simplify theory expressions if possible *) 267 | | Theory a, Theory b -> ( 268 | match T.simplify_and a b with 269 | | None -> 270 | if Test.compare x y < 0 then hashcons_pred (PSeq (x, y)) 271 | else hashcons_pred (PSeq (y, x)) 272 | | Some t -> t ) 273 | | Theory a, PSeq (({node= Theory d; _} as b), c) -> ( 274 | match T.simplify_and a d with 275 | | None -> 276 | if Test.compare x b > 0 then pseq b (pseq x c) 277 | else hashcons_pred (PSeq (x, y)) 278 | | Some t -> pseq t c ) 279 | (* rewrite test sequences into semi-canonical form *) 280 | | PSeq (p, _q), PSeq (r, s) 281 | when c_ord p s >= 0 -> 282 | pseq r (pseq s x) 283 | | PSeq (p, q), PSeq (r, s) when c_ord p r >= 0 && c_ord q s < 0 -> 284 | pseq r (pseq p (pseq q s)) 285 | | PSeq (p, q), PSeq (r, s) when c_ord p r >= 0 && c_ord q s >= 0 -> 286 | pseq r (pseq p (pseq s q)) 287 | | PSeq (p, q), PSeq (r, s) when c_ord q s >= 0 -> 288 | pseq p (pseq r (pseq s q)) 289 | | PSeq (p, q), PSeq (r, s) when c_ord q r >= 0 -> 290 | pseq p (pseq r (pseq q s)) 291 | | PSeq (p, q), PSeq (_r, _s) -> pseq p (pseq q y) 292 | | _, PSeq (r, s) when x.tag = r.tag || x.tag = s.tag -> y 293 | | _, PSeq (r, s) when c_ord x s > 0 -> pseq r (pseq s x) 294 | | _, PSeq (r, s) when c_ord x r > 0 -> pseq r (pseq x s) 295 | | _, PSeq (_r, _s) -> hashcons_pred (PSeq (x, y)) 296 | | PSeq (p, q), _ when y.tag = q.tag || y.tag = p.tag -> x 297 | | PSeq (p, q), _ when c_ord y q > 0 -> pseq p (pseq q y) 298 | | PSeq (p, q), _ when c_ord y p > 0 -> pseq p (pseq y q) 299 | | PSeq (_p, _q), _ -> hashcons_pred (PSeq (y, x)) 300 | (* default case *) 301 | | _, _ -> 302 | if Test.compare x y < 0 then hashcons_pred (PSeq (x, y)) 303 | else hashcons_pred (PSeq (y, x)) 304 | 305 | 306 | let action x = hashcons_kat (Action (1, x)) 307 | 308 | let action_i i x = hashcons_kat (Action (i, x)) 309 | 310 | let pred x = hashcons_kat (Pred x) 311 | 312 | let par x y = 313 | if x.tag == y.tag then x 314 | else 315 | match (x.node, y.node) with 316 | | _, Pred {node=Zero; _} -> x 317 | | Pred {node=Zero; _}, _ -> y 318 | | Pred a, Pred b -> hashcons_kat (Pred (ppar a b)) 319 | (* write 1 + p;p* as p* *) 320 | | Pred {node=One; _}, Seq (p, ({node=Star q; _} as r)) 321 | when p.tag == q.tag -> 322 | r 323 | | Pred {node=One; _}, Seq (({node=Star q; _} as r), p) when p.tag == q.tag -> 324 | r 325 | | Seq (p, ({node=Star q; _} as r)), Pred {node=One; _} when p.tag == q.tag -> 326 | r 327 | | Seq (({node=Star q; _} as r), p), Pred {node=One; _} when p.tag == q.tag -> 328 | r 329 | (* rewrite x + ax == x;(1 + a) == x *) 330 | | Seq ({node=Pred _; _}, p), _ 331 | when p.tag == y.tag -> 332 | p 333 | | Seq (p, {node=Pred _; _}), _ when p.tag == y.tag -> p 334 | | _, Seq ({node=Pred _; _}, p) when p.tag == x.tag -> p 335 | | _, Seq (p, {node=Pred _; _}) when p.tag == x.tag -> p 336 | | _, _ -> hashcons_kat (Par (x, y)) 337 | 338 | 339 | let rec seq x y = 340 | match (x.node, y.node) with 341 | (* merge primitives *) 342 | | Action (i, p), Action (_, q) 343 | when merge && T.variable p == T.variable q -> 344 | hashcons_kat (Action (i, T.merge p q)) 345 | (* identities *) 346 | | _, Pred {node=Zero; _} -> y 347 | | Pred {node=Zero; _}, _ -> x 348 | | _, Pred {node=One; _} -> x 349 | | Pred {node=One; _}, _ -> y 350 | | Star p, Star q when p.tag == q.tag -> x 351 | (* rewrite x*; x; x* == x*; x *) 352 | | Seq ({node=Star p; _}, q), Star r 353 | when q.tag == p.tag && q.tag == r.tag -> 354 | x 355 | | Star r, Seq ({node=Star p; _}, q) when q.tag == p.tag && q.tag == r.tag -> 356 | x 357 | | Seq ({node=Star p; _}, q), Seq ({node=Star r; _}, s) 358 | when q.tag == p.tag && q.tag == r.tag -> 359 | seq x s 360 | | Seq (s, {node=Star r; _}), Seq ({node=Star p; _}, q) 361 | when q.tag == p.tag && q.tag == r.tag -> 362 | seq s y 363 | | _, _ -> hashcons_kat (Seq (x, y)) 364 | 365 | 366 | let star x = 367 | match x.node with 368 | | Pred _ -> pred (one ()) 369 | | Star _y -> x 370 | | _ -> hashcons_kat (Star x) 371 | 372 | 373 | open BatSet 374 | 375 | let push_back p a = T.push_back p a 376 | 377 | let rec push_back_test (p: P.t) (test: Test.t) : Test.t PSet.t = 378 | match test.node with 379 | | One -> PSet.singleton ~cmp:Test.compare test 380 | | Zero -> PSet.create Test.compare 381 | | Theory x -> T.push_back p x 382 | | PPar (a, b) -> PSet.union (push_back_test p a) (push_back_test p b) 383 | | PSeq (a, b) -> 384 | let x = push_back_test p a in 385 | let y = push_back_test p b in 386 | let base = PSet.create Test.compare in 387 | Common.cross_product x y base pseq 388 | | Not _ | Placeholder _ -> failwith "Invalid term in pushback" 389 | 390 | let satisfiable x = T.satisfiable x 391 | 392 | open Z3 393 | 394 | let rec all_variables (a: Test.t) : T.A.t StrMap.t = 395 | match a.node with 396 | | One | Zero | Placeholder _ -> StrMap.empty 397 | | Not b -> all_variables b 398 | | PPar (b, c) | PSeq (b, c) -> 399 | StrMap.union (fun _k v1 _v2 -> Some v1) (all_variables b) (all_variables c) 400 | | Theory x -> StrMap.singleton (T.variable_test x) x 401 | 402 | let z3_satisfiable (a: Test.t) = 403 | let rec sat_aux (a: Test.t) ctx map = 404 | match a.node with 405 | | One -> Z3.Boolean.mk_true ctx 406 | | Zero -> Z3.Boolean.mk_false ctx 407 | | Not b -> Z3.Boolean.mk_not ctx (sat_aux b ctx map) 408 | | PPar (b, c) -> Z3.Boolean.mk_or ctx [sat_aux b ctx map; sat_aux c ctx map] 409 | | PSeq (b, c) -> Z3.Boolean.mk_and ctx [sat_aux b ctx map; sat_aux c ctx map] 410 | | Placeholder _ -> failwith "sat: unreachable" 411 | | Theory x -> T.theory_to_z3_expr x ctx map 412 | in 413 | (* grab all the referenced variables *) 414 | let vars = all_variables a in 415 | (* Create the solver *) 416 | let cfg = [("model", "false"); ("proof", "false")] in 417 | let ctx = mk_context cfg in 418 | let solver = Solver.mk_solver ctx None in 419 | (* create variables from each referenced variable *) 420 | let map = 421 | StrMap.fold 422 | (fun str a acc -> 423 | let xc = T.create_z3_var (str,a) ctx solver in 424 | StrMap.add str xc acc ) 425 | vars StrMap.empty 426 | in 427 | (* recrusively generate the formula and assert it *) 428 | let formula = sat_aux a ctx map in 429 | Solver.add solver [formula] ; 430 | let status = Solver.check solver [] in 431 | Solver.reset solver ; 432 | status = Solver.SATISFIABLE 433 | 434 | let implies (a: Test.t) (b: Test.t) : bool = 435 | let x = pseq a (not b) in 436 | Stdlib.not (satisfiable x) 437 | 438 | 439 | let rec test_of_exprs name es = 440 | match T.parse name es with 441 | | Left x -> theory x 442 | | Right _ -> failwith "Action in predicate" 443 | 444 | 445 | and test_of_expr (e: Syntax.expr) : test = 446 | match e with 447 | | EOne -> one () 448 | | EZero -> zero () 449 | | EPar (e1, e2) -> ppar (test_of_expr e1) (test_of_expr e2) 450 | | ESeq (e1, e2) -> pseq (test_of_expr e1) (test_of_expr e2) 451 | | ENot e1 -> not (test_of_expr e1) 452 | | EStar _ -> failwith "invalid star inside predicate" 453 | | EId name -> test_of_exprs name [] 454 | | ETheory (name, es) -> test_of_exprs name es 455 | 456 | 457 | and term_of_exprs name es = 458 | match T.parse name es with 459 | | Left x -> pred (theory x) 460 | | Right x -> action x 461 | 462 | 463 | and term_of_expr (e: Syntax.expr) = 464 | match e with 465 | | EOne -> pred (one ()) 466 | | EZero -> pred (zero ()) 467 | | EPar (e1, e2) -> par (term_of_expr e1) (term_of_expr e2) 468 | | ESeq (e1, e2) -> seq (term_of_expr e1) (term_of_expr e2) 469 | | EStar e1 -> star (term_of_expr e1) 470 | | ENot e1 -> pred (not (test_of_expr e1)) 471 | | EId name -> term_of_exprs name [] 472 | | ETheory (name, es) -> term_of_exprs name es 473 | 474 | 475 | let parse s = Input.read_from_str s |> term_of_expr 476 | end 477 | -------------------------------------------------------------------------------- /src/kmt.ml: -------------------------------------------------------------------------------- 1 | open Kat 2 | open Addition 3 | open Network 4 | open Product 5 | open Boolean 6 | open Incnat 7 | 8 | open Driver 9 | 10 | module DBoolean = Driver(Boolean) 11 | module DIncNat = Driver(IncNat) 12 | module DAddition = Driver(Addition) 13 | module DNetwork = Driver(Network) 14 | module DProduct = Driver(Product(Boolean)(IncNat)) 15 | module DProductAddition = Driver(Product(Boolean)(Addition)) 16 | 17 | open Cmdliner 18 | 19 | let mode = 20 | let boolean = 21 | let doc = "KMT THEORY of boolean (default)\npredicates: x=F, x=T; actions: set(x,T), set(x,F)" in 22 | DBoolean.run, Arg.info ["boolean"] ~doc 23 | in 24 | let incnat = 25 | let doc = "KMT THEORY of monotonic naturals\npredicates: x>n; actions: inc(x), set(x,n)" in 26 | DIncNat.run, Arg.info ["incnat"] ~doc 27 | in 28 | let addition = 29 | let doc = "KMT THEORY of naturals with more predicates\npredicates: x>n, x List.map (fun src -> (Logs.Src.name src, src)) in 59 | let doc = "Turn on debugging from $(docv). $(docv) must be " ^ 60 | (Arg.doc_alts_enum debug_flags) ^ "." 61 | in 62 | Arg.(value & opt_all (enum debug_flags) [] & info ["d"; "debug"] ~docv:"SRC" ~doc) 63 | 64 | let setup_debugs srcs = 65 | srcs |> List.iter (fun src -> Logs.Src.set_level src (Some Logs.Debug)) 66 | 67 | let setup_debugs = Term.(const setup_debugs $ debugs) 68 | 69 | let run mode args () () = mode args 70 | 71 | let cmd = 72 | let doc = "compute equivalence classes for various KMT theories" in 73 | let info = Cmd.info "kmt" ~version:"v0.1" ~exits:Cmd.Exit.defaults ~doc in 74 | Cmd.v info Term.(const run $ mode $ args $ setup_log $ setup_debugs) 75 | 76 | let main () = exit (Cmd.eval cmd) 77 | 78 | ;; 79 | 80 | main () 81 | -------------------------------------------------------------------------------- /src/kmt_eval.ml: -------------------------------------------------------------------------------- 1 | open Kat 2 | open Addition 3 | open Boolean 4 | open Product 5 | open Decide 6 | 7 | module T = ANSITerminal 8 | module KA = Addition.K 9 | module KB = Boolean.K 10 | module Prod = Product(Addition)(Boolean) 11 | module KP = Prod.K 12 | module DA = Decide(Addition) 13 | module DB = Decide(Boolean) 14 | module DP = Decide(Prod) 15 | 16 | let variables = ["a"; "b"; "c"; "d"; "e"; "f"; "g"; "h"; "i"] 17 | 18 | let random_addition_theory (vars: int) (bound: int) = 19 | let v = Random.int vars in 20 | let b = Random.int bound in 21 | let dir = Random.int 2 in 22 | let str = List.nth variables v in 23 | if dir = 0 then Lt (str, b) else Gt (str, b) 24 | 25 | 26 | let random_addition_action (vars: int) (bound: int) = 27 | let v = Random.int vars in 28 | let b = Random.int bound in 29 | let str = string_of_int v in 30 | Increment (str, b) 31 | 32 | 33 | module Random (K : KAT_IMPL) = struct 34 | let split sz = 35 | let x = Random.int (sz + 1) in 36 | if x = 0 then (1, sz - 1) else if x = sz then (sz - 1, 1) else (x, sz - x) 37 | 38 | 39 | let rec random_test (size: int) (f: unit -> K.A.t) : K.Test.t = 40 | if size = 1 then K.theory (f ()) 41 | else 42 | let x = Random.int 5 in 43 | let l, r = split size in 44 | if x < 1 then K.not (random_test (size - 1) f) 45 | else if x < 3 then K.ppar (random_test l f) (random_test r f) 46 | else K.pseq (random_test l f) (random_test r f) 47 | 48 | 49 | let rec random_term (size: int) (f: unit -> K.P.t) : K.Term.t = 50 | if size = 1 then K.action (f ()) 51 | else 52 | let x = Random.int 5 in 53 | let l, r = split size in 54 | if x < 2 then K.par (random_term l f) (random_term r f) 55 | else if x < 4 then K.seq (random_term l f) (random_term r f) 56 | else K.star (random_term (size - 1) f) 57 | end 58 | 59 | module RA = Random (KA) 60 | 61 | let test_astar_a_norm test = 62 | let term1 = DA.K.pred test in 63 | let term2 = DA.K.star term1 in 64 | try 65 | let eq = DA.equivalent term1 term2 in 66 | assert (not eq); 67 | () 68 | with _ -> () 69 | 70 | let test_count_twice_norm () = 71 | let term1 = DA.K.parse "(inc(x,1))*; x > 10" in 72 | let term2 = DA.K.parse "(inc(x,1))*;(inc(x,1))*; x > 10" in 73 | let eq = DA.equivalent term1 term2 in 74 | assert eq ; 75 | () 76 | 77 | let test_count_order_norm () = 78 | let term1 = DA.K.parse "(inc(x,1))*; x > 3; (inc(y,1))*; y > 3" in 79 | let term2 = DA.K.parse "(inc(x,1))*; (inc(y,1))*; x > 3; y > 3" in 80 | let eq = DA.equivalent term1 term2 in 81 | assert eq; 82 | () 83 | 84 | let test_parity_loop_norm () = 85 | let term1 = 86 | DB.K.parse 87 | "x=F; ( (x=T; set(x,F) + x=F; set(x,T));(x=T; set(x,F) + x=F; set(x,T)) )*" 88 | in 89 | let term2 = 90 | DB.K.parse 91 | " ( (x=T; set(x,F) + x=F; set(x,T));(x=T; set(x,F) + x=F; set(x,T)) )*; x=F" 92 | in 93 | let eq = DB.equivalent term1 term2 in 94 | assert eq; 95 | () 96 | 97 | let test_boolean_formula_norm () = 98 | let term1 = 99 | DB.K.parse 100 | "set(w,F); set(x,T); set(y,F); set(z,F); ((w=T + x=T + y=T + z=T); \ 101 | set(a,T) + (not (w=T + x=T + y=T + z=T)); set(a,F))" 102 | in 103 | let term2 = 104 | DB.K.parse 105 | "set(w,F); set(x,T); set(y,F); set(z,F); (((w=T + x=T) + (y=T + z=T)); \ 106 | set(a,T) + (not ((w=T + x=T) + (y=T + z=T))); set(a,F))" 107 | in 108 | let eq = DB.equivalent term1 term2 in 109 | assert eq; 110 | () 111 | 112 | let test_population_count_norm () = 113 | let term1 = DP.K.parse "y<1; (true + a=T; inc(y,1)); (true + b=T; inc(y,1)); (true + c=T; inc(y,1)); y>2" in 114 | let term2 = DP.K.parse "y<1; a=T; b=T; c=T; inc(y,1); inc(y,1); inc(y,1)" in 115 | let eq = DP.equivalent term1 term2 in 116 | assert eq; 117 | () 118 | 119 | let test_toggle_three_norm () = 120 | let term1 = DP.K.parse "(x=F;set(x,T) + y=F;set(y,T) + x=T;set(x,F) + y=T;set(y,F) + z=F;set(z,T) + z=T;set(z,F))*" in 121 | let term2 = term1 in 122 | let eq = DP.equivalent term1 term2 in 123 | assert eq; 124 | () 125 | 126 | 127 | let go timeout () () : unit = 128 | let run_test name tester arg = 129 | Printf.printf "%-30srunning...%!" name; 130 | let t = Common.timeout timeout tester arg in 131 | Printf.printf "\b\b\b\b\b\b\b\b\b\b "; 132 | begin 133 | match t with 134 | | Some time -> Printf.printf "%7.4f" time 135 | | None -> Printf.printf "%-7s" "timeout" 136 | end; 137 | Printf.printf "\n%!" 138 | in 139 | 140 | let test1 = RA.random_test 10 (fun () -> random_addition_theory 2 3) in 141 | (* let test2 = RA.random_test 100 (fun () -> random_addition_theory 2 3) in *) 142 | 143 | Printf.printf "test time (seconds)\n"; 144 | Printf.printf "% 31ds timeout\n%!" timeout; 145 | Printf.printf "----------------------------------------\n%!"; 146 | run_test "a* != a (10 random `a`s)" test_astar_a_norm test1; 147 | 148 | run_test "count twice" test_count_twice_norm (); 149 | 150 | run_test "count order" test_count_order_norm (); 151 | 152 | run_test "parity loop" test_parity_loop_norm (); 153 | 154 | run_test "boolean tree" test_boolean_formula_norm (); 155 | 156 | run_test "population count" test_population_count_norm (); 157 | 158 | run_test "toggle three bits" test_toggle_three_norm () 159 | 160 | (* arg parsing *) 161 | open Cmdliner 162 | 163 | let setup_log = 164 | let setup_log style_renderer level = 165 | Fmt_tty.setup_std_outputs ?style_renderer (); 166 | Logs.set_level level; 167 | Logs.set_reporter (Logs_fmt.reporter ()) 168 | in 169 | Term.(const setup_log $ Fmt_cli.style_renderer () $ Logs_cli.level ()) 170 | 171 | let setup_debugs = 172 | let debugs = 173 | let debug_flags = Logs.Src.list () |> List.map (fun src -> (Logs.Src.name src, src)) in 174 | let doc = "Turn on debugging from $(docv). $(docv) must be " ^ 175 | (Arg.doc_alts_enum debug_flags) ^ "." 176 | in 177 | Arg.(value & opt_all (enum debug_flags) [] & info ["d"; "debug"] ~docv:"SRC" ~doc) 178 | in 179 | let setup_debugs srcs = 180 | srcs |> List.iter (fun src -> Logs.Src.set_level src (Some Logs.Debug)) 181 | in 182 | Term.(const setup_debugs $ debugs) 183 | 184 | let timeout = 185 | let doc = "Timeout after $(docv) seconds (set <=0 for no timeout; defaults to 30)" 186 | in 187 | Arg.(value & opt Arg.int 30 & info ["t"; "timeout"] ~docv:"SECONDS" ~doc) 188 | 189 | let cmd = 190 | let doc = "Run PLDI2022 evaluation" in 191 | let info = Cmd.info "run_eval" ~doc in 192 | Cmd.v info Term.(const go $ timeout $ setup_log $ setup_debugs) 193 | 194 | let main () = exit (Cmd.eval cmd) 195 | ;; 196 | 197 | main() 198 | 199 | -------------------------------------------------------------------------------- /src/lexer.mll: -------------------------------------------------------------------------------- 1 | 2 | { 3 | open Parser 4 | open Printf 5 | exception Eof 6 | 7 | let incr_linenum lexbuf = 8 | let pos = lexbuf.Lexing.lex_curr_p in 9 | lexbuf.Lexing.lex_curr_p <- 10 | { pos with Lexing.pos_lnum = pos.Lexing.pos_lnum + 1; 11 | Lexing.pos_bol = pos.Lexing.pos_cnum; } ;; 12 | 13 | } 14 | 15 | let id = ['a'-'z' 'A'-'Z' '_' '0'-'9']+ 16 | let symbol = ['~' '`' '!' '@' '#' '$' '%' '^' '&' '|' ':' '?' '>' '<' '[' ']' '=' '-' '.']+ 17 | 18 | rule token = parse 19 | | "/*" { comments 0 lexbuf } 20 | | "false" { ZERO } 21 | | "true" { ONE } 22 | | "not" { NOT } 23 | | symbol as s { SYMBOL s } 24 | | id as s { VAL s } 25 | | "," { COMMA } 26 | | "+" { PLUS } 27 | | ";" { SEMI } 28 | | "*" { STAR } 29 | | "(" { LPAREN } 30 | | ")" { RPAREN } 31 | | [' ' '\t'] { token lexbuf } 32 | | '\n' { incr_linenum lexbuf; token lexbuf} 33 | | _ as c { printf "[Parse Error] Unrecognized character: %c\n" c; token lexbuf } 34 | | eof { EOF } 35 | 36 | and comments level = parse 37 | | "*/" { if level = 0 then token lexbuf else comments (level-1) lexbuf } 38 | | "/*" { comments (level+1) lexbuf } 39 | | '\n' { incr_linenum lexbuf; comments level lexbuf} 40 | | _ { comments level lexbuf } 41 | | eof { raise End_of_file } -------------------------------------------------------------------------------- /src/network.ml: -------------------------------------------------------------------------------- 1 | open Kat 2 | open Common 3 | open Syntax 4 | open BatSet 5 | 6 | type field_val = 7 | | Src of int 8 | | Dst of int 9 | | Pt of int 10 | | Sw of int 11 | [@@deriving eq, ord] 12 | 13 | let get_field = function 14 | | Src _ -> "src" 15 | | Dst _ -> "dst" 16 | | Pt _ -> "pt" 17 | | Sw _ -> "sw" 18 | 19 | let get_value = function 20 | | Src i | Dst i | Pt i | Sw i -> i 21 | 22 | let hash_fv = function 23 | | Src i -> 3 * i + 5 24 | | Dst i -> 7 * i + 11 25 | | Pt i -> 13 * i + 17 26 | | Sw i -> 23 * i + 31 27 | 28 | let field_val_of_string s i = 29 | match s with 30 | | "src" -> Src i 31 | | "dst" -> Dst i 32 | | "pt" -> Pt i 33 | | "sw" -> Sw i 34 | | _ -> failwith ("Invalid field value: " ^ s) 35 | 36 | let show_field_val sep fv = 37 | match fv with 38 | | Src i -> "src" ^ sep ^ (string_of_int i) 39 | | Dst i -> "dst" ^ sep ^ (string_of_int i) 40 | | Pt i -> "pt" ^ sep ^ (string_of_int i) 41 | | Sw i -> "sw" ^ sep ^ (string_of_int i) 42 | 43 | module rec Network : (THEORY with type A.t = field_val and type P.t = field_val) = struct 44 | module K = KAT(Network) 45 | 46 | module Test = K.Test 47 | module Term = K.Term 48 | 49 | module A : (CollectionType with type t = field_val) = struct 50 | type t = field_val 51 | let compare = compare_field_val 52 | let equal = equal_field_val 53 | let hash = hash_fv 54 | let show = show_field_val "=" 55 | end 56 | 57 | module P : (CollectionType with type t = field_val) = struct 58 | type t = field_val 59 | let compare = compare_field_val 60 | let equal = equal_field_val 61 | let hash = hash_fv 62 | let show = show_field_val "<-" 63 | end 64 | 65 | let name () = "network" 66 | 67 | let parse name es = 68 | match name, es with 69 | | "=", [EId s1; EId s2] -> Left (field_val_of_string s1 (int_of_string s2)) 70 | | "<-", [EId s1; EId s2] -> Right (field_val_of_string s1 (int_of_string s2)) 71 | | _, _ -> failwith ("Cannot create theory object from (" ^ name ^ ") and parameters") 72 | 73 | let push_back p a = 74 | match p, a with 75 | | Src i, Src j 76 | | Dst i, Dst j 77 | | Pt i, Pt j 78 | | Sw i, Sw j -> 79 | if i = j 80 | then PSet.singleton ~cmp:K.Test.compare (K.one()) 81 | else PSet.create K.Test.compare 82 | | _, _ -> PSet.singleton ~cmp:K.Test.compare (K.theory a) 83 | 84 | let merge _x y = y 85 | 86 | let reduce a p = 87 | if equal_field_val a p then None 88 | else Some p 89 | 90 | let variable x = get_field x 91 | 92 | let variable_test x = get_field x 93 | 94 | let satisfiable _x = failwith "network sat undefined" 95 | 96 | let theory_to_z3_expr _f _ctx _map = failwith "network theory_to_z3_expr undefined" 97 | 98 | let create_z3_var _str _ctx _solver = failwith "network create_z3_var undefined" 99 | 100 | let simplify_and x y = 101 | match x,y with 102 | | Src a, Src b 103 | | Dst a, Dst b 104 | | Pt a, Pt b 105 | | Sw a, Sw b -> Some (if a = b then K.theory x else K.zero ()) 106 | | _, _ -> None 107 | 108 | let simplify_or _x _y = None 109 | 110 | let simplify_not _x = None 111 | 112 | end 113 | -------------------------------------------------------------------------------- /src/parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Syntax 3 | %} 4 | 5 | %token VAL 6 | %token SYMBOL 7 | %token ZERO ONE PLUS SEMI NOT STAR 8 | %token SEMI LPAREN RPAREN COMMA SYMBOL EOF 9 | 10 | %start expr 11 | %type expr 12 | 13 | %left PLUS 14 | %left SEMI 15 | %right NOT 16 | %nonassoc STAR 17 | %nonassoc SYMBOL 18 | 19 | %% 20 | 21 | expr: 22 | | ZERO { EZero } 23 | | ONE { EOne } 24 | | NOT expr { ENot $2 } 25 | | expr PLUS expr { EPar ($1,$3) } 26 | | expr SEMI expr { ESeq ($1,$3) } 27 | | expr STAR { EStar $1 } 28 | | LPAREN expr RPAREN { $2 } 29 | | VAL { EId $1 } 30 | | VAL LPAREN exprs RPAREN { ETheory ($1, $3) } 31 | | expr SYMBOL expr { ETheory ($2, [$1; $3]) } 32 | ; 33 | 34 | exprs: 35 | | expr { [$1] } 36 | | expr COMMA exprs { $1 :: $3 } 37 | ; -------------------------------------------------------------------------------- /src/product.ml: -------------------------------------------------------------------------------- 1 | open Kat 2 | open Common 3 | open Hashcons 4 | 5 | module Product(T1 : THEORY) (T2: THEORY) : (THEORY with type A.t = (T1.A.t, T2.A.t) either and type P.t = (T1.P.t, T2.P.t) either ) = struct 6 | 7 | module rec Implementation : (THEORY with type A.t = (T1.A.t, T2.A.t) either and type P.t = (T1.P.t, T2.P.t) either ) = struct 8 | 9 | module K = KAT(Implementation) 10 | module Test = K.Test 11 | module Term = K.Term 12 | module P = Common.Either.Make(T1.P)(T2.P) 13 | module A = Common.Either.Make(T1.A)(T2.A) 14 | 15 | let name () = "product(" ^ T1.name () ^ ", " ^ T2.name () ^ ")" 16 | 17 | let parse name es : (A.t, P.t) either = 18 | try 19 | match T1.parse name es with 20 | | Left x -> Left (Left x) 21 | | Right y -> Right (Left y) 22 | with _ -> begin 23 | try 24 | match T2.parse name es with 25 | | Left x -> Left (Right x) 26 | | Right y -> Right (Right y) 27 | with _ -> 28 | failwith ("Cannot create theory object from (" ^ name ^ ") and parameters") 29 | end 30 | 31 | open BatSet 32 | 33 | let rec from_test_left (a : T1.K.Test.t) : K.Test.t = 34 | match a.node with 35 | | Zero -> K.zero () 36 | | One -> K.one () 37 | | Theory x -> K.theory (Left x) 38 | | Not x -> K.not (from_test_left x) 39 | | PPar(x,y) -> K.ppar (from_test_left x) (from_test_left y) 40 | | PSeq(x,y) -> K.pseq (from_test_left x) (from_test_left y) 41 | | Placeholder i -> K.placeholder i 42 | 43 | let rec from_test_right (a : T2.K.Test.t) : K.Test.t = 44 | match a.node with 45 | | Zero -> K.zero () 46 | | One -> K.one () 47 | | Theory x -> K.theory (Right x) 48 | | Not x -> K.not (from_test_right x) 49 | | PPar(x,y) -> K.ppar (from_test_right x) (from_test_right y) 50 | | PSeq(x,y) -> K.pseq (from_test_right x) (from_test_right y) 51 | | Placeholder i -> K.placeholder i 52 | 53 | let rec to_test_left (a : K.Test.t) (f : T2.K.A.t -> T1.K.Test.t) : T1.K.Test.t = 54 | match a.node with 55 | | Zero -> T1.K.zero () 56 | | One -> T1.K.one () 57 | | Theory (Left x) -> T1.K.theory x 58 | | Theory (Right y) -> f y 59 | | Not x -> T1.K.not (to_test_left x f) 60 | | PPar(x,y) -> T1.K.ppar (to_test_left x f) (to_test_left y f) 61 | | PSeq(x,y) -> T1.K.pseq (to_test_left x f) (to_test_left y f) 62 | | Placeholder i -> T1.K.placeholder i 63 | 64 | let rec to_test_right (a : K.Test.t) (f : T1.K.A.t -> T2.K.Test.t) : T2.K.Test.t = 65 | match a.node with 66 | | Zero -> T2.K.zero () 67 | | One -> T2.K.one () 68 | | Theory (Right x) -> T2.K.theory x 69 | | Theory (Left y) -> f y 70 | | Not x -> T2.K.not (to_test_right x f) 71 | | PPar(x,y) -> T2.K.ppar (to_test_right x f) (to_test_right y f) 72 | | PSeq(x,y) -> T2.K.pseq (to_test_right x f) (to_test_right y f) 73 | | Placeholder i -> T2.K.placeholder i 74 | 75 | let convert_from_left set = 76 | BatSet.PSet.fold 77 | (fun v acc -> BatSet.PSet.add (from_test_left v) acc) 78 | set 79 | (BatSet.PSet.create K.Test.compare) 80 | 81 | let convert_from_right set = 82 | BatSet.PSet.fold 83 | (fun v acc -> BatSet.PSet.add (from_test_right v) acc) 84 | set 85 | (BatSet.PSet.create K.Test.compare) 86 | 87 | let push_back p a = 88 | match p,a with 89 | | Left p, Left a -> convert_from_left (T1.push_back p a) 90 | | Right p, Right a -> convert_from_right (T2.push_back p a) 91 | | Left _, Right _ 92 | | Right _, Left _ -> PSet.singleton ~cmp:K.Test.compare (K.theory a) 93 | 94 | let simplify_or a b = 95 | match a,b with 96 | | Left x, Left y -> begin 97 | match T1.simplify_or x y with 98 | | None -> None 99 | | Some z -> Some (from_test_left z) 100 | end 101 | | Right x, Right y -> begin 102 | match T2.simplify_or x y with 103 | | None -> None 104 | | Some z -> Some (from_test_right z) 105 | end 106 | | _, _ -> None 107 | 108 | let simplify_and a b = 109 | match a,b with 110 | | Left x, Left y -> begin 111 | match T1.simplify_and x y with 112 | | None -> None 113 | | Some z -> Some (from_test_left z) 114 | end 115 | | Right x, Right y -> begin 116 | match T2.simplify_and x y with 117 | | None -> None 118 | | Some z -> Some (from_test_right z) 119 | end 120 | | _, _ -> None 121 | 122 | let simplify_not a = 123 | match a with 124 | | Left x -> begin 125 | match T1.simplify_not x with 126 | | None -> None 127 | | Some z -> Some (from_test_left z) 128 | end 129 | | Right y -> begin 130 | match T2.simplify_not y with 131 | | None -> None 132 | | Some z -> Some (from_test_right z) 133 | end 134 | 135 | let merge (_p1 : P.t) (_p2 : P.t) : P.t = failwith "product merge undefined" 136 | 137 | (* TODO MMG 2020-02-28 we could have a real definition here... *) 138 | let reduce _a _p = failwith "product reduce undefined" 139 | 140 | let variable p = 141 | match p with 142 | | Left x -> T1.variable x 143 | | Right y -> T2.variable y 144 | 145 | let variable_test a = 146 | match a with 147 | | Left x -> T1.variable_test x 148 | | Right y -> T2.variable_test y 149 | 150 | let rec only_left (a : K.Test.t) : bool = 151 | match a.node with 152 | | Zero | One | Theory (Left _) -> true 153 | | Theory (Right _) -> false 154 | | Not x -> only_left x 155 | | PPar(x,y) | PSeq(x,y) -> (only_left x && only_left y) 156 | | Placeholder _i -> failwith "impossible" 157 | 158 | let rec only_right (a : K.Test.t) : bool = 159 | match a.node with 160 | | Zero | One | Theory (Right _) -> true 161 | | Theory (Left _) -> false 162 | | Not x -> only_right x 163 | | PPar(x,y) | PSeq(x,y) -> (only_right x && only_right y) 164 | | Placeholder _i -> failwith "impossible" 165 | 166 | let theory_to_z3_expr (a : A.t) (ctx : Z3.context) (map : Z3.Expr.expr StrMap.t) = 167 | match a with 168 | | Left x -> T1.theory_to_z3_expr x ctx map 169 | | Right y -> T2.theory_to_z3_expr y ctx map 170 | 171 | let create_z3_var (str,a) (ctx : Z3.context) (solver : Z3.Solver.solver) : Z3.Expr.expr = 172 | match a with 173 | | Left x -> T1.create_z3_var (str,x) ctx solver 174 | | Right y -> T2.create_z3_var (str,y) ctx solver 175 | 176 | let satisfiable (a: K.Test.t) = 177 | if only_left a then T1.satisfiable (to_test_left a (fun _ -> failwith "product sat left error")) 178 | else if only_right a then T2.satisfiable (to_test_right a (fun _ -> failwith "product sat right error")) 179 | else K.z3_satisfiable a 180 | 181 | end 182 | 183 | include Implementation 184 | end 185 | -------------------------------------------------------------------------------- /src/range.ml: -------------------------------------------------------------------------------- 1 | type range = {lo : int; hi : int} 2 | type t = range list 3 | 4 | let empty = {lo=(-1); hi=(-1)} 5 | let full = {lo=0; hi=max_int} 6 | 7 | let overlaps (r1 : range) (r2 : range) = 8 | (r1.lo >= r2.lo && r1.lo <= r2.hi) || (r1.hi >= r2.lo && r1.hi <= r2.hi) || 9 | (r2.lo >= r1.lo && r2.lo <= r1.hi) || (r2.hi >= r1.lo && r2.hi <= r1.hi) 10 | 11 | let is_empty (r : range) = r.lo < 0 12 | 13 | let unionRange (r1 : range) (r2 : range) = 14 | match is_empty r1, is_empty r2 with 15 | | true, _ -> r2 16 | | _, true -> r1 17 | | false, false -> {lo=min r1.lo r2.lo; hi=max r1.hi r2.hi} 18 | 19 | let interRange (r1 : range) (r2 : range) = 20 | if (is_empty r1) || (is_empty r2) || r1.lo > r2.hi || r2.lo > r1.hi 21 | then empty 22 | else {lo=max r1.lo r2.lo; hi=min r1.hi r2.hi} 23 | 24 | let negateRange (r : range) : t = 25 | if is_empty r then [full] 26 | else 27 | match r.lo, r.hi with 28 | | 0, x when x = max_int -> [] 29 | | 0, x -> [{lo=x+1; hi=max_int}] 30 | | w, x when x = max_int -> [{lo=0; hi=w-1}] 31 | | w, x -> [{lo=0; hi=w-1}; {lo=x+1; hi=max_int}] 32 | 33 | let fromRange (r : range) = 34 | if r = empty then [] 35 | else [ r ] 36 | 37 | let trueRanges = [ full ] 38 | let falseRanges = [] 39 | 40 | let rec unionSingle (r : range) (rs : t) = 41 | match rs with 42 | | [] -> [ r ] 43 | | hd :: tl -> 44 | if r.hi < hd.lo then r :: rs 45 | else if overlaps r hd then unionSingle (unionRange r hd) tl 46 | else r :: (unionSingle r tl) 47 | 48 | let rec union (rs1 : t) (rs2 : t) = 49 | match rs1 with 50 | | [] -> rs2 51 | | hd :: tl -> union tl (unionSingle hd rs2) 52 | 53 | let rec interSingle (r : range) (rs : t) = 54 | match rs with 55 | | [] -> [] 56 | | hd :: tl -> 57 | if overlaps r hd then interRange r hd :: (interSingle r tl) 58 | else interSingle r tl 59 | 60 | let rec inter (rs1 : t) (rs2 : t) = 61 | match rs1 with 62 | | [] -> [] 63 | | hd :: [] -> interSingle hd rs2 64 | | hd :: tl -> inter tl (interSingle hd rs2) 65 | 66 | let negate (rs : t) = 67 | if rs = falseRanges then trueRanges 68 | else List.fold_left (fun acc r -> union acc (negateRange r) ) [] rs 69 | 70 | let is_false (rs : t) = rs = [] 71 | 72 | let is_true (rs : t) = 73 | match rs with 74 | | [r] -> r = full 75 | | _ -> false 76 | 77 | let top = trueRanges 78 | 79 | let bot = falseRanges 80 | 81 | let from_range (x,y) = fromRange {lo=x; hi=y} 82 | 83 | let show_range (r : range) = 84 | if r.lo < 0 then "empty" 85 | else 86 | (if r.hi = max_int then Printf.sprintf "(%d,infinity)" r.lo 87 | else Printf.sprintf "(%d,%d)" r.lo r.hi) 88 | 89 | let show (rs : t) = 90 | Common.show_list show_range rs -------------------------------------------------------------------------------- /src/range.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val from_range : int * int -> t 4 | val union : t -> t -> t 5 | val inter : t -> t -> t 6 | val negate : t -> t 7 | val top : t 8 | val bot : t 9 | 10 | val is_true : t -> bool 11 | val is_false : t -> bool 12 | 13 | val show : t -> string -------------------------------------------------------------------------------- /src/syntax.ml: -------------------------------------------------------------------------------- 1 | type expr = 2 | | EZero 3 | | EOne 4 | | EId of string 5 | | ETheory of string * expr list 6 | | EPar of expr * expr 7 | | ESeq of expr * expr 8 | | EStar of expr 9 | | ENot of expr 10 | 11 | let rec expr_to_string e = 12 | match e with 13 | | EZero -> "0" 14 | | EOne -> "1" 15 | | EId s -> "id(" ^ s ^ ")" 16 | | EPar(e1,e2) -> "(" ^ expr_to_string e1 ^ " + " ^ expr_to_string e2 ^ ")" 17 | | ESeq(e1,e2) -> expr_to_string e1 ^ ";" ^ expr_to_string e2 18 | | EStar e1 -> "(" ^ expr_to_string e1 ^ ")*" 19 | | ENot e1 -> "-" ^ expr_to_string e1 20 | | ETheory(name, _es) -> name ^ "(..)" 21 | -------------------------------------------------------------------------------- /src/test_equivalence.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | open Kat 3 | open Incnat 4 | open Addition 5 | open Boolean 6 | open Product 7 | open Decide 8 | 9 | module type TESTER = 10 | functor (T : THEORY) -> 11 | sig 12 | type t = string 13 | 14 | val pp : t Fmt.t 15 | 16 | val equal : t -> t -> bool 17 | 18 | val assert_equivalent : ?speed:Alcotest.speed_level -> 19 | string -> string -> string -> unit Alcotest.test_case 20 | val assert_not_equivalent : ?speed:Alcotest.speed_level -> 21 | string -> string -> string -> unit Alcotest.test_case 22 | end 23 | 24 | module NormalizationTester(T : THEORY) = struct 25 | module K = T.K 26 | module D = Decide(T) 27 | 28 | type t = string 29 | 30 | let pp = Fmt.string 31 | 32 | let equal s1 s2 = 33 | let p = K.parse s1 in 34 | let q = K.parse s2 in 35 | D.equivalent p q 36 | 37 | let equivalent : string Alcotest.testable = Alcotest.testable pp equal 38 | 39 | let assert_equivalent ?speed:(speed=`Quick) name l r = 40 | Alcotest.test_case name speed (fun () -> Alcotest.(check equivalent) "equivalent" l r) 41 | let assert_not_equivalent ?speed:(speed=`Quick) name l r = 42 | Alcotest.test_case name speed (fun () -> Alcotest.(check (Alcotest.neg equivalent)) "inequivalent" l r) 43 | end 44 | 45 | (* Unit tests *) 46 | module TestAddition (T : TESTER) = struct 47 | module TA = T(Addition) 48 | open TA 49 | 50 | let tests = 51 | [ assert_equivalent "predicate reflexivity" 52 | "x > 2" 53 | "x > 2"; 54 | assert_equivalent "star reflexivity" 55 | "inc(x,1)*; x > 2" 56 | "inc(x,1)*; x > 2"; 57 | assert_equivalent "unrolling 1" 58 | "inc(x,1);inc(x,1)*; x > 2" 59 | "x>1;inc(x,1) + inc(x,1);inc(x,1);inc(x,1)*; x > 2"; 60 | assert_equivalent "unrolling 2" 61 | "inc(x,1)*; x > 2" 62 | "x>2 + inc(x,1);inc(x,1)*; x > 2"; 63 | assert_equivalent "unrolling 3" 64 | "inc(x,1)*; x > 2" 65 | "x>2 + inc(x,1)*; x > 2"; 66 | assert_equivalent "postcondition 1" 67 | "inc(x,1); inc(x,1); inc(x,1); x > 2" 68 | "inc(x,1); inc(x,1); inc(x,1); x > 1"; 69 | assert_not_equivalent "postcondition 2" 70 | "inc(x,1); inc(x,1); inc(x,1); x > 2" 71 | "inc(x,1); inc(x,1); inc(x,1); x > 3"; 72 | assert_equivalent "commutativity" 73 | "inc(x,1);inc(y,1); x > 0; y > 0" 74 | "inc(x,1);inc(y,1); y > 0; x > 0"; 75 | assert_not_equivalent "initial conditions" 76 | "inc(x,1);inc(x,1)*; x > 2" 77 | "x>2;inc(x,1) + inc(x,1);inc(x,1);inc(x,1)*; x > 2"; 78 | assert_equivalent "Greater than" 79 | "x>2;x>1" 80 | "x>2"; 81 | assert_equivalent "commutativity plus" 82 | "x > 2 + y > 1" 83 | "y > 1 + x > 2"; 84 | assert_equivalent "idempotency actions" 85 | "inc(x,1) + inc(x,1)" 86 | "inc(x,1)"; 87 | assert_equivalent "test in loop 1" 88 | "(inc(x,1);x>1)*" 89 | "true + x>0;inc(x,1);inc(x,1)*"; 90 | assert_not_equivalent "test in loop 2" 91 | "(inc(x,1);x>1)*" 92 | "true + inc(x,1);inc(x,1)*"; 93 | assert_equivalent "x>3;not (x>2) = false (regression)" 94 | "x>3; not (x>2)" 95 | "false" 96 | ] 97 | end 98 | 99 | module TestIncNat (T : TESTER) = struct 100 | module TI = T(IncNat) 101 | open TI 102 | 103 | let tests = 104 | [ assert_equivalent "idempotency 1" 105 | "x > 2" 106 | "x > 2"; 107 | assert_equivalent "idempotency 2" 108 | "inc(x)*; x > 2" 109 | "inc(x)*; x > 2"; 110 | assert_equivalent "unrolling 1" 111 | "inc(x);inc(x)*; x > 2" 112 | "x>1;inc(x) + inc(x);inc(x);inc(x)*; x > 2"; 113 | assert_equivalent "unrolling 2" 114 | "inc(x)*; x > 2" 115 | "x>2 + inc(x);inc(x)*; x > 2"; 116 | assert_equivalent "unrolling 3" 117 | "inc(x)*; x > 2" 118 | "x>2 + inc(x)*; x > 2"; 119 | assert_equivalent "postcondition 1" 120 | "inc(x); inc(x); inc(x); x > 2" 121 | "inc(x); inc(x); inc(x); x > 1"; 122 | assert_not_equivalent "postcondition 2" 123 | "inc(x); inc(x); inc(x); x > 2" 124 | "inc(x); inc(x); inc(x); x > 3"; 125 | assert_equivalent "commutativity" 126 | "inc(x);inc(y); x > 0; y > 0" 127 | "inc(x);inc(y); y > 0; x > 0"; 128 | assert_not_equivalent "initial Conditions" 129 | "inc(x);inc(x)*; x > 2" 130 | "x>2;inc(x) + inc(x);inc(x);inc(x)*; x > 2"; 131 | assert_equivalent "greater than" 132 | "x>2;x>1" 133 | "x>2"; 134 | assert_equivalent "commutativity plus" 135 | "x > 2 + y > 1" 136 | "y > 1 + x > 2"; 137 | assert_equivalent "idempotency actions" 138 | "inc(x) + inc(x)" 139 | "inc(x)"; 140 | assert_equivalent "test in loop 1" 141 | "(inc(x);x>1)*" 142 | "true + x>0;inc(x);inc(x)*"; 143 | assert_not_equivalent "test in loop 2" 144 | "(inc(x);x>1)*" 145 | "true + inc(x);inc(x)*"; 146 | assert_equivalent "canceled set" 147 | "set(x,0);x>0" 148 | "false"; 149 | assert_equivalent "set canceled pred" 150 | "set(x,5);x>0" 151 | "set(x,5)"; 152 | assert_not_equivalent "tracing" 153 | "(inc(x))*;set(x,0)" 154 | "set(x,0)"; 155 | assert_equivalent "x>3;not (x>2) = false (regression)" 156 | "x>3; not (x>2)" 157 | "false" 158 | ] 159 | end 160 | 161 | module TestBoolean (T : TESTER) = struct 162 | module TB = T(Boolean) 163 | open TB 164 | 165 | let tests = 166 | [ assert_equivalent "assign eq" 167 | "set(x,T); x=T" 168 | "set(x,T)"; 169 | assert_not_equivalent "assign neq" 170 | "set(x,T); x=F" 171 | "set(x,T)"; 172 | assert_equivalent "assign eq 2" 173 | "set(x,T); set(x,F); x=F" 174 | "set(x,T); set(x,F)"; 175 | assert_equivalent "parity loop" 176 | "x=F; ( (x=T; set(x,F) + x=F; set(x,T));(x=T; set(x,F) + x=F; set(x,T)) )*" 177 | " ( (x=T; set(x,F) + x=F; set(x,T));(x=T; set(x,F) + x=F; set(x,T)) )*; x=F"; 178 | assert_not_equivalent "parity loop 2" 179 | "x=F; ( (x=T; set(x,F) + x=F; set(x,T));(x=T; set(x,F) + x=F; set(x,T)) )*" 180 | " ( (x=T; set(x,F) + x=F; set(x,T));(x=T; set(x,F) + x=F; set(x,T)) )*; x=T"; 181 | assert_equivalent "finiteness" 182 | "x=F + x=T" 183 | "true"; 184 | assert_equivalent "associativity" 185 | "(x=F + y=F) + z=F" 186 | "x=F + (y=F + z=F)"; 187 | assert_equivalent "multiple vars" 188 | "(x=T; set(y,T) + x=F; set(y,F)); (x=T;y=T + x=F;y=F)" 189 | "(x=T; set(y,T) + x=F; set(y,F))"; 190 | assert_not_equivalent "multiple vars 2" 191 | "(x=T; set(y,T) + x=F; set(y,F)); (x=T;y=F + x=F;y=F)" 192 | "(x=T; set(y,T) + x=F; set(y,F))"; 193 | assert_equivalent "unrolling" 194 | "set(x,T)*; x=T" 195 | "x=T + set(x,T); set(x,T)*; x=T"; 196 | assert_equivalent "kat p* identity" 197 | "(a=T)*" 198 | "(a=T;a=T)* + a=T;(a=T;a=T)*"; 199 | assert_equivalent "toggle star" 200 | "(set(x,T) + set(y,T) + set(x,F) + set(y,T))*" 201 | "(set(x,F) + set(y,T) + set(x,T) + set(y,T))*"; 202 | assert_equivalent "tree ordering" 203 | "set(w,F); set(x,T); set(y,F); set(z,F); ((w=T + x=T + y=T + z=T); set(a,T) + (not (w=T + x=T + y=T + z=T)); set(a,F))" 204 | "set(w,F); set(x,T); set(y,F); set(z,F); (((w=T + x=T) + (y=T + z=T)); set(a,T) + (not ((w=T + x=T) + (y=T + z=T))); set(a,F))" 205 | ] 206 | 207 | let denesting_tests = 208 | ["x=F;set(x,T)"; "y=F;set(y,T)"; "x=T;set(x,F)"; "y=T;set(y,F)"] 209 | |> permutations 210 | |> List.map (List.fold_left (fun acc e -> e ^ add_sep " + " acc) "") 211 | |> List.map (fun inner -> "(" ^ inner ^ ")*") 212 | |> unique_pairs 213 | |> List.map (fun (lhs, rhs) -> assert_equivalent (lhs ^ " = " ^ rhs) lhs rhs) 214 | end 215 | 216 | module TestProduct (T : TESTER) = struct 217 | module TP = T(Product(Addition)(Boolean)) 218 | open TP 219 | 220 | let tests = 221 | [ assert_equivalent "actions parse" 222 | "set(x,T); x=T; inc(y,1)" 223 | "set(x,T); inc(y,1)"; 224 | assert_not_equivalent "actions commute" 225 | "set(x,T); inc(y,1)" 226 | "inc(y,1); set(x,T)"; 227 | assert_equivalent "population count" 228 | "y<1; (a=F + a=T; inc(y,1)); y > 0" 229 | "y<1; a=T; inc(y,1)"; 230 | assert_not_equivalent "population count 2" 231 | "y<1; (a=F + a=T; inc(y,1))" 232 | "a=T; inc(y,1)"; 233 | assert_equivalent "population count 3" 234 | "y<1; (true + a=T; inc(y,1)); (true + b=T; inc(y,1)); (true + c=T; inc(y,1)); y>2" 235 | "y<1; a=T; b=T; c=T; inc(y,1); inc(y,1); inc(y,1)"; 236 | assert_equivalent"population count 3 (variant)" 237 | "y<1; (a=F + a=T; inc(y,1)); (b=F + b=T; inc(y,1)); (c=F + c=T; inc(y,1)); y>2" 238 | "y<1; a=T; b=T; c=T; inc(y,1); inc(y,1); inc(y,1)"; 239 | assert_not_equivalent "population count: mismatched domain (regression)" 240 | "y<1; (a=F + a=T; inc(y,1)); not (y < 1)" 241 | "a=T;inc(y,1)" 242 | ] 243 | 244 | end 245 | 246 | module TestAdditionNormalization = TestAddition(NormalizationTester) 247 | 248 | module TestIncNatNormalization = TestIncNat(NormalizationTester) 249 | 250 | module TestBooleanNormalization = TestBoolean(NormalizationTester) 251 | 252 | module TestProductNormalization = TestProduct(NormalizationTester) 253 | 254 | let main () = 255 | Alcotest.run "equivalence" [ 256 | "addition normalization", TestAdditionNormalization.tests 257 | ; "incnat normalization", TestIncNatNormalization.tests 258 | ; "boolean normalization", TestBooleanNormalization.tests 259 | ; "product normalization", TestProductNormalization.tests 260 | ; "denesting normalization", 261 | TestBooleanNormalization.denesting_tests 262 | ] 263 | ;; 264 | 265 | main () 266 | -------------------------------------------------------------------------------- /src/test_word.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | open Word 3 | open Alcotest 4 | 5 | (* TODO better pretty printing *) 6 | let equiv : word testable = 7 | let pp = Fmt.of_to_string Word.show in 8 | testable pp same_words 9 | 10 | let check_equivalent = check equiv "equivalent" 11 | 12 | let check_inequivalent = check (neg equiv) "inequivalent" 13 | 14 | let small_words = [ 15 | emp 16 | ; eps 17 | ; ltr 0 18 | ; ltr 1 19 | ; ltr 2 20 | ] 21 | 22 | let alts (ws: word list) = cartesian_product ws ws |> List.map (uncurry alt) 23 | let cats (ws: word list) = cartesian_product ws ws |> List.map (uncurry cat) 24 | let strs (ws: word list) = ws |> List.map str 25 | 26 | let rec transform (l: 'a list) (xforms: ('a list -> 'a list) list) (lvls: int) : 'a list = 27 | if lvls <= 0 28 | then l 29 | else transform (l @ concat_map (fun xform -> xform l) xforms) xforms (lvls - 1) 30 | 31 | let star_free_words : word list = 32 | transform small_words [alts; cats] 1 (* TODO MMG 2020-03-26 change to 2 *) 33 | 34 | let words : word list = 35 | transform (transform small_words [alts; cats; strs] 1) [strs] 1 36 | 37 | let rec unroll_star_r (w: word) : word = 38 | match w.node with 39 | | Str w_inner -> alt eps (cat w_inner w) 40 | | Emp | Eps | Ltr _ -> w 41 | | Alt (w1, w2) -> alt (unroll_star_r w1) (unroll_star_r w2) 42 | | Cat (w1, w2) -> cat (unroll_star_r w1) (unroll_star_r w2) 43 | 44 | let rec unroll_star_l (w: word) : word = 45 | match w.node with 46 | | Str w_inner -> alt (cat w w_inner) eps 47 | | Emp | Eps | Ltr _ -> w 48 | | Alt (w1, w2) -> alt (unroll_star_l w1) (unroll_star_l w2) 49 | | Cat (w1, w2) -> cat (unroll_star_l w1) (unroll_star_l w2) 50 | 51 | let debug_mode () = 52 | Logs.Src.set_level word_log_src (Some Logs.Debug); 53 | Logs.set_reporter (Logs_fmt.reporter ()) 54 | 55 | let main () = 56 | debug_mode (); 57 | run "word equivalence of regular expressions" [ 58 | "reflexivity", 59 | [test_case ("reflexivity (" ^ string_of_int (List.length words) ^ " cases)") `Quick 60 | (fun () -> words |> List.iter (fun w -> check_equivalent w w))] 61 | ; "symmetry", 62 | begin 63 | let pairs = unique_pairs words in 64 | [test_case ("w1 = w2 <-> w2 = w1 (" ^ string_of_int (List.length pairs) ^ " cases)") `Quick 65 | (fun () -> pairs 66 | |> List.iter (fun (w1, w2) -> 67 | check bool ("same answer for " ^ Word.show w1 ^ " and " ^ Word.show w2) 68 | (same_words w1 w2) (same_words w2 w1)))] 69 | end 70 | ; "star unrolling (w* = 1 + ww*)", 71 | begin 72 | let ws = star_free_words |> strs in 73 | [test_case ("w = unroll w (" ^ string_of_int (List.length ws) ^ " cases)") `Quick 74 | (fun () -> ws |> List.iter (fun w -> check_equivalent w (unroll_star_r w)))] 75 | end 76 | ; "star unrolling (w* = w*w + 1)", 77 | begin 78 | let ws = star_free_words |> strs in 79 | [test_case ("w = unroll w (" ^ string_of_int (List.length ws) ^ " cases)") `Quick 80 | (fun () -> ws |> List.iter (fun w -> check_equivalent w (unroll_star_l w)))] 81 | end 82 | ; "inequivalences", 83 | [ test_case "true != false" `Quick (fun () -> check_inequivalent eps emp) 84 | ; test_case "pi_0 != pi_1" `Quick (fun () -> check_inequivalent (ltr 0) (ltr 1)) 85 | ; test_case "pi_0 != pi_0 + pi_1" `Quick 86 | (fun () -> check_inequivalent (ltr 0) (alt (ltr 0) (ltr 1))) 87 | ; test_case "pi_0* != pi_0*" `Quick 88 | (fun () -> check_inequivalent (ltr 0) (str (ltr 1))) 89 | ; begin 90 | let ws = star_free_words |> strs in 91 | test_case ("w* != false (" ^ string_of_int (List.length ws) ^ " cases)") `Quick 92 | (fun () -> ws |> List.iter (fun w -> check_inequivalent w emp)) 93 | end 94 | ] 95 | ; let w = str (alt (ltr 0) (alt emp (ltr 1))) in 96 | "debugging slowness (w = (pi_0 + false + pi_1)*)", [ 97 | test_case "reflexivity on w" `Quick 98 | (fun () -> check_equivalent w w) 99 | ; test_case "reflexivity on w*" `Quick 100 | (fun () -> check_equivalent (str w) (str w)) 101 | ; test_case "right unrolling (w* = 1 + ww*)" `Quick 102 | (fun () -> check_equivalent w (unroll_star_r w)) 103 | ; test_case "left unrolling (w* = w*w + 1)" `Slow 104 | (fun () -> check_equivalent w (unroll_star_l w)) 105 | ] 106 | ] 107 | ;; 108 | 109 | main () 110 | -------------------------------------------------------------------------------- /src/word.ml: -------------------------------------------------------------------------------- 1 | open Hashcons 2 | open Common 3 | 4 | let word_log_src = Logs.Src.create "kmt.word" 5 | ~doc:"logs regular expression/word equality tests" 6 | module Log = (val Logs.src_log word_log_src : Logs.LOG) 7 | 8 | (* TODO parse words *) 9 | 10 | type letter = int 11 | 12 | let show_letter l = "pi_" ^ string_of_int l 13 | 14 | type word = word_hons hash_consed 15 | and word_hons = 16 | | Emp 17 | | Eps 18 | | Ltr of letter 19 | | Alt of word * word 20 | | Cat of word * word 21 | | Str of word 22 | 23 | let equal_word x y = 24 | match (x, y) with 25 | | Emp, Emp | Eps, Eps -> true 26 | | Ltr l1, Ltr l2 -> l1 = l2 27 | | Alt (a, b), Alt (c, d) | Cat (a, b), Cat (c, d) -> 28 | a.tag = c.tag && b.tag = d.tag 29 | | Str a, Str b -> a.tag = b.tag 30 | | _, _ -> false 31 | 32 | let hash_word x = 33 | match x with 34 | | Emp -> 3 35 | | Eps -> 5 36 | | Ltr l -> 7 * l + 3 37 | | Alt (a, b) -> 13 * (b.hkey + (17 * a.hkey + 19)) 38 | | Cat (a, b) -> 23 * (b.hkey + (29 * a.hkey + 31)) 39 | | Str a -> 37 * a.hkey + 41 40 | 41 | let tbl_word = Hashcons.create 8 42 | 43 | let hashcons_word = Hashcons.hashcons hash_word equal_word tbl_word 44 | 45 | let emp = hashcons_word Emp 46 | let eps = hashcons_word Eps 47 | let ltr l = hashcons_word (Ltr l) 48 | let alt w1 w2 = 49 | match w1.node, w2.node with 50 | | Emp, _ -> w2 51 | | _, Emp -> w1 52 | | _, _ -> if w1.tag = w2.tag 53 | then w1 54 | else hashcons_word (Alt (w1, w2)) 55 | let cat w1 w2 = 56 | match w1.node, w2.node with 57 | | Eps, _ -> w2 58 | | _, Eps -> w1 59 | | _, _ -> hashcons_word (Cat (w1, w2)) 60 | 61 | let str w = 62 | match w.node with 63 | | Emp -> eps 64 | | Eps -> eps 65 | | _ -> hashcons_word (Str w) 66 | 67 | module Word : CollectionType with type t = word = struct 68 | type t = word 69 | 70 | let equal x y = x.tag = y.tag 71 | let compare x y = x.tag - y.tag 72 | let hash x = x.hkey 73 | let show : t -> string = 74 | let rec alt w = 75 | match w.node with 76 | | Alt (w1, w2) -> alt w1 ^ " + " ^ alt w2 77 | | _ -> cat w 78 | 79 | and cat w = 80 | match w.node with 81 | | Cat (w1, w2) -> cat w1 ^ " + " ^ cat w2 82 | | _ -> str w 83 | 84 | and str w = 85 | match w.node with 86 | | Str w -> atom w ^ "*" 87 | | _ -> atom w 88 | 89 | and atom w = 90 | match w.node with 91 | | Ltr l -> show_letter l 92 | | Emp -> "false" 93 | | Eps -> "true" 94 | | _ -> "(" ^ alt w ^ " )" 95 | in 96 | alt 97 | end 98 | 99 | let rec num_letters (w: word) : int = 100 | match w.node with 101 | | Eps | Emp -> 0 102 | | Ltr i -> i 103 | | Alt (w1, w2) | Cat (w1, w2) -> max (num_letters w1) (num_letters w2) 104 | | Str w -> num_letters w 105 | 106 | let rec accepting (w: word) : bool = 107 | match w.node with 108 | | Eps -> true 109 | | Str _ -> true 110 | | Emp | Ltr _ -> false 111 | | Alt (w1, w2) -> accepting w1 || accepting w2 112 | | Cat (w1, w2) -> accepting w1 && accepting w2 113 | 114 | let rec derivative (w: word) (l: letter) : word = 115 | match w.node with 116 | | Emp -> emp 117 | | Eps -> emp 118 | | Ltr l' -> if l = l' then eps else emp 119 | | Alt (w1, w2) -> alt (derivative w1 l) (derivative w2 l) 120 | | Cat (w1, w2) -> 121 | alt (cat (derivative w1 l) w2) (if accepting w1 then (derivative w2 l) else emp) 122 | | Str w_inner -> cat (derivative w_inner l) w 123 | 124 | module UF = BatUref 125 | module WordMap = Hashtbl.Make(Word) 126 | type state = word UF.uref 127 | 128 | let find_state (m: state WordMap.t) (w: word) : state = 129 | match WordMap.find_opt m w with 130 | | None -> 131 | let state = UF.uref w in 132 | WordMap.add m w state; 133 | state 134 | | Some state -> state 135 | 136 | exception Acceptance_mismatch of word * word 137 | 138 | let check_acceptance m w1 w2 = 139 | Log.debug (fun m -> m "checking acceptance of %s and %s" 140 | (Word.show w1) (Word.show w2)); 141 | if accepting w1 <> accepting w2 142 | then raise (Acceptance_mismatch (w1, w2)) 143 | else 144 | let st1 = find_state m w1 in 145 | let st2 = find_state m w2 in 146 | if not (UF.equal st1 st2) 147 | then begin 148 | UF.unite st1 st2; 149 | [(w1,w2)] 150 | end 151 | else [] 152 | 153 | let equivalent_words (w1: word) (w2: word) (sigma: int) : bool = 154 | let m : state WordMap.t = WordMap.create 16 in 155 | let rec loop (l: (word * word) list) : bool = 156 | match l with 157 | | [] -> true (* all done! *) 158 | | (w1, w2)::l' -> 159 | let rec inner (c: int) : (word * word) list= 160 | if c = sigma 161 | then [] 162 | else begin 163 | Log.debug (fun m -> m "comparing %s and %s on %s" 164 | (Word.show w1) (Word.show w2) (show_letter c)); 165 | let w1c = derivative w1 c in 166 | let w2c = derivative w2 c in 167 | Log.debug (fun m -> m "got derivatives %s and %s" 168 | (Word.show w1c) (Word.show w2c)); 169 | check_acceptance m w1c w2c @ inner (c+1) 170 | end 171 | in 172 | let app = inner 0 in 173 | Log.debug (fun m -> m "added %s" (show_list (fun (w1,w2) -> "(" ^ Word.show w1 ^ ", " ^ Word.show w2 ^ ")") app)); 174 | loop (l' @ app) 175 | in 176 | try loop (check_acceptance m w1 w2) 177 | with Acceptance_mismatch _ -> 178 | begin 179 | Log.debug (fun m -> m "%s and %s mismatch\n" (Word.show w1) (Word.show w2)); 180 | false 181 | end 182 | 183 | let same_words (w1: word) (w2: word) : bool = 184 | let sigma = max (num_letters w1) (num_letters w2) + 1 in 185 | equivalent_words w1 w2 sigma 186 | --------------------------------------------------------------------------------