├── .gitignore ├── LICENSE.md ├── README.md ├── acl2 ├── j-bob-lang.lisp ├── j-bob.lisp └── little-prover.lisp └── scheme ├── j-bob-lang.scm ├── j-bob.scm └── little-prover.scm /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.cert 3 | *.dx64fsl -------------------------------------------------------------------------------- /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 | # The Little Prover 2 | 3 | This repository contains "J-Bob", the proof assistant from "The Little Prover" 4 | by Daniel P. Friedman and Carl Eastlund, published by MIT Press in 2015. We 5 | include the necessary code to run J-Bob in ACL2 and Scheme, as well as a 6 | transcript of the proofs in the book. J-Bob is also included in the Dracula 7 | package for Racket. 8 | 9 | Example of using J-Bob in Scheme, in the `scheme/` subdirectory: 10 | 11 | ```scheme 12 | ;; Load the J-Bob language: 13 | (load "j-bob-lang.scm") 14 | ;; Load J-Bob, our little proof assistant: 15 | (load "j-bob.scm") 16 | ;; Load the transcript of all proofs in the book: 17 | (load "little-prover.scm") 18 | ;; Run every proof in the book, up to and including the proof of align/align: 19 | (dethm.align/align) 20 | ``` 21 | 22 | Example of using J-Bob in ACL2, in the `acl2/` subdirectory: 23 | 24 | ```lisp 25 | ;; Load the J-Bob language: 26 | (include-book "j-bob-lang") 27 | ;; Load J-Bob, our little proof assistant: 28 | (include-book "j-bob") 29 | ;; Load the transcript of all proofs in the book: 30 | (include-book "little-prover") 31 | ;; Run every proof in the book, up to and including the proof of align/align: 32 | (dethm.align/align) 33 | ``` 34 | 35 | Example of using J-Bob in Racket, using the Dracula package: 36 | 37 | ```lisp 38 | ;; Load the J-Bob language: 39 | (include-book "j-bob-lang" :dir :teachpacks) 40 | ;; Load J-Bob, our little proof assistant: 41 | (include-book "j-bob" :dir :teachpacks) 42 | ;; Load the transcript of all proofs in the book: 43 | (include-book "little-prover" :dir :teachpacks) 44 | ;; Run every proof in the book, up to and including the proof of align/align: 45 | (dethm.align/align) 46 | ``` 47 | 48 | --- 49 | 50 | If you want to load the Scheme version of J-Bob inside DrRacket, you will need 51 | to load it in the R5RS language with custom settings: 52 | 53 | 1. Use the `Language` menu and the `Choose Language ...` option. 54 | 2. In the dialog box that opens, select `Other Languages`. 55 | 3. Under `Legacy Languages` choose `R5RS`. 56 | 4. Select `Show Details` if there is not already a menu on the right of the dialog box. 57 | 5. Under `Initial Bindings`, make sure that `Disallow redefinition of initial bindings` is *unchecked*. 58 | 6. Then click `OK`, and J-Bob should work with those settings. 59 | -------------------------------------------------------------------------------- /acl2/j-bob-lang.lisp: -------------------------------------------------------------------------------- 1 | (in-package "ACL2") 2 | 3 | (defun if->implies (exp hyps) 4 | (case-match exp 5 | (('if Q A E) 6 | (append 7 | (if->implies A `(,@hyps ,Q)) 8 | (if->implies E `(,@hyps (not ,Q))))) 9 | (('equal X Y) 10 | `((:rewrite :corollary 11 | (implies (and ,@hyps) 12 | (equal ,X ,Y))))) 13 | (& '()))) 14 | 15 | (defmacro dethm (name args body) 16 | (declare (ignore args)) 17 | (let ((rules (if->implies body '()))) 18 | `(defthm ,name ,body 19 | :rule-classes ,rules))) 20 | 21 | (defun size (x) 22 | (if (atom x) 23 | '0 24 | (+ '1 (size (car x)) (size (cdr x))))) 25 | -------------------------------------------------------------------------------- /acl2/j-bob.lisp: -------------------------------------------------------------------------------- 1 | (in-package "ACL2") 2 | (include-book "j-bob-lang") 3 | 4 | (defun list0 () '()) 5 | (defun list0? (x) (equal x '())) 6 | 7 | (defun list1 (x) (cons x (list0))) 8 | (defun list1? (x) 9 | (if (atom x) 'nil (list0? (cdr x)))) 10 | (defun elem1 (xs) (car xs)) 11 | 12 | (defun list2 (x y) (cons x (list1 y))) 13 | (defun list2? (x) 14 | (if (atom x) 'nil (list1? (cdr x)))) 15 | (defun elem2 (xs) (elem1 (cdr xs))) 16 | 17 | (defun list3 (x y z) (cons x (list2 y z))) 18 | (defun list3? (x) 19 | (if (atom x) 'nil (list2? (cdr x)))) 20 | (defun elem3 (xs) (elem2 (cdr xs))) 21 | 22 | (defun tag (sym x) (cons sym x)) 23 | (defun tag? (sym x) 24 | (if (atom x) 'nil (equal (car x) sym))) 25 | (defun untag (x) (cdr x)) 26 | 27 | (defun quote-c (value) 28 | (tag 'quote (list1 value))) 29 | (defun quote? (x) 30 | (if (tag? 'quote x) (list1? (untag x)) 'nil)) 31 | (defun quote.value (e) (elem1 (untag e))) 32 | 33 | (defun if-c (Q A E) (tag 'if (list3 Q A E))) 34 | (defun if? (x) 35 | (if (tag? 'if x) (list3? (untag x)) 'nil)) 36 | (defun if.Q (e) (elem1 (untag e))) 37 | (defun if.A (e) (elem2 (untag e))) 38 | (defun if.E (e) (elem3 (untag e))) 39 | 40 | (defun app-c (name args) (cons name args)) 41 | (defun app? (x) 42 | (if (atom x) 43 | 'nil 44 | (if (quote? x) 45 | 'nil 46 | (if (if? x) 47 | 'nil 48 | 't)))) 49 | (defun app.name (e) (car e)) 50 | (defun app.args (e) (cdr e)) 51 | 52 | (defun var? (x) 53 | (if (equal x 't) 54 | 'nil 55 | (if (equal x 'nil) 56 | 'nil 57 | (if (natp x) 58 | 'nil 59 | (atom x))))) 60 | 61 | (defun defun-c (name formals body) 62 | (tag 'defun (list3 name formals body))) 63 | (defun defun? (x) 64 | (if (tag? 'defun x) (list3? (untag x)) 'nil)) 65 | (defun defun.name (def) (elem1 (untag def))) 66 | (defun defun.formals (def) (elem2 (untag def))) 67 | (defun defun.body (def) (elem3 (untag def))) 68 | 69 | (defun dethm-c (name formals body) 70 | (tag 'dethm (list3 name formals body))) 71 | (defun dethm? (x) 72 | (if (tag? 'dethm x) (list3? (untag x)) 'nil)) 73 | (defun dethm.name (def) (elem1 (untag def))) 74 | (defun dethm.formals (def) (elem2 (untag def))) 75 | (defun dethm.body (def) (elem3 (untag def))) 76 | 77 | (defun if-QAE (e) 78 | (list3 (if.Q e) (if.A e) (if.E e))) 79 | (defun QAE-if (es) 80 | (if-c (elem1 es) (elem2 es) (elem3 es))) 81 | 82 | (defun member? (x ys) 83 | (if (atom ys) 84 | 'nil 85 | (if (equal x (car ys)) 86 | 't 87 | (member? x (cdr ys))))) 88 | 89 | (defun rator? (name) 90 | (member? name 91 | '(equal atom car cdr cons natp size + <))) 92 | 93 | (defun rator.formals (rator) 94 | (if (member? rator '(atom car cdr natp size)) 95 | '(x) 96 | (if (member? rator '(equal cons + <)) 97 | '(x y) 98 | 'nil))) 99 | 100 | (defun def.name (def) 101 | (if (defun? def) 102 | (defun.name def) 103 | (if (dethm? def) 104 | (dethm.name def) 105 | def))) 106 | 107 | (defun def.formals (def) 108 | (if (dethm? def) 109 | (dethm.formals def) 110 | (if (defun? def) 111 | (defun.formals def) 112 | '()))) 113 | 114 | (defun if-c-when-necessary (Q A E) 115 | (if (equal A E) A (if-c Q A E))) 116 | 117 | (defun conjunction (es) 118 | (if (atom es) 119 | (quote-c 't) 120 | (if (atom (cdr es)) 121 | (car es) 122 | (if-c (car es) 123 | (conjunction (cdr es)) 124 | (quote-c 'nil))))) 125 | 126 | (defun implication (es e) 127 | (if (atom es) 128 | e 129 | (if-c (car es) 130 | (implication (cdr es) e) 131 | (quote-c 't)))) 132 | 133 | (defun lookup (name defs) 134 | (if (atom defs) 135 | name 136 | (if (equal (def.name (car defs)) name) 137 | (car defs) 138 | (lookup name (cdr defs))))) 139 | 140 | (defun undefined? (name defs) 141 | (if (var? name) 142 | (equal (lookup name defs) name) 143 | 'nil)) 144 | 145 | (defun arity? (vars es) 146 | (if (atom vars) 147 | (atom es) 148 | (if (atom es) 149 | 'nil 150 | (arity? (cdr vars) (cdr es))))) 151 | 152 | (defun args-arity? (def args) 153 | (if (dethm? def) 154 | 'nil 155 | (if (defun? def) 156 | (arity? (defun.formals def) args) 157 | (if (rator? def) 158 | (arity? (rator.formals def) args) 159 | 'nil)))) 160 | 161 | (defun app-arity? (defs app) 162 | (args-arity? (lookup (app.name app) defs) 163 | (app.args app))) 164 | 165 | (defun bound? (var vars) 166 | (if (equal vars 'any) 't (member? var vars))) 167 | 168 | (defun exprs? (defs vars es) 169 | (if (atom es) 170 | 't 171 | (if (var? (car es)) 172 | (if (bound? (car es) vars) 173 | (exprs? defs vars (cdr es)) 174 | 'nil) 175 | (if (quote? (car es)) 176 | (exprs? defs vars (cdr es)) 177 | (if (if? (car es)) 178 | (if (exprs? defs vars 179 | (if-QAE (car es))) 180 | (exprs? defs vars (cdr es)) 181 | 'nil) 182 | (if (app? (car es)) 183 | (if (app-arity? defs (car es)) 184 | (if (exprs? defs vars 185 | (app.args (car es))) 186 | (exprs? defs vars (cdr es)) 187 | 'nil) 188 | 'nil) 189 | 'nil)))))) 190 | (defun expr? (defs vars e) 191 | (exprs? defs vars (list1 e))) 192 | 193 | (defun get-arg-from (n args from) 194 | (if (atom args) 195 | 'nil 196 | (if (equal n from) 197 | (car args) 198 | (get-arg-from n (cdr args) (+ from '1))))) 199 | (defun get-arg (n args) 200 | (get-arg-from n args '1)) 201 | 202 | (defun set-arg-from (n args y from) 203 | (if (atom args) 204 | '() 205 | (if (equal n from) 206 | (cons y (cdr args)) 207 | (cons (car args) 208 | (set-arg-from n (cdr args) y 209 | (+ from '1)))))) 210 | (defun set-arg (n args y) 211 | (set-arg-from n args y '1)) 212 | 213 | (defun <=len-from (n args from) 214 | (if (atom args) 215 | 'nil 216 | (if (equal n from) 217 | 't 218 | (<=len-from n (cdr args) (+ from '1))))) 219 | (defun <=len (n args) 220 | (if (< '0 n) (<=len-from n args '1) 'nil)) 221 | 222 | (defun subset? (xs ys) 223 | (if (atom xs) 224 | 't 225 | (if (member? (car xs) ys) 226 | (subset? (cdr xs) ys) 227 | 'nil))) 228 | 229 | (defun list-extend (xs x) 230 | (if (atom xs) 231 | (list1 x) 232 | (if (equal (car xs) x) 233 | xs 234 | (cons (car xs) 235 | (list-extend (cdr xs) x))))) 236 | 237 | (defun list-union (xs ys) 238 | (if (atom ys) 239 | xs 240 | (list-union (list-extend xs (car ys)) 241 | (cdr ys)))) 242 | 243 | (defun formals? (vars) 244 | (if (atom vars) 245 | 't 246 | (if (var? (car vars)) 247 | (if (member? (car vars) (cdr vars)) 248 | 'nil 249 | (formals? (cdr vars))) 250 | 'nil))) 251 | 252 | (defun direction? (dir) 253 | (if (natp dir) 254 | 't 255 | (member? dir '(Q A E)))) 256 | 257 | (defun path? (path) 258 | (if (atom path) 259 | 't 260 | (if (direction? (car path)) 261 | (path? (cdr path)) 262 | 'nil))) 263 | 264 | (defun quoted-exprs? (args) 265 | (if (atom args) 266 | 't 267 | (if (quote? (car args)) 268 | (quoted-exprs? (cdr args)) 269 | 'nil))) 270 | 271 | (defun step-args? (defs def args) 272 | (if (dethm? def) 273 | (if (arity? (dethm.formals def) args) 274 | (exprs? defs 'any args) 275 | 'nil) 276 | (if (defun? def) 277 | (if (arity? (defun.formals def) args) 278 | (exprs? defs 'any args) 279 | 'nil) 280 | (if (rator? def) 281 | (if (arity? (rator.formals def) args) 282 | (quoted-exprs? args) 283 | 'nil) 284 | 'nil)))) 285 | 286 | (defun step-app? (defs app) 287 | (step-args? defs 288 | (lookup (app.name app) defs) 289 | (app.args app))) 290 | 291 | (defun step? (defs step) 292 | (if (path? (elem1 step)) 293 | (if (app? (elem2 step)) 294 | (step-app? defs (elem2 step)) 295 | 'nil) 296 | 'nil)) 297 | 298 | (defun steps? (defs steps) 299 | (if (atom steps) 300 | 't 301 | (if (step? defs (car steps)) 302 | (steps? defs (cdr steps)) 303 | 'nil))) 304 | 305 | (defun induction-scheme-for? (def vars e) 306 | (if (defun? def) 307 | (if (arity? (defun.formals def) (app.args e)) 308 | (if (formals? (app.args e)) 309 | (subset? (app.args e) vars) 310 | 'nil) 311 | 'nil) 312 | 'nil)) 313 | 314 | (defun induction-scheme? (defs vars e) 315 | (if (app? e) 316 | (induction-scheme-for? 317 | (lookup (app.name e) defs) 318 | vars 319 | e) 320 | 'nil)) 321 | 322 | (defun seed? (defs def seed) 323 | (if (equal seed 'nil) 324 | 't 325 | (if (defun? def) 326 | (expr? defs (defun.formals def) seed) 327 | (if (dethm? def) 328 | (induction-scheme? defs 329 | (dethm.formals def) 330 | seed) 331 | 'nil)))) 332 | 333 | (defun extend-rec (defs def) 334 | (if (defun? def) 335 | (list-extend defs 336 | (defun-c 337 | (defun.name def) 338 | (defun.formals def) 339 | (app-c (defun.name def) 340 | (defun.formals def)))) 341 | defs)) 342 | 343 | (defun def-contents? (known-defs formals body) 344 | (if (formals? formals) 345 | (expr? known-defs formals body) 346 | 'nil)) 347 | 348 | (defun def? (known-defs def) 349 | (if (dethm? def) 350 | (if (undefined? (dethm.name def) 351 | known-defs) 352 | (def-contents? known-defs 353 | (dethm.formals def) 354 | (dethm.body def)) 355 | 'nil) 356 | (if (defun? def) 357 | (if (undefined? (defun.name def) 358 | known-defs) 359 | (def-contents? 360 | (extend-rec known-defs def) 361 | (defun.formals def) 362 | (defun.body def)) 363 | 'nil) 364 | 'nil))) 365 | 366 | (defun defs? (known-defs defs) 367 | (declare (xargs :measure (size 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 | (declare (xargs :measure (size pfs))) 394 | (if (atom pfs) 395 | 't 396 | (if (proof? defs (car pfs)) 397 | (proofs? 398 | (list-extend defs (elem1 (car pfs))) 399 | (cdr pfs)) 400 | 'nil))) 401 | 402 | (defun sub-var (vars args var) 403 | (if (atom vars) 404 | var 405 | (if (equal (car vars) var) 406 | (car args) 407 | (sub-var (cdr vars) (cdr args) var)))) 408 | 409 | (defun sub-es (vars args es) 410 | (if (atom es) 411 | '() 412 | (if (var? (car es)) 413 | (cons (sub-var vars args (car es)) 414 | (sub-es vars args (cdr es))) 415 | (if (quote? (car es)) 416 | (cons (car es) 417 | (sub-es vars args (cdr es))) 418 | (if (if? (car es)) 419 | (cons 420 | (QAE-if 421 | (sub-es vars args 422 | (if-QAE (car es)))) 423 | (sub-es vars args (cdr es))) 424 | (cons 425 | (app-c (app.name (car es)) 426 | (sub-es vars args 427 | (app.args (car es)))) 428 | (sub-es vars args (cdr es)))))))) 429 | (defun sub-e (vars args e) 430 | (elem1 (sub-es vars args (list1 e)))) 431 | 432 | (defun exprs-recs (f es) 433 | (if (atom es) 434 | '() 435 | (if (var? (car es)) 436 | (exprs-recs f (cdr es)) 437 | (if (quote? (car es)) 438 | (exprs-recs f (cdr es)) 439 | (if (if? (car es)) 440 | (list-union 441 | (exprs-recs f (if-QAE (car es))) 442 | (exprs-recs f (cdr es))) 443 | (if (equal (app.name (car es)) f) 444 | (list-union 445 | (list1 (car es)) 446 | (list-union 447 | (exprs-recs f 448 | (app.args (car es))) 449 | (exprs-recs f (cdr es)))) 450 | (list-union 451 | (exprs-recs f (app.args (car es))) 452 | (exprs-recs f 453 | (cdr es))))))))) 454 | (defun expr-recs (f e) 455 | (exprs-recs f (list1 e))) 456 | 457 | (defun totality/< (meas formals app) 458 | (app-c '< 459 | (list2 (sub-e formals (app.args app) meas) 460 | meas))) 461 | 462 | (defun totality/meas (meas formals apps) 463 | (if (atom apps) 464 | '() 465 | (cons 466 | (totality/< meas formals (car apps)) 467 | (totality/meas meas formals (cdr apps))))) 468 | 469 | (defun totality/if (meas f formals e) 470 | (if (if? e) 471 | (conjunction 472 | (list-extend 473 | (totality/meas meas formals 474 | (expr-recs f (if.Q e))) 475 | (if-c-when-necessary (if.Q e) 476 | (totality/if meas f formals 477 | (if.A e)) 478 | (totality/if meas f formals 479 | (if.E e))))) 480 | (conjunction 481 | (totality/meas meas formals 482 | (expr-recs f e))))) 483 | 484 | (defun totality/claim (meas def) 485 | (if (equal meas 'nil) 486 | (if (equal (expr-recs (defun.name def) 487 | (defun.body def)) 488 | '()) 489 | (quote-c 't) 490 | (quote-c 'nil)) 491 | (if-c 492 | (app-c 'natp (list1 meas)) 493 | (totality/if meas (defun.name def) 494 | (defun.formals def) 495 | (defun.body def)) 496 | (quote-c 'nil)))) 497 | 498 | (defun induction/prems (vars claim apps) 499 | (if (atom apps) 500 | '() 501 | (cons 502 | (sub-e vars (app.args (car apps)) claim) 503 | (induction/prems vars claim (cdr apps))))) 504 | 505 | (defun induction/if (vars claim f e) 506 | (if (if? e) 507 | (implication 508 | (induction/prems vars claim 509 | (expr-recs f (if.Q e))) 510 | (if-c-when-necessary (if.Q e) 511 | (induction/if vars claim f (if.A e)) 512 | (induction/if vars claim f (if.E e)))) 513 | (implication 514 | (induction/prems vars claim 515 | (expr-recs f e)) 516 | claim))) 517 | 518 | (defun induction/defun (vars claim def) 519 | (induction/if vars claim (defun.name def) 520 | (sub-e (defun.formals def) vars 521 | (defun.body def)))) 522 | 523 | (defun induction/claim (defs seed def) 524 | (if (equal seed 'nil) 525 | (dethm.body def) 526 | (induction/defun (app.args seed) 527 | (dethm.body def) 528 | (lookup (app.name seed) defs)))) 529 | 530 | (defun find-focus-at-direction (dir e) 531 | (if (equal dir 'Q) 532 | (if.Q e) 533 | (if (equal dir 'A) 534 | (if.A e) 535 | (if (equal dir 'E) 536 | (if.E e) 537 | (get-arg dir (app.args e)))))) 538 | 539 | (defun rewrite-focus-at-direction (dir e1 e2) 540 | (if (equal dir 'Q) 541 | (if-c e2 (if.A e1) (if.E e1)) 542 | (if (equal dir 'A) 543 | (if-c (if.Q e1) e2 (if.E e1)) 544 | (if (equal dir 'E) 545 | (if-c (if.Q e1) (if.A e1) e2) 546 | (app-c (app.name e1) 547 | (set-arg dir (app.args e1) e2)))))) 548 | 549 | (defun focus-is-at-direction? (dir e) 550 | (if (equal dir 'Q) 551 | (if? e) 552 | (if (equal dir 'A) 553 | (if? e) 554 | (if (equal dir 'E) 555 | (if? e) 556 | (if (app? e) 557 | (<=len dir (app.args e)) 558 | 'nil))))) 559 | 560 | (defun focus-is-at-path? (path e) 561 | (if (atom path) 562 | 't 563 | (if (focus-is-at-direction? (car path) e) 564 | (focus-is-at-path? (cdr path) 565 | (find-focus-at-direction (car path) e)) 566 | 'nil))) 567 | 568 | (defun find-focus-at-path (path e) 569 | (if (atom path) 570 | e 571 | (find-focus-at-path (cdr path) 572 | (find-focus-at-direction (car path) e)))) 573 | 574 | (defun rewrite-focus-at-path (path e1 e2) 575 | (if (atom path) 576 | e2 577 | (rewrite-focus-at-direction (car path) e1 578 | (rewrite-focus-at-path (cdr path) 579 | (find-focus-at-direction (car path) e1) 580 | e2)))) 581 | 582 | (defun prem-A? (prem path e) 583 | (if (atom path) 584 | 'nil 585 | (if (equal (car path) 'A) 586 | (if (equal (if.Q e) prem) 587 | 't 588 | (prem-A? prem (cdr path) 589 | (find-focus-at-direction (car path) 590 | e))) 591 | (prem-A? prem (cdr path) 592 | (find-focus-at-direction (car path) 593 | e))))) 594 | 595 | (defun prem-E? (prem path e) 596 | (if (atom path) 597 | 'nil 598 | (if (equal (car path) 'E) 599 | (if (equal (if.Q e) prem) 600 | 't 601 | (prem-E? prem (cdr path) 602 | (find-focus-at-direction (car path) 603 | e))) 604 | (prem-E? prem (cdr path) 605 | (find-focus-at-direction (car path) 606 | e))))) 607 | 608 | (defun follow-prems (path e thm) 609 | (if (if? thm) 610 | (if (prem-A? (if.Q thm) path e) 611 | (follow-prems path e (if.A thm)) 612 | (if (prem-E? (if.Q thm) path e) 613 | (follow-prems path e (if.E thm)) 614 | thm)) 615 | thm)) 616 | 617 | (defun unary-op (rator rand) 618 | (if (equal rator 'atom) 619 | (atom rand) 620 | (if (equal rator 'car) 621 | (car rand) 622 | (if (equal rator 'cdr) 623 | (cdr rand) 624 | (if (equal rator 'natp) 625 | (natp rand) 626 | (if (equal rator 'size) 627 | (size rand) 628 | 'nil)))))) 629 | 630 | (defun binary-op (rator rand1 rand2) 631 | (if (equal rator 'equal) 632 | (equal rand1 rand2) 633 | (if (equal rator 'cons) 634 | (cons rand1 rand2) 635 | (if (equal rator '+) 636 | (+ rand1 rand2) 637 | (if (equal rator '<) 638 | (< rand1 rand2) 639 | 'nil))))) 640 | 641 | (defun apply-op (rator rands) 642 | (if (member? rator '(atom car cdr natp size)) 643 | (unary-op rator (elem1 rands)) 644 | (if (member? rator '(equal cons + <)) 645 | (binary-op rator 646 | (elem1 rands) 647 | (elem2 rands)) 648 | 'nil))) 649 | 650 | (defun rands (args) 651 | (if (atom args) 652 | '() 653 | (cons (quote.value (car args)) 654 | (rands (cdr args))))) 655 | 656 | (defun eval-op (app) 657 | (quote-c 658 | (apply-op (app.name app) 659 | (rands (app.args app))))) 660 | 661 | (defun app-of-equal? (e) 662 | (if (app? e) 663 | (equal (app.name e) 'equal) 664 | 'nil)) 665 | 666 | (defun equality (focus a b) 667 | (if (equal focus a) 668 | b 669 | (if (equal focus b) 670 | a 671 | focus))) 672 | 673 | (defun equality/equation (focus concl-inst) 674 | (if (app-of-equal? concl-inst) 675 | (equality focus 676 | (elem1 (app.args concl-inst)) 677 | (elem2 (app.args concl-inst))) 678 | focus)) 679 | 680 | (defun equality/path (e path thm) 681 | (if (focus-is-at-path? path e) 682 | (rewrite-focus-at-path path e 683 | (equality/equation 684 | (find-focus-at-path path e) 685 | (follow-prems path e thm))) 686 | e)) 687 | 688 | (defun equality/def (claim path app def) 689 | (if (rator? def) 690 | (equality/path claim path 691 | (app-c 'equal (list2 app (eval-op app)))) 692 | (if (defun? def) 693 | (equality/path claim path 694 | (sub-e (defun.formals def) 695 | (app.args app) 696 | (app-c 'equal 697 | (list2 698 | (app-c (defun.name def) 699 | (defun.formals def)) 700 | (defun.body def))))) 701 | (if (dethm? def) 702 | (equality/path claim path 703 | (sub-e (dethm.formals def) 704 | (app.args app) 705 | (dethm.body def))) 706 | claim)))) 707 | 708 | (defun rewrite/step (defs claim step) 709 | (equality/def claim (elem1 step) (elem2 step) 710 | (lookup (app.name (elem2 step)) defs))) 711 | 712 | (defun rewrite/continue (defs steps old new) 713 | (if (equal new old) 714 | new 715 | (if (atom steps) 716 | new 717 | (rewrite/continue defs (cdr steps) new 718 | (rewrite/step defs new (car steps)))))) 719 | 720 | (defun rewrite/steps (defs claim steps) 721 | (if (atom steps) 722 | claim 723 | (rewrite/continue defs (cdr steps) claim 724 | (rewrite/step defs claim (car steps))))) 725 | 726 | (defun rewrite/prove (defs def seed steps) 727 | (if (defun? def) 728 | (rewrite/steps defs 729 | (totality/claim seed def) 730 | steps) 731 | (if (dethm? def) 732 | (rewrite/steps defs 733 | (induction/claim defs seed def) 734 | steps) 735 | (quote-c 'nil)))) 736 | 737 | (defun rewrite/prove+1 (defs pf e) 738 | (if (equal e (quote-c 't)) 739 | (rewrite/prove defs (elem1 pf) (elem2 pf) 740 | (cdr (cdr pf))) 741 | e)) 742 | 743 | (defun rewrite/prove+ (defs pfs) 744 | (declare (xargs :measure (size pfs))) 745 | (if (atom pfs) 746 | (quote-c 't) 747 | (rewrite/prove+1 defs (car pfs) 748 | (rewrite/prove+ 749 | (list-extend defs (elem1 (car pfs))) 750 | (cdr pfs))))) 751 | 752 | (defun rewrite/define (defs def seed steps) 753 | (if (equal (rewrite/prove defs def seed steps) 754 | (quote-c 't)) 755 | (list-extend defs def) 756 | defs)) 757 | 758 | (defun rewrite/define+1 (defs1 defs2 pfs) 759 | (declare (xargs :measure (size pfs))) 760 | (if (equal defs1 defs2) 761 | defs1 762 | (if (atom pfs) 763 | defs2 764 | (rewrite/define+1 defs2 765 | (rewrite/define defs2 766 | (elem1 (car pfs)) 767 | (elem2 (car pfs)) 768 | (cdr (cdr (car pfs)))) 769 | (cdr pfs))))) 770 | 771 | (defun rewrite/define+ (defs pfs) 772 | (if (atom pfs) 773 | defs 774 | (rewrite/define+1 defs 775 | (rewrite/define defs 776 | (elem1 (car pfs)) 777 | (elem2 (car pfs)) 778 | (cdr (cdr (car pfs)))) 779 | (cdr pfs)))) 780 | 781 | (defun J-Bob/step (defs e steps) 782 | (if (defs? '() defs) 783 | (if (expr? defs 'any e) 784 | (if (steps? defs steps) 785 | (rewrite/steps defs e steps) 786 | e) 787 | e) 788 | e)) 789 | 790 | (defun J-Bob/prove (defs pfs) 791 | (if (defs? '() defs) 792 | (if (proofs? defs pfs) 793 | (rewrite/prove+ defs pfs) 794 | (quote-c 'nil)) 795 | (quote-c 'nil))) 796 | 797 | (defun J-Bob/define (defs pfs) 798 | (if (defs? '() defs) 799 | (if (proofs? defs pfs) 800 | (rewrite/define+ defs pfs) 801 | defs) 802 | defs)) 803 | 804 | (defun axioms () 805 | '((dethm atom/cons (x y) 806 | (equal (atom (cons x y)) 'nil)) 807 | (dethm car/cons (x y) 808 | (equal (car (cons x y)) x)) 809 | (dethm cdr/cons (x y) 810 | (equal (cdr (cons x y)) y)) 811 | (dethm equal-same (x) 812 | (equal (equal x x) 't)) 813 | (dethm equal-swap (x y) 814 | (equal (equal x y) (equal y x))) 815 | (dethm if-same (x y) 816 | (equal (if x y y) y)) 817 | (dethm if-true (x y) 818 | (equal (if 't x y) x)) 819 | (dethm if-false (x y) 820 | (equal (if 'nil x y) y)) 821 | (dethm if-nest-E (x y z) 822 | (if x 't (equal (if x y z) z))) 823 | (dethm if-nest-A (x y z) 824 | (if x (equal (if x y z) y) 't)) 825 | (dethm cons/car+cdr (x) 826 | (if (atom x) 827 | 't 828 | (equal (cons (car x) (cdr x)) x))) 829 | (dethm equal-if (x y) 830 | (if (equal x y) (equal x y) 't)) 831 | (dethm natp/size (x) 832 | (equal (natp (size x)) 't)) 833 | (dethm size/car (x) 834 | (if (atom x) 835 | 't 836 | (equal (< (size (car x)) (size x)) 't))) 837 | (dethm size/cdr (x) 838 | (if (atom x) 839 | 't 840 | (equal (< (size (cdr x)) (size x)) 't))) 841 | (dethm associate-+ (a b c) 842 | (equal (+ (+ a b) c) (+ a (+ b c)))) 843 | (dethm commute-+ (x y) 844 | (equal (+ x y) (+ y x))) 845 | (dethm natp/+ (x y) 846 | (if (natp x) 847 | (if (natp y) 848 | (equal (natp (+ x y)) 't) 849 | 't) 850 | 't)) 851 | (dethm positives-+ (x y) 852 | (if (< '0 x) 853 | (if (< '0 y) 854 | (equal (< '0 (+ x y)) 't) 855 | 't) 856 | 't)) 857 | (dethm common-addends-< (x y z) 858 | (equal (< (+ x z) (+ y z)) (< x y))) 859 | (dethm identity-+ (x) 860 | (if (natp x) (equal (+ '0 x) x) 't)))) 861 | 862 | (defun prelude () 863 | (J-Bob/define (axioms) 864 | '(((defun list-induction (x) 865 | (if (atom x) 866 | '() 867 | (cons (car x) 868 | (list-induction (cdr x))))) 869 | (size x) 870 | ((A E) (size/cdr x)) 871 | ((A) (if-same (atom x) 't)) 872 | ((Q) (natp/size x)) 873 | (() (if-true 't 'nil))) 874 | ((defun star-induction (x) 875 | (if (atom x) 876 | x 877 | (cons (star-induction (car x)) 878 | (star-induction (cdr x))))) 879 | (size x) 880 | ((A E A) (size/cdr x)) 881 | ((A E Q) (size/car x)) 882 | ((A E) (if-true 't 'nil)) 883 | ((A) (if-same (atom x) 't)) 884 | ((Q) (natp/size x)) 885 | (() (if-true 't 'nil)))))) 886 | -------------------------------------------------------------------------------- /acl2/little-prover.lisp: -------------------------------------------------------------------------------- 1 | (in-package "ACL2") 2 | (include-book "j-bob") 3 | 4 | ;; Chapter 1 5 | 6 | (defun chapter1.example1 () 7 | (J-Bob/step (prelude) 8 | '(car (cons 'ham '(eggs))) 9 | '(((1) (cons 'ham '(eggs))) 10 | (() (car '(ham eggs)))))) 11 | 12 | (defun chapter1.example2 () 13 | (J-Bob/step (prelude) 14 | '(atom '()) 15 | '((() (atom '()))))) 16 | 17 | (defun chapter1.example3 () 18 | (J-Bob/step (prelude) 19 | '(atom (cons 'ham '(eggs))) 20 | '(((1) (cons 'ham '(eggs))) 21 | (() (atom '(ham eggs)))))) 22 | 23 | (defun chapter1.example4 () 24 | (J-Bob/step (prelude) 25 | '(atom (cons a b)) 26 | '((() (atom/cons a b))))) 27 | 28 | (defun chapter1.example5 () 29 | (J-Bob/step (prelude) 30 | '(equal 'flapjack (atom (cons a b))) 31 | '(((2) (atom/cons a b)) 32 | (() (equal 'flapjack 'nil))))) 33 | 34 | (defun chapter1.example6 () 35 | (J-Bob/step (prelude) 36 | '(atom (cdr (cons (car (cons p q)) '()))) 37 | '(((1 1 1) (car/cons p q)) 38 | ((1) (cdr/cons p '())) 39 | (() (atom '()))))) 40 | 41 | (defun chapter1.example7 () 42 | (J-Bob/step (prelude) 43 | '(atom (cdr (cons (car (cons p q)) '()))) 44 | '(((1) (cdr/cons (car (cons p q)) '())) 45 | (() (atom '()))))) 46 | 47 | (defun chapter1.example8 () 48 | (J-Bob/step (prelude) 49 | '(car (cons (equal (cons x y) (cons x y)) '(and crumpets))) 50 | '(((1 1) (equal-same (cons x y))) 51 | ((1) (cons 't '(and crumpets))) 52 | (() (car '(t and crumpets)))))) 53 | 54 | (defun chapter1.example9 () 55 | (J-Bob/step (prelude) 56 | '(equal (cons x y) (cons 'bagels '(and lox))) 57 | '((() (equal-swap (cons x y) (cons 'bagels '(and lox))))))) 58 | 59 | (defun chapter1.example10 () 60 | (J-Bob/step (prelude) 61 | '(cons y (equal (car (cons (cdr x) (car y))) (equal (atom x) 'nil))) 62 | '(((2 1) (car/cons (cdr x) (car y)))))) 63 | 64 | (defun chapter1.example11 () 65 | (J-Bob/step (prelude) 66 | '(cons y (equal (car (cons (cdr x) (car y))) (equal (atom x) 'nil))) 67 | '(((2 1) (car/cons (car (cons (cdr x) (car y))) '(oats))) 68 | ((2 2 2) (atom/cons (atom (cdr (cons a b))) (equal (cons a b) c))) 69 | ((2 2 2 1 1 1) (cdr/cons a b)) 70 | ((2 2 2 1 2) (equal-swap (cons a b) c))))) 71 | 72 | (defun chapter1.example12 () 73 | (J-Bob/step (prelude) 74 | '(atom (car (cons (car a) (cdr b)))) 75 | '(((1) (car/cons (car a) (cdr b)))))) 76 | 77 | ;; Chapter 2 78 | 79 | (defun chapter2.example1 () 80 | (J-Bob/step (prelude) 81 | '(if (car (cons a b)) c c) 82 | '(((Q) (car/cons a b)) 83 | (() (if-same a c)) 84 | (() 85 | (if-same 86 | (if (equal a 't) (if (equal 'nil 'nil) a b) (equal 'or (cons 'black '(coffee)))) 87 | c)) 88 | ((Q E 2) (cons 'black '(coffee))) 89 | ((Q A Q) (equal-same 'nil)) 90 | ((Q A) (if-true a b)) 91 | ((Q A) (equal-if a 't))))) 92 | 93 | (defun chapter2.example2 () 94 | (J-Bob/step (prelude) 95 | '(if (atom (car a)) 96 | (if (equal (car a) (cdr a)) 'hominy 'grits) 97 | (if (equal (cdr (car a)) '(hash browns)) 98 | (cons 'ketchup (car a)) 99 | (cons 'mustard (car a)))) 100 | '(((E A 2) (cons/car+cdr (car a))) 101 | ((E A 2 2) (equal-if (cdr (car a)) '(hash browns)))))) 102 | 103 | (defun chapter2.example3 () 104 | (J-Bob/step (prelude) 105 | '(cons 'statement 106 | (cons (if (equal a 'question) (cons n '(answer)) (cons n '(else))) 107 | (if (equal a 'question) (cons n '(other answer)) (cons n '(other else))))) 108 | '(((2) 109 | (if-same (equal a 'question) 110 | (cons (if (equal a 'question) (cons n '(answer)) (cons n '(else))) 111 | (if (equal a 'question) (cons n '(other answer)) (cons n '(other else)))))) 112 | ((2 A 1) (if-nest-A (equal a 'question) (cons n '(answer)) (cons n '(else)))) 113 | ((2 E 1) (if-nest-E (equal a 'question) (cons n '(answer)) (cons n '(else)))) 114 | ((2 A 2) 115 | (if-nest-A (equal a 'question) (cons n '(other answer)) (cons n '(other else)))) 116 | ((2 E 2) 117 | (if-nest-E (equal a 'question) 118 | (cons n '(other answer)) 119 | (cons n '(other else))))))) 120 | 121 | ;; Chapter 3 122 | 123 | (defun defun.pair () 124 | (J-Bob/define (prelude) 125 | '(((defun pair (x y) 126 | (cons x (cons y '()))) 127 | nil)))) 128 | 129 | (defun defun.first-of () 130 | (J-Bob/define (defun.pair) 131 | '(((defun first-of (x) 132 | (car x)) 133 | nil)))) 134 | 135 | (defun defun.second-of () 136 | (J-Bob/define (defun.first-of) 137 | '(((defun second-of (x) 138 | (car (cdr x))) 139 | nil)))) 140 | 141 | (defun dethm.first-of-pair () 142 | (J-Bob/define (defun.second-of) 143 | '(((dethm first-of-pair (a b) 144 | (equal (first-of (pair a b)) a)) 145 | nil 146 | ((1 1) (pair a b)) 147 | ((1) (first-of (cons a (cons b '())))) 148 | ((1) (car/cons a (cons b '()))) 149 | (() (equal-same a)))))) 150 | 151 | (defun dethm.second-of-pair () 152 | (J-Bob/define (dethm.first-of-pair) 153 | '(((dethm second-of-pair (a b) 154 | (equal (second-of (pair a b)) b)) 155 | nil 156 | ((1) (second-of (pair a b))) 157 | ((1 1 1) (pair a b)) 158 | ((1 1) (cdr/cons a (cons b '()))) 159 | ((1) (car/cons b '())) 160 | (() (equal-same b)))))) 161 | 162 | (defun defun.in-pair? () 163 | (J-Bob/define (dethm.second-of-pair) 164 | '(((defun in-pair? (xs) 165 | (if (equal (first-of xs) '?) 't (equal (second-of xs) '?))) 166 | nil)))) 167 | 168 | (defun dethm.in-first-of-pair () 169 | (J-Bob/define (defun.in-pair?) 170 | '(((dethm in-first-of-pair (b) 171 | (equal (in-pair? (pair '? b)) 't)) 172 | nil 173 | ((1 1) (pair '? b)) 174 | ((1) (in-pair? (cons '? (cons b '())))) 175 | ((1 Q 1) (first-of (cons '? (cons b '())))) 176 | ((1 Q 1) (car/cons '? (cons b '()))) 177 | ((1 Q) (equal-same '?)) 178 | ((1) (if-true 't (equal (second-of (cons '? (cons b '()))) '?))) 179 | (() (equal-same 't)))))) 180 | 181 | (defun dethm.in-second-of-pair () 182 | (J-Bob/define (dethm.in-first-of-pair) 183 | '(((dethm in-second-of-pair (a) 184 | (equal (in-pair? (pair a '?)) 't)) 185 | nil 186 | ((1 1) (pair a '?)) 187 | ((1) (in-pair? (cons a (cons '? '())))) 188 | ((1 Q 1) (first-of (cons a (cons '? '())))) 189 | ((1 Q 1) (car/cons a (cons '? '()))) 190 | ((1 E 1) (second-of (cons a (cons '? '())))) 191 | ((1 E 1 1) (cdr/cons a (cons '? '()))) 192 | ((1 E 1) (car/cons '? '())) 193 | ((1 E) (equal-same '?)) 194 | ((1) (if-same (equal a '?) 't)) 195 | (() (equal-same 't)))))) 196 | 197 | ;; Chapter 4 198 | 199 | (defun defun.list0? () 200 | (J-Bob/define (dethm.in-second-of-pair) 201 | '(((defun list0? (x) 202 | (equal x '())) 203 | nil)))) 204 | 205 | (defun defun.list1? () 206 | (J-Bob/define (defun.list0?) 207 | '(((defun list1? (x) 208 | (if (atom x) 'nil (list0? (cdr x)))) 209 | nil)))) 210 | 211 | (defun defun.list2? () 212 | (J-Bob/define (defun.list1?) 213 | '(((defun list2? (x) 214 | (if (atom x) 'nil (list1? (cdr x)))) 215 | nil)))) 216 | 217 | (defun dethm.contradiction () 218 | (J-Bob/prove 219 | (list-extend (prelude) 220 | '(defun partial (x) 221 | (if (partial x) 'nil 't))) 222 | '(((dethm contradiction () 'nil) 223 | nil 224 | (() (if-same (partial x) 'nil)) 225 | ((A) (if-nest-A (partial x) 'nil 't)) 226 | ((E) (if-nest-E (partial x) 't 'nil)) 227 | ((A Q) (partial x)) 228 | ((E Q) (partial x)) 229 | ((A Q) (if-nest-A (partial x) 'nil 't)) 230 | ((E Q) (if-nest-E (partial x) 'nil 't)) 231 | ((A) (if-false 'nil 't)) 232 | ((E) (if-true 't 'nil)) 233 | (() (if-same (partial x) 't)))))) 234 | 235 | (defun defun.list? () 236 | (J-Bob/define (defun.list2?) 237 | '(((defun list? (x) 238 | (if (atom x) (equal x '()) (list? (cdr x)))) 239 | (size x) 240 | ((Q) (natp/size x)) 241 | (() (if-true (if (atom x) 't (< (size (cdr x)) (size x))) 'nil)) 242 | ((E) (size/cdr x)) 243 | (() (if-same (atom x) 't)))))) 244 | 245 | (defun defun.sub () 246 | (J-Bob/define (defun.list?) 247 | '(((defun sub (x y) 248 | (if (atom y) (if (equal y '?) x y) (cons (sub x (car y)) (sub x (cdr y))))) 249 | (size y) 250 | ((Q) (natp/size y)) 251 | (() 252 | (if-true 253 | (if (atom y) 254 | 't 255 | (if (< (size (car y)) (size y)) (< (size (cdr y)) (size y)) 'nil)) 256 | 'nil)) 257 | ((E Q) (size/car y)) 258 | ((E A) (size/cdr y)) 259 | ((E) (if-true 't 'nil)) 260 | (() (if-same (atom y) 't)))))) 261 | 262 | ;; Chapter 5 263 | 264 | (defun defun.memb? () 265 | (J-Bob/define (defun.sub) 266 | '(((defun memb? (xs) 267 | (if (atom xs) 'nil (if (equal (car xs) '?) 't (memb? (cdr xs))))) 268 | (size xs) 269 | ((Q) (natp/size xs)) 270 | (() 271 | (if-true 272 | (if (atom xs) 't (if (equal (car xs) '?) 't (< (size (cdr xs)) (size xs)))) 273 | 'nil)) 274 | ((E E) (size/cdr xs)) 275 | ((E) (if-same (equal (car xs) '?) 't)) 276 | (() (if-same (atom xs) 't)))))) 277 | 278 | (defun defun.remb () 279 | (J-Bob/define (defun.memb?) 280 | '(((defun remb (xs) 281 | (if (atom xs) 282 | '() 283 | (if (equal (car xs) '?) (remb (cdr xs)) (cons (car xs) (remb (cdr xs)))))) 284 | (size xs) 285 | ((Q) (natp/size xs)) 286 | (() (if-true (if (atom xs) 't (< (size (cdr xs)) (size xs))) 'nil)) 287 | ((E) (size/cdr xs)) 288 | (() (if-same (atom xs) 't)))))) 289 | 290 | (defun dethm.memb?/remb0 () 291 | (J-Bob/define (defun.remb) 292 | '(((dethm memb?/remb0 () 293 | (equal (memb? (remb '())) 'nil)) 294 | nil 295 | ((1 1) (remb '())) 296 | ((1 1 Q) (atom '())) 297 | ((1 1) 298 | (if-true '() 299 | (if (equal (car '()) '?) (remb (cdr '())) (cons (car '()) (remb (cdr '())))))) 300 | ((1) (memb? '())) 301 | ((1 Q) (atom '())) 302 | ((1) (if-true 'nil (if (equal (car '()) '?) 't (memb? (cdr '()))))) 303 | (() (equal-same 'nil)))))) 304 | 305 | (defun dethm.memb?/remb1 () 306 | (J-Bob/define (dethm.memb?/remb0) 307 | '(((dethm memb?/remb1 (x1) 308 | (equal (memb? (remb (cons x1 '()))) 'nil)) 309 | nil 310 | ((1 1) (remb (cons x1 '()))) 311 | ((1 1 Q) (atom/cons x1 '())) 312 | ((1 1) 313 | (if-false '() 314 | (if (equal (car (cons x1 '())) '?) 315 | (remb (cdr (cons x1 '()))) 316 | (cons (car (cons x1 '())) (remb (cdr (cons x1 '()))))))) 317 | ((1 1 Q 1) (car/cons x1 '())) 318 | ((1 1 A 1) (cdr/cons x1 '())) 319 | ((1 1 E 1) (car/cons x1 '())) 320 | ((1 1 E 2 1) (cdr/cons x1 '())) 321 | ((1) 322 | (if-same (equal x1 '?) 323 | (memb? (if (equal x1 '?) (remb '()) (cons x1 (remb '())))))) 324 | ((1 A 1) (if-nest-A (equal x1 '?) (remb '()) (cons x1 (remb '())))) 325 | ((1 E 1) (if-nest-E (equal x1 '?) (remb '()) (cons x1 (remb '())))) 326 | ((1 A) (memb?/remb0)) 327 | ((1 E) (memb? (cons x1 (remb '())))) 328 | ((1 E Q) (atom/cons x1 (remb '()))) 329 | ((1 E) 330 | (if-false 'nil 331 | (if (equal (car (cons x1 (remb '()))) '?) 332 | 't 333 | (memb? (cdr (cons x1 (remb '()))))))) 334 | ((1 E Q 1) (car/cons x1 (remb '()))) 335 | ((1 E E 1) (cdr/cons x1 (remb '()))) 336 | ((1 E) (if-nest-E (equal x1 '?) 't (memb? (remb '())))) 337 | ((1 E) (memb?/remb0)) 338 | ((1) (if-same (equal x1 '?) 'nil)) 339 | (() (equal-same 'nil)))))) 340 | 341 | (defun dethm.memb?/remb2 () 342 | (J-Bob/define (dethm.memb?/remb1) 343 | '(((dethm memb?/remb2 (x1 x2) 344 | (equal (memb? (remb (cons x2 (cons x1 '())))) 'nil)) 345 | nil 346 | ((1 1) (remb (cons x2 (cons x1 '())))) 347 | ((1 1 Q) (atom/cons x2 (cons x1 '()))) 348 | ((1 1) 349 | (if-false '() 350 | (if (equal (car (cons x2 (cons x1 '()))) '?) 351 | (remb (cdr (cons x2 (cons x1 '())))) 352 | (cons (car (cons x2 (cons x1 '()))) 353 | (remb (cdr (cons x2 (cons x1 '())))))))) 354 | ((1 1 Q 1) (car/cons x2 (cons x1 '()))) 355 | ((1 1 A 1) (cdr/cons x2 (cons x1 '()))) 356 | ((1 1 E 1) (car/cons x2 (cons x1 '()))) 357 | ((1 1 E 2 1) (cdr/cons x2 (cons x1 '()))) 358 | ((1) 359 | (if-same (equal x2 '?) 360 | (memb? 361 | (if (equal x2 '?) (remb (cons x1 '())) (cons x2 (remb (cons x1 '()))))))) 362 | ((1 A 1) 363 | (if-nest-A (equal x2 '?) (remb (cons x1 '())) (cons x2 (remb (cons x1 '()))))) 364 | ((1 E 1) 365 | (if-nest-E (equal x2 '?) (remb (cons x1 '())) (cons x2 (remb (cons x1 '()))))) 366 | ((1 A) (memb?/remb1 x1)) 367 | ((1 E) (memb? (cons x2 (remb (cons x1 '()))))) 368 | ((1 E Q) (atom/cons x2 (remb (cons x1 '())))) 369 | ((1 E) 370 | (if-false 'nil 371 | (if (equal (car (cons x2 (remb (cons x1 '())))) '?) 372 | 't 373 | (memb? (cdr (cons x2 (remb (cons x1 '())))))))) 374 | ((1 E Q 1) (car/cons x2 (remb (cons x1 '())))) 375 | ((1 E E 1) (cdr/cons x2 (remb (cons x1 '())))) 376 | ((1 E) (if-nest-E (equal x2 '?) 't (memb? (remb (cons x1 '()))))) 377 | ((1 E) (memb?/remb1 x1)) 378 | ((1) (if-same (equal x2 '?) 'nil)) 379 | (() (equal-same 'nil)))))) 380 | 381 | ;; Chapter 6 382 | 383 | (defun dethm.memb?/remb () 384 | (J-Bob/define (dethm.memb?/remb2) 385 | '(((dethm memb?/remb (xs) 386 | (equal (memb? (remb xs)) 'nil)) 387 | (list-induction xs) 388 | ((A 1 1) (remb xs)) 389 | ((A 1 1) 390 | (if-nest-A (atom xs) 391 | '() 392 | (if (equal (car xs) '?) (remb (cdr xs)) (cons (car xs) (remb (cdr xs)))))) 393 | ((A 1) (memb? '())) 394 | ((A 1 Q) (atom '())) 395 | ((A 1) (if-true 'nil (if (equal (car '()) '?) 't (memb? (cdr '()))))) 396 | ((A) (equal-same 'nil)) 397 | ((E A 1 1) (remb xs)) 398 | ((E A 1 1) 399 | (if-nest-E (atom xs) 400 | '() 401 | (if (equal (car xs) '?) (remb (cdr xs)) (cons (car xs) (remb (cdr xs)))))) 402 | ((E A 1) 403 | (if-same (equal (car xs) '?) 404 | (memb? 405 | (if (equal (car xs) '?) (remb (cdr xs)) (cons (car xs) (remb (cdr xs))))))) 406 | ((E A 1 A 1) 407 | (if-nest-A (equal (car xs) '?) (remb (cdr xs)) (cons (car xs) (remb (cdr xs))))) 408 | ((E A 1 E 1) 409 | (if-nest-E (equal (car xs) '?) (remb (cdr xs)) (cons (car xs) (remb (cdr xs))))) 410 | ((E A 1 A) (equal-if (memb? (remb (cdr xs))) 'nil)) 411 | ((E A 1 E) (memb? (cons (car xs) (remb (cdr xs))))) 412 | ((E A 1 E Q) (atom/cons (car xs) (remb (cdr xs)))) 413 | ((E A 1 E) 414 | (if-false 'nil 415 | (if (equal (car (cons (car xs) (remb (cdr xs)))) '?) 416 | 't 417 | (memb? (cdr (cons (car xs) (remb (cdr xs)))))))) 418 | ((E A 1 E Q 1) (car/cons (car xs) (remb (cdr xs)))) 419 | ((E A 1 E E 1) (cdr/cons (car xs) (remb (cdr xs)))) 420 | ((E A 1 E) (if-nest-E (equal (car xs) '?) 't (memb? (remb (cdr xs))))) 421 | ((E A 1 E) (equal-if (memb? (remb (cdr xs))) 'nil)) 422 | ((E A 1) (if-same (equal (car xs) '?) 'nil)) 423 | ((E A) (equal-same 'nil)) 424 | ((E) (if-same (equal (memb? (remb (cdr xs))) 'nil) 't)) 425 | (() (if-same (atom xs) 't)))))) 426 | 427 | ;; Chapter 7 428 | 429 | (defun defun.ctx? () 430 | (J-Bob/define (dethm.memb?/remb) 431 | '(((defun ctx? (x) 432 | (if (atom x) (equal x '?) (if (ctx? (car x)) 't (ctx? (cdr x))))) 433 | (size x) 434 | ((Q) (natp/size x)) 435 | (() 436 | (if-true 437 | (if (atom x) 438 | 't 439 | (if (< (size (car x)) (size x)) 440 | (if (ctx? (car x)) 't (< (size (cdr x)) (size x))) 441 | 'nil)) 442 | 'nil)) 443 | ((E Q) (size/car x)) 444 | ((E A E) (size/cdr x)) 445 | ((E A) (if-same (ctx? (car x)) 't)) 446 | ((E) (if-true 't 'nil)) 447 | (() (if-same (atom x) 't)))))) 448 | 449 | (defun dethm.ctx?/sub () 450 | (J-Bob/define (defun.ctx?) 451 | '(((dethm ctx?/t (x) 452 | (if (ctx? x) (equal (ctx? x) 't) 't)) 453 | (star-induction x) 454 | ((A A 1) (ctx? x)) 455 | ((A A 1) (if-nest-A (atom x) (equal x '?) (if (ctx? (car x)) 't (ctx? (cdr x))))) 456 | ((A Q) (ctx? x)) 457 | ((A Q) (if-nest-A (atom x) (equal x '?) (if (ctx? (car x)) 't (ctx? (cdr x))))) 458 | ((A A 1 1) (equal-if x '?)) 459 | ((A A 1) (equal-same '?)) 460 | ((A A) (equal-same 't)) 461 | ((A) (if-same (equal x '?) 't)) 462 | ((E A A A 1) (ctx? x)) 463 | ((E A A A 1) 464 | (if-nest-E (atom x) (equal x '?) (if (ctx? (car x)) 't (ctx? (cdr x))))) 465 | ((E) 466 | (if-same (ctx? (car x)) 467 | (if (if (ctx? (car x)) (equal (ctx? (car x)) 't) 't) 468 | (if (if (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't) 469 | (if (ctx? x) (equal (if (ctx? (car x)) 't (ctx? (cdr x))) 't) 't) 470 | 't) 471 | 't))) 472 | ((E A Q) (if-nest-A (ctx? (car x)) (equal (ctx? (car x)) 't) 't)) 473 | ((E A A A A 1) (if-nest-A (ctx? (car x)) 't (ctx? (cdr x)))) 474 | ((E E Q) (if-nest-E (ctx? (car x)) (equal (ctx? (car x)) 't) 't)) 475 | ((E E A A A 1) (if-nest-E (ctx? (car x)) 't (ctx? (cdr x)))) 476 | ((E A A A A) (equal-same 't)) 477 | ((E E) 478 | (if-true 479 | (if (if (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't) 480 | (if (ctx? x) (equal (ctx? (cdr x)) 't) 't) 481 | 't) 482 | 't)) 483 | ((E A A A) (if-same (ctx? x) 't)) 484 | ((E A A) (if-same (if (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't) 't)) 485 | ((E A) (if-same (equal (ctx? (car x)) 't) 't)) 486 | ((E E A Q) (ctx? x)) 487 | ((E E A Q) 488 | (if-nest-E (atom x) (equal x '?) (if (ctx? (car x)) 't (ctx? (cdr x))))) 489 | ((E E A Q) (if-nest-E (ctx? (car x)) 't (ctx? (cdr x)))) 490 | ((E E) 491 | (if-same (ctx? (cdr x)) 492 | (if (if (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't) 493 | (if (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't) 494 | 't))) 495 | ((E E A Q)(if-nest-A (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't)) 496 | ((E E A A)(if-nest-A (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't)) 497 | ((E E E Q)(if-nest-E (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't)) 498 | ((E E E A)(if-nest-E (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't)) 499 | ((E E E) (if-same 't 't)) 500 | ((E E A A 1) (equal-if (ctx? (cdr x)) 't)) 501 | ((E E A A) (equal-same 't)) 502 | ((E E A) (if-same (equal (ctx? (cdr x)) 't) 't)) 503 | ((E E) (if-same (ctx? (cdr x)) 't)) 504 | ((E) (if-same (ctx? (car x)) 't)) 505 | (() (if-same (atom x) 't))) 506 | ((dethm ctx?/sub (x y) 507 | (if (ctx? x) (if (ctx? y) (equal (ctx? (sub x y)) 't) 't) 't)) 508 | (star-induction y) 509 | (() 510 | (if-same (ctx? x) 511 | (if (atom y) 512 | (if (ctx? x) (if (ctx? y) (equal (ctx? (sub x y)) 't) 't) 't) 513 | (if (if (ctx? x) 514 | (if (ctx? (car y)) (equal (ctx? (sub x (car y))) 't) 't) 515 | 't) 516 | (if (if (ctx? x) 517 | (if (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't) 518 | 't) 519 | (if (ctx? x) (if (ctx? y) (equal (ctx? (sub x y)) 't) 't) 't) 520 | 't) 521 | 't)))) 522 | ((A A) (if-nest-A (ctx? x) (if (ctx? y) (equal (ctx? (sub x y)) 't) 't) 't)) 523 | ((A E Q) 524 | (if-nest-A (ctx? x) (if (ctx? (car y)) (equal (ctx? (sub x (car y))) 't) 't) 't)) 525 | ((A E A Q) 526 | (if-nest-A (ctx? x) (if (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't) 't)) 527 | ((A E A A) (if-nest-A (ctx? x) (if (ctx? y) (equal (ctx? (sub x y)) 't) 't) 't)) 528 | ((E A) (if-nest-E (ctx? x) (if (ctx? y) (equal (ctx? (sub x y)) 't) 't) 't)) 529 | ((E E Q) 530 | (if-nest-E (ctx? x) (if (ctx? (car y)) (equal (ctx? (sub x (car y))) 't) 't) 't)) 531 | ((E E A Q) 532 | (if-nest-E (ctx? x) (if (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't) 't)) 533 | ((E E A A) (if-nest-E (ctx? x) (if (ctx? y) (equal (ctx? (sub x y)) 't) 't) 't)) 534 | ((E E A) (if-same 't 't)) 535 | ((E E) (if-same 't 't)) 536 | ((E) (if-same (atom y) 't)) 537 | ((A A A 1 1) (sub x y)) 538 | ((A A A 1 1) 539 | (if-nest-A (atom y) 540 | (if (equal y '?) x y) 541 | (cons (sub x (car y)) (sub x (cdr y))))) 542 | ((A A A) (if-same (equal y '?) (equal (ctx? (if (equal y '?) x y)) 't))) 543 | ((A A A A 1 1) (if-nest-A (equal y '?) x y)) 544 | ((A A A E 1 1) (if-nest-E (equal y '?) x y)) 545 | ((A A A A 1) (ctx?/t x)) 546 | ((A A A A) (equal-same 't)) 547 | ((A A A E 1) (ctx?/t y)) 548 | ((A A A E) (equal-same 't)) 549 | ((A A A) (if-same (equal y '?) 't)) 550 | ((A A) (if-same (ctx? y) 't)) 551 | ((A E A A A 1 1) (sub x y)) 552 | ((A E A A A 1 1) 553 | (if-nest-E (atom y) 554 | (if (equal y '?) x y) 555 | (cons (sub x (car y)) (sub x (cdr y))))) 556 | ((A E A A A 1) (ctx? (cons (sub x (car y)) (sub x (cdr y))))) 557 | ((A E A A A 1 Q) (atom/cons (sub x (car y)) (sub x (cdr y)))) 558 | ((A E A A A 1 E Q 1) (car/cons (sub x (car y)) (sub x (cdr y)))) 559 | ((A E A A A 1 E E 1) (cdr/cons (sub x (car y)) (sub x (cdr y)))) 560 | ((A E A A A 1) 561 | (if-false (equal (cons (sub x (car y)) (sub x (cdr y))) '?) 562 | (if (ctx? (sub x (car y))) 't (ctx? (sub x (cdr y)))))) 563 | ((A E A A Q) (ctx? y)) 564 | ((A E A A Q) 565 | (if-nest-E (atom y) (equal y '?) (if (ctx? (car y)) 't (ctx? (cdr y))))) 566 | ((A E) 567 | (if-same (ctx? (car y)) 568 | (if (if (ctx? (car y)) (equal (ctx? (sub x (car y))) 't) 't) 569 | (if (if (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't) 570 | (if (if (ctx? (car y)) 't (ctx? (cdr y))) 571 | (equal (if (ctx? (sub x (car y))) 't (ctx? (sub x (cdr y)))) 't) 572 | 't) 573 | 't) 574 | 't))) 575 | ((A E A Q) (if-nest-A (ctx? (car y)) (equal (ctx? (sub x (car y))) 't) 't)) 576 | ((A E A A A Q) (if-nest-A (ctx? (car y)) 't (ctx? (cdr y)))) 577 | ((A E E Q) (if-nest-E (ctx? (car y)) (equal (ctx? (sub x (car y))) 't) 't)) 578 | ((A E E A A Q) (if-nest-E (ctx? (car y)) 't (ctx? (cdr y)))) 579 | ((A E A A A) 580 | (if-true (equal (if (ctx? (sub x (car y))) 't (ctx? (sub x (cdr y)))) 't) 't)) 581 | ((A E E) 582 | (if-true 583 | (if (if (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't) 584 | (if (ctx? (cdr y)) 585 | (equal (if (ctx? (sub x (car y))) 't (ctx? (sub x (cdr y)))) 't) 586 | 't) 587 | 't) 588 | 't)) 589 | ((A E A A A 1 Q) (equal-if (ctx? (sub x (car y))) 't)) 590 | ((A E A A A 1) (if-true 't (ctx? (sub x (cdr y))))) 591 | ((A E A A A) (equal-same 't)) 592 | ((A E A A) (if-same (if (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't) 't)) 593 | ((A E A) (if-same (equal (ctx? (sub x (car y))) 't) 't)) 594 | ((A E E) 595 | (if-same (ctx? (cdr y)) 596 | (if (if (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't) 597 | (if (ctx? (cdr y)) 598 | (equal (if (ctx? (sub x (car y))) 't (ctx? (sub x (cdr y)))) 't) 599 | 't) 600 | 't))) 601 | ((A E E A Q) (if-nest-A (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't)) 602 | ((A E E A A) 603 | (if-nest-A (ctx? (cdr y)) 604 | (equal (if (ctx? (sub x (car y))) 't (ctx? (sub x (cdr y)))) 't) 605 | 't)) 606 | ((A E E E Q) (if-nest-E (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't)) 607 | ((A E E E A) 608 | (if-nest-E (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) (if-same 't 't)) 612 | ((A E E A A 1 E) (equal-if (ctx? (sub x (cdr y))) 't)) 613 | ((A E E A A 1) (if-same (ctx? (sub x (car y))) 't)) 614 | ((A E E A A) (equal-same 't)) 615 | ((A E E A) (if-same (equal (ctx? (sub x (cdr y))) 't) 't)) 616 | ((A E E) (if-same (ctx? (cdr y)) 't)) 617 | ((A E) (if-same (ctx? (car y)) 't)) 618 | ((A) (if-same (atom y) 't)) 619 | (() (if-same (ctx? x) 't)))))) 620 | 621 | ;; Chapter 8 622 | 623 | (defun defun.member? () 624 | (J-Bob/define (dethm.ctx?/sub) 625 | '(((defun member? (x ys) 626 | (if (atom ys) 'nil (if (equal x (car ys)) 't (member? x (cdr ys))))) 627 | (size ys) 628 | ((Q) (natp/size ys)) 629 | (() 630 | (if-true 631 | (if (atom ys) 't (if (equal x (car ys)) 't (< (size (cdr ys)) (size ys)))) 632 | 'nil)) 633 | ((E E) (size/cdr ys)) 634 | ((E) (if-same (equal x (car ys)) 't)) 635 | (() (if-same (atom ys) 't)))))) 636 | 637 | (defun defun.set? () 638 | (J-Bob/define (defun.member?) 639 | '(((defun set? (xs) 640 | (if (atom xs) 't (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))))) 641 | (size xs) 642 | ((Q) (natp/size xs)) 643 | (() 644 | (if-true 645 | (if (atom xs) 646 | 't 647 | (if (member? (car xs) (cdr xs)) 't (< (size (cdr xs)) (size xs)))) 648 | 'nil)) 649 | ((E E) (size/cdr xs)) 650 | ((E) (if-same (member? (car xs) (cdr xs)) 't)) 651 | (() (if-same (atom xs) 't)))))) 652 | 653 | (defun defun.add-atoms () 654 | (J-Bob/define (defun.set?) 655 | '(((defun add-atoms (x ys) 656 | (if (atom x) 657 | (if (member? x ys) ys (cons x ys)) 658 | (add-atoms (car x) (add-atoms (cdr x) ys)))) 659 | (size x) 660 | ((Q) (natp/size x)) 661 | (() 662 | (if-true 663 | (if (atom x) 664 | 't 665 | (if (< (size (car x)) (size x)) (< (size (cdr x)) (size x)) 'nil)) 666 | 'nil)) 667 | ((E Q) (size/car x)) 668 | ((E A) (size/cdr x)) 669 | ((E) (if-true 't 'nil)) 670 | (() (if-same (atom x) 't)))))) 671 | 672 | (defun defun.atoms () 673 | (J-Bob/define (defun.add-atoms) 674 | '(((defun atoms (x) 675 | (add-atoms x '())) 676 | nil)))) 677 | 678 | (defun dethm.set?/atoms.attempt () 679 | (J-Bob/prove (defun.atoms) 680 | '(((dethm set?/add-atoms (a) 681 | (equal (set? (add-atoms a '())) 't)) 682 | (star-induction a) 683 | ((E A A 1 1) (add-atoms a '()))) 684 | ((dethm set?/atoms (a) 685 | (equal (set? (atoms a)) 't)) 686 | nil 687 | ((1 1) (atoms a)) 688 | ((1) (set?/add-atoms a)) 689 | (() (equal-same 't)))))) 690 | 691 | (defun dethm.set?/atoms () 692 | (J-Bob/define (defun.atoms) 693 | '(((dethm set?/t (xs) 694 | (if (set? xs) (equal (set? xs) 't) 't)) 695 | (list-induction xs) 696 | ((A A 1) (set? xs)) 697 | ((A A 1) 698 | (if-nest-A (atom xs) 't (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))))) 699 | ((A A) (equal-same 't)) 700 | ((A) (if-same (set? xs) 't)) 701 | ((E A A 1) (set? xs)) 702 | ((E A A 1) 703 | (if-nest-E (atom xs) 't (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))))) 704 | ((E A Q) (set? xs)) 705 | ((E A Q) 706 | (if-nest-E (atom xs) 't (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))))) 707 | ((E A) 708 | (if-same (member? (car xs) (cdr xs)) 709 | (if (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))) 710 | (equal (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))) 't) 711 | 't))) 712 | ((E A A Q) (if-nest-A (member? (car xs) (cdr xs)) 'nil (set? (cdr xs)))) 713 | ((E A A A 1) (if-nest-A (member? (car xs) (cdr xs)) 'nil (set? (cdr xs)))) 714 | ((E A E Q) (if-nest-E (member? (car xs) (cdr xs)) 'nil (set? (cdr xs)))) 715 | ((E A E A 1) (if-nest-E (member? (car xs) (cdr xs)) 'nil (set? (cdr xs)))) 716 | ((E A A) (if-false (equal 'nil 't) 't)) 717 | ((E) 718 | (if-same (set? (cdr xs)) 719 | (if (if (set? (cdr xs)) (equal (set? (cdr xs)) 't) 't) 720 | (if (member? (car xs) (cdr xs)) 721 | 't 722 | (if (set? (cdr xs)) (equal (set? (cdr xs)) 't) 't)) 723 | 't))) 724 | ((E A Q) (if-nest-A (set? (cdr xs)) (equal (set? (cdr xs)) 't) 't)) 725 | ((E A A E) (if-nest-A (set? (cdr xs)) (equal (set? (cdr xs)) 't) 't)) 726 | ((E E Q) (if-nest-E (set? (cdr xs)) (equal (set? (cdr xs)) 't) 't)) 727 | ((E E A E) (if-nest-E (set? (cdr xs)) (equal (set? (cdr xs)) 't) 't)) 728 | ((E E A) (if-same (member? (car xs) (cdr xs)) 't)) 729 | ((E E) (if-same 't 't)) 730 | ((E A A E 1) (equal-if (set? (cdr xs)) 't)) 731 | ((E A A E) (equal-same 't)) 732 | ((E A A) (if-same (member? (car xs) (cdr xs)) 't)) 733 | ((E A) (if-same (equal (set? (cdr xs)) 't) 't)) 734 | ((E) (if-same (set? (cdr xs)) 't)) 735 | (() (if-same (atom xs) 't))) 736 | ((dethm set?/nil (xs) 737 | (if (set? xs) 't (equal (set? xs) 'nil))) 738 | (list-induction xs) 739 | ((A Q) (set? xs)) 740 | ((A Q) 741 | (if-nest-A (atom xs) 't (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))))) 742 | ((A) (if-true 't (equal (set? xs) 'nil))) 743 | ((E A E 1) (set? xs)) 744 | ((E A E 1) 745 | (if-nest-E (atom xs) 't (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))))) 746 | ((E A Q) (set? xs)) 747 | ((E A Q) 748 | (if-nest-E (atom xs) 't (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))))) 749 | ((E A) 750 | (if-same (member? (car xs) (cdr xs)) 751 | (if (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))) 752 | 't 753 | (equal (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))) 'nil)))) 754 | ((E A A Q) (if-nest-A (member? (car xs) (cdr xs)) 'nil (set? (cdr xs)))) 755 | ((E A A E 1) (if-nest-A (member? (car xs) (cdr xs)) 'nil (set? (cdr xs)))) 756 | ((E A E Q) (if-nest-E (member? (car xs) (cdr xs)) 'nil (set? (cdr xs)))) 757 | ((E A E E 1) (if-nest-E (member? (car xs) (cdr xs)) 'nil (set? (cdr xs)))) 758 | ((E A A E) (equal-same 'nil)) 759 | ((E A A) (if-same 'nil 't)) 760 | ((E) 761 | (if-same (set? (cdr xs)) 762 | (if (if (set? (cdr xs)) 't (equal (set? (cdr xs)) 'nil)) 763 | (if (member? (car xs) (cdr xs)) 764 | 't 765 | (if (set? (cdr xs)) 't (equal (set? (cdr xs)) 'nil))) 766 | 't))) 767 | ((E A Q) (if-nest-A (set? (cdr xs)) 't (equal (set? (cdr xs)) 'nil))) 768 | ((E A A E) (if-nest-A (set? (cdr xs)) 't (equal (set? (cdr xs)) 'nil))) 769 | ((E E Q) (if-nest-E (set? (cdr xs)) 't (equal (set? (cdr xs)) 'nil))) 770 | ((E E A E) (if-nest-E (set? (cdr xs)) 't (equal (set? (cdr xs)) 'nil))) 771 | ((E A A) (if-same (member? (car xs) (cdr xs)) 't)) 772 | ((E A) (if-same 't 't)) 773 | ((E E A E 1) (equal-if (set? (cdr xs)) 'nil)) 774 | ((E E A E) (equal-same 'nil)) 775 | ((E E A) (if-same (member? (car xs) (cdr xs)) 't)) 776 | ((E E) (if-same (equal (set? (cdr xs)) 'nil) 't)) 777 | ((E) (if-same (set? (cdr xs)) 't)) 778 | (() (if-same (atom xs) 't))) 779 | ((dethm set?/add-atoms (a bs) 780 | (if (set? bs) (equal (set? (add-atoms a bs)) 't) 't)) 781 | (add-atoms a bs) 782 | ((A A 1 1) (add-atoms a bs)) 783 | ((A A 1 1) 784 | (if-nest-A (atom a) 785 | (if (member? a bs) bs (cons a bs)) 786 | (add-atoms (car a) (add-atoms (cdr a) bs)))) 787 | ((A A 1) (if-same (member? a bs) (set? (if (member? a bs) bs (cons a bs))))) 788 | ((A A 1 A 1) (if-nest-A (member? a bs) bs (cons a bs))) 789 | ((A A 1 E 1) (if-nest-E (member? a bs) bs (cons a bs))) 790 | ((A A 1 A) (set?/t bs)) 791 | ((A A 1 E) (set? (cons a bs))) 792 | ((A A 1 E Q) (atom/cons a bs)) 793 | ((A A 1 E E Q 1) (car/cons a bs)) 794 | ((A A 1 E E Q 2) (cdr/cons a bs)) 795 | ((A A 1 E E E 1) (cdr/cons a bs)) 796 | ((A A 1 E) (if-false 't (if (member? a bs) 'nil (set? bs)))) 797 | ((A A 1 E) (if-nest-E (member? a bs) 'nil (set? bs))) 798 | ((A A 1 E) (set?/t bs)) 799 | ((A A 1) (if-same (member? a bs) 't)) 800 | ((A A) (equal-same 't)) 801 | ((A) (if-same (set? bs) 't)) 802 | ((E) 803 | (if-same (set? bs) 804 | (if (if (set? (add-atoms (cdr a) bs)) 805 | (equal (set? (add-atoms (car a) (add-atoms (cdr a) bs))) 't) 806 | 't) 807 | (if (if (set? bs) (equal (set? (add-atoms (cdr a) bs)) 't) 't) 808 | (if (set? bs) (equal (set? (add-atoms a bs)) 't) 't) 809 | 't) 810 | 't))) 811 | ((E A A Q) (if-nest-A (set? bs) (equal (set? (add-atoms (cdr a) bs)) 't) 't)) 812 | ((E A A A) (if-nest-A (set? bs) (equal (set? (add-atoms a bs)) 't) 't)) 813 | ((E E A Q) (if-nest-E (set? bs) (equal (set? (add-atoms (cdr a) bs)) 't) 't)) 814 | ((E E A A) (if-nest-E (set? bs) (equal (set? (add-atoms a bs)) 't) 't)) 815 | ((E E A) (if-same 't 't)) 816 | ((E E) 817 | (if-same 818 | (if (set? (add-atoms (cdr a) bs)) 819 | (equal (set? (add-atoms (car a) (add-atoms (cdr a) bs))) 't) 820 | 't) 821 | 't)) 822 | ((E A) 823 | (if-same (set? (add-atoms (cdr a) bs)) 824 | (if (if (set? (add-atoms (cdr a) bs)) 825 | (equal (set? (add-atoms (car a) (add-atoms (cdr a) bs))) 't) 826 | 't) 827 | (if (equal (set? (add-atoms (cdr a) bs)) 't) 828 | (equal (set? (add-atoms a bs)) 't) 829 | 't) 830 | 't))) 831 | ((E A A Q) 832 | (if-nest-A (set? (add-atoms (cdr a) bs)) 833 | (equal (set? (add-atoms (car a) (add-atoms (cdr a) bs))) 't) 834 | 't)) 835 | ((E A E Q) 836 | (if-nest-E (set? (add-atoms (cdr a) bs)) 837 | (equal (set? (add-atoms (car a) (add-atoms (cdr a) bs))) 't) 838 | 't)) 839 | ((E A E) 840 | (if-true 841 | (if (equal (set? (add-atoms (cdr a) bs)) 't) 842 | (equal (set? (add-atoms a bs)) 't) 843 | 't) 844 | 't)) 845 | ((E A A A Q 1) (set?/t (add-atoms (cdr a) bs))) 846 | ((E A E Q 1) (set?/nil (add-atoms (cdr a) bs))) 847 | ((E A A A Q) (equal 't 't)) 848 | ((E A E Q) (equal 'nil 't)) 849 | ((E A A A) (if-true (equal (set? (add-atoms a bs)) 't) 't)) 850 | ((E A E) (if-false (equal (set? (add-atoms a bs)) 't) 't)) 851 | ((E A A A 1 1) (add-atoms a bs)) 852 | ((E A A A 1 1) 853 | (if-nest-E (atom a) 854 | (if (member? a bs) bs (cons a bs)) 855 | (add-atoms (car a) (add-atoms (cdr a) bs)))) 856 | ((E A A A 1) (equal-if (set? (add-atoms (car a) (add-atoms (cdr a) bs))) 't)) 857 | ((E A A A) (equal-same 't)) 858 | ((E A A) 859 | (if-same (equal (set? (add-atoms (car a) (add-atoms (cdr a) bs))) 't) 't)) 860 | ((E A) (if-same (set? (add-atoms (cdr a) bs)) 't)) 861 | ((E) (if-same (set? bs) 't)) 862 | (() (if-same (atom a) 't))) 863 | ((dethm set?/atoms (a) 864 | (equal (set? (atoms a)) 't)) 865 | nil 866 | ((1 1) (atoms a)) 867 | (() (if-true (equal (set? (add-atoms a '())) 't) 't)) 868 | ((Q) (if-true 't (if (member? (car '()) (cdr '())) 'nil (set? (cdr '()))))) 869 | ((Q Q) (atom '())) 870 | ((Q) (set? '())) 871 | ((A 1) (set?/add-atoms a '())) 872 | ((A) (equal-same 't)) 873 | (() (if-same (set? '()) 't)))))) 874 | 875 | ;; Chapter 9 876 | 877 | (defun defun.rotate () 878 | (J-Bob/define (dethm.set?/atoms) 879 | '(((defun rotate (x) 880 | (cons (car (car x)) (cons (cdr (car x)) (cdr x)))) 881 | nil)))) 882 | 883 | (defun dethm.rotate/cons () 884 | (J-Bob/define (defun.rotate) 885 | '(((dethm rotate/cons (x y z) 886 | (equal (rotate (cons (cons x y) z)) (cons x (cons y z)))) 887 | nil 888 | ((1) (rotate (cons (cons x y) z))) 889 | ((1 1 1) (car/cons (cons x y) z)) 890 | ((1 1) (car/cons x y)) 891 | ((1 2 1 1) (car/cons (cons x y) z)) 892 | ((1 2 1) (cdr/cons x y)) 893 | ((1 2 2) (cdr/cons (cons x y) z)) 894 | (() (equal-same (cons x (cons y z)))))))) 895 | 896 | (defun defun.align.attempt () 897 | (J-Bob/prove (dethm.rotate/cons) 898 | '(((defun align (x) 899 | (if (atom x) 900 | x 901 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 902 | (size x) 903 | ((Q) (natp/size x)) 904 | (() 905 | (if-true 906 | (if (atom x) 907 | 't 908 | (if (atom (car x)) 909 | (< (size (cdr x)) (size x)) 910 | (< (size (rotate x)) (size x)))) 911 | 'nil)) 912 | ((E A) (size/cdr x)) 913 | ((E E 1 1 1) (cons/car+cdr x)) 914 | ((E E 2 1) (cons/car+cdr x)) 915 | ((E E 1 1 1 1) (cons/car+cdr (car x))) 916 | ((E E 2 1 1) (cons/car+cdr (car x))) 917 | ((E E 1 1) (rotate/cons (car (car x)) (cdr (car x)) (cdr x))))))) 918 | 919 | (defun defun.wt () 920 | (J-Bob/define (dethm.rotate/cons) 921 | '(((defun wt (x) 922 | (if (atom x) '1 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x))))) 923 | (size x) 924 | ((Q) (natp/size x)) 925 | (() 926 | (if-true 927 | (if (atom x) 928 | 't 929 | (if (< (size (car x)) (size x)) (< (size (cdr x)) (size x)) 'nil)) 930 | 'nil)) 931 | ((E Q) (size/car x)) 932 | ((E A) (size/cdr x)) 933 | ((E) (if-true 't 'nil)) 934 | (() (if-same (atom x) 't)))))) 935 | 936 | (defun defun.align () 937 | (J-Bob/define (defun.wt) 938 | '(((dethm natp/wt (x) 939 | (equal (natp (wt x)) 't)) 940 | (star-induction x) 941 | ((A 1 1) (wt x)) 942 | ((A 1 1) (if-nest-A (atom x) '1 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x))))) 943 | ((A 1) (natp '1)) 944 | ((A) (equal-same 't)) 945 | ((E A A 1 1) (wt x)) 946 | ((E A A 1 1) 947 | (if-nest-E (atom x) '1 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x))))) 948 | ((E A A) 949 | (if-true (equal (natp (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x)))) 't) 't)) 950 | ((E A A Q) (equal-if (natp (wt (car x))) 't)) 951 | ((E A A A) 952 | (if-true (equal (natp (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x)))) 't) 't)) 953 | ((E A A A Q) (natp/+ (wt (car x)) (wt (car x)))) 954 | ((E A A Q) (equal-if (natp (wt (car x))) 't)) 955 | ((E A A Q) (equal-if (natp (wt (cdr x))) 't)) 956 | ((E A A A A 1) (natp/+ (+ (wt (car x)) (wt (car x))) (wt (cdr x)))) 957 | ((E A A A A) (equal-same 't)) 958 | ((E A A A) (if-same (natp (+ (wt (car x)) (wt (car x)))) 't)) 959 | ((E A A) (if-same (natp (wt (cdr x))) 't)) 960 | ((E A) (if-same (equal (natp (wt (cdr x))) 't) 't)) 961 | ((E) (if-same (equal (natp (wt (car x))) 't) 't)) 962 | (() (if-same (atom x) 't))) 963 | ((dethm positive/wt (x) 964 | (equal (< '0 (wt x)) 't)) 965 | (star-induction x) 966 | ((A 1 2) (wt x)) 967 | ((A 1 2) (if-nest-A (atom x) '1 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x))))) 968 | ((A 1) (< '0 '1)) 969 | ((A) (equal-same 't)) 970 | ((E A A 1 2) (wt x)) 971 | ((E A A 1 2) 972 | (if-nest-E (atom x) '1 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x))))) 973 | ((E A A) 974 | (if-true (equal (< '0 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x)))) 't) 't)) 975 | ((E A A Q) (equal-if (< '0 (wt (car x))) 't)) 976 | ((E A A A) 977 | (if-true (equal (< '0 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x)))) 't) 't)) 978 | ((E A A A Q) (positives-+ (wt (car x)) (wt (car x)))) 979 | ((E A A Q) (equal-if (< '0 (wt (car x))) 't)) 980 | ((E A A Q) (equal-if (< '0 (wt (cdr x))) 't)) 981 | ((E A A A A 1) (positives-+ (+ (wt (car x)) (wt (car x))) (wt (cdr x)))) 982 | ((E A A A A) (equal-same 't)) 983 | ((E A A A) (if-same (< '0 (+ (wt (car x)) (wt (car x)))) 't)) 984 | ((E A A) (if-same (< '0 (wt (cdr x))) 't)) 985 | ((E A) (if-same (equal (< '0 (wt (cdr x))) 't) 't)) 986 | ((E) (if-same (equal (< '0 (wt (car x))) 't) 't)) 987 | (() (if-same (atom x) 't))) 988 | ((defun align (x) 989 | (if (atom x) 990 | x 991 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 992 | (wt x) 993 | ((Q) (natp/wt x)) 994 | (() 995 | (if-true 996 | (if (atom x) 997 | 't 998 | (if (atom (car x)) (< (wt (cdr x)) (wt x)) (< (wt (rotate x)) (wt x)))) 999 | 'nil)) 1000 | ((E A 2) (wt x)) 1001 | ((E A 2) (if-nest-E (atom x) '1 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x))))) 1002 | ((E A) 1003 | (if-true (< (wt (cdr x)) (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x)))) 't)) 1004 | ((E A Q) (natp/wt (cdr x))) 1005 | ((E A A 1) (identity-+ (wt (cdr x)))) 1006 | ((E A A) (common-addends-< '0 (+ (wt (car x)) (wt (car x))) (wt (cdr x)))) 1007 | ((E A Q) (natp/wt (cdr x))) 1008 | ((E A Q) (positive/wt (car x))) 1009 | ((E A A) (positives-+ (wt (car x)) (wt (car x)))) 1010 | ((E A) (if-same (< '0 (wt (car x))) 't)) 1011 | ((E E 1 1) (rotate x)) 1012 | ((E E 1) (wt (cons (car (car x)) (cons (cdr (car x)) (cdr x))))) 1013 | ((E E 1 Q) (atom/cons (car (car x)) (cons (cdr (car x)) (cdr x)))) 1014 | ((E E 1) 1015 | (if-false '1 1016 | (+ (+ (wt (car (cons (car (car x)) (cons (cdr (car x)) (cdr x))))) 1017 | (wt (car (cons (car (car x)) (cons (cdr (car x)) (cdr x)))))) 1018 | (wt (cdr (cons (car (car x)) (cons (cdr (car x)) (cdr x)))))))) 1019 | ((E E 1 1 1 1) (car/cons (car (car x)) (cons (cdr (car x)) (cdr x)))) 1020 | ((E E 1 1 2 1) (car/cons (car (car x)) (cons (cdr (car x)) (cdr x)))) 1021 | ((E E 1 2 1) (cdr/cons (car (car x)) (cons (cdr (car x)) (cdr x)))) 1022 | ((E E 1 2) (wt (cons (cdr (car x)) (cdr x)))) 1023 | ((E E 1 2 Q) (atom/cons (cdr (car x)) (cdr x))) 1024 | ((E E 1 2) 1025 | (if-false '1 1026 | (+ (+ (wt (car (cons (cdr (car x)) (cdr x)))) 1027 | (wt (car (cons (cdr (car x)) (cdr x))))) 1028 | (wt (cdr (cons (cdr (car x)) (cdr x))))))) 1029 | ((E E 1 2 1 1 1) (car/cons (cdr (car x)) (cdr x))) 1030 | ((E E 1 2 1 2 1) (car/cons (cdr (car x)) (cdr x))) 1031 | ((E E 1 2 2 1) (cdr/cons (cdr (car x)) (cdr x))) 1032 | ((E E 2) (wt x)) 1033 | ((E E 2) (if-nest-E (atom x) '1 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x))))) 1034 | ((E E 2 1 1) (wt (car x))) 1035 | ((E E 2 1 1) 1036 | (if-nest-E (atom (car x)) 1037 | '1 1038 | (+ (+ (wt (car (car x))) (wt (car (car x)))) (wt (cdr (car x)))))) 1039 | ((E E 2 1 2) (wt (car x))) 1040 | ((E E 2 1 2) 1041 | (if-nest-E (atom (car x)) 1042 | '1 1043 | (+ (+ (wt (car (car x))) (wt (car (car x)))) (wt (cdr (car x)))))) 1044 | ((E E 1) 1045 | (associate-+ 1046 | (+ (wt (car (car x))) (wt (car (car x)))) 1047 | (+ (wt (cdr (car x))) (wt (cdr (car x)))) 1048 | (wt (cdr x)))) 1049 | ((E E) 1050 | (common-addends-< 1051 | (+ (+ (wt (car (car x))) (wt (car (car x)))) 1052 | (+ (wt (cdr (car x))) (wt (cdr (car x))))) 1053 | (+ (+ (+ (wt (car (car x))) (wt (car (car x)))) (wt (cdr (car x)))) 1054 | (+ (+ (wt (car (car x))) (wt (car (car x)))) (wt (cdr (car x))))) 1055 | (wt (cdr x)))) 1056 | ((E E 1) 1057 | (associate-+ 1058 | (+ (wt (car (car x))) (wt (car (car x)))) 1059 | (wt (cdr (car x))) 1060 | (wt (cdr (car x))))) 1061 | ((E E 1) 1062 | (commute-+ 1063 | (+ (+ (wt (car (car x))) (wt (car (car x)))) (wt (cdr (car x)))) 1064 | (wt (cdr (car x))))) 1065 | ((E E) 1066 | (common-addends-< 1067 | (wt (cdr (car x))) 1068 | (+ (+ (wt (car (car x))) (wt (car (car x)))) (wt (cdr (car x)))) 1069 | (+ (+ (wt (car (car x))) (wt (car (car x)))) (wt (cdr (car x)))))) 1070 | ((E E) 1071 | (if-true 1072 | (< (wt (cdr (car x))) 1073 | (+ (+ (wt (car (car x))) (wt (car (car x)))) (wt (cdr (car x))))) 1074 | 't)) 1075 | ((E E Q) (natp/wt (cdr (car x)))) 1076 | ((E E A 1) (identity-+ (wt (cdr (car x))))) 1077 | ((E E A) 1078 | (common-addends-< 1079 | '0 1080 | (+ (wt (car (car x))) (wt (car (car x)))) 1081 | (wt (cdr (car x))))) 1082 | ((E E Q) (natp/wt (cdr (car x)))) 1083 | ((E E Q) (positive/wt (car (car x)))) 1084 | ((E E A) (positives-+ (wt (car (car x))) (wt (car (car x))))) 1085 | ((E E) (if-same (< '0 (wt (car (car x)))) 't)) 1086 | ((E) (if-same (atom (car x)) 't)) 1087 | (() (if-same (atom x) 't)))))) 1088 | 1089 | (defun dethm.align/align () 1090 | (J-Bob/define (defun.align) 1091 | '(((dethm align/align (x) 1092 | (equal (align (align x)) (align x))) 1093 | (align x) 1094 | ((A 1 1) (align x)) 1095 | ((A 1 1) 1096 | (if-nest-A (atom x) 1097 | x 1098 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 1099 | ((A 2) (align x)) 1100 | ((A 2) 1101 | (if-nest-A (atom x) 1102 | x 1103 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 1104 | ((A 1) (align x)) 1105 | ((A 1) 1106 | (if-nest-A (atom x) 1107 | x 1108 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 1109 | ((A) (equal-same x)) 1110 | ((E A A 1 1) (align x)) 1111 | ((E A A 1 1) 1112 | (if-nest-E (atom x) 1113 | x 1114 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 1115 | ((E A A 1 1) 1116 | (if-nest-A (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x)))) 1117 | ((E A A 2) (align x)) 1118 | ((E A A 2) 1119 | (if-nest-E (atom x) 1120 | x 1121 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 1122 | ((E A A 2) 1123 | (if-nest-A (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x)))) 1124 | ((E A A 1) (align (cons (car x) (align (cdr x))))) 1125 | ((E A A 1 Q) (atom/cons (car x) (align (cdr x)))) 1126 | ((E A A 1 E Q 1) (car/cons (car x) (align (cdr x)))) 1127 | ((E A A 1 E A 1) (car/cons (car x) (align (cdr x)))) 1128 | ((E A A 1 E A 2 1) (cdr/cons (car x) (align (cdr x)))) 1129 | ((E A A 1) 1130 | (if-false (cons (car x) (align (cdr x))) 1131 | (if (atom (car x)) 1132 | (cons (car x) (align (align (cdr x)))) 1133 | (align (rotate (cons (car x) (align (cdr x)))))))) 1134 | ((E A A 1) 1135 | (if-nest-A (atom (car x)) 1136 | (cons (car x) (align (align (cdr x)))) 1137 | (align (rotate (cons (car x) (align (cdr x))))))) 1138 | ((E A A 1 2) (equal-if (align (align (cdr x))) (align (cdr x)))) 1139 | ((E A A) (equal-same (cons (car x) (align (cdr x))))) 1140 | ((E A) (if-same (equal (align (align (cdr x))) (align (cdr x))) 't)) 1141 | ((E E A 1 1) (align x)) 1142 | ((E E A 1 1) 1143 | (if-nest-E (atom x) 1144 | x 1145 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 1146 | ((E E A 1 1) 1147 | (if-nest-E (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x)))) 1148 | ((E E A 2) (align x)) 1149 | ((E E A 2) 1150 | (if-nest-E (atom x) 1151 | x 1152 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 1153 | ((E E A 2) 1154 | (if-nest-E (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x)))) 1155 | ((E E A 1) (equal-if (align (align (rotate x))) (align (rotate x)))) 1156 | ((E E A) (equal-same (align (rotate x)))) 1157 | ((E E) (if-same (equal (align (align (rotate x))) (align (rotate x))) 't)) 1158 | ((E) (if-same (atom (car x)) 't)) 1159 | (() (if-same (atom x) 't)))))) 1160 | -------------------------------------------------------------------------------- /scheme/j-bob-lang.scm: -------------------------------------------------------------------------------- 1 | 2 | (define s.car car) 3 | (define s.cdr cdr) 4 | (define s.+ +) 5 | (define s.< <) 6 | (define (num x) (if (number? x) x 0)) 7 | (define (if/nil Q A E) 8 | (if (equal? Q 'nil) (E) (A))) 9 | 10 | (define (atom x) (if (pair? x) 'nil 't)) 11 | (define (car x) (if (pair? x) (s.car x) '())) 12 | (define (cdr x) (if (pair? x) (s.cdr x) '())) 13 | (define (equal x y) (if (equal? x y) 't 'nil)) 14 | (define (natp x) 15 | (if (integer? x) (if (s.< x 0) 'nil 't) 'nil)) 16 | (define (+ x y) (s.+ (num x) (num y))) 17 | (define (< x y) 18 | (if (s.< (num x) (num y)) 't 'nil)) 19 | 20 | (define-syntax if 21 | (syntax-rules () 22 | ((_ Q A E) 23 | (if/nil Q (lambda () A) (lambda () E))))) 24 | 25 | (define-syntax defun 26 | (syntax-rules () 27 | ((_ name (arg ...) body) 28 | (define (name arg ...) body)))) 29 | 30 | (define-syntax dethm 31 | (syntax-rules () 32 | ((_ name (arg ...) body) 33 | (define (name arg ...) body)))) 34 | 35 | (defun size (x) 36 | (if (atom x) 37 | '0 38 | (+ '1 (+ (size (car x)) (size (cdr x)))))) 39 | -------------------------------------------------------------------------------- /scheme/j-bob.scm: -------------------------------------------------------------------------------- 1 | 2 | (defun list0 () '()) 3 | (defun list0? (x) (equal x '())) 4 | 5 | (defun list1 (x) (cons x (list0))) 6 | (defun list1? (x) 7 | (if (atom x) 'nil (list0? (cdr x)))) 8 | (defun elem1 (xs) (car xs)) 9 | 10 | (defun list2 (x y) (cons x (list1 y))) 11 | (defun list2? (x) 12 | (if (atom x) 'nil (list1? (cdr x)))) 13 | (defun elem2 (xs) (elem1 (cdr xs))) 14 | 15 | (defun list3 (x y z) (cons x (list2 y z))) 16 | (defun list3? (x) 17 | (if (atom x) 'nil (list2? (cdr x)))) 18 | (defun elem3 (xs) (elem2 (cdr xs))) 19 | 20 | (defun tag (sym x) (cons sym x)) 21 | (defun tag? (sym x) 22 | (if (atom x) 'nil (equal (car x) sym))) 23 | (defun untag (x) (cdr x)) 24 | 25 | (defun quote-c (value) 26 | (tag 'quote (list1 value))) 27 | (defun quote? (x) 28 | (if (tag? 'quote x) (list1? (untag x)) 'nil)) 29 | (defun quote.value (e) (elem1 (untag e))) 30 | 31 | (defun if-c (Q A E) (tag 'if (list3 Q A E))) 32 | (defun if? (x) 33 | (if (tag? 'if x) (list3? (untag x)) 'nil)) 34 | (defun if.Q (e) (elem1 (untag e))) 35 | (defun if.A (e) (elem2 (untag e))) 36 | (defun if.E (e) (elem3 (untag e))) 37 | 38 | (defun app-c (name args) (cons name args)) 39 | (defun app? (x) 40 | (if (atom x) 41 | 'nil 42 | (if (quote? x) 43 | 'nil 44 | (if (if? x) 45 | 'nil 46 | 't)))) 47 | (defun app.name (e) (car e)) 48 | (defun app.args (e) (cdr e)) 49 | 50 | (defun var? (x) 51 | (if (equal x 't) 52 | 'nil 53 | (if (equal x 'nil) 54 | 'nil 55 | (if (natp x) 56 | 'nil 57 | (atom x))))) 58 | 59 | (defun defun-c (name formals body) 60 | (tag 'defun (list3 name formals body))) 61 | (defun defun? (x) 62 | (if (tag? 'defun x) (list3? (untag x)) 'nil)) 63 | (defun defun.name (def) (elem1 (untag def))) 64 | (defun defun.formals (def) (elem2 (untag def))) 65 | (defun defun.body (def) (elem3 (untag def))) 66 | 67 | (defun dethm-c (name formals body) 68 | (tag 'dethm (list3 name formals body))) 69 | (defun dethm? (x) 70 | (if (tag? 'dethm x) (list3? (untag x)) 'nil)) 71 | (defun dethm.name (def) (elem1 (untag def))) 72 | (defun dethm.formals (def) (elem2 (untag def))) 73 | (defun dethm.body (def) (elem3 (untag def))) 74 | 75 | (defun if-QAE (e) 76 | (list3 (if.Q e) (if.A e) (if.E e))) 77 | (defun QAE-if (es) 78 | (if-c (elem1 es) (elem2 es) (elem3 es))) 79 | 80 | (defun member? (x ys) 81 | (if (atom ys) 82 | 'nil 83 | (if (equal x (car ys)) 84 | 't 85 | (member? x (cdr ys))))) 86 | 87 | (defun rator? (name) 88 | (member? name 89 | '(equal atom car cdr cons natp size + <))) 90 | 91 | (defun rator.formals (rator) 92 | (if (member? rator '(atom car cdr natp size)) 93 | '(x) 94 | (if (member? rator '(equal cons + <)) 95 | '(x y) 96 | 'nil))) 97 | 98 | (defun def.name (def) 99 | (if (defun? def) 100 | (defun.name def) 101 | (if (dethm? def) 102 | (dethm.name def) 103 | def))) 104 | 105 | (defun def.formals (def) 106 | (if (dethm? def) 107 | (dethm.formals def) 108 | (if (defun? def) 109 | (defun.formals def) 110 | '()))) 111 | 112 | (defun if-c-when-necessary (Q A E) 113 | (if (equal A E) A (if-c Q A E))) 114 | 115 | (defun conjunction (es) 116 | (if (atom es) 117 | (quote-c 't) 118 | (if (atom (cdr es)) 119 | (car es) 120 | (if-c (car es) 121 | (conjunction (cdr es)) 122 | (quote-c 'nil))))) 123 | 124 | (defun implication (es e) 125 | (if (atom es) 126 | e 127 | (if-c (car es) 128 | (implication (cdr es) e) 129 | (quote-c 't)))) 130 | 131 | (defun lookup (name defs) 132 | (if (atom defs) 133 | name 134 | (if (equal (def.name (car defs)) name) 135 | (car defs) 136 | (lookup name (cdr defs))))) 137 | 138 | (defun undefined? (name defs) 139 | (if (var? name) 140 | (equal (lookup name defs) name) 141 | 'nil)) 142 | 143 | (defun arity? (vars es) 144 | (if (atom vars) 145 | (atom es) 146 | (if (atom es) 147 | 'nil 148 | (arity? (cdr vars) (cdr es))))) 149 | 150 | (defun args-arity? (def args) 151 | (if (dethm? def) 152 | 'nil 153 | (if (defun? def) 154 | (arity? (defun.formals def) args) 155 | (if (rator? def) 156 | (arity? (rator.formals def) args) 157 | 'nil)))) 158 | 159 | (defun app-arity? (defs app) 160 | (args-arity? (lookup (app.name app) defs) 161 | (app.args app))) 162 | 163 | (defun bound? (var vars) 164 | (if (equal vars 'any) 't (member? var vars))) 165 | 166 | (defun exprs? (defs vars es) 167 | (if (atom es) 168 | 't 169 | (if (var? (car es)) 170 | (if (bound? (car es) vars) 171 | (exprs? defs vars (cdr es)) 172 | 'nil) 173 | (if (quote? (car es)) 174 | (exprs? defs vars (cdr es)) 175 | (if (if? (car es)) 176 | (if (exprs? defs vars 177 | (if-QAE (car es))) 178 | (exprs? defs vars (cdr es)) 179 | 'nil) 180 | (if (app? (car es)) 181 | (if (app-arity? defs (car es)) 182 | (if (exprs? defs vars 183 | (app.args (car es))) 184 | (exprs? defs vars (cdr es)) 185 | 'nil) 186 | 'nil) 187 | 'nil)))))) 188 | (defun expr? (defs vars e) 189 | (exprs? defs vars (list1 e))) 190 | 191 | (defun get-arg-from (n args from) 192 | (if (atom args) 193 | 'nil 194 | (if (equal n from) 195 | (car args) 196 | (get-arg-from n (cdr args) (+ from '1))))) 197 | (defun get-arg (n args) 198 | (get-arg-from n args '1)) 199 | 200 | (defun set-arg-from (n args y from) 201 | (if (atom args) 202 | '() 203 | (if (equal n from) 204 | (cons y (cdr args)) 205 | (cons (car args) 206 | (set-arg-from n (cdr args) y 207 | (+ from '1)))))) 208 | (defun set-arg (n args y) 209 | (set-arg-from n args y '1)) 210 | 211 | (defun <=len-from (n args from) 212 | (if (atom args) 213 | 'nil 214 | (if (equal n from) 215 | 't 216 | (<=len-from n (cdr args) (+ from '1))))) 217 | (defun <=len (n args) 218 | (if (< '0 n) (<=len-from n args '1) 'nil)) 219 | 220 | (defun subset? (xs ys) 221 | (if (atom xs) 222 | 't 223 | (if (member? (car xs) ys) 224 | (subset? (cdr xs) ys) 225 | 'nil))) 226 | 227 | (defun list-extend (xs x) 228 | (if (atom xs) 229 | (list1 x) 230 | (if (equal (car xs) x) 231 | xs 232 | (cons (car xs) 233 | (list-extend (cdr xs) x))))) 234 | 235 | (defun list-union (xs ys) 236 | (if (atom ys) 237 | xs 238 | (list-union (list-extend xs (car ys)) 239 | (cdr ys)))) 240 | 241 | (defun formals? (vars) 242 | (if (atom vars) 243 | 't 244 | (if (var? (car vars)) 245 | (if (member? (car vars) (cdr vars)) 246 | 'nil 247 | (formals? (cdr vars))) 248 | 'nil))) 249 | 250 | (defun direction? (dir) 251 | (if (natp dir) 252 | 't 253 | (member? dir '(Q A E)))) 254 | 255 | (defun path? (path) 256 | (if (atom path) 257 | 't 258 | (if (direction? (car path)) 259 | (path? (cdr path)) 260 | 'nil))) 261 | 262 | (defun quoted-exprs? (args) 263 | (if (atom args) 264 | 't 265 | (if (quote? (car args)) 266 | (quoted-exprs? (cdr args)) 267 | 'nil))) 268 | 269 | (defun step-args? (defs def args) 270 | (if (dethm? def) 271 | (if (arity? (dethm.formals def) args) 272 | (exprs? defs 'any args) 273 | 'nil) 274 | (if (defun? def) 275 | (if (arity? (defun.formals def) args) 276 | (exprs? defs 'any args) 277 | 'nil) 278 | (if (rator? def) 279 | (if (arity? (rator.formals def) args) 280 | (quoted-exprs? args) 281 | 'nil) 282 | 'nil)))) 283 | 284 | (defun step-app? (defs app) 285 | (step-args? defs 286 | (lookup (app.name app) defs) 287 | (app.args app))) 288 | 289 | (defun step? (defs step) 290 | (if (path? (elem1 step)) 291 | (if (app? (elem2 step)) 292 | (step-app? defs (elem2 step)) 293 | 'nil) 294 | 'nil)) 295 | 296 | (defun steps? (defs steps) 297 | (if (atom steps) 298 | 't 299 | (if (step? defs (car steps)) 300 | (steps? defs (cdr steps)) 301 | 'nil))) 302 | 303 | (defun induction-scheme-for? (def vars e) 304 | (if (defun? def) 305 | (if (arity? (defun.formals def) (app.args e)) 306 | (if (formals? (app.args e)) 307 | (subset? (app.args e) vars) 308 | 'nil) 309 | 'nil) 310 | 'nil)) 311 | 312 | (defun induction-scheme? (defs vars e) 313 | (if (app? e) 314 | (induction-scheme-for? 315 | (lookup (app.name e) defs) 316 | vars 317 | e) 318 | 'nil)) 319 | 320 | (defun seed? (defs def seed) 321 | (if (equal seed 'nil) 322 | 't 323 | (if (defun? def) 324 | (expr? defs (defun.formals def) seed) 325 | (if (dethm? def) 326 | (induction-scheme? defs 327 | (dethm.formals def) 328 | seed) 329 | 'nil)))) 330 | 331 | (defun extend-rec (defs def) 332 | (if (defun? def) 333 | (list-extend defs 334 | (defun-c 335 | (defun.name def) 336 | (defun.formals def) 337 | (app-c (defun.name def) 338 | (defun.formals def)))) 339 | defs)) 340 | 341 | (defun def-contents? (known-defs formals body) 342 | (if (formals? formals) 343 | (expr? known-defs formals body) 344 | 'nil)) 345 | 346 | (defun def? (known-defs def) 347 | (if (dethm? def) 348 | (if (undefined? (dethm.name def) 349 | known-defs) 350 | (def-contents? known-defs 351 | (dethm.formals def) 352 | (dethm.body def)) 353 | 'nil) 354 | (if (defun? def) 355 | (if (undefined? (defun.name def) 356 | known-defs) 357 | (def-contents? 358 | (extend-rec known-defs def) 359 | (defun.formals def) 360 | (defun.body def)) 361 | 'nil) 362 | 'nil))) 363 | 364 | (defun defs? (known-defs defs) 365 | (if (atom defs) 366 | 't 367 | (if (def? known-defs (car defs)) 368 | (defs? (list-extend known-defs (car defs)) 369 | (cdr defs)) 370 | 'nil))) 371 | 372 | (defun list2-or-more? (pf) 373 | (if (atom pf) 374 | 'nil 375 | (if (atom (cdr pf)) 376 | 'nil 377 | 't))) 378 | 379 | (defun proof? (defs pf) 380 | (if (list2-or-more? pf) 381 | (if (def? defs (elem1 pf)) 382 | (if (seed? defs (elem1 pf) (elem2 pf)) 383 | (steps? (extend-rec defs (elem1 pf)) 384 | (cdr (cdr pf))) 385 | 'nil) 386 | 'nil) 387 | 'nil)) 388 | 389 | (defun proofs? (defs pfs) 390 | (if (atom pfs) 391 | 't 392 | (if (proof? defs (car pfs)) 393 | (proofs? 394 | (list-extend defs (elem1 (car pfs))) 395 | (cdr pfs)) 396 | 'nil))) 397 | 398 | (defun sub-var (vars args var) 399 | (if (atom vars) 400 | var 401 | (if (equal (car vars) var) 402 | (car args) 403 | (sub-var (cdr vars) (cdr args) var)))) 404 | 405 | (defun sub-es (vars args es) 406 | (if (atom es) 407 | '() 408 | (if (var? (car es)) 409 | (cons (sub-var vars args (car es)) 410 | (sub-es vars args (cdr es))) 411 | (if (quote? (car es)) 412 | (cons (car es) 413 | (sub-es vars args (cdr es))) 414 | (if (if? (car es)) 415 | (cons 416 | (QAE-if 417 | (sub-es vars args 418 | (if-QAE (car es)))) 419 | (sub-es vars args (cdr es))) 420 | (cons 421 | (app-c (app.name (car es)) 422 | (sub-es vars args 423 | (app.args (car es)))) 424 | (sub-es vars args (cdr es)))))))) 425 | (defun sub-e (vars args e) 426 | (elem1 (sub-es vars args (list1 e)))) 427 | 428 | (defun exprs-recs (f es) 429 | (if (atom es) 430 | '() 431 | (if (var? (car es)) 432 | (exprs-recs f (cdr es)) 433 | (if (quote? (car es)) 434 | (exprs-recs f (cdr es)) 435 | (if (if? (car es)) 436 | (list-union 437 | (exprs-recs f (if-QAE (car es))) 438 | (exprs-recs f (cdr es))) 439 | (if (equal (app.name (car es)) f) 440 | (list-union 441 | (list1 (car es)) 442 | (list-union 443 | (exprs-recs f 444 | (app.args (car es))) 445 | (exprs-recs f (cdr es)))) 446 | (list-union 447 | (exprs-recs f (app.args (car es))) 448 | (exprs-recs f 449 | (cdr es))))))))) 450 | (defun expr-recs (f e) 451 | (exprs-recs f (list1 e))) 452 | 453 | (defun totality/< (meas formals app) 454 | (app-c '< 455 | (list2 (sub-e formals (app.args app) meas) 456 | meas))) 457 | 458 | (defun totality/meas (meas formals apps) 459 | (if (atom apps) 460 | '() 461 | (cons 462 | (totality/< meas formals (car apps)) 463 | (totality/meas meas formals (cdr apps))))) 464 | 465 | (defun totality/if (meas f formals e) 466 | (if (if? e) 467 | (conjunction 468 | (list-extend 469 | (totality/meas meas formals 470 | (expr-recs f (if.Q e))) 471 | (if-c-when-necessary (if.Q e) 472 | (totality/if meas f formals 473 | (if.A e)) 474 | (totality/if meas f formals 475 | (if.E e))))) 476 | (conjunction 477 | (totality/meas meas formals 478 | (expr-recs f e))))) 479 | 480 | (defun totality/claim (meas def) 481 | (if (equal meas 'nil) 482 | (if (equal (expr-recs (defun.name def) 483 | (defun.body def)) 484 | '()) 485 | (quote-c 't) 486 | (quote-c 'nil)) 487 | (if-c 488 | (app-c 'natp (list1 meas)) 489 | (totality/if meas (defun.name def) 490 | (defun.formals def) 491 | (defun.body def)) 492 | (quote-c 'nil)))) 493 | 494 | (defun induction/prems (vars claim apps) 495 | (if (atom apps) 496 | '() 497 | (cons 498 | (sub-e vars (app.args (car apps)) claim) 499 | (induction/prems vars claim (cdr apps))))) 500 | 501 | (defun induction/if (vars claim f e) 502 | (if (if? e) 503 | (implication 504 | (induction/prems vars claim 505 | (expr-recs f (if.Q e))) 506 | (if-c-when-necessary (if.Q e) 507 | (induction/if vars claim f (if.A e)) 508 | (induction/if vars claim f (if.E e)))) 509 | (implication 510 | (induction/prems vars claim 511 | (expr-recs f e)) 512 | claim))) 513 | 514 | (defun induction/defun (vars claim def) 515 | (induction/if vars claim (defun.name def) 516 | (sub-e (defun.formals def) vars 517 | (defun.body def)))) 518 | 519 | (defun induction/claim (defs seed def) 520 | (if (equal seed 'nil) 521 | (dethm.body def) 522 | (induction/defun (app.args seed) 523 | (dethm.body def) 524 | (lookup (app.name seed) defs)))) 525 | 526 | (defun find-focus-at-direction (dir e) 527 | (if (equal dir 'Q) 528 | (if.Q e) 529 | (if (equal dir 'A) 530 | (if.A e) 531 | (if (equal dir 'E) 532 | (if.E e) 533 | (get-arg dir (app.args e)))))) 534 | 535 | (defun rewrite-focus-at-direction (dir e1 e2) 536 | (if (equal dir 'Q) 537 | (if-c e2 (if.A e1) (if.E e1)) 538 | (if (equal dir 'A) 539 | (if-c (if.Q e1) e2 (if.E e1)) 540 | (if (equal dir 'E) 541 | (if-c (if.Q e1) (if.A e1) e2) 542 | (app-c (app.name e1) 543 | (set-arg dir (app.args e1) e2)))))) 544 | 545 | (defun focus-is-at-direction? (dir e) 546 | (if (equal dir 'Q) 547 | (if? e) 548 | (if (equal dir 'A) 549 | (if? e) 550 | (if (equal dir 'E) 551 | (if? e) 552 | (if (app? e) 553 | (<=len dir (app.args e)) 554 | 'nil))))) 555 | 556 | (defun focus-is-at-path? (path e) 557 | (if (atom path) 558 | 't 559 | (if (focus-is-at-direction? (car path) e) 560 | (focus-is-at-path? (cdr path) 561 | (find-focus-at-direction (car path) e)) 562 | 'nil))) 563 | 564 | (defun find-focus-at-path (path e) 565 | (if (atom path) 566 | e 567 | (find-focus-at-path (cdr path) 568 | (find-focus-at-direction (car path) e)))) 569 | 570 | (defun rewrite-focus-at-path (path e1 e2) 571 | (if (atom path) 572 | e2 573 | (rewrite-focus-at-direction (car path) e1 574 | (rewrite-focus-at-path (cdr path) 575 | (find-focus-at-direction (car path) e1) 576 | e2)))) 577 | 578 | (defun prem-A? (prem path e) 579 | (if (atom path) 580 | 'nil 581 | (if (equal (car path) 'A) 582 | (if (equal (if.Q e) prem) 583 | 't 584 | (prem-A? prem (cdr path) 585 | (find-focus-at-direction (car path) 586 | e))) 587 | (prem-A? prem (cdr path) 588 | (find-focus-at-direction (car path) 589 | e))))) 590 | 591 | (defun prem-E? (prem path e) 592 | (if (atom path) 593 | 'nil 594 | (if (equal (car path) 'E) 595 | (if (equal (if.Q e) prem) 596 | 't 597 | (prem-E? prem (cdr path) 598 | (find-focus-at-direction (car path) 599 | e))) 600 | (prem-E? prem (cdr path) 601 | (find-focus-at-direction (car path) 602 | e))))) 603 | 604 | (defun follow-prems (path e thm) 605 | (if (if? thm) 606 | (if (prem-A? (if.Q thm) path e) 607 | (follow-prems path e (if.A thm)) 608 | (if (prem-E? (if.Q thm) path e) 609 | (follow-prems path e (if.E thm)) 610 | thm)) 611 | thm)) 612 | 613 | (defun unary-op (rator rand) 614 | (if (equal rator 'atom) 615 | (atom rand) 616 | (if (equal rator 'car) 617 | (car rand) 618 | (if (equal rator 'cdr) 619 | (cdr rand) 620 | (if (equal rator 'natp) 621 | (natp rand) 622 | (if (equal rator 'size) 623 | (size rand) 624 | 'nil)))))) 625 | 626 | (defun binary-op (rator rand1 rand2) 627 | (if (equal rator 'equal) 628 | (equal rand1 rand2) 629 | (if (equal rator 'cons) 630 | (cons rand1 rand2) 631 | (if (equal rator '+) 632 | (+ rand1 rand2) 633 | (if (equal rator '<) 634 | (< rand1 rand2) 635 | 'nil))))) 636 | 637 | (defun apply-op (rator rands) 638 | (if (member? rator '(atom car cdr natp size)) 639 | (unary-op rator (elem1 rands)) 640 | (if (member? rator '(equal cons + <)) 641 | (binary-op rator 642 | (elem1 rands) 643 | (elem2 rands)) 644 | 'nil))) 645 | 646 | (defun rands (args) 647 | (if (atom args) 648 | '() 649 | (cons (quote.value (car args)) 650 | (rands (cdr args))))) 651 | 652 | (defun eval-op (app) 653 | (quote-c 654 | (apply-op (app.name app) 655 | (rands (app.args app))))) 656 | 657 | (defun app-of-equal? (e) 658 | (if (app? e) 659 | (equal (app.name e) 'equal) 660 | 'nil)) 661 | 662 | (defun equality (focus a b) 663 | (if (equal focus a) 664 | b 665 | (if (equal focus b) 666 | a 667 | focus))) 668 | 669 | (defun equality/equation (focus concl-inst) 670 | (if (app-of-equal? concl-inst) 671 | (equality focus 672 | (elem1 (app.args concl-inst)) 673 | (elem2 (app.args concl-inst))) 674 | focus)) 675 | 676 | (defun equality/path (e path thm) 677 | (if (focus-is-at-path? path e) 678 | (rewrite-focus-at-path path e 679 | (equality/equation 680 | (find-focus-at-path path e) 681 | (follow-prems path e thm))) 682 | e)) 683 | 684 | (defun equality/def (claim path app def) 685 | (if (rator? def) 686 | (equality/path claim path 687 | (app-c 'equal (list2 app (eval-op app)))) 688 | (if (defun? def) 689 | (equality/path claim path 690 | (sub-e (defun.formals def) 691 | (app.args app) 692 | (app-c 'equal 693 | (list2 694 | (app-c (defun.name def) 695 | (defun.formals def)) 696 | (defun.body def))))) 697 | (if (dethm? def) 698 | (equality/path claim path 699 | (sub-e (dethm.formals def) 700 | (app.args app) 701 | (dethm.body def))) 702 | claim)))) 703 | 704 | (defun rewrite/step (defs claim step) 705 | (equality/def claim (elem1 step) (elem2 step) 706 | (lookup (app.name (elem2 step)) defs))) 707 | 708 | (defun rewrite/continue (defs steps old new) 709 | (if (equal new old) 710 | new 711 | (if (atom steps) 712 | new 713 | (rewrite/continue defs (cdr steps) new 714 | (rewrite/step defs new (car steps)))))) 715 | 716 | (defun rewrite/steps (defs claim steps) 717 | (if (atom steps) 718 | claim 719 | (rewrite/continue defs (cdr steps) claim 720 | (rewrite/step defs claim (car steps))))) 721 | 722 | (defun rewrite/prove (defs def seed steps) 723 | (if (defun? def) 724 | (rewrite/steps defs 725 | (totality/claim seed def) 726 | steps) 727 | (if (dethm? def) 728 | (rewrite/steps defs 729 | (induction/claim defs seed def) 730 | steps) 731 | (quote-c 'nil)))) 732 | 733 | (defun rewrite/prove+1 (defs pf e) 734 | (if (equal e (quote-c 't)) 735 | (rewrite/prove defs (elem1 pf) (elem2 pf) 736 | (cdr (cdr pf))) 737 | e)) 738 | 739 | (defun rewrite/prove+ (defs pfs) 740 | (if (atom pfs) 741 | (quote-c 't) 742 | (rewrite/prove+1 defs (car pfs) 743 | (rewrite/prove+ 744 | (list-extend defs (elem1 (car pfs))) 745 | (cdr pfs))))) 746 | 747 | (defun rewrite/define (defs def seed steps) 748 | (if (equal (rewrite/prove defs def seed steps) 749 | (quote-c 't)) 750 | (list-extend defs def) 751 | defs)) 752 | 753 | (defun rewrite/define+1 (defs1 defs2 pfs) 754 | (if (equal defs1 defs2) 755 | defs1 756 | (if (atom pfs) 757 | defs2 758 | (rewrite/define+1 defs2 759 | (rewrite/define defs2 760 | (elem1 (car pfs)) 761 | (elem2 (car pfs)) 762 | (cdr (cdr (car pfs)))) 763 | (cdr pfs))))) 764 | 765 | (defun rewrite/define+ (defs pfs) 766 | (if (atom pfs) 767 | defs 768 | (rewrite/define+1 defs 769 | (rewrite/define defs 770 | (elem1 (car pfs)) 771 | (elem2 (car pfs)) 772 | (cdr (cdr (car pfs)))) 773 | (cdr pfs)))) 774 | 775 | (defun J-Bob/step (defs e steps) 776 | (if (defs? '() defs) 777 | (if (expr? defs 'any e) 778 | (if (steps? defs steps) 779 | (rewrite/steps defs e steps) 780 | e) 781 | e) 782 | e)) 783 | 784 | (defun J-Bob/prove (defs pfs) 785 | (if (defs? '() defs) 786 | (if (proofs? defs pfs) 787 | (rewrite/prove+ defs pfs) 788 | (quote-c 'nil)) 789 | (quote-c 'nil))) 790 | 791 | (defun J-Bob/define (defs pfs) 792 | (if (defs? '() defs) 793 | (if (proofs? defs pfs) 794 | (rewrite/define+ defs pfs) 795 | defs) 796 | defs)) 797 | 798 | (defun axioms () 799 | '((dethm atom/cons (x y) 800 | (equal (atom (cons x y)) 'nil)) 801 | (dethm car/cons (x y) 802 | (equal (car (cons x y)) x)) 803 | (dethm cdr/cons (x y) 804 | (equal (cdr (cons x y)) y)) 805 | (dethm equal-same (x) 806 | (equal (equal x x) 't)) 807 | (dethm equal-swap (x y) 808 | (equal (equal x y) (equal y x))) 809 | (dethm if-same (x y) 810 | (equal (if x y y) y)) 811 | (dethm if-true (x y) 812 | (equal (if 't x y) x)) 813 | (dethm if-false (x y) 814 | (equal (if 'nil x y) y)) 815 | (dethm if-nest-E (x y z) 816 | (if x 't (equal (if x y z) z))) 817 | (dethm if-nest-A (x y z) 818 | (if x (equal (if x y z) y) 't)) 819 | (dethm cons/car+cdr (x) 820 | (if (atom x) 821 | 't 822 | (equal (cons (car x) (cdr x)) x))) 823 | (dethm equal-if (x y) 824 | (if (equal x y) (equal x y) 't)) 825 | (dethm natp/size (x) 826 | (equal (natp (size x)) 't)) 827 | (dethm size/car (x) 828 | (if (atom x) 829 | 't 830 | (equal (< (size (car x)) (size x)) 't))) 831 | (dethm size/cdr (x) 832 | (if (atom x) 833 | 't 834 | (equal (< (size (cdr x)) (size x)) 't))) 835 | (dethm associate-+ (a b c) 836 | (equal (+ (+ a b) c) (+ a (+ b c)))) 837 | (dethm commute-+ (x y) 838 | (equal (+ x y) (+ y x))) 839 | (dethm natp/+ (x y) 840 | (if (natp x) 841 | (if (natp y) 842 | (equal (natp (+ x y)) 't) 843 | 't) 844 | 't)) 845 | (dethm positives-+ (x y) 846 | (if (< '0 x) 847 | (if (< '0 y) 848 | (equal (< '0 (+ x y)) 't) 849 | 't) 850 | 't)) 851 | (dethm common-addends-< (x y z) 852 | (equal (< (+ x z) (+ y z)) (< x y))) 853 | (dethm identity-+ (x) 854 | (if (natp x) (equal (+ '0 x) x) 't)))) 855 | 856 | (defun prelude () 857 | (J-Bob/define (axioms) 858 | '(((defun list-induction (x) 859 | (if (atom x) 860 | '() 861 | (cons (car x) 862 | (list-induction (cdr x))))) 863 | (size x) 864 | ((A E) (size/cdr x)) 865 | ((A) (if-same (atom x) 't)) 866 | ((Q) (natp/size x)) 867 | (() (if-true 't 'nil))) 868 | ((defun star-induction (x) 869 | (if (atom x) 870 | x 871 | (cons (star-induction (car x)) 872 | (star-induction (cdr x))))) 873 | (size x) 874 | ((A E A) (size/cdr x)) 875 | ((A E Q) (size/car x)) 876 | ((A E) (if-true 't 'nil)) 877 | ((A) (if-same (atom x) 't)) 878 | ((Q) (natp/size x)) 879 | (() (if-true 't 'nil)))))) 880 | -------------------------------------------------------------------------------- /scheme/little-prover.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; Chapter 1 3 | 4 | (defun chapter1.example1 () 5 | (J-Bob/step (prelude) 6 | '(car (cons 'ham '(eggs))) 7 | '(((1) (cons 'ham '(eggs))) 8 | (() (car '(ham eggs)))))) 9 | 10 | (defun chapter1.example2 () 11 | (J-Bob/step (prelude) 12 | '(atom '()) 13 | '((() (atom '()))))) 14 | 15 | (defun chapter1.example3 () 16 | (J-Bob/step (prelude) 17 | '(atom (cons 'ham '(eggs))) 18 | '(((1) (cons 'ham '(eggs))) 19 | (() (atom '(ham eggs)))))) 20 | 21 | (defun chapter1.example4 () 22 | (J-Bob/step (prelude) 23 | '(atom (cons a b)) 24 | '((() (atom/cons a b))))) 25 | 26 | (defun chapter1.example5 () 27 | (J-Bob/step (prelude) 28 | '(equal 'flapjack (atom (cons a b))) 29 | '(((2) (atom/cons a b)) 30 | (() (equal 'flapjack 'nil))))) 31 | 32 | (defun chapter1.example6 () 33 | (J-Bob/step (prelude) 34 | '(atom (cdr (cons (car (cons p q)) '()))) 35 | '(((1 1 1) (car/cons p q)) 36 | ((1) (cdr/cons p '())) 37 | (() (atom '()))))) 38 | 39 | (defun chapter1.example7 () 40 | (J-Bob/step (prelude) 41 | '(atom (cdr (cons (car (cons p q)) '()))) 42 | '(((1) (cdr/cons (car (cons p q)) '())) 43 | (() (atom '()))))) 44 | 45 | (defun chapter1.example8 () 46 | (J-Bob/step (prelude) 47 | '(car (cons (equal (cons x y) (cons x y)) '(and crumpets))) 48 | '(((1 1) (equal-same (cons x y))) 49 | ((1) (cons 't '(and crumpets))) 50 | (() (car '(t and crumpets)))))) 51 | 52 | (defun chapter1.example9 () 53 | (J-Bob/step (prelude) 54 | '(equal (cons x y) (cons 'bagels '(and lox))) 55 | '((() (equal-swap (cons x y) (cons 'bagels '(and lox))))))) 56 | 57 | (defun chapter1.example10 () 58 | (J-Bob/step (prelude) 59 | '(cons y (equal (car (cons (cdr x) (car y))) (equal (atom x) 'nil))) 60 | '(((2 1) (car/cons (cdr x) (car y)))))) 61 | 62 | (defun chapter1.example11 () 63 | (J-Bob/step (prelude) 64 | '(cons y (equal (car (cons (cdr x) (car y))) (equal (atom x) 'nil))) 65 | '(((2 1) (car/cons (car (cons (cdr x) (car y))) '(oats))) 66 | ((2 2 2) (atom/cons (atom (cdr (cons a b))) (equal (cons a b) c))) 67 | ((2 2 2 1 1 1) (cdr/cons a b)) 68 | ((2 2 2 1 2) (equal-swap (cons a b) c))))) 69 | 70 | (defun chapter1.example12 () 71 | (J-Bob/step (prelude) 72 | '(atom (car (cons (car a) (cdr b)))) 73 | '(((1) (car/cons (car a) (cdr b)))))) 74 | 75 | ;; Chapter 2 76 | 77 | (defun chapter2.example1 () 78 | (J-Bob/step (prelude) 79 | '(if (car (cons a b)) c c) 80 | '(((Q) (car/cons a b)) 81 | (() (if-same a c)) 82 | (() 83 | (if-same 84 | (if (equal a 't) (if (equal 'nil 'nil) a b) (equal 'or (cons 'black '(coffee)))) 85 | c)) 86 | ((Q E 2) (cons 'black '(coffee))) 87 | ((Q A Q) (equal-same 'nil)) 88 | ((Q A) (if-true a b)) 89 | ((Q A) (equal-if a 't))))) 90 | 91 | (defun chapter2.example2 () 92 | (J-Bob/step (prelude) 93 | '(if (atom (car a)) 94 | (if (equal (car a) (cdr a)) 'hominy 'grits) 95 | (if (equal (cdr (car a)) '(hash browns)) 96 | (cons 'ketchup (car a)) 97 | (cons 'mustard (car a)))) 98 | '(((E A 2) (cons/car+cdr (car a))) 99 | ((E A 2 2) (equal-if (cdr (car a)) '(hash browns)))))) 100 | 101 | (defun chapter2.example3 () 102 | (J-Bob/step (prelude) 103 | '(cons 'statement 104 | (cons (if (equal a 'question) (cons n '(answer)) (cons n '(else))) 105 | (if (equal a 'question) (cons n '(other answer)) (cons n '(other else))))) 106 | '(((2) 107 | (if-same (equal a 'question) 108 | (cons (if (equal a 'question) (cons n '(answer)) (cons n '(else))) 109 | (if (equal a 'question) (cons n '(other answer)) (cons n '(other else)))))) 110 | ((2 A 1) (if-nest-A (equal a 'question) (cons n '(answer)) (cons n '(else)))) 111 | ((2 E 1) (if-nest-E (equal a 'question) (cons n '(answer)) (cons n '(else)))) 112 | ((2 A 2) 113 | (if-nest-A (equal a 'question) (cons n '(other answer)) (cons n '(other else)))) 114 | ((2 E 2) 115 | (if-nest-E (equal a 'question) 116 | (cons n '(other answer)) 117 | (cons n '(other else))))))) 118 | 119 | ;; Chapter 3 120 | 121 | (defun defun.pair () 122 | (J-Bob/define (prelude) 123 | '(((defun pair (x y) 124 | (cons x (cons y '()))) 125 | nil)))) 126 | 127 | (defun defun.first-of () 128 | (J-Bob/define (defun.pair) 129 | '(((defun first-of (x) 130 | (car x)) 131 | nil)))) 132 | 133 | (defun defun.second-of () 134 | (J-Bob/define (defun.first-of) 135 | '(((defun second-of (x) 136 | (car (cdr x))) 137 | nil)))) 138 | 139 | (defun dethm.first-of-pair () 140 | (J-Bob/define (defun.second-of) 141 | '(((dethm first-of-pair (a b) 142 | (equal (first-of (pair a b)) a)) 143 | nil 144 | ((1 1) (pair a b)) 145 | ((1) (first-of (cons a (cons b '())))) 146 | ((1) (car/cons a (cons b '()))) 147 | (() (equal-same a)))))) 148 | 149 | (defun dethm.second-of-pair () 150 | (J-Bob/define (dethm.first-of-pair) 151 | '(((dethm second-of-pair (a b) 152 | (equal (second-of (pair a b)) b)) 153 | nil 154 | ((1) (second-of (pair a b))) 155 | ((1 1 1) (pair a b)) 156 | ((1 1) (cdr/cons a (cons b '()))) 157 | ((1) (car/cons b '())) 158 | (() (equal-same b)))))) 159 | 160 | (defun defun.in-pair? () 161 | (J-Bob/define (dethm.second-of-pair) 162 | '(((defun in-pair? (xs) 163 | (if (equal (first-of xs) '?) 't (equal (second-of xs) '?))) 164 | nil)))) 165 | 166 | (defun dethm.in-first-of-pair () 167 | (J-Bob/define (defun.in-pair?) 168 | '(((dethm in-first-of-pair (b) 169 | (equal (in-pair? (pair '? b)) 't)) 170 | nil 171 | ((1 1) (pair '? b)) 172 | ((1) (in-pair? (cons '? (cons b '())))) 173 | ((1 Q 1) (first-of (cons '? (cons b '())))) 174 | ((1 Q 1) (car/cons '? (cons b '()))) 175 | ((1 Q) (equal-same '?)) 176 | ((1) (if-true 't (equal (second-of (cons '? (cons b '()))) '?))) 177 | (() (equal-same 't)))))) 178 | 179 | (defun dethm.in-second-of-pair () 180 | (J-Bob/define (dethm.in-first-of-pair) 181 | '(((dethm in-second-of-pair (a) 182 | (equal (in-pair? (pair a '?)) 't)) 183 | nil 184 | ((1 1) (pair a '?)) 185 | ((1) (in-pair? (cons a (cons '? '())))) 186 | ((1 Q 1) (first-of (cons a (cons '? '())))) 187 | ((1 Q 1) (car/cons a (cons '? '()))) 188 | ((1 E 1) (second-of (cons a (cons '? '())))) 189 | ((1 E 1 1) (cdr/cons a (cons '? '()))) 190 | ((1 E 1) (car/cons '? '())) 191 | ((1 E) (equal-same '?)) 192 | ((1) (if-same (equal a '?) 't)) 193 | (() (equal-same 't)))))) 194 | 195 | ;; Chapter 4 196 | 197 | (defun defun.list0? () 198 | (J-Bob/define (dethm.in-second-of-pair) 199 | '(((defun list0? (x) 200 | (equal x '())) 201 | nil)))) 202 | 203 | (defun defun.list1? () 204 | (J-Bob/define (defun.list0?) 205 | '(((defun list1? (x) 206 | (if (atom x) 'nil (list0? (cdr x)))) 207 | nil)))) 208 | 209 | (defun defun.list2? () 210 | (J-Bob/define (defun.list1?) 211 | '(((defun list2? (x) 212 | (if (atom x) 'nil (list1? (cdr x)))) 213 | nil)))) 214 | 215 | (defun dethm.contradiction () 216 | (J-Bob/prove 217 | (list-extend (prelude) 218 | '(defun partial (x) 219 | (if (partial x) 'nil 't))) 220 | '(((dethm contradiction () 'nil) 221 | nil 222 | (() (if-same (partial x) 'nil)) 223 | ((A) (if-nest-A (partial x) 'nil 't)) 224 | ((E) (if-nest-E (partial x) 't 'nil)) 225 | ((A Q) (partial x)) 226 | ((E Q) (partial x)) 227 | ((A Q) (if-nest-A (partial x) 'nil 't)) 228 | ((E Q) (if-nest-E (partial x) 'nil 't)) 229 | ((A) (if-false 'nil 't)) 230 | ((E) (if-true 't 'nil)) 231 | (() (if-same (partial x) 't)))))) 232 | 233 | (defun defun.list? () 234 | (J-Bob/define (defun.list2?) 235 | '(((defun list? (x) 236 | (if (atom x) (equal x '()) (list? (cdr x)))) 237 | (size x) 238 | ((Q) (natp/size x)) 239 | (() (if-true (if (atom x) 't (< (size (cdr x)) (size x))) 'nil)) 240 | ((E) (size/cdr x)) 241 | (() (if-same (atom x) 't)))))) 242 | 243 | (defun defun.sub () 244 | (J-Bob/define (defun.list?) 245 | '(((defun sub (x y) 246 | (if (atom y) (if (equal y '?) x y) (cons (sub x (car y)) (sub x (cdr y))))) 247 | (size y) 248 | ((Q) (natp/size y)) 249 | (() 250 | (if-true 251 | (if (atom y) 252 | 't 253 | (if (< (size (car y)) (size y)) (< (size (cdr y)) (size y)) 'nil)) 254 | 'nil)) 255 | ((E Q) (size/car y)) 256 | ((E A) (size/cdr y)) 257 | ((E) (if-true 't 'nil)) 258 | (() (if-same (atom y) 't)))))) 259 | 260 | ;; Chapter 5 261 | 262 | (defun defun.memb? () 263 | (J-Bob/define (defun.sub) 264 | '(((defun memb? (xs) 265 | (if (atom xs) 'nil (if (equal (car xs) '?) 't (memb? (cdr xs))))) 266 | (size xs) 267 | ((Q) (natp/size xs)) 268 | (() 269 | (if-true 270 | (if (atom xs) 't (if (equal (car xs) '?) 't (< (size (cdr xs)) (size xs)))) 271 | 'nil)) 272 | ((E E) (size/cdr xs)) 273 | ((E) (if-same (equal (car xs) '?) 't)) 274 | (() (if-same (atom xs) 't)))))) 275 | 276 | (defun defun.remb () 277 | (J-Bob/define (defun.memb?) 278 | '(((defun remb (xs) 279 | (if (atom xs) 280 | '() 281 | (if (equal (car xs) '?) (remb (cdr xs)) (cons (car xs) (remb (cdr xs)))))) 282 | (size xs) 283 | ((Q) (natp/size xs)) 284 | (() (if-true (if (atom xs) 't (< (size (cdr xs)) (size xs))) 'nil)) 285 | ((E) (size/cdr xs)) 286 | (() (if-same (atom xs) 't)))))) 287 | 288 | (defun dethm.memb?/remb0 () 289 | (J-Bob/define (defun.remb) 290 | '(((dethm memb?/remb0 () 291 | (equal (memb? (remb '())) 'nil)) 292 | nil 293 | ((1 1) (remb '())) 294 | ((1 1 Q) (atom '())) 295 | ((1 1) 296 | (if-true '() 297 | (if (equal (car '()) '?) (remb (cdr '())) (cons (car '()) (remb (cdr '())))))) 298 | ((1) (memb? '())) 299 | ((1 Q) (atom '())) 300 | ((1) (if-true 'nil (if (equal (car '()) '?) 't (memb? (cdr '()))))) 301 | (() (equal-same 'nil)))))) 302 | 303 | (defun dethm.memb?/remb1 () 304 | (J-Bob/define (dethm.memb?/remb0) 305 | '(((dethm memb?/remb1 (x1) 306 | (equal (memb? (remb (cons x1 '()))) 'nil)) 307 | nil 308 | ((1 1) (remb (cons x1 '()))) 309 | ((1 1 Q) (atom/cons x1 '())) 310 | ((1 1) 311 | (if-false '() 312 | (if (equal (car (cons x1 '())) '?) 313 | (remb (cdr (cons x1 '()))) 314 | (cons (car (cons x1 '())) (remb (cdr (cons x1 '()))))))) 315 | ((1 1 Q 1) (car/cons x1 '())) 316 | ((1 1 A 1) (cdr/cons x1 '())) 317 | ((1 1 E 1) (car/cons x1 '())) 318 | ((1 1 E 2 1) (cdr/cons x1 '())) 319 | ((1) 320 | (if-same (equal x1 '?) 321 | (memb? (if (equal x1 '?) (remb '()) (cons x1 (remb '())))))) 322 | ((1 A 1) (if-nest-A (equal x1 '?) (remb '()) (cons x1 (remb '())))) 323 | ((1 E 1) (if-nest-E (equal x1 '?) (remb '()) (cons x1 (remb '())))) 324 | ((1 A) (memb?/remb0)) 325 | ((1 E) (memb? (cons x1 (remb '())))) 326 | ((1 E Q) (atom/cons x1 (remb '()))) 327 | ((1 E) 328 | (if-false 'nil 329 | (if (equal (car (cons x1 (remb '()))) '?) 330 | 't 331 | (memb? (cdr (cons x1 (remb '()))))))) 332 | ((1 E Q 1) (car/cons x1 (remb '()))) 333 | ((1 E E 1) (cdr/cons x1 (remb '()))) 334 | ((1 E) (if-nest-E (equal x1 '?) 't (memb? (remb '())))) 335 | ((1 E) (memb?/remb0)) 336 | ((1) (if-same (equal x1 '?) 'nil)) 337 | (() (equal-same 'nil)))))) 338 | 339 | (defun dethm.memb?/remb2 () 340 | (J-Bob/define (dethm.memb?/remb1) 341 | '(((dethm memb?/remb2 (x1 x2) 342 | (equal (memb? (remb (cons x2 (cons x1 '())))) 'nil)) 343 | nil 344 | ((1 1) (remb (cons x2 (cons x1 '())))) 345 | ((1 1 Q) (atom/cons x2 (cons x1 '()))) 346 | ((1 1) 347 | (if-false '() 348 | (if (equal (car (cons x2 (cons x1 '()))) '?) 349 | (remb (cdr (cons x2 (cons x1 '())))) 350 | (cons (car (cons x2 (cons x1 '()))) 351 | (remb (cdr (cons x2 (cons x1 '())))))))) 352 | ((1 1 Q 1) (car/cons x2 (cons x1 '()))) 353 | ((1 1 A 1) (cdr/cons x2 (cons x1 '()))) 354 | ((1 1 E 1) (car/cons x2 (cons x1 '()))) 355 | ((1 1 E 2 1) (cdr/cons x2 (cons x1 '()))) 356 | ((1) 357 | (if-same (equal x2 '?) 358 | (memb? 359 | (if (equal x2 '?) (remb (cons x1 '())) (cons x2 (remb (cons x1 '()))))))) 360 | ((1 A 1) 361 | (if-nest-A (equal x2 '?) (remb (cons x1 '())) (cons x2 (remb (cons x1 '()))))) 362 | ((1 E 1) 363 | (if-nest-E (equal x2 '?) (remb (cons x1 '())) (cons x2 (remb (cons x1 '()))))) 364 | ((1 A) (memb?/remb1 x1)) 365 | ((1 E) (memb? (cons x2 (remb (cons x1 '()))))) 366 | ((1 E Q) (atom/cons x2 (remb (cons x1 '())))) 367 | ((1 E) 368 | (if-false 'nil 369 | (if (equal (car (cons x2 (remb (cons x1 '())))) '?) 370 | 't 371 | (memb? (cdr (cons x2 (remb (cons x1 '())))))))) 372 | ((1 E Q 1) (car/cons x2 (remb (cons x1 '())))) 373 | ((1 E E 1) (cdr/cons x2 (remb (cons x1 '())))) 374 | ((1 E) (if-nest-E (equal x2 '?) 't (memb? (remb (cons x1 '()))))) 375 | ((1 E) (memb?/remb1 x1)) 376 | ((1) (if-same (equal x2 '?) 'nil)) 377 | (() (equal-same 'nil)))))) 378 | 379 | ;; Chapter 6 380 | 381 | (defun dethm.memb?/remb () 382 | (J-Bob/define (dethm.memb?/remb2) 383 | '(((dethm memb?/remb (xs) 384 | (equal (memb? (remb xs)) 'nil)) 385 | (list-induction xs) 386 | ((A 1 1) (remb xs)) 387 | ((A 1 1) 388 | (if-nest-A (atom xs) 389 | '() 390 | (if (equal (car xs) '?) (remb (cdr xs)) (cons (car xs) (remb (cdr xs)))))) 391 | ((A 1) (memb? '())) 392 | ((A 1 Q) (atom '())) 393 | ((A 1) (if-true 'nil (if (equal (car '()) '?) 't (memb? (cdr '()))))) 394 | ((A) (equal-same 'nil)) 395 | ((E A 1 1) (remb xs)) 396 | ((E A 1 1) 397 | (if-nest-E (atom xs) 398 | '() 399 | (if (equal (car xs) '?) (remb (cdr xs)) (cons (car xs) (remb (cdr xs)))))) 400 | ((E A 1) 401 | (if-same (equal (car xs) '?) 402 | (memb? 403 | (if (equal (car xs) '?) (remb (cdr xs)) (cons (car xs) (remb (cdr xs))))))) 404 | ((E A 1 A 1) 405 | (if-nest-A (equal (car xs) '?) (remb (cdr xs)) (cons (car xs) (remb (cdr xs))))) 406 | ((E A 1 E 1) 407 | (if-nest-E (equal (car xs) '?) (remb (cdr xs)) (cons (car xs) (remb (cdr xs))))) 408 | ((E A 1 A) (equal-if (memb? (remb (cdr xs))) 'nil)) 409 | ((E A 1 E) (memb? (cons (car xs) (remb (cdr xs))))) 410 | ((E A 1 E Q) (atom/cons (car xs) (remb (cdr xs)))) 411 | ((E A 1 E) 412 | (if-false 'nil 413 | (if (equal (car (cons (car xs) (remb (cdr xs)))) '?) 414 | 't 415 | (memb? (cdr (cons (car xs) (remb (cdr xs)))))))) 416 | ((E A 1 E Q 1) (car/cons (car xs) (remb (cdr xs)))) 417 | ((E A 1 E E 1) (cdr/cons (car xs) (remb (cdr xs)))) 418 | ((E A 1 E) (if-nest-E (equal (car xs) '?) 't (memb? (remb (cdr xs))))) 419 | ((E A 1 E) (equal-if (memb? (remb (cdr xs))) 'nil)) 420 | ((E A 1) (if-same (equal (car xs) '?) 'nil)) 421 | ((E A) (equal-same 'nil)) 422 | ((E) (if-same (equal (memb? (remb (cdr xs))) 'nil) 't)) 423 | (() (if-same (atom xs) 't)))))) 424 | 425 | ;; Chapter 7 426 | 427 | (defun defun.ctx? () 428 | (J-Bob/define (dethm.memb?/remb) 429 | '(((defun ctx? (x) 430 | (if (atom x) (equal x '?) (if (ctx? (car x)) 't (ctx? (cdr x))))) 431 | (size x) 432 | ((Q) (natp/size x)) 433 | (() 434 | (if-true 435 | (if (atom x) 436 | 't 437 | (if (< (size (car x)) (size x)) 438 | (if (ctx? (car x)) 't (< (size (cdr x)) (size x))) 439 | 'nil)) 440 | 'nil)) 441 | ((E Q) (size/car x)) 442 | ((E A E) (size/cdr x)) 443 | ((E A) (if-same (ctx? (car x)) 't)) 444 | ((E) (if-true 't 'nil)) 445 | (() (if-same (atom x) 't)))))) 446 | 447 | (defun dethm.ctx?/sub () 448 | (J-Bob/define (defun.ctx?) 449 | '(((dethm ctx?/t (x) 450 | (if (ctx? x) (equal (ctx? x) 't) 't)) 451 | (star-induction x) 452 | ((A A 1) (ctx? x)) 453 | ((A A 1) (if-nest-A (atom x) (equal x '?) (if (ctx? (car x)) 't (ctx? (cdr x))))) 454 | ((A Q) (ctx? x)) 455 | ((A Q) (if-nest-A (atom x) (equal x '?) (if (ctx? (car x)) 't (ctx? (cdr x))))) 456 | ((A A 1 1) (equal-if x '?)) 457 | ((A A 1) (equal-same '?)) 458 | ((A A) (equal-same 't)) 459 | ((A) (if-same (equal x '?) 't)) 460 | ((E A A A 1) (ctx? x)) 461 | ((E A A A 1) 462 | (if-nest-E (atom x) (equal x '?) (if (ctx? (car x)) 't (ctx? (cdr x))))) 463 | ((E) 464 | (if-same (ctx? (car x)) 465 | (if (if (ctx? (car x)) (equal (ctx? (car x)) 't) 't) 466 | (if (if (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't) 467 | (if (ctx? x) (equal (if (ctx? (car x)) 't (ctx? (cdr x))) 't) 't) 468 | 't) 469 | 't))) 470 | ((E A Q) (if-nest-A (ctx? (car x)) (equal (ctx? (car x)) 't) 't)) 471 | ((E A A A A 1) (if-nest-A (ctx? (car x)) 't (ctx? (cdr x)))) 472 | ((E E Q) (if-nest-E (ctx? (car x)) (equal (ctx? (car x)) 't) 't)) 473 | ((E E A A A 1) (if-nest-E (ctx? (car x)) 't (ctx? (cdr x)))) 474 | ((E A A A A) (equal-same 't)) 475 | ((E E) 476 | (if-true 477 | (if (if (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't) 478 | (if (ctx? x) (equal (ctx? (cdr x)) 't) 't) 479 | 't) 480 | 't)) 481 | ((E A A A) (if-same (ctx? x) 't)) 482 | ((E A A) (if-same (if (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't) 't)) 483 | ((E A) (if-same (equal (ctx? (car x)) 't) 't)) 484 | ((E E A Q) (ctx? x)) 485 | ((E E A Q) 486 | (if-nest-E (atom x) (equal x '?) (if (ctx? (car x)) 't (ctx? (cdr x))))) 487 | ((E E A Q) (if-nest-E (ctx? (car x)) 't (ctx? (cdr x)))) 488 | ((E E) 489 | (if-same (ctx? (cdr x)) 490 | (if (if (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't) 491 | (if (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't) 492 | 't))) 493 | ((E E A Q)(if-nest-A (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't)) 494 | ((E E A A)(if-nest-A (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't)) 495 | ((E E E Q)(if-nest-E (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't)) 496 | ((E E E A)(if-nest-E (ctx? (cdr x)) (equal (ctx? (cdr x)) 't) 't)) 497 | ((E E E) (if-same 't 't)) 498 | ((E E A A 1) (equal-if (ctx? (cdr x)) 't)) 499 | ((E E A A) (equal-same 't)) 500 | ((E E A) (if-same (equal (ctx? (cdr x)) 't) 't)) 501 | ((E E) (if-same (ctx? (cdr x)) 't)) 502 | ((E) (if-same (ctx? (car x)) 't)) 503 | (() (if-same (atom x) 't))) 504 | ((dethm ctx?/sub (x y) 505 | (if (ctx? x) (if (ctx? y) (equal (ctx? (sub x y)) 't) 't) 't)) 506 | (star-induction y) 507 | (() 508 | (if-same (ctx? x) 509 | (if (atom y) 510 | (if (ctx? x) (if (ctx? y) (equal (ctx? (sub x y)) 't) 't) 't) 511 | (if (if (ctx? x) 512 | (if (ctx? (car y)) (equal (ctx? (sub x (car y))) 't) 't) 513 | 't) 514 | (if (if (ctx? x) 515 | (if (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't) 516 | 't) 517 | (if (ctx? x) (if (ctx? y) (equal (ctx? (sub x y)) 't) 't) 't) 518 | 't) 519 | 't)))) 520 | ((A A) (if-nest-A (ctx? x) (if (ctx? y) (equal (ctx? (sub x y)) 't) 't) 't)) 521 | ((A E Q) 522 | (if-nest-A (ctx? x) (if (ctx? (car y)) (equal (ctx? (sub x (car y))) 't) 't) 't)) 523 | ((A E A Q) 524 | (if-nest-A (ctx? x) (if (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't) 't)) 525 | ((A E A A) (if-nest-A (ctx? x) (if (ctx? y) (equal (ctx? (sub x y)) 't) 't) 't)) 526 | ((E A) (if-nest-E (ctx? x) (if (ctx? y) (equal (ctx? (sub x y)) 't) 't) 't)) 527 | ((E E Q) 528 | (if-nest-E (ctx? x) (if (ctx? (car y)) (equal (ctx? (sub x (car y))) 't) 't) 't)) 529 | ((E E A Q) 530 | (if-nest-E (ctx? x) (if (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't) 't)) 531 | ((E E A A) (if-nest-E (ctx? x) (if (ctx? y) (equal (ctx? (sub x y)) 't) 't) 't)) 532 | ((E E A) (if-same 't 't)) 533 | ((E E) (if-same 't 't)) 534 | ((E) (if-same (atom y) 't)) 535 | ((A A A 1 1) (sub x y)) 536 | ((A A A 1 1) 537 | (if-nest-A (atom y) 538 | (if (equal y '?) x y) 539 | (cons (sub x (car y)) (sub x (cdr y))))) 540 | ((A A A) (if-same (equal y '?) (equal (ctx? (if (equal y '?) x y)) 't))) 541 | ((A A A A 1 1) (if-nest-A (equal y '?) x y)) 542 | ((A A A E 1 1) (if-nest-E (equal y '?) x y)) 543 | ((A A A A 1) (ctx?/t x)) 544 | ((A A A A) (equal-same 't)) 545 | ((A A A E 1) (ctx?/t y)) 546 | ((A A A E) (equal-same 't)) 547 | ((A A A) (if-same (equal y '?) 't)) 548 | ((A A) (if-same (ctx? y) 't)) 549 | ((A E A A A 1 1) (sub x y)) 550 | ((A E A A A 1 1) 551 | (if-nest-E (atom y) 552 | (if (equal y '?) x y) 553 | (cons (sub x (car y)) (sub x (cdr y))))) 554 | ((A E A A A 1) (ctx? (cons (sub x (car y)) (sub x (cdr y))))) 555 | ((A E A A A 1 Q) (atom/cons (sub x (car y)) (sub x (cdr y)))) 556 | ((A E A A A 1 E Q 1) (car/cons (sub x (car y)) (sub x (cdr y)))) 557 | ((A E A A A 1 E E 1) (cdr/cons (sub x (car y)) (sub x (cdr y)))) 558 | ((A E A A A 1) 559 | (if-false (equal (cons (sub x (car y)) (sub x (cdr y))) '?) 560 | (if (ctx? (sub x (car y))) 't (ctx? (sub x (cdr y)))))) 561 | ((A E A A Q) (ctx? y)) 562 | ((A E A A Q) 563 | (if-nest-E (atom y) (equal y '?) (if (ctx? (car y)) 't (ctx? (cdr y))))) 564 | ((A E) 565 | (if-same (ctx? (car y)) 566 | (if (if (ctx? (car y)) (equal (ctx? (sub x (car y))) 't) 't) 567 | (if (if (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't) 568 | (if (if (ctx? (car y)) 't (ctx? (cdr y))) 569 | (equal (if (ctx? (sub x (car y))) 't (ctx? (sub x (cdr y)))) 't) 570 | 't) 571 | 't) 572 | 't))) 573 | ((A E A Q) (if-nest-A (ctx? (car y)) (equal (ctx? (sub x (car y))) 't) 't)) 574 | ((A E A A A Q) (if-nest-A (ctx? (car y)) 't (ctx? (cdr y)))) 575 | ((A E E Q) (if-nest-E (ctx? (car y)) (equal (ctx? (sub x (car y))) 't) 't)) 576 | ((A E E A A Q) (if-nest-E (ctx? (car y)) 't (ctx? (cdr y)))) 577 | ((A E A A A) 578 | (if-true (equal (if (ctx? (sub x (car y))) 't (ctx? (sub x (cdr y)))) 't) 't)) 579 | ((A E E) 580 | (if-true 581 | (if (if (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't) 582 | (if (ctx? (cdr y)) 583 | (equal (if (ctx? (sub x (car y))) 't (ctx? (sub x (cdr y)))) 't) 584 | 't) 585 | 't) 586 | 't)) 587 | ((A E A A A 1 Q) (equal-if (ctx? (sub x (car y))) 't)) 588 | ((A E A A A 1) (if-true 't (ctx? (sub x (cdr y))))) 589 | ((A E A A A) (equal-same 't)) 590 | ((A E A A) (if-same (if (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't) 't)) 591 | ((A E A) (if-same (equal (ctx? (sub x (car y))) 't) 't)) 592 | ((A E E) 593 | (if-same (ctx? (cdr y)) 594 | (if (if (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't) 595 | (if (ctx? (cdr y)) 596 | (equal (if (ctx? (sub x (car y))) 't (ctx? (sub x (cdr y)))) 't) 597 | 't) 598 | 't))) 599 | ((A E E A Q) (if-nest-A (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't)) 600 | ((A E E A A) 601 | (if-nest-A (ctx? (cdr y)) 602 | (equal (if (ctx? (sub x (car y))) 't (ctx? (sub x (cdr y)))) 't) 603 | 't)) 604 | ((A E E E Q) (if-nest-E (ctx? (cdr y)) (equal (ctx? (sub x (cdr y))) 't) 't)) 605 | ((A E E E A) 606 | (if-nest-E (ctx? (cdr y)) 607 | (equal (if (ctx? (sub x (car y))) 't (ctx? (sub x (cdr y)))) 't) 608 | 't)) 609 | ((A E E E) (if-same 't 't)) 610 | ((A E E A A 1 E) (equal-if (ctx? (sub x (cdr y))) 't)) 611 | ((A E E A A 1) (if-same (ctx? (sub x (car y))) 't)) 612 | ((A E E A A) (equal-same 't)) 613 | ((A E E A) (if-same (equal (ctx? (sub x (cdr y))) 't) 't)) 614 | ((A E E) (if-same (ctx? (cdr y)) 't)) 615 | ((A E) (if-same (ctx? (car y)) 't)) 616 | ((A) (if-same (atom y) 't)) 617 | (() (if-same (ctx? x) 't)))))) 618 | 619 | ;; Chapter 8 620 | 621 | (defun defun.member? () 622 | (J-Bob/define (dethm.ctx?/sub) 623 | '(((defun member? (x ys) 624 | (if (atom ys) 'nil (if (equal x (car ys)) 't (member? x (cdr ys))))) 625 | (size ys) 626 | ((Q) (natp/size ys)) 627 | (() 628 | (if-true 629 | (if (atom ys) 't (if (equal x (car ys)) 't (< (size (cdr ys)) (size ys)))) 630 | 'nil)) 631 | ((E E) (size/cdr ys)) 632 | ((E) (if-same (equal x (car ys)) 't)) 633 | (() (if-same (atom ys) 't)))))) 634 | 635 | (defun defun.set? () 636 | (J-Bob/define (defun.member?) 637 | '(((defun set? (xs) 638 | (if (atom xs) 't (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))))) 639 | (size xs) 640 | ((Q) (natp/size xs)) 641 | (() 642 | (if-true 643 | (if (atom xs) 644 | 't 645 | (if (member? (car xs) (cdr xs)) 't (< (size (cdr xs)) (size xs)))) 646 | 'nil)) 647 | ((E E) (size/cdr xs)) 648 | ((E) (if-same (member? (car xs) (cdr xs)) 't)) 649 | (() (if-same (atom xs) 't)))))) 650 | 651 | (defun defun.add-atoms () 652 | (J-Bob/define (defun.set?) 653 | '(((defun add-atoms (x ys) 654 | (if (atom x) 655 | (if (member? x ys) ys (cons x ys)) 656 | (add-atoms (car x) (add-atoms (cdr x) ys)))) 657 | (size x) 658 | ((Q) (natp/size x)) 659 | (() 660 | (if-true 661 | (if (atom x) 662 | 't 663 | (if (< (size (car x)) (size x)) (< (size (cdr x)) (size x)) 'nil)) 664 | 'nil)) 665 | ((E Q) (size/car x)) 666 | ((E A) (size/cdr x)) 667 | ((E) (if-true 't 'nil)) 668 | (() (if-same (atom x) 't)))))) 669 | 670 | (defun defun.atoms () 671 | (J-Bob/define (defun.add-atoms) 672 | '(((defun atoms (x) 673 | (add-atoms x '())) 674 | nil)))) 675 | 676 | (defun dethm.set?/atoms.attempt () 677 | (J-Bob/prove (defun.atoms) 678 | '(((dethm set?/add-atoms (a) 679 | (equal (set? (add-atoms a '())) 't)) 680 | (star-induction a) 681 | ((E A A 1 1) (add-atoms a '()))) 682 | ((dethm set?/atoms (a) 683 | (equal (set? (atoms a)) 't)) 684 | nil 685 | ((1 1) (atoms a)) 686 | ((1) (set?/add-atoms a)) 687 | (() (equal-same 't)))))) 688 | 689 | (defun dethm.set?/atoms () 690 | (J-Bob/define (defun.atoms) 691 | '(((dethm set?/t (xs) 692 | (if (set? xs) (equal (set? xs) 't) 't)) 693 | (list-induction xs) 694 | ((A A 1) (set? xs)) 695 | ((A A 1) 696 | (if-nest-A (atom xs) 't (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))))) 697 | ((A A) (equal-same 't)) 698 | ((A) (if-same (set? xs) 't)) 699 | ((E A A 1) (set? xs)) 700 | ((E A A 1) 701 | (if-nest-E (atom xs) 't (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))))) 702 | ((E A Q) (set? xs)) 703 | ((E A Q) 704 | (if-nest-E (atom xs) 't (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))))) 705 | ((E A) 706 | (if-same (member? (car xs) (cdr xs)) 707 | (if (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))) 708 | (equal (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))) 't) 709 | 't))) 710 | ((E A A Q) (if-nest-A (member? (car xs) (cdr xs)) 'nil (set? (cdr xs)))) 711 | ((E A A A 1) (if-nest-A (member? (car xs) (cdr xs)) 'nil (set? (cdr xs)))) 712 | ((E A E Q) (if-nest-E (member? (car xs) (cdr xs)) 'nil (set? (cdr xs)))) 713 | ((E A E A 1) (if-nest-E (member? (car xs) (cdr xs)) 'nil (set? (cdr xs)))) 714 | ((E A A) (if-false (equal 'nil 't) 't)) 715 | ((E) 716 | (if-same (set? (cdr xs)) 717 | (if (if (set? (cdr xs)) (equal (set? (cdr xs)) 't) 't) 718 | (if (member? (car xs) (cdr xs)) 719 | 't 720 | (if (set? (cdr xs)) (equal (set? (cdr xs)) 't) 't)) 721 | 't))) 722 | ((E A Q) (if-nest-A (set? (cdr xs)) (equal (set? (cdr xs)) 't) 't)) 723 | ((E A A E) (if-nest-A (set? (cdr xs)) (equal (set? (cdr xs)) 't) 't)) 724 | ((E E Q) (if-nest-E (set? (cdr xs)) (equal (set? (cdr xs)) 't) 't)) 725 | ((E E A E) (if-nest-E (set? (cdr xs)) (equal (set? (cdr xs)) 't) 't)) 726 | ((E E A) (if-same (member? (car xs) (cdr xs)) 't)) 727 | ((E E) (if-same 't 't)) 728 | ((E A A E 1) (equal-if (set? (cdr xs)) 't)) 729 | ((E A A E) (equal-same 't)) 730 | ((E A A) (if-same (member? (car xs) (cdr xs)) 't)) 731 | ((E A) (if-same (equal (set? (cdr xs)) 't) 't)) 732 | ((E) (if-same (set? (cdr xs)) 't)) 733 | (() (if-same (atom xs) 't))) 734 | ((dethm set?/nil (xs) 735 | (if (set? xs) 't (equal (set? xs) 'nil))) 736 | (list-induction xs) 737 | ((A Q) (set? xs)) 738 | ((A Q) 739 | (if-nest-A (atom xs) 't (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))))) 740 | ((A) (if-true 't (equal (set? xs) 'nil))) 741 | ((E A E 1) (set? xs)) 742 | ((E A E 1) 743 | (if-nest-E (atom xs) 't (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))))) 744 | ((E A Q) (set? xs)) 745 | ((E A Q) 746 | (if-nest-E (atom xs) 't (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))))) 747 | ((E A) 748 | (if-same (member? (car xs) (cdr xs)) 749 | (if (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))) 750 | 't 751 | (equal (if (member? (car xs) (cdr xs)) 'nil (set? (cdr xs))) 'nil)))) 752 | ((E A A Q) (if-nest-A (member? (car xs) (cdr xs)) 'nil (set? (cdr xs)))) 753 | ((E A A E 1) (if-nest-A (member? (car xs) (cdr xs)) 'nil (set? (cdr xs)))) 754 | ((E A E Q) (if-nest-E (member? (car xs) (cdr xs)) 'nil (set? (cdr xs)))) 755 | ((E A E E 1) (if-nest-E (member? (car xs) (cdr xs)) 'nil (set? (cdr xs)))) 756 | ((E A A E) (equal-same 'nil)) 757 | ((E A A) (if-same 'nil 't)) 758 | ((E) 759 | (if-same (set? (cdr xs)) 760 | (if (if (set? (cdr xs)) 't (equal (set? (cdr xs)) 'nil)) 761 | (if (member? (car xs) (cdr xs)) 762 | 't 763 | (if (set? (cdr xs)) 't (equal (set? (cdr xs)) 'nil))) 764 | 't))) 765 | ((E A Q) (if-nest-A (set? (cdr xs)) 't (equal (set? (cdr xs)) 'nil))) 766 | ((E A A E) (if-nest-A (set? (cdr xs)) 't (equal (set? (cdr xs)) 'nil))) 767 | ((E E Q) (if-nest-E (set? (cdr xs)) 't (equal (set? (cdr xs)) 'nil))) 768 | ((E E A E) (if-nest-E (set? (cdr xs)) 't (equal (set? (cdr xs)) 'nil))) 769 | ((E A A) (if-same (member? (car xs) (cdr xs)) 't)) 770 | ((E A) (if-same 't 't)) 771 | ((E E A E 1) (equal-if (set? (cdr xs)) 'nil)) 772 | ((E E A E) (equal-same 'nil)) 773 | ((E E A) (if-same (member? (car xs) (cdr xs)) 't)) 774 | ((E E) (if-same (equal (set? (cdr xs)) 'nil) 't)) 775 | ((E) (if-same (set? (cdr xs)) 't)) 776 | (() (if-same (atom xs) 't))) 777 | ((dethm set?/add-atoms (a bs) 778 | (if (set? bs) (equal (set? (add-atoms a bs)) 't) 't)) 779 | (add-atoms a bs) 780 | ((A A 1 1) (add-atoms a bs)) 781 | ((A A 1 1) 782 | (if-nest-A (atom a) 783 | (if (member? a bs) bs (cons a bs)) 784 | (add-atoms (car a) (add-atoms (cdr a) bs)))) 785 | ((A A 1) (if-same (member? a bs) (set? (if (member? a bs) bs (cons a bs))))) 786 | ((A A 1 A 1) (if-nest-A (member? a bs) bs (cons a bs))) 787 | ((A A 1 E 1) (if-nest-E (member? a bs) bs (cons a bs))) 788 | ((A A 1 A) (set?/t bs)) 789 | ((A A 1 E) (set? (cons a bs))) 790 | ((A A 1 E Q) (atom/cons a bs)) 791 | ((A A 1 E E Q 1) (car/cons a bs)) 792 | ((A A 1 E E Q 2) (cdr/cons a bs)) 793 | ((A A 1 E E E 1) (cdr/cons a bs)) 794 | ((A A 1 E) (if-false 't (if (member? a bs) 'nil (set? bs)))) 795 | ((A A 1 E) (if-nest-E (member? a bs) 'nil (set? bs))) 796 | ((A A 1 E) (set?/t bs)) 797 | ((A A 1) (if-same (member? a bs) 't)) 798 | ((A A) (equal-same 't)) 799 | ((A) (if-same (set? bs) 't)) 800 | ((E) 801 | (if-same (set? bs) 802 | (if (if (set? (add-atoms (cdr a) bs)) 803 | (equal (set? (add-atoms (car a) (add-atoms (cdr a) bs))) 't) 804 | 't) 805 | (if (if (set? bs) (equal (set? (add-atoms (cdr a) bs)) 't) 't) 806 | (if (set? bs) (equal (set? (add-atoms a bs)) 't) 't) 807 | 't) 808 | 't))) 809 | ((E A A Q) (if-nest-A (set? bs) (equal (set? (add-atoms (cdr a) bs)) 't) 't)) 810 | ((E A A A) (if-nest-A (set? bs) (equal (set? (add-atoms a bs)) 't) 't)) 811 | ((E E A Q) (if-nest-E (set? bs) (equal (set? (add-atoms (cdr a) bs)) 't) 't)) 812 | ((E E A A) (if-nest-E (set? bs) (equal (set? (add-atoms a bs)) 't) 't)) 813 | ((E E A) (if-same 't 't)) 814 | ((E E) 815 | (if-same 816 | (if (set? (add-atoms (cdr a) bs)) 817 | (equal (set? (add-atoms (car a) (add-atoms (cdr a) bs))) 't) 818 | 't) 819 | 't)) 820 | ((E A) 821 | (if-same (set? (add-atoms (cdr a) bs)) 822 | (if (if (set? (add-atoms (cdr a) bs)) 823 | (equal (set? (add-atoms (car a) (add-atoms (cdr a) bs))) 't) 824 | 't) 825 | (if (equal (set? (add-atoms (cdr a) bs)) 't) 826 | (equal (set? (add-atoms a bs)) 't) 827 | 't) 828 | 't))) 829 | ((E A A Q) 830 | (if-nest-A (set? (add-atoms (cdr a) bs)) 831 | (equal (set? (add-atoms (car a) (add-atoms (cdr a) bs))) 't) 832 | 't)) 833 | ((E A E Q) 834 | (if-nest-E (set? (add-atoms (cdr a) bs)) 835 | (equal (set? (add-atoms (car a) (add-atoms (cdr a) bs))) 't) 836 | 't)) 837 | ((E A E) 838 | (if-true 839 | (if (equal (set? (add-atoms (cdr a) bs)) 't) 840 | (equal (set? (add-atoms a bs)) 't) 841 | 't) 842 | 't)) 843 | ((E A A A Q 1) (set?/t (add-atoms (cdr a) bs))) 844 | ((E A E Q 1) (set?/nil (add-atoms (cdr a) bs))) 845 | ((E A A A Q) (equal 't 't)) 846 | ((E A E Q) (equal 'nil 't)) 847 | ((E A A A) (if-true (equal (set? (add-atoms a bs)) 't) 't)) 848 | ((E A E) (if-false (equal (set? (add-atoms a bs)) 't) 't)) 849 | ((E A A A 1 1) (add-atoms a bs)) 850 | ((E A A A 1 1) 851 | (if-nest-E (atom a) 852 | (if (member? a bs) bs (cons a bs)) 853 | (add-atoms (car a) (add-atoms (cdr a) bs)))) 854 | ((E A A A 1) (equal-if (set? (add-atoms (car a) (add-atoms (cdr a) bs))) 't)) 855 | ((E A A A) (equal-same 't)) 856 | ((E A A) 857 | (if-same (equal (set? (add-atoms (car a) (add-atoms (cdr a) bs))) 't) 't)) 858 | ((E A) (if-same (set? (add-atoms (cdr a) bs)) 't)) 859 | ((E) (if-same (set? bs) 't)) 860 | (() (if-same (atom a) 't))) 861 | ((dethm set?/atoms (a) 862 | (equal (set? (atoms a)) 't)) 863 | nil 864 | ((1 1) (atoms a)) 865 | (() (if-true (equal (set? (add-atoms a '())) 't) 't)) 866 | ((Q) (if-true 't (if (member? (car '()) (cdr '())) 'nil (set? (cdr '()))))) 867 | ((Q Q) (atom '())) 868 | ((Q) (set? '())) 869 | ((A 1) (set?/add-atoms a '())) 870 | ((A) (equal-same 't)) 871 | (() (if-same (set? '()) 't)))))) 872 | 873 | ;; Chapter 9 874 | 875 | (defun defun.rotate () 876 | (J-Bob/define (dethm.set?/atoms) 877 | '(((defun rotate (x) 878 | (cons (car (car x)) (cons (cdr (car x)) (cdr x)))) 879 | nil)))) 880 | 881 | (defun dethm.rotate/cons () 882 | (J-Bob/define (defun.rotate) 883 | '(((dethm rotate/cons (x y z) 884 | (equal (rotate (cons (cons x y) z)) (cons x (cons y z)))) 885 | nil 886 | ((1) (rotate (cons (cons x y) z))) 887 | ((1 1 1) (car/cons (cons x y) z)) 888 | ((1 1) (car/cons x y)) 889 | ((1 2 1 1) (car/cons (cons x y) z)) 890 | ((1 2 1) (cdr/cons x y)) 891 | ((1 2 2) (cdr/cons (cons x y) z)) 892 | (() (equal-same (cons x (cons y z)))))))) 893 | 894 | (defun defun.align.attempt () 895 | (J-Bob/prove (dethm.rotate/cons) 896 | '(((defun align (x) 897 | (if (atom x) 898 | x 899 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 900 | (size x) 901 | ((Q) (natp/size x)) 902 | (() 903 | (if-true 904 | (if (atom x) 905 | 't 906 | (if (atom (car x)) 907 | (< (size (cdr x)) (size x)) 908 | (< (size (rotate x)) (size x)))) 909 | 'nil)) 910 | ((E A) (size/cdr x)) 911 | ((E E 1 1 1) (cons/car+cdr x)) 912 | ((E E 2 1) (cons/car+cdr x)) 913 | ((E E 1 1 1 1) (cons/car+cdr (car x))) 914 | ((E E 2 1 1) (cons/car+cdr (car x))) 915 | ((E E 1 1) (rotate/cons (car (car x)) (cdr (car x)) (cdr x))))))) 916 | 917 | (defun defun.wt () 918 | (J-Bob/define (dethm.rotate/cons) 919 | '(((defun wt (x) 920 | (if (atom x) '1 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x))))) 921 | (size x) 922 | ((Q) (natp/size x)) 923 | (() 924 | (if-true 925 | (if (atom x) 926 | 't 927 | (if (< (size (car x)) (size x)) (< (size (cdr x)) (size x)) 'nil)) 928 | 'nil)) 929 | ((E Q) (size/car x)) 930 | ((E A) (size/cdr x)) 931 | ((E) (if-true 't 'nil)) 932 | (() (if-same (atom x) 't)))))) 933 | 934 | (defun defun.align () 935 | (J-Bob/define (defun.wt) 936 | '(((dethm natp/wt (x) 937 | (equal (natp (wt x)) 't)) 938 | (star-induction x) 939 | ((A 1 1) (wt x)) 940 | ((A 1 1) (if-nest-A (atom x) '1 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x))))) 941 | ((A 1) (natp '1)) 942 | ((A) (equal-same 't)) 943 | ((E A A 1 1) (wt x)) 944 | ((E A A 1 1) 945 | (if-nest-E (atom x) '1 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x))))) 946 | ((E A A) 947 | (if-true (equal (natp (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x)))) 't) 't)) 948 | ((E A A Q) (equal-if (natp (wt (car x))) 't)) 949 | ((E A A A) 950 | (if-true (equal (natp (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x)))) 't) 't)) 951 | ((E A A A Q) (natp/+ (wt (car x)) (wt (car x)))) 952 | ((E A A Q) (equal-if (natp (wt (car x))) 't)) 953 | ((E A A Q) (equal-if (natp (wt (cdr x))) 't)) 954 | ((E A A A A 1) (natp/+ (+ (wt (car x)) (wt (car x))) (wt (cdr x)))) 955 | ((E A A A A) (equal-same 't)) 956 | ((E A A A) (if-same (natp (+ (wt (car x)) (wt (car x)))) 't)) 957 | ((E A A) (if-same (natp (wt (cdr x))) 't)) 958 | ((E A) (if-same (equal (natp (wt (cdr x))) 't) 't)) 959 | ((E) (if-same (equal (natp (wt (car x))) 't) 't)) 960 | (() (if-same (atom x) 't))) 961 | ((dethm positive/wt (x) 962 | (equal (< '0 (wt x)) 't)) 963 | (star-induction x) 964 | ((A 1 2) (wt x)) 965 | ((A 1 2) (if-nest-A (atom x) '1 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x))))) 966 | ((A 1) (< '0 '1)) 967 | ((A) (equal-same 't)) 968 | ((E A A 1 2) (wt x)) 969 | ((E A A 1 2) 970 | (if-nest-E (atom x) '1 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x))))) 971 | ((E A A) 972 | (if-true (equal (< '0 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x)))) 't) 't)) 973 | ((E A A Q) (equal-if (< '0 (wt (car x))) 't)) 974 | ((E A A A) 975 | (if-true (equal (< '0 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x)))) 't) 't)) 976 | ((E A A A Q) (positives-+ (wt (car x)) (wt (car x)))) 977 | ((E A A Q) (equal-if (< '0 (wt (car x))) 't)) 978 | ((E A A Q) (equal-if (< '0 (wt (cdr x))) 't)) 979 | ((E A A A A 1) (positives-+ (+ (wt (car x)) (wt (car x))) (wt (cdr x)))) 980 | ((E A A A A) (equal-same 't)) 981 | ((E A A A) (if-same (< '0 (+ (wt (car x)) (wt (car x)))) 't)) 982 | ((E A A) (if-same (< '0 (wt (cdr x))) 't)) 983 | ((E A) (if-same (equal (< '0 (wt (cdr x))) 't) 't)) 984 | ((E) (if-same (equal (< '0 (wt (car x))) 't) 't)) 985 | (() (if-same (atom x) 't))) 986 | ((defun align (x) 987 | (if (atom x) 988 | x 989 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 990 | (wt x) 991 | ((Q) (natp/wt x)) 992 | (() 993 | (if-true 994 | (if (atom x) 995 | 't 996 | (if (atom (car x)) (< (wt (cdr x)) (wt x)) (< (wt (rotate x)) (wt x)))) 997 | 'nil)) 998 | ((E A 2) (wt x)) 999 | ((E A 2) (if-nest-E (atom x) '1 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x))))) 1000 | ((E A) 1001 | (if-true (< (wt (cdr x)) (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x)))) 't)) 1002 | ((E A Q) (natp/wt (cdr x))) 1003 | ((E A A 1) (identity-+ (wt (cdr x)))) 1004 | ((E A A) (common-addends-< '0 (+ (wt (car x)) (wt (car x))) (wt (cdr x)))) 1005 | ((E A Q) (natp/wt (cdr x))) 1006 | ((E A Q) (positive/wt (car x))) 1007 | ((E A A) (positives-+ (wt (car x)) (wt (car x)))) 1008 | ((E A) (if-same (< '0 (wt (car x))) 't)) 1009 | ((E E 1 1) (rotate x)) 1010 | ((E E 1) (wt (cons (car (car x)) (cons (cdr (car x)) (cdr x))))) 1011 | ((E E 1 Q) (atom/cons (car (car x)) (cons (cdr (car x)) (cdr x)))) 1012 | ((E E 1) 1013 | (if-false '1 1014 | (+ (+ (wt (car (cons (car (car x)) (cons (cdr (car x)) (cdr x))))) 1015 | (wt (car (cons (car (car x)) (cons (cdr (car x)) (cdr x)))))) 1016 | (wt (cdr (cons (car (car x)) (cons (cdr (car x)) (cdr x)))))))) 1017 | ((E E 1 1 1 1) (car/cons (car (car x)) (cons (cdr (car x)) (cdr x)))) 1018 | ((E E 1 1 2 1) (car/cons (car (car x)) (cons (cdr (car x)) (cdr x)))) 1019 | ((E E 1 2 1) (cdr/cons (car (car x)) (cons (cdr (car x)) (cdr x)))) 1020 | ((E E 1 2) (wt (cons (cdr (car x)) (cdr x)))) 1021 | ((E E 1 2 Q) (atom/cons (cdr (car x)) (cdr x))) 1022 | ((E E 1 2) 1023 | (if-false '1 1024 | (+ (+ (wt (car (cons (cdr (car x)) (cdr x)))) 1025 | (wt (car (cons (cdr (car x)) (cdr x))))) 1026 | (wt (cdr (cons (cdr (car x)) (cdr x))))))) 1027 | ((E E 1 2 1 1 1) (car/cons (cdr (car x)) (cdr x))) 1028 | ((E E 1 2 1 2 1) (car/cons (cdr (car x)) (cdr x))) 1029 | ((E E 1 2 2 1) (cdr/cons (cdr (car x)) (cdr x))) 1030 | ((E E 2) (wt x)) 1031 | ((E E 2) (if-nest-E (atom x) '1 (+ (+ (wt (car x)) (wt (car x))) (wt (cdr x))))) 1032 | ((E E 2 1 1) (wt (car x))) 1033 | ((E E 2 1 1) 1034 | (if-nest-E (atom (car x)) 1035 | '1 1036 | (+ (+ (wt (car (car x))) (wt (car (car x)))) (wt (cdr (car x)))))) 1037 | ((E E 2 1 2) (wt (car x))) 1038 | ((E E 2 1 2) 1039 | (if-nest-E (atom (car x)) 1040 | '1 1041 | (+ (+ (wt (car (car x))) (wt (car (car x)))) (wt (cdr (car x)))))) 1042 | ((E E 1) 1043 | (associate-+ 1044 | (+ (wt (car (car x))) (wt (car (car x)))) 1045 | (+ (wt (cdr (car x))) (wt (cdr (car x)))) 1046 | (wt (cdr x)))) 1047 | ((E E) 1048 | (common-addends-< 1049 | (+ (+ (wt (car (car x))) (wt (car (car x)))) 1050 | (+ (wt (cdr (car x))) (wt (cdr (car x))))) 1051 | (+ (+ (+ (wt (car (car x))) (wt (car (car x)))) (wt (cdr (car x)))) 1052 | (+ (+ (wt (car (car x))) (wt (car (car x)))) (wt (cdr (car x))))) 1053 | (wt (cdr x)))) 1054 | ((E E 1) 1055 | (associate-+ 1056 | (+ (wt (car (car x))) (wt (car (car x)))) 1057 | (wt (cdr (car x))) 1058 | (wt (cdr (car x))))) 1059 | ((E E 1) 1060 | (commute-+ 1061 | (+ (+ (wt (car (car x))) (wt (car (car x)))) (wt (cdr (car x)))) 1062 | (wt (cdr (car x))))) 1063 | ((E E) 1064 | (common-addends-< 1065 | (wt (cdr (car x))) 1066 | (+ (+ (wt (car (car x))) (wt (car (car x)))) (wt (cdr (car x)))) 1067 | (+ (+ (wt (car (car x))) (wt (car (car x)))) (wt (cdr (car x)))))) 1068 | ((E E) 1069 | (if-true 1070 | (< (wt (cdr (car x))) 1071 | (+ (+ (wt (car (car x))) (wt (car (car x)))) (wt (cdr (car x))))) 1072 | 't)) 1073 | ((E E Q) (natp/wt (cdr (car x)))) 1074 | ((E E A 1) (identity-+ (wt (cdr (car x))))) 1075 | ((E E A) 1076 | (common-addends-< 1077 | '0 1078 | (+ (wt (car (car x))) (wt (car (car x)))) 1079 | (wt (cdr (car x))))) 1080 | ((E E Q) (natp/wt (cdr (car x)))) 1081 | ((E E Q) (positive/wt (car (car x)))) 1082 | ((E E A) (positives-+ (wt (car (car x))) (wt (car (car x))))) 1083 | ((E E) (if-same (< '0 (wt (car (car x)))) 't)) 1084 | ((E) (if-same (atom (car x)) 't)) 1085 | (() (if-same (atom x) 't)))))) 1086 | 1087 | (defun dethm.align/align () 1088 | (J-Bob/define (defun.align) 1089 | '(((dethm align/align (x) 1090 | (equal (align (align x)) (align x))) 1091 | (align x) 1092 | ((A 1 1) (align x)) 1093 | ((A 1 1) 1094 | (if-nest-A (atom x) 1095 | x 1096 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 1097 | ((A 2) (align x)) 1098 | ((A 2) 1099 | (if-nest-A (atom x) 1100 | x 1101 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 1102 | ((A 1) (align x)) 1103 | ((A 1) 1104 | (if-nest-A (atom x) 1105 | x 1106 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 1107 | ((A) (equal-same x)) 1108 | ((E A A 1 1) (align x)) 1109 | ((E A A 1 1) 1110 | (if-nest-E (atom x) 1111 | x 1112 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 1113 | ((E A A 1 1) 1114 | (if-nest-A (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x)))) 1115 | ((E A A 2) (align x)) 1116 | ((E A A 2) 1117 | (if-nest-E (atom x) 1118 | x 1119 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 1120 | ((E A A 2) 1121 | (if-nest-A (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x)))) 1122 | ((E A A 1) (align (cons (car x) (align (cdr x))))) 1123 | ((E A A 1 Q) (atom/cons (car x) (align (cdr x)))) 1124 | ((E A A 1 E Q 1) (car/cons (car x) (align (cdr x)))) 1125 | ((E A A 1 E A 1) (car/cons (car x) (align (cdr x)))) 1126 | ((E A A 1 E A 2 1) (cdr/cons (car x) (align (cdr x)))) 1127 | ((E A A 1) 1128 | (if-false (cons (car x) (align (cdr x))) 1129 | (if (atom (car x)) 1130 | (cons (car x) (align (align (cdr x)))) 1131 | (align (rotate (cons (car x) (align (cdr x)))))))) 1132 | ((E A A 1) 1133 | (if-nest-A (atom (car x)) 1134 | (cons (car x) (align (align (cdr x)))) 1135 | (align (rotate (cons (car x) (align (cdr x))))))) 1136 | ((E A A 1 2) (equal-if (align (align (cdr x))) (align (cdr x)))) 1137 | ((E A A) (equal-same (cons (car x) (align (cdr x))))) 1138 | ((E A) (if-same (equal (align (align (cdr x))) (align (cdr x))) 't)) 1139 | ((E E A 1 1) (align x)) 1140 | ((E E A 1 1) 1141 | (if-nest-E (atom x) 1142 | x 1143 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 1144 | ((E E A 1 1) 1145 | (if-nest-E (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x)))) 1146 | ((E E A 2) (align x)) 1147 | ((E E A 2) 1148 | (if-nest-E (atom x) 1149 | x 1150 | (if (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x))))) 1151 | ((E E A 2) 1152 | (if-nest-E (atom (car x)) (cons (car x) (align (cdr x))) (align (rotate x)))) 1153 | ((E E A 1) (equal-if (align (align (rotate x))) (align (rotate x)))) 1154 | ((E E A) (equal-same (align (rotate x)))) 1155 | ((E E) (if-same (equal (align (align (rotate x))) (align (rotate x))) 't)) 1156 | ((E) (if-same (atom (car x)) 't)) 1157 | (() (if-same (atom x) 't)))))) 1158 | --------------------------------------------------------------------------------