├── .gitignore ├── CODE_OF_CONDUCT.md ├── LICENSE.md ├── README.md ├── project.clj ├── src └── clj_bob │ ├── j_bob.clj │ ├── lang.clj │ ├── little_prover.clj │ └── repl.clj └── test └── clj_bob └── little_prover_test.clj /.gitignore: -------------------------------------------------------------------------------- 1 | /target 2 | /classes 3 | /checkouts 4 | pom.xml 5 | pom.xml.asc 6 | *.jar 7 | *.class 8 | /.lein-* 9 | /.nrepl-port 10 | .hgignore 11 | .hg/ 12 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Contributor Code of Conduct 2 | 3 | As contributors and maintainers of this project, and in the interest of fostering an open and welcoming community, we pledge to respect all people who contribute through reporting issues, posting feature requests, updating documentation, submitting pull requests or patches, and other activities. 4 | 5 | We are committed to making participation in this project a harassment-free experience for everyone, regardless of level of experience, gender, gender identity and expression, sexual orientation, disability, personal appearance, body size, race, ethnicity, age, religion, or nationality. 6 | 7 | Examples of unacceptable behavior by participants include: 8 | 9 | * The use of sexualized language or imagery 10 | * Personal attacks 11 | * Trolling or insulting/derogatory comments 12 | * Public or private harassment 13 | * Publishing other's private information, such as physical or electronic addresses, without explicit permission 14 | * Other unethical or unprofessional conduct. 15 | 16 | Project maintainers have the right and responsibility to remove, edit, or reject comments, commits, code, wiki edits, issues, and other contributions that are not aligned to this Code of Conduct. By adopting this Code of Conduct, project maintainers commit themselves to fairly and consistently applying these principles to every aspect of managing this project. Project maintainers who do not follow or enforce the Code of Conduct may be permanently removed from the project team. 17 | 18 | This code of conduct applies both within project spaces and in public spaces when an individual is representing the project or its community. 19 | 20 | Instances of abusive, harassing, or otherwise unacceptable behavior may be reported by opening an issue or contacting one or more of the project maintainers. 21 | 22 | This Code of Conduct is adapted from the [Contributor Covenant](http://contributor-covenant.org), version 1.2.0, available at [http://contributor-covenant.org/version/1/2/0/](http://contributor-covenant.org/version/1/2/0/) 23 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Daniel P. Friedman and Carl Eastlund 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, 5 | are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation and/or 12 | other materials provided with the distribution. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 15 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 16 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 17 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 18 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 19 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 20 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 21 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 22 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 23 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 24 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # clj-bob 2 | 3 | A Clojure (technically) port of [J-Bob](https://github.com/the-little-prover/j-bob), the proof assistant from [The Little Prover](https://mitpress.mit.edu/books/little-prover) by Daniel P. Friedman and Carl Eastlund. 4 | 5 | ## caveats 6 | 7 | Ok, so first of all, this is not normal Clojure. 8 | Like the Scheme implementation, this is mostly macros and functions that operate on/emulate ACL2 syntax. 9 | On the one hand, that's really weird. 10 | On the other, that means that this matches the book exactly in almost all cases -- a worthy trade. 11 | 12 | I've successfully tested a bunch of the book's examples (including the final one) and they've all matched the Scheme implementation, but that's the best I can give you right now in terms of assurances. 13 | 14 | ## weird stuff 15 | 16 | The book/J-Bob assume that `.` and `/` are legal to use in function names. 17 | Unfortunately, Clojure disagrees. 18 | Through the use of advanced search-and-replace™ technology, I changed all `.`s and `/`s into `-`. 19 | 20 | That means that `chapter1.example1` is now `chapter1-example1`, `dethm.set?/sub` is now `dethm-set?-sub`, etc. 21 | 22 | ## usage 23 | 24 | ### with an editor repl 25 | 26 | If you're comfortable an editor-based REPL like CIDER, Fireplace, or Cursive, you can open `/src/clj_bob/repl.clj` and start a REPL from there. That namespace does the necessary Clojure exclusions and requires to be ready to execute code directly out of the book. 27 | 28 | ### with `lein repl` 29 | 30 | If you'd prefer to use the [Leiningen](http://leiningen.org) REPL, just clone this repository and run `lein repl` inside of it. 31 | Everything's pre-configured, so you can immediately start typing examples from the book and you *should* see exactly the same output. 32 | 33 | For example: 34 | 35 | ```clojure 36 | #_clj-bob.j-bob=> (car (cons 'ham '(eggs))) 37 | ham 38 | #_clj-bob.j-bob=> (atom '()) ;; no, this is not Clojure 39 | t 40 | ``` 41 | 42 | ## contributions 43 | 44 | ...are very welcome, including docs, issues, and pull requests. 45 | Please note that this project has adopted a [code of conduct](CODE_OF_CONDUCT.md), and contributors are expected to adhere to it. 46 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject clj-bob "0.1.0" 2 | :description "The Little Prover in Clojure" 3 | :url "https://github.com/holguinj/clj-bob" 4 | :dependencies [[org.clojure/clojure "1.7.0"]] 5 | :repl-options {:init-ns clj-bob.j-bob}) 6 | -------------------------------------------------------------------------------- /src/clj_bob/j_bob.clj: -------------------------------------------------------------------------------- 1 | (ns clj-bob.j-bob 2 | (:refer-clojure :exclude [cons if num + < atom bound? var?]) 3 | (:require [clj-bob.lang :refer :all])) 4 | 5 | (defun list0 () '()) 6 | (defun list0? (x) (equal x '())) 7 | 8 | (defun list1 (x) (cons x (list0))) 9 | (defun list1? (x) 10 | (if (atom x) 'nil (list0? (cdr x)))) 11 | (defun elem1 (xs) (car xs)) 12 | 13 | (defun list2 (x y) (cons x (list1 y))) 14 | (defun list2? (x) 15 | (if (atom x) 'nil (list1? (cdr x)))) 16 | (defun elem2 (xs) (elem1 (cdr xs))) 17 | 18 | (defun list3 (x y z) (cons x (list2 y z))) 19 | (defun list3? (x) 20 | (if (atom x) 'nil (list2? (cdr x)))) 21 | (defun elem3 (xs) (elem2 (cdr xs))) 22 | 23 | (defun tag (sym x) (cons sym x)) 24 | (defun tag? (sym x) 25 | (if (atom x) 'nil (equal (car x) sym))) 26 | (defun untag (x) (cdr x)) 27 | 28 | (defun quote-c (value) 29 | (tag 'quote (list1 value))) 30 | (defun quote? (x) 31 | (if (tag? 'quote x) (list1? (untag x)) 'nil)) 32 | (defun quote-value (e) (elem1 (untag e))) 33 | 34 | (defun if-c (Q A E) (tag 'if (list3 Q A E))) 35 | (defun if? (x) 36 | (if (tag? 'if x) (list3? (untag x)) 'nil)) 37 | (defun if-q (e) (elem1 (untag e))) 38 | (defun if-a (e) (elem2 (untag e))) 39 | (defun if-e (e) (elem3 (untag e))) 40 | 41 | (defun app-c (name args) (cons name args)) 42 | (defun app? (x) 43 | (if (atom x) 44 | 'nil 45 | (if (quote? x) 46 | 'nil 47 | (if (if? x) 48 | 'nil 49 | 't)))) 50 | (defun app-name (e) (car e)) 51 | (defun app-args (e) (cdr e)) 52 | 53 | (defun var? (x) 54 | (if (equal x 't) 55 | 'nil 56 | (if (equal x 'nil) 57 | 'nil 58 | (if (natp x) 59 | 'nil 60 | (atom x))))) 61 | 62 | (defun defun-c (name formals body) 63 | (tag 'defun (list3 name formals body))) 64 | (defun defun? (x) 65 | (if (tag? 'defun x) (list3? (untag x)) 'nil)) 66 | (defun defun-name (def) (elem1 (untag def))) 67 | (defun defun-formals (def) (elem2 (untag def))) 68 | (defun defun-body (def) (elem3 (untag def))) 69 | 70 | (defun dethm-c (name formals body) 71 | (tag 'dethm (list3 name formals body))) 72 | (defun dethm? (x) 73 | (if (tag? 'dethm x) (list3? (untag x)) 'nil)) 74 | (defun dethm-name (def) (elem1 (untag def))) 75 | (defun dethm-formals (def) (elem2 (untag def))) 76 | (defun dethm-body (def) (elem3 (untag def))) 77 | 78 | (defun if-qAE (e) 79 | (list3 (if-q e) (if-a e) (if-e e))) 80 | (defun QAE-if (es) 81 | (if-c (elem1 es) (elem2 es) (elem3 es))) 82 | 83 | (defun member? (x ys) 84 | (if (atom ys) 85 | 'nil 86 | (if (equal x (car ys)) 87 | 't 88 | (member? x (cdr ys))))) 89 | 90 | (defun rator? (name) 91 | (member? name 92 | '(equal atom car cdr cons natp size + <))) 93 | 94 | (defun rator-formals (rator) 95 | (if (member? rator '(atom car cdr natp size)) 96 | '(x) 97 | (if (member? rator '(equal cons + <)) 98 | '(x y) 99 | 'nil))) 100 | 101 | (defun def-name (def) 102 | (if (defun? def) 103 | (defun-name def) 104 | (if (dethm? def) 105 | (dethm-name def) 106 | def))) 107 | 108 | (defun def-formals (def) 109 | (if (dethm? def) 110 | (dethm-formals def) 111 | (if (defun? def) 112 | (defun-formals def) 113 | '()))) 114 | 115 | (defun if-c-when-necessary (Q A E) 116 | (if (equal A E) A (if-c Q A E))) 117 | 118 | (defun conjunction (es) 119 | (if (atom es) 120 | (quote-c 't) 121 | (if (atom (cdr es)) 122 | (car es) 123 | (if-c (car es) 124 | (conjunction (cdr es)) 125 | (quote-c 'nil))))) 126 | 127 | (defun implication (es e) 128 | (if (atom es) 129 | e 130 | (if-c (car es) 131 | (implication (cdr es) e) 132 | (quote-c 't)))) 133 | 134 | (defun lookup (name defs) 135 | (if (atom defs) 136 | name 137 | (if (equal (def-name (car defs)) name) 138 | (car defs) 139 | (lookup name (cdr defs))))) 140 | 141 | (defun undefined? (name defs) 142 | (if (var? name) 143 | (equal (lookup name defs) name) 144 | 'nil)) 145 | 146 | (defun arity? (vars es) 147 | (if (atom vars) 148 | (atom es) 149 | (if (atom es) 150 | 'nil 151 | (arity? (cdr vars) (cdr es))))) 152 | 153 | (defun args-arity? (def args) 154 | (if (dethm? def) 155 | 'nil 156 | (if (defun? def) 157 | (arity? (defun-formals def) args) 158 | (if (rator? def) 159 | (arity? (rator-formals def) args) 160 | 'nil)))) 161 | 162 | (defun app-arity? (defs app) 163 | (args-arity? (lookup (app-name app) defs) 164 | (app-args app))) 165 | 166 | (defun bound? (var vars) 167 | (if (equal vars 'any) 't (member? var vars))) 168 | 169 | (defun exprs? (defs vars es) 170 | (if (atom es) 171 | 't 172 | (if (var? (car es)) 173 | (if (bound? (car es) vars) 174 | (exprs? defs vars (cdr es)) 175 | 'nil) 176 | (if (quote? (car es)) 177 | (exprs? defs vars (cdr es)) 178 | (if (if? (car es)) 179 | (if (exprs? defs vars 180 | (if-qAE (car es))) 181 | (exprs? defs vars (cdr es)) 182 | 'nil) 183 | (if (app? (car es)) 184 | (if (app-arity? defs (car es)) 185 | (if (exprs? defs vars 186 | (app-args (car es))) 187 | (exprs? defs vars (cdr es)) 188 | 'nil) 189 | 'nil) 190 | 'nil)))))) 191 | (defun expr? (defs vars e) 192 | (exprs? defs vars (list1 e))) 193 | 194 | (defun get-arg-from (n args from) 195 | (if (atom args) 196 | 'nil 197 | (if (equal n from) 198 | (car args) 199 | (get-arg-from n (cdr args) (+ from '1))))) 200 | (defun get-arg (n args) 201 | (get-arg-from n args '1)) 202 | 203 | (defun set-arg-from (n args y from) 204 | (if (atom args) 205 | '() 206 | (if (equal n from) 207 | (cons y (cdr args)) 208 | (cons (car args) 209 | (set-arg-from n (cdr args) y 210 | (+ from '1)))))) 211 | (defun set-arg (n args y) 212 | (set-arg-from n args y '1)) 213 | 214 | (defun <=len-from (n args from) 215 | (if (atom args) 216 | 'nil 217 | (if (equal n from) 218 | 't 219 | (<=len-from n (cdr args) (+ from '1))))) 220 | (defun <=len (n args) 221 | (if (< '0 n) (<=len-from n args '1) 'nil)) 222 | 223 | (defun subset? (xs ys) 224 | (if (atom xs) 225 | 't 226 | (if (member? (car xs) ys) 227 | (subset? (cdr xs) ys) 228 | 'nil))) 229 | 230 | (defun list-extend (xs x) 231 | (if (atom xs) 232 | (list1 x) 233 | (if (equal (car xs) x) 234 | xs 235 | (cons (car xs) 236 | (list-extend (cdr xs) x))))) 237 | 238 | (defun list-union (xs ys) 239 | (if (atom ys) 240 | xs 241 | (list-union (list-extend xs (car ys)) 242 | (cdr ys)))) 243 | 244 | (defun formals? (vars) 245 | (if (atom vars) 246 | 't 247 | (if (var? (car vars)) 248 | (if (member? (car vars) (cdr vars)) 249 | 'nil 250 | (formals? (cdr vars))) 251 | 'nil))) 252 | 253 | (defun direction? (dir) 254 | (if (natp dir) 255 | 't 256 | (member? dir '(Q A E)))) 257 | 258 | (defun path? (path) 259 | (if (atom path) 260 | 't 261 | (if (direction? (car path)) 262 | (path? (cdr path)) 263 | 'nil))) 264 | 265 | (defun quoted-exprs? (args) 266 | (if (atom args) 267 | 't 268 | (if (quote? (car args)) 269 | (quoted-exprs? (cdr args)) 270 | 'nil))) 271 | 272 | (defun step-args? (defs def args) 273 | (if (dethm? def) 274 | (if (arity? (dethm-formals def) args) 275 | (exprs? defs 'any args) 276 | 'nil) 277 | (if (defun? def) 278 | (if (arity? (defun-formals def) args) 279 | (exprs? defs 'any args) 280 | 'nil) 281 | (if (rator? def) 282 | (if (arity? (rator-formals def) args) 283 | (quoted-exprs? args) 284 | 'nil) 285 | 'nil)))) 286 | 287 | (defun step-app? (defs app) 288 | (step-args? defs 289 | (lookup (app-name app) defs) 290 | (app-args app))) 291 | 292 | (defun step? (defs step) 293 | (if (path? (elem1 step)) 294 | (if (app? (elem2 step)) 295 | (step-app? defs (elem2 step)) 296 | 'nil) 297 | 'nil)) 298 | 299 | (defun steps? (defs steps) 300 | (if (atom steps) 301 | 't 302 | (if (step? defs (car steps)) 303 | (steps? defs (cdr steps)) 304 | 'nil))) 305 | 306 | (defun induction-scheme-for? (def vars e) 307 | (if (defun? def) 308 | (if (arity? (defun-formals def) (app-args e)) 309 | (if (formals? (app-args e)) 310 | (subset? (app-args e) vars) 311 | 'nil) 312 | 'nil) 313 | 'nil)) 314 | 315 | (defun induction-scheme? (defs vars e) 316 | (if (app? e) 317 | (induction-scheme-for? 318 | (lookup (app-name e) defs) 319 | vars 320 | e) 321 | 'nil)) 322 | 323 | (defun seed? (defs def seed) 324 | (if (equal seed 'nil) 325 | 't 326 | (if (defun? def) 327 | (expr? defs (defun-formals def) seed) 328 | (if (dethm? def) 329 | (induction-scheme? defs 330 | (dethm-formals def) 331 | seed) 332 | 'nil)))) 333 | 334 | (defun extend-rec (defs def) 335 | (if (defun? def) 336 | (list-extend defs 337 | (defun-c 338 | (defun-name def) 339 | (defun-formals def) 340 | (app-c (defun-name def) 341 | (defun-formals def)))) 342 | defs)) 343 | 344 | (defun def-contents? (known-defs formals body) 345 | (if (formals? formals) 346 | (expr? known-defs formals body) 347 | 'nil)) 348 | 349 | (defun def? (known-defs def) 350 | (if (dethm? def) 351 | (if (undefined? (dethm-name def) 352 | known-defs) 353 | (def-contents? known-defs 354 | (dethm-formals def) 355 | (dethm-body def)) 356 | 'nil) 357 | (if (defun? def) 358 | (if (undefined? (defun-name def) 359 | known-defs) 360 | (def-contents? 361 | (extend-rec known-defs def) 362 | (defun-formals def) 363 | (defun-body def)) 364 | 'nil) 365 | 'nil))) 366 | 367 | (defun defs? (known-defs defs) 368 | (if (atom defs) 369 | 't 370 | (if (def? known-defs (car defs)) 371 | (defs? (list-extend known-defs (car defs)) 372 | (cdr defs)) 373 | 'nil))) 374 | 375 | (defun list2-or-more? (pf) 376 | (if (atom pf) 377 | 'nil 378 | (if (atom (cdr pf)) 379 | 'nil 380 | 't))) 381 | 382 | (defun proof? (defs pf) 383 | (if (list2-or-more? pf) 384 | (if (def? defs (elem1 pf)) 385 | (if (seed? defs (elem1 pf) (elem2 pf)) 386 | (steps? (extend-rec defs (elem1 pf)) 387 | (cdr (cdr pf))) 388 | 'nil) 389 | 'nil) 390 | 'nil)) 391 | 392 | (defun proofs? (defs pfs) 393 | (if (atom pfs) 394 | 't 395 | (if (proof? defs (car pfs)) 396 | (proofs? 397 | (list-extend defs (elem1 (car pfs))) 398 | (cdr pfs)) 399 | 'nil))) 400 | 401 | (defun sub-var (vars args var) 402 | (if (atom vars) 403 | var 404 | (if (equal (car vars) var) 405 | (car args) 406 | (sub-var (cdr vars) (cdr args) var)))) 407 | 408 | (defun sub-es (vars args es) 409 | (if (atom es) 410 | '() 411 | (if (var? (car es)) 412 | (cons (sub-var vars args (car es)) 413 | (sub-es vars args (cdr es))) 414 | (if (quote? (car es)) 415 | (cons (car es) 416 | (sub-es vars args (cdr es))) 417 | (if (if? (car es)) 418 | (cons 419 | (QAE-if 420 | (sub-es vars args 421 | (if-qAE (car es)))) 422 | (sub-es vars args (cdr es))) 423 | (cons 424 | (app-c (app-name (car es)) 425 | (sub-es vars args 426 | (app-args (car es)))) 427 | (sub-es vars args (cdr es)))))))) 428 | (defun sub-e (vars args e) 429 | (elem1 (sub-es vars args (list1 e)))) 430 | 431 | (defun exprs-recs (f es) 432 | (if (atom es) 433 | '() 434 | (if (var? (car es)) 435 | (exprs-recs f (cdr es)) 436 | (if (quote? (car es)) 437 | (exprs-recs f (cdr es)) 438 | (if (if? (car es)) 439 | (list-union 440 | (exprs-recs f (if-qAE (car es))) 441 | (exprs-recs f (cdr es))) 442 | (if (equal (app-name (car es)) f) 443 | (list-union 444 | (list1 (car es)) 445 | (list-union 446 | (exprs-recs f 447 | (app-args (car es))) 448 | (exprs-recs f (cdr es)))) 449 | (list-union 450 | (exprs-recs f (app-args (car es))) 451 | (exprs-recs f 452 | (cdr es))))))))) 453 | (defun expr-recs (f e) 454 | (exprs-recs f (list1 e))) 455 | 456 | (defun totality-< (meas formals app) 457 | (app-c '< 458 | (list2 (sub-e formals (app-args app) meas) 459 | meas))) 460 | 461 | (defun totality-meas (meas formals apps) 462 | (if (atom apps) 463 | '() 464 | (cons 465 | (totality-< meas formals (car apps)) 466 | (totality-meas meas formals (cdr apps))))) 467 | 468 | (defun totality-if (meas f formals e) 469 | (if (if? e) 470 | (conjunction 471 | (list-extend 472 | (totality-meas meas formals 473 | (expr-recs f (if-q e))) 474 | (if-c-when-necessary (if-q e) 475 | (totality-if meas f formals 476 | (if-a e)) 477 | (totality-if meas f formals 478 | (if-e e))))) 479 | (conjunction 480 | (totality-meas meas formals 481 | (expr-recs f e))))) 482 | 483 | (defun totality-claim (meas def) 484 | (if (equal meas 'nil) 485 | (if (equal (expr-recs (defun-name def) 486 | (defun-body def)) 487 | '()) 488 | (quote-c 't) 489 | (quote-c 'nil)) 490 | (if-c 491 | (app-c 'natp (list1 meas)) 492 | (totality-if meas (defun-name def) 493 | (defun-formals def) 494 | (defun-body def)) 495 | (quote-c 'nil)))) 496 | 497 | (defun induction-prems (vars claim apps) 498 | (if (atom apps) 499 | '() 500 | (cons 501 | (sub-e vars (app-args (car apps)) claim) 502 | (induction-prems vars claim (cdr apps))))) 503 | 504 | (defun induction-if (vars claim f e) 505 | (if (if? e) 506 | (implication 507 | (induction-prems vars claim 508 | (expr-recs f (if-q e))) 509 | (if-c-when-necessary (if-q e) 510 | (induction-if vars claim f (if-a e)) 511 | (induction-if vars claim f (if-e e)))) 512 | (implication 513 | (induction-prems vars claim 514 | (expr-recs f e)) 515 | claim))) 516 | 517 | (defun induction-defun (vars claim def) 518 | (induction-if vars claim (defun-name def) 519 | (sub-e (defun-formals def) vars 520 | (defun-body def)))) 521 | 522 | (defun induction-claim (defs seed def) 523 | (if (equal seed 'nil) 524 | (dethm-body def) 525 | (induction-defun (app-args seed) 526 | (dethm-body def) 527 | (lookup (app-name seed) defs)))) 528 | 529 | (defun find-focus-at-direction (dir e) 530 | (if (equal dir 'Q) 531 | (if-q e) 532 | (if (equal dir 'A) 533 | (if-a e) 534 | (if (equal dir 'E) 535 | (if-e e) 536 | (get-arg dir (app-args e)))))) 537 | 538 | (defun rewrite-focus-at-direction (dir e1 e2) 539 | (if (equal dir 'Q) 540 | (if-c e2 (if-a e1) (if-e e1)) 541 | (if (equal dir 'A) 542 | (if-c (if-q e1) e2 (if-e e1)) 543 | (if (equal dir 'E) 544 | (if-c (if-q e1) (if-a e1) e2) 545 | (app-c (app-name e1) 546 | (set-arg dir (app-args e1) e2)))))) 547 | 548 | (defun focus-is-at-direction? (dir e) 549 | (if (equal dir 'Q) 550 | (if? e) 551 | (if (equal dir 'A) 552 | (if? e) 553 | (if (equal dir 'E) 554 | (if? e) 555 | (if (app? e) 556 | (<=len dir (app-args e)) 557 | 'nil))))) 558 | 559 | (defun focus-is-at-path? (path e) 560 | (if (atom path) 561 | 't 562 | (if (focus-is-at-direction? (car path) e) 563 | (focus-is-at-path? (cdr path) 564 | (find-focus-at-direction (car path) e)) 565 | 'nil))) 566 | 567 | (defun find-focus-at-path (path e) 568 | (if (atom path) 569 | e 570 | (find-focus-at-path (cdr path) 571 | (find-focus-at-direction (car path) e)))) 572 | 573 | (defun rewrite-focus-at-path (path e1 e2) 574 | (if (atom path) 575 | e2 576 | (rewrite-focus-at-direction (car path) e1 577 | (rewrite-focus-at-path (cdr path) 578 | (find-focus-at-direction (car path) e1) 579 | e2)))) 580 | 581 | (defun prem-A? (prem path e) 582 | (if (atom path) 583 | 'nil 584 | (if (equal (car path) 'A) 585 | (if (equal (if-q e) prem) 586 | 't 587 | (prem-A? prem (cdr path) 588 | (find-focus-at-direction (car path) 589 | e))) 590 | (prem-A? prem (cdr path) 591 | (find-focus-at-direction (car path) 592 | e))))) 593 | 594 | (defun prem-E? (prem path e) 595 | (if (atom path) 596 | 'nil 597 | (if (equal (car path) 'E) 598 | (if (equal (if-q e) prem) 599 | 't 600 | (prem-E? prem (cdr path) 601 | (find-focus-at-direction (car path) 602 | e))) 603 | (prem-E? prem (cdr path) 604 | (find-focus-at-direction (car path) 605 | e))))) 606 | 607 | (defun follow-prems (path e thm) 608 | (if (if? thm) 609 | (if (prem-A? (if-q thm) path e) 610 | (follow-prems path e (if-a thm)) 611 | (if (prem-E? (if-q thm) path e) 612 | (follow-prems path e (if-e thm)) 613 | thm)) 614 | thm)) 615 | 616 | (defun unary-op (rator rand) 617 | (if (equal rator 'atom) 618 | (atom rand) 619 | (if (equal rator 'car) 620 | (car rand) 621 | (if (equal rator 'cdr) 622 | (cdr rand) 623 | (if (equal rator 'natp) 624 | (natp rand) 625 | (if (equal rator 'size) 626 | (size rand) 627 | 'nil)))))) 628 | 629 | (defun binary-op (rator rand1 rand2) 630 | (if (equal rator 'equal) 631 | (equal rand1 rand2) 632 | (if (equal rator 'cons) 633 | (cons rand1 rand2) 634 | (if (equal rator '+) 635 | (+ rand1 rand2) 636 | (if (equal rator '<) 637 | (< rand1 rand2) 638 | 'nil))))) 639 | 640 | (defun apply-op (rator rands) 641 | (if (member? rator '(atom car cdr natp size)) 642 | (unary-op rator (elem1 rands)) 643 | (if (member? rator '(equal cons + <)) 644 | (binary-op rator 645 | (elem1 rands) 646 | (elem2 rands)) 647 | 'nil))) 648 | 649 | (defun rands (args) 650 | (if (atom args) 651 | '() 652 | (cons (quote-value (car args)) 653 | (rands (cdr args))))) 654 | 655 | (defun eval-op (app) 656 | (quote-c 657 | (apply-op (app-name app) 658 | (rands (app-args app))))) 659 | 660 | (defun app-of-equal? (e) 661 | (if (app? e) 662 | (equal (app-name e) 'equal) 663 | 'nil)) 664 | 665 | (defun equality (focus a b) 666 | (if (equal focus a) 667 | b 668 | (if (equal focus b) 669 | a 670 | focus))) 671 | 672 | (defun equality-equation (focus concl-inst) 673 | (if (app-of-equal? concl-inst) 674 | (equality focus 675 | (elem1 (app-args concl-inst)) 676 | (elem2 (app-args concl-inst))) 677 | focus)) 678 | 679 | (defun equality-path (e path thm) 680 | (if (focus-is-at-path? path e) 681 | (rewrite-focus-at-path path e 682 | (equality-equation 683 | (find-focus-at-path path e) 684 | (follow-prems path e thm))) 685 | e)) 686 | 687 | (defun equality-def (claim path app def) 688 | (if (rator? def) 689 | (equality-path claim path 690 | (app-c 'equal (list2 app (eval-op app)))) 691 | (if (defun? def) 692 | (equality-path claim path 693 | (sub-e (defun-formals def) 694 | (app-args app) 695 | (app-c 'equal 696 | (list2 697 | (app-c (defun-name def) 698 | (defun-formals def)) 699 | (defun-body def))))) 700 | (if (dethm? def) 701 | (equality-path claim path 702 | (sub-e (dethm-formals def) 703 | (app-args app) 704 | (dethm-body def))) 705 | claim)))) 706 | 707 | (defun rewrite-step (defs claim step) 708 | (equality-def claim (elem1 step) (elem2 step) 709 | (lookup (app-name (elem2 step)) defs))) 710 | 711 | (defun rewrite-continue (defs steps old new) 712 | (if (equal new old) 713 | new 714 | (if (atom steps) 715 | new 716 | (rewrite-continue defs (cdr steps) new 717 | (rewrite-step defs new (car steps)))))) 718 | 719 | (defun rewrite-steps (defs claim steps) 720 | (if (atom steps) 721 | claim 722 | (rewrite-continue defs (cdr steps) claim 723 | (rewrite-step defs claim (car steps))))) 724 | 725 | (defun rewrite-prove (defs def seed steps) 726 | (if (defun? def) 727 | (rewrite-steps defs 728 | (totality-claim seed def) 729 | steps) 730 | (if (dethm? def) 731 | (rewrite-steps defs 732 | (induction-claim defs seed def) 733 | steps) 734 | (quote-c 'nil)))) 735 | 736 | (defun rewrite-prove+1 (defs pf e) 737 | (if (equal e (quote-c 't)) 738 | (rewrite-prove defs (elem1 pf) (elem2 pf) 739 | (cdr (cdr pf))) 740 | e)) 741 | 742 | (defun rewrite-prove+ (defs pfs) 743 | (if (atom pfs) 744 | (quote-c 't) 745 | (rewrite-prove+1 defs (car pfs) 746 | (rewrite-prove+ 747 | (list-extend defs (elem1 (car pfs))) 748 | (cdr pfs))))) 749 | 750 | (defun rewrite-define (defs def seed steps) 751 | (if (equal (rewrite-prove defs def seed steps) 752 | (quote-c 't)) 753 | (list-extend defs def) 754 | defs)) 755 | 756 | (defun rewrite-define+1 (defs1 defs2 pfs) 757 | (if (equal defs1 defs2) 758 | defs1 759 | (if (atom pfs) 760 | defs2 761 | (rewrite-define+1 defs2 762 | (rewrite-define defs2 763 | (elem1 (car pfs)) 764 | (elem2 (car pfs)) 765 | (cdr (cdr (car pfs)))) 766 | (cdr pfs))))) 767 | 768 | (defun rewrite-define+ (defs pfs) 769 | (if (atom pfs) 770 | defs 771 | (rewrite-define+1 defs 772 | (rewrite-define defs 773 | (elem1 (car pfs)) 774 | (elem2 (car pfs)) 775 | (cdr (cdr (car pfs)))) 776 | (cdr pfs)))) 777 | 778 | (defun J-Bob-step (defs e steps) 779 | (if (defs? '() defs) 780 | (if (expr? defs 'any e) 781 | (if (steps? defs steps) 782 | (rewrite-steps defs e steps) 783 | e) 784 | e) 785 | e)) 786 | 787 | (defun J-Bob-prove (defs pfs) 788 | (if (defs? '() defs) 789 | (if (proofs? defs pfs) 790 | (rewrite-prove+ defs pfs) 791 | (quote-c 'nil)) 792 | (quote-c 'nil))) 793 | 794 | (defun J-Bob-define (defs pfs) 795 | (if (defs? '() defs) 796 | (if (proofs? defs pfs) 797 | (rewrite-define+ defs pfs) 798 | defs) 799 | defs)) 800 | 801 | (defun axioms () 802 | '((dethm atom-cons (x y) 803 | (equal (atom (cons x y)) 'nil)) 804 | (dethm car-cons (x y) 805 | (equal (car (cons x y)) x)) 806 | (dethm cdr-cons (x y) 807 | (equal (cdr (cons x y)) y)) 808 | (dethm equal-same (x) 809 | (equal (equal x x) 't)) 810 | (dethm equal-swap (x y) 811 | (equal (equal x y) (equal y x))) 812 | (dethm if-same (x y) 813 | (equal (if x y y) y)) 814 | (dethm if-true (x y) 815 | (equal (if 't x y) x)) 816 | (dethm if-false (x y) 817 | (equal (if 'nil x y) y)) 818 | (dethm if-nest-e (x y z) 819 | (if x 't (equal (if x y z) z))) 820 | (dethm if-nest-a (x y z) 821 | (if x (equal (if x y z) y) 't)) 822 | (dethm cons-car+cdr (x) 823 | (if (atom x) 824 | 't 825 | (equal (cons (car x) (cdr x)) x))) 826 | (dethm equal-if (x y) 827 | (if (equal x y) (equal x y) 't)) 828 | (dethm natp-size (x) 829 | (equal (natp (size x)) 't)) 830 | (dethm size-car (x) 831 | (if (atom x) 832 | 't 833 | (equal (< (size (car x)) (size x)) 't))) 834 | (dethm size-cdr (x) 835 | (if (atom x) 836 | 't 837 | (equal (< (size (cdr x)) (size x)) 't))) 838 | (dethm associate-+ (a b c) 839 | (equal (+ (+ a b) c) (+ a (+ b c)))) 840 | (dethm commute-+ (x y) 841 | (equal (+ x y) (+ y x))) 842 | (dethm natp-+ (x y) 843 | (if (natp x) 844 | (if (natp y) 845 | (equal (natp (+ x y)) 't) 846 | 't) 847 | 't)) 848 | (dethm positives-+ (x y) 849 | (if (< '0 x) 850 | (if (< '0 y) 851 | (equal (< '0 (+ x y)) 't) 852 | 't) 853 | 't)) 854 | (dethm common-addends-< (x y z) 855 | (equal (< (+ x z) (+ y z)) (< x y))) 856 | (dethm identity-+ (x) 857 | (if (natp x) (equal (+ '0 x) x) 't)))) 858 | 859 | (defun prelude () 860 | (J-Bob-define (axioms) 861 | '(((defun list-induction (x) 862 | (if (atom x) 863 | '() 864 | (cons (car x) 865 | (list-induction (cdr x))))) 866 | (size x) 867 | ((A E) (size-cdr x)) 868 | ((A) (if-same (atom x) 't)) 869 | ((Q) (natp-size x)) 870 | (() (if-true 't 'nil))) 871 | ((defun star-induction (x) 872 | (if (atom x) 873 | x 874 | (cons (star-induction (car x)) 875 | (star-induction (cdr x))))) 876 | (size x) 877 | ((A E A) (size-cdr x)) 878 | ((A E Q) (size-car x)) 879 | ((A E) (if-true 't 'nil)) 880 | ((A) (if-same (atom x) 't)) 881 | ((Q) (natp-size x)) 882 | (() (if-true 't 'nil)))))) 883 | -------------------------------------------------------------------------------- /src/clj_bob/lang.clj: -------------------------------------------------------------------------------- 1 | (ns clj-bob.lang 2 | (:refer-clojure :exclude [atom cons + < num if]) 3 | (:require [clojure.string :as str])) 4 | 5 | (defn if-nil [q a e] 6 | (if (or (nil? q) 7 | (= 'nil q)) 8 | (e) 9 | (a))) 10 | 11 | (defn if 12 | [Q A E] 13 | (if-nil Q 14 | (fn [] A) 15 | (fn [] E))) 16 | 17 | (defrecord Pair [car cdr]) 18 | (defmethod print-method Pair [p writer] 19 | (.write writer (format "(%s . %s)" (:car p) (:cdr p)))) 20 | 21 | (defn s-car [x] 22 | (if (instance? Pair x) 23 | (:car x) 24 | (first x))) 25 | 26 | (defn s-cdr [x] 27 | (if (instance? Pair x) 28 | (:cdr x) 29 | (rest x))) 30 | 31 | (def s-+ clojure.core/+) 32 | (def s-< clojure.core/<) 33 | 34 | (defn cons [h t] 35 | (if (sequential? t) 36 | (apply list (concat [h] t)) 37 | (Pair. h t))) 38 | 39 | (defn equal 40 | "HAHAHAHA equality in Scheme is very weak." 41 | [x y] 42 | (= (str/lower-case x) 43 | (str/lower-case y))) 44 | 45 | (defn pair? [x] 46 | (or (instance? Pair x) 47 | (and (list? x) 48 | (seq x)))) 49 | 50 | ;; this is a bit different 51 | (defn num [x] 52 | (let [num-sym? #(re-find #"^\d+$" (str %))] 53 | (cond 54 | (number? x) x 55 | (num-sym? x) (Integer/parseInt (str x)) 56 | :else 0))) 57 | 58 | (defn atom [x] 59 | (if (pair? x) 60 | 'nil 61 | 't)) 62 | 63 | (defn car [x] 64 | (if (pair? x) 65 | (s-car x) 66 | ())) 67 | 68 | (defn cdr [x] 69 | (if (pair? x) 70 | (s-cdr x) 71 | ())) 72 | 73 | (defn equal [x y] 74 | (if (= x y) 75 | 't 76 | 'nil)) 77 | 78 | (defn < [x y] 79 | (if (s-< (num x) (num y)) 80 | 't 81 | 'nil)) 82 | 83 | (defn nat? [x] 84 | (if (and (integer? x) 85 | (< 0 x)) 86 | 't 87 | 'nil)) 88 | 89 | (def natp nat?) 90 | 91 | (defn + [x y] 92 | (s-+ (num x) (num y))) 93 | 94 | (defmacro defun 95 | [name args & body] 96 | `(defn ~name ~(vec args) ~@body)) 97 | 98 | (defmacro dethm 99 | [name args & body] 100 | `(defn ~name ~(vec args) ~@body)) 101 | 102 | (defn size [x] 103 | (if (atom x) 104 | 0 105 | (+ 1 (+ (size (car x)) (size (cdr x)))))) 106 | -------------------------------------------------------------------------------- /src/clj_bob/little_prover.clj: -------------------------------------------------------------------------------- 1 | (ns clj-bob.little-prover 2 | (:refer-clojure :exclude [cons num if + < atom bound? var?]) 3 | (:require [clj-bob.lang :refer :all] 4 | [clj-bob.j-bob :refer :all])) 5 | 6 | 7 | ;; Chapter 1 8 | 9 | (defun chapter1-example1 () 10 | (J-Bob-step (prelude) 11 | '(car (cons 'ham '(eggs))) 12 | '(((1) (cons 'ham '(eggs))) 13 | (() (car '(ham eggs)))))) 14 | 15 | (defun chapter1-example2 () 16 | (J-Bob-step (prelude) 17 | '(atom '()) 18 | '((() (atom '()))))) 19 | 20 | (defun chapter1-example3 () 21 | (J-Bob-step (prelude) 22 | '(atom (cons 'ham '(eggs))) 23 | '(((1) (cons 'ham '(eggs))) 24 | (() (atom '(ham eggs)))))) 25 | 26 | (defun chapter1-example4 () 27 | (J-Bob-step (prelude) 28 | '(atom (cons a b)) 29 | '((() (atom-cons a b))))) 30 | 31 | (defun chapter1-example5 () 32 | (J-Bob-step (prelude) 33 | '(equal 'flapjack (atom (cons a b))) 34 | '(((2) (atom-cons a b)) 35 | (() (equal 'flapjack 'nil))))) 36 | 37 | (defun chapter1-example6 () 38 | (J-Bob-step (prelude) 39 | '(atom (cdr (cons (car (cons p q)) '()))) 40 | '(((1 1 1) (car-cons p q)) 41 | ((1) (cdr-cons p '())) 42 | (() (atom '()))))) 43 | 44 | (defun chapter1-example7 () 45 | (J-Bob-step (prelude) 46 | '(atom (cdr (cons (car (cons p q)) '()))) 47 | '(((1) (cdr-cons (car (cons p q)) '())) 48 | (() (atom '()))))) 49 | 50 | (defun chapter1-example8 () 51 | (J-Bob-step (prelude) 52 | '(car (cons (equal (cons x y) (cons x y)) '(and crumpets))) 53 | '(((1 1) (equal-same (cons x y))) 54 | ((1) (cons 't '(and crumpets))) 55 | (() (car '(t and crumpets)))))) 56 | 57 | (defun chapter1-example9 () 58 | (J-Bob-step (prelude) 59 | '(equal (cons x y) (cons 'bagels '(and lox))) 60 | '((() (equal-swap (cons x y) (cons 'bagels '(and lox))))))) 61 | 62 | (defun chapter1-example10 () 63 | (J-Bob-step (prelude) 64 | '(cons y (equal (car (cons (cdr x) (car y))) (equal (atom x) 'nil))) 65 | '(((2 1) (car-cons (cdr x) (car y)))))) 66 | 67 | (defun chapter1-example11 () 68 | (J-Bob-step (prelude) 69 | '(cons y (equal (car (cons (cdr x) (car y))) (equal (atom x) 'nil))) 70 | '(((2 1) (car-cons (car (cons (cdr x) (car y))) '(oats))) 71 | ((2 2 2) (atom-cons (atom (cdr (cons a b))) (equal (cons a b) c))) 72 | ((2 2 2 1 1 1) (cdr-cons a b)) 73 | ((2 2 2 1 2) (equal-swap (cons a b) c))))) 74 | 75 | (defun chapter1-example12 () 76 | (J-Bob-step (prelude) 77 | '(atom (car (cons (car a) (cdr b)))) 78 | '(((1) (car-cons (car a) (cdr b)))))) 79 | 80 | ;; Chapter 2 81 | 82 | (defun chapter2-example1 () 83 | (J-Bob-step (prelude) 84 | '(if (car (cons a b)) c c) 85 | '(((Q) (car-cons a b)) 86 | (() (if-same a c)) 87 | (() 88 | (if-same 89 | (if (equal a 't) (if (equal 'nil 'nil) a b) (equal 'or (cons 'black '(coffee)))) 90 | c)) 91 | ((Q E 2) (cons 'black '(coffee))) 92 | ((Q A Q) (equal-same 'nil)) 93 | ((Q A) (if-true a b)) 94 | ((Q A) (equal-if a 't))))) 95 | 96 | (defun chapter2-example2 () 97 | (J-Bob-step (prelude) 98 | '(if (atom (car a)) 99 | (if (equal (car a) (cdr a)) 'hominy 'grits) 100 | (if (equal (cdr (car a)) '(hash browns)) 101 | (cons 'ketchup (car a)) 102 | (cons 'mustard (car a)))) 103 | '(((E A 2) (cons-car+cdr (car a))) 104 | ((E A 2 2) (equal-if (cdr (car a)) '(hash browns)))))) 105 | 106 | (defun chapter2-example3 () 107 | (J-Bob-step (prelude) 108 | '(cons 'statement 109 | (cons (if (equal a 'question) (cons n '(answer)) (cons n '(else))) 110 | (if (equal a 'question) (cons n '(other answer)) (cons n '(other else))))) 111 | '(((2) 112 | (if-same (equal a 'question) 113 | (cons (if (equal a 'question) (cons n '(answer)) (cons n '(else))) 114 | (if (equal a 'question) (cons n '(other answer)) (cons n '(other else)))))) 115 | ((2 A 1) (if-nest-A (equal a 'question) (cons n '(answer)) (cons n '(else)))) 116 | ((2 E 1) (if-nest-E (equal a 'question) (cons n '(answer)) (cons n '(else)))) 117 | ((2 A 2) 118 | (if-nest-A (equal a 'question) (cons n '(other answer)) (cons n '(other else)))) 119 | ((2 E 2) 120 | (if-nest-E (equal a 'question) 121 | (cons n '(other answer)) 122 | (cons n '(other else))))))) 123 | 124 | ;; Chapter 3 125 | 126 | (defun defun-pair () 127 | (J-Bob-define (prelude) 128 | '(((defun pair (x y) 129 | (cons x (cons y '()))) 130 | nil)))) 131 | 132 | (defun defun-first-of () 133 | (J-Bob-define (defun-pair) 134 | '(((defun first-of (x) 135 | (car x)) 136 | nil)))) 137 | 138 | (defun defun-second-of () 139 | (J-Bob-define (defun-first-of) 140 | '(((defun second-of (x) 141 | (car (cdr x))) 142 | nil)))) 143 | 144 | (defun dethm-first-of-pair () 145 | (J-Bob-define (defun-second-of) 146 | '(((dethm first-of-pair (a b) 147 | (equal (first-of (pair a b)) a)) 148 | nil 149 | ((1 1) (pair a b)) 150 | ((1) (first-of (cons a (cons b '())))) 151 | ((1) (car-cons a (cons b '()))) 152 | (() (equal-same a)))))) 153 | 154 | (defun dethm-second-of-pair () 155 | (J-Bob-define (dethm-first-of-pair) 156 | '(((dethm second-of-pair (a b) 157 | (equal (second-of (pair a b)) b)) 158 | nil 159 | ((1) (second-of (pair a b))) 160 | ((1 1 1) (pair a b)) 161 | ((1 1) (cdr-cons a (cons b '()))) 162 | ((1) (car-cons b '())) 163 | (() (equal-same b)))))) 164 | 165 | (defun defun-in-pair? () 166 | (J-Bob-define (dethm-second-of-pair) 167 | '(((defun in-pair? (xs) 168 | (if (equal (first-of xs) '?) 't (equal (second-of xs) '?))) 169 | nil)))) 170 | 171 | (defun dethm-in-first-of-pair () 172 | (J-Bob-define (defun-in-pair?) 173 | '(((dethm in-first-of-pair (b) 174 | (equal (in-pair? (pair '? b)) 't)) 175 | nil 176 | ((1 1) (pair '? b)) 177 | ((1) (in-pair? (cons '? (cons b '())))) 178 | ((1 Q 1) (first-of (cons '? (cons b '())))) 179 | ((1 Q 1) (car-cons '? (cons b '()))) 180 | ((1 Q) (equal-same '?)) 181 | ((1) (if-true 't (equal (second-of (cons '? (cons b '()))) '?))) 182 | (() (equal-same 't)))))) 183 | 184 | (defun dethm-in-second-of-pair () 185 | (J-Bob-define (dethm-in-first-of-pair) 186 | '(((dethm in-second-of-pair (a) 187 | (equal (in-pair? (pair a '?)) 't)) 188 | nil 189 | ((1 1) (pair a '?)) 190 | ((1) (in-pair? (cons a (cons '? '())))) 191 | ((1 Q 1) (first-of (cons a (cons '? '())))) 192 | ((1 Q 1) (car-cons a (cons '? '()))) 193 | ((1 E 1) (second-of (cons a (cons '? '())))) 194 | ((1 E 1 1) (cdr-cons a (cons '? '()))) 195 | ((1 E 1) (car-cons '? '())) 196 | ((1 E) (equal-same '?)) 197 | ((1) (if-same (equal a '?) 't)) 198 | (() (equal-same 't)))))) 199 | 200 | ;; Chapter 4 201 | 202 | (defun defun-list0? () 203 | (J-Bob-define (dethm-in-second-of-pair) 204 | '(((defun list0? (x) 205 | (equal x '())) 206 | nil)))) 207 | 208 | (defun defun-list1? () 209 | (J-Bob-define (defun-list0?) 210 | '(((defun list1? (x) 211 | (if (atom x) 'nil (list0? (cdr x)))) 212 | nil)))) 213 | 214 | (defun defun-list2? () 215 | (J-Bob-define (defun-list1?) 216 | '(((defun list2? (x) 217 | (if (atom x) 'nil (list1? (cdr x)))) 218 | nil)))) 219 | 220 | (defun dethm-contradiction () 221 | (J-Bob-prove 222 | (list-extend (prelude) 223 | '(defun partial (x) 224 | (if (partial x) 'nil 't))) 225 | '(((dethm contradiction () 'nil) 226 | nil 227 | (() (if-same (partial x) 'nil)) 228 | ((A) (if-nest-A (partial x) 'nil 't)) 229 | ((E) (if-nest-E (partial x) 't 'nil)) 230 | ((A Q) (partial x)) 231 | ((E Q) (partial x)) 232 | ((A Q) (if-nest-A (partial x) 'nil 't)) 233 | ((E Q) (if-nest-E (partial x) 'nil 't)) 234 | ((A) (if-false 'nil 't)) 235 | ((E) (if-true 't 'nil)) 236 | (() (if-same (partial x) 't)))))) 237 | 238 | (defun defun-list? () 239 | (J-Bob-define (defun-list2?) 240 | '(((defun list? (x) 241 | (if (atom x) (equal x '()) (list? (cdr x)))) 242 | (size x) 243 | ((Q) (natp-size x)) 244 | (() (if-true (if (atom x) 't (< (size (cdr x)) (size x))) 'nil)) 245 | ((E) (size-cdr x)) 246 | (() (if-same (atom x) 't)))))) 247 | 248 | (defun defun-sub () 249 | (J-Bob-define (defun-list?) 250 | '(((defun sub (x y) 251 | (if (atom y) (if (equal y '?) x y) (cons (sub x (car y)) (sub x (cdr y))))) 252 | (size y) 253 | ((Q) (natp-size y)) 254 | (() 255 | (if-true 256 | (if (atom y) 257 | 't 258 | (if (< (size (car y)) (size y)) (< (size (cdr y)) (size y)) 'nil)) 259 | 'nil)) 260 | ((E Q) (size-car y)) 261 | ((E A) (size-cdr y)) 262 | ((E) (if-true 't 'nil)) 263 | (() (if-same (atom y) 't)))))) 264 | 265 | ;; Chapter 5 266 | 267 | (defun defun-memb? () 268 | (J-Bob-define (defun-sub) 269 | '(((defun memb? (xs) 270 | (if (atom xs) 'nil (if (equal (car xs) '?) 't (memb? (cdr xs))))) 271 | (size xs) 272 | ((Q) (natp-size xs)) 273 | (() 274 | (if-true 275 | (if (atom xs) 't (if (equal (car xs) '?) 't (< (size (cdr xs)) (size xs)))) 276 | 'nil)) 277 | ((E E) (size-cdr xs)) 278 | ((E) (if-same (equal (car xs) '?) 't)) 279 | (() (if-same (atom xs) 't)))))) 280 | 281 | (defun defun-remb () 282 | (J-Bob-define (defun-memb?) 283 | '(((defun remb (xs) 284 | (if (atom xs) 285 | '() 286 | (if (equal (car xs) '?) (remb (cdr xs)) (cons (car xs) (remb (cdr xs)))))) 287 | (size xs) 288 | ((Q) (natp-size xs)) 289 | (() (if-true (if (atom xs) 't (< (size (cdr xs)) (size xs))) 'nil)) 290 | ((E) (size-cdr xs)) 291 | (() (if-same (atom xs) 't)))))) 292 | 293 | (defun dethm-memb?-remb0 () 294 | (J-Bob-define (defun-remb) 295 | '(((dethm memb?-remb0 () 296 | (equal (memb? (remb '())) 'nil)) 297 | nil 298 | ((1 1) (remb '())) 299 | ((1 1 Q) (atom '())) 300 | ((1 1) 301 | (if-true '() 302 | (if (equal (car '()) '?) (remb (cdr '())) (cons (car '()) (remb (cdr '())))))) 303 | ((1) (memb? '())) 304 | ((1 Q) (atom '())) 305 | ((1) (if-true 'nil (if (equal (car '()) '?) 't (memb? (cdr '()))))) 306 | (() (equal-same 'nil)))))) 307 | 308 | (defun dethm-memb?-remb1 () 309 | (J-Bob-define (dethm-memb?-remb0) 310 | '(((dethm memb?-remb1 (x1) 311 | (equal (memb? (remb (cons x1 '()))) 'nil)) 312 | nil 313 | ((1 1) (remb (cons x1 '()))) 314 | ((1 1 Q) (atom-cons x1 '())) 315 | ((1 1) 316 | (if-false '() 317 | (if (equal (car (cons x1 '())) '?) 318 | (remb (cdr (cons x1 '()))) 319 | (cons (car (cons x1 '())) (remb (cdr (cons x1 '()))))))) 320 | ((1 1 Q 1) (car-cons x1 '())) 321 | ((1 1 A 1) (cdr-cons x1 '())) 322 | ((1 1 E 1) (car-cons x1 '())) 323 | ((1 1 E 2 1) (cdr-cons x1 '())) 324 | ((1) 325 | (if-same (equal x1 '?) 326 | (memb? (if (equal x1 '?) (remb '()) (cons x1 (remb '())))))) 327 | ((1 A 1) (if-nest-A (equal x1 '?) (remb '()) (cons x1 (remb '())))) 328 | ((1 E 1) (if-nest-E (equal x1 '?) (remb '()) (cons x1 (remb '())))) 329 | ((1 A) (memb?-remb0)) 330 | ((1 E) (memb? (cons x1 (remb '())))) 331 | ((1 E Q) (atom-cons x1 (remb '()))) 332 | ((1 E) 333 | (if-false 'nil 334 | (if (equal (car (cons x1 (remb '()))) '?) 335 | 't 336 | (memb? (cdr (cons x1 (remb '()))))))) 337 | ((1 E Q 1) (car-cons x1 (remb '()))) 338 | ((1 E E 1) (cdr-cons x1 (remb '()))) 339 | ((1 E) (if-nest-E (equal x1 '?) 't (memb? (remb '())))) 340 | ((1 E) (memb?-remb0)) 341 | ((1) (if-same (equal x1 '?) 'nil)) 342 | (() (equal-same 'nil)))))) 343 | 344 | (defun dethm-memb?-remb2 () 345 | (J-Bob-define (dethm-memb?-remb1) 346 | '(((dethm memb?-remb2 (x1 x2) 347 | (equal (memb? (remb (cons x2 (cons x1 '())))) 'nil)) 348 | nil 349 | ((1 1) (remb (cons x2 (cons x1 '())))) 350 | ((1 1 Q) (atom-cons x2 (cons x1 '()))) 351 | ((1 1) 352 | (if-false '() 353 | (if (equal (car (cons x2 (cons x1 '()))) '?) 354 | (remb (cdr (cons x2 (cons x1 '())))) 355 | (cons (car (cons x2 (cons x1 '()))) 356 | (remb (cdr (cons x2 (cons x1 '())))))))) 357 | ((1 1 Q 1) (car-cons x2 (cons x1 '()))) 358 | ((1 1 A 1) (cdr-cons x2 (cons x1 '()))) 359 | ((1 1 E 1) (car-cons x2 (cons x1 '()))) 360 | ((1 1 E 2 1) (cdr-cons x2 (cons x1 '()))) 361 | ((1) 362 | (if-same (equal x2 '?) 363 | (memb? 364 | (if (equal x2 '?) (remb (cons x1 '())) (cons x2 (remb (cons x1 '()))))))) 365 | ((1 A 1) 366 | (if-nest-A (equal x2 '?) (remb (cons x1 '())) (cons x2 (remb (cons x1 '()))))) 367 | ((1 E 1) 368 | (if-nest-E (equal x2 '?) (remb (cons x1 '())) (cons x2 (remb (cons x1 '()))))) 369 | ((1 A) (memb?-remb1 x1)) 370 | ((1 E) (memb? (cons x2 (remb (cons x1 '()))))) 371 | ((1 E Q) (atom-cons x2 (remb (cons x1 '())))) 372 | ((1 E) 373 | (if-false 'nil 374 | (if (equal (car (cons x2 (remb (cons x1 '())))) '?) 375 | 't 376 | (memb? (cdr (cons x2 (remb (cons x1 '())))))))) 377 | ((1 E Q 1) (car-cons x2 (remb (cons x1 '())))) 378 | ((1 E E 1) (cdr-cons x2 (remb (cons x1 '())))) 379 | ((1 E) (if-nest-E (equal x2 '?) 't (memb? (remb (cons x1 '()))))) 380 | ((1 E) (memb?-remb1 x1)) 381 | ((1) (if-same (equal x2 '?) 'nil)) 382 | (() (equal-same 'nil)))))) 383 | 384 | ;; Chapter 6 385 | 386 | (defun dethm-memb?-remb () 387 | (J-Bob-define (dethm-memb?-remb2) 388 | '(((dethm memb?-remb (xs) 389 | (equal (memb? (remb xs)) 'nil)) 390 | (list-induction xs) 391 | ((A 1 1) (remb xs)) 392 | ((A 1 1) 393 | (if-nest-A (atom xs) 394 | '() 395 | (if (equal (car xs) '?) (remb (cdr xs)) (cons (car xs) (remb (cdr xs)))))) 396 | ((A 1) (memb? '())) 397 | ((A 1 Q) (atom '())) 398 | ((A 1) (if-true 'nil (if (equal (car '()) '?) 't (memb? (cdr '()))))) 399 | ((A) (equal-same 'nil)) 400 | ((E A 1 1) (remb xs)) 401 | ((E A 1 1) 402 | (if-nest-E (atom xs) 403 | '() 404 | (if (equal (car xs) '?) (remb (cdr xs)) (cons (car xs) (remb (cdr xs)))))) 405 | ((E A 1) 406 | (if-same (equal (car xs) '?) 407 | (memb? 408 | (if (equal (car xs) '?) (remb (cdr xs)) (cons (car xs) (remb (cdr xs))))))) 409 | ((E A 1 A 1) 410 | (if-nest-A (equal (car xs) '?) (remb (cdr xs)) (cons (car xs) (remb (cdr xs))))) 411 | ((E A 1 E 1) 412 | (if-nest-E (equal (car xs) '?) (remb (cdr xs)) (cons (car xs) (remb (cdr xs))))) 413 | ((E A 1 A) (equal-if (memb? (remb (cdr xs))) 'nil)) 414 | ((E A 1 E) (memb? (cons (car xs) (remb (cdr xs))))) 415 | ((E A 1 E Q) (atom-cons (car xs) (remb (cdr xs)))) 416 | ((E A 1 E) 417 | (if-false 'nil 418 | (if (equal (car (cons (car xs) (remb (cdr xs)))) '?) 419 | 't 420 | (memb? (cdr (cons (car xs) (remb (cdr xs)))))))) 421 | ((E A 1 E Q 1) (car-cons (car xs) (remb (cdr xs)))) 422 | ((E A 1 E E 1) (cdr-cons (car xs) (remb (cdr xs)))) 423 | ((E A 1 E) (if-nest-E (equal (car xs) '?) 't (memb? (remb (cdr xs))))) 424 | ((E A 1 E) (equal-if (memb? (remb (cdr xs))) 'nil)) 425 | ((E A 1) (if-same (equal (car xs) '?) 'nil)) 426 | ((E A) (equal-same 'nil)) 427 | ((E) (if-same (equal (memb? (remb (cdr xs))) 'nil) 't)) 428 | (() (if-same (atom xs) 't)))))) 429 | 430 | ;; Chapter 7 431 | 432 | (defun defun-ctx? () 433 | (J-Bob-define (dethm-memb?-remb) 434 | '(((defun ctx? (x) 435 | (if (atom x) (equal x '?) (if (ctx? (car x)) 't (ctx? (cdr x))))) 436 | (size x) 437 | ((Q) (natp-size x)) 438 | (() 439 | (if-true 440 | (if (atom x) 441 | 't 442 | (if (< (size (car x)) (size x)) 443 | (if (ctx? (car x)) 't (< (size (cdr x)) (size x))) 444 | 'nil)) 445 | 'nil)) 446 | ((E Q) (size-car x)) 447 | ((E A E) (size-cdr x)) 448 | ((E A) (if-same (ctx? (car x)) 't)) 449 | ((E) (if-true 't 'nil)) 450 | (() (if-same (atom x) 't)))))) 451 | 452 | ;; Too large! gotta break this up. 453 | (def ctx?-sub-pt1 454 | '((dethm ctx?-t (x) 455 | (if (ctx? x) (equal (ctx? x) 't) 't)) 456 | (star-induction x) 457 | ((A A 1) (ctx? x)) 458 | ((A A 1) (if-nest-A (atom x) (equal x '?) (if (ctx? (car x)) 't (ctx? (cdr x))))) 459 | ((A Q) (ctx? x)) 460 | ((A Q) (if-nest-A (atom x) (equal x '?) (if (ctx? (car x)) 't (ctx? (cdr x))))) 461 | ((A A 1 1) (equal-if x '?)) 462 | ((A A 1) (equal-same '?)) 463 | ((A A) (equal-same 't)) 464 | ((A) (if-same (equal x '?) 't)) 465 | ((E A A A 1) (ctx? x)) 466 | ((E A A A 1) 467 | (if-nest-E (atom x) (equal x '?) (if (ctx? (car x)) 't (ctx? (cdr x))))) 468 | ((E) 469 | (if-same (ctx? (car x)) 470 | (if (if (ctx? (car x)) (equal (ctx? (car x)) 't) 't) 471 | (if (if (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't) 472 | (if (ctx? x) (equal (if (ctx? (car x)) 't (ctx? (cdr x))) 't) 't) 473 | 't) 474 | 't))) 475 | ((E A Q) (if-nest-A (ctx? (car x)) (equal (ctx? (car x)) 't) 't)) 476 | ((E A A A A 1) (if-nest-A (ctx? (car x)) 't (ctx? (cdr x)))) 477 | ((E E Q) (if-nest-E (ctx? (car x)) (equal (ctx? (car x)) 't) 't)) 478 | ((E E A A A 1) (if-nest-E (ctx? (car x)) 't (ctx? (cdr x)))) 479 | ((E A A A A) (equal-same 't)) 480 | ((E E) 481 | (if-true 482 | (if (if (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't) 483 | (if (ctx? x) (equal (ctx? (cdr x)) 't) 't) 484 | 't) 485 | 't)) 486 | ((E A A A) (if-same (ctx? x) 't)) 487 | ((E A A) (if-same (if (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't) 't)) 488 | ((E A) (if-same (equal (ctx? (car x)) 't) 't)) 489 | ((E E A Q) (ctx? x)) 490 | ((E E A Q) 491 | (if-nest-E (atom x) (equal x '?) (if (ctx? (car x)) 't (ctx? (cdr x))))) 492 | ((E E A Q) (if-nest-E (ctx? (car x)) 't (ctx? (cdr x)))) 493 | ((E E) 494 | (if-same (ctx? (cdr x)) 495 | (if (if (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't) 496 | (if (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't) 497 | 't))) 498 | ((E E A Q)(if-nest-A (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't)) 499 | ((E E A A)(if-nest-A (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't)) 500 | ((E E E Q)(if-nest-E (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't)) 501 | ((E E E A)(if-nest-E (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't)) 502 | ((E E E) (if-same 't 't)) 503 | ((E E A A 1) (equal-if (ctx? (cdr x)) 't)) 504 | ((E E A A) (equal-same 't)) 505 | ((E E A) (if-same (equal (ctx? (cdr x)) 't) 't)) 506 | ((E E) (if-same (ctx? (cdr x)) 't)) 507 | ((E) (if-same (ctx? (car x)) 't)) 508 | (() (if-same (atom x) 't)))) 509 | 510 | (def ctx?-sub-pt2 511 | '((dethm ctx?-sub (x y) 512 | (if (ctx? x) (if (ctx? y) (equal (ctx? (sub x y)) 't) 't) 't)) 513 | (star-induction y) 514 | (() 515 | (if-same (ctx? x) 516 | (if (atom y) 517 | (if (ctx? x) (if (ctx? y) (equal (ctx? (sub x y)) 't) 't) 't) 518 | (if (if (ctx? x) 519 | (if (ctx? (car y)) (equal (ctx? (sub x (car y))) 't) 't) 520 | 't) 521 | (if (if (ctx? x) 522 | (if (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't) 523 | 't) 524 | (if (ctx? x) (if (ctx? y) (equal (ctx? (sub x y)) 't) 't) 't) 525 | 't) 526 | 't)))) 527 | ((A A) (if-nest-A (ctx? x) (if (ctx? y) (equal (ctx? (sub x y)) 't) 't) 't)) 528 | ((A E Q) 529 | (if-nest-A (ctx? x) (if (ctx? (car y)) (equal (ctx? (sub x (car y))) 't) 't) 't)) 530 | ((A E A Q) 531 | (if-nest-A (ctx? x) (if (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't) 't)) 532 | ((A E A A) (if-nest-A (ctx? x) (if (ctx? y) (equal (ctx? (sub x y)) 't) 't) 't)) 533 | ((E A) (if-nest-E (ctx? x) (if (ctx? y) (equal (ctx? (sub x y)) 't) 't) 't)) 534 | ((E E Q) 535 | (if-nest-E (ctx? x) (if (ctx? (car y)) (equal (ctx? (sub x (car y))) 't) 't) 't)) 536 | ((E E A Q) 537 | (if-nest-E (ctx? x) (if (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't) 't)) 538 | ((E E A A) (if-nest-E (ctx? x) (if (ctx? y) (equal (ctx? (sub x y)) 't) 't) 't)) 539 | ((E E A) (if-same 't 't)) 540 | ((E E) (if-same 't 't)) 541 | ((E) (if-same (atom y) 't)) 542 | ((A A A 1 1) (sub x y)) 543 | ((A A A 1 1) 544 | (if-nest-A (atom y) 545 | (if (equal y '?) x y) 546 | (cons (sub x (car y)) (sub x (cdr y))))) 547 | ((A A A) (if-same (equal y '?) (equal (ctx? (if (equal y '?) x y)) 't))) 548 | ((A A A A 1 1) (if-nest-A (equal y '?) x y)) 549 | ((A A A E 1 1) (if-nest-E (equal y '?) x y)) 550 | ((A A A A 1) (ctx?-t x)) 551 | ((A A A A) (equal-same 't)) 552 | ((A A A E 1) (ctx?-t y)) 553 | ((A A A E) (equal-same 't)) 554 | ((A A A) (if-same (equal y '?) 't)) 555 | ((A A) (if-same (ctx? y) 't)) 556 | ((A E A A A 1 1) (sub x y)) 557 | ((A E A A A 1 1) 558 | (if-nest-E (atom y) 559 | (if (equal y '?) x y) 560 | (cons (sub x (car y)) (sub x (cdr y))))) 561 | ((A E A A A 1) (ctx? (cons (sub x (car y)) (sub x (cdr y))))) 562 | ((A E A A A 1 Q) (atom-cons (sub x (car y)) (sub x (cdr y)))) 563 | ((A E A A A 1 E Q 1) (car-cons (sub x (car y)) (sub x (cdr y)))) 564 | ((A E A A A 1 E E 1) (cdr-cons (sub x (car y)) (sub x (cdr y)))) 565 | ((A E A A A 1) 566 | (if-false (equal (cons (sub x (car y)) (sub x (cdr y))) '?) 567 | (if (ctx? (sub x (car y))) 't (ctx? (sub x (cdr y)))))) 568 | ((A E A A Q) (ctx? y)) 569 | ((A E A A Q) 570 | (if-nest-E (atom y) (equal y '?) (if (ctx? (car y)) 't (ctx? (cdr y))))) 571 | ((A E) 572 | (if-same (ctx? (car y)) 573 | (if (if (ctx? (car y)) (equal (ctx? (sub x (car y))) 't) 't) 574 | (if (if (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't) 575 | (if (if (ctx? (car y)) 't (ctx? (cdr y))) 576 | (equal (if (ctx? (sub x (car y))) 't (ctx? (sub x (cdr y)))) 't) 577 | 't) 578 | 't) 579 | 't))) 580 | ((A E A Q) (if-nest-A (ctx? (car y)) (equal (ctx? (sub x (car y))) 't) 't)) 581 | ((A E A A A Q) (if-nest-A (ctx? (car y)) 't (ctx? (cdr y)))) 582 | ((A E E Q) (if-nest-E (ctx? (car y)) (equal (ctx? (sub x (car y))) 't) 't)) 583 | ((A E E A A Q) (if-nest-E (ctx? (car y)) 't (ctx? (cdr y)))) 584 | ((A E A A A) 585 | (if-true (equal (if (ctx? (sub x (car y))) 't (ctx? (sub x (cdr y)))) 't) 't)) 586 | ((A E E) 587 | (if-true 588 | (if (if (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't) 589 | (if (ctx? (cdr y)) 590 | (equal (if (ctx? (sub x (car y))) 't (ctx? (sub x (cdr y)))) 't) 591 | 't) 592 | 't) 593 | 't)) 594 | ((A E A A A 1 Q) (equal-if (ctx? (sub x (car y))) 't)) 595 | ((A E A A A 1) (if-true 't (ctx? (sub x (cdr y))))) 596 | ((A E A A A) (equal-same 't)) 597 | ((A E A A) (if-same (if (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't) 't)) 598 | ((A E A) (if-same (equal (ctx? (sub x (car y))) 't) 't)) 599 | ((A E E) 600 | (if-same (ctx? (cdr y)) 601 | (if (if (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't) 602 | (if (ctx? (cdr y)) 603 | (equal (if (ctx? (sub x (car y))) 't (ctx? (sub x (cdr y)))) 't) 604 | 't) 605 | 't))) 606 | ((A E E A Q) (if-nest-A (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't)) 607 | ((A E E A A) 608 | (if-nest-A (ctx? (cdr y)) 609 | (equal (if (ctx? (sub x (car y))) 't (ctx? (sub x (cdr y)))) 't) 610 | 't)) 611 | ((A E E E Q) (if-nest-E (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't)) 612 | ((A E E E A) 613 | (if-nest-E (ctx? (cdr y)) 614 | (equal (if (ctx? (sub x (car y))) 't (ctx? (sub x (cdr y)))) 't) 615 | 't)) 616 | ((A E E E) (if-same 't 't)) 617 | ((A E E A A 1 E) (equal-if (ctx? (sub x (cdr y))) 't)) 618 | ((A E E A A 1) (if-same (ctx? (sub x (car y))) 't)) 619 | ((A E E A A) (equal-same 't)) 620 | ((A E E A) (if-same (equal (ctx? (sub x (cdr y))) 't) 't)) 621 | ((A E E) (if-same (ctx? (cdr y)) 't)) 622 | ((A E) (if-same (ctx? (car y)) 't)) 623 | ((A) (if-same (atom y) 't)) 624 | (() (if-same (ctx? x) 't)))) 625 | 626 | (defun dethm-ctx?-sub () 627 | (J-Bob-define (defun-ctx?) 628 | (concat 629 | ctx?-sub-pt1 630 | ctx?-sub-pt2))) 631 | 632 | ;; Chapter 8 633 | 634 | (defun defun-member? () 635 | (J-Bob-define (dethm-ctx?-sub) 636 | '(((defun member? (x ys) 637 | (if (atom ys) 'nil (if (equal x (car ys)) 't (member? x (cdr ys))))) 638 | (size ys) 639 | ((Q) (natp-size ys)) 640 | (() 641 | (if-true 642 | (if (atom ys) 't (if (equal x (car ys)) 't (< (size (cdr ys)) (size ys)))) 643 | 'nil)) 644 | ((E E) (size-cdr ys)) 645 | ((E) (if-same (equal x (car ys)) 't)) 646 | (() (if-same (atom ys) 't)))))) 647 | 648 | (defun defun-set? () 649 | (J-Bob-define (defun-member?) 650 | '(((defun set? (xs) 651 | (if (atom xs) 't (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))))) 652 | (size xs) 653 | ((Q) (natp-size xs)) 654 | (() 655 | (if-true 656 | (if (atom xs) 657 | 't 658 | (if (member? (car xs) (cdr xs)) 't (< (size (cdr xs)) (size xs)))) 659 | 'nil)) 660 | ((E E) (size-cdr xs)) 661 | ((E) (if-same (member? (car xs) (cdr xs)) 't)) 662 | (() (if-same (atom xs) 't)))))) 663 | 664 | (defun defun-add-atoms () 665 | (J-Bob-define (defun-set?) 666 | '(((defun add-atoms (x ys) 667 | (if (atom x) 668 | (if (member? x ys) ys (cons x ys)) 669 | (add-atoms (car x) (add-atoms (cdr x) ys)))) 670 | (size x) 671 | ((Q) (natp-size x)) 672 | (() 673 | (if-true 674 | (if (atom x) 675 | 't 676 | (if (< (size (car x)) (size x)) (< (size (cdr x)) (size x)) 'nil)) 677 | 'nil)) 678 | ((E Q) (size-car x)) 679 | ((E A) (size-cdr x)) 680 | ((E) (if-true 't 'nil)) 681 | (() (if-same (atom x) 't)))))) 682 | 683 | (defun defun-atoms () 684 | (J-Bob-define (defun-add-atoms) 685 | '(((defun atoms (x) 686 | (add-atoms x '())) 687 | nil)))) 688 | 689 | (defun dethm-set?-atoms-attempt () 690 | (J-Bob-prove (defun-atoms) 691 | '(((dethm set?-add-atoms (a) 692 | (equal (set? (add-atoms a '())) 't)) 693 | (star-induction a) 694 | ((E A A 1 1) (add-atoms a '()))) 695 | ((dethm set?-atoms (a) 696 | (equal (set? (atoms a)) 't)) 697 | nil 698 | ((1 1) (atoms a)) 699 | ((1) (set?-add-atoms a)) 700 | (() (equal-same 't)))))) 701 | 702 | (defun dethm-set?-atoms () 703 | (J-Bob-define (defun-atoms) 704 | '(((dethm set?-t (xs) 705 | (if (set? xs) (equal (set? xs) 't) 't)) 706 | (list-induction xs) 707 | ((A A 1) (set? xs)) 708 | ((A A 1) 709 | (if-nest-A (atom xs) 't (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))))) 710 | ((A A) (equal-same 't)) 711 | ((A) (if-same (set? xs) 't)) 712 | ((E A A 1) (set? xs)) 713 | ((E A A 1) 714 | (if-nest-E (atom xs) 't (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))))) 715 | ((E A Q) (set? xs)) 716 | ((E A Q) 717 | (if-nest-E (atom xs) 't (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))))) 718 | ((E A) 719 | (if-same (member? (car xs) (cdr xs)) 720 | (if (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))) 721 | (equal (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))) 't) 722 | 't))) 723 | ((E A A Q) (if-nest-A (member? (car xs) (cdr xs)) 'nil (set? (cdr xs)))) 724 | ((E A A A 1) (if-nest-A (member? (car xs) (cdr xs)) 'nil (set? (cdr xs)))) 725 | ((E A E Q) (if-nest-E (member? (car xs) (cdr xs)) 'nil (set? (cdr xs)))) 726 | ((E A E A 1) (if-nest-E (member? (car xs) (cdr xs)) 'nil (set? (cdr xs)))) 727 | ((E A A) (if-false (equal 'nil 't) 't)) 728 | ((E) 729 | (if-same (set? (cdr xs)) 730 | (if (if (set? (cdr xs)) (equal (set? (cdr xs)) 't) 't) 731 | (if (member? (car xs) (cdr xs)) 732 | 't 733 | (if (set? (cdr xs)) (equal (set? (cdr xs)) 't) 't)) 734 | 't))) 735 | ((E A Q) (if-nest-A (set? (cdr xs)) (equal (set? (cdr xs)) 't) 't)) 736 | ((E A A E) (if-nest-A (set? (cdr xs)) (equal (set? (cdr xs)) 't) 't)) 737 | ((E E Q) (if-nest-E (set? (cdr xs)) (equal (set? (cdr xs)) 't) 't)) 738 | ((E E A E) (if-nest-E (set? (cdr xs)) (equal (set? (cdr xs)) 't) 't)) 739 | ((E E A) (if-same (member? (car xs) (cdr xs)) 't)) 740 | ((E E) (if-same 't 't)) 741 | ((E A A E 1) (equal-if (set? (cdr xs)) 't)) 742 | ((E A A E) (equal-same 't)) 743 | ((E A A) (if-same (member? (car xs) (cdr xs)) 't)) 744 | ((E A) (if-same (equal (set? (cdr xs)) 't) 't)) 745 | ((E) (if-same (set? (cdr xs)) 't)) 746 | (() (if-same (atom xs) 't))) 747 | ((dethm set?-nil (xs) 748 | (if (set? xs) 't (equal (set? xs) 'nil))) 749 | (list-induction xs) 750 | ((A Q) (set? xs)) 751 | ((A Q) 752 | (if-nest-A (atom xs) 't (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))))) 753 | ((A) (if-true 't (equal (set? xs) 'nil))) 754 | ((E A E 1) (set? xs)) 755 | ((E A E 1) 756 | (if-nest-E (atom xs) 't (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))))) 757 | ((E A Q) (set? xs)) 758 | ((E A Q) 759 | (if-nest-E (atom xs) 't (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))))) 760 | ((E A) 761 | (if-same (member? (car xs) (cdr xs)) 762 | (if (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))) 763 | 't 764 | (equal (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))) 'nil)))) 765 | ((E A A Q) (if-nest-A (member? (car xs) (cdr xs)) 'nil (set? (cdr xs)))) 766 | ((E A A E 1) (if-nest-A (member? (car xs) (cdr xs)) 'nil (set? (cdr xs)))) 767 | ((E A E Q) (if-nest-E (member? (car xs) (cdr xs)) 'nil (set? (cdr xs)))) 768 | ((E A E E 1) (if-nest-E (member? (car xs) (cdr xs)) 'nil (set? (cdr xs)))) 769 | ((E A A E) (equal-same 'nil)) 770 | ((E A A) (if-same 'nil 't)) 771 | ((E) 772 | (if-same (set? (cdr xs)) 773 | (if (if (set? (cdr xs)) 't (equal (set? (cdr xs)) 'nil)) 774 | (if (member? (car xs) (cdr xs)) 775 | 't 776 | (if (set? (cdr xs)) 't (equal (set? (cdr xs)) 'nil))) 777 | 't))) 778 | ((E A Q) (if-nest-A (set? (cdr xs)) 't (equal (set? (cdr xs)) 'nil))) 779 | ((E A A E) (if-nest-A (set? (cdr xs)) 't (equal (set? (cdr xs)) 'nil))) 780 | ((E E Q) (if-nest-E (set? (cdr xs)) 't (equal (set? (cdr xs)) 'nil))) 781 | ((E E A E) (if-nest-E (set? (cdr xs)) 't (equal (set? (cdr xs)) 'nil))) 782 | ((E A A) (if-same (member? (car xs) (cdr xs)) 't)) 783 | ((E A) (if-same 't 't)) 784 | ((E E A E 1) (equal-if (set? (cdr xs)) 'nil)) 785 | ((E E A E) (equal-same 'nil)) 786 | ((E E A) (if-same (member? (car xs) (cdr xs)) 't)) 787 | ((E E) (if-same (equal (set? (cdr xs)) 'nil) 't)) 788 | ((E) (if-same (set? (cdr xs)) 't)) 789 | (() (if-same (atom xs) 't))) 790 | ((dethm set?-add-atoms (a bs) 791 | (if (set? bs) (equal (set? (add-atoms a bs)) 't) 't)) 792 | (add-atoms a bs) 793 | ((A A 1 1) (add-atoms a bs)) 794 | ((A A 1 1) 795 | (if-nest-A (atom a) 796 | (if (member? a bs) bs (cons a bs)) 797 | (add-atoms (car a) (add-atoms (cdr a) bs)))) 798 | ((A A 1) (if-same (member? a bs) (set? (if (member? a bs) bs (cons a bs))))) 799 | ((A A 1 A 1) (if-nest-A (member? a bs) bs (cons a bs))) 800 | ((A A 1 E 1) (if-nest-E (member? a bs) bs (cons a bs))) 801 | ((A A 1 A) (set?-t bs)) 802 | ((A A 1 E) (set? (cons a bs))) 803 | ((A A 1 E Q) (atom-cons a bs)) 804 | ((A A 1 E E Q 1) (car-cons a bs)) 805 | ((A A 1 E E Q 2) (cdr-cons a bs)) 806 | ((A A 1 E E E 1) (cdr-cons a bs)) 807 | ((A A 1 E) (if-false 't (if (member? a bs) 'nil (set? bs)))) 808 | ((A A 1 E) (if-nest-E (member? a bs) 'nil (set? bs))) 809 | ((A A 1 E) (set?-t bs)) 810 | ((A A 1) (if-same (member? a bs) 't)) 811 | ((A A) (equal-same 't)) 812 | ((A) (if-same (set? bs) 't)) 813 | ((E) 814 | (if-same (set? bs) 815 | (if (if (set? (add-atoms (cdr a) bs)) 816 | (equal (set? (add-atoms (car a) (add-atoms (cdr a) bs))) 't) 817 | 't) 818 | (if (if (set? bs) (equal (set? (add-atoms (cdr a) bs)) 't) 't) 819 | (if (set? bs) (equal (set? (add-atoms a bs)) 't) 't) 820 | 't) 821 | 't))) 822 | ((E A A Q) (if-nest-A (set? bs) (equal (set? (add-atoms (cdr a) bs)) 't) 't)) 823 | ((E A A A) (if-nest-A (set? bs) (equal (set? (add-atoms a bs)) 't) 't)) 824 | ((E E A Q) (if-nest-E (set? bs) (equal (set? (add-atoms (cdr a) bs)) 't) 't)) 825 | ((E E A A) (if-nest-E (set? bs) (equal (set? (add-atoms a bs)) 't) 't)) 826 | ((E E A) (if-same 't 't)) 827 | ((E E) 828 | (if-same 829 | (if (set? (add-atoms (cdr a) bs)) 830 | (equal (set? (add-atoms (car a) (add-atoms (cdr a) bs))) 't) 831 | 't) 832 | 't)) 833 | ((E A) 834 | (if-same (set? (add-atoms (cdr a) bs)) 835 | (if (if (set? (add-atoms (cdr a) bs)) 836 | (equal (set? (add-atoms (car a) (add-atoms (cdr a) bs))) 't) 837 | 't) 838 | (if (equal (set? (add-atoms (cdr a) bs)) 't) 839 | (equal (set? (add-atoms a bs)) 't) 840 | 't) 841 | 't))) 842 | ((E A A Q) 843 | (if-nest-A (set? (add-atoms (cdr a) bs)) 844 | (equal (set? (add-atoms (car a) (add-atoms (cdr a) bs))) 't) 845 | 't)) 846 | ((E A E Q) 847 | (if-nest-E (set? (add-atoms (cdr a) bs)) 848 | (equal (set? (add-atoms (car a) (add-atoms (cdr a) bs))) 't) 849 | 't)) 850 | ((E A E) 851 | (if-true 852 | (if (equal (set? (add-atoms (cdr a) bs)) 't) 853 | (equal (set? (add-atoms a bs)) 't) 854 | 't) 855 | 't)) 856 | ((E A A A Q 1) (set?-t (add-atoms (cdr a) bs))) 857 | ((E A E Q 1) (set?-nil (add-atoms (cdr a) bs))) 858 | ((E A A A Q) (equal 't 't)) 859 | ((E A E Q) (equal 'nil 't)) 860 | ((E A A A) (if-true (equal (set? (add-atoms a bs)) 't) 't)) 861 | ((E A E) (if-false (equal (set? (add-atoms a bs)) 't) 't)) 862 | ((E A A A 1 1) (add-atoms a bs)) 863 | ((E A A A 1 1) 864 | (if-nest-E (atom a) 865 | (if (member? a bs) bs (cons a bs)) 866 | (add-atoms (car a) (add-atoms (cdr a) bs)))) 867 | ((E A A A 1) (equal-if (set? (add-atoms (car a) (add-atoms (cdr a) bs))) 't)) 868 | ((E A A A) (equal-same 't)) 869 | ((E A A) 870 | (if-same (equal (set? (add-atoms (car a) (add-atoms (cdr a) bs))) 't) 't)) 871 | ((E A) (if-same (set? (add-atoms (cdr a) bs)) 't)) 872 | ((E) (if-same (set? bs) 't)) 873 | (() (if-same (atom a) 't))) 874 | ((dethm set?-atoms (a) 875 | (equal (set? (atoms a)) 't)) 876 | nil 877 | ((1 1) (atoms a)) 878 | (() (if-true (equal (set? (add-atoms a '())) 't) 't)) 879 | ((Q) (if-true 't (if (member? (car '()) (cdr '())) 'nil (set? (cdr '()))))) 880 | ((Q Q) (atom '())) 881 | ((Q) (set? '())) 882 | ((A 1) (set?-add-atoms a '())) 883 | ((A) (equal-same 't)) 884 | (() (if-same (set? '()) 't)))))) 885 | 886 | ;; Chapter 9 887 | 888 | (defun defun-rotate () 889 | (J-Bob-define (dethm-set?-atoms) 890 | '(((defun rotate (x) 891 | (cons (car (car x)) (cons (cdr (car x)) (cdr x)))) 892 | nil)))) 893 | 894 | (defun dethm-rotate-cons () 895 | (J-Bob-define (defun-rotate) 896 | '(((dethm rotate-cons (x y z) 897 | (equal (rotate (cons (cons x y) z)) (cons x (cons y z)))) 898 | nil 899 | ((1) (rotate (cons (cons x y) z))) 900 | ((1 1 1) (car-cons (cons x y) z)) 901 | ((1 1) (car-cons x y)) 902 | ((1 2 1 1) (car-cons (cons x y) z)) 903 | ((1 2 1) (cdr-cons x y)) 904 | ((1 2 2) (cdr-cons (cons x y) z)) 905 | (() (equal-same (cons x (cons y z)))))))) 906 | 907 | (defun defun-align-attempt () 908 | (J-Bob-prove (dethm-rotate-cons) 909 | '(((defun align (x) 910 | (if (atom x) 911 | x 912 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 913 | (size x) 914 | ((Q) (natp-size x)) 915 | (() 916 | (if-true 917 | (if (atom x) 918 | 't 919 | (if (atom (car x)) 920 | (< (size (cdr x)) (size x)) 921 | (< (size (rotate x)) (size x)))) 922 | 'nil)) 923 | ((E A) (size-cdr x)) 924 | ((E E 1 1 1) (cons-car+cdr x)) 925 | ((E E 2 1) (cons-car+cdr x)) 926 | ((E E 1 1 1 1) (cons-car+cdr (car x))) 927 | ((E E 2 1 1) (cons-car+cdr (car x))) 928 | ((E E 1 1) (rotate-cons (car (car x)) (cdr (car x)) (cdr x))))))) 929 | 930 | (defun defun-wt () 931 | (J-Bob-define (dethm-rotate-cons) 932 | '(((defun wt (x) 933 | (if (atom x) '1 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x))))) 934 | (size x) 935 | ((Q) (natp-size x)) 936 | (() 937 | (if-true 938 | (if (atom x) 939 | 't 940 | (if (< (size (car x)) (size x)) (< (size (cdr x)) (size x)) 'nil)) 941 | 'nil)) 942 | ((E Q) (size-car x)) 943 | ((E A) (size-cdr x)) 944 | ((E) (if-true 't 'nil)) 945 | (() (if-same (atom x) 't)))))) 946 | 947 | (defun defun-align () 948 | (J-Bob-define (defun-wt) 949 | '(((dethm natp-wt (x) 950 | (equal (natp (wt x)) 't)) 951 | (star-induction x) 952 | ((A 1 1) (wt x)) 953 | ((A 1 1) (if-nest-A (atom x) '1 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x))))) 954 | ((A 1) (natp '1)) 955 | ((A) (equal-same 't)) 956 | ((E A A 1 1) (wt x)) 957 | ((E A A 1 1) 958 | (if-nest-E (atom x) '1 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x))))) 959 | ((E A A) 960 | (if-true (equal (natp (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x)))) 't) 't)) 961 | ((E A A Q) (equal-if (natp (wt (car x))) 't)) 962 | ((E A A A) 963 | (if-true (equal (natp (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x)))) 't) 't)) 964 | ((E A A A Q) (natp-+ (wt (car x)) (wt (car x)))) 965 | ((E A A Q) (equal-if (natp (wt (car x))) 't)) 966 | ((E A A Q) (equal-if (natp (wt (cdr x))) 't)) 967 | ((E A A A A 1) (natp-+ (+ (wt (car x)) (wt (car x))) (wt (cdr x)))) 968 | ((E A A A A) (equal-same 't)) 969 | ((E A A A) (if-same (natp (+ (wt (car x)) (wt (car x)))) 't)) 970 | ((E A A) (if-same (natp (wt (cdr x))) 't)) 971 | ((E A) (if-same (equal (natp (wt (cdr x))) 't) 't)) 972 | ((E) (if-same (equal (natp (wt (car x))) 't) 't)) 973 | (() (if-same (atom x) 't))) 974 | ((dethm positive-wt (x) 975 | (equal (< '0 (wt x)) 't)) 976 | (star-induction x) 977 | ((A 1 2) (wt x)) 978 | ((A 1 2) (if-nest-A (atom x) '1 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x))))) 979 | ((A 1) (< '0 '1)) 980 | ((A) (equal-same 't)) 981 | ((E A A 1 2) (wt x)) 982 | ((E A A 1 2) 983 | (if-nest-E (atom x) '1 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x))))) 984 | ((E A A) 985 | (if-true (equal (< '0 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x)))) 't) 't)) 986 | ((E A A Q) (equal-if (< '0 (wt (car x))) 't)) 987 | ((E A A A) 988 | (if-true (equal (< '0 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x)))) 't) 't)) 989 | ((E A A A Q) (positives-+ (wt (car x)) (wt (car x)))) 990 | ((E A A Q) (equal-if (< '0 (wt (car x))) 't)) 991 | ((E A A Q) (equal-if (< '0 (wt (cdr x))) 't)) 992 | ((E A A A A 1) (positives-+ (+ (wt (car x)) (wt (car x))) (wt (cdr x)))) 993 | ((E A A A A) (equal-same 't)) 994 | ((E A A A) (if-same (< '0 (+ (wt (car x)) (wt (car x)))) 't)) 995 | ((E A A) (if-same (< '0 (wt (cdr x))) 't)) 996 | ((E A) (if-same (equal (< '0 (wt (cdr x))) 't) 't)) 997 | ((E) (if-same (equal (< '0 (wt (car x))) 't) 't)) 998 | (() (if-same (atom x) 't))) 999 | ((defun align (x) 1000 | (if (atom x) 1001 | x 1002 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 1003 | (wt x) 1004 | ((Q) (natp-wt x)) 1005 | (() 1006 | (if-true 1007 | (if (atom x) 1008 | 't 1009 | (if (atom (car x)) (< (wt (cdr x)) (wt x)) (< (wt (rotate x)) (wt x)))) 1010 | 'nil)) 1011 | ((E A 2) (wt x)) 1012 | ((E A 2) (if-nest-E (atom x) '1 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x))))) 1013 | ((E A) 1014 | (if-true (< (wt (cdr x)) (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x)))) 't)) 1015 | ((E A Q) (natp-wt (cdr x))) 1016 | ((E A A 1) (identity-+ (wt (cdr x)))) 1017 | ((E A A) (common-addends-< '0 (+ (wt (car x)) (wt (car x))) (wt (cdr x)))) 1018 | ((E A Q) (natp-wt (cdr x))) 1019 | ((E A Q) (positive-wt (car x))) 1020 | ((E A A) (positives-+ (wt (car x)) (wt (car x)))) 1021 | ((E A) (if-same (< '0 (wt (car x))) 't)) 1022 | ((E E 1 1) (rotate x)) 1023 | ((E E 1) (wt (cons (car (car x)) (cons (cdr (car x)) (cdr x))))) 1024 | ((E E 1 Q) (atom-cons (car (car x)) (cons (cdr (car x)) (cdr x)))) 1025 | ((E E 1) 1026 | (if-false '1 1027 | (+ (+ (wt (car (cons (car (car x)) (cons (cdr (car x)) (cdr x))))) 1028 | (wt (car (cons (car (car x)) (cons (cdr (car x)) (cdr x)))))) 1029 | (wt (cdr (cons (car (car x)) (cons (cdr (car x)) (cdr x)))))))) 1030 | ((E E 1 1 1 1) (car-cons (car (car x)) (cons (cdr (car x)) (cdr x)))) 1031 | ((E E 1 1 2 1) (car-cons (car (car x)) (cons (cdr (car x)) (cdr x)))) 1032 | ((E E 1 2 1) (cdr-cons (car (car x)) (cons (cdr (car x)) (cdr x)))) 1033 | ((E E 1 2) (wt (cons (cdr (car x)) (cdr x)))) 1034 | ((E E 1 2 Q) (atom-cons (cdr (car x)) (cdr x))) 1035 | ((E E 1 2) 1036 | (if-false '1 1037 | (+ (+ (wt (car (cons (cdr (car x)) (cdr x)))) 1038 | (wt (car (cons (cdr (car x)) (cdr x))))) 1039 | (wt (cdr (cons (cdr (car x)) (cdr x))))))) 1040 | ((E E 1 2 1 1 1) (car-cons (cdr (car x)) (cdr x))) 1041 | ((E E 1 2 1 2 1) (car-cons (cdr (car x)) (cdr x))) 1042 | ((E E 1 2 2 1) (cdr-cons (cdr (car x)) (cdr x))) 1043 | ((E E 2) (wt x)) 1044 | ((E E 2) (if-nest-E (atom x) '1 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x))))) 1045 | ((E E 2 1 1) (wt (car x))) 1046 | ((E E 2 1 1) 1047 | (if-nest-E (atom (car x)) 1048 | '1 1049 | (+ (+ (wt (car (car x))) (wt (car (car x)))) (wt (cdr (car x)))))) 1050 | ((E E 2 1 2) (wt (car x))) 1051 | ((E E 2 1 2) 1052 | (if-nest-E (atom (car x)) 1053 | '1 1054 | (+ (+ (wt (car (car x))) (wt (car (car x)))) (wt (cdr (car x)))))) 1055 | ((E E 1) 1056 | (associate-+ 1057 | (+ (wt (car (car x))) (wt (car (car x)))) 1058 | (+ (wt (cdr (car x))) (wt (cdr (car x)))) 1059 | (wt (cdr x)))) 1060 | ((E E) 1061 | (common-addends-< 1062 | (+ (+ (wt (car (car x))) (wt (car (car x)))) 1063 | (+ (wt (cdr (car x))) (wt (cdr (car x))))) 1064 | (+ (+ (+ (wt (car (car x))) (wt (car (car x)))) (wt (cdr (car x)))) 1065 | (+ (+ (wt (car (car x))) (wt (car (car x)))) (wt (cdr (car x))))) 1066 | (wt (cdr x)))) 1067 | ((E E 1) 1068 | (associate-+ 1069 | (+ (wt (car (car x))) (wt (car (car x)))) 1070 | (wt (cdr (car x))) 1071 | (wt (cdr (car x))))) 1072 | ((E E 1) 1073 | (commute-+ 1074 | (+ (+ (wt (car (car x))) (wt (car (car x)))) (wt (cdr (car x)))) 1075 | (wt (cdr (car x))))) 1076 | ((E E) 1077 | (common-addends-< 1078 | (wt (cdr (car x))) 1079 | (+ (+ (wt (car (car x))) (wt (car (car x)))) (wt (cdr (car x)))) 1080 | (+ (+ (wt (car (car x))) (wt (car (car x)))) (wt (cdr (car x)))))) 1081 | ((E E) 1082 | (if-true 1083 | (< (wt (cdr (car x))) 1084 | (+ (+ (wt (car (car x))) (wt (car (car x)))) (wt (cdr (car x))))) 1085 | 't)) 1086 | ((E E Q) (natp-wt (cdr (car x)))) 1087 | ((E E A 1) (identity-+ (wt (cdr (car x))))) 1088 | ((E E A) 1089 | (common-addends-< 1090 | '0 1091 | (+ (wt (car (car x))) (wt (car (car x)))) 1092 | (wt (cdr (car x))))) 1093 | ((E E Q) (natp-wt (cdr (car x)))) 1094 | ((E E Q) (positive-wt (car (car x)))) 1095 | ((E E A) (positives-+ (wt (car (car x))) (wt (car (car x))))) 1096 | ((E E) (if-same (< '0 (wt (car (car x)))) 't)) 1097 | ((E) (if-same (atom (car x)) 't)) 1098 | (() (if-same (atom x) 't)))))) 1099 | 1100 | (defun dethm-align-align () 1101 | (J-Bob-define (defun-align) 1102 | '(((dethm align-align (x) 1103 | (equal (align (align x)) (align x))) 1104 | (align x) 1105 | ((A 1 1) (align x)) 1106 | ((A 1 1) 1107 | (if-nest-A (atom x) 1108 | x 1109 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 1110 | ((A 2) (align x)) 1111 | ((A 2) 1112 | (if-nest-A (atom x) 1113 | x 1114 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 1115 | ((A 1) (align x)) 1116 | ((A 1) 1117 | (if-nest-A (atom x) 1118 | x 1119 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 1120 | ((A) (equal-same x)) 1121 | ((E A A 1 1) (align x)) 1122 | ((E A A 1 1) 1123 | (if-nest-E (atom x) 1124 | x 1125 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 1126 | ((E A A 1 1) 1127 | (if-nest-A (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x)))) 1128 | ((E A A 2) (align x)) 1129 | ((E A A 2) 1130 | (if-nest-E (atom x) 1131 | x 1132 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 1133 | ((E A A 2) 1134 | (if-nest-A (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x)))) 1135 | ((E A A 1) (align (cons (car x) (align (cdr x))))) 1136 | ((E A A 1 Q) (atom-cons (car x) (align (cdr x)))) 1137 | ((E A A 1 E Q 1) (car-cons (car x) (align (cdr x)))) 1138 | ((E A A 1 E A 1) (car-cons (car x) (align (cdr x)))) 1139 | ((E A A 1 E A 2 1) (cdr-cons (car x) (align (cdr x)))) 1140 | ((E A A 1) 1141 | (if-false (cons (car x) (align (cdr x))) 1142 | (if (atom (car x)) 1143 | (cons (car x) (align (align (cdr x)))) 1144 | (align (rotate (cons (car x) (align (cdr x)))))))) 1145 | ((E A A 1) 1146 | (if-nest-A (atom (car x)) 1147 | (cons (car x) (align (align (cdr x)))) 1148 | (align (rotate (cons (car x) (align (cdr x))))))) 1149 | ((E A A 1 2) (equal-if (align (align (cdr x))) (align (cdr x)))) 1150 | ((E A A) (equal-same (cons (car x) (align (cdr x))))) 1151 | ((E A) (if-same (equal (align (align (cdr x))) (align (cdr x))) 't)) 1152 | ((E E A 1 1) (align x)) 1153 | ((E E A 1 1) 1154 | (if-nest-E (atom x) 1155 | x 1156 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 1157 | ((E E A 1 1) 1158 | (if-nest-E (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x)))) 1159 | ((E E A 2) (align x)) 1160 | ((E E A 2) 1161 | (if-nest-E (atom x) 1162 | x 1163 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 1164 | ((E E A 2) 1165 | (if-nest-E (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x)))) 1166 | ((E E A 1) (equal-if (align (align (rotate x))) (align (rotate x)))) 1167 | ((E E A) (equal-same (align (rotate x)))) 1168 | ((E E) (if-same (equal (align (align (rotate x))) (align (rotate x))) 't)) 1169 | ((E) (if-same (atom (car x)) 't)) 1170 | (() (if-same (atom x) 't)))))) 1171 | -------------------------------------------------------------------------------- /src/clj_bob/repl.clj: -------------------------------------------------------------------------------- 1 | (ns clj-bob.repl 2 | "a convenience namespace for CIDER, Fireplace, Cursive etc." 3 | (:refer-clojure :exclude [cons if num + < atom bound? var?]) 4 | (:require [clj-bob.lang :refer :all] 5 | [clj-bob.j-bob :refer :all] 6 | [clj-bob.little-prover :as book])) 7 | 8 | ;; Experiment below 9 | ;; ------------------------------------------------------------ 10 | 11 | (comment 12 | (car (cons 'ham '(eggs))) 13 | ;; ham 14 | 15 | (atom '()) 16 | ;; t 17 | ) 18 | -------------------------------------------------------------------------------- /test/clj_bob/little_prover_test.clj: -------------------------------------------------------------------------------- 1 | (ns clj-bob.little-prover-test 2 | (:require [clj-bob.little-prover :refer :all] 3 | [clj-bob.lang :as l] 4 | [clojure.test :refer :all])) 5 | 6 | (declare dethm-align-align-ref) 7 | (declare dethm-set?-atoms-ref) 8 | 9 | (deftest acceptance 10 | (testing "evaluates to the same result as the reference implementation in scheme" 11 | (are [example scheme-output] (= scheme-output (example)) 12 | chapter1-example1 '(car (cons (quote ham) (quote (eggs)))) 13 | chapter1-example2 (quote 't) 14 | chapter1-example3 '(atom (cons (quote ham) (quote (eggs)))) 15 | chapter1-example4 (quote 'nil) 16 | chapter1-example5 '(equal (quote flapjack) (atom (cons a b))) 17 | chapter1-example6 '(atom (cdr (cons (car (cons p q)) (quote ())))) 18 | chapter1-example7 '(atom (cdr (cons (car (cons p q)) (quote ())))) 19 | chapter1-example8 '(car (cons (equal (cons x y) (cons x y)) (quote (and crumpets)))) 20 | chapter1-example9 '(equal (cons (quote bagels) (quote (and lox))) (cons x y)) 21 | chapter1-example10 '(cons y (equal (car (cons (cdr x) (car y))) (equal (atom x) (quote nil)))) 22 | chapter1-example11 '(cons y (equal (car (cons (cdr x) (car y))) (equal (atom x) (quote nil)))) 23 | chapter1-example12 '(atom (car (cons (car a) (cdr b)))) 24 | 25 | chapter2-example1 '(if (car (cons a b)) c c) 26 | chapter2-example2 '(if (atom (car a)) 27 | (if (equal (car a) (cdr a)) 28 | (quote hominy) 29 | (quote grits)) 30 | (if (equal (cdr (car a)) (quote (hash browns))) 31 | (cons (quote ketchup) (car a)) 32 | (cons (quote mustard) (car a)))) 33 | chapter2-example3 '(cons (quote statement) 34 | (cons (if (equal a (quote question)) 35 | (cons n (quote (answer))) 36 | (cons n (quote (else)))) 37 | (if (equal a (quote question)) 38 | (cons n (quote (other answer))) 39 | (cons n (quote (other else)))))) 40 | 41 | dethm-set?-atoms dethm-set?-atoms-ref 42 | 43 | dethm-align-align dethm-align-align-ref))) 44 | 45 | (def dethm-set?-atoms-ref 46 | '((dethm atom-cons (x y) (equal (atom (cons x y)) (quote nil))) 47 | (dethm car-cons (x y) (equal (car (cons x y)) x)) 48 | (dethm cdr-cons (x y) (equal (cdr (cons x y)) y)) 49 | (dethm equal-same (x) (equal (equal x x) (quote t))) 50 | (dethm equal-swap (x y) (equal (equal x y) (equal y x))) 51 | (dethm if-same (x y) (equal (if x y y) y)) 52 | (dethm if-true (x y) (equal (if (quote t) x y) x)) 53 | (dethm if-false (x y) (equal (if (quote nil) x y) y)) 54 | (dethm if-nest-e (x y z) (if x (quote t) (equal (if x y z) z))) 55 | (dethm if-nest-a (x y z) (if x (equal (if x y z) y) (quote t))) 56 | (dethm cons-car+cdr (x) (if (atom x) (quote t) (equal (cons (car x) (cdr x)) x))) 57 | (dethm equal-if (x y) (if (equal x y) (equal x y) (quote t))) 58 | (dethm natp-size (x) (equal (natp (size x)) (quote t))) 59 | (dethm size-car (x) (if (atom x) (quote t) (equal (< (size (car x)) (size x)) (quote t)))) 60 | (dethm size-cdr (x) (if (atom x) (quote t) (equal (< (size (cdr x)) (size x)) (quote t)))) 61 | (dethm associate-+ (a b c) (equal (+ (+ a b) c) (+ a (+ b c)))) 62 | (dethm commute-+ (x y) (equal (+ x y) (+ y x))) 63 | (dethm natp-+ (x y) (if (natp x) (if (natp y) (equal (natp (+ x y)) (quote t)) (quote t)) (quote t))) 64 | (dethm positives-+ (x y) (if (< (quote 0) x) (if (< (quote 0) y) (equal (< (quote 0) (+ x y)) (quote t)) (quote t)) (quote t))) 65 | (dethm common-addends-< (x y z) (equal (< (+ x z) (+ y z)) (< x y))) 66 | (dethm identity-+ (x) (if (natp x) (equal (+ (quote 0) x) x) (quote t))) 67 | (defun list-induction (x) (if (atom x) (quote ()) (cons (car x) (list-induction (cdr x))))) 68 | (defun star-induction (x) (if (atom x) x (cons (star-induction (car x)) (star-induction (cdr x))))) 69 | (defun pair (x y) (cons x (cons y (quote ())))) 70 | (defun first-of (x) (car x)) 71 | (defun second-of (x) (car (cdr x))) 72 | (defun in-pair? (xs) (if (equal (first-of xs) (quote ?)) (quote t) (equal (second-of xs) (quote ?)))) 73 | (defun list0? (x) (equal x (quote ()))) 74 | (defun list1? (x) (if (atom x) (quote nil) (list0? (cdr x)))) 75 | (defun list2? (x) (if (atom x) (quote nil) (list1? (cdr x)))) 76 | (defun list? (x) (if (atom x) (equal x (quote ())) (list? (cdr x)))) 77 | (defun sub (x y) (if (atom y) (if (equal y (quote ?)) x y) (cons (sub x (car y)) (sub x (cdr y))))) 78 | (defun memb? (xs) (if (atom xs) (quote nil) (if (equal (car xs) (quote ?)) (quote t) (memb? (cdr xs))))) 79 | (defun remb (xs) (if (atom xs) (quote ()) (if (equal (car xs) (quote ?)) (remb (cdr xs)) (cons (car xs) (remb (cdr xs)))))) 80 | (defun ctx? (x) (if (atom x) (equal x (quote ?)) (if (ctx? (car x)) (quote t) (ctx? (cdr x))))) 81 | (defun member? (x ys) (if (atom ys) (quote nil) (if (equal x (car ys)) (quote t) (member? x (cdr ys))))) 82 | (defun set? (xs) (if (atom xs) (quote t) (if (member? (car xs) (cdr xs)) (quote nil) (set? (cdr xs))))) 83 | (defun add-atoms (x ys) (if (atom x) (if (member? x ys) ys (cons x ys)) (add-atoms (car x) (add-atoms (cdr x) ys)))) 84 | (defun atoms (x) (add-atoms x (quote ()))))) 85 | 86 | (def dethm-align-align-ref-pt1 87 | '((dethm atom-cons (x y) (equal (atom (cons x y)) (quote nil))) 88 | (dethm car-cons (x y) (equal (car (cons x y)) x)) 89 | (dethm cdr-cons (x y) (equal (cdr (cons x y)) y)) 90 | (dethm equal-same (x) (equal (equal x x) (quote t))) 91 | (dethm equal-swap (x y) (equal (equal x y) (equal y x))) 92 | (dethm if-same (x y) (equal (if x y y) y)) 93 | (dethm if-true (x y) (equal (if (quote t) x y) x)) 94 | (dethm if-false (x y) (equal (if (quote nil) x y) y)) 95 | (dethm if-nest-e (x y z) (if x (quote t) (equal (if x y z) z))) 96 | (dethm if-nest-a (x y z) (if x (equal (if x y z) y) (quote t))) 97 | (dethm cons-car+cdr (x) (if (atom x) (quote t) (equal (cons (car x) (cdr x)) x))) 98 | (dethm equal-if (x y) (if (equal x y) (equal x y) (quote t))) 99 | (dethm natp-size (x) (equal (natp (size x)) (quote t))) 100 | (dethm size-car (x) (if (atom x) (quote t) (equal (< (size (car x)) (size x)) (quote t)))) 101 | (dethm size-cdr (x) (if (atom x) (quote t) (equal (< (size (cdr x)) (size x)) (quote t)))) 102 | (dethm associate-+ (a b c) (equal (+ (+ a b) c) (+ a (+ b c)))) 103 | (dethm commute-+ (x y) (equal (+ x y) (+ y x))) 104 | (dethm natp-+ (x y) (if (natp x) (if (natp y) (equal (natp (+ x y)) (quote t)) (quote t)) (quote t))) 105 | (dethm positives-+ (x y) (if (< (quote 0) x) (if (< (quote 0) y) (equal (< (quote 0) (+ x y)) (quote t)) (quote t)) (quote t))) 106 | (dethm common-addends-< (x y z) (equal (< (+ x z) (+ y z)) (< x y))) 107 | (dethm identity-+ (x) (if (natp x) (equal (+ (quote 0) x) x) (quote t))))) 108 | 109 | (def dethm-align-align-ref-pt2 110 | '((defun list-induction (x) (if (atom x) (quote ()) (cons (car x) (list-induction (cdr x))))) 111 | (defun star-induction (x) (if (atom x) x (cons (star-induction (car x)) (star-induction (cdr x))))) 112 | (defun pair (x y) (cons x (cons y (quote ())))) 113 | (defun first-of (x) (car x)) 114 | (defun second-of (x) (car (cdr x))) 115 | (defun in-pair? (xs) (if (equal (first-of xs) (quote ?)) (quote t) (equal (second-of xs) (quote ?)))) 116 | (defun list0? (x) (equal x (quote ()))) 117 | (defun list1? (x) (if (atom x) (quote nil) (list0? (cdr x)))) 118 | (defun list2? (x) (if (atom x) (quote nil) (list1? (cdr x)))) 119 | (defun list? (x) (if (atom x) (equal x (quote ())) (list? (cdr x)))) 120 | (defun sub (x y) (if (atom y) (if (equal y (quote ?)) x y) (cons (sub x (car y)) (sub x (cdr y))))) 121 | (defun memb? (xs) (if (atom xs) (quote nil) (if (equal (car xs) (quote ?)) (quote t) (memb? (cdr xs))))) 122 | (defun remb (xs) (if (atom xs) (quote ()) (if (equal (car xs) (quote ?)) (remb (cdr xs)) (cons (car xs) (remb (cdr xs)))))) 123 | (defun ctx? (x) (if (atom x) (equal x (quote ?)) (if (ctx? (car x)) (quote t) (ctx? (cdr x))))) 124 | (defun member? (x ys) (if (atom ys) (quote nil) (if (equal x (car ys)) (quote t) (member? x (cdr ys))))) 125 | (defun set? (xs) (if (atom xs) (quote t) (if (member? (car xs) (cdr xs)) (quote nil) (set? (cdr xs))))) 126 | (defun add-atoms (x ys) (if (atom x) (if (member? x ys) ys (cons x ys)) (add-atoms (car x) (add-atoms (cdr x) ys)))) 127 | (defun atoms (x) (add-atoms x (quote ()))) 128 | (defun rotate (x) (cons (car (car x)) (cons (cdr (car x)) (cdr x)))) 129 | (defun wt (x) (if (atom x) (quote 1) (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x))))))) 130 | 131 | (def dethm-align-align-ref 132 | "Unfortunately, the Clojure reader seems to have trouble parsing all of this at once." 133 | (concat dethm-align-align-ref-pt1 134 | dethm-align-align-ref-pt2)) 135 | --------------------------------------------------------------------------------