#| Copyright (C) 1994 by Computational Logic, Inc. All Rights Reserved. This script is hereby placed in the public domain, and therefore unlimited editing and redistribution is permitted. NO WARRANTY Computational Logic, Inc. PROVIDES ABSOLUTELY NO WARRANTY. THE EVENT SCRIPT IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, ANY IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SCRIPT IS WITH YOU. SHOULD THE SCRIPT PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. IN NO EVENT WILL Computational Logic, Inc. BE LIABLE TO YOU FOR ANY DAMAGES, ANY LOST PROFITS, LOST MONIES, OR OTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THIS SCRIPT (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES), EVEN IF YOU HAVE ADVISED US OF THE POSSIBILITY OF SUCH DAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. |# ; ------------------------------------------------------------ ; was bags.events ; ------------------------------------------------------------ (boot-strap nqthm) (DEFN DELETE (X L) (IF (LISTP L) (IF (EQUAL X (CAR L)) (CDR L) (CONS (CAR L) (DELETE X (CDR L)))) L)) (DEFN BAGDIFF (X Y) (IF (LISTP Y) (IF (MEMBER (CAR Y) X) (BAGDIFF (DELETE (CAR Y) X) (CDR Y)) (BAGDIFF X (CDR Y))) X)) (DEFN BAGINT (X Y) (IF (LISTP X) (IF (MEMBER (CAR X) Y) (CONS (CAR X) (BAGINT (CDR X) (DELETE (CAR X) Y))) (BAGINT (CDR X) Y)) NIL)) (DEFN OCCURRENCES (X L) (IF (LISTP L) (IF (EQUAL X (CAR L)) (ADD1 (OCCURRENCES X (CDR L))) (OCCURRENCES X (CDR L))) 0)) (DEFN SUBBAGP (X Y) (IF (LISTP X) (IF (MEMBER (CAR X) Y) (SUBBAGP (CDR X) (DELETE (CAR X) Y)) F) T)) (LEMMA LISTP-DELETE (REWRITE) (EQUAL (LISTP (DELETE X L)) (IF (LISTP L) (OR (NOT (EQUAL X (CAR L))) (LISTP (CDR L))) F)) ((ENABLE DELETE) (INDUCT (DELETE X L)))) (disable listp-delete) (LEMMA DELETE-NON-MEMBER (REWRITE) (IMPLIES (NOT (MEMBER X Y)) (EQUAL (DELETE X Y) Y)) ((ENABLE DELETE))) (LEMMA DELETE-DELETE (REWRITE) (EQUAL (DELETE Y (DELETE X Z)) (DELETE X (DELETE Y Z))) ((ENABLE DELETE DELETE-NON-MEMBER))) (lemma equal-occurrences-zero (rewrite) (equal (equal (occurrences x l) 0) (not (member x l))) ((enable occurrences))) (LEMMA MEMBER-NON-LIST (REWRITE) (IMPLIES (NOT (LISTP L)) (NOT (MEMBER X L)))) (lemma member-delete (rewrite) (equal (member x (delete y l)) (if (member x l) (if (equal x y) (lessp 1 (occurrences x l)) t) f)) ((enable delete occurrences))) (LEMMA MEMBER-DELETE-IMPLIES-MEMBERSHIP (REWRITE) (IMPLIES (MEMBER X (DELETE Y L)) (MEMBER X L)) ((ENABLE DELETE))) (LEMMA OCCURRENCES-DELETE (REWRITE) (EQUAL (OCCURRENCES X (DELETE Y L)) (IF (EQUAL X Y) (IF (MEMBER X L) (SUB1 (OCCURRENCES X L)) 0) (OCCURRENCES X L))) ((ENABLE OCCURRENCES DELETE EQUAL-OCCURRENCES-ZERO))) (LEMMA MEMBER-BAGDIFF (REWRITE) (EQUAL (MEMBER X (BAGDIFF A B)) (LESSP (OCCURRENCES X B) (OCCURRENCES X A))) ((ENABLE BAGDIFF OCCURRENCES EQUAL-OCCURRENCES-ZERO OCCURRENCES-DELETE))) (lemma bagdiff-delete (rewrite) (equal (bagdiff (delete e x) y) (delete e (bagdiff x y))) ((enable BAGDIFF DELETE DELETE-DELETE DELETE-NON-MEMBER MEMBER-BAGDIFF MEMBER-DELETE OCCURRENCES-DELETE))) (LEMMA SUBBAGP-DELETE (REWRITE) (IMPLIES (SUBBAGP X (DELETE U Y)) (SUBBAGP X Y)) ((ENABLE DELETE SUBBAGP DELETE-DELETE MEMBER-DELETE-IMPLIES-MEMBERSHIP))) (LEMMA SUBBAGP-CDR1 (REWRITE) (IMPLIES (SUBBAGP X Y) (SUBBAGP (CDR X) Y)) ((ENABLE SUBBAGP SUBBAGP-DELETE))) (LEMMA SUBBAGP-CDR2 (REWRITE) (IMPLIES (SUBBAGP X (CDR Y)) (SUBBAGP X Y)) ((ENABLE DELETE SUBBAGP DELETE-NON-MEMBER SUBBAGP-CDR1))) (LEMMA SUBBAGP-BAGINT1 (REWRITE) (SUBBAGP (BAGINT X Y) X) ((ENABLE DELETE SUBBAGP BAGINT SUBBAGP-CDR2))) (LEMMA SUBBAGP-BAGINT2 (REWRITE) (SUBBAGP (BAGINT X Y) Y) ((ENABLE SUBBAGP BAGINT SUBBAGP-CDR2))) (prove-lemma occurrences-bagint (rewrite) (equal (occurrences x (bagint a b)) (if (lessp (occurrences x a) (occurrences x b)) (occurrences x a) (occurrences x b))) ((enable occurrences bagint equal-occurrences-zero occurrences-delete))) (prove-lemma occurrences-bagdiff (rewrite) (equal (occurrences x (bagdiff a b)) (difference (occurrences x a) (occurrences x b))) ((enable occurrences bagdiff equal-occurrences-zero occurrences-delete))) (prove-lemma member-bagint (rewrite) (equal (member x (bagint a b)) (and (member x a) (member x b))) ((enable bagint member-delete))) (deftheory bags (occurrences-bagint bagdiff-delete occurrences-bagdiff member-bagint member-bagdiff subbagp-bagint2 subbagp-bagint1 subbagp-cdr2 subbagp-cdr1 subbagp-delete)) ; ------------------------------------------------------------ ; was naturals.events ; ------------------------------------------------------------ ;; Tue Sep 26 10:20:45 1989, from ~wilding/numerical/newnat.events ;; NATURALS Theory ;; Created by Bill Bevier 1988 (see CLI internal note 057) ;; Modifications by Bill Bevier and Matt Wilding (9/89) including ;; adding some new metalemmas for times, reorganizing the theories, ;; removing some extraneous lemmas, and removing dependence upon ;; other theories (by adding the pertinent lemmas). ;; This script requires the bags theory ;; This script sets up a theory for the NATURALS with the following subtheories ;; ADDITION ;; MULTIPLICATION ;; REMAINDER ;; QUOTIENT ;; EXPONENTIATION ;; LOGS ;; GCDS ;; The theories of EXPONENTIATION, LOGS, and GCDS still need a lot of work ; -------------------------------------------------------------------------------- ; ARITHMETIC ; -------------------------------------------------------------------------------- ; -------------------- PLUS & DIFFERENCE -------------------- ; ---------- EQUAL ---------- (lemma equal-plus-0 (rewrite) (equal (equal (plus a b) 0) (and (zerop a) (zerop b)))) (lemma plus-cancellation (rewrite) (equal (equal (plus a b) (plus a c)) (equal (fix b) (fix c)))) (disable plus-cancellation) (lemma equal-difference-0 (rewrite) (and (equal (equal (difference x y) 0) (not (lessp y x))) (equal (equal 0 (difference x y)) (not (lessp y x)))) ((induct (difference x y)))) (lemma difference-cancellation (rewrite) (equal (equal (difference x y) (difference z y)) (if (lessp x y) (not (lessp y z)) (if (lessp z y) (not (lessp y x)) (equal (fix x) (fix z))))) ((enable equal-difference-0))) (disable difference-cancellation) ; ---------- PLUS ---------- (lemma commutativity-of-plus (rewrite) (equal (plus x y) (plus y x))) (lemma commutativity2-of-plus (rewrite) (equal (plus x (plus y z)) (plus y (plus x z)))) (lemma plus-zero-arg2 (rewrite) (implies (zerop y) (equal (plus x y) (fix x))) ((induct (plus x y)))) (lemma plus-add1-arg1 (rewrite) (equal (plus (add1 a) b) (add1 (plus a b)))) (lemma plus-add1-arg2 (rewrite) (equal (plus x (add1 y)) (if (numberp y) (add1 (plus x y)) (add1 x)))) (lemma associativity-of-plus (rewrite) (equal (plus (plus x y) z) (plus x (plus y z)))) (lemma plus-difference-arg1 (rewrite) (equal (plus (difference a b) c) (if (lessp b a) (difference (plus a c) b) (plus 0 c))) ((induct (difference a b)))) (lemma plus-difference-arg2 (rewrite) (equal (plus a (difference b c)) (if (lessp c b) (difference (plus a b) c) (plus a 0))) ((induct (plus a b)))) ; ---------- DIFFERENCE-PLUS cancellation rules ---------- ; ; Here are the basic canonicalization rules for differences of sums. These ; are subsumed by the meta lemmas and are therefore globally disabled. ; They are here merely to prove the meta lemmas. (lemma difference-plus-cancellation-proof () (equal (difference (plus x y) x) (fix y))) (lemma difference-plus-cancellation (rewrite) (and (equal (difference (plus x y) x) (fix y)) (equal (difference (plus y x) x) (fix y))) ((use (difference-plus-cancellation-proof (x x) (y y))) (enable commutativity-of-plus))) (disable difference-plus-cancellation) (lemma difference-plus-plus-cancellation-proof () (equal (difference (plus x y) (plus x z)) (difference y z))) (lemma difference-plus-plus-cancellation (rewrite) (and (equal (difference (plus x y) (plus x z)) (difference y z)) (equal (difference (plus y x) (plus x z)) (difference y z)) (equal (difference (plus x y) (plus z x)) (difference y z)) (equal (difference (plus y x) (plus z x)) (difference y z))) ((use (difference-plus-plus-cancellation-proof (x x) (y y) (z z))) (enable commutativity-of-plus))) (disable difference-plus-plus-cancellation) (lemma difference-plus-plus-cancellation-hack (rewrite) (equal (difference (plus w x a) (plus y z a)) (difference (plus w x) (plus y z))) ((enable commutativity-of-plus commutativity2-of-plus difference-plus-plus-cancellation) (do-not-induct t))) (disable difference-plus-plus-cancellation-hack) ; Here are a few more facts about difference needed to prove the meta lemmas. ; These are disabled here. We re-prove them after the proof of the meta ; lemmas so that they will fire before the meta lemmas in subsequent proofs. (lemma diff-sub1-arg2 (rewrite) (equal (difference a (sub1 b)) (if (zerop b) (fix a) (if (lessp a b) 0 (add1 (difference a b))))) ((induct (difference a b)))) (disable diff-sub1-arg2) (lemma diff-diff-arg1 (rewrite) (equal (difference (difference x y) z) (difference x (plus y z)))) (lemma diff-diff-arg2 (rewrite) (equal (difference a (difference b c)) (if (lessp b c) (fix a) (difference (plus a c) b))) ((enable diff-sub1-arg2 plus-zero-arg2) (induct (difference a b)))) ; diff-diff-diff should be removed, but since the hack lemmas for ; correctness-of-cancel-difference-plus are designed for it, we'll ; keep it around. (lemma diff-diff-diff (rewrite) (implies (and (leq b a) (leq d c)) (equal (difference (difference a b) (difference c d)) (difference (plus a d) (plus b c)))) ((enable diff-diff-arg1 diff-diff-arg2 plus-difference-arg2 plus-zero-arg2) (do-not-induct t))) (disable diff-diff-diff) (lemma difference-lessp-arg1 (rewrite) (implies (lessp a b) (equal (difference a b) 0))) (disable difference-lessp-arg1) ; -------------------------------------------------------------------------------- ; Meta Lemmas to Cancel PLUS and DIFFERENCE expressions ; -------------------------------------------------------------------------------- ; ---------- PLUS-TREE and PLUS-FRINGE ---------- (defn plus-fringe (x) (if (and (listp x) (equal (car x) 'plus)) (append (plus-fringe (cadr x)) (plus-fringe (caddr x))) (cons x nil))) (defn plus-tree (l) (if (nlistp l) ''0 (if (nlistp (cdr l)) (list 'fix (car l)) (if (nlistp (cddr l)) (list 'plus (car l) (cadr l)) (list 'plus (car l) (plus-tree (cdr l))))))) (lemma numberp-eval$-plus (rewrite) (implies (and (listp x) (equal (car x) 'plus)) (numberp (eval$ t x a)))) (disable numberp-eval$-plus) (lemma numberp-eval$-plus-tree (rewrite) (numberp (eval$ t (plus-tree l) a)) ((enable plus-tree))) (disable numberp-eval$-plus-tree) (lemma member-implies-plus-tree-greatereqp (rewrite) (implies (member x y) (not (lessp (eval$ t (plus-tree y) a) (eval$ t x a)))) ((enable plus-tree plus-zero-arg2))) (disable member-implies-plus-tree-greatereqp) (lemma plus-tree-delete (rewrite) (equal (eval$ t (plus-tree (delete x y)) a) (if (member x y) (difference (eval$ t (plus-tree y) a) (eval$ t x a)) (eval$ t (plus-tree y) a))) ((enable delete plus-tree delete-non-member difference-plus-cancellation equal-difference-0 equal-plus-0 listp-delete member-implies-plus-tree-greatereqp numberp-eval$-plus-tree plus-zero-arg2))) (disable plus-tree-delete) (lemma subbagp-implies-plus-tree-greatereqp (rewrite) (implies (subbagp x y) (not (lessp (eval$ t (plus-tree y) a) (eval$ t (plus-tree x) a)))) ((enable plus-tree subbagp member-implies-plus-tree-greatereqp plus-tree-delete plus-zero-arg2 subbagp-cdr2))) (disable subbagp-implies-plus-tree-greatereqp) (lemma plus-tree-bagdiff (rewrite) (implies (subbagp x y) (equal (eval$ t (plus-tree (bagdiff y x)) a) (difference (eval$ t (plus-tree y) a) (eval$ t (plus-tree x) a)))) ((enable bagdiff plus-tree subbagp commutativity-of-plus diff-diff-arg1 difference-lessp-arg1 member-implies-plus-tree-greatereqp numberp-eval$-plus-tree plus-tree-delete plus-zero-arg2 subbagp-cdr2 subbagp-implies-plus-tree-greatereqp))) (disable plus-tree-bagdiff) (lemma numberp-eval$-bridge (rewrite) (implies (equal (eval$ t z a) (eval$ t (plus-tree x) a)) (numberp (eval$ t z a))) ((enable plus-tree numberp-eval$-plus-tree))) (disable numberp-eval$-bridge) (lemma bridge-to-subbagp-implies-plus-tree-greatereqp (rewrite) (implies (and (subbagp y (plus-fringe z)) (equal (eval$ t z a) (eval$ t (plus-tree (plus-fringe z)) a))) (equal (lessp (eval$ t z a) (eval$ t (plus-tree y) a)) f)) ((enable subbagp plus-fringe plus-tree subbagp-implies-plus-tree-greatereqp))) (disable bridge-to-subbagp-implies-plus-tree-greatereqp) (lemma eval$-plus-tree-append (rewrite) (equal (eval$ t (plus-tree (append x y)) a) (plus (eval$ t (plus-tree x) a) (eval$ t (plus-tree y) a))) ((enable plus-zero-arg2 commutativity2-of-plus commutativity-of-plus equal-plus-0 plus-cancellation plus-tree numberp-eval$-plus-tree numberp-eval$-bridge))) (disable eval$-plus-tree-append) (lemma plus-tree-plus-fringe (rewrite) (equal (eval$ t (plus-tree (plus-fringe x)) a) (fix (eval$ t x a))) ((enable plus-zero-arg2 commutativity-of-plus plus-fringe plus-tree numberp-eval$-plus numberp-eval$-bridge eval$-plus-tree-append) (induct (plus-fringe x)))) (disable plus-tree-plus-fringe) (lemma member-implies-numberp (rewrite) (implies (and (member c (plus-fringe x)) (numberp (eval$ t c a))) (numberp (eval$ t x a))) ((enable plus-fringe numberp-eval$-plus) (induct (plus-fringe x)))) (disable member-implies-numberp) (lemma cadr-eval$-list (rewrite) (and (equal (car (eval$ 'list x a)) (eval$ t (car x) a)) (equal (cdr (eval$ 'list x a)) (if (listp x) (eval$ 'list (cdr x) a) 0)))) (disable cadr-eval$-list) (lemma eval$-quote (rewrite) (equal (eval$ t (cons 'quote args) a) (car args))) (disable eval$-quote) (lemma listp-eval$ (rewrite) (equal (listp (eval$ 'list x a)) (listp x))) (disable listp-eval$) ; ---------- CANCEL PLUS ---------- ; CANCEL-EQUAL-PLUS cancels identical terms in a term which is the equality ; of two sums. For example, ; ; (EQUAL (PLUS A B C) (PLUS B D E)) => (EQUAL (PLUS A C) (PLUS D E)) ; (defn cancel-equal-plus (x) (if (and (listp x) (equal (car x) 'equal)) (if (and (listp (cadr x)) (equal (caadr x) 'plus) (listp (caddr x)) (equal (caaddr x) 'plus)) (list 'equal (plus-tree (bagdiff (plus-fringe (cadr x)) (bagint (plus-fringe (cadr x)) (plus-fringe (caddr x))))) (plus-tree (bagdiff (plus-fringe (caddr x)) (bagint (plus-fringe (cadr x)) (plus-fringe (caddr x)))))) (if (and (listp (cadr x)) (equal (caadr x) 'plus) (member (caddr x) (plus-fringe (cadr x)))) (list 'if (list 'numberp (caddr x)) (list 'equal (plus-tree (delete (caddr x) (plus-fringe (cadr x)))) ''0) (list 'quote f)) (if (and (listp (caddr x)) (equal (caaddr x) 'plus) (member (cadr x) (plus-fringe (caddr x)))) (list 'if (list 'numberp (cadr x)) (list 'equal ''0 (plus-tree (delete (cadr x) (plus-fringe (caddr x))))) (list 'quote f)) x))) x)) (lemma correctness-of-cancel-equal-plus ((meta equal)) (equal (eval$ t x a) (eval$ t (cancel-equal-plus x) a)) ((enable bridge-to-subbagp-implies-plus-tree-greatereqp cancel-equal-plus difference-cancellation equal-difference-0 eval$-quote member-implies-numberp member-implies-plus-tree-greatereqp numberp-eval$-plus plus-tree-bagdiff plus-tree-delete plus-tree-plus-fringe subbagp-bagint1 subbagp-bagint2) (disable eval$))) ; ---------- CANCEL-DIFFERENCE-PLUS ---------- ; CANCEL-DIFFERENCE-PLUS cancels identical terms in a term which is the ; difference of two sums. For example, ; ; (DIFFERENCE (PLUS A B C) (PLUS B D E)) => (DIFFERENCE (PLUS A C) (PLUS D E)) ; ; Using rewrite rules, we canonicalize terms involving PLUS and DIFFERENCE ; to be the DIFFERENCE of two sums. Then CANCEL-DIFFERENCE-PLUS cancels out ; like terms. (defn cancel-difference-plus (x) (if (and (listp x) (equal (car x) 'difference)) (if (and (listp (cadr x)) (equal (caadr x) 'plus) (listp (caddr x)) (equal (caaddr x) 'plus)) (list 'difference (plus-tree (bagdiff (plus-fringe (cadr x)) (bagint (plus-fringe (cadr x)) (plus-fringe (caddr x))))) (plus-tree (bagdiff (plus-fringe (caddr x)) (bagint (plus-fringe (cadr x)) (plus-fringe (caddr x)))))) (if (and (listp (cadr x)) (equal (caadr x) 'plus) (member (caddr x) (plus-fringe (cadr x)))) (plus-tree (delete (caddr x) (plus-fringe (cadr x)))) (if (and (listp (caddr x)) (equal (caaddr x) 'plus) (member (cadr x) (plus-fringe (caddr x)))) ''0 x))) x)) (lemma correctness-of-cancel-difference-plus ((meta difference)) (equal (eval$ t x a) (eval$ t (cancel-difference-plus x) a)) ((enable cancel-difference-plus associativity-of-plus bridge-to-subbagp-implies-plus-tree-greatereqp commutativity-of-plus diff-diff-diff difference-lessp-arg1 difference-plus-plus-cancellation-hack equal-difference-0 eval$-quote member-implies-plus-tree-greatereqp numberp-eval$-plus plus-tree-bagdiff plus-tree-delete plus-tree-plus-fringe subbagp-bagint1 subbagp-bagint2) (disable eval$))) ; ---------- DIFFERENCE ---------- ; Here are the rules for difference terms which we want to try before ; the meta lemmas. They help canonicalize terms to differences of sums. (lemma difference-elim (elim) (implies (and (numberp y) (not (lessp y x))) (equal (plus x (difference y x)) y))) (lemma difference-leq-arg1 (rewrite) (implies (leq a b) (equal (difference a b) 0))) (lemma difference-add1-arg2 (rewrite) (equal (difference a (add1 b)) (if (lessp b a) (sub1 (difference a b)) 0)) ((enable difference-leq-arg1) (induct (difference a b)))) (lemma difference-sub1-arg2 (rewrite) (equal (difference a (sub1 b)) (if (zerop b) (fix a) (if (lessp a b) 0 (add1 (difference a b))))) ((enable diff-sub1-arg2))) (lemma difference-difference-arg1 (rewrite) (equal (difference (difference x y) z) (difference x (plus y z))) ((enable diff-diff-arg1))) (lemma difference-difference-arg2 (rewrite) (equal (difference a (difference b c)) (if (lessp b c) (fix a) (difference (plus a c) b))) ((enable diff-diff-arg2))) (lemma difference-x-x (rewrite) (equal (difference x x) 0)) ; ---------- LESSP ---------- (lemma lessp-difference-cancellation (rewrite) (equal (lessp (difference a c) (difference b c)) (if (leq c a) (lessp a b) (lessp c b))) ((enable equal-difference-0))) (disable lessp-difference-cancellation) ; CANCEL-LESSP-PLUS cancels LESSP terms whose arguments are sums. ; Examples: ; (LESSP (PLUS A B C) (PLUS A C D)) -> (LESSP (FIX B) (FIX D)) ; (LESSP A (PLUS A B)) -> (NOT (ZEROP (FIX B))) ; (LESSP (PLUS A B) A) -> F (defn cancel-lessp-plus (x) (if (and (listp x) (equal (car x) 'lessp)) (if (and (listp (cadr x)) (equal (caadr x) 'plus) (listp (caddr x)) (equal (caaddr x) 'plus)) (list 'lessp (plus-tree (bagdiff (plus-fringe (cadr x)) (bagint (plus-fringe (cadr x)) (plus-fringe (caddr x))))) (plus-tree (bagdiff (plus-fringe (caddr x)) (bagint (plus-fringe (cadr x)) (plus-fringe (caddr x)))))) (if (and (listp (cadr x)) (equal (caadr x) 'plus) (member (caddr x) (plus-fringe (cadr x)))) (list 'quote f) (if (and (listp (caddr x)) (equal (caaddr x) 'plus) (member (cadr x) (plus-fringe (caddr x)))) (list 'not (list 'zerop (plus-tree (delete (cadr x) (plus-fringe (caddr x)))))) x))) x)) (lemma correctness-of-cancel-lessp-plus ((meta lessp)) (equal (eval$ t x a) (eval$ t (cancel-lessp-plus x) a)) ((enable cancel-lessp-plus bridge-to-subbagp-implies-plus-tree-greatereqp equal-difference-0 eval$-quote lessp-difference-cancellation member-implies-plus-tree-greatereqp numberp-eval$-plus plus-tree-bagdiff plus-tree-delete plus-tree-plus-fringe subbagp-bagint1 subbagp-bagint2) (disable eval$))) ; Define the available theory of addition. To get the list of events to ; put in the theory, evaluate the following form in NQTHM at this point ; in the script. This form lists all lemmas which are globally enabled, ; and which have non-null lemma type. ; ; (remove-if-not (function (lambda (x) ; (and (member x (lemmas)) ; (not (assoc x disabled-lemmas)) ; (not (null (nth 2 (get x 'event))))))) ; chronology) (deftheory addition (EQUAL-PLUS-0 EQUAL-DIFFERENCE-0 COMMUTATIVITY-OF-PLUS COMMUTATIVITY2-OF-PLUS PLUS-ZERO-ARG2 PLUS-ADD1-ARG2 PLUS-ADD1-ARG1 ASSOCIATIVITY-OF-PLUS PLUS-DIFFERENCE-ARG1 PLUS-DIFFERENCE-ARG2 diff-diff-arg1 diff-diff-arg2 CORRECTNESS-OF-CANCEL-EQUAL-PLUS CORRECTNESS-OF-CANCEL-DIFFERENCE-PLUS DIFFERENCE-ELIM DIFFERENCE-LEQ-ARG1 DIFFERENCE-ADD1-ARG2 DIFFERENCE-SUB1-ARG2 DIFFERENCE-DIFFERENCE-ARG1 DIFFERENCE-DIFFERENCE-ARG2 DIFFERENCE-X-X CORRECTNESS-OF-CANCEL-LESSP-PLUS)) ; ---------- TIMES ---------- (lemma equal-times-0 (rewrite) (equal (equal (times x y) 0) (or (zerop x) (zerop y))) ((enable equal-plus-0) (induct (times x y)))) (lemma equal-times-1 (rewrite) (equal (equal (times a b) 1) (and (equal a 1) (equal b 1))) ((enable equal-plus-0) (induct (times a b)))) ;(lemma equal-sub1-times-0 (rewrite) ; (equal (equal (sub1 (times a b)) 0) ; (or (zerop a) ; (zerop b) ; (and (equal a 1) (equal b 1))))) (lemma equal-sub1-0 (rewrite) (equal (equal (sub1 x) 0) (or (zerop x) (equal x 1)))) (lemma times-zero (rewrite) (implies (zerop y) (equal (times x y) 0)) ((enable plus-zero-arg2 commutativity-of-plus))) (lemma times-add1 (rewrite) (equal (times x (add1 y)) (if (numberp y) (plus x (times x y)) (fix x))) ((enable plus-zero-arg2 commutativity-of-plus))) (lemma commutativity-of-times (rewrite) (equal (times y x) (times x y)) ((enable times-zero times-add1))) (lemma times-distributes-over-plus-proof () (equal (times x (plus y z)) (plus (times x y) (times x z))) ((enable commutativity2-of-plus associativity-of-plus))) (lemma times-distributes-over-plus (rewrite) (and (equal (times x (plus y z)) (plus (times x y) (times x z))) (equal (times (plus x y) z) (plus (times x z) (times y z)))) ((use (times-distributes-over-plus-proof (x x) (y y) (z z)) (times-distributes-over-plus-proof (x z) (y x) (z y))) (enable commutativity-of-times))) (lemma commutativity2-of-times (rewrite) (equal (times x y z) (times y x z)) ((enable commutativity-of-times times-distributes-over-plus))) (lemma associativity-of-times (rewrite) (equal (times (times x y) z) (times x y z)) ((enable commutativity-of-times commutativity2-of-times))) (lemma times-distributes-over-difference-proof () (equal (times (difference a b) c) (difference (times a c) (times b c))) ((enable commutativity-of-times) (enable-theory addition))) (lemma times-distributes-over-difference (rewrite) (and (equal (times (difference a b) c) (difference (times a c) (times b c))) (equal (times a (difference b c)) (difference (times a b) (times a c)))) ((use (times-distributes-over-difference-proof (a a) (b b) (c c)) (times-distributes-over-difference-proof (a b) (b c) (c a))) (enable commutativity-of-times))) (lemma times-quotient-proof () (implies (and (not (zerop x)) (equal (remainder y x) 0)) (equal (times (quotient y x) x) (fix y))) ((enable times-zero times-add1) (induct (remainder y x)))) (lemma times-quotient (rewrite) (implies (and (not (zerop y)) (equal (remainder x y) 0)) (and (equal (times (quotient x y) y) (fix x)) (equal (times y (quotient x y)) (fix x)))) ((use (times-quotient-proof (x y) (y x))) (enable commutativity-of-times))) (lemma times-1-arg1 (rewrite) (equal (times 1 x) (fix x)) ((enable times-zero))) (lemma lessp-times1-proof () (implies (and (lessp a b) (not (zerop c))) (equal (lessp a (times b c)) t))) (lemma lessp-times1 (rewrite) (implies (and (lessp a b) (not (zerop c))) (and (equal (lessp a (times b c)) t) (equal (lessp a (times c b)) t))) ((enable commutativity-of-times) (use (lessp-times1-proof (a a) (b b) (c c))) (do-not-induct t))) (lemma lessp-times2-proof () (implies (and (leq a b) (not (zerop c))) (equal (lessp (times b c) a) f))) (lemma lessp-times2 (rewrite) (implies (and (leq a b) (not (zerop c))) (and (equal (lessp (times b c) a) f) (equal (lessp (times c b) a) f))) ((enable commutativity-of-times) (use (lessp-times2-proof (a a) (b b) (c c))) (do-not-induct t))) (lemma lessp-times3-proof1 () (implies (and (not (zerop a)) (lessp 1 b)) (lessp a (times a b))) ((enable-theory addition) (enable times-zero))) (lemma lessp-times3-proof2 () (implies (lessp a (times a b)) (and (not (zerop a)) (lessp 1 b))) ((enable-theory addition))) (lemma lessp-times3 (rewrite) (and (equal (lessp a (times a b)) (and (not (zerop a)) (lessp 1 b))) (equal (lessp a (times b a)) (and (not (zerop a)) (lessp 1 b)))) ((enable commutativity-of-times) (use (lessp-times3-proof1 (a a) (b b)) (lessp-times3-proof2 (a a) (b b))) (do-not-induct t))) (lemma lessp-times-cancellation-proof () (equal (lessp (times x z) (times y z)) (and (not (zerop z)) (lessp x y))) ((enable commutativity-of-times correctness-of-cancel-lessp-plus times-zero))) (lemma lessp-times-cancellation1 (rewrite) (and (equal (lessp (times x z) (times y z)) (and (not (zerop z)) (lessp x y))) (equal (lessp (times z x) (times y z)) (and (not (zerop z)) (lessp x y))) (equal (lessp (times x z) (times z y)) (and (not (zerop z)) (lessp x y))) (equal (lessp (times z x) (times z y)) (and (not (zerop z)) (lessp x y)))) ((use (lessp-times-cancellation-proof (x x) (y y) (z z))) (enable commutativity-of-times) (do-not-induct t))) (disable lessp-times-cancellation1) (lemma lessp-plus-times-proof () (implies (lessp x a) (equal (lessp (plus x (times a b)) (times a c)) (lessp b c))) ((enable-theory addition) (enable commutativity-of-times lessp-times-cancellation1 lessp-times1 lessp-times2 lessp-times3 times-add1 times-zero) (induct (lessp b c)))) (lemma lessp-plus-times1 (rewrite) (and (equal (lessp (plus a (times b c)) b) (and (lessp a b) (zerop c))) (equal (lessp (plus a (times c b)) b) (and (lessp a b) (zerop c))) (equal (lessp (plus (times c b) a) b) (and (lessp a b) (zerop c))) (equal (lessp (plus (times b c) a) b) (and (lessp a b) (zerop c)))) ((use (lessp-plus-times-proof (a b) (b c) (c 1) (x a))) (enable commutativity-of-plus commutativity-of-times times-1-arg1) (do-not-induct t))) (lemma lessp-plus-times2 (rewrite) (implies (and (not (zerop a)) (lessp x a)) (and (equal (lessp (plus x (times a b)) (times a c)) (lessp b c)) (equal (lessp (plus x (times b a)) (times a c)) (lessp b c)) (equal (lessp (plus x (times a b)) (times c a)) (lessp b c)) (equal (lessp (plus x (times b a)) (times c a)) (lessp b c)) (equal (lessp (plus (times a b) x) (times a c)) (lessp b c)) (equal (lessp (plus (times b a) x) (times a c)) (lessp b c)) (equal (lessp (plus (times a b) x) (times c a)) (lessp b c)) (equal (lessp (plus (times b a) x) (times c a)) (lessp b c)))) ((enable commutativity-of-plus commutativity-of-times) (use (lessp-plus-times-proof (a a) (b b) (c c) (x x))) (do-not-induct t))) (lemma lessp-1-times (rewrite) (equal (lessp 1 (times a b)) (not (or (zerop a) (zerop b) (and (equal a 1) (equal b 1)))))) ;;; meta lemmas to cancel lessp-times and equal-times expressions ;; examples ;; (lessp (times b (times d a)) (times b (times e (times a f)))) -> ;; (and (and (not (zerop a)) ;; (not (zerop b))) ;; (lessp (fix d) (times e f))) ;; ;; (equal (times b (times c d)) (times b d)) -> ;; (or (or (zerop b) (zerop d)) ;; (equal (fix c) 1)) (defn times-tree (x) (if (nlistp x) ''1 (if (nlistp (cdr x)) (list 'fix (car x)) (if (nlistp (cddr x)) (list 'times (car x) (cadr x)) (list 'times (car x) (times-tree (cdr x))))))) (defn times-fringe (x) (if (and (listp x) (equal (car x) 'times)) (append (times-fringe (cadr x)) (times-fringe (caddr x))) (cons x nil))) (defn or-zerop-tree (x) (if (nlistp x) '(false) (if (nlistp (cdr x)) (list 'zerop (car x)) (if (nlistp (cddr x)) (list 'or (list 'zerop (car x)) (list 'zerop (cadr x))) (list 'or (list 'zerop (car x)) (or-zerop-tree (cdr x))))))) (defn and-not-zerop-tree (x) (if (nlistp x) '(true) (if (nlistp (cdr x)) (list 'not (list 'zerop (car x))) (list 'and (list 'not (list 'zerop (car x))) (and-not-zerop-tree (cdr x)))))) (lemma numberp-eval$-times (rewrite) (implies (equal (car x) 'times) (numberp (eval$ t x a)))) (disable numberp-eval$-times) (lemma eval$-times (rewrite) (implies (equal (car x) 'times) (equal (eval$ t x a) (times (eval$ t (cadr x) a) (eval$ t (caddr x) a))))) (disable eval$-times) (lemma eval$-or (rewrite) (implies (equal (car x) 'or) (equal (eval$ t x a) (or (eval$ t (cadr x) a) (eval$ t (caddr x) a))))) (disable eval$-or) (lemma eval$-equal (rewrite) (implies (equal (car x) 'equal) (equal (eval$ t x a) (equal (eval$ t (cadr x) a) (eval$ t (caddr x) a))))) (disable eval$-equal) (lemma eval$-lessp (rewrite) (implies (equal (car x) 'lessp) (equal (eval$ t x a) (lessp (eval$ t (cadr x) a) (eval$ t (caddr x) a))))) (disable eval$-lessp) (lemma eval$-quotient (rewrite) (implies (equal (car x) 'quotient) (equal (eval$ t x a) (quotient (eval$ t (cadr x) a) (eval$ t (caddr x) a))))) (disable eval$-quotient) (lemma eval$-if (rewrite) (implies (equal (car x) 'if) (equal (eval$ t x a) (if (eval$ t (cadr x) a) (eval$ t (caddr x) a) (eval$ t (cadddr x) a))))) (disable eval$-if) (lemma numberp-eval$-times-tree (rewrite) (numberp (eval$ t (times-tree x) a)) ((enable times-tree))) (disable numberp-eval$-times-tree) (lemma lessp-times-arg1 () (implies (not (zerop a)) (equal (not (lessp (times a x) (times a y))) (not (lessp x y)))) ((induct (plus a x)) (enable times correctness-of-cancel-lessp-plus))) (lemma infer-equality-from-not-lessp () (implies (and (numberp a) (numberp b)) (equal (and (not (lessp a b)) (not (lessp b a))) (equal a b)))) (lemma equal-times-arg1 (rewrite) (implies (not (zerop a)) (equal (equal (times a x) (times a y)) (equal (fix x) (fix y)))) ((use (lessp-times-arg1 (a a) (x x) (y y)) (lessp-times-arg1 (a a) (x y) (y x)) (infer-equality-from-not-lessp (a (times a x)) (b (times a y)))) (do-not-induct t))) (disable equal-times-arg1) (lemma equal-times-bridge (rewrite) (equal (equal (times a b) (times c (times a d))) (or (zerop a) (equal (fix b) (times c d)))) ((enable commutativity-of-times commutativity2-of-times equal-times-0 equal-times-arg1 times-zero))) (disable equal-times-bridge) (lemma eval$-times-member (rewrite) (implies (member e x) (equal (eval$ t (times-tree x) a) (times (eval$ t e a) (eval$ t (times-tree (delete e x)) a)))) ((enable delete times-tree COMMUTATIVITY-OF-TIMES DELETE-NON-MEMBER EQUAL-TIMES-0 EQUAL-TIMES-BRIDGE LISTP-DELETE MEMBER-NON-LIST TIMES-1-ARG1 TIMES-ZERO))) (disable eval$-times-member) (lemma zerop-makes-times-tree-zero (rewrite) (implies (and (not (eval$ t (and-not-zerop-tree x) a)) (subbagp x y)) (equal (eval$ t (times-tree y) a) 0)) ((enable AND-NOT-ZEROP-TREE COMMUTATIVITY-OF-TIMES EVAL$-TIMES-MEMBER SUBBAGP TIMES-TREE TIMES-ZERO))) (disable zerop-makes-times-tree-zero) (lemma or-zerop-tree-is-not-zerop-tree (rewrite) (equal (eval$ t (or-zerop-tree x) a) (not (eval$ t (and-not-zerop-tree x) a))) ((enable AND-NOT-ZEROP-TREE OR-ZEROP-TREE))) (disable or-zerop-tree-is-not-zerop-tree) (lemma zerop-makes-times-tree-zero2 (rewrite) (implies (and (eval$ t (or-zerop-tree x) a) (subbagp x y)) (equal (eval$ t (times-tree y) a) 0)) ((use (zerop-makes-times-tree-zero) (or-zerop-tree-is-not-zerop-tree)) (enable OR-ZEROP-TREE SUBBAGP TIMES-TREE))) (disable zerop-makes-times-tree-zero2) (lemma times-tree-append (rewrite) (equal (eval$ t (times-tree (append x y)) a) (times (eval$ t (times-tree x) a) (eval$ t (times-tree y) a))) ((enable append ASSOCIATIVITY-OF-TIMES COMMUTATIVITY-OF-TIMES COMMUTATIVITY2-OF-TIMES EQUAL-TIMES-0 EQUAL-TIMES-ARG1 EQUAL-TIMES-BRIDGE NUMBERP-EVAL$-TIMES-TREE TIMES-1-ARG1 TIMES-TREE TIMES-ZERO))) (disable times-tree-append) (lemma times-tree-of-times-fringe (rewrite) (equal (eval$ t (times-tree (times-fringe x)) a) (fix (eval$ t x a))) ((enable COMMUTATIVITY-OF-TIMES EVAL$-TIMES TIMES-FRINGE TIMES-TREE TIMES-TREE-APPEND TIMES-ZERO) (induct (times-fringe x)))) (disable times-tree-of-times-fringe) (defn cancel-lessp-times (x) (if (and (equal (car x) 'lessp) (equal (caadr x) 'times) (equal (caaddr x) 'times)) (let ((inboth (bagint (times-fringe (cadr x)) (times-fringe (caddr x))))) (if (listp inboth) (list 'and (and-not-zerop-tree inboth) (list 'lessp (times-tree (bagdiff (times-fringe (cadr x)) inboth)) (times-tree (bagdiff (times-fringe (caddr x)) inboth)))) x)) x)) (lemma eval$-lessp-times-tree-bagdiff (rewrite) (implies (and (subbagp x y) (subbagp x z) (eval$ t (and-not-zerop-tree x) a)) (equal (lessp (eval$ t (times-tree (bagdiff y x)) a) (eval$ t (times-tree (bagdiff z x)) a)) (lessp (eval$ t (times-tree y) a) (eval$ t (times-tree z) a)))) ((enable AND-NOT-ZEROP-TREE BAGDIFF EVAL$-TIMES-MEMBER LESSP-TIMES-CANCELLATION1 SUBBAGP SUBBAGP-CDR1 SUBBAGP-CDR2 TIMES-TREE ZEROP-MAKES-TIMES-TREE-ZERO))) (disable eval$-lessp-times-tree-bagdiff) (lemma zerop-makes-lessp-false-bridge (rewrite) (implies (and (equal (car x) 'times) (equal (car y) 'times) (not (eval$ t (and-not-zerop-tree (bagint (times-fringe x) (times-fringe y))) a))) (equal (lessp (times (eval$ t (cadr x) a) (eval$ t (caddr x) a)) (times (eval$ t (cadr y) a) (eval$ t (caddr y) a))) f)) ((enable AND-NOT-ZEROP-TREE BAGINT COMMUTATIVITY-OF-TIMES DELETE EQUAL-TIMES-0 EVAL$-TIMES ;MEMBER-CONS ;MEMBER-NON-LIST SUBBAGP-BAGINT1 SUBBAGP-BAGINT2 TIMES-FRINGE TIMES-TREE TIMES-TREE-APPEND TIMES-TREE-OF-TIMES-FRINGE TIMES-ZERO) (use (zerop-makes-times-tree-zero (x (bagint (times-fringe x) (times-fringe y))) (y (times-fringe x))) (zerop-makes-times-tree-zero (x (bagint (times-fringe x) (times-fringe y))) (y (times-fringe y)))))) (disable zerop-makes-lessp-false-bridge) (lemma correctness-of-cancel-lessp-times ((meta lessp)) (equal (eval$ t x a) (eval$ t (cancel-lessp-times x) a)) ((enable CANCEL-LESSP-TIMES EVAL$-LESSP-TIMES-TREE-BAGDIFF EVAL$-LESSP EVAL$-TIMES SUBBAGP-BAGINT1 SUBBAGP-BAGINT2 TIMES-TREE-OF-TIMES-FRINGE ZEROP-MAKES-LESSP-FALSE-BRIDGE))) (defn cancel-equal-times (x) (if (and (equal (car x) 'equal) (equal (caadr x) 'times) (equal (caaddr x) 'times)) (let ((inboth (bagint (times-fringe (cadr x)) (times-fringe (caddr x))))) (if (listp inboth) (list 'or (or-zerop-tree inboth) (list 'equal (times-tree (bagdiff (times-fringe (cadr x)) inboth)) (times-tree (bagdiff (times-fringe (caddr x)) inboth)))) x)) x)) (lemma zerop-makes-equal-true-bridge (rewrite) (implies (and (equal (car x) 'times) (equal (car y) 'times) (eval$ t (or-zerop-tree (bagint (times-fringe x) (times-fringe y))) a)) (equal (equal (times (eval$ t (cadr x) a) (eval$ t (caddr x) a)) (times (eval$ t (cadr y) a) (eval$ t (caddr y) a))) t)) ((enable BAGINT COMMUTATIVITY-OF-TIMES DELETE EQUAL-TIMES-0 EVAL$-TIMES OR-ZEROP-TREE SUBBAGP-BAGINT1 SUBBAGP-BAGINT2 TIMES-FRINGE TIMES-TREE TIMES-TREE-APPEND TIMES-TREE-OF-TIMES-FRINGE TIMES-ZERO) (use (zerop-makes-times-tree-zero2 (x (bagint (times-fringe x) (times-fringe y))) (y (times-fringe x))) (zerop-makes-times-tree-zero2 (x (bagint (times-fringe x) (times-fringe y))) (y (times-fringe y)))))) (disable zerop-makes-equal-true-bridge) (lemma eval$-equal-times-tree-bagdiff (rewrite) (implies (and (subbagp x y) (subbagp x z) (not (eval$ t (or-zerop-tree x) a))) (equal (equal (eval$ t (times-tree (bagdiff y x)) a) (eval$ t (times-tree (bagdiff z x)) a)) (equal (eval$ t (times-tree y) a) (eval$ t (times-tree z) a)))) ((enable AND-NOT-ZEROP-TREE BAGDIFF EQUAL-TIMES-ARG1 EVAL$-TIMES-MEMBER NUMBERP-EVAL$-TIMES-TREE OR-ZEROP-TREE OR-ZEROP-TREE-IS-NOT-ZEROP-TREE SUBBAGP SUBBAGP-CDR1 SUBBAGP-CDR2 TIMES-TREE ZEROP-MAKES-TIMES-TREE-ZERO))) (disable eval$-equal-times-tree-bagdiff) (lemma cancel-equal-times-preserves-inequality (rewrite) (implies (and (subbagp z x) (subbagp z y) (not (equal (eval$ t (times-tree x) a) (eval$ t (times-tree y) a)))) (not (equal (eval$ t (times-tree (bagdiff x z)) a) (eval$ t (times-tree (bagdiff y z)) a)))) ((enable BAGDIFF EVAL$-TIMES-MEMBER SUBBAGP SUBBAGP-CDR2 TIMES-TREE))) (disable cancel-equal-times-preserves-inequality) (lemma cancel-equal-times-preserves-inequality-bridge (rewrite) (implies (and (equal (car x) 'times) (equal (car y) 'times) (not (equal (times (eval$ t (cadr x) a) (eval$ t (caddr x) a)) (times (eval$ t (cadr y) a) (eval$ t (caddr y) a))))) (not (equal (eval$ t (times-tree (bagdiff (times-fringe x) (bagint (times-fringe x) (times-fringe y)))) a) (eval$ t (times-tree (bagdiff (times-fringe y) (bagint (times-fringe x) (times-fringe y)))) a)))) ((enable BAGDIFF BAGINT COMMUTATIVITY-OF-TIMES SUBBAGP-BAGINT1 SUBBAGP-BAGINT2 TIMES-FRINGE TIMES-TREE TIMES-TREE-APPEND TIMES-TREE-OF-TIMES-FRINGE TIMES-ZERO) (use (cancel-equal-times-preserves-inequality (z (bagint (times-fringe x) (times-fringe y))) (x (times-fringe x)) (y (times-fringe y)))))) (disable cancel-equal-times-preserves-inequality-bridge) (lemma correctness-of-cancel-equal-times ((meta equal)) (equal (eval$ t x a) (eval$ t (cancel-equal-times x) a)) ((enable CANCEL-EQUAL-TIMES CANCEL-EQUAL-TIMES-PRESERVES-INEQUALITY-BRIDGE EVAL$-EQUAL EVAL$-EQUAL-TIMES-TREE-BAGDIFF EVAL$-TIMES SUBBAGP-BAGINT1 SUBBAGP-BAGINT2 TIMES-TREE-OF-TIMES-FRINGE ZEROP-MAKES-EQUAL-TRUE-BRIDGE))) ; Define the available theory of multiplication. To get the list of ; events to put in the theory, evaluate the following form in NQTHM at ; this point in the script. This form lists all lemmas which are ; globally enabled, and which have non-null lemma type. ; ; (remove-if-not (function (lambda (x) ; (and (member x (lemmas)) ; (not (assoc x disabled-lemmas)) ; (not (null (nth 2 (get x 'event)))) ; (not (member x (nth 2 (get 'addition 'event))))))) ; chronology) (deftheory multiplication (EQUAL-TIMES-0 EQUAL-TIMES-1 equal-sub1-0 TIMES-ZERO TIMES-ADD1 COMMUTATIVITY-OF-TIMES TIMES-DISTRIBUTES-OVER-PLUS COMMUTATIVITY2-OF-TIMES ASSOCIATIVITY-OF-TIMES TIMES-DISTRIBUTES-OVER-DIFFERENCE TIMES-QUOTIENT TIMES-1-ARG1 LESSP-TIMES1 LESSP-TIMES2 lessp-times3 LESSP-PLUS-TIMES1 LESSP-PLUS-TIMES2 LESSP-1-TIMES correctness-of-cancel-lessp-times correctness-of-cancel-equal-times)) ; ---------- REMAINDER ---------- (lemma lessp-remainder (rewrite generalize) (equal (lessp (remainder x y) y) (not (zerop y)))) (lemma remainder-noop (rewrite) (implies (lessp a b) (equal (remainder a b) (fix a)))) (lemma remainder-of-non-number (rewrite) (implies (not (numberp a)) (equal (remainder a n) (remainder 0 n)))) (lemma remainder-zero (rewrite) (implies (zerop x) (equal (remainder y x) (fix y)))) (lemma plus-remainder-times-quotient (rewrite) (equal (plus (remainder x y) (times y (quotient x y))) (fix x)) ((enable commutativity2-of-plus commutativity-of-plus times-zero times-add1 commutativity-of-times))) (DISABLE PLUS-REMAINDER-TIMES-QUOTIENT) (lemma remainder-quotient-elim (elim) (implies (and (not (zerop y)) (numberp x)) (equal (plus (remainder x y) (times y (quotient x y))) x)) ((enable plus-remainder-times-quotient))) ; (lemma remainder-sub1 (rewrite) ; (implies (and (not (zerop a)) ; (not (zerop b))) ; (equal (remainder (sub1 a) b) ; (if (equal (remainder a b) 0) ; (sub1 b) ; (sub1 (remainder a b))))) ; ((enable lessp-remainder ; remainder-noop ; remainder-quotient-elim) ; (enable-theory addition) ; (induct (remainder a b)))) (lemma remainder-add1 (rewrite) (implies (equal (remainder a b) 0) (equal (remainder (add1 a) b) (remainder 1 b))) ((enable remainder-noop) (enable-theory addition) (induct (remainder a b)))) (lemma remainder-plus-proof () (implies (equal (remainder b c) 0) (equal (remainder (plus a b) c) (remainder a c))) ((enable remainder-noop) (enable-theory addition) (induct (remainder b c)))) (lemma remainder-plus (rewrite) (implies (equal (remainder a c) 0) (and (equal (remainder (plus a b) c) (remainder b c)) (equal (remainder (plus b a) c) (remainder b c)) (equal (remainder (plus x y a) c) (remainder (plus x y) c)))) ((use (remainder-plus-proof (a b) (b a) (c c)) (remainder-plus-proof (a a) (b b) (c c)) (remainder-plus-proof (b a) (a (plus x y)) (c c))) (enable commutativity-of-plus commutativity2-of-plus associativity-of-plus))) (lemma equal-remainder-plus-0-proof () (implies (equal (remainder a c) 0) (equal (equal (remainder (plus a b) c) 0) (equal (remainder b c) 0))) ((enable remainder-plus))) (lemma equal-remainder-plus-0 (rewrite) (implies (equal (remainder a c) 0) (and (equal (equal (remainder (plus a b) c) 0) (equal (remainder b c) 0)) (equal (equal (remainder (plus b a) c) 0) (equal (remainder b c) 0)) (equal (equal (remainder (plus x y a) c) 0) (equal (remainder (plus x y) c) 0)))) ((use (equal-remainder-plus-0-proof (a a) (b b) (c c)) (equal-remainder-plus-0-proof (a b) (b a) (c c)) (equal-remainder-plus-0-proof (a a) (b (plus x y)) (c c))) (enable associativity-of-plus commutativity-of-plus commutativity2-of-plus) (do-not-induct t))) (lemma equal-remainder-plus-remainder-proof () (implies (lessp a c) (equal (equal (remainder (plus a b) c) (remainder b c)) (zerop a))) ((enable remainder-noop) (enable-theory addition) (induct (remainder b c)))) (lemma equal-remainder-plus-remainder (rewrite) (implies (lessp a c) (and (equal (equal (remainder (plus a b) c) (remainder b c)) (zerop a)) (equal (equal (remainder (plus b a) c) (remainder b c)) (zerop a)))) ((use (equal-remainder-plus-remainder-proof (a a) (b b) (c c))) (enable commutativity-of-plus) (do-not-induct t))) (DISABLE EQUAL-REMAINDER-PLUS-REMAINDER) (lemma remainder-times1-proof () (implies (equal (remainder b c) 0) (equal (remainder (times a b) c) 0)) ((enable-theory multiplication addition) (enable remainder-plus remainder-noop remainder-zero))) (lemma remainder-times1 (rewrite) (implies (equal (remainder b c) 0) (and (equal (remainder (times a b) c) 0) (equal (remainder (times b a) c) 0))) ((use (remainder-times1-proof (a a) (b b) (c c)) (remainder-times1-proof (a b) (b a) (c c))) (enable commutativity-of-times))) (lemma remainder-times1-instance-proof () (equal (remainder (times x y) y) 0) ((enable commutativity-of-times difference-plus-cancellation remainder-zero) (induct (times x y)))) (lemma remainder-times1-instance (rewrite) (and (equal (remainder (times x y) y) 0) (equal (remainder (times x y) x) 0)) ((use (remainder-times1-instance-proof (x x) (y y)) (remainder-times1-instance-proof (x y) (y x))) (enable commutativity-of-times))) (lemma remainder-times-times-proof () (equal (remainder (times x y) (times x z)) (times x (remainder y z))) ((enable-theory addition multiplication) (enable remainder-zero) (induct (remainder y z)))) (lemma remainder-times-times (rewrite) (and (equal (remainder (times x y) (times x z)) (times x (remainder y z))) (equal (remainder (times x z) (times y z)) (times (remainder x y) z))) ((use (remainder-times-times-proof (x x) (y y) (z z)) (remainder-times-times-proof (x z) (y x) (z y))) (enable commutativity-of-times))) (DISABLE REMAINDER-TIMES-TIMES) (lemma remainder-times2-proof () (implies (equal (remainder a z) 0) (equal (remainder a (times z y)) (times z (remainder (quotient a z) y)))) ((enable-theory addition multiplication) (enable lessp-remainder remainder-noop remainder-plus remainder-quotient-elim remainder-times-times remainder-times1-instance remainder-zero) (do-not-induct t))) (lemma remainder-times2 (rewrite) (implies (equal (remainder a z) 0) (and (equal (remainder a (times y z)) (times z (remainder (quotient a z) y))) (equal (remainder a (times z y)) (times z (remainder (quotient a z) y))))) ((use (remainder-times2-proof (a a) (y y) (z z))) (enable commutativity-of-times))) (lemma remainder-times2-instance (rewrite) (and (equal (remainder (times x y) (times x z)) (times x (remainder y z))) (equal (remainder (times x z) (times y z)) (times (remainder x y) z))) ((enable remainder-times-times))) (lemma remainder-difference1 (rewrite) (implies (equal (remainder a c) (remainder b c)) (equal (remainder (difference a b) c) (difference (remainder a c) (remainder b c)))) ((enable lessp-remainder equal-remainder-plus-remainder remainder-plus remainder-quotient-elim remainder-times1-instance) (enable-theory addition) (do-not-induct t))) (defn double-remainder-induction (a b c) (if (zerop c) 0 (if (lessp a c) 0 (if (lessp b c) 0 (double-remainder-induction (difference a c) (difference b c) c))))) (lemma remainder-difference2 (rewrite) (implies (and (equal (remainder a c) 0) (not (equal (remainder b c) 0))) (equal (remainder (difference a b) c) (if (lessp b a) (difference c (remainder b c)) 0))) ((enable equal-remainder-plus-0 lessp-remainder remainder-noop remainder-of-non-number remainder-quotient-elim remainder-times1-instance remainder-zero) (disable times-distributes-over-plus) (enable-theory addition multiplication) (induct (double-remainder-induction a b c)))) (lemma remainder-difference3 (rewrite) (implies (and (equal (remainder b c) 0) (not (equal (remainder a c) 0))) (equal (remainder (difference a b) c) (if (lessp b a) (remainder a c) 0))) ((enable remainder-noop remainder-of-non-number remainder-zero) (enable-theory addition) (induct (double-remainder-induction a b c)))) (DISABLE REMAINDER-DIFFERENCE3) (lemma equal-remainder-difference-0 (rewrite) (equal (equal (remainder (difference a b) c) 0) (if (leq b a) (equal (remainder a c) (remainder b c)) t)) ((enable lessp-remainder remainder-difference1 remainder-of-non-number remainder-plus remainder-quotient-elim remainder-times1-instance remainder-zero) (enable-theory addition) (do-not-induct t))) (DISABLE EQUAL-REMAINDER-DIFFERENCE-0) (lemma lessp-plus-fact (rewrite) (implies (and (equal (remainder b x) 0) (equal (remainder c x) 0) (lessp b c) (lessp a x)) (equal (lessp (plus a b) c) t)) ((enable-theory addition) (induct (double-remainder-induction b c x)))) (DISABLE LESSP-PLUS-FACT) (lemma remainder-plus-fact () (implies (and (equal (remainder b x) 0) (equal (remainder c x) 0) (lessp a x)) (equal (remainder (plus a b) c) (plus a (remainder b c)))) ((enable lessp-plus-fact remainder-noop remainder-difference1) (enable-theory addition multiplication) (induct (remainder b c)))) (lemma remainder-plus-times-times-proof () (implies (lessp a b) (equal (remainder (plus a (times b c)) (times b d)) (plus a (remainder (times b c) (times b d))))) ((use (remainder-plus-fact (a a) (x b) (b (times b c)) (c (times b d)))) (enable remainder-times1-instance remainder-times2-instance) (do-not-induct t))) (lemma remainder-plus-times-times (rewrite) (implies (lessp a b) (and (equal (remainder (plus a (times b c)) (times b d)) (plus a (remainder (times b c) (times b d)))) (equal (remainder (plus a (times c b)) (times d b)) (plus a (remainder (times c b) (times d b)))))) ((use (remainder-plus-times-times-proof (a a) (b b) (c c) (d d))) (enable commutativity-of-times) (do-not-induct t))) ; REMAINDER-PLUS-TIMES-TIMES-INSTANCE is the completion of the rules ; TIMES-DISTRIBUTES-OVER-PLUS, REMAINDER-TIMES-TIMES and REMAINDER-PLUS-TIMES-TIMES (lemma remainder-plus-times-times-instance (rewrite) (implies (lessp a b) (and (equal (remainder (plus a (times b c) (times b d)) (times b e)) (plus a (times b (remainder (plus c d) e)))) (equal (remainder (plus a (times c b) (times d b)) (times e b)) (plus a (times b (remainder (plus c d) e)))))) ((enable commutativity-of-times remainder-times-times remainder-plus-times-times) (use (times-distributes-over-plus (x b) (y c) (z d))) (do-not-induct t))) (lemma remainder-remainder (rewrite) (implies (equal (remainder b a) 0) (equal (remainder (remainder n b) a) (remainder n a))) ((induct (remainder n b)) (enable remainder-plus remainder-quotient-elim remainder-zero) (enable-theory addition multiplication))) (lemma remainder-1-arg1 (rewrite) (equal (remainder 1 x) (if (equal x 1) 0 1)) ((enable difference-leq-arg1))) (lemma remainder-1-arg2 (rewrite) (equal (remainder y 1) 0)) (lemma remainder-x-x (rewrite) (equal (remainder x x) 0) ((enable equal-difference-0))) (lemma transitivity-of-divides () (implies (and (equal (remainder a b) 0) (equal (remainder b c) 0)) (equal (remainder a c) 0)) ((enable remainder remainder-noop remainder-plus) (enable-theory addition))) ; Define the available theory of remainder. To get the list of ; events to put in the theory, evaluate the following form in NQTHM at ; this point in the script. This form lists all lemmas which are ; globally enabled, and which have non-null lemma type. ; ; ; (let ((lemmas (lemmas))) ; (remove-if-not (function (lambda (x) ; (and (member x lemmas) ; (not (assoc x disabled-lemmas)) ; (not (null (nth 2 (get x 'event)))) ; (not (member x (nth 2 (get 'addition 'event)))) ; (not (member x (nth 2 (get 'multiplication 'event))))))) ; chronology)) (deftheory remainders (LESSP-REMAINDER REMAINDER-NOOP REMAINDER-OF-NON-NUMBER REMAINDER-ZERO REMAINDER-QUOTIENT-ELIM REMAINDER-ADD1 REMAINDER-PLUS EQUAL-REMAINDER-PLUS-0 REMAINDER-TIMES1 REMAINDER-TIMES1-INSTANCE REMAINDER-TIMES2 REMAINDER-TIMES2-INSTANCE REMAINDER-DIFFERENCE1 REMAINDER-DIFFERENCE2 REMAINDER-PLUS-TIMES-TIMES REMAINDER-PLUS-TIMES-TIMES-INSTANCE REMAINDER-REMAINDER REMAINDER-1-ARG1 REMAINDER-1-ARG2 REMAINDER-X-X)) ; ---------- QUOTIENT, DIVIDES ---------- (lemma quotient-noop (rewrite) (implies (equal b 1) (equal (quotient a b) (fix a)))) (lemma quotient-of-non-number (rewrite) (implies (not (numberp a)) (equal (quotient a n) (quotient 0 n)))) (lemma quotient-zero (rewrite) (implies (zerop x) (equal (quotient y x) 0))) (lemma quotient-add1 (rewrite) (implies (equal (remainder a b) 0) (equal (quotient (add1 a) b) (if (equal b 1) (add1 (quotient a b)) (quotient a b)))) ((enable quotient-noop) (enable-theory addition) (induct (remainder a b)))) (lemma equal-quotient-0 (rewrite) (equal (equal (quotient a b) 0) (or (zerop b) (lessp a b))) ((induct (quotient a b)))) (lemma quotient-sub1 (rewrite) (implies (and (not (zerop a)) (not (zerop b))) (equal (quotient (sub1 a) b) (if (equal (remainder a b) 0) (sub1 (quotient a b)) (quotient a b)))) ((enable quotient-noop equal-quotient-0) (enable-theory addition) (induct (remainder a b)))) (lemma quotient-plus-proof () (implies (equal (remainder b c) 0) (equal (quotient (plus a b) c) (plus (quotient a c) (quotient b c)))) ((enable remainder-noop) (enable-theory addition) (induct (remainder b c)))) (lemma quotient-plus (rewrite) (implies (equal (remainder a c) 0) (and (equal (quotient (plus a b) c) (plus (quotient a c) (quotient b c))) (equal (quotient (plus b a) c) (plus (quotient a c) (quotient b c))) (equal (quotient (plus x y a) c) (plus (quotient (plus x y) c) (quotient a c))))) ((use (quotient-plus-proof (a b) (b a) (c c)) (quotient-plus-proof (a a) (b b) (c c)) (quotient-plus-proof (a (plus x y)) (b a) (c c))) (enable commutativity-of-plus commutativity2-of-plus associativity-of-plus) (do-not-induct t))) ; I need QUOTIENT-TIMES-INSTANCE to prove the more general QUOTIENT-TIMES, ; but I want QUOTIENT-TIMES-INSTANCE to be tried first (i.e. come after ; QUOTIENT-TIMES in the event list.) So first, prove QUOTIENT-TIMES-INSTANCE-TEMP, ; then prove QUOTIENT-TIMES, and finally give QUOTIENT-TIMES-INSTANCE. (lemma quotient-times-instance-temp-proof () (equal (quotient (times y x) y) (if (zerop y) 0 (fix x))) ((enable times-zero commutativity-of-times difference-plus-cancellation))) (lemma quotient-times-instance-temp (rewrite) (and (equal (quotient (times y x) y) (if (zerop y) 0 (fix x))) (equal (quotient (times x y) y) (if (zerop y) 0 (fix x)))) ((use (quotient-times-instance-temp-proof (x x) (y y)) (quotient-times-instance-temp-proof (x y) (y x))) (enable commutativity-of-times))) (DISABLE QUOTIENT-TIMES-INSTANCE-TEMP) (lemma quotient-times-proof () (implies (equal (remainder a c) 0) (equal (quotient (times a b) c) (times b (quotient a c)))) ((enable-theory addition multiplication remainders) (enable quotient-plus quotient-noop equal-quotient-0 quotient-times-instance-temp) (induct (remainder a c)))) (lemma quotient-times (rewrite) (implies (equal (remainder a c) 0) (and (equal (quotient (times a b) c) (times b (quotient a c))) (equal (quotient (times b a) c) (times b (quotient a c))))) ((enable commutativity-of-times) (use (quotient-times-proof (a a) (b b) (c c))) (do-not-induct t))) (lemma quotient-times-instance (rewrite) (and (equal (quotient (times y x) y) (if (zerop y) 0 (fix x))) (equal (quotient (times x y) y) (if (zerop y) 0 (fix x)))) ((enable quotient-times-instance-temp))) (lemma quotient-times-times-proof () (equal (quotient (times x y) (times x z)) (if (zerop x) 0 (quotient y z))) ((enable-theory addition) (enable lessp-times-cancellation1 equal-times-0 times-zero commutativity-of-times times-distributes-over-difference) (induct (quotient y z)))) (lemma quotient-times-times (rewrite) (and (equal (quotient (times x y) (times x z)) (if (zerop x) 0 (quotient y z))) (equal (quotient (times x z) (times y z)) (if (zerop z) 0 (quotient x y)))) ((use (quotient-times-times-proof (x x) (y y) (z z)) (quotient-times-times-proof (x z) (y x) (z y))) (enable commutativity-of-times))) (disable quotient-times-times) (lemma quotient-difference1 (rewrite) (implies (equal (remainder a c) (remainder b c)) (equal (quotient (difference a b) c) (difference (quotient a c) (quotient b c)))) ((enable-theory addition multiplication remainders) (enable quotient-plus quotient-times-instance equal-remainder-plus-remainder) (do-not-induct t))) (lemma quotient-lessp-arg1 (rewrite) (implies (lessp a b) (equal (quotient a b) 0))) (lemma quotient-difference2 (rewrite) (implies (and (equal (remainder a c) 0) (not (equal (remainder b c) 0))) (equal (quotient (difference a b) c) (if (lessp b a) (difference (quotient a c) (add1 (quotient b c))) 0))) ((enable equal-quotient-0 equal-remainder-plus-0 quotient-times-instance quotient-zero) (disable times-distributes-over-plus equal-remainder-difference-0 remainder-difference3) (enable-theory addition multiplication remainders) (induct (double-remainder-induction a b c)))) (lemma quotient-difference3 (rewrite) (implies (and (equal (remainder b c) 0) (not (equal (remainder a c) 0))) (equal (quotient (difference a b) c) (if (lessp b a) (difference (quotient a c) (quotient b c)) 0))) ((enable equal-quotient-0 equal-remainder-plus-0 quotient-lessp-arg1 quotient-times-instance quotient-zero) (disable times-distributes-over-plus equal-remainder-difference-0 remainder-difference3) (enable-theory addition multiplication remainders) (induct (double-remainder-induction a b c)))) (lemma remainder-equals-its-first-argument (rewrite) (equal (equal a (remainder a b)) (and (numberp a) (or (zerop b) (lessp a b)))) ((induct (remainder a b)) (enable lessp-remainder remainder-noop remainder-zero))) (DISABLE REMAINDER-EQUALS-ITS-FIRST-ARGUMENT) (lemma quotient-remainder-times (rewrite) (equal (quotient (remainder x (times a b)) a) (remainder (quotient x a) b)) ((enable-theory addition multiplication remainders) (enable ;lessp-plus-times2 remainder-equals-its-first-argument quotient-noop quotient-plus quotient-times-instance quotient-zero) (do-not-induct t))) (lemma quotient-remainder (rewrite) (implies (equal (remainder c a) 0) (equal (quotient (remainder b c) a) (remainder (quotient b a) (quotient c a)))) ((enable-theory addition multiplication remainders) (enable quotient-noop quotient-plus quotient-remainder-times quotient-times-instance quotient-zero) (do-not-induct t))) (lemma quotient-remainder-instance (rewrite) (equal (quotient (remainder x (times a b)) a) (remainder (quotient x a) b)) ((enable quotient-remainder quotient-times-instance remainder-times1-instance) (do-not-induct t))) (lemma quotient-plus-fact () (implies (and (equal (remainder b x) 0) (equal (remainder c x) 0) (lessp a x)) (equal (quotient (plus a b) c) (quotient b c))) ((enable quotient-lessp-arg1 lessp-plus-fact) (enable-theory addition multiplication remainders) (induct (quotient b c)))) (lemma quotient-plus-times-times-proof () (implies (lessp a b) (equal (quotient (plus a (times b c)) (times b d)) (quotient (times b c) (times b d)))) ((use (quotient-plus-fact (a a) (x b) (b (times b c)) (c (times b d)))) (enable remainder-times1-instance) (do-not-induct t))) (lemma quotient-plus-times-times (rewrite) (implies (lessp a b) (and (equal (quotient (plus a (times b c)) (times b d)) (quotient (times b c) (times b d))) (equal (quotient (plus a (times b c)) (times b d)) (quotient (times b c) (times b d))))) ((use (quotient-plus-times-times-proof (a a) (b b) (c c) (d d))) (enable commutativity-of-times) (do-not-induct t))) ; QUOTIENT-PLUS-TIMES-TIMES-INSTANCE is the completion of the rules ; QUOTIENT-TIMES-TIMES, QUOTIENT-PLUS-TIMES-TIMES and TIMES-DISTRIBUTES-OVER-PLUS (lemma quotient-plus-times-times-instance (rewrite) (implies (lessp a b) (and (equal (quotient (plus a (times b c) (times b d)) (times b e)) (if (zerop b) 0 (quotient (plus c d) e))) (equal (quotient (plus a (times c b) (times d b)) (times e b)) (if (zerop b) 0 (quotient (plus d c) e))))) ((enable commutativity-of-times commutativity-of-plus quotient-times-times quotient-plus-times-times) (use (times-distributes-over-plus (x b) (y c) (z d))) (do-not-induct t))) (lemma quotient-quotient (rewrite) (equal (quotient (quotient b a) c) (quotient b (times a c))) ((enable-theory addition multiplication remainders) (disable times-distributes-over-plus) (enable quotient-lessp-arg1 quotient-plus quotient-plus-times-times quotient-times-instance quotient-times-times quotient-noop quotient-zero) (do-not-induct t))) (lemma leq-quotient () (implies (lessp a b) (leq (quotient a c) (quotient b c))) ((induct (double-remainder-induction a b c)) (enable quotient-lessp-arg1 quotient-zero))) (lemma quotient-1-arg2 (rewrite) (equal (quotient n 1) (fix n))) (lemma quotient-1-arg1-casesplit () (or (zerop n) (equal n 1) (lessp 1 n))) (lemma quotient-1-arg1 (rewrite) (equal (quotient 1 n) (if (equal n 1) 1 0)) ((enable quotient-lessp-arg1) (use (quotient-1-arg1-casesplit)))) (lemma quotient-x-x (rewrite) (implies (not (zerop x)) (equal (quotient x x) 1)) ((enable difference-x-x))) (lemma lessp-quotient (rewrite) (equal (lessp (quotient i j) i) (and (not (zerop i)) (not (equal j 1))))) ;; Metalemma to cancel quotient-times expressions ;; ex. ;; (quotient (times a b) (times c (times d a))) -> ;; (if (not (zerop a)) ;; (quotient (fix b) (times c d)) ;; (zero)) ;; (defn cancel-quotient-times (x) (if (and (equal (car x) 'quotient) (equal (caadr x) 'times) (equal (caaddr x) 'times)) (let ((inboth (bagint (times-fringe (cadr x)) (times-fringe (caddr x))))) (if (listp inboth) (list 'if (and-not-zerop-tree inboth) (list 'quotient (times-tree (bagdiff (times-fringe (cadr x)) inboth)) (times-tree (bagdiff (times-fringe (caddr x)) inboth))) '(zero)) x)) x)) (lemma zerop-makes-quotient-zero-bridge (rewrite) (implies (and (equal (car x) 'times) (equal (car y) 'times) (not (eval$ t (and-not-zerop-tree (bagint (times-fringe x) (times-fringe y))) a))) (equal (quotient (times (eval$ t (cadr x) a) (eval$ t (caddr x) a)) (times (eval$ t (cadr y) a) (eval$ t (caddr y) a))) 0)) ((use (zerop-makes-times-tree-zero (x (bagint (times-fringe x) (times-fringe y))) (y (times-fringe x))) (zerop-makes-times-tree-zero (x (bagint (times-fringe x) (times-fringe y))) (y (times-fringe y)))) (enable AND-NOT-ZEROP-TREE BAGINT DELETE EQUAL-QUOTIENT-0 EQUAL-TIMES-0 EVAL$-TIMES ;MEMBER-CONS ;MEMBER-NON-LIST SUBBAGP-BAGINT1 SUBBAGP-BAGINT2 TIMES-FRINGE TIMES-TREE TIMES-TREE-APPEND TIMES-TREE-OF-TIMES-FRINGE ZEROP-MAKES-LESSP-FALSE-BRIDGE))) (disable zerop-makes-quotient-zero-bridge) (lemma eval$-quotient-times-tree-bagdiff (rewrite) (implies (and (subbagp x y) (subbagp x z) (eval$ t (and-not-zerop-tree x) a)) (equal (quotient (eval$ t (times-tree (bagdiff y x)) a) (eval$ t (times-tree (bagdiff z x)) a)) (quotient (eval$ t (times-tree y) a) (eval$ t (times-tree z) a)))) ((enable AND-NOT-ZEROP-TREE BAGDIFF EQUAL-QUOTIENT-0 EVAL$-TIMES-MEMBER NUMBERP-EVAL$-TIMES-TREE QUOTIENT-TIMES-TIMES SUBBAGP SUBBAGP-CDR1 SUBBAGP-CDR2 TIMES-TREE ZEROP-MAKES-TIMES-TREE-ZERO))) (disable eval$-quotient-times-tree-bagdiff) (lemma correctness-of-cancel-quotient-times ((meta quotient)) (equal (eval$ t x a) (eval$ t (cancel-quotient-times x) a)) ((enable CANCEL-QUOTIENT-TIMES EVAL$-QUOTIENT-TIMES-TREE-BAGDIFF EVAL$-QUOTIENT EVAL$-TIMES SUBBAGP-BAGINT1 SUBBAGP-BAGINT2 TIMES-TREE-OF-TIMES-FRINGE ZEROP-MAKES-QUOTIENT-ZERO-BRIDGE))) ; Define the available theory of quotient. To get the list of events to ; put in the theory, evaluate the following form in NQTHM at this point ; in the script. This form lists all lemmas which are globally enabled, ; and which have non-null lemma type. ; ; ; (let ((lemmas (lemmas))) ; (remove-if-not (function (lambda (x) ; (and (member x lemmas) ; (not (assoc x disabled-lemmas)) ; (not (null (nth 2 (get x 'event)))) ; (not (member x (nth 2 (get 'addition 'event)))) ; (not (member x (nth 2 (get 'multiplication 'event)))) ; (not (member x (nth 2 (get 'remainders 'event))))))) ; chronology)) (deftheory quotients (QUOTIENT-NOOP QUOTIENT-OF-NON-NUMBER QUOTIENT-ZERO QUOTIENT-ADD1 EQUAL-QUOTIENT-0 QUOTIENT-SUB1 QUOTIENT-PLUS QUOTIENT-TIMES QUOTIENT-TIMES-INSTANCE QUOTIENT-DIFFERENCE1 QUOTIENT-LESSP-ARG1 QUOTIENT-DIFFERENCE2 QUOTIENT-DIFFERENCE3 QUOTIENT-REMAINDER-TIMES QUOTIENT-REMAINDER QUOTIENT-REMAINDER-INSTANCE QUOTIENT-PLUS-TIMES-TIMES QUOTIENT-PLUS-TIMES-TIMES-INSTANCE QUOTIENT-QUOTIENT QUOTIENT-1-ARG2 QUOTIENT-1-ARG1 QUOTIENT-X-X LESSP-QUOTIENT correctness-of-cancel-quotient-times)) ;;; exp, log, and gcd (defn exp (i j) (if (zerop j) 1 (times i (exp i (sub1 j))))) (defn log (base n) (if (lessp base 2) 0 (if (zerop n) 0 (add1 (log base (quotient n base)))))) (defn gcd (x y) (if (zerop x) (fix y) (if (zerop y) x (if (lessp x y) (gcd x (difference y x)) (gcd (difference x y) y)))) ((ord-lessp (cons (add1 x) (fix y))))) (lemma remainder-exp (rewrite) (implies (not (zerop k)) (equal (remainder (exp n k) n) 0)) ((enable exp remainder-times1-instance))) (defn double-number-induction (i j) (if (zerop i) 0 (if (zerop j) 0 (double-number-induction (sub1 i) (sub1 j))))) (lemma remainder-exp-exp (rewrite) (implies (leq i j) (equal (remainder (exp a j) (exp a i)) 0)) ((enable exp remainder-1-arg2 remainder-times2-instance) (enable-theory addition multiplication) (induct (double-number-induction i j)))) (lemma quotient-exp (rewrite) (implies (not (zerop k)) (equal (quotient (exp n k) n) (if (zerop n) 0 (exp n (sub1 k))))) ((enable exp quotient-times-instance))) (lemma exp-zero (rewrite) (implies (zerop k) (equal (exp n k) 1)) ((enable exp))) (lemma exp-add1 (rewrite) (equal (exp n (add1 k)) (times n (exp n k))) ((enable exp))) (lemma exp-plus (rewrite) (equal (exp i (plus j k)) (times (exp i j) (exp i k))) ((enable exp associativity-of-times commutativity-of-times))) (lemma exp-0-arg1 (rewrite) (equal (exp 0 k) (if (zerop k) 1 0)) ((enable exp))) (lemma exp-1-arg1 (rewrite) (equal (exp 1 k) 1) ((enable exp))) (lemma exp-0-arg2 (rewrite) (equal (exp n 0) 1) ((enable exp))) (lemma exp-times (rewrite) (equal (exp (times i j) k) (times (exp i k) (exp j k))) ((enable exp associativity-of-times commutativity2-of-times exp-zero))) (lemma exp-exp (rewrite) (equal (exp (exp i j) k) (exp i (times j k))) ((enable exp exp-zero exp-1-arg1 exp-plus exp-times))) (lemma equal-exp-0 (rewrite) (equal (equal (exp n k) 0) (and (zerop n) (not (zerop k)))) ((enable exp equal-times-0) (induct (exp n k)))) (lemma equal-exp-1 (rewrite) (equal (equal (exp n k) 1) (if (zerop k) t (equal n 1))) ((enable exp times-zero times-add1))) (lemma exp-difference (rewrite) (implies (and (leq c b) (not (zerop a))) (equal (exp a (difference b c)) (quotient (exp a b) (exp a c)))) ((enable exp) (enable-theory addition multiplication remainders quotients))) (deftheory exponentiation (equal-exp-0 equal-exp-1 exp-exp exp-add1 exp-times exp-1-arg1 exp-zero exp-0-arg2 exp-0-arg1 exp-difference exp-plus quotient-exp remainder-exp-exp remainder-exp)) (lemma equal-log-0 (rewrite) (equal (equal (log base n) 0) (or (lessp base 2) (zerop n))) ((enable log) (induct (log base n)))) (lemma log-0 (rewrite) (implies (zerop n) (equal (log base n) 0)) ((enable log))) (lemma log-1 (rewrite) (implies (lessp 1 base) (equal (log base 1) 1)) ((enable log) (induct (log base n)))) (defn double-log-induction (base a b) (if (lessp base 2) 0 (if (zerop a) 0 (if (zerop b) 0 (double-log-induction base (quotient a base) (quotient b base)))))) (lemma leq-log-log nil (implies (leq n m) (leq (log c n) (log c m))) ((enable log) (induct (double-log-induction c n m)) (use (leq-quotient (a n) (b m) (c c))))) (lemma log-quotient (rewrite) (implies (lessp 1 c) (equal (log c (quotient n c)) (sub1 (log c n)))) ((enable log))) (lemma log-quotient-times-proof () (implies (lessp 1 c) (equal (log c (quotient n (times c m))) (sub1 (log c (quotient n m))))) ((enable log) (enable-theory addition multiplication remainders quotients))) (lemma log-quotient-times (rewrite) (implies (lessp 1 c) (and (equal (log c (quotient n (times c m))) (sub1 (log c (quotient n m)))) (equal (log c (quotient n (times m c))) (sub1 (log c (quotient n m)))))) ((use (log-quotient-times-proof (c c) (n n) (m m))) (enable commutativity-of-times))) (lemma log-quotient-exp (rewrite) (implies (lessp 1 c) (equal (log c (quotient n (exp c m))) (difference (log c n) m))) ((enable exp log log-quotient-times) (enable-theory addition multiplication remainders quotients))) (lemma log-times-proof () (implies (and (lessp 1 c) (not (zerop n))) (equal (log c (times c n)) (add1 (log c n)))) ((enable log) (enable-theory addition multiplication remainders quotients))) (lemma log-times (rewrite) (implies (and (lessp 1 c) (not (zerop n))) (and (equal (log c (times c n)) (add1 (log c n))) (equal (log c (times n c)) (add1 (log c n))))) ((use (log-times-proof (c c) (n n))) (enable commutativity-of-times))) (lemma log-times-exp-proof () (implies (and (lessp 1 c) (not (zerop n))) (equal (log c (times n (exp c m))) (plus (log c n) m))) ((enable log exp) (enable-theory addition multiplication remainders quotients))) (lemma log-times-exp (rewrite) (implies (and (lessp 1 c) (not (zerop n))) (and (equal (log c (times n (exp c m))) (plus (log c n) m)) (equal (log c (times (exp c m) n)) (plus (log c n) m)))) ((use (log-times-exp-proof (c c) (n n) (m m))) (enable commutativity-of-times))) (lemma log-exp (rewrite) (implies (lessp 1 c) (equal (log c (exp c n)) (add1 n))) ((enable log exp log-1) (enable-theory addition multiplication remainders quotients))) (deftheory logs (LOG-EXP LOG-TIMES-EXP LOG-TIMES LOG-QUOTIENT-EXP LOG-QUOTIENT-TIMES LOG-QUOTIENT LOG-1 LOG-0 EQUAL-LOG-0 EXP-EXP)) (lemma commutativity-of-gcd (rewrite) (equal (gcd b a) (gcd a b)) ((enable gcd) (enable-theory addition))) (defn single-number-induction (n) (if (zerop n) 0 (single-number-induction (sub1 n)))) (lemma gcd-0 (rewrite) (and (equal (gcd 0 x) (fix x)) (equal (gcd x 0) (fix x))) ((enable gcd))) (lemma gcd-1 (rewrite) (and (equal (gcd 1 x) 1) (equal (gcd x 1) 1)) ((enable gcd) (enable-theory addition) (induct (single-number-induction x)))) (lemma equal-gcd-0 (rewrite) (equal (equal (gcd a b) 0) (and (zerop a) (zerop b))) ((enable gcd) (enable-theory addition) (induct (gcd a b)))) (lemma lessp-gcd (rewrite) (implies (not (zerop b)) (and (equal (lessp b (gcd a b)) f) (equal (lessp b (gcd b a)) f))) ((enable gcd commutativity-of-gcd) (enable-theory addition))) (lemma gcd-plus-instance-temp-proof () (equal (gcd a (plus a b)) (gcd a b)) ((enable gcd commutativity-of-gcd) (enable-theory addition) (induct (gcd a b)))) (lemma gcd-plus-instance-temp (rewrite) (and (equal (gcd a (plus a b)) (gcd a b)) (equal (gcd a (plus b a)) (gcd a b))) ((enable commutativity-of-plus) (use (gcd-plus-instance-temp-proof (a a) (b b))) (do-not-induct t))) (lemma gcd-plus-proof () (implies (equal (remainder b a) 0) (equal (gcd a (plus b c)) (gcd a c))) ((enable gcd commutativity-of-gcd gcd-1 gcd-plus-instance-temp) (enable-theory addition) (induct (remainder b a)))) (lemma gcd-plus (rewrite) (implies (equal (remainder b a) 0) (and (equal (gcd a (plus b c)) (gcd a c)) (equal (gcd a (plus c b)) (gcd a c)) (equal (gcd (plus b c) a) (gcd a c)) (equal (gcd (plus c b) a) (gcd a c)))) ((enable commutativity-of-plus commutativity-of-gcd) (use (gcd-plus-proof (a a) (b b) (c c))) (do-not-induct t))) (lemma gcd-plus-instance (rewrite) (and (equal (gcd a (plus a b)) (gcd a b)) (equal (gcd a (plus b a)) (gcd a b))) ((enable gcd-plus-instance-temp) (do-not-induct t))) (lemma remainder-gcd (rewrite) (and (equal (remainder a (gcd a b)) 0) (equal (remainder b (gcd a b)) 0)) ((enable gcd) (enable-theory addition remainders))) (lemma distributivity-of-times-over-gcd-proof () (equal (gcd (times x z) (times y z)) (times z (gcd x y))) ((enable gcd commutativity-of-gcd gcd-0 gcd-plus) (enable-theory addition multiplication remainders))) (lemma distributivity-of-times-over-gcd (rewrite) (and (equal (gcd (times x z) (times y z)) (times z (gcd x y))) (equal (gcd (times z x) (times y z)) (times z (gcd x y))) (equal (gcd (times x z) (times z y)) (times z (gcd x y))) (equal (gcd (times z x) (times z y)) (times z (gcd x y)))) ((use (distributivity-of-times-over-gcd-proof (x x) (y y) (z z))) (enable commutativity-of-times) (do-not-induct t))) (lemma gcd-is-the-greatest nil (implies (and (not (zerop x)) (not (zerop y)) (equal (remainder x z) 0) (equal (remainder y z) 0)) (leq z (gcd x y))) ((enable gcd commutativity-of-gcd distributivity-of-times-over-gcd equal-gcd-0) (enable-theory addition multiplication remainders) (do-not-induct t))) (lemma common-divisor-divides-gcd (rewrite) (implies (and (equal (remainder x z) 0) (equal (remainder y z) 0)) (equal (remainder (gcd x y) z) 0)) ((enable gcd commutativity-of-gcd distributivity-of-times-over-gcd equal-gcd-0) (enable-theory addition multiplication remainders) (do-not-induct t))) ; We prove ASSOCIATIVITY-OF-GCD and COMMUTATIVITY2-OF-GCD roughly the same way. ; Use GCD-IS-THE-GREATEST twice to show that each side of the equality is ; less than or equal to the other side. (lemma associativity-of-gcd-zero-case () (implies (or (zerop a) (zerop b) (zerop c)) (equal (gcd (gcd a b) c) (gcd a (gcd b c)))) ((enable gcd gcd-0) (do-not-induct t))) (lemma associativity-of-gcd (rewrite) (equal (gcd (gcd a b) c) (gcd a (gcd b c))) ((enable equal-gcd-0 remainder-gcd) (use (gcd-is-the-greatest (x a) (y (gcd b c)) (z (gcd (gcd a b) c))) (gcd-is-the-greatest (x (gcd a b)) (y c) (z (gcd a (gcd b c)))) (associativity-of-gcd-zero-case (a a) (b b) (c c)) (transitivity-of-divides (a a) (b (gcd a b)) (c (gcd (gcd a b) c))) (transitivity-of-divides (a b) (b (gcd a b)) (c (gcd (gcd a b) c))) (transitivity-of-divides (a b) (b (gcd b c)) (c (gcd a (gcd b c)))) (transitivity-of-divides (a c) (b (gcd b c)) (c (gcd a (gcd b c)))) (common-divisor-divides-gcd (x b) (y c) (z (gcd (gcd a b) c))) (common-divisor-divides-gcd (x a) (y b) (z (gcd a (gcd b c)))) ) (do-not-induct t))) (lemma commutativity2-of-gcd-zero-case () (implies (or (zerop a) (zerop b) (zerop c)) (equal (gcd b (gcd a c)) (gcd a (gcd b c)))) ((enable gcd gcd-0 commutativity-of-gcd) (do-not-induct t))) (lemma commutativity2-of-gcd (rewrite) (equal (gcd b (gcd a c)) (gcd a (gcd b c))) ((enable equal-gcd-0 remainder-gcd) (use (gcd-is-the-greatest (x a) (y (gcd b c)) (z (gcd b (gcd a c)))) (gcd-is-the-greatest (x b) (y (gcd a c)) (z (gcd a (gcd b c)))) (commutativity2-of-gcd-zero-case (a a) (b b) (c c)) (transitivity-of-divides (a a) (b (gcd a c)) (c (gcd b (gcd a c)))) (transitivity-of-divides (a c) (b (gcd a c)) (c (gcd b (gcd a c)))) (transitivity-of-divides (a b) (b (gcd b c)) (c (gcd a (gcd b c)))) (transitivity-of-divides (a c) (b (gcd b c)) (c (gcd a (gcd b c)))) (common-divisor-divides-gcd (x b) (y c) (z (gcd b (gcd a c)))) (common-divisor-divides-gcd (x a) (y c) (z (gcd a (gcd b c)))) ) (do-not-induct t))) (lemma gcd-x-x (rewrite) (equal (gcd x x) (fix x)) ((enable gcd) (enable-theory addition) (induct (single-number-induction x)))) (lemma gcd-idempotence (rewrite) (and (equal (gcd x (gcd x y)) (gcd x y)) (equal (gcd y (gcd x y)) (gcd x y))) ((enable gcd gcd-x-x gcd-plus remainder-gcd gcd-1 commutativity-of-gcd) (enable-theory addition) (induct (gcd x y)))) (deftheory gcds (commutativity2-of-gcd associativity-of-gcd common-divisor-divides-gcd distributivity-of-times-over-gcd lessp-gcd equal-gcd-0 gcd-0 gcd-idempotence gcd-x-x remainder-gcd gcd-plus gcd-plus-instance gcd-1 commutativity-of-gcd)) (deftheory naturals (addition multiplication remainders quotients exponentiation logs gcds)) ; ------------------------------------------------------------ ; was integers.events ; ------------------------------------------------------------ ;; By Matt Kaufmann, modified from earlier integer library of Bill ;; Bevier and Matt Wilding. A few functions (even ILESSP) have ;; been changed, but I expect the functionality of this library to ;; include all the functionality of the old one in most or even all ;; cases. ;; Modified from /local/src/nqthm-libs/integers.events to get ILEQ ;; expressed in terms of ILESSP and IDIFFERENCE in terms of INEG and ;; IPLUS. There are other changes too. The highlights are the new ;; metalemmas. ;; I'm going to leave the eval$ rules on that are proved here, and ;; leave eval$ off. ;; My intention is that this library be used in a mode in which ILEQ ;; and IDIFFERENCE are left enabled. Otherwise, the aforementioned ;; meta lemmas may not be very useful, and also a number of additional ;; replacement rules may be needed. ;; There are three theories created by this library. INTEGER-DEFNS is ;; a list of definitions of all integer functions (not including the ;; cancellation metafunctions and their auxiliaries, though), except ;; that ILEQ and IDIFFERENCE have been omitted. This is a useful ;; theory for an ENABLE-THEORY hint when one simply wants to blast all ;; integer functions open, and it's also useful if one wants to close ;; them down with a DISABLE-THEORY hint (perhaps to go with an ;; (ENABLE-THEORY T) hint). Second, ALL-INTEGER-DEFNS is the same as ;; INTEGER-DEFNS except that ILEQ and IDIFFERENCE are included in this ;; one. Finally, INTEGERS is a list of all events to be "exported as ;; enabled" from this file when working in a mode where everything not ;; enabled by an ENABLE-THEORY hint is to be disabled. Notice that ;; some rewrite rules have been included that might appear to be ;; unnecessary in light of the metalemmas; that's because metalemmas ;; only work on tame terms. However, there's no guarantee that the ;; rewrite rules alone will prove very useful (on non-tame terms). ;; Also notice that INTEGER-DEFNS is disjoint from INTEGERS, since we ;; expect the basic definitions (other than ILEQ and IDIFFERENCE) to ;; remain disabled. ;; It's easy to see what I have and haven't placed in INTEGERS, since ;; I'll simply comment out the event names that I want to exclude (see ;; end of this file). ;; One might wish to consider changing (fix-int (minus ...)) in some ;; of the definitions below to (ineg ...). ;; The following meta rules are in this library. ;; (A little documentation added by Matt Wilding July 90) ;; ;; CORRECTNESS-OF-CANCEL-INEG ;; cancel the first argument of an iplus term with a member of the second ;; argument. ;; ;; ex: (iplus (ineg y) (iplus (ineg x) (iplus y z))) ;; --> ;; (iplus (ineg x) (fix-int z)) ;; ;; CORRECTNESS-OF-CANCEL-IPLUS ;; cancel the sides of an equality of iplus sums ;; ;; ex: (equal (iplus x (iplus y z)) (iplus a (iplus z x))) ;; --> ;; (equal (fix-int y) (fix-int a)) ;; ;; CORRECTNESS-OF-CANCEL-IPLUS-ILESSP ;; cancel the sides of an ilessp inequality of sums ;; ;; ex: (ilessp (iplus x (iplus y z)) (iplus a (iplus z x))) ;; --> ;; (ilessp y a) ;; ;; CORRECTNESS-OF-CANCEL-ITIMES ;; cancel the sides of an equality of itimes products ;; ;; ex: (equal (itimes x (itimes y z)) (itimes a (itimes z x))) ;; --> ;; (if (equal (itimes x z) '0) ;; t ;; (equal (fix-int y) (fix-int a))) ;; ;; CORRECTNESS-OF-CANCEL-ITIMES-ILESSP ;; cancel the sides of an inequality of itimes products ;; ;; ex: (ilessp (itimes x (itimes y z)) (itimes a (itimes z x))) ;; --> ;; (if (ilessp (itimes x z) '0) ;; (ilessp a y) ;; (if (ilessp 0 (itimes x z)) ;; (ilessp y a) ;; f)) ;; ;; CORRECTNESS-OF-CANCEL-ITIMES-FACTORS ;; cancel factors in equality terms ;; ex: (equal (iplus (itimes x y) x) (itimes z x)) ;; --> ;; (if (equal (fix-int x) '0) ;; t ;; (equal (fix-int (plus y 1)) (fix-int z))) ;; ;; CORRECTNESS-OF-CANCEL-ITIMES-ILESSP-FACTORS ;; cancel factors in ilessp terms ;; ex: (equal (iplus (itimes x y) x) (itimes z x)) ;; --> ;; (if (ilessp x '0) ;; (ilessp z (iplus y 1)) ;; (if (ilessp '0 x) ;; (ilessp (iplus y '1) z) ;; f)) ;; ;; CORRECTNESS-OF-CANCEL-FACTORS-0 ;; factor one side of equality when other side is constant 0 ;; ;; ex: (equal (iplus x (itimes x y)) '0) ;; --> ;; (or (equal (fix-int (iplus '1 y)) '0) ;; (equal (fix-int x) '0)) ;; ;; CORRECTNESS-OF-CANCEL-FACTORS-ILESSP-0 ;; factor one side of inequality when other side is constant 0 ;; ;; ex: (ilessp (iplus x (itimes x y)) '0) ;; --> ;; (or (and (ilessp (iplus '1 y) '0) ;; (ilessp '0 x)) ;; (and (ilessp '0 (iplus '1 y)) ;; (ilessp x '0))) ;; ;; CORRECTNESS-OF-CANCEL-INEG-TERMS-FROM-EQUALITY ;; rewrite equality to remove ineg terms ;; ;; ex: (equal (iplus (ineg x) (ineg y)) (iplus (ineg z) w)) ;; --> ;; (equal (fix-int z) (iplus x (iplus y w))) ;; ;; CORRECTNESS-OF-CANCEL-INEG-TERMS-FROM-INEQUALITY ;; rewrite inequalities to remove ineg terms ;; ;; ex: (ilessp (iplus (ineg x) (ineg y)) (iplus (ineg z) w)) ;; --> ;; (ilessp (fix-int z) (iplus x (iplus y w))) ;(note-lib "/local/src/nqthm-libs/naturals") ;(compile-uncompiled-defns "xxx") ; -------------------------------------------------------------------------------- ; Integers ; -------------------------------------------------------------------------------- #| The function below has no AND or OR, for efficiency (defn integerp (x) (or (numberp x) (and (negativep x) (not (zerop (negative-guts x)))))) |# (DEFN INTEGERP (X) (COND ((NUMBERP X) T) ((NEGATIVEP X) (NOT (ZEROP (NEGATIVE-GUTS X)))) (T F))) (defn fix-int (x) (if (integerp x) x 0)) ;; Even though I'll include a definition for izerop here, I'll ;; often avoid using it. (defn izerop (i) (equal (fix-int i) 0)) #| old version: (defn izerop (i) (if (integerp i) (equal i 0) t)) |# (defn ilessp (i j) (if (negativep i) (if (negativep j) (lessp (negative-guts j) (negative-guts i)) (if (equal i (minus 0)) (lessp 0 j) t)) (if (negativep j) f (lessp i j)))) (defn ileq (i j) ;; I expect this to be enabled, in analogy to leq. (not (ilessp j i))) (defn iplus (x y) (if (negativep x) (if (negativep y) (if (and (zerop (negative-guts x)) (zerop (negative-guts y))) 0 (minus (plus (negative-guts x) (negative-guts y)))) (if (lessp y (negative-guts x)) (minus (difference (negative-guts x) y)) (difference y (negative-guts x)))) (if (negativep y) (if (lessp x (negative-guts y)) (minus (difference (negative-guts y) x)) (difference x (negative-guts y))) (plus x y)))) (defn ineg (x) (if (negativep x) (negative-guts x) (if (zerop x) 0 (minus x)))) (defn idifference (x y) ;; I find it troublesome to reason separately about idifference, ;; especially for metalemmas, so I intend to keep it enabled. (iplus x (ineg y))) (defn iabs (i) (if (negativep i) (negative-guts i) (fix i))) (defn itimes (i j) (if (negativep i) (if (negativep j) (times (negative-guts i) (negative-guts j)) (fix-int (minus (times (negative-guts i) j)))) (if (negativep j) (fix-int (minus (times i (negative-guts j)))) (times i j)))) (defn iquotient (i j) (if (equal (fix-int j) 0) 0 (if (negativep i) (if (negativep j) (if (equal (remainder (negative-guts i) (negative-guts j)) 0) (quotient (negative-guts i) (negative-guts j)) (add1 (quotient (negative-guts i) (negative-guts j)))) (if (equal (remainder (negative-guts i) j) 0) (fix-int (minus (quotient (negative-guts i) j))) (fix-int (minus (add1 (quotient (negative-guts i) j)))))) (if (negativep j) (fix-int (minus (quotient i (negative-guts j)))) (quotient i j))))) (defn iremainder (i j) (idifference i (itimes j (iquotient i j)))) (defn idiv (i j) (if (equal (fix-int j) 0) 0 (if (negativep i) (if (negativep j) (quotient (negative-guts i) (negative-guts j)) (if (equal (remainder (negative-guts i) j) 0) (fix-int (minus (quotient (negative-guts i) j))) (fix-int (minus (add1 (quotient (negative-guts i) j)))))) (if (negativep j) (if (equal (remainder i (negative-guts j)) 0) (fix-int (minus (quotient i (negative-guts j)))) (fix-int (minus (add1 (quotient i (negative-guts j)))))) (quotient i j))))) (defn imod (i j) (idifference (fix-int i) (itimes j (idiv i j)))) (defn iquo (i j) (if (equal (fix-int j) 0) 0 (if (negativep i) (if (negativep j) (quotient (negative-guts i) (negative-guts j)) (fix-int (minus (quotient (negative-guts i) j)))) (if (negativep j) (fix-int (minus (quotient i (negative-guts j)))) (quotient i j))))) (defn irem (i j) (idifference (fix-int i) (itimes j (iquo i j)))) ; ---------- DEFTHEORY events for definitions ---------- (deftheory integer-defns ;; omits ILEQ and IDIFFERENCE and IZEROP (integerp fix-int ilessp iplus ineg iabs itimes iquotient iremainder idiv imod iquo irem)) (deftheory all-integer-defns (integerp fix-int izerop ilessp ileq iplus ineg idifference iabs itimes iquotient iremainder idiv imod iquo irem)) (disable integerp) (disable fix-int) (disable ilessp) (disable iplus) (disable ineg) (disable iabs) (disable itimes) ;; I've disabled the rest later in the file, just because the lemmas ;; about division were (re-)proved with the remaining functions enabled. ; ---------- INTEGERP ---------- (lemma integerp-fix-int (rewrite) (integerp (fix-int x)) ((enable integerp fix-int))) (lemma integerp-iplus (rewrite) (integerp (iplus x y)) ((enable integerp iplus))) (lemma integerp-idifference (rewrite) (integerp (idifference x y)) ((enable integerp-iplus idifference))) (lemma integerp-ineg (rewrite) (integerp (ineg x)) ((enable integerp ineg))) (lemma integerp-iabs (rewrite) (integerp (iabs x)) ((enable integerp iabs))) (lemma integerp-itimes (rewrite) (integerp (itimes x y)) ((enable integerp itimes fix-int))) ; ---------- FIX-INT ---------- ;; The first of these, FIX-INT-REMOVER, is potentially dangerous from ;; a backchaining point of view, but I believe it's necessary. At least ;; the lemmas below it should go a long way toward preventing its application. (lemma fix-int-remover (rewrite) (implies (integerp x) (equal (fix-int x) x)) ((enable fix-int integerp))) (lemma fix-int-fix-int (rewrite) (equal (fix-int (fix-int x)) (fix-int x)) ((enable fix-int integerp))) (lemma fix-int-iplus (rewrite) (equal (fix-int (iplus a b)) (iplus a b)) ((enable fix-int integerp iplus))) (lemma fix-int-idifference (rewrite) (equal (fix-int (idifference a b)) (idifference a b)) ((enable fix-int-iplus idifference))) (lemma fix-int-ineg (rewrite) (equal (fix-int (ineg x)) (ineg x)) ((enable fix-int integerp ineg))) (lemma fix-int-iabs (rewrite) (equal (fix-int (iabs x)) (iabs x)) ((enable integerp fix-int iabs))) (lemma fix-int-itimes (rewrite) (equal (fix-int (itimes x y)) (itimes x y)) ((enable integerp itimes fix-int))) ; ---------- INEG ---------- (lemma ineg-iplus (rewrite) (equal (ineg (iplus a b)) (iplus (ineg a) (ineg b))) ((enable iplus ineg plus-zero-arg2))) (lemma ineg-ineg (rewrite) (equal (ineg (ineg x)) (fix-int x)) ((enable ineg fix-int integerp))) (lemma ineg-fix-int (rewrite) (equal (ineg (fix-int x)) (ineg x)) ((enable ineg fix-int integerp))) (lemma ineg-of-non-integerp (rewrite) (implies (not (integerp x)) (equal (ineg x) 0)) ((enable ineg integerp))) ;; I don't want the backchaining to slow down the prover. (disable ineg-of-non-integerp) (lemma ineg-0 (rewrite) (equal (ineg 0) 0) ((enable ineg))) ; ---------- IPLUS ---------- ;; The first two of these really aren't necessary, in light ;; of the cancellation metalemma. (lemma iplus-left-id (rewrite) (implies (not (integerp x)) (equal (iplus x y) (fix-int y))) ((enable integerp iplus fix-int))) ;; I don't want the backchaining to slow down the prover. (disable iplus-left-id) (lemma iplus-right-id (rewrite) (implies (not (integerp y)) (equal (iplus x y) (fix-int x))) ((enable integerp iplus fix-int plus-zero-arg2))) ;; I don't want the backchaining to slow down the prover. (disable iplus-right-id) (lemma iplus-0-left (rewrite) (equal (iplus 0 x) (fix-int x)) ((enable iplus fix-int integerp))) (lemma iplus-0-right (rewrite) ;; just in case we turn off commutativity (equal (iplus x 0) (fix-int x)) ((enable iplus fix-int integerp))) (lemma commutativity2-of-iplus (rewrite) (equal (iplus x (iplus y z)) (iplus y (iplus x z))) ((enable iplus commutativity2-of-plus))) (lemma commutativity-of-iplus (rewrite) (equal (iplus x y) (iplus y x)) ((enable iplus commutativity2-of-iplus))) (lemma associativity-of-iplus (rewrite) (equal (iplus (iplus x y) z) (iplus x (iplus y z))) ((enable iplus) (enable-theory addition))) (lemma iplus-cancellation-1 (rewrite) (equal (equal (iplus a b) (iplus a c)) (equal (fix-int b) (fix-int c))) ((enable iplus fix-int integerp) (enable-theory addition))) (lemma iplus-cancellation-2 (rewrite) (equal (equal (iplus b a) (iplus c a)) (equal (fix-int b) (fix-int c))) ((use (iplus-cancellation-1)) (enable commutativity-of-iplus))) (lemma iplus-ineg1 (rewrite) (equal (iplus (ineg a) a) 0) ((enable iplus ineg integerp fix-int))) (lemma iplus-ineg2 (rewrite) (equal (iplus a (ineg a)) 0) ((enable iplus ineg integerp fix-int))) (lemma iplus-fix-int1 (rewrite) (equal (iplus (fix-int a) b) (iplus a b)) ((enable iplus fix-int integerp plus-zero-arg2) (do-not-induct t))) (lemma iplus-fix-int2 (rewrite) (equal (iplus a (fix-int b)) (iplus a b)) ((enable iplus fix-int integerp plus-zero-arg2) (do-not-induct t))) ; ---------- IDIFFERENCE ---------- ;; mostly omitted, but I'll keep a few (lemma idifference-fix-int1 (rewrite) (equal (idifference (fix-int a) b) (idifference a b)) ((enable idifference iplus-fix-int1) (do-not-induct t))) (lemma idifference-fix-int2 (rewrite) (equal (idifference a (fix-int b)) (idifference a b)) ((enable idifference iplus-fix-int2 ineg-fix-int) (do-not-induct t))) ; -------------------------------------------------------------------------------- ; Cancel INEG ; -------------------------------------------------------------------------------- ;; We assume that the given term (IPLUS x y) has the property that y has already ;; been reduced and x is not an iplus-term. So, the only question is whether ;; or not the formal negative of x appears in the fringe of y. #| The function below has no AND or OR, for efficiency (defn cancel-ineg-aux (x y) ;; returns nil or else a new term provably equal to (IPLUS x y) (if (and (listp x) (equal (car x) 'ineg)) (cond ((equal y (cadr x)) ''0) ((and (listp y) (equal (car y) 'iplus)) (let ((y1 (cadr y)) (y2 (caddr y))) (if (equal y1 (cadr x)) (list 'fix-int y2) (let ((z (cancel-ineg-aux x y2))) (if z (list 'iplus y1 z) f))))) (t f)) (cond ((nlistp y) f) ((equal (car y) 'ineg) (if (equal x (cadr y)) ''0 f)) ((equal (car y) 'iplus) (let ((y1 (cadr y)) (y2 (caddr y))) (if (and (listp y1) (equal (car y1) 'ineg) (equal x (cadr y1))) (list 'fix-int y2) (let ((z (cancel-ineg-aux x y2))) (if z (list 'iplus y1 z) f))))) (t f)))) |# (DEFN CANCEL-INEG-AUX (X Y) (COND ((LISTP X) (COND ((EQUAL (CAR X) 'INEG) (COND ((EQUAL Y (CADR X)) ''0) ((LISTP Y) (IF (EQUAL (CAR Y) 'IPLUS) (COND ((EQUAL (CADR Y) (CADR X)) (LIST 'FIX-INT (CADDR Y))) ((CANCEL-INEG-AUX X (CADDR Y)) (LIST 'IPLUS (CADR Y) (CANCEL-INEG-AUX X (CADDR Y)))) (T F)) F)) (T F))) ((NLISTP Y) F) ((EQUAL (CAR Y) 'INEG) (IF (EQUAL X (CADR Y)) ''0 F)) ((EQUAL (CAR Y) 'IPLUS) (COND ((LISTP (CADR Y)) (COND ((EQUAL (CAADR Y) 'INEG) (COND ((EQUAL X (CADADR Y)) (LIST 'FIX-INT (CADDR Y))) ((CANCEL-INEG-AUX X (CADDR Y)) (LIST 'IPLUS (CADR Y) (CANCEL-INEG-AUX X (CADDR Y)))) (T F))) ((CANCEL-INEG-AUX X (CADDR Y)) (LIST 'IPLUS (CADR Y) (CANCEL-INEG-AUX X (CADDR Y)))) (T F))) ((CANCEL-INEG-AUX X (CADDR Y)) (LIST 'IPLUS (CADR Y) (CANCEL-INEG-AUX X (CADDR Y)))) (T F))) (T F))) ((NLISTP Y) F) ((EQUAL (CAR Y) 'INEG) (IF (EQUAL X (CADR Y)) ''0 F)) ((EQUAL (CAR Y) 'IPLUS) (COND ((LISTP (CADR Y)) (COND ((EQUAL (CAADR Y) 'INEG) (COND ((EQUAL X (CADADR Y)) (LIST 'FIX-INT (CADDR Y))) ((CANCEL-INEG-AUX X (CADDR Y)) (LIST 'IPLUS (CADR Y) (CANCEL-INEG-AUX X (CADDR Y)))) (T F))) ((CANCEL-INEG-AUX X (CADDR Y)) (LIST 'IPLUS (CADR Y) (CANCEL-INEG-AUX X (CADDR Y)))) (T F))) ((CANCEL-INEG-AUX X (CADDR Y)) (LIST 'IPLUS (CADR Y) (CANCEL-INEG-AUX X (CADDR Y)))) (T F))) (T F))) #| The function below has no AND or OR, for efficiency (defn cancel-ineg (x) (if (and (listp x) (equal (car x) 'iplus)) (let ((temp (cancel-ineg-aux (cadr x) (caddr x)))) (if temp temp x)) x)) |# (DEFN CANCEL-INEG (X) (IF (LISTP X) (IF (EQUAL (CAR X) 'IPLUS) (IF (CANCEL-INEG-AUX (CADR X) (CADDR X)) (CANCEL-INEG-AUX (CADR X) (CADDR X)) X) X) X)) ;; It seems a big win to turn off eval$. I'll leave the recursive step out in ;; hopes that rewrite-eval$ handles it OK. (prove-lemma eval$-list-cons (rewrite) (equal (eval$ 'list (cons x y) a) (cons (eval$ t x a) (eval$ 'list y a)))) (prove-lemma eval$-list-nlistp (rewrite) (implies (nlistp x) (equal (eval$ 'list x a) nil))) (prove-lemma eval$-litatom (rewrite) (implies (litatom x) (equal (eval$ t x a) (cdr (assoc x a))))) #| (prove-lemma eval$-quotep (rewrite) (equal (eval$ t (list 'quote x) a) x)) |# ;; In place of the above I'll do the following, from ;; the naturals library. (enable eval$-quote) (prove-lemma eval$-other (rewrite) (implies (and (not (litatom x)) (nlistp x)) (equal (eval$ t x a) x))) (disable eval$) ;; What I'd like to do is say what (eval$ t (cancel-ineg-aux x y) a), ;; but a rewrite rule will loop because of the recursion. So I ;; introduce a silly auxiliary function so that the opening-up ;; heuristics can help me. The function body has (listp y) tests ;; so that it can be accepted. (defn eval$-cancel-ineg-aux-fn (x y a) (if (and (listp x) (equal (car x) 'ineg)) (cond ((equal y (cadr x)) 0) (t (let ((y1 (cadr y)) (y2 (caddr y))) (if (equal y1 (cadr x)) (fix-int (eval$ t y2 a)) (if (listp y);; silly acceptability thing (iplus (eval$ t y1 a) (eval$-cancel-ineg-aux-fn x y2 a)) 0))))) (cond ((equal (car y) 'ineg) 0) (t (let ((y1 (cadr y)) (y2 (caddr y))) (if (and (listp y1) (equal (car y1) 'ineg) (equal x (cadr y1))) (fix-int (eval$ t y2 a)) (if (listp y);; silly acceptability thing (iplus (eval$ t y1 a) (eval$-cancel-ineg-aux-fn x y2 a)) 0))))))) (prove-lemma eval$-cancel-ineg-aux-is-its-fn (rewrite) (implies (not (equal (cancel-ineg-aux x y) f)) (equal (eval$ t (cancel-ineg-aux x y) a) (eval$-cancel-ineg-aux-fn x y a)))) (prove-lemma iplus-ineg3 (rewrite) (equal (iplus (ineg x) (iplus x y)) (fix-int y)) ((enable-theory integer-defns))) (prove-lemma iplus-ineg4 (rewrite) (equal (iplus x (iplus (ineg x) y)) (fix-int y)) ((use (iplus-ineg3 (x (ineg x)) (y y))))) (prove-lemma iplus-ineg-promote (rewrite) (equal (iplus y (ineg x)) (iplus (ineg x) y))) (prove-lemma iplus-x-y-ineg-x (rewrite) (equal (iplus x (iplus y (ineg x))) (fix-int y))) (disable iplus-ineg-promote) (prove-lemma correctness-of-cancel-ineg-aux (rewrite) (implies (not (equal (cancel-ineg-aux x y) f)) (equal (eval$-cancel-ineg-aux-fn x y a) (iplus (eval$ t x a) (eval$ t y a)))) ((induct (cancel-ineg-aux x y)))) (prove-lemma correctness-of-cancel-ineg ((meta iplus)) (equal (eval$ t x a) (eval$ t (cancel-ineg x) a)) ((disable cancel-ineg-aux))) (disable correctness-of-cancel-ineg-aux) ; -------------------------------------------------------------------------------- ; Cancel IPLUS ; -------------------------------------------------------------------------------- ;; All I do here is cancel like terms from both sides. The problem of handling ;; INEG cancellation IS handled completely separately above. That hasn't always ;; been the case -- in my first try I attempted to integrate the operations. ;; But now I see that for things like (equal z (iplus x (iplus y (ineg x)))) ;; the integrated approach will fail. Also, thanks to Matt Wilding, for pointing ;; out that the "four squares" example that Bill Pase sent me ran faster with ;; the newer approach (on his previously-implemented version for the rationals). #| The function below has no AND or OR, for efficiency (defn iplus-fringe (x) (if (and (listp x) (equal (car x) (quote iplus))) (append (iplus-fringe (cadr x)) (iplus-fringe (caddr x))) (cons x nil))) |# (DEFN IPLUS-FRINGE (X) (IF (LISTP X) (IF (EQUAL (CAR X) 'IPLUS) (APPEND (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))) (LIST X)) (LIST X))) (prove-lemma lessp-count-listp-cdr (rewrite) (implies (listp (cdr x)) (lessp (count (cdr x)) (count x)))) (defn iplus-tree-rec (l) (if (nlistp (cdr l)) (car l) (list (quote iplus) (car l) (iplus-tree-rec (cdr l))))) (defn iplus-tree (l) (if (listp l) (if (listp (cdr l)) (iplus-tree-rec l) (list (quote fix-int) (car l))) (quote (quote 0)))) (defn iplus-list (x) (if (listp x) (iplus (car x) (iplus-list (cdr x))) 0)) (prove-lemma integerp-iplus-list (rewrite) (integerp (iplus-list x))) (prove-lemma eval$-iplus-tree-rec (rewrite) (equal (eval$ t (iplus-tree-rec x) a) (if (listp x) (if (listp (cdr x)) (iplus-list (eval$ 'list x a)) (eval$ t (car x) a)) 0))) (prove-lemma eval$-iplus-tree (rewrite) (equal (eval$ t (iplus-tree x) a) (iplus-list (eval$ 'list x a)))) (prove-lemma eval$-list-append (rewrite) (equal (eval$ 'list (append x y) a) (append (eval$ 'list x a) (eval$ 'list y a)))) #| The function below has no AND or OR, for efficiency (defn cancel-iplus (x) (if (and (listp x) (equal (car x) (quote equal))) (if (and (listp (cadr x)) (equal (caadr x) (quote iplus)) (listp (caddr x)) (equal (caaddr x) (quote iplus))) (let ((xs (iplus-fringe (cadr x))) (ys (iplus-fringe (caddr x)))) (let ((bagint (bagint xs ys))) (if (listp bagint) (list (quote equal) (iplus-tree (bagdiff xs bagint)) (iplus-tree (bagdiff ys bagint))) x))) (if (and (listp (cadr x)) (equal (caadr x) (quote iplus)) ;; We don't want to introduce the IF below unless something ;; is "gained", or else we may get into an infinite rewriting loop. (member (caddr x) (iplus-fringe (cadr x)))) (list (quote if) (list (quote integerp) (caddr x)) (list (quote equal) (iplus-tree (delete (caddr x) (iplus-fringe (cadr x)))) ''0) (list (quote quote) f)) (if (and (listp (caddr x)) (equal (caaddr x) (quote iplus)) (member (cadr x) (iplus-fringe (caddr x)))) (list (quote if) (list (quote integerp) (cadr x)) (list (quote equal) ''0 (iplus-tree (delete (cadr x) (iplus-fringe (caddr x))))) (list (quote quote) f)) x))) x)) |# (DEFN CANCEL-IPLUS (X) (IF (LISTP X) (IF (EQUAL (CAR X) 'EQUAL) (COND ((LISTP (CADR X)) (COND ((EQUAL (CAADR X) 'IPLUS) (COND ((LISTP (CADDR X)) (COND ((EQUAL (CAADDR X) 'IPLUS) (IF (LISTP (BAGINT (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X)))) (LIST 'EQUAL (IPLUS-TREE (BAGDIFF (IPLUS-FRINGE (CADR X)) (BAGINT (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))))) (IPLUS-TREE (BAGDIFF (IPLUS-FRINGE (CADDR X)) (BAGINT (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X)))))) X)) ((MEMBER (CADDR X) (IPLUS-FRINGE (CADR X))) (LIST 'IF (LIST 'INTEGERP (CADDR X)) (CONS 'EQUAL (CONS (IPLUS-TREE (DELETE (CADDR X) (IPLUS-FRINGE (CADR X)))) '('0))) (LIST 'QUOTE F))) (T X))) ((MEMBER (CADDR X) (IPLUS-FRINGE (CADR X))) (LIST 'IF (LIST 'INTEGERP (CADDR X)) (CONS 'EQUAL (CONS (IPLUS-TREE (DELETE (CADDR X) (IPLUS-FRINGE (CADR X)))) '('0))) (LIST 'QUOTE F))) (T X))) ((LISTP (CADDR X)) (IF (EQUAL (CAADDR X) 'IPLUS) (IF (MEMBER (CADR X) (IPLUS-FRINGE (CADDR X))) (LIST 'IF (LIST 'INTEGERP (CADR X)) (LIST 'EQUAL ''0 (IPLUS-TREE (DELETE (CADR X) (IPLUS-FRINGE (CADDR X))))) (LIST 'QUOTE F)) X) X)) (T X))) ((LISTP (CADDR X)) (IF (EQUAL (CAADDR X) 'IPLUS) (IF (MEMBER (CADR X) (IPLUS-FRINGE (CADDR X))) (LIST 'IF (LIST 'INTEGERP (CADR X)) (LIST 'EQUAL ''0 (IPLUS-TREE (DELETE (CADR X) (IPLUS-FRINGE (CADDR X))))) (LIST 'QUOTE F)) X) X)) (T X)) X) X)) (lemma eval$-cancel-iplus (rewrite) (equal (eval$ t (cancel-iplus x) a) (if (and (listp x) (equal (car x) (quote equal))) (if (and (listp (cadr x)) (equal (caadr x) (quote iplus)) (listp (caddr x)) (equal (caaddr x) (quote iplus))) (let ((xs (iplus-fringe (cadr x))) (ys (iplus-fringe (caddr x)))) (let ((bagint (bagint xs ys))) (if (listp bagint) (equal (iplus-list (eval$ 'list (bagdiff xs (bagint xs ys)) a)) (iplus-list (eval$ 'list (bagdiff ys (bagint xs ys)) a))) (eval$ t x a)))) (if (and (listp (cadr x)) (equal (caadr x) (quote iplus)) (member (caddr x) (iplus-fringe (cadr x)))) (if (integerp (eval$ t (caddr x) a)) (equal (iplus-list (eval$ 'list (delete (caddr x) (iplus-fringe (cadr x))) a)) 0) f) (if (and (listp (caddr x)) (equal (caaddr x) (quote iplus)) (member (cadr x) (iplus-fringe (caddr x)))) (if (integerp (eval$ t (cadr x) a)) (equal 0 (iplus-list (eval$ 'list (delete (cadr x) (iplus-fringe (caddr x))) a))) f) (eval$ t x a)))) (eval$ t x a))) ((enable eval$-iplus-tree cancel-iplus eval$-list-cons eval$-litatom eval$-quote) (disable eval$))) (disable cancel-iplus) (prove-lemma eval$-iplus-list-delete (rewrite) (implies (member z y) (equal (iplus-list (eval$ 'list (delete z y) a)) (idifference (iplus-list (eval$ 'list y a)) (eval$ t z a))))) (prove-lemma eval$-iplus-list-bagdiff (rewrite) (implies (subbagp x y) (equal (iplus-list (eval$ 'list (bagdiff y x) a)) (idifference (iplus-list (eval$ 'list y a)) (iplus-list (eval$ 'list x a)))))) (prove-lemma iplus-list-append (rewrite) (equal (iplus-list (append x y)) (iplus (iplus-list x) (iplus-list y)))) (disable iplus-tree) ;; because we want to use EVAL$-IPLUS-TREE for now (lemma not-integerp-implies-not-equal-iplus (rewrite) (implies (not (integerp a)) (equal (equal a (iplus b c)) f)) ((use (integerp-iplus (x b) (y c))) (enable integerp) (do-not-induct t))) (prove-lemma iplus-list-eval$-fringe (rewrite) ;; similar to IPLUS-TREE-IPLUS-FRINGE (equal (iplus-list (eval$ 'list (iplus-fringe x) a)) (fix-int (eval$ t x a))) ((induct (iplus-fringe x)))) ;; The following two lemmas aren't needed but they sure do ;; shorten the total proof time!!! (prove-lemma iplus-ineg5-lemma-1 (rewrite) (implies (integerp x) (equal (equal x (iplus y (iplus (ineg z) w))) (equal x (iplus (ineg z) (iplus y w)))))) (prove-lemma iplus-ineg5-lemma-2 (rewrite) (implies (and (integerp x) (integerp v)) (equal (equal x (iplus (ineg z) v)) (equal (iplus x z) v)))) (lemma iplus-ineg5 (rewrite) (implies (integerp x) (equal (equal x (iplus y (iplus (ineg z) w))) (equal (iplus x z) (iplus y w)))) ((enable iplus-ineg5-lemma-1 iplus-ineg5-lemma-2 integerp-iplus))) (disable iplus-ineg5-lemma-1) (disable iplus-ineg5-lemma-2) (lemma iplus-ineg6 (rewrite) (implies (integerp x) (equal (equal x (iplus y (iplus w (ineg z)))) (equal (iplus x z) (iplus y w)))) ((use (iplus-ineg5) (commutativity-of-iplus (x w) (y (ineg z)))))) (prove-lemma eval$-iplus (rewrite) (implies (and (listp x) (equal (car x) 'iplus)) (equal (eval$ t x a) (iplus (eval$ t (cadr x) a) (eval$ t (caddr x) a))))) (prove-lemma iplus-ineg7 (rewrite) (equal (equal 0 (iplus x (ineg y))) (equal (fix-int y) (fix-int x))) ((enable-theory integer-defns))) (prove-lemma correctness-of-cancel-iplus ((meta equal)) (equal (eval$ t x a) (eval$ t (cancel-iplus x) a))) (disable iplus-ineg5) (disable iplus-ineg6) ; -------------------------------------------------------------------------------- ; Cancel IPLUS from ILESSP ; -------------------------------------------------------------------------------- ;; This is similar to the cancellation of IPLUS terms from equalities, ;; handled above, and uses many of the same lemmas. A small but definite ;; difference however is that for ILESSP we don't have to fix integers. ;; By luck we have that iplus-tree-rec is appropriate here, since ;; the lemma eval$-iplus-tree-rec shows that it (accidentally) behaves ;; properly on the empty list. (prove-lemma ilessp-fix-int-1 (rewrite) (equal (ilessp (fix-int x) y) (ilessp x y)) ((enable-theory integer-defns))) (prove-lemma ilessp-fix-int-2 (rewrite) (equal (ilessp x (fix-int y)) (ilessp x y)) ((enable-theory integer-defns))) ;; Perhaps the easiest approach is to do everything with respect to the ;; same IPLUS-TREE function that we used before, and then once the ;; supposed meta-lemma is proved, go back and show that we get the ;; same answer if we use a version that doesn't fix-int singleton fringes. (defn make-cancel-iplus-inequality-1 (x y) ;; x and y are term lists (list (quote ilessp) (iplus-tree (bagdiff x (bagint x y))) (iplus-tree (bagdiff y (bagint x y))))) #| The function below has no AND or OR, for efficiency (defn cancel-iplus-ilessp-1 (x) (if (and (listp x) (equal (car x) (quote ilessp))) (make-cancel-iplus-inequality-1 (iplus-fringe (cadr x)) (iplus-fringe (caddr x))) x)) |# (DEFN CANCEL-IPLUS-ILESSP-1 (X) (IF (LISTP X) (IF (EQUAL (CAR X) 'ILESSP) (MAKE-CANCEL-IPLUS-INEQUALITY-1 (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))) X) X)) ;; Notice that IPLUS-TREE-NO-FIX-INT is currently enabled, which is ;; good since we want to use EVAL$-IPLUS-TREE-NO-FIX-INT for now. (prove-lemma lessp-difference-plus-arg1 (rewrite) (equal (lessp w (difference (plus w y) x)) (lessp x y))) (prove-lemma lessp-difference-plus-arg1-commuted (rewrite) (equal (lessp w (difference (plus y w) x)) (lessp x y))) (prove-lemma iplus-cancellation-1-for-ilessp (rewrite) (equal (ilessp (iplus a b) (iplus a c)) (ilessp b c)) ((enable-theory integer-defns))) (prove-lemma iplus-cancellation-2-for-ilessp (rewrite) (equal (ilessp (iplus b a) (iplus c a)) (ilessp b c))) (prove-lemma correctness-of-cancel-iplus-ilessp-lemma nil (equal (eval$ t x a) (eval$ t (cancel-iplus-ilessp-1 x) a))) (defn iplus-tree-no-fix-int (l) (if (listp l) (iplus-tree-rec l) (quote (quote 0)))) (prove-lemma eval$-ilessp-iplus-tree-no-fix-int (rewrite) (equal (ilessp (eval$ t (iplus-tree-no-fix-int x) a) (eval$ t (iplus-tree-no-fix-int y) a)) (ilessp (eval$ t (iplus-tree x) a) (eval$ t (iplus-tree y) a)))) (disable iplus-tree-no-fix-int) (lemma make-cancel-iplus-inequality-simplifier (rewrite) (equal (eval$ t (make-cancel-iplus-inequality-1 x y) a) (eval$ t (list (quote ilessp) (iplus-tree-no-fix-int (bagdiff x (bagint x y))) (iplus-tree-no-fix-int (bagdiff y (bagint x y)))) a)) ((enable make-cancel-iplus-inequality-1 eval$-ilessp-iplus-tree-no-fix-int) (disable eval$))) #| The function below has no AND or OR, for efficiency (defn cancel-iplus-ilessp (x) (if (and (listp x) (equal (car x) (quote ilessp))) (let ((x1 (iplus-fringe (cadr x))) (y1 (iplus-fringe (caddr x)))) (let ((bagint (bagint x1 y1))) (if (listp bagint) ;; I check (listp bagint) only for efficiency (list (quote ilessp) (iplus-tree-no-fix-int (bagdiff x1 bagint)) (iplus-tree-no-fix-int (bagdiff y1 bagint))) x))) x)) |# ;; **** Should perhaps check that some argument of the ILESSP has function ;; symbol IPLUS, or else we may wind up dealing with (ILESSP 0 0). That should ;; be harmless enough, though, even if *1*IPLUS is disabled; we'll just get the ;; same term back, the hard way. (DEFN CANCEL-IPLUS-ILESSP (X) (IF (LISTP X) (IF (EQUAL (CAR X) 'ILESSP) (IF (LISTP (BAGINT (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X)))) (LIST 'ILESSP (IPLUS-TREE-NO-FIX-INT (BAGDIFF (IPLUS-FRINGE (CADR X)) (BAGINT (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))))) (IPLUS-TREE-NO-FIX-INT (BAGDIFF (IPLUS-FRINGE (CADDR X)) (BAGINT (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X)))))) X) X) X)) (disable make-cancel-iplus-inequality-1) (prove-lemma correctness-of-cancel-iplus-ilessp ((meta ilessp)) (equal (eval$ t x a) (eval$ t (cancel-iplus-ilessp x) a)) ((use (correctness-of-cancel-iplus-ilessp-lemma)))) ; ---------- Multiplication ---------- (lemma itimes-zero1 (rewrite) (implies (equal (fix-int x) 0) (equal (itimes x y) 0)) ((enable itimes times fix-int integerp) (do-not-induct t))) (prove-lemma itimes-0-left (rewrite) (equal (itimes 0 y) 0)) ;; I don't want the backchaining to slow down the prover. (disable itimes-zero1) (lemma itimes-zero2 (rewrite) (implies (equal (fix-int y) 0) (equal (itimes x y) 0)) ((enable itimes fix-int integerp times-zero) (do-not-induct t))) (prove-lemma itimes-0-right (rewrite) (equal (itimes x 0) 0)) ;; I don't want the backchaining to slow down the prover. (disable itimes-zero2) (lemma itimes-fix-int1 (rewrite) (equal (itimes (fix-int a) b) (itimes a b)) ((enable itimes fix-int integerp) (do-not-induct t))) (lemma itimes-fix-int2 (rewrite) (equal (itimes a (fix-int b)) (itimes a b)) ((enable itimes fix-int integerp times-zero) (do-not-induct t))) (lemma commutativity-of-itimes (rewrite) (equal (itimes x y) (itimes y x)) ((enable itimes fix-int integerp) (enable-theory multiplication) (do-not-induct t))) (lemma itimes-distributes-over-iplus-proof () (equal (itimes x (iplus y z)) (iplus (itimes x y) (itimes x z))) ((enable itimes iplus integerp fix-int commutativity2-of-iplus associativity-of-iplus) (enable-theory multiplication addition) (do-not-induct t))) (lemma itimes-distributes-over-iplus (rewrite) (and (equal (itimes x (iplus y z)) (iplus (itimes x y) (itimes x z))) (equal (itimes (iplus x y) z) (iplus (itimes x z) (itimes y z)))) ((use (itimes-distributes-over-iplus-proof (x x) (y y) (z z)) (itimes-distributes-over-iplus-proof (x z) (y x) (z y))) (enable commutativity-of-itimes))) (lemma commutativity2-of-itimes (rewrite) (equal (itimes x (itimes y z)) (itimes y (itimes x z))) ((enable itimes integerp fix-int) (enable-theory multiplication) (do-not-induct t))) (lemma associativity-of-itimes (rewrite) (equal (itimes (itimes x y) z) (itimes x (itimes y z))) ((enable itimes integerp fix-int) (enable-theory multiplication) (do-not-induct t))) (lemma equal-itimes-0 (rewrite) (equal (equal (itimes x y) 0) (or (equal (fix-int x) 0) (equal (fix-int y) 0))) ((enable itimes integerp fix-int) (enable-theory multiplication) (do-not-induct t))) (lemma equal-itimes-1 (rewrite) (equal (equal (itimes a b) 1) (or (and (equal a 1) (equal b 1)) (and (equal a -1) (equal b -1)))) ((enable itimes integerp fix-int) (enable-theory multiplication) (do-not-induct t))) (lemma equal-itimes-minus-1 (rewrite) (equal (equal (itimes a b) -1) (or (and (equal a -1) (equal b 1)) (and (equal a 1) (equal b -1)))) ((enable itimes integerp fix-int) (enable-theory multiplication) (do-not-induct t))) (lemma itimes-1-arg1 (rewrite) (equal (itimes 1 x) (fix-int x)) ((enable integerp fix-int itimes) (enable-theory multiplication) (do-not-induct t))) ; ---------- Division ---------- (lemma quotient-remainder-uniqueness () (implies (and (equal a (plus r (times b q))) (lessp r b)) (and (equal (fix r) (remainder a b)) (equal (fix q) (quotient a b)))) ((enable-theory naturals) (enable remainder quotient))) ; We want to define IQUOTIENT and IREMAINDER. The standard approach to ; integer division derives from from the following theorem. ; ; Division Theorem: ; For all integers i,j, j not 0, there exist unique integers q and r ; which satisfy i = jq + r, 0 <= r < |j|. ; ; The functions IQUOTIENT and IREMAINDER are intended to compute q and r. ; Therefore, to be satisfied that we have the right definitions, we must ; prove the above theorem. (prove-lemma division-theorem-part1 () (implies (integerp i) (equal (iplus (iremainder i j) (itimes j (iquotient i j))) i))) (prove-lemma division-theorem-part2 () (implies (and (integerp j) (not (equal j 0))) (not (ilessp (iremainder i j) 0))) ((enable-theory integer-defns))) (prove-lemma division-theorem-part3 () (implies (and (integerp j) (not (equal j 0))) (ilessp (iremainder i j) (iabs j))) ((enable-theory integer-defns))) (lemma division-theorem () (implies (and (integerp i) (integerp j) (not (equal j 0))) (and (equal (iplus (iremainder i j) (itimes j (iquotient i j))) i) (not (ilessp (iremainder i j) 0)) (ilessp (iremainder i j) (iabs j)))) ((use (division-theorem-part1 (i i) (j j)) (division-theorem-part2 (i i) (j j)) (division-theorem-part3 (i i) (j j))))) (lemma quotient-difference-lessp-arg2 (rewrite) (implies (and (equal (remainder a c) 0) (lessp b c)) (equal (quotient (difference a b) c) (if (zerop b) (quotient a c) (if (lessp b a) (difference (quotient a c) (add1 (quotient b c))) 0)))) ((enable-theory naturals) (do-not-induct t))) (lemma iquotient-iremainder-uniqueness () (implies (and (integerp i) (integerp j) (integerp r) (integerp q) (not (equal j 0)) (equal i (iplus r (itimes j q))) (not (ilessp r 0)) (ilessp r (iabs j))) (and (equal r (iremainder i j)) (equal q (iquotient i j)))) ((enable iremainder iabs idifference iplus ineg fix-int itimes iquotient ilessp integerp quotient-difference-lessp-arg2) (enable-theory naturals) (do-not-induct t))) ; It turns out that in computer arithmetic, notions of division other than that ; given by the division theorem are used. Two in particular, called ; "truncate towards negative infinity" and "truncate towards zero" are common. ; We present their definitions here. ; Division Theorem (truncate towards negative infinity variant): ; ; For all integers i,j, j not 0, there exist unique integers q and r ; which satisfy ; i = jq + r, 0 <= r < j (j > 0) ; j < r <= 0 (j < 0) ; ; In this version the integer quotient of two integers is the integer floor ; of the real quotient of the integers. The remainder has the sign of the ; divisor. The functions IDIV and IMOD are intended to compute q and r. ; Therefore, to be satisfied that we have the right definitions, we must ; prove the above theorem. (prove-lemma division-theorem-for-truncate-to-neginf-part1 () (implies (integerp i) (equal (iplus (imod i j) (itimes j (idiv i j))) i)) ((enable-theory integer-defns))) (lemma division-theorem-for-truncate-to-neginf-part2 () (implies (ilessp 0 j) (and (not (ilessp (imod i j) 0)) (ilessp (imod i j) j))) ((enable imod ilessp idifference iplus ineg itimes idiv integerp fix-int) (enable-theory naturals) (do-not-induct t))) (lemma division-theorem-for-truncate-to-neginf-part3 () (implies (and (integerp j) (ilessp j 0)) (and (not (ilessp 0 (imod i j))) (ilessp j (imod i j)))) ((enable imod ilessp idifference iplus ineg itimes idiv integerp fix-int) (enable-theory naturals) (do-not-induct t))) (lemma division-theorem-for-truncate-to-neginf () (implies (and (integerp i) (integerp j) (not (equal j 0))) (and (equal (iplus (imod i j) (itimes j (idiv i j))) i) (if (ilessp 0 j) (and (not (ilessp (imod i j) 0)) (ilessp (imod i j) j)) (and (not (ilessp 0 (imod i j))) (ilessp j (imod i j)))))) ((use (division-theorem-for-truncate-to-neginf-part1 (i i) (j j)) (division-theorem-for-truncate-to-neginf-part2 (i i) (j j)) (division-theorem-for-truncate-to-neginf-part3 (i i) (j j))) (enable integerp ilessp) (do-not-induct t))) (lemma idiv-imod-uniqueness () (implies (and (integerp i) (integerp j) (integerp r) (integerp q) (not (equal j 0)) (equal i (iplus r (itimes j q))) (if (ilessp 0 j) (and (not (ilessp r 0)) (ilessp r j)) (and (not (ilessp 0 r)) (ilessp j r)))) (and (equal r (imod i j)) (equal q (idiv i j)))) ((enable imod iabs idifference iplus ineg fix-int itimes idiv ilessp integerp ;lessp-plus-times-crock ;lessp-times-crock1 ;lessp-times-crock2 ;lessp-times-crock3 ;lessp-times-crock4 quotient-difference-lessp-arg2) (enable-theory naturals) (do-not-induct t))) ; Division Theorem (truncate towards zero variant): ; ; For all integers i,j, j not 0, there exist unique integers q and r ; which satisfy ; i = jq + r, 0 <= r < |j| (i => 0) ; -|j| < r <= 0 (i < 0) ; ; In this version (iquo, irem), the integer quotient of two integers is the integer floor ; of the real quotient of the integers, if the real quotient is positive. If the ; real quotient is negative, the integer quotient is the integer ceiling of the ; real quotient. The remainder has the sign of the dividend. The functions IQUO ; and IREM are intended to compute q and r. Therefore, to be satisfied that we ; have the right definitions, we must prove the above theorem. (prove-lemma division-theorem-for-truncate-to-zero-part1 () (implies (integerp i) (equal (iplus (irem i j) (itimes j (iquo i j))) i)) ((enable-theory integer-defns))) (prove-lemma division-theorem-for-truncate-to-zero-part2 () (implies (and (integerp i) (integerp j) (not (equal j 0)) (not (ilessp i 0))) (and (not (ilessp (irem i j) 0)) (ilessp (irem i j) (iabs j)))) ((enable-theory integer-defns))) (prove-lemma division-theorem-for-truncate-to-zero-part3 () (implies (and (integerp i) (integerp j) (not (equal j 0)) (ilessp i 0)) (and (not (ilessp 0 (irem i j))) (ilessp (ineg (iabs j)) (irem i j)))) ((enable-theory integer-defns))) (lemma division-theorem-for-truncate-to-zero () (implies (and (integerp i) (integerp j) (not (equal j 0))) (and (equal (iplus (irem i j) (itimes j (iquo i j))) i) (if (not (ilessp i 0)) (and (not (ilessp (irem i j) 0)) (ilessp (irem i j) (iabs j))) (and (not (ilessp 0 (irem i j))) (ilessp (ineg (iabs j)) (irem i j)))))) ((use (division-theorem-for-truncate-to-zero-part1 (i i) (j j)) (division-theorem-for-truncate-to-zero-part2 (i i) (j j)) (division-theorem-for-truncate-to-zero-part3 (i i) (j j))) (enable integerp ilessp) (do-not-induct t))) (prove-lemma iquo-irem-uniqueness () (implies (and (integerp i) (integerp j) (integerp r) (integerp q) (not (equal j 0)) (equal i (iplus r (itimes j q))) (if (not (ilessp i 0)) (and (not (ilessp r 0)) (ilessp r (iabs j))) (and (not (ilessp 0 r)) (ilessp (ineg (iabs j)) r)))) (and (equal r (irem i j)) (equal q (iquo i j)))) ((enable-theory integer-defns))) ; ---------- Multiplication Facts (prove-lemma itimes-ineg-1 (rewrite) (equal (itimes (ineg x) y) (ineg (itimes x y))) ((enable-theory integer-defns))) (prove-lemma itimes-ineg-2 (rewrite) (equal (itimes x (ineg y)) (ineg (itimes x y))) ((enable-theory integer-defns))) (prove-lemma itimes-cancellation-1 (rewrite) (equal (equal (itimes a b) (itimes a c)) (or (equal (fix-int a) 0) (equal (fix-int b) (fix-int c)))) ((enable-theory integer-defns))) (lemma itimes-cancellation-2 (rewrite) (equal (equal (itimes b a) (itimes c a)) (or (equal (fix-int a) 0) (equal (fix-int b) (fix-int c)))) ((use (itimes-cancellation-1)) (enable commutativity-of-itimes))) (lemma itimes-cancellation-3 (rewrite) (equal (equal (itimes a b) (itimes c a)) (or (equal (fix-int a) 0) (equal (fix-int b) (fix-int c)))) ((use (itimes-cancellation-1)) (enable commutativity-of-itimes))) ; ---------- Division Facts (lemma integerp-iquotient (rewrite) (integerp (iquotient i j)) ((enable integerp iquotient fix-int) (do-not-induct t))) (lemma integerp-iremainder (rewrite) (integerp (iremainder i j)) ((enable iremainder integerp-idifference) (do-not-induct t))) (lemma integerp-idiv (rewrite) (integerp (idiv i j)) ((enable integerp idiv fix-int) (do-not-induct t))) (lemma integerp-imod (rewrite) (integerp (imod i j)) ((enable imod integerp-idifference) (do-not-induct t))) (lemma integerp-iquo (rewrite) (integerp (iquo i j)) ((enable integerp iquo fix-int) (do-not-induct t))) (lemma integerp-irem (rewrite) (integerp (irem i j)) ((enable irem integerp-idifference) (do-not-induct t))) (lemma iquotient-fix-int1 (rewrite) (equal (iquotient (fix-int i) j) (iquotient i j)) ((enable integerp iquotient fix-int) (do-not-induct t))) (lemma iquotient-fix-int2 (rewrite) (equal (iquotient i (fix-int j)) (iquotient i j)) ((enable integerp iquotient fix-int) (do-not-induct t))) (lemma iremainder-fix-int1 (rewrite) (equal (iremainder (fix-int i) j) (iremainder i j)) ((enable iremainder idifference-fix-int1 iquotient-fix-int1) (do-not-induct t))) (lemma iremainder-fix-int2 (rewrite) (equal (iremainder i (fix-int j)) (iremainder i j)) ((enable iremainder itimes-fix-int1 iquotient-fix-int2) (do-not-induct t))) (lemma idiv-fix-int1 (rewrite) (equal (idiv (fix-int i) j) (idiv i j)) ((enable integerp idiv fix-int) (do-not-induct t))) (lemma idiv-fix-int2 (rewrite) (equal (idiv i (fix-int j)) (idiv i j)) ((enable integerp idiv fix-int) (do-not-induct t))) (lemma imod-fix-int1 (rewrite) (equal (imod (fix-int i) j) (imod i j)) ((enable imod fix-int-fix-int idiv-fix-int1) (do-not-induct t))) (lemma imod-fix-int2 (rewrite) (equal (imod i (fix-int j)) (imod i j)) ((enable imod itimes-fix-int1 idiv-fix-int2) (do-not-induct t))) (lemma iquo-fix-int1 (rewrite) (equal (iquo (fix-int i) j) (iquo i j)) ((enable integerp iquo fix-int) (do-not-induct t))) (lemma iquo-fix-int2 (rewrite) (equal (iquo i (fix-int j)) (iquo i j)) ((enable integerp iquo fix-int) (do-not-induct t))) (lemma irem-fix-int1 (rewrite) (equal (irem (fix-int i) j) (irem i j)) ((enable irem fix-int-fix-int iquo-fix-int1) (do-not-induct t))) (lemma irem-fix-int2 (rewrite) (equal (irem i (fix-int j)) (irem i j)) ((enable irem itimes-fix-int1 iquo-fix-int2) (do-not-induct t))) (lemma fix-int-iquotient (rewrite) (equal (fix-int (iquotient i j)) (iquotient i j)) ((enable integerp iquotient fix-int) (do-not-induct t))) (lemma fix-int-iremainder (rewrite) (equal (fix-int (iremainder i j)) (iremainder i j)) ((enable iremainder fix-int-idifference) (do-not-induct t))) (lemma fix-int-idiv (rewrite) (equal (fix-int (idiv i j)) (idiv i j)) ((enable integerp idiv fix-int) (do-not-induct t))) (lemma fix-int-imod (rewrite) (equal (fix-int (imod i j)) (imod i j)) ((enable imod fix-int-idifference) (do-not-induct t))) (lemma fix-int-iquo (rewrite) (equal (fix-int (iquo i j)) (iquo i j)) ((enable integerp iquo fix-int) (do-not-induct t))) (lemma fix-int-irem (rewrite) (equal (fix-int (irem i j)) (irem i j)) ((enable irem fix-int-idifference) (do-not-induct t))) (disable iquotient) (disable iremainder) (disable idiv) (disable imod) (disable iquo) (disable irem) ; ---------- Meta lemma for itimes cancellation ;; I tried to adapt this somewhat from corresponding meta lemmas in ;; naturals library, but it seemed to get hairy. So instead I'll try ;; to parallel the development I gave for IPLUS. I'll be lazier here ;; about efficiency, so I'll use a completely analogous definition of ;; itimes-tree. Notice that I've avoided the IZEROP-TREE approach ;; from the naturals version, in that I simply create the appropriate ;; common fringe into a product and say that this product is non-zero ;; when dividing both sides by it. It can then be up to the user whether ;; or not to enable the (meta or rewrite) rule that says that izerop of a product reduces ;; to the disjunction of izerop of the factors. #| The function below has no AND or OR, for efficiency (defn itimes-fringe (x) (if (and (listp x) (equal (car x) (quote itimes))) (append (itimes-fringe (cadr x)) (itimes-fringe (caddr x))) (cons x nil))) |# (DEFN ITIMES-FRINGE (X) (IF (LISTP X) (IF (EQUAL (CAR X) 'ITIMES) (APPEND (ITIMES-FRINGE (CADR X)) (ITIMES-FRINGE (CADDR X))) (LIST X)) (LIST X))) (defn itimes-tree-rec (l) (if (nlistp (cdr l)) (car l) (list (quote itimes) (car l) (itimes-tree-rec (cdr l))))) (defn itimes-tree (l) (if (listp l) (if (listp (cdr l)) (itimes-tree-rec l) (list (quote fix-int) (car l))) (quote (quote 1)))) (defn itimes-list (x) (if (listp x) (itimes (car x) (itimes-list (cdr x))) 1)) (prove-lemma integerp-itimes-list (rewrite) (integerp (itimes-list x))) (prove-lemma eval$-itimes-tree-rec (rewrite) (implies (listp x) (equal (eval$ t (itimes-tree-rec x) a) (if (listp (cdr x)) (itimes-list (eval$ 'list x a)) (eval$ t (car x) a))))) ;; The following allows us to pretty much ignore itimes-tree forever. (Notice ;; that it is disabled immediately below.) (prove-lemma eval$-itimes-tree (rewrite) (equal (eval$ t (itimes-tree x) a) (itimes-list (eval$ 'list x a)))) (disable itimes-tree) ;; because we want to use EVAL$-ITIMES-TREE for now (defn make-cancel-itimes-equality (x y in-both) ;; x and y are term lists and for efficiency we pass in-both as their bagint, ;; which is a listp. (list 'if (list 'equal (itimes-tree in-both) ''0) (list 'quote t) (list (quote equal) (itimes-tree (bagdiff x in-both)) (itimes-tree (bagdiff y in-both))))) #| The function below has no AND or OR, for efficiency (defn cancel-itimes (x) (if (and (listp x) (equal (car x) (quote equal))) (if (and (listp (cadr x)) (equal (caadr x) (quote itimes)) (listp (caddr x)) (equal (caaddr x) (quote itimes))) (if (listp (bagint (itimes-fringe (cadr x)) (itimes-fringe (caddr x)))) (make-cancel-itimes-equality (itimes-fringe (cadr x)) (itimes-fringe (caddr x)) (bagint (itimes-fringe (cadr x)) (itimes-fringe (caddr x)))) x) (if (and (listp (cadr x)) (equal (caadr x) (quote itimes))) ;; We don't want to introduce the IF below unless something ;; is "gained", or else we may get into an infinite rewriting loop. (if (member (caddr x) (itimes-fringe (cadr x))) (list (quote if) (list (quote integerp) (caddr x)) (make-cancel-itimes-equality (itimes-fringe (cadr x)) (list (caddr x)) (list (caddr x))) (list (quote quote) f)) x) (if (and (listp (caddr x)) (equal (caaddr x) (quote itimes))) (if (member (cadr x) (itimes-fringe (caddr x))) (list (quote if) (list (quote integerp) (cadr x)) (make-cancel-itimes-equality (list (cadr x)) (itimes-fringe (caddr x)) (list (cadr x))) (list (quote quote) f)) x) x))) x)) |# (DEFN CANCEL-ITIMES (X) (IF (LISTP X) (IF (EQUAL (CAR X) 'EQUAL) (COND ((LISTP (CADR X)) (COND ((EQUAL (CAADR X) 'ITIMES) (COND ((LISTP (CADDR X)) (COND ((EQUAL (CAADDR X) 'ITIMES) (IF (LISTP (BAGINT (ITIMES-FRINGE (CADR X)) (ITIMES-FRINGE (CADDR X)))) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FRINGE (CADR X)) (ITIMES-FRINGE (CADDR X)) (BAGINT (ITIMES-FRINGE (CADR X)) (ITIMES-FRINGE (CADDR X)))) X)) ((MEMBER (CADDR X) (ITIMES-FRINGE (CADR X))) (LIST 'IF (LIST 'INTEGERP (CADDR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FRINGE (CADR X)) (LIST (CADDR X)) (LIST (CADDR X))) (LIST 'QUOTE F))) (T X))) ((MEMBER (CADDR X) (ITIMES-FRINGE (CADR X))) (LIST 'IF (LIST 'INTEGERP (CADDR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FRINGE (CADR X)) (LIST (CADDR X)) (LIST (CADDR X))) (LIST 'QUOTE F))) (T X))) ((LISTP (CADDR X)) (IF (EQUAL (CAADDR X) 'ITIMES) (IF (MEMBER (CADR X) (ITIMES-FRINGE (CADDR X))) (LIST 'IF (LIST 'INTEGERP (CADR X)) (MAKE-CANCEL-ITIMES-EQUALITY (LIST (CADR X)) (ITIMES-FRINGE (CADDR X)) (LIST (CADR X))) (LIST 'QUOTE F)) X) X)) (T X))) ((LISTP (CADDR X)) (IF (EQUAL (CAADDR X) 'ITIMES) (IF (MEMBER (CADR X) (ITIMES-FRINGE (CADDR X))) (LIST 'IF (LIST 'INTEGERP (CADR X)) (MAKE-CANCEL-ITIMES-EQUALITY (LIST (CADR X)) (ITIMES-FRINGE (CADDR X)) (LIST (CADR X))) (LIST 'QUOTE F)) X) X)) (T X)) X) X)) (prove-lemma itimes-list-append (rewrite) (equal (itimes-list (append x y)) (itimes (itimes-list x) (itimes-list y)))) (prove-lemma itimes-list-eval$-fringe (rewrite) ;; similar to ITIMES-TREE-ITIMES-FRINGE (equal (itimes-list (eval$ 'list (itimes-fringe x) a)) (fix-int (eval$ t x a))) ((induct (itimes-fringe x)))) (prove-lemma integerp-eval$-itimes (rewrite) (implies (equal (car x) 'itimes) (integerp (eval$ t x a)))) (lemma not-integerp-implies-not-equal-itimes (rewrite) (implies (not (integerp a)) (equal (equal a (itimes b c)) f)) ((use (integerp-itimes (x b) (y c))) (enable integerp) (do-not-induct t))) (prove-lemma itimes-list-eval$-delete (rewrite) (implies (member z y) (equal (itimes-list (eval$ 'list y a)) (itimes (eval$ t z a) (itimes-list (eval$ 'list (delete z y) a)))))) (prove-lemma itimes-list-bagdiff (rewrite) (implies (subbagp x y) (equal (itimes-list (eval$ 'list y a)) (itimes (itimes-list (eval$ 'list (bagdiff y x) a)) (itimes-list (eval$ 'list x a))))) ((induct (bagdiff y x)))) (prove-lemma equal-itimes-list-eval$-list-delete (rewrite) (implies (and (member c y) (not (equal (fix-int (eval$ t c a)) 0))) (equal (equal x (itimes-list (eval$ 'list (delete c y) a))) (and (integerp x) (equal (itimes x (eval$ t c a)) (itimes-list (eval$ 'list y a))))))) (disable itimes-list-eval$-delete) ;; I had trouble with the clausifier (thanks, J, for pointing that out ;; as the source of my trouble) in the proof of the meta lemma -- it's ;; getting rid of a case split. So, I'll proceed by reducing ;; cancel-itimes in each case; see lemma eval$-make-cancel-itimes-equality ;; (and its -1 and -2 versions). (prove-lemma member-append (rewrite) (equal (member a (append x y)) (or (member a x) (member a y)))) (prove-lemma member-izerop-itimes-fringe (rewrite) (implies (and (member z (itimes-fringe x)) (equal (fix-int (eval$ t z a)) 0)) (equal (fix-int (eval$ t x a)) 0)) ((induct (itimes-fringe x)))) (prove-lemma correctness-of-cancel-itimes-hack-1 (rewrite) (implies (and (member w (itimes-fringe (cons 'itimes x1))) (equal (fix-int (eval$ t w a)) 0) (not (equal (fix-int (eval$ t (car x1) a)) 0))) (equal (fix-int (eval$ t (cadr x1) a)) 0))) (enable eval$-equal) (prove-lemma eval$-make-cancel-itimes-equality (rewrite) (equal (eval$ t (make-cancel-itimes-equality x y in-both) a) (if (eval$ t (list 'equal (itimes-tree in-both) ''0) a) t (equal (itimes-list (eval$ 'list (bagdiff x in-both) a)) (itimes-list (eval$ 'list (bagdiff y in-both) a)))))) (disable make-cancel-itimes-equality) ;; Here's a special case that I hope helps with the clausifier problem. ;; The lemma above seems necessary for its proof. (prove-lemma eval$-make-cancel-itimes-equality-1 (rewrite) (equal (eval$ t (make-cancel-itimes-equality (list x) y (list x)) a) (if (equal (fix-int (eval$ t x a)) 0) t (equal 1 (itimes-list (eval$ 'list (delete x y) a)))))) (prove-lemma equal-fix-int (rewrite) (equal (equal (fix-int x) x) (integerp x)) ((enable-theory integer-defns))) ;; Here's another special case that I hope helps with the clausifier problem. (prove-lemma eval$-make-cancel-itimes-equality-2 (rewrite) (equal (eval$ t (make-cancel-itimes-equality x (list y) (list y)) a) (if (equal (fix-int (eval$ t y a)) 0) t (equal 1 (itimes-list (eval$ 'list (delete y x) a)))))) (prove-lemma eval$-equal-itimes-tree-itimes-fringe-0 (rewrite) (implies (and (eval$ t (list 'equal (itimes-tree (itimes-fringe x)) ''0) a) (equal (car x) 'itimes)) (equal (eval$ t x a) 0))) (prove-lemma izerop-eval-of-member-implies-itimes-list-0 (rewrite) (implies (and (member z y) (equal (fix-int (eval$ t z a)) 0)) (equal (itimes-list (eval$ 'list y a)) 0))) #| The function below has no AND or OR, for efficiency (defn subsetp (x y) (if (nlistp x) t (and (member (car x) y) (subsetp (cdr x) y)))) |# (DEFN SUBSETP (X Y) (COND ((NLISTP X) T) ((MEMBER (CAR X) Y) (SUBSETP (CDR X) Y)) (T F))) (prove-lemma subsetp-implies-itimes-list-eval$-equals-0 (rewrite) (implies (and (subsetp x y) (equal (itimes-list (eval$ 'list x a)) 0)) (equal (itimes-list (eval$ 'list y a)) 0))) (prove-lemma subbagp-subsetp (rewrite) (implies (subbagp x y) (subsetp x y))) (prove-lemma equal-0-itimes-list-eval$-bagint-1 (rewrite) (implies (equal (itimes-list (eval$ 'list (bagint x y) a)) 0) (equal (itimes-list (eval$ 'list x a)) 0)) ((use (subsetp-implies-itimes-list-eval$-equals-0 (x (bagint x y)) (y x))) (disable subsetp-implies-itimes-list-eval$-equals-0))) (prove-lemma equal-0-itimes-list-eval$-bagint-2 (rewrite) (implies (equal (itimes-list (eval$ 'list (bagint x y) a)) 0) (equal (itimes-list (eval$ 'list y a)) 0)) ((use (subsetp-implies-itimes-list-eval$-equals-0 (x (bagint x y)) (y y))) (disable subsetp-implies-itimes-list-eval$-equals-0))) (prove-lemma correctness-of-cancel-itimes-hack-2 (rewrite) (implies (and (listp u) (equal (car u) 'itimes) (listp v) (equal (car v) 'itimes) (not (equal (eval$ t u a) (eval$ t v a)))) (not (equal (itimes-list (eval$ 'list (bagdiff (itimes-fringe u) (bagint (itimes-fringe u) (itimes-fringe v))) a)) (itimes-list (eval$ 'list (bagdiff (itimes-fringe v) (bagint (itimes-fringe u) (itimes-fringe v))) a))))) ((use (itimes-list-bagdiff (y (itimes-fringe u)) (x (bagint (itimes-fringe u) (itimes-fringe v))) (a a)) (itimes-list-bagdiff (y (itimes-fringe v)) (x (bagint (itimes-fringe u) (itimes-fringe v))) (a a))))) (prove-lemma correctness-of-cancel-itimes-hack-3-lemma (rewrite) (implies (and (equal u (itimes a b)) (not (equal (fix-int a) 0))) (equal (equal u (itimes a c)) (equal (fix-int b) (fix-int c))))) (prove-lemma correctness-of-cancel-itimes-hack-3 (rewrite) (implies (and (listp u) (equal (car u) 'itimes) (listp v) (equal (car v) 'itimes) (equal (eval$ t u a) (eval$ t v a)) (not (eval$ t (list 'equal (itimes-tree (bagint (itimes-fringe u) (itimes-fringe v))) ''0) a))) (equal (equal (itimes-list (eval$ 'list (bagdiff (itimes-fringe u) (bagint (itimes-fringe u) (itimes-fringe v))) a)) (itimes-list (eval$ 'list (bagdiff (itimes-fringe v) (bagint (itimes-fringe u) (itimes-fringe v))) a))) t)) ((use (itimes-list-bagdiff (y (itimes-fringe u)) (x (bagint (itimes-fringe u) (itimes-fringe v))) (a a)) (itimes-list-bagdiff (y (itimes-fringe v)) (x (bagint (itimes-fringe u) (itimes-fringe v))) (a a))))) (disable correctness-of-cancel-itimes-hack-3-lemma) (prove-lemma correctness-of-cancel-itimes ((meta equal)) (equal (eval$ t x a) (eval$ t (cancel-itimes x) a)) ((do-not-induct t))) ; ---------- Meta lemma for itimes cancellation on ilessp terms ;; I'll try to keep this similar to the approach for equalities above, ;; modified as in the iplus case (i.e. no fix-int is necessary). ;; EVAL$-EQUAL is currently enabled, but that's OK. (defn itimes-tree-no-fix-int (l) (if (listp l) (itimes-tree-rec l) (quote (quote 1)))) ;; The following allows us to pretty much ignore ;; itimes-tree-no-fix-int forever. (Notice that it is disabled ;; immediately below.) (prove-lemma eval$-itimes-tree-no-fix-int-1 (rewrite) (equal (ilessp (eval$ t (itimes-tree-no-fix-int x) a) y) (ilessp (eval$ t (itimes-tree x) a) y))) (prove-lemma eval$-itimes-tree-no-fix-int-2 (rewrite) (equal (ilessp y (eval$ t (itimes-tree-no-fix-int x) a)) (ilessp y (eval$ t (itimes-tree x) a)))) (disable itimes-tree-no-fix-int) ;; We want to use EVAL$-ITIMES-TREE, and ITIMES-TREE is still disabled ;; so we're in good shape. (defn make-cancel-itimes-inequality (x y in-both) ;; x and y are term lists and for efficiency we pass in-both as their bagint, ;; which is a listp. (list 'if (list 'ilessp (itimes-tree-no-fix-int in-both) ''0) (list (quote ilessp) (itimes-tree-no-fix-int (bagdiff y in-both)) (itimes-tree-no-fix-int (bagdiff x in-both))) (list 'if (list 'ilessp ''0 (itimes-tree-no-fix-int in-both)) (list (quote ilessp) (itimes-tree-no-fix-int (bagdiff x in-both)) (itimes-tree-no-fix-int (bagdiff y in-both))) '(false)))) #| The function below has no AND or OR, for efficiency (defn cancel-itimes-ilessp (x) (if (and (listp x) (equal (car x) (quote ilessp)) (listp (bagint (itimes-fringe (cadr x)) (itimes-fringe (caddr x))))) (make-cancel-itimes-inequality (itimes-fringe (cadr x)) (itimes-fringe (caddr x)) (bagint (itimes-fringe (cadr x)) (itimes-fringe (caddr x)))) x)) |# (DEFN CANCEL-ITIMES-ILESSP (X) (IF (LISTP X) (IF (EQUAL (CAR X) 'ILESSP) (IF (LISTP (BAGINT (ITIMES-FRINGE (CADR X)) (ITIMES-FRINGE (CADDR X)))) (MAKE-CANCEL-ITIMES-INEQUALITY (ITIMES-FRINGE (CADR X)) (ITIMES-FRINGE (CADDR X)) (BAGINT (ITIMES-FRINGE (CADR X)) (ITIMES-FRINGE (CADDR X)))) X) X) X)) (prove-lemma eval$-make-cancel-itimes-inequality (rewrite) (equal (eval$ t (make-cancel-itimes-inequality x y in-both) a) (if (eval$ t (list 'ilessp (itimes-tree-no-fix-int in-both) ''0) a) (ilessp (eval$ t (itimes-tree-no-fix-int (bagdiff y in-both)) a) (eval$ t (itimes-tree-no-fix-int (bagdiff x in-both)) a)) (if (eval$ t (list 'ilessp ''0 (itimes-tree-no-fix-int in-both)) a) (ilessp (eval$ t (itimes-tree-no-fix-int (bagdiff x in-both)) a) (eval$ t (itimes-tree-no-fix-int (bagdiff y in-both)) a)) f)))) (disable make-cancel-itimes-inequality) (prove-lemma listp-bagint-with-singleton-implies-member (rewrite) (implies (listp (bagint y (list z))) (member z y))) (prove-lemma itimes-list-eval$-list-0 (rewrite) (implies (member 0 x) (equal (itimes-list (eval$ 'list x a)) 0))) (prove-lemma ilessp-itimes-right-positive nil (implies (ilessp 0 x) (equal (ilessp y z) (ilessp (itimes y x) (itimes z x)))) ((enable-theory integer-defns))) (prove-lemma correctness-of-cancel-itimes-ilessp-hack-1 (rewrite) (implies (and (subbagp bag x) (subbagp bag y) (ilessp 0 (itimes-list (eval$ 'list bag a)))) (equal (ilessp (itimes-list (eval$ 'list (bagdiff x bag) a)) (itimes-list (eval$ 'list (bagdiff y bag) a))) (ilessp (itimes-list (eval$ 'list x a)) (itimes-list (eval$ 'list y a))))) ((use (ilessp-itimes-right-positive (x (itimes-list (eval$ 'list bag a))) (y (itimes-list (eval$ 'list (bagdiff x bag) a))) (z (itimes-list (eval$ 'list (bagdiff y bag) a)))) (itimes-list-bagdiff (y x) (x bag) (a a)) (itimes-list-bagdiff (y y) (x bag) (a a))))) (prove-lemma listp-bagint-with-singleton-member (rewrite) (equal (listp (bagint y (list z))) (member z y))) (prove-lemma correctness-of-cancel-itimes-ilessp-hack-2-lemma (rewrite) (implies (member 0 (itimes-fringe w)) (equal (eval$ t w a) 0)) ((expand (itimes-fringe w)))) (prove-lemma correctness-of-cancel-itimes-ilessp-hack-2 (rewrite) (implies (member 0 (itimes-fringe w)) (not (ilessp (eval$ t w a) 0)))) (disable correctness-of-cancel-itimes-ilessp-hack-2-lemma) ;;; Now hack-3 and hack-4 below are all that's left to prove before the ;;; main result. (prove-lemma ilessp-trichotomy (rewrite) (implies (not (ilessp x y)) (equal (ilessp y x) (not (equal (fix-int x) (fix-int y))))) ((enable-theory integer-defns))) (prove-lemma correctness-of-cancel-itimes-ilessp-hack-3-lemma-1 nil (implies (and (equal 0 (itimes-list (eval$ 'list bag a))) (subsetp bag z)) (equal (itimes-list (eval$ 'list z a)) 0))) (prove-lemma correctness-of-cancel-itimes-ilessp-hack-3-lemma-2 nil (implies (and (equal 0 (itimes-list (eval$ 'list bag a))) (subsetp bag (itimes-fringe x))) (equal (fix-int (eval$ t x a)) 0)) ((use (correctness-of-cancel-itimes-ilessp-hack-3-lemma-1 (z (itimes-fringe x)))))) (prove-lemma same-fix-int-implies-not-ilessp (rewrite) (implies (equal (fix-int x) (fix-int y)) (not (ilessp x y))) ((enable-theory integer-defns))) (prove-lemma correctness-of-cancel-itimes-ilessp-hack-3 (rewrite) (implies (and (not (ilessp (itimes-list (eval$ 'list bag a)) 0)) (not (ilessp 0 (itimes-list (eval$ 'list bag a)))) (subbagp bag (itimes-fringe w)) (subbagp bag (itimes-fringe v))) (not (ilessp (eval$ t w a) (eval$ t v a)))) ((use (correctness-of-cancel-itimes-ilessp-hack-3-lemma-2 (x w) (bag bag)) (correctness-of-cancel-itimes-ilessp-hack-3-lemma-2 (x v) (bag bag))))) (prove-lemma ilessp-itimes-right-negative nil (implies (ilessp x 0) (equal (ilessp y z) (ilessp (itimes z x) (itimes y x)))) ((enable-theory integer-defns))) (prove-lemma correctness-of-cancel-itimes-ilessp-hack-4 (rewrite) (implies (and (subbagp bag x) (subbagp bag y) (ilessp (itimes-list (eval$ 'list bag a)) 0)) (equal (ilessp (itimes-list (eval$ 'list (bagdiff x bag) a)) (itimes-list (eval$ 'list (bagdiff y bag) a))) (ilessp (itimes-list (eval$ 'list y a)) (itimes-list (eval$ 'list x a))))) ((use (ilessp-itimes-right-negative (x (itimes-list (eval$ 'list bag a))) (y (itimes-list (eval$ 'list (bagdiff x bag) a))) (z (itimes-list (eval$ 'list (bagdiff y bag) a)))) (itimes-list-bagdiff (y x) (x bag) (a a)) (itimes-list-bagdiff (y y) (x bag) (a a))))) (disable ilessp-trichotomy) (disable same-fix-int-implies-not-ilessp) (prove-lemma correctness-of-cancel-itimes-ilessp ((meta ilessp)) (equal (eval$ t x a) (eval$ t (cancel-itimes-ilessp x) a)) ((do-not-induct t))) ;; I think that the following lemma is safe because it won't be ;; called at all during relieve-hyps. (prove-lemma ilessp-strict (rewrite) (implies (ilessp x y) (not (ilessp y x))) ((enable-theory integer-defns))) ; ---------- Setting up the State ---------- ;; I'll close by disabling (or enabling) those rules and definitions ;; whose status as left over from above isn't quite what I'd like. ;; I'm going to leave the eval$ rules on and eval$ off. (disable eval$-cancel-iplus) (disable eval$-iplus) (disable lessp-count-listp-cdr) (disable eval$-iplus-tree-rec) (disable eval$-iplus-tree) ;;(disable eval$-list-append) ;; Nice rule -- I'll keep it enabled (disable iplus-list-eval$-fringe) (disable eval$-iplus-list-bagdiff) (disable lessp-difference-plus-arg1) (disable lessp-difference-plus-arg1-commuted) (disable correctness-of-cancel-iplus-ilessp-lemma) (disable eval$-ilessp-iplus-tree-no-fix-int) (disable make-cancel-iplus-inequality-simplifier) (disable quotient-difference-lessp-arg2) (disable eval$-itimes-tree-rec) (disable eval$-itimes-tree) (disable itimes-list-eval$-fringe) (disable integerp-eval$-itimes) (disable itimes-list-bagdiff) (disable equal-itimes-list-eval$-list-delete) (disable member-izerop-itimes-fringe) (disable correctness-of-cancel-itimes-hack-1) (disable eval$-make-cancel-itimes-equality) (disable eval$-make-cancel-itimes-equality-1) (disable eval$-make-cancel-itimes-equality-2) (disable eval$-equal-itimes-tree-itimes-fringe-0) (disable izerop-eval-of-member-implies-itimes-list-0) (disable subsetp-implies-itimes-list-eval$-equals-0) (disable equal-0-itimes-list-eval$-bagint-1) (disable equal-0-itimes-list-eval$-bagint-2) (disable correctness-of-cancel-itimes-hack-2) (disable correctness-of-cancel-itimes-hack-3-lemma) (disable correctness-of-cancel-itimes-hack-3) (disable eval$-itimes-tree-no-fix-int-1) (disable eval$-itimes-tree-no-fix-int-2) (disable eval$-make-cancel-itimes-inequality) (disable listp-bagint-with-singleton-implies-member) (disable itimes-list-eval$-list-0) (disable correctness-of-cancel-itimes-ilessp-hack-1) (disable listp-bagint-with-singleton-member) (disable correctness-of-cancel-itimes-ilessp-hack-2) (disable correctness-of-cancel-itimes-ilessp-hack-3-lemma-1) (disable correctness-of-cancel-itimes-ilessp-hack-3-lemma-2) (disable correctness-of-cancel-itimes-ilessp-hack-3) (disable correctness-of-cancel-itimes-ilessp-hack-4) ;; The last one is a tough call, but I think it's OK. ;; (disable ilessp-strict) ;;;;;; ***** EXTRA META STUFF ***** ;;;;;; ;; The next goal is to improve itimes cancellation so that it looks ;; for common factors, and hence works on equations like ;; x*y + x = x*z ;; and, for that matter, ;; a*x + -b*x = 0. ;; Rather than changing the existing cancel-itimes function, I'll ;; leave that one but disable its metalemma at the end. Then if the ;; new version, which I'll call cancel-itimes-factors, is found to be ;; too slow, one can always disable its metalemma and re-enable the ;; metalemma for cancel-itimes. ;; Notice, by the way, that the existing cancel-itimes function is ;; useless for something like the following, since there's no special ;; treatment for INEG. I'll remedy that in this version. #| (IMPLIES (AND (NOT (IZEROP X)) (EQUAL (ITIMES A X) (INEG (ITIMES B X)))) (EQUAL (FIX-INT A) (INEG B))) |# (defn itimes-tree-ineg (l) ;; Like itimes-tree-rec in that it doesn't apply fix-int even for a one-element ;; list, but with special treatment if l is a list starting with (quote -1). ;; Notice the coding with IF, for computational efficiency. (if (listp l) (if (equal (car l) (list 'quote -1)) (if (listp (cdr l)) (list 'ineg (itimes-tree-rec (cdr l))) (car l)) (itimes-tree-rec l)) (quote (quote 1)))) (defn itimes-factors (x) ;; a "generalization" of itimes-fringe (if (listp x) (cond ((equal (car x) (quote itimes)) (append (itimes-factors (cadr x)) (itimes-factors (caddr x)))) ((equal (car x) (quote iplus)) (let ((bag1 (itimes-factors (cadr x))) (bag2 (itimes-factors (caddr x)))) (let ((inboth (bagint bag1 bag2))) (if (listp inboth) (cons (list 'iplus (itimes-tree-ineg (bagdiff bag1 inboth)) (itimes-tree-ineg (bagdiff bag2 inboth))) inboth) (list x))))) ((equal (car x) (quote ineg)) (cons (list 'quote -1) (itimes-factors (cadr x)))) (t (list x))) (list x))) (prove-lemma itimes--1 (rewrite) (equal (itimes -1 x) (ineg x)) ((enable-theory integer-defns))) ;; I'll need the following lemma because it's simplest not to deal with ;; e.g. (equal x x), where x is a variable, in the meta thing. I'll do ;; the one after it too, simply because I'm thinking of it now. (prove-lemma equal-ineg-ineg (rewrite) (equal (equal (ineg x) (ineg y)) (equal (fix-int x) (fix-int y))) ((enable-theory integer-defns))) (prove-lemma ilessp-ineg-ineg (rewrite) (equal (ilessp (ineg x) (ineg y)) (ilessp y x)) ((enable-theory integer-defns))) (prove-lemma fix-int-eval$-itimes-tree-rec (rewrite) (implies (listp x) (equal (fix-int (eval$ t (itimes-tree-rec x) a)) (itimes-list (eval$ 'list x a)))) ((enable eval$-itimes-tree-rec))) (prove-lemma eval$-itimes-tree-ineg (rewrite) (equal (fix-int (eval$ t (itimes-tree-ineg x) a)) (itimes-list (eval$ 'list x a))) ((enable eval$-itimes-tree-rec))) ;; Now I want the above lemma to apply, but it doesn't, so the ;; following three lemmas are used instead. (prove-lemma ineg-eval$-itimes-tree-ineg (rewrite) (equal (ineg (eval$ t (itimes-tree-ineg x) a)) (ineg (itimes-list (eval$ 'list x a)))) ((use (eval$-itimes-tree-ineg)))) (prove-lemma iplus-eval$-itimes-tree-ineg (rewrite) (and (equal (iplus (eval$ t (itimes-tree-ineg x) a) y) (iplus (itimes-list (eval$ 'list x a)) y)) (equal (iplus y (eval$ t (itimes-tree-ineg x) a)) (iplus y (itimes-list (eval$ 'list x a))))) ((use (eval$-itimes-tree-ineg)))) (prove-lemma itimes-eval$-itimes-tree-ineg (rewrite) (and (equal (itimes (eval$ t (itimes-tree-ineg x) a) y) (itimes (itimes-list (eval$ 'list x a)) y)) (equal (itimes y (eval$ t (itimes-tree-ineg x) a)) (itimes y (itimes-list (eval$ 'list x a))))) ((use (eval$-itimes-tree-ineg)))) (disable itimes-tree-ineg) #| ****** The following definitions are for efficient execution of metafunctions. They should probably be applied to all the metafunctions with fns arguments AND and OR. (defmacro nqthm-macroexpand (defn &rest fns) `(nqthm-macroexpand-fn ',defn ',fns)) (defun nqthm-macroexpand-fn (defn fns) (iterate for fn in fns when (not (get fn 'sdefn)) do (er soft (fn) |Sorry| |,| |but| |there| |is| |no| SDEFN |for| (!ppr fn (quote |.|)))) (let (name args body) (match! defn (defn name args body)) (let ((arity-alist (cons (cons name (length args)) arity-alist))) (list 'defn name args (untranslate (normalize-ifs (nqthm-macroexpand-term (translate body) fns) nil nil nil)))))) (defun nqthm-macroexpand-term (term fns) (cond ((or (variablep term) (fquotep term)) term) ((member-eq (ffn-symb term) fns) (let ((sdefn (get (ffn-symb term) 'sdefn))) (sub-pair-var (cadr sdefn) (iterate for arg in (fargs term) collect (nqthm-macroexpand-term arg fns)) (caddr sdefn)))) (t (fcons-term (ffn-symb term) (iterate for arg in (fargs term) collect (nqthm-macroexpand-term arg fns)))))) |# ;; I "macroexpand" away the following below, so it's not really needed except ;; for the proof. That is, I use it in the definition of cancel-itimes-factors, ;; but then get rid of it for cancel-itimes-factors-expanded, and although I ;; reason about the former, I USE the latter, for efficiency. (defn iplus-or-itimes-term (x) (if (listp x) (case (car x) (iplus t) (itimes t) (ineg (if (listp (cadr x)) (equal (car (cadr x)) 'itimes) f)) (otherwise f)) f)) (defn cancel-itimes-factors (x) (if (and (listp x) (equal (car x) (quote equal))) (let ((bagint (bagint (itimes-factors (cadr x)) (itimes-factors (caddr x))))) (let ((new-equality (make-cancel-itimes-equality (itimes-factors (cadr x)) (itimes-factors (caddr x)) bagint))) (if (iplus-or-itimes-term (cadr x)) (if (listp bagint) (if (iplus-or-itimes-term (caddr x)) new-equality (list 'if (list 'integerp (caddr x)) new-equality (list 'quote f))) x) (if (iplus-or-itimes-term (caddr x)) (if (listp bagint) (list 'if (list 'integerp (cadr x)) new-equality (list 'quote f)) x) x)))) x)) ;; The following was generated with the nqthm-macroexpand macro defined above. (DEFN CANCEL-ITIMES-FACTORS-expanded (X) (IF (LISTP X) (IF (EQUAL (CAR X) 'EQUAL) (COND ((LISTP (CADR X)) (CASE (CAR (CAR (CDR X))) (IPLUS (IF (LISTP (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (IF (LISTP (CADDR X)) (CASE (CAR (CAR (CDR (CDR X)))) (IPLUS (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X))))) (ITIMES (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X))))) (INEG (IF (LISTP (CADADDR X)) (IF (EQUAL (CAADADDR X) 'ITIMES) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'IF (LIST 'INTEGERP (CADDR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'QUOTE F))) (LIST 'IF (LIST 'INTEGERP (CADDR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'QUOTE F)))) (OTHERWISE (LIST 'IF (LIST 'INTEGERP (CADDR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'QUOTE F)))) (LIST 'IF (LIST 'INTEGERP (CADDR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'QUOTE F))) X)) (ITIMES (IF (LISTP (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (IF (LISTP (CADDR X)) (CASE (CAR (CAR (CDR (CDR X)))) (IPLUS (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X))))) (ITIMES (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X))))) (INEG (IF (LISTP (CADADDR X)) (IF (EQUAL (CAADADDR X) 'ITIMES) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'IF (LIST 'INTEGERP (CADDR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'QUOTE F))) (LIST 'IF (LIST 'INTEGERP (CADDR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'QUOTE F)))) (OTHERWISE (LIST 'IF (LIST 'INTEGERP (CADDR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'QUOTE F)))) (LIST 'IF (LIST 'INTEGERP (CADDR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'QUOTE F))) X)) (INEG (COND ((LISTP (CADADR X)) (COND ((EQUAL (CAADADR X) 'ITIMES) (IF (LISTP (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (IF (LISTP (CADDR X)) (CASE (CAR (CAR (CDR (CDR X)))) (IPLUS (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X))))) (ITIMES (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X))))) (INEG (IF (LISTP (CADADDR X)) (IF (EQUAL (CAADADDR X) 'ITIMES) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'IF (LIST 'INTEGERP (CADDR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'QUOTE F))) (LIST 'IF (LIST 'INTEGERP (CADDR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'QUOTE F)))) (OTHERWISE (LIST 'IF (LIST 'INTEGERP (CADDR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'QUOTE F)))) (LIST 'IF (LIST 'INTEGERP (CADDR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'QUOTE F))) X)) ((LISTP (CADDR X)) (CASE (CAR (CAR (CDR (CDR X)))) (IPLUS (IF (LISTP (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'IF (LIST 'INTEGERP (CADR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'QUOTE F)) X)) (ITIMES (IF (LISTP (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'IF (LIST 'INTEGERP (CADR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'QUOTE F)) X)) (INEG (IF (LISTP (CADADDR X)) (IF (EQUAL (CAADADDR X) 'ITIMES) (IF (LISTP (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'IF (LIST 'INTEGERP (CADR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'QUOTE F)) X) X) X)) (OTHERWISE X))) (T X))) ((LISTP (CADDR X)) (CASE (CAR (CAR (CDR (CDR X)))) (IPLUS (IF (LISTP (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'IF (LIST 'INTEGERP (CADR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'QUOTE F)) X)) (ITIMES (IF (LISTP (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'IF (LIST 'INTEGERP (CADR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'QUOTE F)) X)) (INEG (IF (LISTP (CADADDR X)) (IF (EQUAL (CAADADDR X) 'ITIMES) (IF (LISTP (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'IF (LIST 'INTEGERP (CADR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'QUOTE F)) X) X) X)) (OTHERWISE X))) (T X))) (OTHERWISE (IF (LISTP (CADDR X)) (CASE (CAR (CAR (CDR (CDR X)))) (IPLUS (IF (LISTP (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'IF (LIST 'INTEGERP (CADR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'QUOTE F)) X)) (ITIMES (IF (LISTP (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'IF (LIST 'INTEGERP (CADR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'QUOTE F)) X)) (INEG (IF (LISTP (CADADDR X)) (IF (EQUAL (CAADADDR X) 'ITIMES) (IF (LISTP (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'IF (LIST 'INTEGERP (CADR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'QUOTE F)) X) X) X)) (OTHERWISE X)) X)))) ((LISTP (CADDR X)) (CASE (CAR (CAR (CDR (CDR X)))) (IPLUS (IF (LISTP (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'IF (LIST 'INTEGERP (CADR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'QUOTE F)) X)) (ITIMES (IF (LISTP (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'IF (LIST 'INTEGERP (CADR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'QUOTE F)) X)) (INEG (IF (LISTP (CADADDR X)) (IF (EQUAL (CAADADDR X) 'ITIMES) (IF (LISTP (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'IF (LIST 'INTEGERP (CADR X)) (MAKE-CANCEL-ITIMES-EQUALITY (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)) (BAGINT (ITIMES-FACTORS (CADR X)) (ITIMES-FACTORS (CADDR X)))) (LIST 'QUOTE F)) X) X) X)) (OTHERWISE X))) (T X)) X) X)) (prove-lemma cancel-itimes-factors-expanded-cancel-itimes-factors (rewrite) (equal (cancel-itimes-factors-expanded x) (cancel-itimes-factors x)) ((disable-theory t) (enable-theory ground-zero) (enable iplus-or-itimes-term cancel-itimes-factors cancel-itimes-factors-expanded))) (disable cancel-itimes-factors-expanded) (disable iplus-or-itimes-term) (prove-lemma equal-itimes-list-eval$-list-delete-new-1 (rewrite) (implies (not (equal (fix-int (eval$ t elt a)) 0)) (equal (equal x (itimes-list (eval$ 'list (delete elt bag) a))) (if (member elt bag) (and (integerp x) (equal (itimes x (eval$ t elt a) ) (itimes-list (eval$ 'list bag a)))) (equal x (itimes-list (eval$ 'list bag a)))))) ((enable equal-itimes-list-eval$-list-delete))) (prove-lemma equal-itimes-list-eval$-list-delete-new-2 (rewrite) (implies (not (equal (fix-int (eval$ t elt a)) 0)) (equal (equal (itimes-list (eval$ 'list (delete elt bag) a)) x) (if (member elt bag) (and (integerp x) (equal (itimes x (eval$ t elt a) ) (itimes-list (eval$ 'list bag a)))) (equal x (itimes-list (eval$ 'list bag a))))))) (prove-lemma itimes-itimes-list-eval$-list-delete (rewrite) (implies (member x bag) (equal (itimes (eval$ t x a) (itimes-list (eval$ 'list (delete x bag) a))) (itimes-list (eval$ 'list bag a))))) (prove-lemma equal-itimes-list-eval$-list-bagdiff (rewrite) (implies (and (subbagp in-both bag1) (subbagp in-both bag2) (not (equal (itimes-list (eval$ 'list in-both a)) 0))) (equal (equal (itimes-list (eval$ 'list (bagdiff bag1 in-both) a)) (itimes-list (eval$ 'list (bagdiff bag2 in-both) a))) (equal (itimes-list (eval$ 'list bag1 a)) (itimes-list (eval$ 'list bag2 a)))))) (prove-lemma membership-of-0-implies-itimes-list-is-0 (rewrite) (implies (member 0 x) (equal (itimes-list x) 0))) (prove-lemma member-0-eval$-list (rewrite) (implies (member 0 x) (member 0 (eval$ 'list x a)))) (prove-lemma itimes-list-eval$-factors-lemma (rewrite) (equal (itimes (itimes-list (eval$ 'list (bagint bag1 bag2) a)) (itimes-list (eval$ 'list (bagdiff bag2 (bagint bag1 bag2)) a))) (itimes-list (eval$ 'list bag2 a))) ((use (itimes-list-bagdiff (x (bagint bag1 bag2)) (y bag2))))) (prove-lemma itimes-list-eval$-factors-lemma-prime (rewrite) (equal (itimes (itimes-list (eval$ 'list (bagint bag1 bag2) a)) (itimes-list (eval$ 'list (bagdiff bag1 (bagint bag1 bag2)) a))) (itimes-list (eval$ 'list bag1 a))) ((use (itimes-list-bagdiff (x (bagint bag1 bag2)) (y bag1))))) (prove-lemma itimes-list-eval$-factors (rewrite) ;; similar to ITIMES-LIST-EVAL$-FRINGE, except one has to reason about bagdiff etc. (equal (itimes-list (eval$ 'list (itimes-factors x) a)) (fix-int (eval$ t x a))) ((induct (itimes-factors x)) (enable ;;eval$-list-append ;; already enabled now integerp-eval$-itimes itimes-list-bagdiff listp-bagint-with-singleton-member))) (prove-lemma iplus-or-itimes-term-integerp-eval$ (rewrite) (implies (iplus-or-itimes-term x) (integerp (eval$ t x a))) ((enable iplus-or-itimes-term))) (prove-lemma eval$-list-bagint-0 nil (implies (equal (itimes-list (eval$ 'list (bagint x y) a)) 0) (and (equal (itimes-list (eval$ 'list x a)) 0) (equal (itimes-list (eval$ 'list y a)) 0))) ((use (subsetp-implies-itimes-list-eval$-equals-0 (x (bagint x y)) (y x)) (subsetp-implies-itimes-list-eval$-equals-0 (x (bagint x y)) (y y))))) (prove-lemma eval$-list-bagint-0-implies-equal (rewrite) (implies (and (equal (itimes-list (eval$ 'list (bagint (itimes-factors v) (itimes-factors w)) a)) 0) (integerp (eval$ t v a)) (integerp (eval$ t w a))) (equal (equal (eval$ t v a) (eval$ t w a)) t)) ((use (eval$-list-bagint-0 (x (itimes-factors v)) (y (itimes-factors w)))))) (prove-lemma correctness-of-cancel-itimes-factors ((meta equal)) (equal (eval$ t x a) (eval$ t (cancel-itimes-factors-expanded x) a)) ((do-not-induct t) (enable eval$-itimes-tree eval$-make-cancel-itimes-equality))) ;; OK -- now, the lessp case, finally. Ugh! (defn cancel-itimes-ilessp-factors (x) (if (listp x) (if (equal (car x) 'ilessp) (if (listp (bagint (itimes-factors (cadr x)) (itimes-factors (caddr x)))) (make-cancel-itimes-inequality (itimes-factors (cadr x)) (itimes-factors (caddr x)) (bagint (itimes-factors (cadr x)) (itimes-factors (caddr x)))) x) x) x)) (prove-lemma bagint-singleton (rewrite) (equal (bagint x (list y)) (if (member y x) (list y) nil))) (prove-lemma izerop-ilessp-0-relationship (rewrite) (equal (equal (fix-int x) 0) (and (not (ilessp x 0)) (not (ilessp 0 x)))) ((enable-theory integer-defns))) (prove-lemma ilessp-itimes-list-eval$-list-delete-helper-1 (rewrite) (implies (ilessp 0 w) (equal (ilessp (itimes x w) (itimes w u)) (ilessp x u)))) (prove-lemma ilessp-itimes-list-eval$-list-delete-helper-2 (rewrite) (implies (ilessp w 0) (equal (ilessp (itimes w u) (itimes x w)) (ilessp x u)))) (prove-lemma ilessp-itimes-list-eval$-list-delete (rewrite) (implies (and (member z y) (not (equal (fix-int (eval$ t z a)) 0))) (equal (ilessp x (itimes-list (eval$ 'list (delete z y) a))) (if (ilessp 0 (eval$ t z a)) (ilessp (itimes x (eval$ t z a)) (itimes-list (eval$ 'list y a))) (if (ilessp (eval$ t z a) 0) (ilessp (itimes-list (eval$ 'list y a)) (itimes x (eval$ t z a))) f)))) ((enable itimes-list-eval$-delete) (disable itimes-itimes-list-eval$-list-delete))) (prove-lemma ilessp-itimes-list-eval$-list-delete-prime-helper-1 (rewrite) (implies (ilessp 0 w) (equal (ilessp (itimes w u) (itimes x w)) (ilessp u x)))) (prove-lemma ilessp-itimes-list-eval$-list-delete-prime-helper-2 (rewrite) (implies (ilessp w 0) (equal (ilessp (itimes x w) (itimes w u)) (ilessp u x)))) (prove-lemma ilessp-itimes-list-eval$-list-delete-prime (rewrite) (implies (and (member z y) (not (equal (fix-int (eval$ t z a)) 0))) (equal (ilessp (itimes-list (eval$ 'list (delete z y) a)) x) (if (ilessp 0 (eval$ t z a)) (ilessp (itimes-list (eval$ 'list y a)) (itimes x (eval$ t z a))) (if (ilessp (eval$ t z a) 0) (ilessp (itimes x (eval$ t z a)) (itimes-list (eval$ 'list y a))) f)))) ((enable itimes-list-eval$-delete) (disable itimes-itimes-list-eval$-list-delete ilessp-itimes-list-eval$-list-delete))) ;; **** Do I have anything like the following two lemmas for the equality case? ;; Should I? ;;;***** I should also consider if I've dealt with things like 0 = a*x + b*x, and ;;; simlilarly for ilessp. (prove-lemma ilessp-0-itimes (rewrite) (equal (ilessp 0 (itimes x y)) (or (and (ilessp 0 x) (ilessp 0 y)) (and (ilessp x 0) (ilessp y 0)))) ((enable-theory integer-defns))) (prove-lemma ilessp-itimes-0 (rewrite) (equal (ilessp (itimes x y) 0) (or (and (ilessp 0 x) (ilessp y 0)) (and (ilessp x 0) (ilessp 0 y)))) ((enable-theory integer-defns))) (prove-lemma ilessp-itimes-list-eval$-list-bagdiff (rewrite) (implies (and (subbagp in-both bag1) (subbagp in-both bag2) (not (equal (itimes-list (eval$ 'list in-both a)) 0))) (equal (ilessp (itimes-list (eval$ 'list (bagdiff bag1 in-both) a)) (itimes-list (eval$ 'list (bagdiff bag2 in-both) a))) (if (ilessp 0 (itimes-list (eval$ 'list in-both a))) (ilessp (itimes-list (eval$ 'list bag1 a)) (itimes-list (eval$ 'list bag2 a))) (ilessp (itimes-list (eval$ 'list bag2 a)) (itimes-list (eval$ 'list bag1 a)))))) ((enable ilessp-trichotomy) (disable izerop-ilessp-0-relationship))) (prove-lemma zero-ilessp-implies-not-equal nil ;; This is not a rewrite rule because I don't want to slow down ;; the rewriter. Maybe that's not such a great decision. (implies (ilessp 0 x) (not (equal 0 x)))) (prove-lemma ilessp-itimes-list-eval$-list-bagdiff-corollary-1 (rewrite) (implies (and (subbagp in-both bag1) (subbagp in-both bag2) (ilessp 0 (itimes-list (eval$ 'list in-both a)))) (equal (ilessp (itimes-list (eval$ 'list (bagdiff bag1 in-both) a)) (itimes-list (eval$ 'list (bagdiff bag2 in-both) a))) (ilessp (itimes-list (eval$ 'list bag1 a)) (itimes-list (eval$ 'list bag2 a))))) ((use (zero-ilessp-implies-not-equal (x (itimes-list (eval$ 'list in-both a))))))) (prove-lemma ilessp-zero-implies-not-equal nil ;; This is not a rewrite rule because I don't want to slow down ;; the rewriter. Maybe that's not such a great decision. (implies (ilessp x 0) (not (equal 0 x)))) (prove-lemma ilessp-itimes-list-eval$-list-bagdiff-corollary-2 (rewrite) (implies (and (subbagp in-both bag1) (subbagp in-both bag2) (ilessp (itimes-list (eval$ 'list in-both a)) 0)) (equal (ilessp (itimes-list (eval$ 'list (bagdiff bag1 in-both) a)) (itimes-list (eval$ 'list (bagdiff bag2 in-both) a))) (ilessp (itimes-list (eval$ 'list bag2 a)) (itimes-list (eval$ 'list bag1 a))))) ((use (ilessp-zero-implies-not-equal (x (itimes-list (eval$ 'list in-both a))))))) (prove-lemma member-0-itimes-factors-yields-0 (rewrite) ;; I'll hang this on MEMBER for efficiency (implies (not (equal (eval$ t w a) 0)) (not (member 0 (itimes-factors w))))) (prove-lemma member-0-itimes-factors-yields-0-ilessp-consequence-1 (rewrite) ;; I'll hang this on MEMBER for efficiency (implies (ilessp (eval$ t w a) 0) (not (member 0 (itimes-factors w)))) ((use (member-0-itimes-factors-yields-0)))) (prove-lemma member-0-itimes-factors-yields-0-ilessp-consequence-2 (rewrite) ;; I'll hang this on MEMBER for efficiency (implies (ilessp 0 (eval$ t w a)) (not (member 0 (itimes-factors w)))) ((use (member-0-itimes-factors-yields-0)))) #| (prove-lemma eval$-list-bagint-0 nil (implies (equal (itimes-list (eval$ 'list (bagint x y) a)) 0) (and (equal (itimes-list (eval$ 'list x a)) 0) (equal (itimes-list (eval$ 'list y a)) 0))) ((use (subsetp-implies-itimes-list-eval$-equals-0 (x (bagint x y)) (y x)) (subsetp-implies-itimes-list-eval$-equals-0 (x (bagint x y)) (y y))))) |# #| (prove-lemma eval$-list-bagint-0-implies-equal (rewrite) (implies (and (equal (itimes-list (eval$ 'list (bagint (itimes-factors v) (itimes-factors w)) a)) 0) (integerp (eval$ t v a)) (integerp (eval$ t w a))) (equal (equal (eval$ t v a) (eval$ t w a)) t)) ((use (eval$-list-bagint-0 (x (itimes-factors v)) (y (itimes-factors w)))))) |# ;; At this point I'm going to switch the states of ilessp-trichotomy and ;; izerop-ilessp-0-relationship, for good (or till I change my mind again!). (enable ilessp-trichotomy) (disable izerop-ilessp-0-relationship) (prove-lemma eval$-list-bagint-0-for-ilessp nil (implies (and (not (ilessp (itimes-list (eval$ 'list (bagint x y) a)) 0)) (not (ilessp 0 (itimes-list (eval$ 'list (bagint x y) a))))) (and (equal (fix-int (itimes-list (eval$ 'list x a))) 0) (equal (fix-int (itimes-list (eval$ 'list y a))) 0))) ((use (subsetp-implies-itimes-list-eval$-equals-0 (x (bagint x y)) (y x)) (subsetp-implies-itimes-list-eval$-equals-0 (x (bagint x y)) (y y))))) (prove-lemma eval$-list-bagint-0-implies-equal-for-ilessp-lemma nil (implies (and (not (ilessp (itimes-list (eval$ 'list (bagint (itimes-factors v) (itimes-factors w)) a)) 0)) (not (ilessp 0 (itimes-list (eval$ 'list (bagint (itimes-factors v) (itimes-factors w)) a))))) (equal (fix-int (eval$ t v a)) (fix-int (eval$ t w a)))) ((use (eval$-list-bagint-0-for-ilessp (x (itimes-factors v)) (y (itimes-factors w)))))) (prove-lemma equal-fix-int-to-ilessp nil ;; Not a rewrite rule, for efficiency (implies (equal (fix-int x) (fix-int y)) (not (ilessp x y))) ((enable-theory integer-defns))) (prove-lemma eval$-list-bagint-0-implies-equal-for-ilessp (rewrite) (implies (and (not (ilessp (itimes-list (eval$ 'list (bagint (itimes-factors v) (itimes-factors w)) a)) 0)) (not (ilessp 0 (itimes-list (eval$ 'list (bagint (itimes-factors v) (itimes-factors w)) a))))) (and (not (ilessp (eval$ t v a) (eval$ t w a))) (not (ilessp (eval$ t w a) (eval$ t v a))))) ((use (eval$-list-bagint-0-implies-equal-for-ilessp-lemma) (equal-fix-int-to-ilessp (x (eval$ t v a)) (y (eval$ t w a))) (equal-fix-int-to-ilessp (x (eval$ t w a)) (y (eval$ t v a)))))) ;; The rewrite rule ILESSP-TRICHOTOMY seemed to mess up the proof of the following, ;; so I'm just going to leave it disabled. (disable ilessp-trichotomy) (prove-lemma correctness-of-cancel-itimes-ilessp-factors ((meta ilessp)) (equal (eval$ t x a) (eval$ t (cancel-itimes-ilessp-factors x) a)) ((do-not-induct t) (enable eval$-itimes-tree-no-fix-int-1 eval$-itimes-tree-no-fix-int-2 eval$-itimes-tree eval$-make-cancel-itimes-inequality))) ;; OK -- now, the zero cases. (enable LESSP-COUNT-LISTP-CDR) (defn disjoin-equalities-with-0 (factors) (if (listp (cdr factors)) (list 'or (list 'equal (list 'fix-int (car factors)) ''0) (disjoin-equalities-with-0 (cdr factors))) (list 'equal (list 'fix-int (car factors)) ''0))) (disable LESSP-COUNT-LISTP-CDR) (defn cancel-factors-0 (x) (if (listp x) (if (equal (car x) 'equal) (if (equal (cadr x) ''0) (let ((factors (itimes-factors (caddr x)))) (if (listp (cdr factors)) (disjoin-equalities-with-0 factors) x)) (if (equal (caddr x) ''0) (let ((factors (itimes-factors (cadr x)))) (if (listp (cdr factors)) (disjoin-equalities-with-0 factors) x)) x)) x) x)) (defn some-eval$s-to-0 (x a) ;; says that some member of x eval$s to an izerop (if (listp x) (or (equal (fix-int (eval$ t (car x) a)) 0) (some-eval$s-to-0 (cdr x) a)) f)) (prove-lemma eval$-disjoin-equalities-with-0 (rewrite) (implies (listp lst) (equal (eval$ t (disjoin-equalities-with-0 lst) a) (some-eval$s-to-0 lst a)))) (prove-lemma some-eval$s-to-0-append (rewrite) (equal (some-eval$s-to-0 (append x y) a) (or (some-eval$s-to-0 x a) (some-eval$s-to-0 y a)))) (prove-lemma some-eval$s-to-0-eliminator (rewrite) (equal (some-eval$s-to-0 x a) (equal (itimes-list (eval$ 'list x a)) 0))) (prove-lemma listp-cdr-factors-implies-integerp (rewrite) (implies (listp (cdr (itimes-factors v))) (integerp (eval$ t v a))) ((expand (itimes-factors v)))) (prove-lemma correctness-of-cancel-factors-0 ((meta equal)) (equal (eval$ t x a) (eval$ t (cancel-factors-0 x) a))) ;; and now for inequalities... (enable LESSP-COUNT-LISTP-CDR) (defn conjoin-inequalities-with-0 (factors parity) ;; Returns an inequality saying that 0 is less than the product of the ;; factors if parity is not F and the other way around otherwise. (if (listp (cdr factors)) (if parity (list 'or (list 'and (list 'ilessp ''0 (car factors)) (conjoin-inequalities-with-0 (cdr factors) t)) (list 'and (list 'ilessp (car factors) ''0) (conjoin-inequalities-with-0 (cdr factors) f))) (list 'or (list 'and (list 'ilessp (car factors) ''0) (conjoin-inequalities-with-0 (cdr factors) t)) (list 'and (list 'ilessp ''0 (car factors)) (conjoin-inequalities-with-0 (cdr factors) f)))) (if parity (list 'ilessp ''0 (car factors)) (list 'ilessp (car factors) ''0)))) (disable lessp-count-listp-cdr) (defn cancel-factors-ilessp-0 (x) (if (listp x) (if (equal (car x) 'ilessp) (if (equal (cadr x) ''0) (let ((factors (itimes-factors (caddr x)))) (if (listp (cdr factors)) (conjoin-inequalities-with-0 factors t) x)) (if (equal (caddr x) ''0) (let ((factors (itimes-factors (cadr x)))) (if (listp (cdr factors)) (conjoin-inequalities-with-0 factors f) x)) x)) x) x)) (prove-lemma conjoin-inequalities-with-0-eliminator (rewrite) (implies (listp x) (equal (eval$ t (conjoin-inequalities-with-0 x parity) a) (if parity (ilessp 0 (itimes-list (eval$ 'list x a))) (ilessp (itimes-list (eval$ 'list x a)) 0))))) (prove-lemma correctness-of-cancel-factors-ilessp-0 ((meta ilessp)) (equal (eval$ t x a) (eval$ t (cancel-factors-ilessp-0 x) a))) (disable equal-itimes-list-eval$-list-delete-new-1) (disable equal-itimes-list-eval$-list-delete-new-2) (disable itimes-itimes-list-eval$-list-delete) (disable equal-itimes-list-eval$-list-bagdiff) (disable itimes-list-eval$-factors-lemma) (disable itimes-list-eval$-factors-lemma-prime) (disable itimes-list-eval$-factors) (disable iplus-or-itimes-term-integerp-eval$) (disable eval$-list-bagint-0) (disable eval$-list-bagint-0-implies-equal) (disable izerop-ilessp-0-relationship) (disable ilessp-itimes-list-eval$-list-delete-helper-1) (disable ilessp-itimes-list-eval$-list-delete-helper-2) (disable ilessp-itimes-list-eval$-list-delete) (disable ilessp-itimes-list-eval$-list-delete-prime-helper-1) (disable ilessp-itimes-list-eval$-list-delete-prime-helper-2) (disable ilessp-itimes-list-eval$-list-delete-prime) (disable ilessp-0-itimes) (disable ilessp-itimes-0) (disable listp-cdr-factors-implies-integerp) ;; We presumably have better meta-lemmas now, but if we want we ;; can disable those (i.e., correctness-of-cancel-itimes-factors, ;; correctness-of-cancel-itimes-ilessp-factors, ;; correctness-of-cancel-factors-0, and ;; correctness-of-cancel-factors-ilessp-0) and enable the two ;; mentioned below: (disable correctness-of-cancel-itimes) (disable correctness-of-cancel-itimes-ilessp) ;; I'll disable some rules now, finally, that I'd previously thought ;; would be OK but now fear because of potential nasty backchaining. (disable not-integerp-implies-not-equal-iplus) (disable not-integerp-implies-not-equal-itimes) (disable subbagp-subsetp) (disable eval$-list-bagint-0-implies-equal-for-ilessp) ; ---------- Cancel ineg terms from equalities and inequalities ---------- (defn split-out-ineg-terms (x) ;; Here x is a list and we return a pair consisting of ;; a list of the terms in x not starting with INEG and a list ;; of those terms that do (with their INEG headers stripped off). (if (listp x) (let ((pair (split-out-ineg-terms (cdr x))) (a (car x))) (if (listp a) (if (equal (car a) 'ineg) (cons (car pair) (cons (cadr a) (cdr pair))) (if (and (equal (car a) 'quote) (negativep (cadr a)) (not (equal (negative-guts (cadr a)) 0))) (cons (car pair) (cons (list 'quote (negative-guts (cadr a))) (cdr pair))) (cons (cons a (car pair)) (cdr pair)))) (cons (cons a (car pair)) (cdr pair)))) (cons nil nil))) (defn remove-inegs (x y) ;; x and y are term lists that are known to represent integers. ;; The idea is to rearrange (equal x y) or (ilessp x y). Notice ;; that the negative terms are put in the front, so that APPEND ;; will run fast and do no CONSing in the frequent case that ;; there are no negative terms. ;; Returns F, though, if there's no change at all. I was getting ;; into an infinite loop when I built a new term, since there was ;; an extra FIX-INT put there. (let ((xpair (split-out-ineg-terms x)) (ypair (split-out-ineg-terms y))) (if (or (listp (cdr xpair)) (listp (cdr ypair))) (cons (append (cdr ypair) (car xpair)) (append (cdr xpair) (car ypair))) f))) (defn iplus-or-ineg-term (x) (and (listp x) (or (equal (car x) (quote ineg)) (equal (car x) (quote iplus))))) (defn make-cancel-ineg-terms-equality (x) (let ((new-fringes (remove-inegs (iplus-fringe (cadr x)) (iplus-fringe (caddr x))))) (if new-fringes (if (iplus-or-ineg-term (cadr x)) (if (iplus-or-ineg-term (caddr x)) (list (quote equal) (iplus-tree (car new-fringes)) (iplus-tree (cdr new-fringes))) (list 'if (list 'integerp (caddr x)) (list (quote equal) (iplus-tree (car new-fringes)) (iplus-tree (cdr new-fringes))) (list 'quote f))) ;; otherwise, the first argument is not an iplus or ineg term (if (iplus-or-ineg-term (caddr x)) (list 'if (list 'integerp (cadr x)) (list (quote equal) (iplus-tree (car new-fringes)) (iplus-tree (cdr new-fringes))) (list 'quote f)) x)) x))) (defn cancel-ineg-terms-from-equality (x) (if (and (listp x) (equal (car x) (quote equal))) (make-cancel-ineg-terms-equality x) x)) ;; The following was created from nqthm-macroexpand with arguments ;; and or make-cancel-ineg-terms-equality iplus-or-ineg-term (DEFN CANCEL-INEG-TERMS-FROM-EQUALITY-expanded (X) (IF (LISTP X) (IF (EQUAL (CAR X) 'EQUAL) (IF (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))) (COND ((LISTP (CADR X)) (CASE (CAR (CAR (CDR X))) (INEG (IF (LISTP (CADDR X)) (CASE (CAR (CAR (CDR (CDR X)))) (INEG (LIST 'EQUAL (IPLUS-TREE (CAR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))))) (IPLUS-TREE (CDR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))))))) (IPLUS (LIST 'EQUAL (IPLUS-TREE (CAR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))))) (IPLUS-TREE (CDR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))))))) (OTHERWISE (LIST 'IF (LIST 'INTEGERP (CADDR X)) (LIST 'EQUAL (IPLUS-TREE (CAR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))))) (IPLUS-TREE (CDR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X)))))) (LIST 'QUOTE F)))) (LIST 'IF (LIST 'INTEGERP (CADDR X)) (LIST 'EQUAL (IPLUS-TREE (CAR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))))) (IPLUS-TREE (CDR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X)))))) (LIST 'QUOTE F)))) (IPLUS (IF (LISTP (CADDR X)) (CASE (CAR (CAR (CDR (CDR X)))) (INEG (LIST 'EQUAL (IPLUS-TREE (CAR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))))) (IPLUS-TREE (CDR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))))))) (IPLUS (LIST 'EQUAL (IPLUS-TREE (CAR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))))) (IPLUS-TREE (CDR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))))))) (OTHERWISE (LIST 'IF (LIST 'INTEGERP (CADDR X)) (LIST 'EQUAL (IPLUS-TREE (CAR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))))) (IPLUS-TREE (CDR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X)))))) (LIST 'QUOTE F)))) (LIST 'IF (LIST 'INTEGERP (CADDR X)) (LIST 'EQUAL (IPLUS-TREE (CAR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))))) (IPLUS-TREE (CDR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X)))))) (LIST 'QUOTE F)))) (OTHERWISE (IF (LISTP (CADDR X)) (CASE (CAR (CAR (CDR (CDR X)))) (INEG (LIST 'IF (LIST 'INTEGERP (CADR X)) (LIST 'EQUAL (IPLUS-TREE (CAR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))))) (IPLUS-TREE (CDR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X)))))) (LIST 'QUOTE F))) (IPLUS (LIST 'IF (LIST 'INTEGERP (CADR X)) (LIST 'EQUAL (IPLUS-TREE (CAR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))))) (IPLUS-TREE (CDR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X)))))) (LIST 'QUOTE F))) (OTHERWISE X)) X)))) ((LISTP (CADDR X)) (CASE (CAR (CAR (CDR (CDR X)))) (INEG (LIST 'IF (LIST 'INTEGERP (CADR X)) (LIST 'EQUAL (IPLUS-TREE (CAR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))))) (IPLUS-TREE (CDR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X)))))) (LIST 'QUOTE F))) (IPLUS (LIST 'IF (LIST 'INTEGERP (CADR X)) (LIST 'EQUAL (IPLUS-TREE (CAR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))))) (IPLUS-TREE (CDR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X)))))) (LIST 'QUOTE F))) (OTHERWISE X))) (T X)) X) X) X)) (prove-lemma CANCEL-INEG-TERMS-FROM-EQUALITY-CANCEL-INEG-TERMS-FROM-EQUALITY-expanded (rewrite) (equal (CANCEL-INEG-TERMS-FROM-EQUALITY-expanded x) (CANCEL-INEG-TERMS-FROM-EQUALITY x)) ((disable-theory t) (enable-theory ground-zero) (enable make-cancel-ineg-terms-equality iplus-or-ineg-term CANCEL-INEG-TERMS-FROM-EQUALITY-expanded CANCEL-INEG-TERMS-FROM-EQUALITY))) (disable CANCEL-INEG-TERMS-FROM-EQUALITY-expanded) (prove-lemma integerp-eval$-iplus-or-ineg-term (rewrite) (implies (iplus-or-ineg-term x) (integerp (eval$ t x a)))) (disable iplus-or-ineg-term) (prove-lemma eval$-iplus-list-car-remove-inegs (rewrite) (implies (remove-inegs x y) (equal (iplus-list (eval$ 'list (car (remove-inegs x y)) a)) (iplus (iplus-list (eval$ 'list (car (split-out-ineg-terms x)) a)) (iplus-list (eval$ 'list (cdr (split-out-ineg-terms y)) a)))))) (prove-lemma eval$-iplus-list-cdr-remove-inegs (rewrite) (implies (remove-inegs x y) (equal (iplus-list (eval$ 'list (cdr (remove-inegs x y)) a)) (iplus (iplus-list (eval$ 'list (car (split-out-ineg-terms y)) a)) (iplus-list (eval$ 'list (cdr (split-out-ineg-terms x)) a)))))) (prove-lemma minus-ineg (rewrite) (implies (and (numberp x) (not (equal x 0))) (equal (minus x) (ineg x))) ((enable-theory integer-defns))) (prove-lemma iplus-list-eval$-car-split-out-ineg-terms (rewrite) (equal (iplus-list (eval$ 'list (car (split-out-ineg-terms x)) a)) (iplus (iplus-list (eval$ 'list x a)) (iplus-list (eval$ 'list (cdr (split-out-ineg-terms x)) a)))) ((induct (split-out-ineg-terms x)) (enable eval$-quote))) (disable remove-inegs) (prove-lemma correctness-of-cancel-ineg-terms-from-equality ((meta equal)) (equal (eval$ t x a) (eval$ t (cancel-ineg-terms-from-equality-expanded x) a)) ((enable eval$-iplus-tree iplus-list-eval$-fringe eval$-quote) (disable iplus-fringe))) (defn make-cancel-ineg-terms-inequality (x) (let ((new-fringes (remove-inegs (iplus-fringe (cadr x)) (iplus-fringe (caddr x))))) (if new-fringes (list (quote ilessp) (iplus-tree (car new-fringes)) (iplus-tree (cdr new-fringes))) x))) (defn cancel-ineg-terms-from-inequality (x) (if (and (listp x) (equal (car x) (quote ilessp))) ;; the tests below are for efficiency only (if (iplus-or-ineg-term (cadr x)) (make-cancel-ineg-terms-inequality x) (if (iplus-or-ineg-term (caddr x)) (make-cancel-ineg-terms-inequality x) x)) x)) ;; The following was created from nqthm-macroexpand with arguments ;; and or make-cancel-ineg-terms-inequality iplus-or-ineg-term (DEFN CANCEL-INEG-TERMS-FROM-INEQUALITY-expanded (X) (IF (LISTP X) (IF (EQUAL (CAR X) 'ILESSP) (COND ((LISTP (CADR X)) (CASE (CAR (CAR (CDR X))) (INEG (IF (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))) (LIST 'ILESSP (IPLUS-TREE (CAR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))))) (IPLUS-TREE (CDR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X)))))) X)) (IPLUS (IF (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))) (LIST 'ILESSP (IPLUS-TREE (CAR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))))) (IPLUS-TREE (CDR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X)))))) X)) (OTHERWISE (IF (LISTP (CADDR X)) (CASE (CAR (CAR (CDR (CDR X)))) (INEG (IF (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))) (LIST 'ILESSP (IPLUS-TREE (CAR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))))) (IPLUS-TREE (CDR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X)))))) X)) (IPLUS (IF (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))) (LIST 'ILESSP (IPLUS-TREE (CAR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))))) (IPLUS-TREE (CDR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X)))))) X)) (OTHERWISE X)) X)))) ((LISTP (CADDR X)) (CASE (CAR (CAR (CDR (CDR X)))) (INEG (IF (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))) (LIST 'ILESSP (IPLUS-TREE (CAR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))))) (IPLUS-TREE (CDR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X)))))) X)) (IPLUS (IF (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))) (LIST 'ILESSP (IPLUS-TREE (CAR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X))))) (IPLUS-TREE (CDR (REMOVE-INEGS (IPLUS-FRINGE (CADR X)) (IPLUS-FRINGE (CADDR X)))))) X)) (OTHERWISE X))) (T X)) X) X)) (prove-lemma CANCEL-INEG-TERMS-FROM-INEQUALITY-CANCEL-INEG-TERMS-FROM-INEQUALITY-expanded (rewrite) (equal (CANCEL-INEG-TERMS-FROM-INEQUALITY-expanded x) (CANCEL-INEG-TERMS-FROM-INEQUALITY x)) ((disable-theory t) (enable-theory ground-zero) (enable make-cancel-ineg-terms-inequality iplus-or-ineg-term CANCEL-INEG-TERMS-FROM-INEQUALITY-expanded CANCEL-INEG-TERMS-FROM-INEQUALITY))) (disable CANCEL-INEG-TERMS-FROM-INEQUALITY-expanded) (prove-lemma correctness-of-cancel-ineg-terms-from-inequality ((meta ilessp)) (equal (eval$ t x a) (eval$ t (cancel-ineg-terms-from-inequality-expanded x) a)) ((enable eval$-iplus-tree iplus-list-eval$-fringe eval$-quote) (disable iplus-fringe))) (disable minus-ineg) (disable integerp-eval$-iplus-or-ineg-term) ; ---------- Eliminating constants ---------- ;; We want to combine in terms like (iplus 3 (iplus x 7)). Also, when ;; two iplus terms are equated or in-equated, there should only be a ;; natural number summand on at most one side. Finally, if one adds 1 ;; to the right side of a strict inequality, a stronger inequality (in ;; a certain sense) is obtained by removing the 1 and making a non-strict ;; inequality in the other direction. (prove-lemma plus-iplus (rewrite) (implies (and (numberp i) (numberp j)) (equal (plus i j) (iplus i j))) ((enable iplus))) (prove-lemma iplus-constants (rewrite) ;; by now the term presumably has no MINUS terms in it (equal (iplus (add1 i) (iplus (add1 j) x)) (iplus (plus (add1 i) (add1 j)) x)) ((enable fix-int integerp) (disable plus-add1-arg1))) (prove-lemma numberp-is-integerp (rewrite) (implies (numberp w) (integerp w)) ((enable integerp))) (prove-lemma difference-idifference (rewrite) (implies (and (numberp x) (numberp y) (leq x y)) (equal (difference y x) (idifference y x)))) (prove-lemma cancel-constants-equal-lemma nil (implies (and (numberp m) (numberp n)) (equal (equal (iplus m x) (iplus n y)) (if (lessp m n) (equal (fix-int x) (iplus (difference n m) y)) (equal (iplus (difference m n) x) (fix-int y)))))) (prove-lemma cancel-constants-equal (rewrite) (equal (equal (iplus (add1 i) x) (iplus (add1 j) y)) (if (lessp i j) (equal (fix-int x) (iplus (difference j i) y)) (equal (iplus (difference i j) x) (fix-int y)))) ((use (cancel-constants-equal-lemma (m (add1 i)) (n (add1 j)))) (expand (difference (add1 i) (add1 j)) (difference (add1 j) (add1 i)) (lessp (add1 i) (add1 j))) (disable-theory t) (enable-theory ground-zero))) (prove-lemma ilessp-add1 (rewrite) (implies (numberp y) (equal (ilessp x (add1 y)) (not (ilessp y x)))) ((enable-theory integer-defns))) (prove-lemma ilessp-add1-iplus (rewrite) (implies (numberp y) (equal (ilessp x (iplus (add1 y) z)) (not (ilessp (iplus y z) x)))) ((enable-theory integer-defns) (disable plus-iplus difference-idifference))) (prove-lemma cancel-constants-ilessp-lemma-1 nil (implies (and (numberp m) (numberp n)) (equal (ilessp (iplus m x) (iplus n y)) (if (lessp m n) (ilessp x (iplus (difference n m) y)) (ilessp (iplus (difference m n) x) y))))) (prove-lemma cancel-constants-ilessp-lemma-2 nil (implies (and (numberp m) (numberp n)) (equal (ilessp (iplus m x) (iplus n y)) (if (lessp m n) (not (ilessp (iplus (sub1 (difference n m)) y) x)) (ilessp (iplus (difference m n) x) y)))) ((use (cancel-constants-ilessp-lemma-1) (ilessp-add1-iplus (y (sub1 (difference n m))) (z y) (x x))) (disable ilessp-add1-iplus))) (prove-lemma cancel-constants-ilessp (rewrite) (equal (ilessp (iplus (add1 i) x) (iplus (add1 j) y)) (if (lessp i j) (not (ilessp (iplus (sub1 (difference j i)) y) x)) (ilessp (iplus (difference i j) x) y))) ((use (cancel-constants-ilessp-lemma-2 (m (add1 i)) (n (add1 j)))) (expand (difference (add1 i) (add1 j)) (difference (add1 j) (add1 i)) (lessp (add1 i) (add1 j))) (disable-theory t) (enable-theory ground-zero))) (disable plus-iplus) (disable numberp-is-integerp) (disable difference-idifference) ; ---------- Final DEFTHEORY event ---------- ;; I'll go ahead and include iplus-list and itimes-list and lemmas ;; about them that were developed. ;; I've left out ILESSP-TRICHOTOMY because I'm scared it will slow ;; things down too much. But it certainly represents useful ;; information. (deftheory integers (ileq idifference integerp-fix-int integerp-iplus integerp-idifference integerp-ineg integerp-iabs integerp-itimes fix-int-remover fix-int-fix-int fix-int-iplus fix-int-idifference fix-int-ineg fix-int-iabs fix-int-itimes ineg-iplus ineg-ineg ineg-fix-int ineg-of-non-integerp ineg-0 iplus-left-id iplus-right-id iplus-0-left iplus-0-right commutativity2-of-iplus commutativity-of-iplus associativity-of-iplus iplus-cancellation-1 iplus-cancellation-2 iplus-ineg1 iplus-ineg2 iplus-fix-int1 iplus-fix-int2 idifference-fix-int1 idifference-fix-int2 ;; iplus-fringe lessp-count-listp-cdr iplus-tree-rec iplus-tree iplus-list ;; eval$-iplus-tree-rec eval$-iplus-tree eval$-list-append ;; cancel-iplus iplus-list-append iplus-ineg3 iplus-ineg4 ;; iplus-list-eval$-fringe ;; not-integerp-implies-not-equal-iplus <<>> correctness-of-cancel-iplus ilessp-fix-int-1 ilessp-fix-int-2 ;; make-cancel-iplus-inequality-1 cancel-iplus-ilessp-1 ;; <<< I omit the following two facts because they're naturals facts, ;; and hence I feel that it's up to naturals to "export" ;; them >>> ;; lessp-difference-plus-arg1 lessp-difference-plus-arg1-commuted iplus-cancellation-1-for-ilessp iplus-cancellation-2-for-ilessp ;; correctness-of-cancel-iplus-ilessp-lemma iplus-tree-no-fix-int ;; eval$-ilessp-iplus-tree-no-fix-int ;; make-cancel-iplus-inequality-simplifier cancel-iplus-ilessp correctness-of-cancel-iplus-ilessp ;; itimes-zero1 itimes-0-left ;; itimes-zero2 itimes-0-right itimes-fix-int1 itimes-fix-int2 commutativity-of-itimes itimes-distributes-over-iplus-proof itimes-distributes-over-iplus commutativity2-of-itimes associativity-of-itimes equal-itimes-0 equal-itimes-1 equal-itimes-minus-1 itimes-1-arg1 quotient-remainder-uniqueness ;; division-theorem-part1 division-theorem-part2 division-theorem-part3 division-theorem ;; <<< Same comment as in angle braces above >>> quotient-difference-lessp-arg2 ;; iquotient-iremainder-uniqueness ;; division-theorem-for-truncate-to-neginf-part1 ;; division-theorem-for-truncate-to-neginf-part2 ;; division-theorem-for-truncate-to-neginf-part3 ;; division-theorem-for-truncate-to-neginf ;; idiv-imod-uniqueness ;; division-theorem-for-truncate-to-zero-part1 ;; division-theorem-for-truncate-to-zero-part2 ;; division-theorem-for-truncate-to-zero-part3 ;; division-theorem-for-truncate-to-zero iquo-irem-uniqueness itimes-ineg-1 itimes-ineg-2 itimes-cancellation-1 itimes-cancellation-2 itimes-cancellation-3 integerp-iquotient integerp-iremainder integerp-idiv integerp-imod integerp-iquo integerp-irem iquotient-fix-int1 iquotient-fix-int2 iremainder-fix-int1 iremainder-fix-int2 idiv-fix-int1 idiv-fix-int2 imod-fix-int1 imod-fix-int2 iquo-fix-int1 iquo-fix-int2 irem-fix-int1 irem-fix-int2 fix-int-iquotient fix-int-iremainder fix-int-idiv fix-int-imod fix-int-iquo fix-int-irem ;; itimes-fringe ;; itimes-tree-rec itimes-tree itimes-list ;; eval$-itimes-tree-rec ;; eval$-itimes-tree make-cancel-itimes-equality ;; cancel-itimes itimes-list-append ;; itimes-list-eval$-fringe ;; integerp-eval$-itimes ;; not-integerp-implies-not-equal-itimes <<>> ;; itimes-list-eval$-delete itimes-list-bagdiff ;; equal-itimes-list-eval$-list-delete member-append;; <<< I'll go ahead and export this since it's ;; so fundamental if one has member around. >>> ;; member-izerop-itimes-fringe correctness-of-cancel-itimes-hack-1 ;; eval$-make-cancel-itimes-equality ;; eval$-make-cancel-itimes-equality-1 equal-fix-int ;; eval$-make-cancel-itimes-equality-2 ;; eval$-equal-itimes-tree-itimes-fringe-0 ;; izerop-eval-of-member-implies-itimes-list-0 subsetp;; <<< May as well have this enabled if it's going to ;; be imported here. >>> ;; subsetp-implies-itimes-list-eval$-equals-0 ;; subbagp-subsetp <<>> ;; equal-0-itimes-list-eval$-bagint-1 ;; equal-0-itimes-list-eval$-bagint-2 ;; correctness-of-cancel-itimes-hack-2 ;; correctness-of-cancel-itimes-hack-3-lemma ;; correctness-of-cancel-itimes-hack-3 correctness-of-cancel-itimes ;; itimes-tree-no-fix-int eval$-itimes-tree-no-fix-int-1 ;; eval$-itimes-tree-no-fix-int-2 make-cancel-itimes-inequality ;; cancel-itimes-ilessp eval$-make-cancel-itimes-inequality ;; listp-bagint-with-singleton-implies-member itimes-list-eval$-list-0 ;; ilessp-itimes-right-positive ;; correctness-of-cancel-itimes-ilessp-hack-1 ;; listp-bagint-with-singleton-member <<< Too obscure to be worthwhile >>> ;; correctness-of-cancel-itimes-ilessp-hack-2-lemma ;; correctness-of-cancel-itimes-ilessp-hack-2 ;; ilessp-trichotomy <<>> ;; correctness-of-cancel-itimes-ilessp-hack-3-lemma-1 ;; correctness-of-cancel-itimes-ilessp-hack-3-lemma-2 ;; same-fix-int-implies-not-ilessp ;; correctness-of-cancel-itimes-ilessp-hack-3 ;; ilessp-itimes-right-negative ;; correctness-of-cancel-itimes-ilessp-hack-4 correctness-of-cancel-itimes-ilessp ilessp-strict ;; cancel-ineg-aux ;; cancel-ineg eval$-list-cons eval$-list-nlistp eval$-litatom eval$-quote eval$-other ;; eval$-cancel-ineg-aux-fn eval$-cancel-ineg-aux-is-its-fn iplus-ineg-promote iplus-x-y-ineg-x ;; correctness-of-cancel-ineg-aux correctness-of-cancel-ineg integerp-iplus-list ;; eval$-cancel-iplus eval$-iplus-list-delete eval$-iplus-list-bagdiff ;; iplus-ineg5-lemma-1 iplus-ineg5-lemma-2 iplus-ineg5 iplus-ineg6 ;; eval$-iplus plus-ineg7 ;; <<>> ITIMES-TREE-INEG ITIMES-FACTORS ITIMES--1 EQUAL-INEG-INEG ILESSP-INEG-INEG FIX-INT-EVAL$-ITIMES-TREE-REC ;may as well leave it enabled EVAL$-ITIMES-TREE-INEG ;may as well leave it enabled INEG-EVAL$-ITIMES-TREE-INEG ;may as well leave it enabled IPLUS-EVAL$-ITIMES-TREE-INEG ;may as well leave it enabled ITIMES-EVAL$-ITIMES-TREE-INEG ;may as well leave it enabled IPLUS-OR-ITIMES-TERM CANCEL-ITIMES-FACTORS CANCEL-ITIMES-FACTORS-EXPANDED CANCEL-ITIMES-FACTORS-EXPANDED-CANCEL-ITIMES-FACTORS ;; EQUAL-ITIMES-LIST-EVAL$-LIST-DELETE-NEW-1 ;; EQUAL-ITIMES-LIST-EVAL$-LIST-DELETE-NEW-2 ;; ITIMES-ITIMES-LIST-EVAL$-LIST-DELETE ;; EQUAL-ITIMES-LIST-EVAL$-LIST-BAGDIFF MEMBERSHIP-OF-0-IMPLIES-ITIMES-LIST-IS-0 MEMBER-0-EVAL$-LIST ;; ITIMES-LIST-EVAL$-FACTORS-LEMMA ;; ITIMES-LIST-EVAL$-FACTORS-LEMMA-PRIME ITIMES-LIST-EVAL$-FACTORS ;; IPLUS-OR-ITIMES-TERM-INTEGERP-EVAL$ ;; EVAL$-LIST-BAGINT-0 ;; EVAL$-LIST-BAGINT-0-IMPLIES-EQUAL CORRECTNESS-OF-CANCEL-ITIMES-FACTORS CANCEL-ITIMES-ILESSP-FACTORS BAGINT-SINGLETON ;; <<>> ;; IZEROP-ILESSP-0-RELATIONSHIP ;; ILESSP-ITIMES-LIST-EVAL$-LIST-DELETE-HELPER-1 ;; ILESSP-ITIMES-LIST-EVAL$-LIST-DELETE-HELPER-2 ;; ILESSP-ITIMES-LIST-EVAL$-LIST-DELETE ;; ILESSP-ITIMES-LIST-EVAL$-LIST-DELETE-PRIME-HELPER-1 ;; ILESSP-ITIMES-LIST-EVAL$-LIST-DELETE-PRIME-HELPER-2 ;; ILESSP-ITIMES-LIST-EVAL$-LIST-DELETE-PRIME ;; ILESSP-0-ITIMES ;; ILESSP-ITIMES-0 ILESSP-ITIMES-LIST-EVAL$-LIST-BAGDIFF ;; ZERO-ILESSP-IMPLIES-NOT-EQUAL <<>> ILESSP-ITIMES-LIST-EVAL$-LIST-BAGDIFF-COROLLARY-1 ;; ILESSP-ZERO-IMPLIES-NOT-EQUAL <<>> MEMBER-0-ITIMES-FACTORS-YIELDS-0 MEMBER-0-ITIMES-FACTORS-YIELDS-0-ILESSP-CONSEQUENCE-1 MEMBER-0-ITIMES-FACTORS-YIELDS-0-ILESSP-CONSEQUENCE-2 ;; EVAL$-LIST-BAGINT-0-FOR-ILESSP <<>> ;; EVAL$-LIST-BAGINT-0-IMPLIES-EQUAL-FOR-ILESSP-LEMMA <<>> ;; EQUAL-FIX-INT-TO-ILESSP <<>> ;; EVAL$-LIST-BAGINT-0-IMPLIES-EQUAL-FOR-ILESSP ILESSP-ITIMES-LIST-EVAL$-LIST-BAGDIFF-COROLLARY-2 CORRECTNESS-OF-CANCEL-ITIMES-ILESSP-FACTORS DISJOIN-EQUALITIES-WITH-0 CANCEL-FACTORS-0 SOME-EVAL$S-TO-0 EVAL$-DISJOIN-EQUALITIES-WITH-0 SOME-EVAL$S-TO-0-APPEND SOME-EVAL$S-TO-0-ELIMINATOR ;; LISTP-CDR-FACTORS-IMPLIES-INTEGERP CORRECTNESS-OF-CANCEL-FACTORS-0 CONJOIN-INEQUALITIES-WITH-0 CANCEL-FACTORS-ILESSP-0 ;;;;;; and now from the final two metalemmas split-out-ineg-terms ;; function ;; remove-inegs ;; function, disabled ;; make-cancel-ineg-terms-equality ;; function ;; iplus-or-ineg-term ;; function, disabled ;; cancel-ineg-terms-from-equality ;; function, disabled ;; CANCEL-INEG-TERMS-FROM-EQUALITY-expanded ;; function ;; CANCEL-INEG-TERMS-FROM-EQUALITY-CANCEL-INEG-TERMS-FROM-EQUALITY-expanded ;;harmless ;; integerp-eval$-iplus-or-ineg-term ;; should be disabled, since iplus-or-ineg-term is ;; eval$-iplus-list-car-remove-inegs ;; harmless ;; eval$-iplus-list-cdr-remove-inegs ;; harmless ;; minus-ineg ;; definitely should be disabled ;; iplus-list-eval$-car-split-out-ineg-terms ;; harmless correctness-of-cancel-ineg-terms-from-equality ;; make-cancel-ineg-terms-inequality ;; function ;; cancel-ineg-terms-from-inequality ;; function ;; CANCEL-INEG-TERMS-FROM-INEQUALITY-expanded ;; function, disabled ;; CANCEL-INEG-TERMS-FROM-INEQUALITY-CANCEL-INEG-TERMS-FROM-INEQUALITY-expanded ;; harmless correctness-of-cancel-ineg-terms-from-inequality ;; plus-iplus iplus-constants ;; numberp-is-integerp ;; difference-idifference ;; cancel-constants-equal-lemma ;; nil lemma cancel-constants-equal ilessp-add1 ilessp-add1-iplus ;; cancel-constants-ilessp-lemma-1 ;; nil lemma ;; cancel-constants-ilessp-lemma-2 ;; nil lemma cancel-constants-ilessp )) ; ------------------------------------------------------------ ; was lists.events ; ------------------------------------------------------------ ; -------------------------------------------------------------------------------- ; Basic Functions on Lists ; -------------------------------------------------------------------------------- ; --------------------------------- DEFINITIONS ---------------------------------- ; Besides these functions, the theory of lists assumes APPEND is defined. (defn firstn (n l) (if (not (listp l)) nil (if (zerop n) nil (cons (car l) (firstn (sub1 n) (cdr l)))))) (defn init (value length) (if (zerop length) nil (cons value (init value (sub1 length))))) (defn lastcdr (l) (if (not (listp l)) l (lastcdr (cdr l)))) (defn length (l) (if (not (listp l)) 0 (add1 (length (cdr l))))) (defn plist (l) (if (not (listp l)) nil (cons (car l) (plist (cdr l))))) (defn plistp (l) (if (not (listp l)) (equal l nil) (plistp (cdr l)))) (defn restn (n l) (if (not (listp l)) l (if (zerop n) l (restn (sub1 n) (cdr l))))) (defn reverse (l) (if (not (listp l)) nil (append (reverse (cdr l)) (list (car l))))) ; --------------------------------- THEOREMS ------------------------------------ ; ---------- LISTP ---------- (lemma listp-append (rewrite) (equal (listp (append a b)) (or (listp a) (listp b))) ((enable append))) (lemma listp-firstn (rewrite) (equal (listp (firstn n l)) (and (listp l) (not (zerop n)))) ((enable firstn))) (lemma listp-init (rewrite) (equal (listp (init val n)) (not (zerop n))) ((enable init))) (lemma listp-lastcdr (rewrite) (equal (listp (lastcdr l)) f) ((enable lastcdr))) (lemma listp-plist (rewrite) (equal (listp (plist l)) (listp l)) ((enable plist))) (lemma listp-restn (rewrite) (equal (listp (restn n l)) (lessp n (length l))) ((enable restn length))) (lemma listp-reverse (rewrite) (equal (listp (reverse l)) (listp l)) ((enable reverse))) ; ---------- plistp ---------- (lemma plistp-nlistp (rewrite) (implies (nlistp l) (equal (plistp l) (equal l nil))) ((enable plistp))) (lemma plistp-cons (rewrite) (equal (plistp (cons a l)) (plistp l)) ((enable plistp))) (lemma plistp-append (rewrite) (equal (plistp (append a b)) (plistp b)) ((enable plistp append))) (lemma plistp-firstn (rewrite generalize) (plistp (firstn n l)) ((enable plistp firstn))) (lemma plistp-init (rewrite) (plistp (init val n)) ((enable plistp init))) (lemma plistp-lastcdr (rewrite generalize) (equal (plistp (lastcdr l)) (plistp l)) ((enable plistp lastcdr))) (lemma plistp-plist (rewrite generalize) (plistp (plist l)) ((enable plistp plist))) (lemma plistp-restn (rewrite generalize) (equal (plistp (restn n l)) (plistp l)) ((enable restn plistp))) (lemma plistp-reverse (rewrite) (plistp (reverse a)) ((enable plistp reverse plistp-append))) ; ---------- LENGTH ---------- (lemma equal-length-0 (rewrite) (equal (equal (length l) 0) (not (listp l))) ((enable length))) (lemma length-nlistp (rewrite) (implies (nlistp x) (equal (length x) 0)) ((enable length))) (lemma length-cons (rewrite) (equal (length (cons a x)) (add1 (length x))) ((enable length))) (lemma length-append (rewrite) (equal (length (append a b)) (plus (length a) (length b))) ((enable append length))) (lemma length-firstn (rewrite generalize) (equal (length (firstn n l)) (if (leq n (length l)) (fix n) (length l))) ((enable firstn length))) (lemma length-init (rewrite) (equal (length (init bit n)) (fix n)) ((enable length init))) (lemma length-lastcdr (rewrite generalize) (equal (length (lastcdr l)) 0) ((enable length lastcdr))) (lemma length-plist (rewrite generalize) (equal (length (plist l)) (length l)) ((enable length plist))) (lemma length-restn (rewrite generalize) (equal (length (restn n l)) (difference (length l) n)) ((enable restn length))) (lemma length-reverse (rewrite) (equal (length (reverse l)) (length l)) ((enable length reverse length-append))) ; ---------- APPEND ---------- (lemma append-left-id (rewrite) (implies (not (listp a)) (equal (append a b) b)) ((enable append))) (lemma append-nil (rewrite) (equal (append a nil) (plist a)) ((enable append plist))) (lemma associativity-of-append (rewrite) (equal (append (append a b) c) (append a (append b c))) ((enable append))) (lemma associativity-of-append-inverse (rewrite) (equal (append a (append b c)) (append (append a b) c)) ((enable associativity-of-append))) (disable associativity-of-append-inverse) (lemma append-firstn-restn (rewrite elim) (equal (append (firstn i l) (restn i l)) l) ((enable append firstn restn))) (lemma append-init-list (rewrite) (equal (append (init v n) (list v)) (init v (add1 n))) ((enable append init))) (lemma append-init-init (rewrite) (equal (append (init v i) (init v j)) (init v (plus i j))) ((enable append init))) (lemma append-lastcdr-arg1 (rewrite) (equal (append (lastcdr a) b) b) ((enable append lastcdr))) (lemma append-lastcdr-arg2 (rewrite) (equal (append l (lastcdr l)) l) ((enable append lastcdr))) (lemma append-plist (rewrite) (equal (append (plist a) b) (append a b)) ((enable append plist))) (lemma append-plist-lastcdr (rewrite elim) (equal (append (plist l) (lastcdr l)) l) ((enable append plist lastcdr))) ; ---------- FIRSTN ---------- (lemma firstn-with-large-index (rewrite) (implies (leq (length l) n) (equal (firstn n l) (plist l))) ((enable firstn plist length))) (lemma firstn-with-non-number-index (rewrite) (implies (not (numberp n)) (equal (firstn n l) (firstn 0 l))) ((enable firstn))) (lemma firstn-nlistp (rewrite) (implies (not (listp l)) (equal (firstn n l) nil)) ((enable firstn))) (lemma firstn-0 (rewrite) (equal (firstn 0 l) nil) ((enable firstn))) (lemma firstn-cons (rewrite) (equal (firstn n (cons a b)) (if (zerop n) nil (cons a (firstn (sub1 n) b)))) ((enable firstn))) (lemma firstn-append (rewrite) (equal (firstn n (append a b)) (if (leq n (length a)) (firstn n a) (append a (firstn (difference n (length a)) b)))) ((enable firstn append length))) (lemma firstn-firstn (rewrite) (equal (firstn i (firstn n l)) (if (lessp i n) (firstn i l) (firstn n l))) ((enable firstn))) (lemma firstn-init (rewrite) (equal (firstn n (init v i)) (if (lessp n i) (init v n) (init v i))) ((enable firstn init))) (lemma firstn-lastcdr (rewrite) (equal (firstn n (lastcdr l)) nil) ((enable firstn lastcdr))) (lemma firstn-plist (rewrite) (equal (firstn n (plist l)) (firstn n l)) ((enable firstn plist))) ; FIRSTN-RESTN has no obvious reduction. ; ---------- INIT ---------- (lemma car-init (rewrite) (implies (not (zerop n)) (equal (car (init v n)) v)) ((enable init))) (lemma init-with-non-number-index (rewrite) (implies (not (numberp n)) (equal (init v n) (init v 0))) ((enable init))) (lemma init-add1 (rewrite) (equal (init x (add1 n)) (cons x (init x n))) ((enable init))) (lemma init-0 (rewrite) (equal (init v 0) nil) ((enable init))) ; ---------- LASTCDR ---------- (lemma lastcdr-nlistp (rewrite) (implies (not (listp l)) (equal (lastcdr l) l)) ((enable lastcdr))) (lemma lastcdr-cons (rewrite) (equal (lastcdr (cons a l)) (lastcdr l)) ((enable lastcdr))) (lemma lastcdr-append (rewrite) (equal (lastcdr (append a b)) (lastcdr b)) ((enable lastcdr append))) (lemma lastcdr-firstn (rewrite) (equal (lastcdr (firstn n l)) nil) ((enable lastcdr firstn))) (lemma lastcdr-init (rewrite) (equal (lastcdr (init v i)) nil) ((enable lastcdr init))) (lemma lastcdr-lastcdr (rewrite) (equal (lastcdr (lastcdr l)) (lastcdr l)) ((enable lastcdr))) (lemma lastcdr-plist (rewrite) (equal (lastcdr (plist l)) nil) ((enable lastcdr plist))) (lemma lastcdr-restn (rewrite) (equal (lastcdr (restn n l)) (lastcdr l)) ((enable lastcdr restn))) (lemma lastcdr-reverse (rewrite) (equal (lastcdr (reverse l)) nil) ((enable lastcdr reverse lastcdr-append))) ; ---------- PLIST ---------- (lemma equal-plist (rewrite) (implies (plistp l) (equal (plist l) l)) ((enable plistp plist))) (lemma plist-nlistp (rewrite) (implies (not (listp x)) (equal (plist x) nil)) ((enable plist))) (lemma plist-cons (rewrite) (equal (plist (cons a l)) (cons a (plist l))) ((enable plist))) (lemma plist-append (rewrite) (equal (plist (append a b)) (append a (plist b))) ((enable append plist))) (lemma plist-firstn (rewrite) (equal (plist (firstn n l)) (firstn n l)) ((enable plist firstn))) (lemma plist-init (rewrite) (equal (plist (init v i)) (init v i)) ((enable plist init))) (lemma plist-lastcdr (rewrite) (equal (plist (lastcdr l)) nil) ((enable plist lastcdr))) (lemma plist-plist (rewrite) (equal (plist (plist l)) (plist l)) ((enable plist))) (lemma plist-restn (rewrite) (equal (plist (restn n l)) (restn n (plist l))) ((enable plist restn))) (lemma plist-reverse (rewrite) (equal (plist (reverse l)) (reverse l)) ((enable plist reverse plist-append))) ; ---------- RESTN ---------- (lemma restn-with-non-number-index (rewrite) (implies (not (numberp n)) (equal (restn n l) (restn 0 l))) ((enable restn))) (lemma restn-with-large-index (rewrite) (implies (leq (length l) n) (equal (restn n l) (lastcdr l))) ((enable restn lastcdr length))) (lemma restn-nlistp (rewrite) (implies (not (listp l)) (equal (restn n l) l)) ((enable restn))) (lemma restn-0 (rewrite) (equal (restn 0 l) l) ((enable restn))) (lemma restn-cons (rewrite) (equal (restn n (cons a b)) (if (zerop n) (cons a b) (restn (sub1 n) b))) ((enable restn))) (lemma restn-append (rewrite) (equal (restn n (append a b)) (if (leq n (length a)) (append (restn n a) b) (restn (difference n (length a)) b))) ((enable restn append length))) (lemma restn-firstn (rewrite) (equal (restn n (firstn i l)) (if (leq i n) nil (firstn (difference i n) (restn n l)))) ((enable firstn restn))) (lemma restn-init (rewrite) (equal (restn n (init v i)) (init v (difference i n))) ((enable restn init))) (lemma restn-lastcdr (rewrite) (equal (restn n (lastcdr l)) (lastcdr l)) ((enable restn lastcdr))) (lemma restn-plist (rewrite) (equal (restn n (plist l)) (plist (restn n l))) ((enable restn plist))) (disable restn-plist) (lemma restn-restn (rewrite) (equal (restn i (restn j l)) (restn (plus j i) l)) ((enable restn))) ; ---------- REVERSE ---------- (lemma reverse-nlistp (rewrite) (implies (not (listp l)) (equal (reverse l) nil)) ((enable reverse))) (lemma reverse-cons (rewrite) (equal (reverse (cons a l)) (append (reverse l) (list a))) ((enable reverse))) (lemma reverse-append (rewrite) (equal (reverse (append a b)) (append (reverse b) (reverse a))) ((enable append reverse associativity-of-append plist-reverse append-nil))) (lemma reverse-init (rewrite) (equal (reverse (init v n)) (init v n)) ((enable reverse init append-init-list))) (lemma reverse-lastcdr (rewrite) (equal (reverse (lastcdr l)) nil) ((enable reverse lastcdr))) (lemma reverse-plist (rewrite) (equal (reverse (plist l)) (reverse l)) ((enable reverse plist))) (lemma reverse-reverse (rewrite) (implies (plistp l) (equal (reverse (reverse l)) l)) ((enable plistp append reverse reverse-append))) ; ---------------------------------------------------------------------- (deftheory lists (APPEND-FIRSTN-RESTN APPEND-INIT-INIT APPEND-INIT-LIST APPEND-LASTCDR-ARG1 APPEND-LASTCDR-ARG2 APPEND-LEFT-ID APPEND-NIL APPEND-PLIST APPEND-PLIST-LASTCDR ASSOCIATIVITY-OF-APPEND CAR-INIT EQUAL-LENGTH-0 EQUAL-PLIST FIRSTN-0 FIRSTN-APPEND FIRSTN-CONS FIRSTN-FIRSTN FIRSTN-INIT FIRSTN-LASTCDR FIRSTN-NLISTP FIRSTN-PLIST FIRSTN-WITH-LARGE-INDEX FIRSTN-WITH-NON-NUMBER-INDEX INIT-0 INIT-ADD1 INIT-WITH-NON-NUMBER-INDEX LASTCDR-APPEND LASTCDR-CONS LASTCDR-FIRSTN LASTCDR-INIT LASTCDR-LASTCDR LASTCDR-NLISTP LASTCDR-PLIST LASTCDR-RESTN LASTCDR-REVERSE LENGTH-APPEND LENGTH-CONS LENGTH-FIRSTN LENGTH-INIT LENGTH-LASTCDR LENGTH-NLISTP LENGTH-PLIST LENGTH-RESTN LENGTH-REVERSE LISTP-APPEND LISTP-FIRSTN LISTP-INIT LISTP-LASTCDR LISTP-PLIST LISTP-RESTN LISTP-REVERSE PLIST-APPEND PLIST-CONS PLIST-FIRSTN PLIST-INIT PLIST-LASTCDR PLIST-NLISTP PLIST-PLIST PLIST-RESTN PLIST-REVERSE PLISTP-APPEND PLISTP-CONS PLISTP-FIRSTN PLISTP-INIT PLISTP-LASTCDR PLISTP-NLISTP PLISTP-PLIST PLISTP-RESTN PLISTP-REVERSE RESTN-0 RESTN-APPEND RESTN-CONS RESTN-FIRSTN RESTN-INIT RESTN-LASTCDR RESTN-NLISTP RESTN-RESTN RESTN-WITH-LARGE-INDEX RESTN-WITH-NON-NUMBER-INDEX REVERSE-APPEND REVERSE-CONS REVERSE-INIT REVERSE-LASTCDR REVERSE-NLISTP REVERSE-PLIST REVERSE-REVERSE)) ; ------------------------------------------------------------ ; was piton-basis.events ; ------------------------------------------------------------ ;; The following stuff is from Piton, defs.events (add-shell p-state nil p-statep ((p-pc (none-of) zero) (p-ctrl-stk (none-of) zero) (p-temp-stk (none-of) zero) (p-prog-segment (none-of) zero) (p-data-segment (none-of) zero) (p-max-ctrl-stk-size (none-of) zero) (p-max-temp-stk-size (none-of) zero) (p-word-size (none-of) zero) (p-psw (none-of) zero))) ; Each element of the program segment is a program. A program is a list ; of the form: ; (name (formal1 formal2 ... formaln) ; ((temp1 init1) ; ... ; (tempk initk)) ; instr1 ; instr2 ; ... ; instrm) ; The name and each formal and temp is a symbol. The initial values ; of the temps are tagged values. The instrs are either LISTP objects ; which may be optionalled labelled by litatoms. To label an ; instruction ins with the label lab, write (dl lab comment ins). ; Comment may be any object. It is completely ignored. ; Roughly speaking, a CALL of name binds the formals to the top n ; elements of the temp-stk (removing them from that stack and building ; a ctrl-stk frame), binds the temps to the corresponding tagged ; values (also in the ctrl-stk frame), and executes each instruction. ; When a symbol is used as a variable name in an instruction we will ; look for its value as though it were stored in an alist whose keys ; were listed in the following order: ; formal1 ... formaln temp1 ... tempk. ; That is, a variable reference is first to the formals, then to the ; temps. In the case of duplications we use the first occurrence in ; the list. ; The following function sets the psw to the one given. If that is ; anything besides 'RUN the Piton machine halts. (defn p-halt (p psw) (p-state (p-pc p) (p-ctrl-stk p) (p-temp-stk p) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) psw)) ; We characterize the errorneous psws as all those besides 'RUN and ; 'HALT: (defn errorp (psw) (and (not (equal psw 'run)) (not (equal psw 'halt)))) ; Association lists. (defn put-assoc (val name alist) (if (nlistp alist) alist (if (equal name (caar alist)) (cons (cons name val) (cdr alist)) (cons (car alist) (put-assoc val name (cdr alist)))))) ; The following function determines whether name is bound in alist. (defn definedp (name alist) (if (nlistp alist) f (if (equal name (caar alist)) t (definedp name (cdr alist))))) ; This function is used to obtain the definition of a Piton variable ; or subroutine name. (defn definition (name alist) (assoc name alist)) ; These two functions are used for manipulating Piton variable values. (defn value (name alist) (cdr (definition name alist))) (defn put-value (val name alist) (put-assoc val name alist)) ; This function is used to strip the values out of an alist. (defn strip-cdrs (alist) (if (nlistp alist) nil (cons (cdr (car alist)) (strip-cdrs (cdr alist))))) (defn strip-cadrs (alist) (if (nlistp alist) nil (cons (cadr (car alist)) (strip-cadrs (cdr alist))))) ; Piton programs. ; When I fetch the definitions of programs from the prog-segment I ; want to decompose them into the following pieces: (defn name (d) (car d)) (defn formal-vars (d) (cadr d)) (defn temp-var-dcls (d) (caddr d)) (defn program-body (d) (cdddr d)) ; The ``locals'' of a program is the union of the formal-vars ; and the temporaries. (defn local-vars (d) (append (formal-vars d) (strip-cars (temp-var-dcls d)))) ; Addresses ; Our addresses are tagged ``address pairs''. The pair specifies ; an area name in some memory segment and an offset from the ; base address of that area. We call such a pair an ``adp'' ; (pronounced ``a d p''). (defn adp-name (adp) (car adp)) (defn adp-offset (adp) (cdr adp)) ; The tag indicates which segment of memory the address points into. ; For example, at the Piton level, the tag PC means into the prog ; segment and the tag ADDR means into the data segment. At lower levels ; there are other tags and other segments. An object is an address ; pair if it and its associated segment satisfy the following relation (defn adpp (x segment) (and (listp x) (numberp (adp-offset x)) (definedp (adp-name x) segment) (lessp (adp-offset x) (length (value (adp-name x) segment))))) ; Program counters are slightly different from addresses because ; the areas in the program segment are not (name . value) but ; (name formal-vars temps . program-body). (defn pcpp (x segment) (and (listp x) (numberp (adp-offset x)) (definedp (adp-name x) segment) (lessp (adp-offset x) (length (program-body (definition (adp-name x) segment)))))) ; We nevertheless often manipulate them with the same functions we ; do adps. For example, add1-adp, below, increments the offset of an ; adp by 1. We will write (add1-adp pc) even though pc is a pcpp. (defn add-adp (adp n) (cons (adp-name adp) (plus (adp-offset adp) n))) (defn add1-adp (adp) (add-adp adp 1)) (defn sub-adp (adp n) (cons (adp-name adp) (difference (adp-offset adp) n))) (defn sub1-adp (adp) (sub-adp adp 1)) (defn get (n lst) (if (zerop n) (car lst) (get (sub1 n) (cdr lst)))) (defn put (val n lst) (if (zerop n) (if (listp lst) (cons val (cdr lst)) (list val)) (cons (car lst) (put val (sub1 n) (cdr lst))))) (defn fetch-adp (adp segment) (get (adp-offset adp) (value (adp-name adp) segment))) (defn deposit-adp (val adp segment) (put-value (put val (adp-offset adp) (value (adp-name adp) segment)) (adp-name adp) segment)) ; While get enumerates the elements of lst from 0 starting at ; the left, we also need the function that enumerates the elements ; from 0 starting at the right. This is used in the specification ; of the fetch-temp-stk instruction. The name rget stands for "right get" ; or perhaps "reversed get": (defn rget (n lst) (get (sub1 (difference (length lst) n)) lst)) ; The corresponding put function: (defn rput (val n lst) (put val (sub1 (difference (length lst) n)) lst)) ; Tagged Objects ; We keep all Piton objects tagged. The form we use is ; (tag obj) where tag is one of a fixed set of LITATOMs ; enumerated by the function p-objectp below. The following ; three functions let us create a tagged object, access the ; tag field and access the contents field. (defn tag (type obj) (list type obj)) (defn type (const) (car const)) (defn untag (const) (cadr const)) ; Tagged Addresses ; We have a variety of objects in the system that are tagged address pairs. ; We call these things ``addresses'' and define primitives for recognizing ; and manipulating them. At this level we do not care what the tags are, ; we just strip them off or duplicate them as necessary. That is, to ; increment (tag (DELTA1 . 25)) we build (tag (DELTA1 . 26)) without ; inspecting tag. (defn addressp (x segment) (adpp (untag x) segment)) (defn area-name (x) (adp-name (untag x))) (defn offset (x) (adp-offset (untag x))) (defn add-addr (addr n) (tag (type addr) (add-adp (untag addr) n))) (defn add1-addr (addr) (add-addr addr 1)) (defn sub-addr (addr n) (tag (type addr) (sub-adp (untag addr) n))) (defn sub1-addr (addr) (sub-addr addr 1)) (defn fetch (addr segment) (fetch-adp (untag addr) segment)) (defn deposit (val addr segment) (deposit-adp val (untag addr) segment)) ; Note: Addresses are just one of many data types. We could define ; tagged versions of all of our data manipulation functions. E.g., ; we could define (nat-plus x y) = (tag 'nat (plus (untag x) (untag y))). ; However we do not. Instead we use tag and untag freely below. ; The reason we go to the trouble of defining tagged address functions ; is because we use those constructs so often -- not just to implement ; the semantics of the ADDR data type operations. For example, fetching ; and depositing into memory, getting instructions, etc., all use ; tagged address manipulation. ; Booleans ; Unlike the logic, the PITON machine uses the LITATOM 'T for true and ; the LITATOM 'F for false. This means we can't use the primitive ; AND, OR, and NOT functions of the logic to do AND-BOOL, OR-BOOL, and ; NOT-BOOL. The reason I adopted this curious convention is so that T ; and F can be written inside of quoted list constants -- i.e., in ; PITON programs. That is, if in the logic you write '(PUSH-CONSTANT ; (BOOL T)) that T is the litatom 'T, not (TRUE). (defn booleanp (x) (or (equal x 't) (equal x 'f))) (defn bool (x) (tag 'bool (if x 't 'f))) ; Because we know we only apply the boolean operators to booleanps we ; can skimp on the tests. (defn or-bool (x y) (if (equal x 'f) y 't)) (defn and-bool (x y) (if (equal x 'f) 'f y)) (defn not-bool (x) (if (equal x 'f) 't 'f)) ; *** 14-12-87/jsm: The following defn was added during the proofs ; for i->m. (defn xor-bool (x y) (if (equal x 'f) y (if (equal y 'f) 't 'f))) ; Naturals (defn small-naturalp (i word-size) (and (numberp i) (lessp i (exp 2 word-size)))) (defn bool-to-nat (flg) (if (equal flg 'f) 0 1)) ; *** 16-12-87/jsm: "fix-small" was renamed "fix-small-natural" so that ; a parallel "fix-small-integer" could be defined. (defn fix-small-natural (n word-size) (remainder n (exp 2 word-size))) ; Integers ; The functions below are defined so that if given integerps they ; return integerps. In particular, they never create (MINUS 0) though ; they might pass one through. ;; INTEGERP and ILESSP are defined in integers.events ;(defn integerp (i) ; (or (numberp i) ; (and (negativep i) ; (not (equal (negative-guts i) 0))))) ;(defn ilessp (i j) ; (if (negativep i) ; (if (negativep j) ; (lessp (negative-guts j) ; (negative-guts i)) ; t) ; (if (negativep j) ; f ; (lessp i j)))) (defn small-integerp (i word-size) (and (integerp i) (not (ilessp i (minus (exp 2 (sub1 word-size))))) (ilessp i (exp 2 (sub1 word-size))))) ;; IPLUS is defined in integers.events ;(defn iplus (i j) ; (if (negativep i) ; (if (negativep j) ; (minus ; (plus (negative-guts i) ; (negative-guts j))) ; (if (lessp j (negative-guts i)) ; (minus (difference (negative-guts i) j)) ; (difference j (negative-guts i)))) ; (if (negativep j) ; (if (lessp i (negative-guts j)) ; (minus (difference (negative-guts j) i)) ; (difference i (negative-guts j))) ; (plus i j)))) ;; INEG is the same as INEGATE and is defined integer.events ;(defn inegate (i) ; (if (negativep i) ; (negative-guts i) ; (if (zerop i) ; 0 ; (minus i)))) (defn inegate (i) (ineg i)) ;; IDIFFERENCE is defined in integers.events ;(defn idifference (i j) ; (iplus i (inegate j))) (defn fix-small-integer (i word-size) (if (small-integerp i word-size) i (if (negativep i) (iplus i (exp 2 word-size)) (iplus i (minus (exp 2 word-size)))))) ; Bit vectors (defn bitp (x) (or (equal x 0) (equal x 1))) (defn bit-vectorp (x n) (if (nlistp x) (and (equal x nil) (zerop n)) (and (not (zerop n)) (bitp (car x)) (bit-vectorp (cdr x) (sub1 n))))) (defn or-bit (bit1 bit2) (if (equal bit1 0) (if (equal bit2 0) 0 1) 1)) (defn not-bit (bit) (if (equal bit 0) 1 0)) (defn and-bit (bit1 bit2) (if (equal bit1 0) 0 (if (equal bit2 0) 0 1))) (defn xor-bit (bit1 bit2) (if (equal bit1 0) (if (equal bit2 0) 0 1) (if (equal bit2 0) 1 0))) (defn or-bitv (a b) (if (nlistp a) nil (cons (or-bit (car a) (car b)) (or-bitv (cdr a) (cdr b))))) (defn not-bitv (a) (if (nlistp a) nil (cons (not-bit (car a)) (not-bitv (cdr a))))) (defn and-bitv (a b) (if (nlistp a) nil (cons (and-bit (car a) (car b)) (and-bitv (cdr a) (cdr b))))) (defn xor-bitv (a b) (if (nlistp a) nil (cons (xor-bit (car a) (car b)) (xor-bitv (cdr a) (cdr b))))) (defn all-but-last (a) (if (nlistp a) nil (if (nlistp (cdr a)) nil (cons (car a) (all-but-last (cdr a)))))) (defn rsh-bitv (a) (cons 0 (all-but-last a))) (defn lsh-bitv (a) (append (cdr a) (list 0))) (defn all-zero-bitvp (a) (if (listp a) (and (equal (car a) 0) (all-zero-bitvp (cdr a))) t)) ; Stacks (defn push (x stk) (cons x stk)) (defn top (stk) (car stk)) (defn pop (stk) (cdr stk)) (defn popn (n x) (if (zerop n) x (popn (sub1 n) (cdr x)))) (defn top1 (stk) (top (pop stk))) (defn top2 (stk) (top (pop (pop stk)))) ; Labels ; In an earlier version of this I used the Lisp PROG convention for ; denoting labels: a label is an atom in a list that otherwise ; contains non-atomic instructions. The trouble with that convention ; is that the notions of the ``ith element'' and the ``length'' of ; such instruction lists have to be redefined to skip labels. I ; anticipate much work going into the accessing of items at given ; addresses and wanted to use the same kind of fetch for program items ; as for data items. Thus I have decided that each item in a list is ; an instruction and some are labelled. ; Here is a function which labels ins with lab: (defn dl (lab comment ins) (list 'dl lab comment ins)) ; The following function recognizes labelled items: (defn labelledp (x) (equal (car x) 'dl)) ; This function extracts the instruction from the labelling. (defn unlabel (x) (if (labelledp x) (cadddr x) x)) ; I suspect we will never want to know whether something was labelled ; or not but rather deal with everything as though it weren't. So I ; will disable the unlabel function. (disable unlabel) ; The following function determines whether x is defined as a label ; in lst. (defn find-labelp (x lst) (if (nlistp lst) f (if (and (labelledp (car lst)) (equal x (cadr (car lst)))) t (find-labelp x (cdr lst))))) ; This function counts the number of items in lst before the first ; one labelled x. (defn find-label (x lst) (if (nlistp lst) 0 (if (and (labelledp (car lst)) (equal x (cadr (car lst)))) 0 (add1 (find-label x (cdr lst)))))) ; Generally we convert labels into tagged PCs. We use the following ; function: (defn pc (lab program) (tag 'pc (cons (name program) (find-label lab (program-body program))))) ; The following function is used by the JUMP-CASE instruction to ; check that a list of labels has been provided. (defn all-find-labelp (lab-lst lst) (if (nlistp lab-lst) t (and (find-labelp (car lab-lst) lst) (all-find-labelp (cdr lab-lst) lst)))) ; P-Level Primitives (defn p-objectp (x p) (and (listp x) (equal (cddr x) nil) (case (type x) (nat (small-naturalp (untag x) (p-word-size p))) (int (small-integerp (untag x) (p-word-size p))) (bitv (bit-vectorp (untag x) (p-word-size p))) (bool (booleanp (untag x))) (addr (adpp (untag x) (p-data-segment p))) (pc (pcpp (untag x) (p-prog-segment p))) (subr (definedp (untag x) (p-prog-segment p))) (otherwise f)))) (defn p-objectp-type (type x p) ; *** 25/3/88 jsm. the (type x) below used to be (car x) (and (equal (type x) type) (p-objectp x p))) (defn all-p-objectps (lst p) (if (nlistp lst) (equal lst nil) (and (p-objectp (car lst) p) (all-p-objectps (cdr lst) p)))) ; The following function checks that it is ok to increment ; the pc by 1. (defn add1-p-pc (p) (add1-addr (p-pc p))) (defn add1-p-pcp (p) (pcpp (untag (add1-p-pc p)) (p-prog-segment p))) (defn p-current-program (p) (definition (area-name (p-pc p)) (p-prog-segment p))) (defn p-current-instruction (p) (unlabel (get (offset (p-pc p)) (program-body (p-current-program p))))) (defn p-frame (bindings ret-pc) (list bindings ret-pc)) (defn bindings (frame) (car frame)) (defn ret-pc (frame) (cadr frame)) (defn p-frame-size (frame) (plus 2 (length (bindings frame)))) (defn p-ctrl-stk-size (ctrl-stk) (if (nlistp ctrl-stk) 0 (plus (p-frame-size (top ctrl-stk)) (p-ctrl-stk-size (cdr ctrl-stk))))) (defn local-varp (var ctrl-stk) (definedp var (bindings (top ctrl-stk)))) (defn local-var-value (var ctrl-stk) (value var (bindings (top ctrl-stk)))) (defn set-local-var-value (val var ctrl-stk) (push (p-frame (put-value val var (bindings (top ctrl-stk))) (ret-pc (top ctrl-stk))) (pop ctrl-stk))) ;; REVERSE is defined in lists.events ;(defn reverse (x) ; (if (nlistp x) ; nil ; (append (reverse (cdr x)) (list (car x))))) (defn first-n (n x) (if (zerop n) nil (cons (car x) (first-n (sub1 n) (cdr x))))) (defn pair-formal-vars-with-actuals (formal-vars temp-stk) ; (PAIR-FORMAL-VARS-WITH-ACTUALS '(X Y Z) '(2 1 0 A B)) is ; '((X . 0) (Y . 1) (Z . 2)). (pairlist formal-vars (reverse (first-n (length formal-vars) temp-stk)))) ; Note: I considered defining this function with: ; (reverse (pairlist (reverse formal-vars) temp-stk)) ; I am not sure which defn is the easiest to work with. (defn pair-temps-with-initial-values (temp-var-dcls) ; In programs, the temp-var-dcls are written as doublet lists, ; not alists. That is, we write ((X (INT -23)) (Y (INT 123))) ; rather than ((X . (INT -23)) (Y . (INT 123))). I adopted this ; syntax simply to avoid dot notation in displayed programs. ; However, I have decided to represent the run-time association of ; values to variables with alists employing dot notation. The reason ; is that I want all my associations to be according to the same ; conventions -- either always in the CDR or always in the CADR. But ; if I avoid dot notation and make it always in the CADR, then the ; associations of definitions with program names and memory locations ; with area-names both have extra levels of parentheses. ; This function converts from the external form of temp-var-dcls ; to the internal. (if (nlistp temp-var-dcls) nil (cons (cons (caar temp-var-dcls) (cadar temp-var-dcls)) (pair-temps-with-initial-values (cdr temp-var-dcls))))) (defn make-p-call-frame (formal-vars temp-stk temp-var-dcls ret-pc) (p-frame (append (pair-formal-vars-with-actuals formal-vars temp-stk) (pair-temps-with-initial-values temp-var-dcls)) ret-pc)) ; If (FOO (X Y Z) ((A a) (B b) (C c)) ...) is a Piton program then ; the frame constructed when FOO is CALLed with temp-stk ; '(2 1 0 ...) looks like this: ; (((X . 0) (Y . 1) (Z . 2) (A . a) (B . b) (C . c)) ; ret-pc) ;----------------------------------------------------------------------------- ; Individual Instructions. ; I now begin defining the instruction set. Suppose ins is an ; instruction opcode. Then I will define 3 functions, each with the ; word ins in its name. The three functions are: ; p-ins-okp: T or F according to whether the given instruction ; is well-formed and legal to execute in a given state. ; p-ins-step: the new state produced by the execution of a legal ; well-formed instruction ; icode-ins: the icode for this instruction. ; (CALL subr) Push a new frame onto the ctrl-stk binding the ; formals and temps of the subroutine subr to their ; actual values and saving the current return pc. ; Transfer control to the beginning of subr. (defn p-call-okp (ins p) (and (not (lessp (p-max-ctrl-stk-size p) (p-ctrl-stk-size (push (make-p-call-frame (formal-vars (definition (cadr ins) (p-prog-segment p))) (p-temp-stk p) (temp-var-dcls (definition (cadr ins) (p-prog-segment p))) (add1-addr (p-pc p))) (p-ctrl-stk p))))) (not (lessp (length (p-temp-stk p)) (length (formal-vars (definition (cadr ins) (p-prog-segment p)))))))) (defn p-call-step (ins p) (p-state (tag 'pc (cons (cadr ins) 0)) (push (make-p-call-frame (formal-vars (definition (cadr ins) (p-prog-segment p))) (p-temp-stk p) (temp-var-dcls (definition (cadr ins) (p-prog-segment p))) (add1-addr (p-pc p))) (p-ctrl-stk p)) (popn (length (formal-vars (definition (cadr ins) (p-prog-segment p)))) (p-temp-stk p)) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) ; We now discuss how we compile a call instruction. This means ; explaining a lot about the lower level machines and the structure of ; the compiler. ; Associated with every opcode, xxx, is a function named ; icode-xxx which generates the symbolic machine code ; for the opcode. Code generated is called ``icode'' because it is ; the code executed by the I machine. ; Every icode-xxx function gets three arguments: ; ins the Piton instruction being compiled ; pcn the offset of the pc pointing to that Piton instruction ; program the Piton program containing the instruction ; The pcn may be used as a unique seed for icode labels generated by the ; compiler. It is guaranteed to be a NUMBERP. ; Icode contains labels. What are these labels? That is, what objects ; do we use for icode labels? The answer is Piton PC-type objects. ; Icode labels are tagged so we can distinguish them from other things. ; The tag we use is 'PC! At the icode level the initials PC should be ; thought of as standing for LABEL. ; Thus, in icode, (SUBR . 25) is a label! It is tagged PC and thus ; a reference to it in the instruction stream would be denoted ; (PC (SUBR . 25)). Remember that in icode PC stands for LABEL. ; To distinguish a reference from the defining occurrence, the defining ; occurrence is tagged exactly as in Piton code with DL. ; Thus, the defining occurrence of (SUBR . 25) would be in an instruction ; of the form ; (DL (SUBR . 25) comment icode-ins) ; For each valid pc in a Piton program the icompiler defines that pc ; as a label at the beginning of the basic block of icode generated ; for the instruction at that pc. Thus, the PC objects of Piton ; become the labels of icode programs and are given meaning. In ; mapping the Piton PCs down to icode labels it is not necessary to do ; anything. That is the beauty of our using the tag PC at the icode ; level. Once upon a time I marked icode labels with the tag 'ILAB. ; But that means that when mapping the stacks or data memory down to ; the i level I had to go through and change all the PCs to ILABs. ; Now I don't. The stacks at the r level are identical to the stacks ; at the i level! (In the toy version, the r level stacks had pcs on ; them and they were transformed into i-level pcs. That is no longer ; done. The objects on the i-level stack become labels without any ; work.) ; User defined Piton labels, e.g., LOOP, are systematically eliminated ; by the icompiler into these pc type labels. That is, when the ; defining occurrence of LOOP occurs at pcn 25 in a Piton program, it ; simply dropped in favor of the automatically generated pc-style ; label (DL (name . 25) & &). When LOOP is used in a JUMP ; statement the corresponding pc-style label is computed and used ; instead. ; So far, we have established that all valid PC type objects in Piton ; are defined icode labels. Furthermore, the label objects used in ; Piton are systematically eliminated in favor of pc-style labels. ; However, there are icode labels that are NOT valid Piton PC type ; objects! ; The problem arises because icode needs internal labels within basic ; blocks or to mark the prelude and postlude. To generate distinct ; system-internal labels I exploit the fact that all valid Piton pc ; labels are of the form (name . number) where number is less than ; the length of the program body. I generate labels of the ; form (name anything) and I also generate a single label of the form ; (name . length) where length is the length of the program body. ; I use labels of the first form to mark the PRELUDE for subroutine ; entry. The label is (name PRELUDE). I use the second label to ; mark the postlude. Because these are icode labels they ; are tagged in the icode with either the PC tag, indicating a ; reference, e.g., (PC (name PRELUDE)), or the DL tag, ; indicating the defining occurrence (DL (name POSTLUDE) & &). ; Despite the fact that they are sometimes tagged PC they are not ; Piton PC. Remember: in icode PC stands for LABEL! ; Once upon a time I marked the postlude with (name POSTLUDE). But ; that required that every program body end with a (RET) because ; many instructions assumed that the label marking the beginning of ; the block of instructions icompiled for the "next" Piton instruction ; was (name . n+1) where n is the position of the current instruction. ; (If the last instr is a (RET) then every other instr has a ; next one that is so labelled.) I don't like enforcing the ; "last instr is a (RET)" convention, and it also makes the ; resulting implementation less efficient because often programs ; hit a (RET) which merely jumps to the instruction following the (RET) ; rather than just falling off the end. ; It is important that every icode label be structured enough to ; permit me to determine in which program it is defined. All my ; labels have the name of the parent program as the car and then ; arbitrary stuff after. I need to be able to find definitions since ; icode sometimes jumps to foreign labels (upon subroutine exit) and ; it must be possible to figure out the new pc from the supplied ; label. ; Historical Note and Commentary on Icode Labels: ; The presence in the icode of labels is rather unexpected to me. ; Originally labels were eliminated by the icompiler. It is also odd ; that the high level language provides the notion of PC and the low ; level language uses labels! Its a reversal of conceptual depth. ; The reason is that our pcs can be non-local. That is, it is ; permitted in Piton for subroutine FOO to manipulate the non-local pc ; (BAR . 25) and to pass it to BAR and jumped to. ; If I were to map PCs in Piton down to pcs in the icode it would be ; necessary for the icompiler to compute icode pcs from Piton pcs. ; But that can't be done without an overall view of the system -- it ; cannot be done on a program by program basis. So instead of using ; icode pcs below I use symbolic labels. The fact that the labels I ; use are not atomic is irrelevant -- imagine icode labels were ; symbols if you wish. The natural time to replace these symbols is ; at link time when we have absolute addresses. An address like (BAR ; . 25) can be thought of as simply an alternative entry point into ; BAR and thus is like a subroutine in itself. ; Of course, I could make the icompiler have a second pass in which ; labels are eliminated in favor of icode-level pcs. (That pass was ; called REMOVE-LABELS in HRIL.) But the proof of the correctness of ; the icompiler is in the R->I transition and that is already the ; hardest of the three transitions to prove. So in a way it is nice ; to eliminate a complexity from there. Introducing the complexity in ; I->L is ok too both because that transition is the simplest and ; because it is already dealing with the idea that jumping to a ; symbolic subroutine address is the same as jumping to an absolute ; address where that subroutine is located. So I don't think pushing ; label removal to the final transition is necessarily going to ; complicate the proof down there very much. ; Now, on with my icompiler! (defn icode-call (ins pcn program) (list '(cpush_*) (tag 'pc (cons (name program) (add1 pcn))) '(jump_*) (tag 'pc (cons (cadr ins) '(prelude))))) ; Notes: See the "Guide to Decrypting I-level Opcodes" near the ; defn of link-instruction-alist for an explanation of the meaning ; of the i-level opcodes used in the icode- fns. ; Four observations come to mind about this piece of icode. ; First, while the tag function has heretofore been used only to ; produce Piton objects, I am here using it to produce icode objects, ; namely PCs. Second, the return address pushed onto csp is an icode ; label not a pc. Third, the return address label, (name . pcn+1) is ; not defined here. That is because it is defined when I process the ; pcn+1st instruction. In fact, icompile-program-body lays down the ; DLs implicit in the use of that label. Fourth, the (name ; prelude) label is not defined here. In fact, generate-prelude takes ; care of its defn. ; There is more to the compilation of a CALL instruction than merely ; the sequence of instructions generated for the CALL itself: one ; must also consider the prelude that is part of every subroutine ; entry. The prelude must be undone by the postlude. I therefore ; include below the CALL code, the prelude, and the postlude. (defn generate-prelude1 (temp-var-dcls) (if (nlistp temp-var-dcls) nil (cons '(cpush_*) (cons (cadr (car temp-var-dcls)) (generate-prelude1 (cdr temp-var-dcls)))))) (defn generate-prelude2 (formal-vars) (if (nlistp formal-vars) nil (cons '(cpush_+) (generate-prelude2 (cdr formal-vars))))) (defn generate-prelude (program) (append (list (DL (cons (name program) '(prelude)) '(prelude) '(cpush_cfp)) '(move_cfp_csp)) (append (generate-prelude1 (reverse (temp-var-dcls program))) (generate-prelude2 (formal-vars program))))) ; Observe how the formals and temps are arranged on the stack. ; Suppose that the header for the subroutine FOO is (FOO (X Y Z) ((A ; a) (B b) (C c)) ...) where a, b, and c are constants. At the ; beginning of the execution of (CALL FOO) the temp-stk and ctrl-stk ; look like this: ; ... ... ; e1 c1 <- csp ; x ; y ; z <- tsp ; Our stacks on the lower level grow downward. For example, a ; typical value for tsp might be '((TEMP-STK) . 25), which denotes ; the 25th word from the base of the area named '(TEMP-STK). The ; contents of that word is the item on the top of the stack. To push ; something, tsp would become '((TEMP-STK) . 24). To pop something, ; tsp would become '((TEMP-STK) . 26). ; Note that the base of the area named '(TEMP-STK) is not the ; base of the stack! ; After execution of (CALL FOO) the stacks are: ; ... ... ; e1 <- tsp c1 ; ret-pc ; old-fp <- cfp ; c +5 ; b +4 ; a +3 ; z +2 ; y +1 ; x <- csp +0 (defn find-position-of-var (var lst) ; Find the position of var in lst, starting from the ; left-most element of lst. 0 based. (if (nlistp lst) 0 (if (equal var (car lst)) 0 (add1 (find-position-of-var var (cdr lst)))))) (defn offset-from-csp (var program) ; Find the offset from csp of var in a frame built for program. ; When we icompile a reference to var we will take csp and add ; this offset to it. If the locals of the program are ; '(x y z a b c) then the offset of 'x is 0, that of 'c is 5 ; and the offset for a non-local-varp is 6. Thus, if the ; topmost frame of the ctrl stack was built for program -- and ; hence has bindings for each of the locals in the order listed ; above -- then (local-varp var ctrl-stk) is true iff the offset ; is less than the length of the locals. (find-position-of-var var (local-vars program))) ; We now define (defn generate-postlude (program) (list (DL (cons (name program) (length (program-body program))) '(postlude) '(move_csp_cfp)) '(cpop_cfp) '(cpop_pc))) ; (RET) Return from the current subroutine, leaving temp-stk ; untouched but restoring ctrl-stk. We make a special ; case out of top-level RETs: halt the machine with the ; distinguished, non-erroneous psw HALT. (defn p-ret-okp (ins p) t) (defn p-ret-step (ins p) (if (listp (pop (p-ctrl-stk p))) (p-state (ret-pc (top (p-ctrl-stk p))) (pop (p-ctrl-stk p)) (p-temp-stk p) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run) (p-halt p 'halt))) (defn icode-ret (ins pcn program) (list '(jump_*) (tag 'pc (cons (name program) (length (program-body program)))))) ; (LOCN var) The argument var must be a local variable. Suppose ; its value is i. Then push onto temp-stk the value ; of the ith variable bound in the current frame. ; i must be less than the number of variables bound. ; We enumerate the variables from left to right. ; The enumeration is 0 based. Thus, if a subroutine ; has formals X, Y, and Z, and declares temps ; A, B, and C, in that order, X is the 0th local, ; Y the 1st, Z the 2nd, A the 3rd, etc. (defn p-locn-okp (ins p) (and (p-objectp-type 'nat (local-var-value (cadr ins) (p-ctrl-stk p)) p) (lessp (untag (local-var-value (cadr ins) (p-ctrl-stk p))) (length (bindings (top (p-ctrl-stk p))))) (lessp (length (p-temp-stk p)) (p-max-temp-stk-size p)))) ; Observe that LOCN enumerates the variables in the same order that ; they are offset from csp. This is also the same order in which ; they are bound in the p-frame built for the subroutine. ; *** 14-12-87/jsm: The definitions of keyn and var-name were once ; found here but have been deleted because they are no longer used. ; Here then is the step function for LOCN: (defn p-locn-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) ; *** 14-12-87/mk: We no longer go through the variable name ; but instead go directly to the value by position. (push (cdr (get (untag (local-var-value (cadr ins) (p-ctrl-stk p))) (bindings (top (p-ctrl-stk p))))) (p-temp-stk p)) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-locn (ins pcn program) (list '(move_x_*) (tag 'nat (offset-from-csp (cadr ins) program)) '(add_x{n}_csp) ;x is now the address of var '(move_x_) ;x is now the value of var, i '(add_x{n}_csp) ;x is now the address of vari '(tpush_))) ;push value of vari ; (PUSH-CONSTANT c) Push c onto temp-stk. c is normally a tagged ; constant but we permit two abbreviations. ; If c is the atom 'pc, it denotes the pc ; of the instruction following this one. ; If c is a non-LISTP that is defined in ; the current program with a DL, it ; denotes the pc of that label. (defn p-push-constant-okp (ins p) (lessp (length (p-temp-stk p)) (p-max-temp-stk-size p))) ; First I define the ``unabbreviate'' function. Observe that the ; abbreviation depends upon the current state, p, since it permits the ; abbreviation of the current p-pc. (defn unabbreviate-constant (c p) (if (equal c 'pc) ; *** 14-12-87/mk: In the original version an extra layer ; of tagging was done here. (add1-p-pc p) (if (nlistp c) (pc c (p-current-program p)) c))) (defn p-push-constant-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (unabbreviate-constant (cadr ins) p) (p-temp-stk p)) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-push-constant (ins pcn program) (list '(tpush_*) (if (equal (cadr ins) 'pc) (tag 'pc (cons (name program) (add1 pcn))) (if (nlistp (cadr ins)) (pc (cadr ins) program) (cadr ins))))) ; (PUSH-LOCAL var) Push the value of the local variable var onto ; the temp-stk. (defn p-push-local-okp (ins p) (lessp (length (p-temp-stk p)) (p-max-temp-stk-size p))) (defn p-push-local-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (local-var-value (cadr ins) (p-ctrl-stk p)) (p-temp-stk p)) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-push-local (ins pcn program) (list '(move_x_*) (tag 'nat (offset-from-csp (cadr ins) program)) '(add_x{n}_csp) ;x is now the address of var '(tpush_))) ;push value of var onto tsp ; (PUSH-GLOBAL var) Push the value of the global variable var onto ; temp-stk. (defn p-push-global-okp (ins p) (lessp (length (p-temp-stk p)) (p-max-temp-stk-size p))) (defn p-push-global-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (fetch (tag 'addr (cons (cadr ins) 0)) (p-data-segment p)) (p-temp-stk p)) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-push-global (ins pcn program) (list '(move_x_*) (tag 'addr (cons (cadr ins) 0)) '(tpush_))) ; (PUSH-CTRL-STK-FREE-SIZE) ; Push onto temp-stk the size of the ; remaining free space in the control ; stack. This is the number of pushes ; that can be done on the ctrl-stack ; without causing an error. (defn p-push-ctrl-stk-free-size-okp (ins p) (lessp (length (p-temp-stk p)) (p-max-temp-stk-size p))) (defn p-push-ctrl-stk-free-size-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'nat (difference (p-max-ctrl-stk-size p) (p-ctrl-stk-size (p-ctrl-stk p)))) (p-temp-stk p)) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-push-ctrl-stk-free-size (ins pcn program) '((move_x_*) (sys-addr (full-ctrl-stk-addr . 0)) (move_x_) (tpush_csp) (sub_{s}_x{s}))) ; (PUSH-TEMP-STK-FREE-SIZE) ; Push onto temp-stk the size of the ; remaining free space in the temp ; stack. This is the number of pushes ; that can be done on the temp-stack ; without causing an error -- assuming ; that the number pushed here has been ; popped off. For example, if there ; is one slot left on the temp stack ; when this instruction is executed, ; (NAT 1) is pushed and the stack is ; then full. When it is popped, we ; know 1 push can be done. (defn p-push-temp-stk-free-size-okp (ins p) (lessp (length (p-temp-stk p)) (p-max-temp-stk-size p))) (defn p-push-temp-stk-free-size-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'nat (difference (p-max-temp-stk-size p) (length (p-temp-stk p)))) (p-temp-stk p)) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-push-temp-stk-free-size (ins pcn program) '((move_x_*) (sys-addr (full-temp-stk-addr . 0)) (move_x_) (tpush_tsp) (sub_{s}_x{s}))) ; (PUSH-TEMP-STK-INDEX n) ; Push onto temp-stk the temp stk index of the ; slot n below the current top. n must be a ; natural number less than the length of the ; stack. The object pushed is a NAT. ; Below is a picture of a temp-stk with ; of length 6, A being at the top: ; temp-stk: (A B C D E F) ; index: 5 4 3 2 1 0 ; n: 0 1 2 3 4 5 ; The index returned is suitable for use by ; FETCH-TEMP-STK and DEPOSIT-TEMP-STK. (defn p-push-temp-stk-index-okp (ins p) (and (lessp (length (p-temp-stk p)) (p-max-temp-stk-size p)) (lessp (cadr ins) (length (p-temp-stk p))))) (defn p-push-temp-stk-index-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'nat (sub1 (difference (length (p-temp-stk p)) (cadr ins)))) (p-temp-stk p)) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) ; Note: The assembly code below uses sub__x{s}_y{s} but is not actually ; sensitive to the z-flg. I use that instruction simply because it ; was in the i machine already. (defn icode-push-temp-stk-index (ins pcn program) (list '(move_y_tsp) '(move_x_*) '(sys-addr (empty-temp-stk-addr . 0)) '(move_x_) '(sub__x{s}_y{s}) '(tpush_x) '(move_x_*) (tag 'nat (add1 (cadr ins))) '(sub_{n}_x{n}))) ; (JUMP-IF-TEMP-STK-FULL lab) ; If the temp-stk is full, jump to lab. (defn p-jump-if-temp-stk-full-okp (ins p) t) (defn p-jump-if-temp-stk-full-step (ins p) (p-state (if (equal (length (p-temp-stk p)) (p-max-temp-stk-size p)) (pc (cadr ins) (p-current-program p)) (add1-p-pc p)) (p-ctrl-stk p) (p-temp-stk p) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-jump-if-temp-stk-full (ins pcn program) (list '(move_x_tsp) '(move_y_*) '(sys-addr (full-temp-stk-addr . 0)) '(move_y_) '(sub__x{s}_y{s}) '(move_x_*) (pc (cadr ins) program) '(jump-z_x))) ; (JUMP-IF-TEMP-STK-EMPTY lab) ; If the temp-stk is empty, jump to lab. (defn p-jump-if-temp-stk-empty-okp (ins p) t) (defn p-jump-if-temp-stk-empty-step (ins p) (p-state (if (zerop (length (p-temp-stk p))) (pc (cadr ins) (p-current-program p)) (add1-p-pc p)) (p-ctrl-stk p) (p-temp-stk p) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-jump-if-temp-stk-empty (ins pcn program) (list '(move_y_tsp) '(move_x_*) '(sys-addr (empty-temp-stk-addr . 0)) '(move_x_) '(sub__x{s}_y{s}) '(move_x_*) (pc (cadr ins) program) '(jump-z_x))) ; (POP) Pop top of temp-stk and discard (defn p-pop-okp (ins p) (listp (p-temp-stk p))) (defn p-pop-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (pop (p-temp-stk p)) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-pop (ins pcn program) '((tpop_x))) ; (POP* n) Pop temp-stk n times. (defn p-pop*-okp (ins p) (not (lessp (length (p-temp-stk p)) (cadr ins)))) (defn p-pop*-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (popn (cadr ins) (p-temp-stk p)) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-pop* (ins pcn program) (list '(add_tsp_*{n}) (tag 'nat (cadr ins)))) ; (POPN) Pop temp-stk once to obtain n, ; a NAT. Then pop and discard n ; things from temp-stk. n must be ; less than or equal to the length ; of the stack (after it is popped ; off). (defn p-popn-okp (ins p) (and (listp (p-temp-stk p)) (p-objectp-type 'nat (top (p-temp-stk p)) p) (not (lessp (length (p-temp-stk p)) (add1 (untag (top (p-temp-stk p)))))))) (defn p-popn-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (popn (untag (top (p-temp-stk p))) (pop (p-temp-stk p))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-popn (ins pcn program) '((tpop_x) (add_tsp_x{n}))) ; (POP-LOCAL var) Pop top of temp-stk and put the value into the local ; variable var. (defn p-pop-local-okp (ins p) (listp (p-temp-stk p))) (defn p-pop-local-step (ins p) (p-state (add1-p-pc p) (set-local-var-value (top (p-temp-stk p)) (cadr ins) (p-ctrl-stk p)) (pop (p-temp-stk p)) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-pop-local (ins pcn program) (list '(move_x_*) (tag 'nat (offset-from-csp (cadr ins) program)) '(add_x{n}_csp) '(tpop_))) ; (POP-GLOBAL var) Pop top of temp-stk and put the value into the global ; variable var. (defn p-pop-global-okp (ins p) (listp (p-temp-stk p))) (defn p-pop-global-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (pop (p-temp-stk p)) (p-prog-segment p) (deposit (top (p-temp-stk p)) (tag 'addr (cons (cadr ins) 0)) (p-data-segment p)) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-pop-global (ins pcn program) (list '(move_x_*) (tag 'addr (cons (cadr ins) 0)) '(tpop_))) ; (POP-LOCN var) Pop top of temp-stk and put the value into the ith ; bound var in the current frame, where i is the value ; of the bound variable var. (defn p-pop-locn-okp (ins p) (and (p-objectp-type 'nat (local-var-value (cadr ins) (p-ctrl-stk p)) p) (lessp (untag (local-var-value (cadr ins) (p-ctrl-stk p))) (length (bindings (top (p-ctrl-stk p))))) (listp (p-temp-stk p)))) ; *** 14-12-87/mk: In the original definition we set the value ; by going through the name of the ith variable. Duplicate ; names caused problems. We now set the value via position. ; Two new functions are defined. (defn put-value-indirect (val n lst) (if (listp lst) (if (zerop n) (cons (cons (caar lst) val) (cdr lst)) (cons (car lst) (put-value-indirect val (sub1 n) (cdr lst)))) lst)) (defn set-local-var-indirect (val index ctrl-stk) (push (p-frame (put-value-indirect val index (bindings (top ctrl-stk))) (ret-pc (top ctrl-stk))) (pop ctrl-stk))) (defn p-pop-locn-step (ins p) (p-state (add1-p-pc p) ; *** 14-12-87/mk: (set-local-var-indirect (top (p-temp-stk p)) (untag (local-var-value (cadr ins) (p-ctrl-stk p))) (p-ctrl-stk p)) (pop (p-temp-stk p)) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-pop-locn (ins pcn program) (list '(move_x_*) (tag 'nat (offset-from-csp (cadr ins) program)) '(add_x{n}_csp) ;x is now the address of var '(move_x_) ;x is now the value of var, i '(add_x{n}_csp) ;x is now the address of vari '(tpop_))) ; (POP-CALL) Pop temp-stk to obtain a subroutine name and ; call that subroutine. (defn p-pop-call-okp (ins p) (and (listp (p-temp-stk p)) (p-objectp-type 'subr (top (p-temp-stk p)) p) (p-call-okp (list 'call (untag (top (p-temp-stk p)))) (p-state (p-pc p) (p-ctrl-stk p) (pop (p-temp-stk p)) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)))) (defn p-pop-call-step (ins p) (p-call-step (list 'call (untag (top (p-temp-stk p)))) (p-state (p-pc p) (p-ctrl-stk p) (pop (p-temp-stk p)) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run))) (defn icode-pop-call (ins pcn program) (list '(tpop_x) '(cpush_*) (tag 'pc (cons (name program) (add1 pcn))) '(jump_x{subr}))) ; (FETCH-TEMP-STK) Pop top of temp-stk. The result must ; be an index into the temp-stk, that is, ; a NAT less than the length of temp-stk. ; Push onto the temp-stk the contents of ; the indexed cell of temp-stk. (defn p-fetch-temp-stk-okp (ins p) (and (listp (p-temp-stk p)) (p-objectp-type 'nat (top (p-temp-stk p)) p) (lessp (untag (top (p-temp-stk p))) (length (p-temp-stk p))))) (defn p-fetch-temp-stk-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (rget (untag (top (p-temp-stk p))) (p-temp-stk p)) (pop (p-temp-stk p))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-fetch-temp-stk (ins pcn program) '((tpop_y) (incr_y_y{n}) (move_x_*) (sys-addr (empty-temp-stk-addr . 0)) (move_x_) (sub_x{s}_y{n}) (tpush_))) ; (DEPOSIT-TEMP-STK) Pop top and top1 off of temp-stk. top must be ; an index into temp-stk. Deposit top1 into the indexed ; cell of temp-stk. (defn p-deposit-temp-stk-okp (ins p) (and (listp (p-temp-stk p)) (listp (pop (p-temp-stk p))) (p-objectp-type 'nat (top (p-temp-stk p)) p) (lessp (untag (top (p-temp-stk p))) (length (pop (pop (p-temp-stk p))))))) (defn p-deposit-temp-stk-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (rput (top1 (p-temp-stk p)) (untag (top (p-temp-stk p))) (pop (pop (p-temp-stk p)))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-deposit-temp-stk (ins pcn program) '((tpop_y) (incr_y_y{n}) (move_x_*) (sys-addr (empty-temp-stk-addr . 0)) (move_x_) (sub_x{s}_y{n}) (tpop_))) ; (JUMP lab) Jump to the location named by lab in the current ; program. (defn p-jump-okp (ins p) t) (defn p-jump-step (ins p) (p-state (pc (cadr ins) (p-current-program p)) (p-ctrl-stk p) (p-temp-stk p) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-jump (ins pcn program) (list '(jump_*) (pc (cadr ins) program))) ; (JUMP-CASE lab0 lab1 ... labn) ; Pop top of temp-stk. It must be a some nat, i. ; Jump to labi. (defn p-jump-case-okp (ins p) (and (listp (p-temp-stk p)) (p-objectp-type 'nat (top (p-temp-stk p)) p) (lessp (untag (top (p-temp-stk p))) (length (cdr ins))))) (defn p-jump-case-step (ins p) (p-state (pc (get (untag (top (p-temp-stk p))) (cdr ins)) (p-current-program p)) (p-ctrl-stk p) (pop (p-temp-stk p)) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn jump_*-lst (lst program) (if (nlistp lst) nil (cons '(jump_*) (cons (pc (car lst) program) (jump_*-lst (cdr lst) program))))) (defn icode-jump-case (ins pcn program) (append '((tpop_x) (add_x_x{n}) (add_pc_x{n})) (jump_*-lst (cdr ins) program))) ; (PUSHJ lab) Push onto temp-stk the pc of the next instruction ; and then jump to the location named by lab in the ; current program. (defn p-pushj-okp (ins p) (lessp (length (p-temp-stk p)) (p-max-temp-stk-size p))) (defn p-pushj-step (ins p) (p-state (pc (cadr ins) (p-current-program p)) (p-ctrl-stk p) (push (add1-p-pc p) (p-temp-stk p)) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-pushj (ins pcn program) (list '(tpush_*) (tag 'pc (cons (name program) (add1 pcn))) '(jump_*) (pc (cadr ins) program))) ; (POPJ) Pop the temp-stk to obtain a pc and jump to that ; location. The location must be within the current ; program! (defn p-popj-okp (ins p) (and (listp (p-temp-stk p)) (p-objectp-type 'pc (top (p-temp-stk p)) p) (equal (area-name (top (p-temp-stk p))) (area-name (p-pc p))))) (defn p-popj-step (ins p) (p-state (top (p-temp-stk p)) (p-ctrl-stk p) (pop (p-temp-stk p)) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-popj (ins pcn program) '((tpop_pc))) ; (SET-LOCAL var) Set the local variable var to the top of the temp-stk ; but do not pop the temp-stk. (defn p-set-local-okp (ins p) (listp (p-temp-stk p))) (defn p-set-local-step (ins p) (p-state (add1-p-pc p) (set-local-var-value (top (p-temp-stk p)) (cadr ins) (p-ctrl-stk p)) (p-temp-stk p) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-set-local (ins pcn program) (list '(move_x_*) (tag 'nat (offset-from-csp (cadr ins) program)) '(add_x{n}_csp) '(move__))) ; (SET-GLOBAL var) Set the global variable var to the top of the temp-stk ; but do not pop the temp-stk. (defn p-set-global-okp (ins p) (listp (p-temp-stk p))) (defn p-set-global-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (p-temp-stk p) (p-prog-segment p) (deposit (top (p-temp-stk p)) (tag 'addr (cons (cadr ins) 0)) (p-data-segment p)) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-set-global (ins pcn program) (list '(move_x_*) (tag 'addr (cons (cadr ins) 0)) '(move__))) ; (TEST-type-AND-JUMP flg lab) ; Each instruction in this family pops one item, x, off ; temp-stk. The item must be of the indicated type. ; The item is tested as indicated by the flg. If the ; test is satisfied, we jump to the indicated label, lab. ; Otherwise, the next instruction is executed. The ; flags and tests available depend upon the type. ; We enumerate them in the documentation for each ; test-and-jump instruction. ; For each member of the family I define p-test-xxx-and-jump-okp, ; which approves the execution of the instruction. Then I define ; p-test-xxx-and-jump-step and ; icode-test-xxx-and-jump. Both the -okp and the ; -step function are defined in terms of more general purpose functions. (defn p-test-and-jump-okp (ins type test p) (and (listp (p-temp-stk p)) (p-objectp-type type (top (p-temp-stk p)) p))) (defn p-test-and-jump-step (test lab p) (if test (p-state (pc lab (p-current-program p)) (p-ctrl-stk p) (pop (p-temp-stk p)) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run) (p-state (add1-p-pc p) (p-ctrl-stk p) (pop (p-temp-stk p)) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run))) ; (TEST-NAT-AND-JUMP flg lab) ; flg test ; ZERO jump if x is 0 ; NOT-ZERO jump if x is not 0 (defn p-test-natp (flg x) (case flg (ZERO (equal x 0)) (otherwise (not (equal x 0))))) (defn p-test-nat-and-jump-okp (ins p) (p-test-and-jump-okp ins 'nat (p-test-natp (cadr ins) (untag (top (p-temp-stk p)))) p)) (defn p-test-nat-and-jump-step (ins p) (p-test-and-jump-step (p-test-natp (cadr ins) (untag (top (p-temp-stk p)))) (caddr ins) p)) (defn icode-test-nat-and-jump (ins pcn program) (case (cadr ins) (ZERO (list '(tpop{n}__y) '(move_x_*) (pc (caddr ins) program) '(jump-z_x))) (otherwise (list '(tpop{n}__y) '(move_x_*) (pc (caddr ins) program) '(jump-nz_x))))) ; (TEST-INT-AND-JUMP flg lab) ; flg test ; ZERO jump if x is 0 ; NOT-ZERO jump if x is not 0 ; NEG jump if x is negative ; NOT-NEG jump if x is not negative ; POS jump if x is positive ; NOT-POS jump if x is not positive (defn p-test-intp (flg x) (case flg (ZERO (equal x 0)) (NOT-ZERO (not (equal x 0))) (NEG (negativep x)) (NOT-NEG (not (negativep x))) (POS (and (numberp x) (not (equal x 0)))) (otherwise (or (equal x 0) (negativep x))))) (defn p-test-int-and-jump-okp (ins p) (p-test-and-jump-okp ins 'int (p-test-intp (cadr ins) (untag (top (p-temp-stk p)))) p)) (defn p-test-int-and-jump-step (ins p) (p-test-and-jump-step (p-test-intp (cadr ins) (untag (top (p-temp-stk p)))) (caddr ins) p)) (defn icode-test-int-and-jump (ins pcn program) (case (cadr ins) (ZERO (list '(tpop{i}__y) '(move_x_*) (pc (caddr ins) program) '(jump-z_x))) (NOT-ZERO (list '(tpop{i}__y) '(move_x_*) (pc (caddr ins) program) '(jump-nz_x))) (NEG (list '(tpop{i}__y) '(move_x_*) (pc (caddr ins) program) '(jump-n_x))) (NOT-NEG (list '(tpop{i}__y) '(move_x_*) (pc (caddr ins) program) '(jump-nn_x))) (POS (list '(tpop{i}__y) '(move_x_*) (tag 'pc (cons (name program) (add1 pcn))) '(jump-n_x) '(jump-z_x) '(jump_*) (pc (caddr ins) program))) (otherwise (list '(tpop{i}__y) '(move_x_*) (pc (caddr ins) program) '(jump-n_x) '(jump-z_x))))) ; (TEST-BOOL-AND-JUMP flg lab) ; flg test ; T jump if x is T ; F jump if x is F (defn p-test-boolp (flg x) (case flg (T (equal x 'T)) (otherwise (equal x 'F)))) (defn p-test-bool-and-jump-okp (ins p) (p-test-and-jump-okp ins 'bool (p-test-boolp (cadr ins) (untag (top (p-temp-stk p)))) p)) (defn p-test-bool-and-jump-step (ins p) (p-test-and-jump-step (p-test-boolp (cadr ins) (untag (top (p-temp-stk p)))) (caddr ins) p)) (defn icode-test-bool-and-jump (ins pcn program) (case (cadr ins) (T (list '(tpop{b}__y) '(move_x_*) (pc (caddr ins) program) '(jump-nz_x))) (otherwise (list '(tpop{b}__y) '(move_x_*) (pc (caddr ins) program) '(jump-z_x))))) ; (TEST-BITV-AND-JUMP flg lab) ; flg test ; ALL-ZERO jump if x contains all 0's ; NOT-ALL-ZERO jump if x contains a 1 (defn p-test-bitvp (flg x) (case flg (ALL-ZERO (all-zero-bitvp x)) (otherwise (not (all-zero-bitvp x))))) (defn p-test-bitv-and-jump-okp (ins p) (p-test-and-jump-okp ins 'bitv (p-test-bitvp (cadr ins) (untag (top (p-temp-stk p)))) p)) (defn p-test-bitv-and-jump-step (ins p) (p-test-and-jump-step (p-test-bitvp (cadr ins) (untag (top (p-temp-stk p)))) (caddr ins) p)) (defn icode-test-bitv-and-jump (ins pcn program) (case (cadr ins) (ALL-ZERO (list '(tpop{v}__y) '(move_x_*) (pc (caddr ins) program) '(jump-z_x))) (otherwise (list '(tpop{v}__y) '(move_x_*) (pc (caddr ins) program) '(jump-nz_x))))) ; (NO-OP) Do nothing. Advance the pc to the next instruction. (defn p-no-op-okp (ins p) t) (defn p-no-op-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (p-temp-stk p) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-no-op (ins pcn program) (list '(move_x_x))) ; Note: One might ask why no-ops generate any instructions at all. ; The reason is that it was the easiest way to guarantee that I kept ; proper track of high level pcs. I have a guarantee that every pc ; at the high level corresponds to a label at the i level. I have ; adopted the (DL pc & ins) hack to associate labels with instructions. ; I can't attach multiple labels to the same point. So I see no alternative ; to generating a place holder instruction for the no-op and attaching ; a label to it. Of course, I could change the DL conventions so that ; if no instruction was present we migrated the label down to the next ; DL and used (DL (pc1 pc2 ...) ins). But even that loses ; if a no-op occurs as the last instruction. This seems simplest. ; (ADD-ADDR) Pop top and top1 from temp-stk. Top1 must ; be an addr, top must be a nat. Increment ; the addr by nat and if that is a legal address ; push it onto temp-stk. (defn p-add-addr-okp (ins p) (and (listp (p-temp-stk p)) (listp (pop (p-temp-stk p))) (p-objectp-type 'nat (top (p-temp-stk p)) p) (p-objectp-type 'addr (top1 (p-temp-stk p)) p) (p-objectp-type 'addr (add-addr (top1 (p-temp-stk p)) (untag (top (p-temp-stk p)))) p))) (defn p-add-addr-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (add-addr (top1 (p-temp-stk p)) (untag (top (p-temp-stk p)))) (pop (pop (p-temp-stk p)))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-add-addr (ins pcn program) '((tpop_x) (add_{a}_x{n}))) ; (SUB-ADDR) Pop top and top1 off of temp-stk. ; Top must be a nat and top1 must be ; an addr. Decrement the offset of the ; addr by nat and push the result. (defn p-sub-addr-okp (ins p) (and (listp (p-temp-stk p)) (listp (pop (p-temp-stk p))) (p-objectp-type 'nat (top (p-temp-stk p)) p) (p-objectp-type 'addr (top1 (p-temp-stk p)) p) (not (lessp (offset (top1 (p-temp-stk p))) (untag (top (p-temp-stk p))))))) (defn p-sub-addr-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (sub-addr (top1 (p-temp-stk p)) (untag (top (p-temp-stk p)))) (pop (pop (p-temp-stk p)))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-sub-addr (ins pcn program) '((tpop_x) (sub_{a}_x{n}))) ; (EQ) Pop top and top1 off of temp-stk. If they ; are both of the same type, push T or F according ; to whether they are equal. (defn p-eq-okp (ins p) (and (listp (p-temp-stk p)) (listp (pop (p-temp-stk p))) (equal (type (top (p-temp-stk p))) (type (top1 (p-temp-stk p)))))) (defn p-eq-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (bool (equal (untag (top1 (p-temp-stk p))) (untag (top (p-temp-stk p))))) (pop (pop (p-temp-stk p)))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-eq (ins pcn program) '((tpop_x) (xor___x) (xor__) (move-z__*) (bool t))) ; (LT-ADDR) Pop top and top1 off of temp-stk, ; and if both are addresses into the same area, ; push T if top1 < top and push F otherwise. (defn p-lt-addr-okp (ins p) (and (listp (p-temp-stk p)) (listp (pop (p-temp-stk p))) (p-objectp-type 'addr (top (p-temp-stk p)) p) (p-objectp-type 'addr (top1 (p-temp-stk p)) p) (equal (area-name (top (p-temp-stk p))) (area-name (top1 (p-temp-stk p)))))) (defn p-lt-addr-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (bool (lessp (offset (top1 (p-temp-stk p))) (offset (top (p-temp-stk p))))) (pop (pop (p-temp-stk p)))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-lt-addr (ins pcn program) '((tpop_x) (sub__{a}_x{a}) (xor__) (move-c__*) (bool t))) ; (FETCH) Pop top of temp-stk. The result must ; be an address. Push the contents of that ; address onto temp-stk. (defn p-fetch-okp (ins p) (and (listp (p-temp-stk p)) (p-objectp-type 'addr (top (p-temp-stk p)) p))) (defn p-fetch-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (fetch (top (p-temp-stk p)) (p-data-segment p)) (pop (p-temp-stk p))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-fetch (ins pcn program) '((tpop_x) (tpush_))) ; (DEPOSIT) Pop top and top1 off of temp-stk. top must be ; an address. Deposit top1 into the address. (defn p-deposit-okp (ins p) (and (listp (p-temp-stk p)) (listp (pop (p-temp-stk p))) (p-objectp-type 'addr (top (p-temp-stk p)) p))) (defn p-deposit-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (pop (pop (p-temp-stk p))) (p-prog-segment p) (deposit (top1 (p-temp-stk p)) (top (p-temp-stk p)) (p-data-segment p)) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-deposit (ins pcn program) '((tpop_x) (tpop_))) ; (ADD-INT) Pop top and top1 off of temp-stk. Both must ; be INTs. Add them together and push the result, ; provided it is representable as an INT. (defn p-add-int-okp (ins p) (and (listp (p-temp-stk p)) (listp (pop (p-temp-stk p))) (p-objectp-type 'int (top (p-temp-stk p)) p) (p-objectp-type 'int (top1 (p-temp-stk p)) p) (small-integerp (iplus (untag (top1 (p-temp-stk p))) (untag (top (p-temp-stk p)))) (p-word-size p)))) (defn p-add-int-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'int (iplus (untag (top1 (p-temp-stk p))) (untag (top (p-temp-stk p))))) (pop (pop (p-temp-stk p)))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-add-int (ins pcn program) '((tpop_x) (add_{i}_x{i}))) ; (ADD-INT-WITH-CARRY) ; Pop three things off temp stack, top, top1 and ; top2. Top and top1 must be INTs. Top2 must ; be Boolean. Add top+top1+top2 -- coercing T to 1 ; and F to 0. Push two results. First, a boolean ; indicating whether top+top1+top2 is not small. ; On top of that, push the corrected sum. The corrected ; sum is the sum, if that is a small-integerp; the ; sum+2**word-size, if the sum is not small and is ; negative; and the sum-2**word-size, if the sum is ; not small and not negative. (defn p-add-int-with-carry-okp (ins p) (and (listp (p-temp-stk p)) (listp (pop (p-temp-stk p))) (listp (pop (pop (p-temp-stk p)))) (p-objectp-type 'int (top (p-temp-stk p)) p) (p-objectp-type 'int (top1 (p-temp-stk p)) p) (p-objectp-type 'bool (top2 (p-temp-stk p)) p))) (defn p-add-int-with-carry-step (ins p) (let ((sum (iplus (bool-to-nat (untag (top2 (p-temp-stk p)))) (iplus (untag (top1 (p-temp-stk p))) (untag (top (p-temp-stk p))))))) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'int (fix-small-integer sum (p-word-size p))) ; *** 5-3-88/jsm: replaced (tag 'bool &) by (bool &) (push (bool (not (small-integerp sum (p-word-size p)))) (pop (pop (pop (p-temp-stk p)))))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run))) (defn icode-add-int-with-carry (ins pcn program) '((tpop_x) (tpop_y) (asr___{b}) ;set c-flg to top tsp. Set top to F. (addc__x{i}_y{i}) ;x <- x+y+carry-flg (move-v__*) ;set top tsp to T if v-flg. (bool T) (tpush_x))) ; (ADD1-INT) Pop top of temp-stk. The result must be an INT. ; Increment it by one and push the result, provided ; it is representable as an INT. (defn p-add1-int-okp (ins p) (and (listp (p-temp-stk p)) (p-objectp-type 'int (top (p-temp-stk p)) p) (small-integerp (iplus 1 (untag (top (p-temp-stk p)))) (p-word-size p)))) (defn p-add1-int-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'int (iplus 1 (untag (top (p-temp-stk p))))) (pop (p-temp-stk p))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-add1-int (ins pcn program) '((incr__{i}))) ; (SUB-INT) Pop top and top1 off of temp-stk. Both must be ; INTs. Subtract top from top1, i.e., form top1-top, ; and push the result provided it is representable ; as an INT. (defn p-sub-int-okp (ins p) (and (listp (p-temp-stk p)) (listp (pop (p-temp-stk p))) (p-objectp-type 'int (top (p-temp-stk p)) p) (p-objectp-type 'int (top1 (p-temp-stk p)) p) (small-integerp (idifference (untag (top1 (p-temp-stk p))) (untag (top (p-temp-stk p)))) (p-word-size p)))) (defn p-sub-int-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'int (idifference (untag (top1 (p-temp-stk p))) (untag (top (p-temp-stk p))))) (pop (pop (p-temp-stk p)))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-sub-int (ins pcn program) '((tpop_x) (sub_{i}_x{i}))) ; (SUB-INT-WITH-CARRY) ; Pop three things off temp stack, top, top1 and ; top2. Top and top1 must be INTs. Top2 must ; be Boolean. Form top1-(top+top2) -- coercing T to 1 ; and F to 0. Push two results. First, a boolean ; indicating whether top1-(top+top2) is not small. ; On top of that, push the corrected diff. The corrected ; diff is the diff, if that is a small-integerp; the ; diff+2**word-size, if the diff is not small and is ; negative; and the diff-2**word-size, if the diff is ; not small and not negative. (defn p-sub-int-with-carry-okp (ins p) (and (listp (p-temp-stk p)) (listp (pop (p-temp-stk p))) (listp (pop (pop (p-temp-stk p)))) (p-objectp-type 'int (top (p-temp-stk p)) p) (p-objectp-type 'int (top1 (p-temp-stk p)) p) (p-objectp-type 'bool (top2 (p-temp-stk p)) p))) (defn p-sub-int-with-carry-step (ins p) (let ((diff (idifference (untag (top1 (p-temp-stk p))) (iplus (untag (top (p-temp-stk p))) (bool-to-nat (untag (top2 (p-temp-stk p)))))))) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'int (fix-small-integer diff (p-word-size p))) ; *** 5-3-88/jsm: replaced (tag 'bool &) by (bool &) (push (bool (not (small-integerp diff (p-word-size p)))) (pop (pop (pop (p-temp-stk p)))))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run))) (defn icode-sub-int-with-carry (ins pcn program) '((tpop_y) (tpop_x) (asr___{b}) ;set c-flg to top tsp. Set top to F. (subb__x{i}_y{i}) ;x <- x-y+carry-flg (move-v__*) ;set top tsp to T if v-flg. (bool T) (tpush_x))) ; (SUB1-INT) Pop top of temp-stk. It must be an INT. ; Decrement it by one and push the result, ; provided it is representable as an INT. (defn p-sub1-int-okp (ins p) (and (listp (p-temp-stk p)) (p-objectp-type 'int (top (p-temp-stk p)) p) (small-integerp (idifference (untag (top (p-temp-stk p))) 1) (p-word-size p)))) (defn p-sub1-int-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'int (idifference (untag (top (p-temp-stk p))) 1)) (pop (p-temp-stk p))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-sub1-int (ins pcn program) '((decr__{i}))) ; (NEG-INT) Pop top of temp-stk. It must be an INT. ; Negate it and push the result provided it is ; representable as an INT. (defn p-neg-int-okp (ins p) (and (listp (p-temp-stk p)) (p-objectp-type 'int (top (p-temp-stk p)) p) (small-integerp (inegate (untag (top (p-temp-stk p)))) (p-word-size p)))) (defn p-neg-int-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'int (inegate (untag (top (p-temp-stk p))))) (pop (p-temp-stk p))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-neg-int (ins pcn program) '((neg__{i}))) ; (LT-INT) Pop top and top1 off of temp-stk, and push T or F ; according to whether top1 < top. (defn p-lt-int-okp (ins p) (and (listp (p-temp-stk p)) (listp (pop (p-temp-stk p))) (p-objectp-type 'int (top (p-temp-stk p)) p) (p-objectp-type 'int (top1 (p-temp-stk p)) p))) (defn p-lt-int-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (bool (ilessp (untag (top1 (p-temp-stk p))) (untag (top (p-temp-stk p))))) (pop (pop (p-temp-stk p)))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) ; Let n-flg and v-flg be the values of the n-flg and v-flg after computing x-y. ; It is a theorem that x_{i}_x{i}) (move__*) (bool f) (move-v__*) (bool t) (move_x_*) (bool f) (move-n_x_*) (bool t) (xor_{b}_x{b}))) ; The code above requires 7 clock ticks. I have written one requiring ; 5 or 6 ticks, depending on whether n-flg was T or F. But that code ; required an interior label and a move-n_pc_ instruction where the ; label at pc+1 is one less than where I need to go (because the post ; increment adds to it). The interior label would destroy the current ; r-i proof structure, but could probably be patched around. ; (INT-TO-NAT) Pop top off of temp-stk. Top should ; be of type INT and be nonnegative. ; Push the NAT corresponding to top. (defn p-int-to-nat-okp (ins p) (and (listp (p-temp-stk p)) (p-objectp-type 'int (top (p-temp-stk p)) p) (not (negativep (untag (top (p-temp-stk p))))))) (defn p-int-to-nat-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'nat (untag (top (p-temp-stk p)))) (pop (p-temp-stk p))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-int-to-nat (ins pcn program) '((int-to-nat))) ; (ADD-NAT) Pop top and top1 off of temp-stk. ; Both top and top1 must be NATs. Push ; their NAT sum. ; *** 15-12-87/jsm: This is actually a new Piton instruction with ; the same name as an old one. The old ADD-NAT has been renamed ; ADD-NAT-WITH-CARRY. (defn p-add-nat-okp (ins p) (and (listp (p-temp-stk p)) (listp (pop (p-temp-stk p))) (p-objectp-type 'nat (top (p-temp-stk p)) p) (p-objectp-type 'nat (top1 (p-temp-stk p)) p) (small-naturalp (plus (untag (top1 (p-temp-stk p))) (untag (top (p-temp-stk p)))) (p-word-size p)))) (defn p-add-nat-step (ins p) (let ((sum (plus (untag (top1 (p-temp-stk p))) (untag (top (p-temp-stk p)))))) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'nat sum) (pop (pop (p-temp-stk p)))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run))) (defn icode-add-nat (ins pcn program) '((tpop_x) (add_{n}_x{n}))) ; (ADD-NAT-WITH-CARRY) ; Pop top, top1 and top2 off of temp-stk. ; Both top and top1 must be NATs. Top2 must be BOOL. ; Add all three together -- coercing T to 1 and F to 0. ; Let the result be sum. Push T or F according to ; whether sum is not small. Then push ; sum mod 2**word-size. ; *** 15-12-87/jsm: This used to be called ADD-NAT. I have renamed it ; so that the name ADD-NAT can be used for the simpler instruction ; that adds two naturals without input or output carry. (defn p-add-nat-with-carry-okp (ins p) (and (listp (p-temp-stk p)) (listp (pop (p-temp-stk p))) (listp (pop (pop (p-temp-stk p)))) (p-objectp-type 'nat (top (p-temp-stk p)) p) (p-objectp-type 'nat (top1 (p-temp-stk p)) p) (p-objectp-type 'bool (top2 (p-temp-stk p)) p))) (defn p-add-nat-with-carry-step (ins p) (let ((sum (plus (bool-to-nat (untag (top2 (p-temp-stk p)))) (untag (top1 (p-temp-stk p))) (untag (top (p-temp-stk p)))))) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'nat (fix-small-natural sum (p-word-size p))) (push (bool ; *** 1-88/mk: The (tag 'bool ...) has been removed since the (bool ...) ; is already there. (not (small-naturalp sum (p-word-size p)))) (pop (pop (pop (p-temp-stk p)))))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run))) (defn icode-add-nat-with-carry (ins pcn program) '((tpop_x) (tpop_y) (asr___{b}) ;set c-flg to top tsp. Set top to F. (addc__x{n}_y{n}) ;x <- x+y+carry-flg (move-c__*) ;set top tsp to T if carry-flg. (bool T) (tpush_x))) ;push sum. ; (ADD1-NAT) Pop top off of temp-stk, add 1 to it ; and push the result. The result must ; be representable. ; *** 16-12-87/jsm: New instruction. (defn p-add1-nat-okp (ins p) (and (listp (p-temp-stk p)) (p-objectp-type 'nat (top (p-temp-stk p)) p) (small-naturalp (add1 (untag (top (p-temp-stk p)))) (p-word-size p)))) (defn p-add1-nat-step (ins p) (let ((sum (add1 (untag (top (p-temp-stk p)))))) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'nat sum) (pop (p-temp-stk p))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run))) (defn icode-add1-nat (ins pcn program) '((incr__{n}))) ; (SUB-NAT) Pop top, top1 off of temp-stk. ; Both top and top1 must be NATs. ; If top1 >= top ; then push top1-top. ; Else, error. ; *** 15-12-87/jsm: This is a new instruction with an old name. ; The instruction SUB-NAT-WITH-CARRY is now what used to be SUB-NAT. (defn p-sub-nat-okp (ins p) (and (listp (p-temp-stk p)) (listp (pop (p-temp-stk p))) (p-objectp-type 'nat (top (p-temp-stk p)) p) (p-objectp-type 'nat (top1 (p-temp-stk p)) p) (not (lessp (untag (top1 (p-temp-stk p))) (untag (top (p-temp-stk p))))))) (defn p-sub-nat-step (ins p) (let ((y (untag (top (p-temp-stk p)))) (x (untag (top1 (p-temp-stk p))))) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'nat (difference x y)) (pop (pop (p-temp-stk p)))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run))) (defn icode-sub-nat (ins pcn program) '((tpop_x) (sub_{n}_x{n}))) ; (SUB-NAT-WITH-CARRY) ; Pop top, top1 and top2 off of temp-stk. ; Both top and top1 must be NATs. Top2 must be BOOL. ; If top1 >= top+top2 -- coercing T to 1 and F to 0 -- ; then push F and top1-(top+top2). ; Else, push T and 2**word-size-((top+top2)-top1). ; *** 15-12-87/jsm: This instruction was renamed from SUB-NAT to free ; that name for the new, simpler instruction. (defn p-sub-nat-with-carry-okp (ins p) (and (listp (p-temp-stk p)) (listp (pop (p-temp-stk p))) (listp (pop (pop (p-temp-stk p)))) (p-objectp-type 'nat (top (p-temp-stk p)) p) (p-objectp-type 'nat (top1 (p-temp-stk p)) p) (p-objectp-type 'bool (top2 (p-temp-stk p)) p))) (defn p-sub-nat-with-carry-step (ins p) (let ((y (untag (top (p-temp-stk p)))) (x (untag (top1 (p-temp-stk p)))) (c (bool-to-nat (untag (top2 (p-temp-stk p)))))) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'nat (if (lessp x (plus y c)) (difference (exp 2 (p-word-size p)) (difference (plus y c) x)) (difference x (plus y c)))) (push (bool (lessp x (plus y c))) (pop (pop (pop (p-temp-stk p)))))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run))) (defn icode-sub-nat-with-carry (ins pcn program) '((tpop_y) (tpop_x) (asr___{b}) ;set c-flg to top tsp. Set top to F. (subb__x{n}_y{n}) ;x <- x-(y+c) (move-c__*) ;set top tsp to T if carry-flg. (bool T) (tpush_x))) ; (SUB1-NAT) Pop top off of temp-stk. ; Top must be a NAT other than ; 0. Push top-1. ; *** 16-12-87/jsm: This is a new instruction. (defn p-sub1-nat-okp (ins p) (and (listp (p-temp-stk p)) (p-objectp-type 'nat (top (p-temp-stk p)) p) (not (zerop (untag (top (p-temp-stk p))))))) (defn p-sub1-nat-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'nat (sub1 (untag (top (p-temp-stk p))))) (pop (p-temp-stk p))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-sub1-nat (ins pcn program) '((decr__{n}))) ; (LT-NAT) Pop top and top1 off of temp-stk, and push T or F ; according to whether top1 < top. (defn p-lt-nat-okp (ins p) (and (listp (p-temp-stk p)) (listp (pop (p-temp-stk p))) (p-objectp-type 'nat (top (p-temp-stk p)) p) (p-objectp-type 'nat (top1 (p-temp-stk p)) p))) (defn p-lt-nat-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) ; *** 1-88/mk: The following is different because (tag 'bool ...) doesn't ; keep us using 't and 'f instead of T and F (push (bool (lessp (untag (top1 (p-temp-stk p))) (untag (top (p-temp-stk p))))) (pop (pop (p-temp-stk p)))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-lt-nat (ins pcn program) '((tpop_x) (sub__{n}_x{n}) (xor__) (move-c__*) (bool t))) ; (MULT2-NAT) Pop top of temp-stk, multiply by 2 and push ; the result, which must be a small-naturalp. (defn p-mult2-nat-okp (ins p) (and (listp (p-temp-stk p)) (p-objectp-type 'nat (top (p-temp-stk p)) p) (small-naturalp (times 2 (untag (top (p-temp-stk p)))) (p-word-size p)))) (defn p-mult2-nat-step (ins p) (let ((prod (times 2 (untag (top (p-temp-stk p)))))) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'nat prod) (pop (p-temp-stk p))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run))) (defn icode-mult2-nat (ins pcn program) '((add__{n}))) ; (MULT2-NAT-WITH-CARRY-OUT) ; Pop top of temp-stk, multiply by 2 and push ; two things: whether the result is not smallp and ; the result mod 2**word-size. ; *** 15-12-87/jsm: Renamed from MULT2. (defn p-mult2-nat-with-carry-out-okp (ins p) (and (listp (p-temp-stk p)) (p-objectp-type 'nat (top (p-temp-stk p)) p) (lessp (length (p-temp-stk p)) (p-max-temp-stk-size p)))) (defn p-mult2-nat-with-carry-out-step (ins p) (let ((prod (times 2 (untag (top (p-temp-stk p)))))) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'nat (fix-small-natural prod (p-word-size p))) (push (bool (not (small-naturalp prod (p-word-size p)))) (pop (p-temp-stk p)))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run))) (defn icode-mult2-nat-with-carry-out (ins pcn program) '((tpop_x) (add__x_x{n}) (tpush_*) (bool F) (move-c__*) (bool T) (tpush_x))) ; (DIV2-NAT) Pop top of temp-stk, divide by 2 and push ; two things: the quotient mod 2 and then ; the remainder mod 2. (defn p-div2-nat-okp (ins p) (and (listp (p-temp-stk p)) (p-objectp-type 'nat (top (p-temp-stk p)) p) (lessp (length (p-temp-stk p)) (p-max-temp-stk-size p)))) (defn p-div2-nat-step (ins p) (let ((quo (quotient (untag (top (p-temp-stk p))) 2)) (rem (remainder (untag (top (p-temp-stk p))) 2))) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'nat rem) (push (tag 'nat quo) (pop (p-temp-stk p)))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run))) (defn icode-div2-nat (ins pcn program) '((tpop__x) ;guarantees to clear carry flg (lsr__x_x{n}) (tpush_x) (tpush_*) (nat 0) (move-c__*) (nat 1))) ; (OR-BITV) Pop top and top1 off of temp-stk, or them together ; and push the result. (defn p-or-bitv-okp (ins p) (and (listp (p-temp-stk p)) (listp (pop (p-temp-stk p))) (p-objectp-type 'bitv (top (p-temp-stk p)) p) (p-objectp-type 'bitv (top1 (p-temp-stk p)) p))) (defn p-or-bitv-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'bitv (or-bitv (untag (top1 (p-temp-stk p))) (untag (top (p-temp-stk p))))) (pop (pop (p-temp-stk p)))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-or-bitv (ins pcn program) '((tpop_x) (or_{v}_x{v}))) ; (AND-BITV) Pop top and top1 off of temp-stk, and them together ; and push the result. (defn p-and-bitv-okp (ins p) (and (listp (p-temp-stk p)) (listp (pop (p-temp-stk p))) (p-objectp-type 'bitv (top (p-temp-stk p)) p) (p-objectp-type 'bitv (top1 (p-temp-stk p)) p))) (defn p-and-bitv-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'bitv (and-bitv (untag (top1 (p-temp-stk p))) (untag (top (p-temp-stk p))))) (pop (pop (p-temp-stk p)))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-and-bitv (ins pcn program) '((tpop_x) (and_{v}_x{v}))) ; (NOT-BITV) Pop top of temp-stk, not it, and push the result. (defn p-not-bitv-okp (ins p) (and (listp (p-temp-stk p)) (p-objectp-type 'bitv (top (p-temp-stk p)) p))) (defn p-not-bitv-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'bitv (not-bitv (untag (top (p-temp-stk p))))) (pop (p-temp-stk p))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-not-bitv (ins pcn program) '((not__{v}))) ; (XOR-BITV) Pop top and top1 off of temp-stk, xor them, ; and push the result. (defn p-xor-bitv-okp (ins p) (and (listp (p-temp-stk p)) (listp (pop (p-temp-stk p))) (p-objectp-type 'bitv (top (p-temp-stk p)) p) (p-objectp-type 'bitv (top1 (p-temp-stk p)) p))) (defn p-xor-bitv-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'bitv (xor-bitv (untag (top1 (p-temp-stk p))) (untag (top (p-temp-stk p))))) (pop (pop (p-temp-stk p)))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-xor-bitv (ins pcn program) '((tpop_x) (xor_{v}_x{v}))) ; (RSH-BITV) Pop top of temp-stk, shift it right 1, bringing ; a 0 in at the top, and push the result. (defn p-rsh-bitv-okp (ins p) (and (listp (p-temp-stk p)) (p-objectp-type 'bitv (top (p-temp-stk p)) p))) (defn p-rsh-bitv-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'bitv (rsh-bitv (untag (top (p-temp-stk p))))) (pop (p-temp-stk p))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-rsh-bitv (ins pcn program) '((lsr__{v}))) ; (LSH-BITV) Pop top of temp-stk, shift it left 1, bringing ; a 0 in at the btm, and push the result. (defn p-lsh-bitv-okp (ins p) (and (listp (p-temp-stk p)) (p-objectp-type 'bitv (top (p-temp-stk p)) p))) (defn p-lsh-bitv-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'bitv (lsh-bitv (untag (top (p-temp-stk p))))) (pop (p-temp-stk p))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-lsh-bitv (ins pcn program) '((add__{v}))) ; (OR-BOOL) Pop top and top1 off of temp-stk, or them together ; and push the result. (defn p-or-bool-okp (ins p) (and (listp (p-temp-stk p)) (listp (pop (p-temp-stk p))) (p-objectp-type 'bool (top (p-temp-stk p)) p) (p-objectp-type 'bool (top1 (p-temp-stk p)) p))) (defn p-or-bool-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'bool (or-bool (untag (top1 (p-temp-stk p))) (untag (top (p-temp-stk p))))) (pop (pop (p-temp-stk p)))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-or-bool (ins pcn program) '((tpop_x) (or_{b}_x{b}))) ; (AND-BOOL) Pop top and top1 off of temp-stk, and them together ; and push the result. ; (defn p-and-bool-okp (ins p) (and (listp (p-temp-stk p)) (listp (pop (p-temp-stk p))) (p-objectp-type 'bool (top (p-temp-stk p)) p) (p-objectp-type 'bool (top1 (p-temp-stk p)) p))) (defn p-and-bool-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'bool (and-bool (untag (top1 (p-temp-stk p))) (untag (top (p-temp-stk p))))) (pop (pop (p-temp-stk p)))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-and-bool (ins pcn program) '((tpop_x) (and_{b}_x{b}))) ; (NOT-BOOL) Pop top of temp-stk, not it, and push the result. (defn p-not-bool-okp (ins p) (and (listp (p-temp-stk p)) (p-objectp-type 'bool (top (p-temp-stk p)) p))) (defn p-not-bool-step (ins p) (p-state (add1-p-pc p) (p-ctrl-stk p) (push (tag 'bool ; *** 1-88/mk: TOP used to be TOP1 on the following line (not-bool (untag (top (p-temp-stk p))))) (pop (p-temp-stk p))) (p-prog-segment p) (p-data-segment p) (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) 'run)) (defn icode-not-bool (ins pcn program) '((xor_{b}_*{b}) (bool t))) ;--------------------------------------------------------------------------------- ; The P Machine ; The complete list of PITON opcodes is given below. To add a new ; instruction, xxx, to the PITON machine it is necessary to ; (a) define the function (p-xxx-okp ins p), which returns T or F ; according to whether it is legal to execute ins in state p, where ; ins is an instance of the new instruction xxx. ; (b) define the function (p-xxx-step ins p), which returns the state ; produced by stepping forward from state p by the instruction ins. ; Ins is known to be p-xxx-okp. ; (c) add xxx to the list below. ; The prescription above does NOT address how you implement the new ; instruction via the icompiler, etc. (defn piton-opcodes nil '(call ret locn push-constant push-local push-global push-ctrl-stk-free-size push-temp-stk-free-size push-temp-stk-index jump-if-temp-stk-full jump-if-temp-stk-empty pop pop* popn pop-local pop-global pop-locn pop-call fetch-temp-stk deposit-temp-stk jump jump-case pushj popj set-local set-global test-nat-and-jump test-int-and-jump test-bool-and-jump test-bitv-and-jump no-op add-addr sub-addr eq lt-addr fetch deposit add-int add-int-with-carry add1-int sub-int sub-int-with-carry sub1-int neg-int lt-int int-to-nat add-nat add-nat-with-carry add1-nat sub-nat sub-nat-with-carry sub1-nat lt-nat mult2-nat mult2-nat-with-carry-out div2-nat or-bitv and-bitv not-bitv xor-bitv rsh-bitv lsh-bitv or-bool and-bool not-bool )) ; The following function generates the name of the error ; message produced when an illegal instruction is hit. The ; first argument is the ``level'' name, e.g., 'P or 'R. ; the (cdr (unpack 'g-instruction)) is used instead of ; (unpack '-instruction) only because '-instruction is an ; illegal evg in the logic, since it does not start with an ; alphabetic character. (defn x-y-error-msg (x y) (pack (append (unpack 'illegal-) (append (unpack y) (cdr (unpack 'g-instruction)))))) ; The function checks that it is legal to execute ins in state ; p: (defn p-ins-okp (ins p) (case (car ins) (call (p-call-okp ins p)) (ret (p-ret-okp ins p)) (locn (p-locn-okp ins p)) (push-constant (p-push-constant-okp ins p)) (push-local (p-push-local-okp ins p)) (push-global (p-push-global-okp ins p)) (push-ctrl-stk-free-size (p-push-ctrl-stk-free-size-okp ins p)) (push-temp-stk-free-size (p-push-temp-stk-free-size-okp ins p)) (push-temp-stk-index (p-push-temp-stk-index-okp ins p)) (jump-if-temp-stk-full (p-jump-if-temp-stk-full-okp ins p)) (jump-if-temp-stk-empty (p-jump-if-temp-stk-empty-okp ins p)) (pop (p-pop-okp ins p)) (pop* (p-pop*-okp ins p)) (popn (p-popn-okp ins p)) (pop-local (p-pop-local-okp ins p)) (pop-global (p-pop-global-okp ins p)) (pop-locn (p-pop-locn-okp ins p)) (pop-call (p-pop-call-okp ins p)) (fetch-temp-stk (p-fetch-temp-stk-okp ins p)) (deposit-temp-stk (p-deposit-temp-stk-okp ins p)) (jump (p-jump-okp ins p)) (jump-case (p-jump-case-okp ins p)) (pushj (p-pushj-okp ins p)) (popj (p-popj-okp ins p)) (set-local (p-set-local-okp ins p)) (set-global (p-set-global-okp ins p)) (test-nat-and-jump (p-test-nat-and-jump-okp ins p)) (test-int-and-jump (p-test-int-and-jump-okp ins p)) (test-bool-and-jump (p-test-bool-and-jump-okp ins p)) (test-bitv-and-jump (p-test-bitv-and-jump-okp ins p)) (no-op (p-no-op-okp ins p)) (add-addr (p-add-addr-okp ins p)) (sub-addr (p-sub-addr-okp ins p)) (eq (p-eq-okp ins p)) (lt-addr (p-lt-addr-okp ins p)) (fetch (p-fetch-okp ins p)) (deposit (p-deposit-okp ins p)) (add-int (p-add-int-okp ins p)) (add-int-with-carry (p-add-int-with-carry-okp ins p)) (add1-int (p-add1-int-okp ins p)) (sub-int (p-sub-int-okp ins p)) (sub-int-with-carry (p-sub-int-with-carry-okp ins p)) (sub1-int (p-sub1-int-okp ins p)) (neg-int (p-neg-int-okp ins p)) (lt-int (p-lt-int-okp ins p)) (int-to-nat (p-int-to-nat-okp ins p)) (add-nat (p-add-nat-okp ins p)) (add-nat-with-carry (p-add-nat-with-carry-okp ins p)) (add1-nat (p-add1-nat-okp ins p)) (sub-nat (p-sub-nat-okp ins p)) (sub-nat-with-carry (p-sub-nat-with-carry-okp ins p)) (sub1-nat (p-sub1-nat-okp ins p)) (lt-nat (p-lt-nat-okp ins p)) (mult2-nat (p-mult2-nat-okp ins p)) (mult2-nat-with-carry-out (p-mult2-nat-with-carry-out-okp ins p)) (div2-nat (p-div2-nat-okp ins p)) (or-bitv (p-or-bitv-okp ins p)) (and-bitv (p-and-bitv-okp ins p)) (not-bitv (p-not-bitv-okp ins p)) (xor-bitv (p-xor-bitv-okp ins p)) (rsh-bitv (p-rsh-bitv-okp ins p)) (lsh-bitv (p-lsh-bitv-okp ins p)) (or-bool (p-or-bool-okp ins p)) (and-bool (p-and-bool-okp ins p)) (not-bool (p-not-bool-okp ins p)) (otherwise f))) ; Note: Initially I used an APPLY$ to define this function but ; that suffers because we don't track the dependency between ; p-ins-okp and p-not-bool-okp, say. Thus, if the -okp ; function for some instruction is undone and changed, ; theorems about the top-level -okp remain in the data-base, ; inconsistently. So I have abandoned the APPLY$ and define ; the function with a CASE statement. ; If ins is legal, the following function steps the state forward one. (defn p-ins-step (ins p) (case (car ins) (call (p-call-step ins p)) (ret (p-ret-step ins p)) (locn (p-locn-step ins p)) (push-constant (p-push-constant-step ins p)) (push-local (p-push-local-step ins p)) (push-global (p-push-global-step ins p)) (push-ctrl-stk-free-size (p-push-ctrl-stk-free-size-step ins p)) (push-temp-stk-free-size (p-push-temp-stk-free-size-step ins p)) (push-temp-stk-index (p-push-temp-stk-index-step ins p)) (jump-if-temp-stk-full (p-jump-if-temp-stk-full-step ins p)) (jump-if-temp-stk-empty (p-jump-if-temp-stk-empty-step ins p)) (pop (p-pop-step ins p)) (pop* (p-pop*-step ins p)) (popn (p-popn-step ins p)) (pop-local (p-pop-local-step ins p)) (pop-global (p-pop-global-step ins p)) (pop-locn (p-pop-locn-step ins p)) (pop-call (p-pop-call-step ins p)) (fetch-temp-stk (p-fetch-temp-stk-step ins p)) (deposit-temp-stk (p-deposit-temp-stk-step ins p)) (jump (p-jump-step ins p)) (jump-case (p-jump-case-step ins p)) (pushj (p-pushj-step ins p)) (popj (p-popj-step ins p)) (set-local (p-set-local-step ins p)) (set-global (p-set-global-step ins p)) (test-nat-and-jump (p-test-nat-and-jump-step ins p)) (test-int-and-jump (p-test-int-and-jump-step ins p)) (test-bool-and-jump (p-test-bool-and-jump-step ins p)) (test-bitv-and-jump (p-test-bitv-and-jump-step ins p)) (no-op (p-no-op-step ins p)) (add-addr (p-add-addr-step ins p)) (sub-addr (p-sub-addr-step ins p)) (eq (p-eq-step ins p)) (lt-addr (p-lt-addr-step ins p)) (fetch (p-fetch-step ins p)) (deposit (p-deposit-step ins p)) (add-int (p-add-int-step ins p)) (add-int-with-carry (p-add-int-with-carry-step ins p)) (add1-int (p-add1-int-step ins p)) (sub-int (p-sub-int-step ins p)) (sub-int-with-carry (p-sub-int-with-carry-step ins p)) (sub1-int (p-sub1-int-step ins p)) (neg-int (p-neg-int-step ins p)) (lt-int (p-lt-int-step ins p)) (int-to-nat (p-int-to-nat-step ins p)) (add-nat (p-add-nat-step ins p)) (add-nat-with-carry (p-add-nat-with-carry-step ins p)) (add1-nat (p-add1-nat-step ins p)) (sub-nat (p-sub-nat-step ins p)) (sub-nat-with-carry (p-sub-nat-with-carry-step ins p)) (sub1-nat (p-sub1-nat-step ins p)) (lt-nat (p-lt-nat-step ins p)) (mult2-nat (p-mult2-nat-step ins p)) (mult2-nat-with-carry-out (p-mult2-nat-with-carry-out-step ins p)) (div2-nat (p-div2-nat-step ins p)) (or-bitv (p-or-bitv-step ins p)) (and-bitv (p-and-bitv-step ins p)) (not-bitv (p-not-bitv-step ins p)) (xor-bitv (p-xor-bitv-step ins p)) (rsh-bitv (p-rsh-bitv-step ins p)) (lsh-bitv (p-lsh-bitv-step ins p)) (or-bool (p-or-bool-step ins p)) (and-bool (p-and-bool-step ins p)) (not-bool (p-not-bool-step ins p)) (otherwise (p-halt p 'run)))) ; We now package these up into a single function that takes an ; instruction and a state and returns the result of executing the ; given instruction in the state or causing an error. (defn p-step1 (ins p) (if (p-ins-okp ins p) (p-ins-step ins p) (p-halt p (x-y-error-msg 'p (car ins))))) ; Of course, we are only interested in executing the current ; instruction of a state. That is what we call stepping the state. (defn p-step (p) (if (equal (p-psw p) 'run) (p-step1 (p-current-instruction p) p) p)) ; Note that p-step is a no-op if the psw is anything besides RUN. ; And given the ability to step a state, here is how you step it n ; times. (defn p (p n) (if (zerop n) p (p (p-step p) (sub1 n)))) ; The function p, above, is the PITON machine. ; Note: In the toy version of the system I set the final psw to ; TIMED-OUT if n exhausted before an error or HALT occurred. I ; think the above defn is better because it gives us ; (p p (plus i j)) = (p (p p i) j). Consider the psw of (p p n). ; If it is 'RUN then everything worked normally and n was exhausted. ; If it is 'HALT then a top-level return occurred. ; If it is anything else, an error halted the machine. ; Note that a final psw of RUN is equivalent in this world to a ; final psw of 'TIMED-OUT in the toy one. ; The initial Piton state. We will in general be mapping down ; arbitrary Piton states. But it is convenient to have a function ; that produces an initial state. Here it is: (defn p0 (temp-stk prog-segment data-segment) (p-state '(pc (main . 0)) (push (make-p-call-frame (formal-vars (definition 'main prog-segment)) temp-stk (temp-var-dcls (definition 'main prog-segment)) '(pc (main . 0))) nil) nil prog-segment data-segment 20 20 32 'run)) ; The Icompiler ; Most of the icompiler has been defined already, in the ; icode-ins functions among the definitions of ; the P machine instruction steppers. ; With them we can generate the assembly code for a given instruction ; ins located at offset pcn in a given program. Note that we here ; include a DL that labels the basic block of icode generated ; for the instruction. The comment we ``generate'' is just the high ; level instruction being icompiled, complete with its label, if any. ; We completely ignore the Piton labels here, stripping them off with ; unlabel in every dealing with ins. We get away with this because ; every reference to a Piton label, as in a JUMP statement, is converted ; to a reference to the PC instead and we generate a label for every ; PC. (defn icode1 (ins pcn prog) (case (car ins) (call (icode-call ins pcn prog)) (ret (icode-ret ins pcn prog)) (locn (icode-locn ins pcn prog)) (push-constant (icode-push-constant ins pcn prog)) (push-local (icode-push-local ins pcn prog)) (push-global (icode-push-global ins pcn prog)) (push-ctrl-stk-free-size (icode-push-ctrl-stk-free-size ins pcn prog)) (push-temp-stk-free-size (icode-push-temp-stk-free-size ins pcn prog)) (push-temp-stk-index (icode-push-temp-stk-index ins pcn prog)) (jump-if-temp-stk-full (icode-jump-if-temp-stk-full ins pcn prog)) (jump-if-temp-stk-empty (icode-jump-if-temp-stk-empty ins pcn prog)) (pop (icode-pop ins pcn prog)) (pop* (icode-pop* ins pcn prog)) (popn (icode-popn ins pcn prog)) (pop-local (icode-pop-local ins pcn prog)) (pop-global (icode-pop-global ins pcn prog)) (pop-locn (icode-pop-locn ins pcn prog)) (pop-call (icode-pop-call ins pcn prog)) (fetch-temp-stk (icode-fetch-temp-stk ins pcn prog)) (deposit-temp-stk (icode-deposit-temp-stk ins pcn prog)) (jump (icode-jump ins pcn prog)) (jump-case (icode-jump-case ins pcn prog)) (pushj (icode-pushj ins pcn prog)) (popj (icode-popj ins pcn prog)) (set-local (icode-set-local ins pcn prog)) (set-global (icode-set-global ins pcn prog)) (test-nat-and-jump (icode-test-nat-and-jump ins pcn prog)) (test-int-and-jump (icode-test-int-and-jump ins pcn prog)) (test-bool-and-jump (icode-test-bool-and-jump ins pcn prog)) (test-bitv-and-jump (icode-test-bitv-and-jump ins pcn prog)) (no-op (icode-no-op ins pcn prog)) (add-addr (icode-add-addr ins pcn prog)) (sub-addr (icode-sub-addr ins pcn prog)) (eq (icode-eq ins pcn prog)) (lt-addr (icode-lt-addr ins pcn prog)) (fetch (icode-fetch ins pcn prog)) (deposit (icode-deposit ins pcn prog)) (add-int (icode-add-int ins pcn prog)) (add-int-with-carry (icode-add-int-with-carry ins pcn prog)) (add1-int (icode-add1-int ins pcn prog)) (sub-int (icode-sub-int ins pcn prog)) (sub-int-with-carry (icode-sub-int-with-carry ins pcn prog)) (sub1-int (icode-sub1-int ins pcn prog)) (neg-int (icode-neg-int ins pcn prog)) (lt-int (icode-lt-int ins pcn prog)) (int-to-nat (icode-int-to-nat ins pcn prog)) (add-nat (icode-add-nat ins pcn prog)) (add-nat-with-carry (icode-add-nat-with-carry ins pcn prog)) (add1-nat (icode-add1-nat ins pcn prog)) (sub-nat (icode-sub-nat ins pcn prog)) (sub-nat-with-carry (icode-sub-nat-with-carry ins pcn prog)) (sub1-nat (icode-sub1-nat ins pcn prog)) (lt-nat (icode-lt-nat ins pcn prog)) (mult2-nat (icode-mult2-nat ins pcn prog)) (mult2-nat-with-carry-out (icode-mult2-nat-with-carry-out ins pcn prog)) (div2-nat (icode-div2-nat ins pcn prog)) (or-bitv (icode-or-bitv ins pcn prog)) (and-bitv (icode-and-bitv ins pcn prog)) (not-bitv (icode-not-bitv ins pcn prog)) (xor-bitv (icode-xor-bitv ins pcn prog)) (rsh-bitv (icode-rsh-bitv ins pcn prog)) (lsh-bitv (icode-lsh-bitv ins pcn prog)) (or-bool (icode-or-bool ins pcn prog)) (and-bool (icode-and-bool ins pcn prog)) (not-bool (icode-not-bool ins pcn prog)) (otherwise '((error))))) ; Note that if the opcode of ins is unrecognized we lay down an erroneous ; opcode, error. The I-level machine halts with psw 'error on ; this instruction. (defn dl-block (lab comment block) (cons (dl lab comment (car block)) (cdr block))) (defn icode (ins pcn program) (dl-block (cons (name program) pcn) ins (icode1 (unlabel ins) pcn program))) ; To icompile the body of a procedure we walk through the list of ; instructions in it, appending together the result of assembling ; each. We increment the pcn on each step. (defn icompile-program-body (lst pcn program) (if (nlistp lst) nil (append (icode (car lst) pcn program) (icompile-program-body (cdr lst) (add1 pcn) program)))) ; To icompile a program we sandwich the icompiled body between the prelude ; and postlude. (defn icompile-program (program) (cons (name program) (append (generate-prelude program) (append (icompile-program-body (program-body program) 0 program) (generate-postlude program))))) ; The assembling of a system of programs is done by assembling each ; program in isolation. (defn icompile (programs) (if (nlistp programs) nil (cons (icompile-program (car programs)) (icompile (cdr programs))))) ; Proper P states ; I begin by defining what a proper piton program is, by defining ; what a proper piton instruction is, for each type of instruction. ; In the definitions below, ins is an instruction that occurs in ; the program named name in the p-state p. Despite the fact that ; this notion of proper takes a p-state, I shall prove that it is ; invariant under execution. (defn proper-p-call-instructionp (ins name p) (and (equal (length ins) 2) (definedp (cadr ins) (p-prog-segment p)))) (defn proper-p-ret-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-locn-instructionp (ins name p) (and (equal (length ins) 2) (member (cadr ins) (local-vars (definition name (p-prog-segment p)))))) (defn proper-p-push-constant-instructionp (ins name p) (and (equal (length ins) 2) (or (p-objectp (cadr ins) p) (equal (cadr ins) 'pc) (find-labelp (cadr ins) (program-body (definition name (p-prog-segment p))))))) (defn proper-p-push-local-instructionp (ins name p) (and (equal (length ins) 2) (member (cadr ins) (local-vars (definition name (p-prog-segment p)))))) (defn proper-p-push-global-instructionp (ins name p) (and (equal (length ins) 2) (definedp (cadr ins) (p-data-segment p)))) (defn proper-p-push-ctrl-stk-free-size-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-push-temp-stk-free-size-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-push-temp-stk-index-instructionp (ins name p) (and (equal (length ins) 2) (small-naturalp (cadr ins) (p-word-size p)))) (defn proper-p-jump-if-temp-stk-full-instructionp (ins name p) (and (equal (length ins) 2) (find-labelp (cadr ins) (program-body (definition name (p-prog-segment p)))))) (defn proper-p-jump-if-temp-stk-empty-instructionp (ins name p) (and (equal (length ins) 2) (find-labelp (cadr ins) (program-body (definition name (p-prog-segment p)))))) (defn proper-p-pop-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-pop*-instructionp (ins name p) (and (equal (length ins) 2) (small-naturalp (cadr ins) (p-word-size p)))) (defn proper-p-popn-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-pop-local-instructionp (ins name p) (and (equal (length ins) 2) (member (cadr ins) (local-vars (definition name (p-prog-segment p)))))) (defn proper-p-pop-global-instructionp (ins name p) (and (equal (length ins) 2) (definedp (cadr ins) (p-data-segment p)))) (defn proper-p-pop-locn-instructionp (ins name p) (and (equal (length ins) 2) (member (cadr ins) (local-vars (definition name (p-prog-segment p)))))) (defn proper-p-pop-call-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-fetch-temp-stk-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-deposit-temp-stk-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-jump-instructionp (ins name p) (and (equal (length ins) 2) (find-labelp (cadr ins) (program-body (definition name (p-prog-segment p)))))) (defn proper-p-jump-case-instructionp (ins name p) (and (listp (cdr ins)) (all-find-labelp (cdr ins) (program-body (definition name (p-prog-segment p)))))) (defn proper-p-pushj-instructionp (ins name p) (and (equal (length ins) 2) (find-labelp (cadr ins) (program-body (definition name (p-prog-segment p)))))) (defn proper-p-popj-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-set-local-instructionp (ins name p) (and (equal (length ins) 2) (member (cadr ins) (local-vars (definition name (p-prog-segment p)))))) (defn proper-p-set-global-instructionp (ins name p) (and (equal (length ins) 2) (definedp (cadr ins) (p-data-segment p)))) (defn proper-p-test-nat-and-jump-instructionp (ins name p) (and (equal (length ins) 3) (find-labelp (caddr ins) (program-body (definition name (p-prog-segment p)))))) (defn proper-p-test-int-and-jump-instructionp (ins name p) (and (equal (length ins) 3) (find-labelp (caddr ins) (program-body (definition name (p-prog-segment p)))))) (defn proper-p-test-bool-and-jump-instructionp (ins name p) (and (equal (length ins) 3) (find-labelp (caddr ins) (program-body (definition name (p-prog-segment p)))))) (defn proper-p-test-bitv-and-jump-instructionp (ins name p) (and (equal (length ins) 3) (find-labelp (caddr ins) (program-body (definition name (p-prog-segment p)))))) (defn proper-p-no-op-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-add-addr-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-sub-addr-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-eq-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-lt-addr-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-fetch-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-deposit-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-add-int-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-add-int-with-carry-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-add1-int-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-sub-int-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-sub-int-with-carry-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-sub1-int-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-neg-int-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-lt-int-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-int-to-nat-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-add-nat-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-add-nat-with-carry-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-add1-nat-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-sub-nat-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-sub-nat-with-carry-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-sub1-nat-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-lt-nat-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-mult2-nat-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-mult2-nat-with-carry-out-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-div2-nat-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-or-bitv-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-and-bitv-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-not-bitv-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-xor-bitv-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-rsh-bitv-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-lsh-bitv-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-or-bool-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-and-bool-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-not-bool-instructionp (ins name p) (equal (length ins) 1)) (defn proper-p-instructionp (ins name p) (and (plistp ins) ; Was properp AF (case (car ins) (call (proper-p-call-instructionp ins name p)) (ret (proper-p-ret-instructionp ins name p)) (locn (proper-p-locn-instructionp ins name p)) (push-constant (proper-p-push-constant-instructionp ins name p)) (push-local (proper-p-push-local-instructionp ins name p)) (push-global (proper-p-push-global-instructionp ins name p)) (push-ctrl-stk-free-size (proper-p-push-ctrl-stk-free-size-instructionp ins name p)) (push-temp-stk-free-size (proper-p-push-temp-stk-free-size-instructionp ins name p)) (push-temp-stk-index (proper-p-push-temp-stk-index-instructionp ins name p)) (jump-if-temp-stk-full (proper-p-jump-if-temp-stk-full-instructionp ins name p)) (jump-if-temp-stk-empty (proper-p-jump-if-temp-stk-empty-instructionp ins name p)) (pop (proper-p-pop-instructionp ins name p)) (pop* (proper-p-pop*-instructionp ins name p)) (popn (proper-p-popn-instructionp ins name p)) (pop-local (proper-p-pop-local-instructionp ins name p)) (pop-global (proper-p-pop-global-instructionp ins name p)) (pop-locn (proper-p-pop-locn-instructionp ins name p)) (pop-call (proper-p-pop-call-instructionp ins name p)) (fetch-temp-stk (proper-p-fetch-temp-stk-instructionp ins name p)) (deposit-temp-stk (proper-p-deposit-temp-stk-instructionp ins name p)) (jump (proper-p-jump-instructionp ins name p)) (jump-case (proper-p-jump-case-instructionp ins name p)) (pushj (proper-p-pushj-instructionp ins name p)) (popj (proper-p-popj-instructionp ins name p)) (set-local (proper-p-set-local-instructionp ins name p)) (set-global (proper-p-set-global-instructionp ins name p)) (test-nat-and-jump (proper-p-test-nat-and-jump-instructionp ins name p)) (test-int-and-jump (proper-p-test-int-and-jump-instructionp ins name p)) (test-bool-and-jump (proper-p-test-bool-and-jump-instructionp ins name p)) (test-bitv-and-jump (proper-p-test-bitv-and-jump-instructionp ins name p)) (no-op (proper-p-no-op-instructionp ins name p)) (add-addr (proper-p-add-addr-instructionp ins name p)) (sub-addr (proper-p-sub-addr-instructionp ins name p)) (eq (proper-p-eq-instructionp ins name p)) (lt-addr (proper-p-lt-addr-instructionp ins name p)) (fetch (proper-p-fetch-instructionp ins name p)) (deposit (proper-p-deposit-instructionp ins name p)) (add-int (proper-p-add-int-instructionp ins name p)) (add-int-with-carry (proper-p-add-int-with-carry-instructionp ins name p)) (add1-int (proper-p-add1-int-instructionp ins name p)) (sub-int (proper-p-sub-int-instructionp ins name p)) (sub-int-with-carry (proper-p-sub-int-with-carry-instructionp ins name p)) (sub1-int (proper-p-sub1-int-instructionp ins name p)) (neg-int (proper-p-neg-int-instructionp ins name p)) (lt-int (proper-p-lt-int-instructionp ins name p)) (int-to-nat (proper-p-int-to-nat-instructionp ins name p)) (add-nat (proper-p-add-nat-instructionp ins name p)) (add-nat-with-carry (proper-p-add-nat-with-carry-instructionp ins name p)) (add1-nat (proper-p-add1-nat-instructionp ins name p)) (sub-nat (proper-p-sub-nat-instructionp ins name p)) (sub-nat-with-carry (proper-p-sub-nat-with-carry-instructionp ins name p)) (sub1-nat (proper-p-sub1-nat-instructionp ins name p)) (lt-nat (proper-p-lt-nat-instructionp ins name p)) (mult2-nat (proper-p-mult2-nat-instructionp ins name p)) (mult2-nat-with-carry-out (proper-p-mult2-nat-with-carry-out-instructionp ins name p)) (div2-nat (proper-p-div2-nat-instructionp ins name p)) (or-bitv (proper-p-or-bitv-instructionp ins name p)) (and-bitv (proper-p-and-bitv-instructionp ins name p)) (not-bitv (proper-p-not-bitv-instructionp ins name p)) (xor-bitv (proper-p-xor-bitv-instructionp ins name p)) (rsh-bitv (proper-p-rsh-bitv-instructionp ins name p)) (lsh-bitv (proper-p-lsh-bitv-instructionp ins name p)) (or-bool (proper-p-or-bool-instructionp ins name p)) (and-bool (proper-p-and-bool-instructionp ins name p)) (not-bool (proper-p-not-bool-instructionp ins name p)) (otherwise f)))) (defn legal-labelp (ins) (implies (labelledp ins) (litatom (cadr ins)))) ; The following predicate recognizes lists of properly labeled ; proper instructions. (defn proper-labeled-p-instructionsp (lst name p) (if (nlistp lst) (equal lst nil) (and (legal-labelp (car lst)) (proper-p-instructionp (unlabel (car lst)) name p) (proper-labeled-p-instructionsp (cdr lst) name p)))) ; A list is fall-off proof if it is not possible for execution to ; fall off the end. We shall prove that if a list is fall-off proof ; and you are at an instruction other than one of those listed below, ; then add1-p-pcp is ok. (defn fall-off-proofp (lst) (member (car (unlabel (get (sub1 (length lst)) lst))) '(ret jump jump-case popj))) (defn proper-p-program-bodyp (lst name p) (and (listp lst) (proper-labeled-p-instructionsp lst name p) (fall-off-proofp lst))) (defn all-litatoms (lst) (if (nlistp lst) (equal lst nil) (and (litatom (car lst)) (all-litatoms (cdr lst))))) (defn proper-p-temp-var-dclsp (temp-var-dcls p) (if (nlistp temp-var-dcls) t (and (litatom (car (car temp-var-dcls))) (p-objectp (cadr (car temp-var-dcls)) p) (proper-p-temp-var-dclsp (cdr temp-var-dcls) p)))) (defn proper-p-programp (prog p) (and (litatom (name prog)) (all-litatoms (formal-vars prog)) (proper-p-temp-var-dclsp (temp-var-dcls prog) p) (proper-p-program-bodyp (program-body prog) (name prog) p))) (defn proper-p-prog-segmentp (segment p) (if (nlistp segment) (equal segment nil) (and (proper-p-programp (car segment) p) (proper-p-prog-segmentp (cdr segment) p)))) (defn proper-p-alistp (alist p) (if (nlistp alist) (equal alist nil) (and (listp (car alist)) (litatom (caar alist)) (p-objectp (cdr (car alist)) p) (proper-p-alistp (cdr alist) p)))) (defn proper-p-framep (frame name p) (and (listp frame) (listp (cdr frame)) (equal (cddr frame) nil) (proper-p-alistp (bindings frame) p) (equal (strip-cars (bindings frame)) (local-vars (definition name (p-prog-segment p)))) (p-objectp-type 'pc (ret-pc frame) p))) (defn proper-p-ctrl-stkp (ctrl-stk name p) (if (nlistp ctrl-stk) (equal ctrl-stk nil) (and (proper-p-framep (top ctrl-stk) name p) (proper-p-ctrl-stkp (pop ctrl-stk) (area-name (ret-pc (top ctrl-stk))) p))) ((lessp (count ctrl-stk)))) (defn proper-p-temp-stkp (temp-stk p) (if (nlistp temp-stk) (equal temp-stk nil) (and (p-objectp (top temp-stk) p) (proper-p-temp-stkp (pop temp-stk) p))) ((lessp (count temp-stk)))) (defn proper-p-area (area p) (and (litatom (car area)) (listp (cdr area)) (all-p-objectps (cdr area) p))) (defn proper-p-data-segmentp (data-segment p) (if (nlistp data-segment) (equal data-segment nil) (and (proper-p-area (car data-segment) p) (not (definedp (caar data-segment) (cdr data-segment))) (proper-p-data-segmentp (cdr data-segment) p)))) ; Below is the definition of proper P state. Intuitively, ; a proper p state has the following properties: ; (1) it is a p-state shell; ; (2) the pc is a legal address into the program segment; ; (3) the ctrl stack is non-empty; ; (4) the top frame of the ctrl stack is appropriate for ; the current pc, which means the locals of that program ; are bound to legal objects and the ret-pc is legal; ; (5) the rest of the ctrl stack is properly structured; ; (6) the ctrl stack isn't too large; ; (7) the temp stack contains legal objects; ; (8) the temp stack isn't too large; ; (9) the prog segment contains programs of the form ; (name formal-vars temp-var-dcls . body) -- see proper-prog-segment; ;(10) the data segment contains non-empty areas consisting ; of legal objects; ;(11) the resource limitations are all numeric; ;(12) the stack sizes are less than 2**word-size -- this insures that ; the stack free sizes and indices are all representable ;(13) the word size is not 0. This insures that lsh and other bitv ; operations are well-defined (bitv's are non-empty). ; It is supposed to be the case that if p is proper and stepping p to ; p' does not produce an error then p' is proper. (defn proper-p-statep (p) (and (p-statep p) (p-objectp-type 'pc (p-pc p) p) (listp (p-ctrl-stk p)) (proper-p-framep (top (p-ctrl-stk p)) (area-name (p-pc p)) p) (proper-p-ctrl-stkp (pop (p-ctrl-stk p)) (area-name (ret-pc (top (p-ctrl-stk p)))) p) (not (lessp (p-max-ctrl-stk-size p) (p-ctrl-stk-size (p-ctrl-stk p)))) (proper-p-temp-stkp (p-temp-stk p) p) (not (lessp (p-max-temp-stk-size p) (length (p-temp-stk p)))) (proper-p-prog-segmentp (p-prog-segment p) p) (proper-p-data-segmentp (p-data-segment p) p) (numberp (p-max-ctrl-stk-size p)) (numberp (p-max-temp-stk-size p)) (numberp (p-word-size p)) (lessp (p-max-ctrl-stk-size p) (exp 2 (p-word-size p))) (lessp (p-max-temp-stk-size p) (exp 2 (p-word-size p))) (lessp 0 (p-word-size p)))) ; We also define the predicate that checks that a state is loadable on ; FM8502. This is not technically part of the Piton definition but ; rather concerned with the implementation. (defn segment-length (segment) (if (nlistp segment) 0 (plus (length (cdr (car segment))) (segment-length (cdr segment))))) (defn total-p-system-size (p) (plus (segment-length (icompile (p-prog-segment p))) (segment-length (p-data-segment p)) (add1 (p-max-ctrl-stk-size p)) (add1 (p-max-temp-stk-size p)) 3)) (defn p-loadablep (p) (lessp (total-p-system-size p) (exp 2 (p-word-size p)))) ; Examples of P and the Icompiler ; We are now ready to test the foregoing definitions. (defn display-p-state (p) (list 'p-state (p-pc p) (list 'nxt-inst (p-current-instruction p)) (list 'bindings (bindings (top (p-ctrl-stk p)))) (list 'temp-stk (p-temp-stk p)) (list 'data-seg (p-data-segment p)) (list 'psw (p-psw p)) (list 'ret-pc (ret-pc (top (p-ctrl-stk p)))) (list 'pop-ctrl-stk (pop (p-ctrl-stk p))))) (defn augment-displayed-p-state (p p0) (p-state (assoc 'pc (cdr p)) (push (p-frame (cadr (assoc 'bindings (cdr p))) (cadr (assoc 'ret-pc (cdr p)))) (cadr (assoc 'pop-ctrl-stk (cdr p)))) (cadr (assoc 'temp-stk (cdr p))) (p-prog-segment p0) (cadr (assoc 'data-seg (cdr p))) (p-max-ctrl-stk-size p0) (p-max-temp-stk-size p0) (p-word-size p0) (cadr (assoc 'psw (cdr p))))) (defn ps (p n p0) (display-p-state (p (augment-displayed-p-state p p0) n))) ; display-p-state abbreviates the given p state, showing just those ; components that change and showing them in the order I find convenient. ; augment-displayed-p-state takes a displayed state and ``the'' original ; one and constructs a new state whose display is the given state. ; Really it just takes the dynamic information in the displayed state ; and merges it with the static information in the original state. ; The effect of the foregoing defns is that we can use r-loop conveniently ; to step through p computations. In particular, in r-loop ; (setq p0 (p-state ...)) ; (setq p (display-p-state p0)) ; then repeatedly type ; (setq p (ps p 1 p0)) ; to single step from p0 and see each state in its displayed form. ; Here is a p state. We call this p0 in our subsequent examples. #| (quote (p-state '(pc (main . 0)) '( ( nil (pc (main . 0))) ) nil '((main nil nil (call test) (ret)) (test nil nil (push-constant (addr (ar1 . 0))) (push-constant (nat 4)) (call clear) (ret)) (clear (array max-index) ((ptr (nat 0))) (push-local array) (push-local max-index) (add-addr) (pop-local ptr) (dl loop (this is the top level loop we deposit 0 into ptr test to see if ptr is array and if not decrement ptr and repeat) (push-constant (nat 0))) (push-local ptr) (deposit) (push-local ptr) (push-local array) (eq) (test-bool-and-jump t end) (push-local ptr) (push-constant (nat 1)) (sub-addr) (pop-local ptr) (jump loop) (dl end (we get here when ptr is array) (ret)))) '((ar1 (nat 10) (nat 11) (nat 12) (nat 13) (nat 14))) 12 7 8 'run)) |# (defn signature (area) (cons (car area) (length area))) (defn same-signature (segment1 segment2) (if (listp segment1) (and (listp segment2) (equal (signature (car segment1)) (signature (car segment2))) (same-signature (cdr segment1) (cdr segment2))) (nlistp segment2))) ;; ***** End stuff from defs.events ***** ;; Now some other lemmas from Piton. The ones that are easy to prove (i.e. ;; do not depend on other lemmas) we prove, the rest are added as axioms. ;; The following is from p-r.events ; I will disable type, tag and untag for sanity's sake, ; but prove the obvious relationships first. (prove-lemma type-tag (rewrite) (equal (type (tag x y)) x)) (prove-lemma untag-tag (rewrite) (equal (untag (tag x y)) y)) (prove-lemma equal-tags (rewrite) (equal (equal (tag type x) (tag type y)) (equal x y))) (prove-lemma cddr-tag (rewrite) (equal (cddr (tag type obj)) nil)) (disable type) (disable tag) (disable untag) ; Error messages are irrelevant as long as they are not 'run or 'halt. (prove-lemma not-equal-x-y-error-msg-run (rewrite) (not (equal (x-y-error-msg x y) 'run))) (prove-lemma not-equal-x-y-error-msg-halt (rewrite) (not (equal (x-y-error-msg x y) 'halt))) (disable x-y-error-msg) (prove-lemma p-objectp-opener (rewrite) (and (implies (equal (type x) 'nat) (equal (p-objectp x p) (and (equal (cddr x) nil) (small-naturalp (untag x) (p-word-size p))))) (implies (equal (type x) 'int) (equal (p-objectp x p) (and (equal (cddr x) nil) (small-integerp (untag x) (p-word-size p))))) (implies (equal (type x) 'bitv) (equal (p-objectp x p) (and (equal (cddr x) nil) (bit-vectorp (untag x) (p-word-size p))))) (implies (equal (type x) 'bool) (equal (p-objectp x p) (and (equal (cddr x) nil) (booleanp (untag x))))) (implies (equal (type x) 'addr) (equal (p-objectp x p) (and (equal (cddr x) nil) (adpp (untag x) (p-data-segment p))))) (implies (equal (type x) 'pc) (equal (p-objectp x p) (and (equal (cddr x) nil) (pcpp (untag x) (p-prog-segment p))))) (implies (equal (type x) 'subr) (equal (p-objectp x p) (and (equal (cddr x) nil) (definedp (untag x) (p-prog-segment p))))))) (disable p-objectp) (disable name) (disable formal-vars) (disable temp-var-dcls) (disable program-body) (prove-lemma bindings-p-frame (rewrite) (equal (bindings (p-frame alist pc)) alist)) (prove-lemma ret-pc-p-frame (rewrite) (equal (ret-pc (p-frame alist pc)) pc)) (disable bindings) (disable ret-pc) (disable p-frame) (disable proper-p-instructionp) (disable legal-labelp) (prove-lemma proper-labeled-p-instructionsp-implies-labelp-and-instructionp nil (implies (and (proper-labeled-p-instructionsp lst name p) (member x lst)) (and (legal-labelp x) (proper-p-instructionp (unlabel x) name p))) ((disable legal-labelp ; Added disable to speed up proof, AF proper-p-instructionp))) (prove-lemma proper-p-prog-segmentp-implies-proper-p-programp nil (implies (and (proper-p-prog-segmentp segment p) (member prog segment)) (proper-p-programp prog p)) ((disable proper-p-programp))) ; Added disable to speed up proof, AF (prove-lemma member-assoc (rewrite) (implies (definedp name alist) (member (assoc name alist) alist))) (prove-lemma name-assoc (rewrite) (implies (definedp name alist) (equal (name (assoc name alist)) name)) ((enable name))) (prove-lemma member-get (rewrite) (implies (lessp n (length lst)) (member (get n lst) lst))) (prove-lemma proper-p-statep-implies-proper-p-instructionp nil (implies (and (proper-p-prog-segmentp (p-prog-segment p) p) (definedp (car (untag (p-pc p))) (p-prog-segment p)) (lessp (cdr (untag (p-pc p))) (length (program-body (assoc (car (untag (p-pc p))) (p-prog-segment p)))))) (proper-p-instructionp (p-current-instruction p) (car (untag (p-pc p))) p)) ((use (proper-p-prog-segmentp-implies-proper-p-programp (segment (p-prog-segment p)) (prog (assoc (car (untag (p-pc p))) (p-prog-segment p)))) (proper-labeled-p-instructionsp-implies-labelp-and-instructionp (lst (program-body (assoc (car (untag (p-pc p))) (p-prog-segment p)))) (name (car (untag (p-pc p)))) (x (get (cdr (untag (p-pc p))) (program-body (assoc (car (untag (p-pc p))) (p-prog-segment p))))))))) ; Now I restructure proper-p-statep into two parts, those that ; have to do with arithmetic and those that do not. The parts ; that do not are arithmetic, I confine to proper-p-statep1, ; which I keep closed and backchain into as needed. The other ; parts I keep out in the open. In addition, I throw in the ; proper-p-instructionp proved above, essentially forward ; chaining through the lemma. (disable p-loadablep) (defn proper-p-statep1 (p) (and (p-statep p) (equal (type (p-pc p)) 'pc) (listp (p-pc p)) (equal (cddr (p-pc p)) nil) (listp (untag (p-pc p))) (definedp (car (untag (p-pc p))) (p-prog-segment p)) (listp (p-ctrl-stk p)) (listp (car (p-ctrl-stk p))) (listp (cdr (car (p-ctrl-stk p)))) (equal (cddr (car (p-ctrl-stk p))) nil) (proper-p-alistp (bindings (car (p-ctrl-stk p))) p) (equal (strip-cars (bindings (car (p-ctrl-stk p)))) (append (formal-vars (assoc (car (untag (p-pc p))) (p-prog-segment p))) (strip-cars (temp-var-dcls (assoc (car (untag (p-pc p))) (p-prog-segment p)))))) (equal (type (ret-pc (car (p-ctrl-stk p)))) 'pc) (listp (ret-pc (car (p-ctrl-stk p)))) (equal (cddr (ret-pc (car (p-ctrl-stk p)))) nil) (listp (untag (ret-pc (car (p-ctrl-stk p))))) (definedp (car (untag (ret-pc (car (p-ctrl-stk p))))) (p-prog-segment p)) (proper-p-ctrl-stkp (cdr (p-ctrl-stk p)) (car (untag (ret-pc (car (p-ctrl-stk p))))) p) (proper-p-temp-stkp (p-temp-stk p) p) (proper-p-prog-segmentp (p-prog-segment p) p) (proper-p-data-segmentp (p-data-segment p) p))) (prove-lemma proper-p-statep-restructuring (rewrite) (equal (proper-p-statep p) (and (proper-p-statep1 p) (numberp (cdr (untag (p-pc p)))) (lessp (cdr (untag (p-pc p))) (length (program-body (assoc (car (untag (p-pc p))) (p-prog-segment p))))) (numberp (cdr (untag (ret-pc (car (p-ctrl-stk p)))))) (lessp (cdr (untag (ret-pc (car (p-ctrl-stk p))))) (length (program-body (assoc (car (untag (ret-pc (car (p-ctrl-stk p))))) (p-prog-segment p))))) (not (lessp (p-max-ctrl-stk-size p) (p-ctrl-stk-size (p-ctrl-stk p)))) (not (lessp (p-max-temp-stk-size p) (length (p-temp-stk p)))) (numberp (p-max-ctrl-stk-size p)) (numberp (p-max-temp-stk-size p)) (numberp (p-word-size p)) (lessp (p-max-ctrl-stk-size p) (exp 2 (p-word-size p))) (lessp (p-max-temp-stk-size p) (exp 2 (p-word-size p))) (lessp 0 (p-word-size p)) (proper-p-instructionp (p-current-instruction p) (car (untag (p-pc p))) p))) ((use (proper-p-statep-implies-proper-p-instructionp)))) (prove-lemma proper-p-statep1-properties (rewrite) (implies (proper-p-statep1 p) (and (p-statep p) (equal (type (p-pc p)) 'pc) (listp (p-pc p)) (equal (cddr (p-pc p)) nil) (listp (untag (p-pc p))) (definedp (car (untag (p-pc p))) (p-prog-segment p)) (listp (p-ctrl-stk p)) (listp (car (p-ctrl-stk p))) (listp (cdr (car (p-ctrl-stk p)))) (equal (cddr (car (p-ctrl-stk p))) nil) (proper-p-alistp (bindings (car (p-ctrl-stk p))) p) (equal (strip-cars (bindings (car (p-ctrl-stk p)))) (append (formal-vars (assoc (car (untag (p-pc p))) (p-prog-segment p))) (strip-cars (temp-var-dcls (assoc (car (untag (p-pc p))) (p-prog-segment p)))))) (equal (type (ret-pc (car (p-ctrl-stk p)))) 'pc) (listp (ret-pc (car (p-ctrl-stk p)))) (equal (cddr (ret-pc (car (p-ctrl-stk p)))) nil) (listp (untag (ret-pc (car (p-ctrl-stk p))))) (definedp (car (untag (ret-pc (car (p-ctrl-stk p))))) (p-prog-segment p)) (proper-p-ctrl-stkp (cdr (p-ctrl-stk p)) (car (untag (ret-pc (car (p-ctrl-stk p))))) p) (proper-p-temp-stkp (p-temp-stk p) p) (proper-p-prog-segmentp (p-prog-segment p) p) (proper-p-data-segmentp (p-data-segment p) p)))) (disable proper-p-statep) (disable proper-p-statep1) (disable p-current-instruction) ; Now I provide a simple delayed opener for proper-p-instructionp: (prove-lemma proper-p-instructionp-opener (rewrite) (implies (equal (car ins) (pack xxx)) (equal (proper-p-instructionp ins name p) (and (plistp ins) ; Was (properp ins) AF (case (car ins) (call (proper-p-call-instructionp ins name p)) (ret (proper-p-ret-instructionp ins name p)) (locn (proper-p-locn-instructionp ins name p)) (push-constant (proper-p-push-constant-instructionp ins name p)) (push-local (proper-p-push-local-instructionp ins name p)) (push-global (proper-p-push-global-instructionp ins name p)) (push-ctrl-stk-free-size (proper-p-push-ctrl-stk-free-size-instructionp ins name p)) (push-temp-stk-free-size (proper-p-push-temp-stk-free-size-instructionp ins name p)) (push-temp-stk-index (proper-p-push-temp-stk-index-instructionp ins name p)) (jump-if-temp-stk-full (proper-p-jump-if-temp-stk-full-instructionp ins name p)) (jump-if-temp-stk-empty (proper-p-jump-if-temp-stk-empty-instructionp ins name p)) (pop (proper-p-pop-instructionp ins name p)) (pop* (proper-p-pop*-instructionp ins name p)) (popn (proper-p-popn-instructionp ins name p)) (pop-local (proper-p-pop-local-instructionp ins name p)) (pop-global (proper-p-pop-global-instructionp ins name p)) (pop-locn (proper-p-pop-locn-instructionp ins name p)) (pop-call (proper-p-pop-call-instructionp ins name p)) (fetch-temp-stk (proper-p-fetch-temp-stk-instructionp ins name p)) (deposit-temp-stk (proper-p-deposit-temp-stk-instructionp ins name p)) (jump (proper-p-jump-instructionp ins name p)) (jump-case (proper-p-jump-case-instructionp ins name p)) (pushj (proper-p-pushj-instructionp ins name p)) (popj (proper-p-popj-instructionp ins name p)) (set-local (proper-p-set-local-instructionp ins name p)) (set-global (proper-p-set-global-instructionp ins name p)) (test-nat-and-jump (proper-p-test-nat-and-jump-instructionp ins name p)) (test-int-and-jump (proper-p-test-int-and-jump-instructionp ins name p)) (test-bool-and-jump (proper-p-test-bool-and-jump-instructionp ins name p)) (test-bitv-and-jump (proper-p-test-bitv-and-jump-instructionp ins name p)) (no-op (proper-p-no-op-instructionp ins name p)) (add-addr (proper-p-add-addr-instructionp ins name p)) (sub-addr (proper-p-sub-addr-instructionp ins name p)) (eq (proper-p-eq-instructionp ins name p)) (lt-addr (proper-p-lt-addr-instructionp ins name p)) (fetch (proper-p-fetch-instructionp ins name p)) (deposit (proper-p-deposit-instructionp ins name p)) (add-int (proper-p-add-int-instructionp ins name p)) (add-int-with-carry (proper-p-add-int-with-carry-instructionp ins name p)) (add1-int (proper-p-add1-int-instructionp ins name p)) (sub-int (proper-p-sub-int-instructionp ins name p)) (sub-int-with-carry (proper-p-sub-int-with-carry-instructionp ins name p)) (sub1-int (proper-p-sub1-int-instructionp ins name p)) (neg-int (proper-p-neg-int-instructionp ins name p)) (lt-int (proper-p-lt-int-instructionp ins name p)) (int-to-nat (proper-p-int-to-nat-instructionp ins name p)) (add-nat (proper-p-add-nat-instructionp ins name p)) (add-nat-with-carry (proper-p-add-nat-with-carry-instructionp ins name p)) (add1-nat (proper-p-add1-nat-instructionp ins name p)) (sub-nat (proper-p-sub-nat-instructionp ins name p)) (sub-nat-with-carry (proper-p-sub-nat-with-carry-instructionp ins name p)) (sub1-nat (proper-p-sub1-nat-instructionp ins name p)) (lt-nat (proper-p-lt-nat-instructionp ins name p)) (mult2-nat (proper-p-mult2-nat-instructionp ins name p)) (mult2-nat-with-carry-out (proper-p-mult2-nat-with-carry-out-instructionp ins name p)) (div2-nat (proper-p-div2-nat-instructionp ins name p)) (or-bitv (proper-p-or-bitv-instructionp ins name p)) (and-bitv (proper-p-and-bitv-instructionp ins name p)) (not-bitv (proper-p-not-bitv-instructionp ins name p)) (xor-bitv (proper-p-xor-bitv-instructionp ins name p)) (rsh-bitv (proper-p-rsh-bitv-instructionp ins name p)) (lsh-bitv (proper-p-lsh-bitv-instructionp ins name p)) (or-bool (proper-p-or-bool-instructionp ins name p)) (and-bool (proper-p-and-bool-instructionp ins name p)) (not-bool (proper-p-not-bool-instructionp ins name p)) (otherwise f))))) ((enable proper-p-instructionp) (disable proper-p-call-instructionp proper-p-ret-instructionp proper-p-locn-instructionp proper-p-push-constant-instructionp proper-p-push-local-instructionp proper-p-push-global-instructionp proper-p-push-ctrl-stk-free-size-instructionp proper-p-push-temp-stk-free-size-instructionp proper-p-push-temp-stk-index-instructionp proper-p-jump-if-temp-stk-full-instructionp proper-p-jump-if-temp-stk-empty-instructionp proper-p-pop-instructionp proper-p-pop*-instructionp proper-p-popn-instructionp proper-p-pop-local-instructionp proper-p-pop-global-instructionp proper-p-pop-locn-instructionp proper-p-pop-call-instructionp proper-p-fetch-temp-stk-instructionp proper-p-deposit-temp-stk-instructionp proper-p-jump-instructionp proper-p-jump-case-instructionp proper-p-pushj-instructionp proper-p-popj-instructionp proper-p-set-local-instructionp proper-p-set-global-instructionp proper-p-test-nat-and-jump-instructionp proper-p-test-int-and-jump-instructionp proper-p-test-bool-and-jump-instructionp proper-p-test-bitv-and-jump-instructionp proper-p-no-op-instructionp proper-p-add-addr-instructionp proper-p-sub-addr-instructionp proper-p-eq-instructionp proper-p-lt-addr-instructionp proper-p-fetch-instructionp proper-p-deposit-instructionp proper-p-add-int-instructionp proper-p-add-int-with-carry-instructionp proper-p-add1-int-instructionp proper-p-sub-int-instructionp proper-p-sub-int-with-carry-instructionp proper-p-sub1-int-instructionp proper-p-neg-int-instructionp proper-p-lt-int-instructionp proper-p-int-to-nat-instructionp proper-p-add-nat-instructionp proper-p-add-nat-with-carry-instructionp proper-p-add1-nat-instructionp proper-p-sub-nat-instructionp proper-p-sub-nat-with-carry-instructionp proper-p-sub1-nat-instructionp proper-p-lt-nat-instructionp proper-p-mult2-nat-instructionp proper-p-mult2-nat-with-carry-out-instructionp proper-p-div2-nat-instructionp proper-p-or-bitv-instructionp proper-p-and-bitv-instructionp proper-p-not-bitv-instructionp proper-p-xor-bitv-instructionp proper-p-rsh-bitv-instructionp proper-p-lsh-bitv-instructionp proper-p-or-bool-instructionp proper-p-and-bool-instructionp proper-p-not-bool-instructionp))) (prove-lemma length-put-assoc (rewrite) (equal (length (put-assoc val name alist)) (length alist))) (prove-lemma assoc-put-assoc-1 (rewrite) (implies (not (equal name1 name2)) (equal (assoc name1 (put-assoc val name2 alist)) (assoc name1 alist)))) (prove-lemma assoc-put-assoc-2 (rewrite) (implies (definedp name alist) (equal (assoc name (put-assoc val name alist)) (cons name val)))) ;; The original lemma SAME-SIGNATURE-PUT-ASSOC-1 had the DEFINEDP ;; term below in it. It is not necessary so I commented it out. -- AF (prove-lemma same-signature-put-assoc-1 (rewrite) (implies (and ;(definedp name segment1) (litatom name) (equal (length val) (length (value name segment1)))) (equal (same-signature (put-assoc val name segment1) segment2) (same-signature segment1 segment2)))) ;; The original lemma SAME-SIGNATURE-PUT-ASSOC-2 had the DEFINEDP ;; term below in it. It is not necessary so I commented it out. -- AF (prove-lemma same-signature-put-assoc-2 (rewrite) (implies (and ;(definedp name segment2) (litatom name) (equal (length val) (length (value name segment2)))) (equal (same-signature segment1 (put-assoc val name segment2)) (same-signature segment1 segment2)))) (disable same-signature) ; Now I want to disable get and put so that they are only manipulated by ; the lemmas we have proved. (disable get) (disable put) (prove-lemma length-first-n (rewrite) (equal (length (first-n n x)) (fix n))) (prove-lemma same-signature-implies-equal-lengths (rewrite) (implies (same-signature segment1 segment2) (equal (length (cdr (assoc name segment1))) (length (cdr (assoc name segment2))))) ((enable same-signature))) (prove-lemma same-signature-implies-equal-definedp (rewrite) (implies (same-signature segment1 segment2) (equal (definedp name segment1) (definedp name segment2))) ((enable same-signature))) (prove-lemma same-signature-reflexive-generalized (rewrite) (same-signature segment segment) ((enable same-signature))) (prove-lemma definedp-put-assoc (rewrite) (equal (definedp name1 (put-assoc val name2 alist)) (definedp name1 alist))) (prove-lemma p-objectp-type-opener (rewrite) (and (equal (p-objectp-type 'nat x p) (and (equal (type x) 'nat) (equal (cddr x) nil) (small-naturalp (untag x) (p-word-size p)))) (equal (p-objectp-type 'int x p) (and (equal (type x) 'int) (equal (cddr x) nil) (small-integerp (untag x) (p-word-size p)))) (equal (p-objectp-type 'bitv x p) (and (equal (type x) 'bitv) (equal (cddr x) nil) (bit-vectorp (untag x) (p-word-size p)))) (equal (p-objectp-type 'bool x p) (and (equal (type x) 'bool) (equal (cddr x) nil) (booleanp (untag x)))) (equal (p-objectp-type 'addr x p) (and (equal (type x) 'addr) (equal (cddr x) nil) (adpp (untag x) (p-data-segment p)))) (equal (p-objectp-type 'pc x p) (and (equal (type x) 'pc) (equal (cddr x) nil) (pcpp (untag x) (p-prog-segment p)))) (equal (p-objectp-type 'subr x p) (and (equal (type x) 'subr) (equal (cddr x) nil) (definedp (untag x) (p-prog-segment p))))) ;; I don't know how this lemma was proven without the below enable. -- AF ((enable p-objectp))) (disable p-objectp-type) ;; This is from Piton but with PROPERP instead of PLISTP (prove-lemma proper-p-alistp-append (rewrite) (implies (plistp a) ; (properp a) (equal (proper-p-alistp (append a b) p) (and (proper-p-alistp a p) (proper-p-alistp b p))))) (prove-lemma strip-cars-put-assoc (rewrite) (equal (strip-cars (put-assoc val var alist)) (strip-cars alist))) ; So after the rule is applied, we have to prove two proper-p-alistps. ; The first is for the pairlist of the formals to the actuals. ; The second is for the initialization of the temp vars. ; The first is handled by: (prove-lemma proper-p-alistp-pairlist (rewrite) (implies (and (all-litatoms formals) (all-p-objectps actuals p) (equal (length formals) (length actuals))) (proper-p-alistp (pairlist formals actuals) p))) ; where the hypotheses above are relieved as follows. The all-litatoms ; of the formals is derived from proper-p-prog-segmentp: (prove-lemma all-litatoms-formal-vars-generalized nil (implies (and (proper-p-prog-segmentp segment p) (definedp name segment)) (all-litatoms (formal-vars (assoc name segment)))) ((enable proper-p-programp proper-p-program-bodyp))) (prove-lemma all-litatoms-formal-vars (rewrite) (implies (and (proper-p-prog-segmentp (p-prog-segment p) p) (definedp name (p-prog-segment p))) (all-litatoms (formal-vars (assoc name (p-prog-segment p))))) ((use (all-litatoms-formal-vars-generalized (segment (p-prog-segment p)))))) ; The third hypothesis of the pairlist lemma above is that the lengths of ; the formals and actuals are the same. That follows from what we've ; already proved. ; Now we move to the second proper-p-alistp task, namely, for the ; initialization of the temp vars. That is handled by: (prove-lemma proper-p-prog-segmentp-implies-proper-p-temp-var-dclsp (rewrite) (implies (and (proper-p-prog-segmentp segment p) (definedp name segment)) (proper-p-temp-var-dclsp (temp-var-dcls (assoc name segment)) p)) ((enable proper-p-programp proper-p-program-bodyp))) (prove-lemma proper-p-alistp-pair-temps-with-initial-values (rewrite) (implies (proper-p-temp-var-dclsp var-dcls p) (proper-p-alistp (pair-temps-with-initial-values var-dcls) p))) (disable p-call-okp) (disable p-call-step) (disable p-ret-okp) (disable p-ret-step) (disable p-locn-okp) (disable p-locn-step) (disable p-push-constant-okp) (disable p-push-constant-step) (disable p-push-local-okp) (disable p-push-local-step) (disable p-push-global-okp) (disable p-push-global-step) (disable p-push-ctrl-stk-free-size-okp) (disable p-push-ctrl-stk-free-size-step) (disable p-push-temp-stk-free-size-okp) (disable p-push-temp-stk-free-size-step) (disable p-push-temp-stk-index-okp) (disable p-push-temp-stk-index-step) (disable p-jump-if-temp-stk-full-okp) (disable p-jump-if-temp-stk-full-step) (disable p-jump-if-temp-stk-empty-okp) (disable p-jump-if-temp-stk-empty-step) (disable p-pop-okp) (disable p-pop-step) (disable p-pop*-okp) (disable p-pop*-step) (disable p-popn-okp) (disable p-popn-step) (disable p-pop-local-okp) (disable p-pop-local-step) (disable p-pop-global-okp) (disable p-pop-global-step) (disable p-pop-locn-okp) (disable p-pop-locn-step) (disable p-pop-call-okp) (disable p-pop-call-step) (disable p-fetch-temp-stk-okp) (disable p-fetch-temp-stk-step) (disable p-deposit-temp-stk-okp) (disable p-deposit-temp-stk-step) (disable p-jump-okp) (disable p-jump-step) (disable p-jump-case-okp) (disable p-jump-case-step) (disable p-pushj-okp) (disable p-pushj-step) (disable p-popj-okp) (disable p-popj-step) (disable p-set-local-okp) (disable p-set-local-step) (disable p-set-global-okp) (disable p-set-global-step) (disable p-test-nat-and-jump-okp) (disable p-test-nat-and-jump-step) (disable p-test-int-and-jump-okp) (disable p-test-int-and-jump-step) (disable p-test-bool-and-jump-okp) (disable p-test-bool-and-jump-step) (disable p-test-bitv-and-jump-okp) (disable p-test-bitv-and-jump-step) (disable p-no-op-okp) (disable p-no-op-step) (disable p-add-addr-okp) (disable p-add-addr-step) (disable p-sub-addr-okp) (disable p-sub-addr-step) (disable p-eq-okp) (disable p-eq-step) (disable p-lt-addr-okp) (disable p-lt-addr-step) (disable p-fetch-okp) (disable p-fetch-step) (disable p-deposit-okp) (disable p-deposit-step) (disable p-add-int-okp) (disable p-add-int-step) (disable p-add-int-with-carry-okp) (disable p-add-int-with-carry-step) (disable p-add1-int-okp) (disable p-add1-int-step) (disable p-sub-int-okp) (disable p-sub-int-step) (disable p-sub-int-with-carry-okp) (disable p-sub-int-with-carry-step) (disable p-sub1-int-okp) (disable p-sub1-int-step) (disable p-neg-int-okp) (disable p-neg-int-step) (disable p-lt-int-okp) (disable p-lt-int-step) (disable p-int-to-nat-okp) (disable p-int-to-nat-step) (disable p-add-nat-okp) (disable p-add-nat-step) (disable p-add-nat-with-carry-okp) (disable p-add-nat-with-carry-step) (disable p-add1-nat-okp) (disable p-add1-nat-step) (disable p-sub-nat-okp) (disable p-sub-nat-step) (disable p-sub-nat-with-carry-okp) (disable p-sub-nat-with-carry-step) (disable p-sub1-nat-okp) (disable p-sub1-nat-step) (disable p-lt-nat-okp) (disable p-lt-nat-step) (disable p-mult2-nat-okp) (disable p-mult2-nat-step) (disable p-mult2-nat-with-carry-out-okp) (disable p-mult2-nat-with-carry-out-step) (disable p-div2-nat-okp) (disable p-div2-nat-step) (disable p-or-bitv-okp) (disable p-or-bitv-step) (disable p-and-bitv-okp) (disable p-and-bitv-step) (disable p-not-bitv-okp) (disable p-not-bitv-step) (disable p-xor-bitv-okp) (disable p-xor-bitv-step) (disable p-rsh-bitv-okp) (disable p-rsh-bitv-step) (disable p-lsh-bitv-okp) (disable p-lsh-bitv-step) (disable p-or-bool-okp) (disable p-or-bool-step) (disable p-and-bool-okp) (disable p-and-bool-step) (disable p-not-bool-okp) (disable p-not-bool-step) (defn p-ins-okp2 (ins p) (case (car ins) (eq (p-eq-okp ins p)) (lt-addr (p-lt-addr-okp ins p)) (fetch (p-fetch-okp ins p)) (deposit (p-deposit-okp ins p)) (add-int (p-add-int-okp ins p)) (add-int-with-carry (p-add-int-with-carry-okp ins p)) (add1-int (p-add1-int-okp ins p)) (sub-int (p-sub-int-okp ins p)) (sub-int-with-carry (p-sub-int-with-carry-okp ins p)) (sub1-int (p-sub1-int-okp ins p)) (neg-int (p-neg-int-okp ins p)) (lt-int (p-lt-int-okp ins p)) (int-to-nat (p-int-to-nat-okp ins p)) (add-nat (p-add-nat-okp ins p)) (add-nat-with-carry (p-add-nat-with-carry-okp ins p)) (add1-nat (p-add1-nat-okp ins p)) (sub-nat (p-sub-nat-okp ins p)) (sub-nat-with-carry (p-sub-nat-with-carry-okp ins p)) (sub1-nat (p-sub1-nat-okp ins p)) (lt-nat (p-lt-nat-okp ins p)) (mult2-nat (p-mult2-nat-okp ins p)) (mult2-nat-with-carry-out (p-mult2-nat-with-carry-out-okp ins p)) (div2-nat (p-div2-nat-okp ins p)) (or-bitv (p-or-bitv-okp ins p)) (and-bitv (p-and-bitv-okp ins p)) (not-bitv (p-not-bitv-okp ins p)) (xor-bitv (p-xor-bitv-okp ins p)) (rsh-bitv (p-rsh-bitv-okp ins p)) (lsh-bitv (p-lsh-bitv-okp ins p)) (or-bool (p-or-bool-okp ins p)) (and-bool (p-and-bool-okp ins p)) (not-bool (p-not-bool-okp ins p)) (otherwise f))) (defn p-ins-okp1 (ins p) (case (car ins) (call (p-call-okp ins p)) (ret (p-ret-okp ins p)) (locn (p-locn-okp ins p)) (push-constant (p-push-constant-okp ins p)) (push-local (p-push-local-okp ins p)) (push-global (p-push-global-okp ins p)) (push-ctrl-stk-free-size (p-push-ctrl-stk-free-size-okp ins p)) (push-temp-stk-free-size (p-push-temp-stk-free-size-okp ins p)) (push-temp-stk-index (p-push-temp-stk-index-okp ins p)) (jump-if-temp-stk-full (p-jump-if-temp-stk-full-okp ins p)) (jump-if-temp-stk-empty (p-jump-if-temp-stk-empty-okp ins p)) (pop (p-pop-okp ins p)) (pop* (p-pop*-okp ins p)) (popn (p-popn-okp ins p)) (pop-local (p-pop-local-okp ins p)) (pop-global (p-pop-global-okp ins p)) (pop-locn (p-pop-locn-okp ins p)) (pop-call (p-pop-call-okp ins p)) (fetch-temp-stk (p-fetch-temp-stk-okp ins p)) (deposit-temp-stk (p-deposit-temp-stk-okp ins p)) (jump (p-jump-okp ins p)) (jump-case (p-jump-case-okp ins p)) (pushj (p-pushj-okp ins p)) (popj (p-popj-okp ins p)) (set-local (p-set-local-okp ins p)) (set-global (p-set-global-okp ins p)) (test-nat-and-jump (p-test-nat-and-jump-okp ins p)) (test-int-and-jump (p-test-int-and-jump-okp ins p)) (test-bool-and-jump (p-test-bool-and-jump-okp ins p)) (test-bitv-and-jump (p-test-bitv-and-jump-okp ins p)) (no-op (p-no-op-okp ins p)) (add-addr (p-add-addr-okp ins p)) (sub-addr (p-sub-addr-okp ins p)) (otherwise (p-ins-okp2 ins p)))) (prove-lemma p-ins-okp-is-p-ins-okp1 (rewrite) (equal (p-ins-okp ins p) (p-ins-okp1 ins p))) (disable p-ins-okp) (disable p-ins-okp-is-p-ins-okp1) (defn p-ins-step2 (ins p) (case (car ins) (eq (p-eq-step ins p)) (lt-addr (p-lt-addr-step ins p)) (fetch (p-fetch-step ins p)) (deposit (p-deposit-step ins p)) (add-int (p-add-int-step ins p)) (add-int-with-carry (p-add-int-with-carry-step ins p)) (add1-int (p-add1-int-step ins p)) (sub-int (p-sub-int-step ins p)) (sub-int-with-carry (p-sub-int-with-carry-step ins p)) (sub1-int (p-sub1-int-step ins p)) (neg-int (p-neg-int-step ins p)) (lt-int (p-lt-int-step ins p)) (int-to-nat (p-int-to-nat-step ins p)) (add-nat (p-add-nat-step ins p)) (add-nat-with-carry (p-add-nat-with-carry-step ins p)) (add1-nat (p-add1-nat-step ins p)) (sub-nat (p-sub-nat-step ins p)) (sub-nat-with-carry (p-sub-nat-with-carry-step ins p)) (sub1-nat (p-sub1-nat-step ins p)) (lt-nat (p-lt-nat-step ins p)) (mult2-nat (p-mult2-nat-step ins p)) (mult2-nat-with-carry-out (p-mult2-nat-with-carry-out-step ins p)) (div2-nat (p-div2-nat-step ins p)) (or-bitv (p-or-bitv-step ins p)) (and-bitv (p-and-bitv-step ins p)) (not-bitv (p-not-bitv-step ins p)) (xor-bitv (p-xor-bitv-step ins p)) (rsh-bitv (p-rsh-bitv-step ins p)) (lsh-bitv (p-lsh-bitv-step ins p)) (or-bool (p-or-bool-step ins p)) (and-bool (p-and-bool-step ins p)) (not-bool (p-not-bool-step ins p)) (otherwise (p-halt p 'run)))) (defn p-ins-step1 (ins p) (case (car ins) (call (p-call-step ins p)) (ret (p-ret-step ins p)) (locn (p-locn-step ins p)) (push-constant (p-push-constant-step ins p)) (push-local (p-push-local-step ins p)) (push-global (p-push-global-step ins p)) (push-ctrl-stk-free-size (p-push-ctrl-stk-free-size-step ins p)) (push-temp-stk-free-size (p-push-temp-stk-free-size-step ins p)) (push-temp-stk-index (p-push-temp-stk-index-step ins p)) (jump-if-temp-stk-full (p-jump-if-temp-stk-full-step ins p)) (jump-if-temp-stk-empty (p-jump-if-temp-stk-empty-step ins p)) (pop (p-pop-step ins p)) (pop* (p-pop*-step ins p)) (popn (p-popn-step ins p)) (pop-local (p-pop-local-step ins p)) (pop-global (p-pop-global-step ins p)) (pop-locn (p-pop-locn-step ins p)) (pop-call (p-pop-call-step ins p)) (fetch-temp-stk (p-fetch-temp-stk-step ins p)) (deposit-temp-stk (p-deposit-temp-stk-step ins p)) (jump (p-jump-step ins p)) (jump-case (p-jump-case-step ins p)) (pushj (p-pushj-step ins p)) (popj (p-popj-step ins p)) (set-local (p-set-local-step ins p)) (set-global (p-set-global-step ins p)) (test-nat-and-jump (p-test-nat-and-jump-step ins p)) (test-int-and-jump (p-test-int-and-jump-step ins p)) (test-bool-and-jump (p-test-bool-and-jump-step ins p)) (test-bitv-and-jump (p-test-bitv-and-jump-step ins p)) (no-op (p-no-op-step ins p)) (add-addr (p-add-addr-step ins p)) (sub-addr (p-sub-addr-step ins p)) (otherwise (p-ins-step2 ins p)))) (prove-lemma p-ins-step-is-p-ins-step1 (rewrite) (equal (p-ins-step ins p) (p-ins-step1 ins p))) (disable p-ins-step) (disable p-ins-step-is-p-ins-step1) ; We disable p-ins-okp because the main owc theorem involves p-ins-okp ; and p-ins-step, and opening either is sufficient to drive the case ; analysis. If both open, then we get cross-multiplied cases and ; there is a lot of silly propositional work to do. So we arbitrarily ; choose to keep p-ins-okp disabled. Now we could choose to rewrite ; it to p-xxx-okp when the car of ins is 'xxx, analogously to what we ; did for r-ins-okp above. But the proof of the owc should be faster ; if we do this: keep p-ins-okp disabled and show that p-xxx-okp holds ; if the car of ins is 'xxx. The reason is that when we fire the ; xxx-one-way-correspondence-p-r lemma we will want to get p-xxx-okp ; and we'll be governed by a p-ins-okp and a hyp about car ins. But ; the hyp about car ins won't have been raised all the way to the top ; and so won't yet be available to tell the p-ins-okp which way to go. ; This is the same strategy used for r-ins-okp in the r-i level proof. (prove-lemma p-ins-okp2-backchainer (rewrite) (implies (p-ins-okp2 ins p) (and (implies (equal (car ins) 'eq) (p-eq-okp ins p)) (implies (equal (car ins) 'lt-addr) (p-lt-addr-okp ins p)) (implies (equal (car ins) 'fetch) (p-fetch-okp ins p)) (implies (equal (car ins) 'deposit) (p-deposit-okp ins p)) (implies (equal (car ins) 'add-int) (p-add-int-okp ins p)) (implies (equal (car ins) 'add-int-with-carry) (p-add-int-with-carry-okp ins p)) (implies (equal (car ins) 'add1-int) (p-add1-int-okp ins p)) (implies (equal (car ins) 'sub-int) (p-sub-int-okp ins p)) (implies (equal (car ins) 'sub-int-with-carry) (p-sub-int-with-carry-okp ins p)) (implies (equal (car ins) 'sub1-int) (p-sub1-int-okp ins p)) (implies (equal (car ins) 'neg-int) (p-neg-int-okp ins p)) (implies (equal (car ins) 'lt-int) (p-lt-int-okp ins p)) (implies (equal (car ins) 'int-to-nat) (p-int-to-nat-okp ins p)) (implies (equal (car ins) 'add-nat) (p-add-nat-okp ins p)) (implies (equal (car ins) 'add-nat-with-carry) (p-add-nat-with-carry-okp ins p)) (implies (equal (car ins) 'add1-nat) (p-add1-nat-okp ins p)) (implies (equal (car ins) 'sub-nat) (p-sub-nat-okp ins p)) (implies (equal (car ins) 'sub-nat-with-carry) (p-sub-nat-with-carry-okp ins p)) (implies (equal (car ins) 'sub1-nat) (p-sub1-nat-okp ins p)) (implies (equal (car ins) 'lt-nat) (p-lt-nat-okp ins p)) (implies (equal (car ins) 'mult2-nat) (p-mult2-nat-okp ins p)) (implies (equal (car ins) 'mult2-nat-with-carry-out) (p-mult2-nat-with-carry-out-okp ins p)) (implies (equal (car ins) 'div2-nat) (p-div2-nat-okp ins p)) (implies (equal (car ins) 'or-bitv) (p-or-bitv-okp ins p)) (implies (equal (car ins) 'and-bitv) (p-and-bitv-okp ins p)) (implies (equal (car ins) 'not-bitv) (p-not-bitv-okp ins p)) (implies (equal (car ins) 'xor-bitv) (p-xor-bitv-okp ins p)) (implies (equal (car ins) 'rsh-bitv) (p-rsh-bitv-okp ins p)) (implies (equal (car ins) 'lsh-bitv) (p-lsh-bitv-okp ins p)) (implies (equal (car ins) 'or-bool) (p-or-bool-okp ins p)) (implies (equal (car ins) 'and-bool) (p-and-bool-okp ins p)) (implies (equal (car ins) 'not-bool) (p-not-bool-okp ins p))))) (disable p-ins-okp2) (prove-lemma p-ins-okp-backchainer (rewrite) (implies (p-ins-okp ins p) (and (implies (equal (car ins) 'call) (p-call-okp ins p)) (implies (equal (car ins) 'ret) (p-ret-okp ins p)) (implies (equal (car ins) 'locn) (p-locn-okp ins p)) (implies (equal (car ins) 'push-constant) (p-push-constant-okp ins p)) (implies (equal (car ins) 'push-local) (p-push-local-okp ins p)) (implies (equal (car ins) 'push-global) (p-push-global-okp ins p)) (implies (equal (car ins) 'push-ctrl-stk-free-size) (p-push-ctrl-stk-free-size-okp ins p)) (implies (equal (car ins) 'push-temp-stk-free-size) (p-push-temp-stk-free-size-okp ins p)) (implies (equal (car ins) 'push-temp-stk-index) (p-push-temp-stk-index-okp ins p)) (implies (equal (car ins) 'jump-if-temp-stk-full) (p-jump-if-temp-stk-full-okp ins p)) (implies (equal (car ins) 'jump-if-temp-stk-empty) (p-jump-if-temp-stk-empty-okp ins p)) (implies (equal (car ins) 'pop) (p-pop-okp ins p)) (implies (equal (car ins) 'pop*) (p-pop*-okp ins p)) (implies (equal (car ins) 'popn) (p-popn-okp ins p)) (implies (equal (car ins) 'pop-local) (p-pop-local-okp ins p)) (implies (equal (car ins) 'pop-global) (p-pop-global-okp ins p)) (implies (equal (car ins) 'pop-locn) (p-pop-locn-okp ins p)) (implies (equal (car ins) 'pop-call) (p-pop-call-okp ins p)) (implies (equal (car ins) 'fetch-temp-stk) (p-fetch-temp-stk-okp ins p)) (implies (equal (car ins) 'deposit-temp-stk) (p-deposit-temp-stk-okp ins p)) (implies (equal (car ins) 'jump) (p-jump-okp ins p)) (implies (equal (car ins) 'jump-case) (p-jump-case-okp ins p)) (implies (equal (car ins) 'pushj) (p-pushj-okp ins p)) (implies (equal (car ins) 'popj) (p-popj-okp ins p)) (implies (equal (car ins) 'set-local) (p-set-local-okp ins p)) (implies (equal (car ins) 'set-global) (p-set-global-okp ins p)) (implies (equal (car ins) 'test-nat-and-jump) (p-test-nat-and-jump-okp ins p)) (implies (equal (car ins) 'test-int-and-jump) (p-test-int-and-jump-okp ins p)) (implies (equal (car ins) 'test-bool-and-jump) (p-test-bool-and-jump-okp ins p)) (implies (equal (car ins) 'test-bitv-and-jump) (p-test-bitv-and-jump-okp ins p)) (implies (equal (car ins) 'no-op) (p-no-op-okp ins p)) (implies (equal (car ins) 'add-addr) (p-add-addr-okp ins p)) (implies (equal (car ins) 'sub-addr) (p-sub-addr-okp ins p)))) ((enable p-ins-okp-is-p-ins-okp1 p-ins-okp1))) ; The only problem with these backchainers is that we don't know that the ; above cases are exhaustive. That is, suppose the current instruction ; is none of the above. Then p-ins-okp is false. We need to know that. ; The most natural expression of this fact is that if the instruction ; is not call and not ret and, etc., then p-ins-okp is false. But that ; is an inefficient way to hang it, because every time we see p-ins-okp ; we'll try to show the instruction is none of the above and most of the time ; it will be one of the ones listed half-way through the list. So we'll ; hang it on one of the instructions! It reads: if p-ins-okp is true ; and the instruction is not call, not ret, etc., then the instruction ; is 'not-bool, except we split it into two lemmas. (prove-lemma p-ins-okp-exhausted (rewrite) (implies (and (p-ins-okp ins p) (not (equal (car ins) 'call)) (not (equal (car ins) 'ret)) (not (equal (car ins) 'locn)) (not (equal (car ins) 'push-constant)) (not (equal (car ins) 'push-local)) (not (equal (car ins) 'push-global)) (not (equal (car ins) 'push-ctrl-stk-free-size)) (not (equal (car ins) 'push-temp-stk-free-size)) (not (equal (car ins) 'push-temp-stk-index)) (not (equal (car ins) 'jump-if-temp-stk-full)) (not (equal (car ins) 'jump-if-temp-stk-empty)) (not (equal (car ins) 'pop)) (not (equal (car ins) 'pop*)) (not (equal (car ins) 'popn)) (not (equal (car ins) 'pop-local)) (not (equal (car ins) 'pop-global)) (not (equal (car ins) 'pop-locn)) (not (equal (car ins) 'pop-call)) (not (equal (car ins) 'fetch-temp-stk)) (not (equal (car ins) 'deposit-temp-stk)) (not (equal (car ins) 'jump)) (not (equal (car ins) 'jump-case)) (not (equal (car ins) 'pushj)) (not (equal (car ins) 'popj)) (not (equal (car ins) 'set-local)) (not (equal (car ins) 'set-global)) (not (equal (car ins) 'test-nat-and-jump)) (not (equal (car ins) 'test-int-and-jump)) (not (equal (car ins) 'test-bool-and-jump)) (not (equal (car ins) 'test-bitv-and-jump)) (not (equal (car ins) 'no-op)) (not (equal (car ins) 'add-addr)) (not (equal (car ins) 'sub-addr))) (p-ins-okp2 ins p)) ((enable p-ins-okp-is-p-ins-okp1 p-ins-okp1))) (prove-lemma p-ins-okp2-exhausted (rewrite) (implies (and (p-ins-okp2 ins p) (not (equal (car ins) 'eq)) (not (equal (car ins) 'lt-addr)) (not (equal (car ins) 'fetch)) (not (equal (car ins) 'deposit)) (not (equal (car ins) 'add-int)) (not (equal (car ins) 'add-int-with-carry)) (not (equal (car ins) 'add1-int)) (not (equal (car ins) 'sub-int)) (not (equal (car ins) 'sub-int-with-carry)) (not (equal (car ins) 'sub1-int)) (not (equal (car ins) 'neg-int)) (not (equal (car ins) 'lt-int)) (not (equal (car ins) 'int-to-nat)) (not (equal (car ins) 'add-nat)) (not (equal (car ins) 'add-nat-with-carry)) (not (equal (car ins) 'add1-nat)) (not (equal (car ins) 'sub-nat)) (not (equal (car ins) 'sub-nat-with-carry)) (not (equal (car ins) 'sub1-nat)) (not (equal (car ins) 'lt-nat)) (not (equal (car ins) 'mult2-nat)) (not (equal (car ins) 'mult2-nat-with-carry-out)) (not (equal (car ins) 'div2-nat)) (not (equal (car ins) 'or-bitv)) (not (equal (car ins) 'and-bitv)) (not (equal (car ins) 'not-bitv)) (not (equal (car ins) 'xor-bitv)) (not (equal (car ins) 'rsh-bitv)) (not (equal (car ins) 'lsh-bitv)) (not (equal (car ins) 'or-bool)) (not (equal (car ins) 'and-bool))) (equal (equal (car ins) 'not-bool) t)) ((enable p-ins-okp2))) (disable p-ins-step2) (prove-lemma transitivity-of-same-signature (rewrite) (implies (and (same-signature segment1 segment2) (same-signature segment2 segment3)) (same-signature segment1 segment3)) ((enable same-signature))) ;; ***** End stuff from p-r.events ***** ;; The next two lemmas are from big-add.events by J Moore. (prove-lemma p-opener (rewrite) (and (equal (p s 0) s) (equal (p (p-state pc ctrl temp prog data max-ctrl max-temp word-size psw) (add1 n)) (p (p-step (p-state pc ctrl temp prog data max-ctrl max-temp word-size psw)) n))) ((disable p-step))) (disable p-opener) (disable p) (prove-lemma p-step1-opener (rewrite) (equal (p-step1 (cons opcode operands) p) (if (p-ins-okp (cons opcode operands) p) (p-ins-step (cons opcode operands) p) (p-halt p (x-y-error-msg 'p opcode)))) ((disable p-ins-okp p-ins-step x-y-error-msg))) (disable p-step1-opener) (disable p-step1) ;; ***** End stuff from big-add.events ***** (disable same-signature-implies-equal-lengths) (disable same-signature-implies-equal-definedp) (disable transitivity-of-same-signature) ;; The following axioms are proven in Piton (in p-r). (add-axiom p-step-preserves-proper-p-statep (rewrite) (implies (and (proper-p-statep p) (not (errorp (p-psw (p-step p))))) (proper-p-statep (p-step p)))) (add-axiom once-errorp-always-errorp-step (rewrite) (implies (not (errorp (p-psw (p-step p)))) (not (errorp (p-psw p))))) (add-axiom once-errorp-always-errorp (rewrite) (implies (not (errorp (p-psw (p p n)))) (not (errorp (p-psw p)))) ;((disable p-step)) ) (add-axiom p-preserves-proper-p-statep (rewrite) (implies (and (proper-p-statep p) (not (errorp (p-psw (p p n))))) (proper-p-statep (p p n)))) ;; ***** End axioms proven in p-r.events ***** ;; The following lemmas are NOT proven in Piton. (defn p-invariant1 (p0 p1) (and (equal (p-prog-segment p0) (p-prog-segment p1)) (equal (p-max-ctrl-stk-size p0) (p-max-ctrl-stk-size p1)) (equal (p-max-temp-stk-size p0) (p-max-temp-stk-size p1)) (equal (p-word-size p0) (p-word-size p1)))) (defn p-invariant (p0 p1) (and (same-signature (p-data-segment p0) (p-data-segment p1)) (p-invariant1 p0 p1))) (prove-lemma p-invariant-opener (rewrite) (equal (p-invariant (p-state pc ctrl-stk temp-stk (p-prog-segment p) data-seg (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) psw) p) (same-signature data-seg (p-data-segment p)))) (prove-lemma p-invariant1-opener (rewrite) (p-invariant1 (p-state pc ctrl-stk temp-stk (p-prog-segment p) data-seg (p-max-ctrl-stk-size p) (p-max-temp-stk-size p) (p-word-size p) psw) p)) (disable p-invariant) (disable p-invariant1) ;; It will be easier later to no that the p-prog-segment and the 3 resource ;; limitations p-max-ctrl-stk-size, p-max-temp-stk-size and p-word-size ;; never change. It is nice to not have to check the run flag. We could ;; probably prove that if we have a PROPER-P-STATEP that these are invariant ;; but we get nicer rewrite rules later (at the lr level anyway) if we ;; do not have to assume that. (prove-lemma no-op-preserves-p-invariant (rewrite) (implies (equal (car ins) 'no-op) (p-invariant (p-no-op-step ins p) p)) ((enable p-no-op-step))) (prove-lemma push-global-preserves-p-invariant (rewrite) (implies (equal (car ins) 'push-global) (p-invariant (p-push-global-step ins p) p)) ((enable p-push-global-step))) ;; The following is inspired by the lemma length-put of Piton. (prove-lemma my-length-put (rewrite) (equal (length (put val n lst)) (if (lessp n (length lst)) (length lst) (add1 n))) ((enable put))) (disable my-length-put) (prove-lemma proper-p-statep-proper-implies-proper-p-instructionp () (implies (proper-p-statep p) (proper-p-instructionp (p-current-instruction p) (car (untag (p-pc p))) p)) ((use (proper-p-statep-implies-proper-p-instructionp (p p))) (disable adpp area-name bit-vectorp booleanp definedp proper-p-framep small-naturalp small-integerp) (enable proper-p-statep p-objectp my-length-put))) (prove-lemma definedp-p-data-segment-implies-listp-generalized nil (implies (and (proper-p-data-segmentp segment p) (definedp name segment)) (listp (cdr (assoc name segment))))) ;; The lemma definedp-p-data-segment-implies-listp in p-r was definedp with ;; proper-p-statep1, which we don't use, so and a '-1' [so there are not ;; name conflicts] to the name and use proper-p-statep. AF (prove-lemma definedp-p-data-segment-implies-listp-1 (rewrite) (implies (and (proper-p-statep p) (definedp name (p-data-segment p))) (listp (cdr (assoc name (p-data-segment p))))) ((use (definedp-p-data-segment-implies-listp-generalized (segment (p-data-segment p)))) (enable proper-p-statep) ; Added the enable & disable. AF (disable proper-p-framep))) (disable definedp-p-data-segment-implies-listp-1) (prove-lemma definedp-p-data-segment-implies-litatom-generalized nil (implies (and (proper-p-data-segmentp segment p) (definedp name segment)) (litatom name))) (prove-lemma definedp-p-data-segment-implies-litatom () (implies (and (proper-p-statep p) (definedp name (p-data-segment p))) (litatom name)) ((use (definedp-p-data-segment-implies-litatom-generalized (segment (p-data-segment p)))) (enable proper-p-statep) (disable proper-p-framep))) (prove-lemma pop-global-preserves-p-invariant1 (rewrite) (implies (equal (car ins) 'pop-global) (p-invariant1 (p-pop-global-step ins p) p)) ((disable area-name offset p-current-program) (enable p-pop-global-step))) (prove-lemma pop-global-preserves-p-same-signature-data-segment (rewrite) (let ((new-p (p-pop-global-step (p-current-instruction p) p))) (implies (and (equal (p-psw p) 'run) (equal (car (p-current-instruction p)) 'pop-global) (proper-p-statep p) (p-pop-global-okp (p-current-instruction p) p)) (same-signature (p-data-segment new-p) (p-data-segment p)))) ((disable area-name offset p-current-program proper-p-statep-restructuring) (enable p-pop-global-okp p-pop-global-step definedp-p-data-segment-implies-listp-1) (use (proper-p-statep-proper-implies-proper-p-instructionp (p p)) (my-length-put (val (car (p-temp-stk p))) (n 0) (lst (value (cadr (p-current-instruction p)) (p-data-segment p)))) (definedp-p-data-segment-implies-litatom (p p) (name (cadr (p-current-instruction p))))))) (prove-lemma push-local-preserves-p-invariant (rewrite) (implies (equal (car ins) 'push-local) (p-invariant (p-push-local-step ins p) p)) ((enable p-push-local-step))) (prove-lemma pop-local-preserves-p-invariant (rewrite) (implies (equal (car ins) 'pop-local) (p-invariant (p-pop-local-step ins p) p)) ((enable p-pop-local-step))) (prove-lemma deposit-preserves-p-invariant1 (rewrite) (implies (equal (car ins) 'deposit) (p-invariant1 (p-deposit-step ins p) p)) ((disable area-name offset p-current-program) (enable p-deposit-step))) (prove-lemma deposit-preserves-same-signature-data-segment (rewrite) (let ((new-p (p-deposit-step (p-current-instruction p) p))) (implies (and (equal (p-psw p) 'run) (equal (car (p-current-instruction p)) 'deposit) (proper-p-statep p) (p-deposit-okp (p-current-instruction p) p)) (same-signature (p-data-segment new-p) (p-data-segment p)))) ((disable area-name bit-vectorp booleanp definedp offset p-current-program proper-p-framep small-naturalp small-integerp proper-p-statep-restructuring) (enable p-deposit-okp p-deposit-step p-objectp my-length-put) (use (proper-p-statep-proper-implies-proper-p-instructionp (p p)) (definedp-p-data-segment-implies-litatom (p p) (name (car (untag (car (p-temp-stk p))))))))) (prove-lemma add1-nat-preserves-p-invariant (rewrite) (implies (equal (car ins) 'add1-nat) (p-invariant (p-add1-nat-step ins p) p)) ((enable p-add1-nat-step))) (prove-lemma add-addr-preserves-p-invariant (rewrite) (implies (equal (car ins) 'add-addr) (p-invariant (p-add-addr-step ins p) p)) ((enable p-add-addr-step))) (prove-lemma add-nat-with-carry-preserves-p-invariant (rewrite) (implies (equal (car ins) 'add-nat-with-carry) (p-invariant (p-add-nat-with-carry-step ins p) p)) ((disable-theory addition) (disable add1-p-pc bool *1*bool bool-to-nat fix-small-natural small-naturalp) (enable p-add-nat-with-carry-step))) (prove-lemma mult2-nat-with-carry-out-preserves-p-invariant (rewrite) (implies (equal (car ins) 'mult2-nat-with-carry-out) (p-invariant (p-mult2-nat-with-carry-out-step ins p) p)) ((disable-theory addition multiplication) (disable add1-p-pc bool *1*bool fix-small-natural small-naturalp) (enable p-mult2-nat-with-carry-out-step))) (prove-lemma fetch-temp-stk-preserves-p-invariant (rewrite) (implies (equal (car ins) 'fetch-temp-stk) (p-invariant (p-fetch-temp-stk-step ins p) p)) ((enable p-fetch-temp-stk-step))) (prove-lemma deposit-temp-stk-preserves-p-invariant (rewrite) (implies (equal (car ins) 'deposit-temp-stk) (p-invariant (p-deposit-temp-stk-step ins p) p)) ((enable p-deposit-temp-stk-step))) (prove-lemma pop*-preserves-p-invariant (rewrite) (implies (equal (car ins) 'pop*) (p-invariant (p-pop*-step ins p) p)) ((enable p-pop*-step))) (prove-lemma popn-preserves-p-invariant (rewrite) (implies (equal (car ins) 'popn) (p-invariant (p-popn-step ins p) p)) ((enable p-popn-step))) ; For what it's worth, this concludes the so-called "test section" ; of instructions identified as interesting in the case of the ; one-way-correspondence proof. (prove-lemma set-local-preserves-p-invariant (rewrite) (implies (equal (car ins) 'set-local) (p-invariant (p-set-local-step ins p) p)) ((enable p-set-local-step))) (prove-lemma set-global-preserves-p-invariant1 (rewrite) (implies (equal (car ins) 'set-global) (p-invariant1 (p-set-global-step ins p) p)) ((disable area-name offset p-current-program) (enable p-set-global-step))) (prove-lemma set-global-preserves-same-signature-data-segment (rewrite) (let ((new-p (p-set-global-step (p-current-instruction p) p))) (implies (and (equal (p-psw p) 'run) (equal (car (p-current-instruction p)) 'set-global) (proper-p-statep p) (p-set-global-okp (p-current-instruction p) p)) (same-signature (p-data-segment new-p) (p-data-segment p)))) ((disable area-name offset p-current-program proper-p-statep-restructuring) (enable p-set-global-okp p-set-global-step definedp-p-data-segment-implies-listp-1) (use (proper-p-statep-proper-implies-proper-p-instructionp (p p)) (my-length-put (val (car (p-temp-stk p))) (n 0) (lst (value (cadr (p-current-instruction p)) (p-data-segment p)))) (definedp-p-data-segment-implies-litatom (p p) (name (cadr (p-current-instruction p))))))) (prove-lemma push-constant-preserves-p-invariant (rewrite) (implies (equal (car ins) 'push-constant) (p-invariant (p-push-constant-step ins p) p)) ((enable p-push-constant-step))) (prove-lemma push-ctrl-stk-free-size-preserves-p-invariant (rewrite) (implies (equal (car ins) 'push-ctrl-stk-free-size) (p-invariant (p-push-ctrl-stk-free-size-step ins p) p)) ((enable p-push-ctrl-stk-free-size-step))) (prove-lemma push-temp-stk-free-size-preserves-p-invariant (rewrite) (implies (equal (car ins) 'push-temp-stk-free-size) (p-invariant (p-push-temp-stk-free-size-step ins p) p)) ((enable p-push-temp-stk-free-size-step))) (prove-lemma push-temp-stk-index-preserves-p-invariant (rewrite) (implies (equal (car ins) 'push-temp-stk-index) (p-invariant (p-push-temp-stk-index-step ins p) p)) ((enable p-push-temp-stk-index-step))) (prove-lemma pop-preserves-p-invariant (rewrite) (implies (equal (car ins) 'pop) (p-invariant (p-pop-step ins p) p)) ((enable p-pop-step))) (prove-lemma jump-preserves-p-invariant (rewrite) (implies (equal (car ins) 'jump) (p-invariant (p-jump-step ins p) p)) ((enable p-jump-step))) (prove-lemma pushj-preserves-p-invariant (rewrite) (implies (equal (car ins) 'pushj) (p-invariant (p-pushj-step ins p) p)) ((enable p-pushj-step))) (prove-lemma popj-preserves-p-invariant (rewrite) (implies (equal (car ins) 'popj) (p-invariant (p-popj-step ins p) p)) ((enable p-popj-step))) (prove-lemma sub-addr-preserves-p-invariant (rewrite) (implies (equal (car ins) 'sub-addr) (p-invariant (p-sub-addr-step ins p) p)) ((enable p-sub-addr-step))) (prove-lemma eq-preserves-p-invariant (rewrite) (implies (equal (car ins) 'eq) (p-invariant (p-eq-step ins p) p)) ((enable p-eq-step))) (prove-lemma lt-addr-preserves-p-invariant (rewrite) (implies (equal (car ins) 'lt-addr) (p-invariant (p-lt-addr-step ins p) p)) ((enable p-lt-addr-step))) (prove-lemma fetch-preserves-p-invariant (rewrite) (implies (equal (car ins) 'fetch) (p-invariant (p-fetch-step ins p) p)) ((enable p-fetch-step))) (prove-lemma add-int-preserves-p-invariant (rewrite) (implies (equal (car ins) 'add-int) (p-invariant (p-add-int-step ins p) p)) ((enable p-add-int-step))) (prove-lemma add-int-with-carry-preserves-p-invariant (rewrite) (implies (equal (car ins) 'add-int-with-carry) (p-invariant (p-add-int-with-carry-step ins p) p)) ((disable-theory addition) (disable add1-p-pc bool *1*bool bool-to-nat fix-small-integer iplus pop push small-integerp top top1 top2 commutativity2-of-iplus commutativity-of-iplus) (enable p-add-int-with-carry-step))) (prove-lemma add1-int-preserves-p-invariant (rewrite) (implies (equal (car ins) 'add1-int) (p-invariant (p-add1-int-step ins p) p)) ((enable p-add1-int-step))) (prove-lemma sub-int-preserves-p-invariant (rewrite) (implies (equal (car ins) 'sub-int) (p-invariant (p-sub-int-step ins p) p)) ((enable p-sub-int-step))) (prove-lemma sub-int-with-carry-preserves-p-invariant (rewrite) (implies (equal (car ins) 'sub-int-with-carry) (p-invariant (p-sub-int-with-carry-step ins p) p)) ((disable-theory addition) (disable add1-p-pc bool *1*bool bool-to-nat fix-small-integer idifference iplus pop push small-integerp top top1 top2 commutativity2-of-iplus commutativity-of-iplus) (enable p-sub-int-with-carry-step))) (prove-lemma sub1-int-preserves-p-invariant (rewrite) (implies (equal (car ins) 'sub1-int) (p-invariant (p-sub1-int-step ins p) p)) ((enable p-sub1-int-step))) (prove-lemma neg-int-preserves-p-invariant (rewrite) (implies (equal (car ins) 'neg-int) (p-invariant (p-neg-int-step ins p) p)) ((enable p-neg-int-step))) (prove-lemma lt-int-preserves-p-invariant (rewrite) (implies (equal (car ins) 'lt-int) (p-invariant (p-lt-int-step ins p) p)) ((enable p-lt-int-step))) (prove-lemma int-to-nat-preserves-p-invariant (rewrite) (implies (equal (car ins) 'int-to-nat) (p-invariant (p-int-to-nat-step ins p) p)) ((enable p-int-to-nat-step))) (prove-lemma add-nat-preserves-p-invariant (rewrite) (implies (equal (car ins) 'add-nat) (p-invariant (p-add-nat-step ins p) p)) ((enable p-add-nat-step))) (prove-lemma sub-nat-preserves-p-invariant (rewrite) (implies (equal (car ins) 'sub-nat) (p-invariant (p-sub-nat-step ins p) p)) ((enable p-sub-nat-step))) (prove-lemma sub-nat-with-carry-preserves-p-invariant (rewrite) (implies (equal (car ins) 'sub-nat-with-carry) (p-invariant (p-sub-nat-with-carry-step ins p) p)) ((disable-theory addition) (disable bool *1*bool bool-to-nat difference exp plus push pop top top1 top2) (enable p-sub-nat-with-carry-step))) (prove-lemma sub1-nat-preserves-p-invariant (rewrite) (implies (equal (car ins) 'sub1-nat) (p-invariant (p-sub1-nat-step ins p) p)) ((enable p-sub1-nat-step))) (prove-lemma lt-nat-preserves-p-invariant (rewrite) (implies (equal (car ins) 'lt-nat) (p-invariant (p-lt-nat-step ins p) p)) ((enable p-lt-nat-step))) (prove-lemma mult2-nat-preserves-p-invariant (rewrite) (implies (equal (car ins) 'mult2-nat) (p-invariant (p-mult2-nat-step ins p) p)) ((enable p-mult2-nat-step))) (prove-lemma div2-nat-preserves-p-invariant (rewrite) (implies (equal (car ins) 'div2-nat) (p-invariant (p-div2-nat-step ins p) p)) ((enable p-div2-nat-step))) (prove-lemma or-bitv-preserves-p-invariant (rewrite) (implies (equal (car ins) 'or-bitv) (p-invariant (p-or-bitv-step ins p) p)) ((enable p-or-bitv-step))) (prove-lemma and-bitv-preserves-p-invariant (rewrite) (implies (equal (car ins) 'and-bitv) (p-invariant (p-and-bitv-step ins p) p)) ((enable p-and-bitv-step))) (prove-lemma not-bitv-preserves-p-invariant (rewrite) (implies (equal (car ins) 'not-bitv) (p-invariant (p-not-bitv-step ins p) p)) ((enable p-not-bitv-step))) (prove-lemma xor-bitv-preserves-p-invariant (rewrite) (implies (equal (car ins) 'xor-bitv) (p-invariant (p-xor-bitv-step ins p) p)) ((enable p-xor-bitv-step))) (prove-lemma rsh-bitv-preserves-p-invariant (rewrite) (implies (equal (car ins) 'rsh-bitv) (p-invariant (p-rsh-bitv-step ins p) p)) ((enable p-rsh-bitv-step))) (prove-lemma lsh-bitv-preserves-p-invariant (rewrite) (implies (equal (car ins) 'lsh-bitv) (p-invariant (p-lsh-bitv-step ins p) p)) ((enable p-lsh-bitv-step))) (prove-lemma or-bool-preserves-p-invariant (rewrite) (implies (equal (car ins) 'or-bool) (p-invariant (p-or-bool-step ins p) p)) ((enable p-or-bool-step))) (prove-lemma and-bool-preserves-p-invariant (rewrite) (implies (equal (car ins) 'and-bool) (p-invariant (p-and-bool-step ins p) p)) ((enable p-and-bool-step))) (prove-lemma not-bool-preserves-p-invariant (rewrite) (implies (equal (car ins) 'not-bool) (p-invariant (p-not-bool-step ins p) p)) ((enable p-not-bool-step))) (prove-lemma jump-if-temp-stk-full-preserves-p-invariant (rewrite) (implies (equal (car ins) 'jump-if-temp-stk-full) (p-invariant (p-jump-if-temp-stk-full-step ins p) p)) ((enable p-jump-if-temp-stk-full-step))) (prove-lemma jump-if-temp-stk-empty-preserves-p-invariant (rewrite) (implies (equal (car ins) 'jump-if-temp-stk-empty) (p-invariant (p-jump-if-temp-stk-empty-step ins p) p)) ((enable p-jump-if-temp-stk-empty-step))) (prove-lemma test-nat-and-jump-preserves-p-invariant (rewrite) (implies (equal (car ins) 'test-nat-and-jump) (p-invariant (p-test-nat-and-jump-step ins p) p)) ((disable-theory addition) (disable p-test-natp) (enable p-test-nat-and-jump-step))) (prove-lemma test-int-and-jump-preserves-p-invariant (rewrite) (implies (equal (car ins) 'test-int-and-jump) (p-invariant (p-test-int-and-jump-step ins p) p)) ((disable p-test-intp) (enable p-test-int-and-jump-step))) (prove-lemma test-bool-and-jump-preserves-p-invariant (rewrite) (implies (equal (car ins) 'test-bool-and-jump) (p-invariant (p-test-bool-and-jump-step ins p) p)) ((disable p-test-boolp) (enable p-test-bool-and-jump-step))) (prove-lemma test-bitv-and-jump-preserves-p-invariant (rewrite) (implies (equal (car ins) 'test-bitv-and-jump) (p-invariant (p-test-bitv-and-jump-step ins p) p)) ((disable p-test-bitvp) (enable p-test-bitv-and-jump-step))) (prove-lemma pop-locn-preserves-p-invariant (rewrite) (implies (equal (car ins) 'pop-locn) (p-invariant (p-pop-locn-step ins p) p)) ((enable p-pop-locn-step))) (prove-lemma locn-preserves-p-invariant (rewrite) (implies (equal (car ins) 'locn) (p-invariant (p-locn-step ins p) p)) ((enable p-locn-step))) (prove-lemma jump-case-preserves-p-invariant (rewrite) (implies (equal (car ins) 'jump-case) (p-invariant (p-jump-case-step ins p) p)) ((enable p-jump-case-step))) (prove-lemma call-preserves-p-invariant (rewrite) (implies (equal (car ins) 'call) (p-invariant (p-call-step ins p) p)) ((disable add1-addr definition make-p-call-frame p-call-okp push) (enable p-call-step))) (prove-lemma pop-call-preserves-p-invariant (rewrite) (implies (equal (car ins) 'pop-call) (p-invariant (p-pop-call-step ins p) p)) ((disable add1-addr definition make-p-call-frame p-call-okp push) (enable p-pop-call-step p-call-step))) (prove-lemma ret-preserves-p-invariant (rewrite) (implies (equal (car ins) 'ret) (p-invariant (p-ret-step ins p) p)) ((enable p-ret-step))) (prove-lemma p-invariant-p-invariant1 (rewrite) (implies (p-invariant p0 p1) (p-invariant1 p0 p1)) ((enable p-invariant))) (prove-lemma p-ins-step2-preserves-p-invariant1 (rewrite) (p-invariant1 (p-ins-step2 ins p) p) ((enable p-ins-okp2 p-ins-step2))) (prove-lemma p-ins-step-preserves-p-invariant1 () (p-invariant1 (p-ins-step ins p) p) ((enable p-ins-step-is-p-ins-step1 p-ins-step1))) (disable p-invariant-p-invariant1) (prove-lemma p-invariant1-reflexive (rewrite) (p-invariant1 p p) ((enable p-invariant1))) (prove-lemma p-invariant1-p-halt (rewrite) (and (equal (p-invariant1 p0 (p-halt p1 error-message)) (p-invariant1 p0 p1)) (equal (p-invariant1 (p-halt p0 error-message) p1) (p-invariant1 p0 p1))) ((enable p-invariant1))) (prove-lemma p-step-preserves-p-invariant1 (rewrite) (p-invariant1 (p-step p) p) ((use (p-ins-step-preserves-p-invariant1 (p p) (ins (p-current-instruction p)))) ;; Whoops we need to enable p-step1. (enable p-step1))) (prove-lemma transitivity-of-p-invariant1 (rewrite) (implies (and (p-invariant1 p0 p1) (p-invariant1 p1 p2)) (p-invariant1 p0 p2)) ((enable p-invariant1))) (prove-lemma p-preserves-p-invariant1 (rewrite) (p-invariant1 (p p n) p) ((induct (p p n)) (enable p) (disable p-step errorp))) (disable transitivity-of-p-invariant1) (prove-lemma p-preserves-p-resources (rewrite) (and (equal (p-prog-segment (p p n)) (p-prog-segment p)) (equal (p-max-ctrl-stk-size (p p n)) (p-max-ctrl-stk-size p)) (equal (p-max-temp-stk-size (p p n)) (p-max-temp-stk-size p)) (equal (p-word-size (p p n)) (p-word-size p))) ((do-not-induct t) (enable p-invariant1) (use (p-preserves-p-invariant1 (p p) (n n))) (disable p-step errorp p-preserves-p-invariant1))) (prove-lemma p-invariant-same-signature-data-segments (rewrite) (implies (p-invariant p0 p1) (same-signature (p-data-segment p0) (p-data-segment p1))) ((enable p-invariant))) (prove-lemma p-ins-step2-preserves-same-signature-data-segment (rewrite) (let ((new-p (p-ins-step2 (p-current-instruction p) p))) (implies (and (equal (p-psw p) 'run) (p-ins-okp2 (p-current-instruction p) p) (proper-p-statep p)) (same-signature (p-data-segment new-p) (p-data-segment p)))) ((enable p-ins-okp2 p-ins-step2) (disable proper-p-statep-restructuring))) (prove-lemma p-ins-step-preserves-same-signature-data-segment nil (implies (and (equal (p-psw p) 'run) (p-ins-okp (p-current-instruction p) p) (proper-p-statep p)) (same-signature (p-data-segment (p-ins-step (p-current-instruction p) p)) (p-data-segment p))) ((enable p-ins-step-is-p-ins-step1 p-ins-step1) (disable proper-p-statep-restructuring))) (disable p-invariant-same-signature-data-segments) (prove-lemma p-step-preserves-same-signature-data-segment (rewrite) (implies (and (proper-p-statep p) (not (errorp (p-psw (p-step p))))) (same-signature (p-data-segment (p-step p)) (p-data-segment p))) ((use (p-ins-step-preserves-same-signature-data-segment (p p))) (disable proper-p-statep-restructuring) ;; Whoops we need to enable p-step1. (enable p-step1))) (prove-lemma p-preserves-same-signature-data-segment (rewrite) (implies (and (proper-p-statep p) (not (errorp (p-psw (p p n))))) (same-signature (p-data-segment (p p n)) (p-data-segment p))) ((induct (p p n)) (enable p transitivity-of-same-signature) (disable p-step errorp proper-p-statep-restructuring))) ;; Finally enable the Piton -okp and -step functions, we want them for later. (enable p-call-okp) (enable p-call-step) (enable p-ret-okp) (enable p-ret-step) (enable p-locn-okp) (enable p-locn-step) (enable p-push-constant-okp) (enable p-push-constant-step) (enable p-push-local-okp) (enable p-push-local-step) (enable p-push-global-okp) (enable p-push-global-step) (enable p-push-ctrl-stk-free-size-okp) (enable p-push-ctrl-stk-free-size-step) (enable p-push-temp-stk-free-size-okp) (enable p-push-temp-stk-free-size-step) (enable p-push-temp-stk-index-okp) (enable p-push-temp-stk-index-step) (enable p-jump-if-temp-stk-full-okp) (enable p-jump-if-temp-stk-full-step) (enable p-jump-if-temp-stk-empty-okp) (enable p-jump-if-temp-stk-empty-step) (enable p-pop-okp) (enable p-pop-step) (enable p-pop*-okp) (enable p-pop*-step) (enable p-popn-okp) (enable p-popn-step) (enable p-pop-local-okp) (enable p-pop-local-step) (enable p-pop-global-okp) (enable p-pop-global-step) (enable p-pop-locn-okp) (enable p-pop-locn-step) (enable p-pop-call-okp) (enable p-pop-call-step) (enable p-fetch-temp-stk-okp) (enable p-fetch-temp-stk-step) (enable p-deposit-temp-stk-okp) (enable p-deposit-temp-stk-step) (enable p-jump-okp) (enable p-jump-step) (enable p-jump-case-okp) (enable p-jump-case-step) (enable p-pushj-okp) (enable p-pushj-step) (enable p-popj-okp) (enable p-popj-step) (enable p-set-local-okp) (enable p-set-local-step) (enable p-set-global-okp) (enable p-set-global-step) (enable p-test-nat-and-jump-okp) (enable p-test-nat-and-jump-step) (enable p-test-int-and-jump-okp) (enable p-test-int-and-jump-step) (enable p-test-bool-and-jump-okp) (enable p-test-bool-and-jump-step) (enable p-test-bitv-and-jump-okp) (enable p-test-bitv-and-jump-step) (enable p-no-op-okp) (enable p-no-op-step) (enable p-add-addr-okp) (enable p-add-addr-step) (enable p-sub-addr-okp) (enable p-sub-addr-step) (enable p-eq-okp) (enable p-eq-step) (enable p-lt-addr-okp) (enable p-lt-addr-step) (enable p-fetch-okp) (enable p-fetch-step) (enable p-deposit-okp) (enable p-deposit-step) (enable p-add-int-okp) (enable p-add-int-step) (enable p-add-int-with-carry-okp) (enable p-add-int-with-carry-step) (enable p-add1-int-okp) (enable p-add1-int-step) (enable p-sub-int-okp) (enable p-sub-int-step) (enable p-sub-int-with-carry-okp) (enable p-sub-int-with-carry-step) (enable p-sub1-int-okp) (enable p-sub1-int-step) (enable p-neg-int-okp) (enable p-neg-int-step) (enable p-lt-int-okp) (enable p-lt-int-step) (enable p-int-to-nat-okp) (enable p-int-to-nat-step) (enable p-add-nat-okp) (enable p-add-nat-step) (enable p-add-nat-with-carry-okp) (enable p-add-nat-with-carry-step) (enable p-add1-nat-okp) (enable p-add1-nat-step) (enable p-sub-nat-okp) (enable p-sub-nat-step) (enable p-sub-nat-with-carry-okp) (enable p-sub-nat-with-carry-step) (enable p-sub1-nat-okp) (enable p-sub1-nat-step) (enable p-lt-nat-okp) (enable p-lt-nat-step) (enable p-mult2-nat-okp) (enable p-mult2-nat-step) (enable p-mult2-nat-with-carry-out-okp) (enable p-mult2-nat-with-carry-out-step) (enable p-div2-nat-okp) (enable p-div2-nat-step) (enable p-or-bitv-okp) (enable p-or-bitv-step) (enable p-and-bitv-okp) (enable p-and-bitv-step) (enable p-not-bitv-okp) (enable p-not-bitv-step) (enable p-xor-bitv-okp) (enable p-xor-bitv-step) (enable p-rsh-bitv-okp) (enable p-rsh-bitv-step) (enable p-lsh-bitv-okp) (enable p-lsh-bitv-step) (enable p-or-bool-okp) (enable p-or-bool-step) (enable p-and-bool-okp) (enable p-and-bool-step) (enable p-not-bool-okp) (enable p-not-bool-step) (enable p-ins-step) (enable p-ins-okp) ; ------------------------------------------------------------ ; was l-.events ; ------------------------------------------------------------ ;;; This is a prototype compiler for the Logic. Right now we only include ;;; CONS, CAR, CDR, LISTP and TRUE and TRUEP. (Also Quote). ;; Functions to test compiler: ;; ------------------------------------------------------------------------- (defn app (x y) (if (listp x) (cons (car x) (app (cdr x) y)) y)) (defn rev (x) (if (listp x) (app (rev (cdr x)) (list (car x))) nil)) (defn frev (x y) (if (listp x) (frev (cdr x) (cons (car x) y)) y)) ;; ------------------------------------------------------------------------- ;; End functions for testing ;; Returns a list containing the value or F. (defn l-eval (flag expr alist clk) (cond ((equal flag 'list) (if (listp expr) (cons (l-eval t (car expr) alist clk) (l-eval 'list (cdr expr) alist clk)) nil)) ((zerop clk) f) ((litatom expr) (list (cdr (assoc expr alist)))) ((nlistp expr) (list expr)) ((equal (car expr) 'quote) (list (cadr expr))) ((equal (car expr) 'if) (let ((test (l-eval t (cadr expr) alist clk))) (if test (if (car test) (l-eval t (caddr expr) alist clk) (l-eval t (cadddr expr) alist clk)) f))) ((member f (l-eval 'list (cdr expr) alist clk)) f) ((subrp (car expr)) (list (apply-subr (car expr) (strip-cars (l-eval 'list (cdr expr) alist clk))))) (t (l-eval t (body (car expr)) (pairlist (formals (car expr)) (strip-cars (l-eval 'list (cdr expr) alist clk))) (sub1 clk)))) ((ord-lessp (cons (add1 clk) (count expr))))) (defn remove-costs (list) (if (listp list) (cons (list (caar list)) (remove-costs (cdr list))) nil)) (prove-lemma strip-cars-remove-costs (rewrite) (equal (strip-cars (remove-costs l)) (strip-cars l))) (prove-lemma member-strip-cars-definedp (rewrite) (equal (member x (strip-cars y)) (definedp x y))) (disable member-strip-cars-definedp) (prove-lemma member-plist (rewrite) (equal (member x (plist y)) (member x y))) (prove-lemma car-assoc (rewrite) (implies (definedp x y) (equal (car (assoc x y)) x))) (prove-lemma v&c$-l-eval-equivalence () (implies (or (and (equal flag 'list) (not (member f (l-eval flag expr alist clock)))) (and (not (equal flag 'list)) (not (equal (l-eval flag expr alist clock) f)))) (and (equal (l-eval flag expr alist clock) (if (equal flag 'list) (remove-costs (v&c$ flag expr alist)) (list (car (v&c$ flag expr alist))))) (or (and (equal flag 'list) (not (member f (v&c$ flag expr alist)))) (and (not (equal flag 'list)) (not (equal (v&c$ flag expr alist) f)))))) ((induct (l-eval flag expr alist clock)) (expand (v&c-apply$ (car expr) (v&c$ 'list (cdr expr) alist))))) (prove-lemma cdr-v&c$-lessp-if-cadr (rewrite) (implies (v&c-apply$ 'if (cons (v&c$ t test alist) (v&c$ 'list branches alist))) (lessp (cdr (v&c$ t test alist)) (cdr (v&c-apply$ 'if (cons (v&c$ t test alist) (v&c$ 'list branches alist)))))) ((expand (v&c-apply$ 'if (cons (v&c$ t test alist) (v&c$ 'list branches alist)))))) (prove-lemma cdr-v&c$-lessp-if-caddr (rewrite) (implies (and (v&c-apply$ 'if (cons (v&c$ t test alist) (v&c$ 'list branches alist))) (car (v&c$ t test alist))) (lessp (cdr (v&c$ t (car branches) alist)) (cdr (v&c-apply$ 'if (cons (v&c$ t test alist) (v&c$ 'list branches alist)))))) ((expand (v&c-apply$ 'if (cons (v&c$ t test alist) (v&c$ 'list branches alist)))))) (prove-lemma cdr-v&c$-lessp-if-cadddr (rewrite) (implies (and (v&c-apply$ 'if (cons (v&c$ t test alist) (v&c$ 'list branches alist))) (not (car (v&c$ t test alist)))) (lessp (cdr (v&c$ t (cadr branches) alist)) (cdr (v&c-apply$ 'if (cons (v&c$ t test alist) (v&c$ 'list branches alist)))))) ((expand (v&c-apply$ 'if (cons (v&c$ t test alist) (v&c$ 'list branches alist)))))) (prove-lemma v&c$-f-l-eval-f-if-helper-1 (rewrite) (implies (and (not (zerop clock)) (listp expr) (equal (car expr) 'if) (l-eval t (cadr expr) alist clock) (v&c$ t (cadr expr) alist) (not (v&c-apply$ 'if (cons (v&c$ t (cadr expr) alist) (v&c$ 'list (cddr expr) alist)))) (car (l-eval t (cadr expr) alist clock)) (v&c$ t (caddr expr) alist)) (not (l-eval t (caddr expr) alist clock))) ((use (v&c$-l-eval-equivalence (flag t) (expr (cadr expr)) (alist alist) (clock clock))) (do-not-induct t))) (disable v&c$-f-l-eval-f-if-helper-1) (prove-lemma v&c$-f-l-eval-f-if-helper-2 (rewrite) (implies (and (not (zerop clock)) (listp expr) (equal (car expr) 'if) (l-eval t (cadr expr) alist clock) (v&c$ t (cadr expr) alist) (not (v&c-apply$ 'if (cons (v&c$ t (cadr expr) alist) (v&c$ 'list (cddr expr) alist)))) (not (car (l-eval t (cadr expr) alist clock))) (v&c$ t (cadddr expr) alist)) (not (l-eval t (cadddr expr) alist clock))) ((use (v&c$-l-eval-equivalence (flag t) (expr (cadr expr)) (alist alist) (clock clock))) (do-not-induct t))) (disable v&c$-f-l-eval-f-if-helper-2) (prove-lemma v&c$-f-l-eval-flag-list (rewrite) (implies (not (member f (l-eval 'list expr alist clock))) (equal (strip-cars (v&c$ 'list expr alist)) (strip-cars (l-eval 'list expr alist clock)))) ((use (v&c$-l-eval-equivalence (flag 'list) (expr expr) (alist alist) (clock clock))) (do-not-induct t))) (disable v&c$-f-l-eval-flag-list) (prove-lemma v&c$-f-l-eval-f () (implies (or (and (equal flag 'list) (member f (v&c$ flag expr alist))) (and (not (equal flag 'list)) (equal (v&c$ flag expr alist) f))) (or (and (equal flag 'list) (member f (l-eval flag expr alist clock))) (and (not (equal flag 'list)) (equal (l-eval flag expr alist clock) f)))) ((induct (l-eval flag expr alist clock)) (expand (v&c-apply$ (car expr) (v&c$ 'list (cdr expr) alist))) (enable v&c$-f-l-eval-f-if-helper-1 v&c$-f-l-eval-f-if-helper-2 v&c$-f-l-eval-flag-list))) (prove-lemma l-eval-v&c$-flag-not-list (rewrite) (implies (and (not (v&c$ flag expr alist)) (not (equal flag 'list))) (equal (l-eval flag expr alist clock) f)) ((use (v&c$-f-l-eval-f (flag flag) (expr expr) (alist alist) (clock clock))))) (disable l-eval-v&c$-flag-not-list) (prove-lemma l-eval-v&c$-flag-list (rewrite) (implies (member f (v&c$ 'list expr alist)) (member f (l-eval 'list expr alist clock))) ((use (v&c$-f-l-eval-f (flag 'list) (expr expr) (alist alist) (clock clock))))) (prove-lemma v&c$-l-eval-flag-list (rewrite) (implies (not (member f (l-eval 'list expr alist clock))) (not (member f (v&c$ 'list expr alist)))) ((use (v&c$-l-eval-equivalence (flag 'list) (expr expr) (alist alist) (clock clock))))) (prove-lemma member-f-v&c$-fact-1 (rewrite) (implies (and (listp expr) (not (equal (car expr) 'quote)) (not (equal (car expr) 'if)) (member f (v&c$ 'list (cdr expr) alist)) (not (equal flag 'list))) (not (v&c$ flag expr alist))) ((do-not-induct t) (expand (v&c-apply$ (car expr) (v&c$ 'list (cdr expr) alist))))) (prove-lemma sum-cdrs-v&c$-list-fact-1 (rewrite) (implies (and (v&c-apply$ fun (v&c$ 'list arg-list alist)) (not (equal fun 'quote)) (not (equal fun 'if))) (lessp (sum-cdrs (v&c$ 'list arg-list alist)) (cdr (v&c-apply$ fun (v&c$ 'list arg-list alist))))) ((expand (v&c-apply$ fun (v&c$ 'list arg-list alist))))) (prove-lemma subrp-expr-v&c-apply$ (rewrite) (implies (and (subrp x) (not (equal x 'if)) (not (member f args))) (equal (car (v&c-apply$ x args)) (apply-subr x (strip-cars args)))) ((do-not-induct t) (expand (v&c-apply$ x args)))) (prove-lemma not-subrp-expr-v&c-apply$ (rewrite) (implies (and (not (subrp x)) (not (member f args))) (equal (car (v&c-apply$ x args)) (car (v&c$ t (body x) (pairlist (formals x) (strip-cars args)))))) ((do-not-induct t) (expand (v&c-apply$ x args)))) (prove-lemma v&c$-body-lessp-fact-1 (rewrite) (implies (and (not (subrp fun)) (v&c-apply$ fun args)) (lessp (cdr (v&c$ t (body fun) (pairlist (formals fun) (strip-cars args)))) (cdr (v&c-apply$ fun args)))) ((do-not-induct t) (expand (v&c-apply$ fun args)))) (prove-lemma v&c$-not-subrp-expand-1 (rewrite) (implies (and (v&c-apply$ fun args) (not (subrp fun))) (v&c$ t (body fun) (pairlist (formals fun) (strip-cars args)))) ((do-not-induct t) (expand (v&c-apply$ fun args)))) (prove-lemma not-member-remove-costs (rewrite) (implies (not (listp x)) (not (member x (remove-costs list))))) (prove-lemma l-eval-not-f-v&c$-equivalence () (implies (or (and (equal flag 'list) (not (member f (v&c$ flag expr alist))) (lessp (sum-cdrs (v&c$ flag expr alist)) clock)) (and (not (equal flag 'list)) (not (equal (v&c$ flag expr alist) f)) (lessp (cdr (v&c$ flag expr alist)) clock))) (and (equal (l-eval flag expr alist clock) (if (equal flag 'list) (remove-costs (v&c$ flag expr alist)) (list (car (v&c$ flag expr alist))))) (or (and (equal flag 'list) (not (member f (v&c$ flag expr alist)))) (and (not (equal flag 'list)) (not (equal (v&c$ flag expr alist) f)))))) ((induct (l-eval flag expr alist clock)) (enable l-eval-v&c$-flag-not-list) (disable l-eval remove-costs strip-cars) (expand (l-eval flag expr alist clock) (l-eval 'list expr alist clock) (remove-costs (cons (v&c$ t (car expr) alist) (v&c$ 'list (cdr expr) alist)))))) ; ------------------------------------------------------------ ; was s-eval1.events ; ------------------------------------------------------------ (disable pack-equal) (defn NUMBER-CONS (x) (if (listp x) (add1 (plus (number-cons (car x)) (number-cons (cdr x)))) 0)) (prove-lemma NUMBER-CONS-CAR (rewrite) (implies (listp x) (lessp (number-cons (car x)) (number-cons x)))) (prove-lemma NUMBER-CONS-CDR (rewrite) (implies (listp x) (lessp (number-cons (cdr x)) (number-cons x)))) (prove-lemma NUMBER-CONS-CADR-CADDR-CADDDR (rewrite) (implies (listp x) (and (lessp (number-cons (cadr x)) (number-cons x)) (lessp (number-cons (caddr x)) (number-cons x)) (lessp (number-cons (cadddr x)) (number-cons x))))) ;; ***** The S-level (S for Subexpression). ***** ;; This level is somewhat similar to the logic. Quoted constants are now ;; looked up in a global alist. ;; An S-STATE has eight components. ;; S-PNAME: the name of the program currently being executed ;; S-POS: the "position" of the expression currently being evaluated. ;; S-ANS: the answer ;; S-PARAMS: an alist with entries of form ( . ) ;; S-TEMPS: an alist with entries of form ( ) ;; S-PROGS: an alist with entires of form ;; ( ) ;; S-ERR-FLAG: A flag that should be 'RUN, otherwise it means we terminated ;; with an error. ;; S-PNAME names the current program, S-POS denotes the position. ;; The position is a list of integers that uniquely determines the ;; current sub-expression. ;; An example in the list: ;; (a b (c d (f g) (h (i j) k l m))) ;; the position (2 2) denotes the list (f g). ;; ;; The expression and the bodies of the programs (S-PROGS) are ;; slightly different from the logic. ;; Parameters (entries in S-PARAMS) appear as LITATOMs (i.e. they ;; are not changed). ;; Entries in S-TEMPS are triples, the CAR is the expression, ;; the CADR is a boolean flag, if T it means that the CADDR is the value ;; of the expression, otherwise the CADDR is undefined. ;; There are 3 forms that effect or are effected by S-TEMPS. The CAR of ;; each of these forms is a singleton list, with one of the values: ;; TEMP-EVAL, TEMP-FETCH, or TEMP-TEST. ;; All these forms should have an expression as the only argument ;; (called EXP below). ;; TEMP-EVAL: if the flag corresoponding to EXP in S-TEMPS is not F, ;; set S-ERR-FLAG to an error and return, otherwise evaluate ;; EXP and put it and the value into S-TEMPS and set the flag. ;; TEMP-FETCH: if the flag corresponding to EXP in S-TEMPS is set returns ;; the value associated with EXP, otherwise sets S-ERR-FLAG ;; to an error. ;; TEMP-TEST: if the flag corresponding to EXP in S-TEMPS is set ;; returns the value associated with EXP, otherwise evaluate ;; EXP and put it and the value into S-TEMPS, setting the flag. (defn S-TEMP-EVAL () '(temp-eval)) (defn S-TEMP-FETCH () '(temp-fetch)) (defn S-TEMP-TEST () '(temp-test)) (defn S-TEMP-SETP (expr temps) (cadr (assoc expr temps))) (disable s-temp-setp) (defn S-TEMP-VALUE (expr temps) (caddr (assoc expr temps))) (add-shell S-STATE nil s-statep ((s-pname (none-of) zero) (s-pos (none-of) zero) (s-ans (none-of) zero) (s-params (none-of) zero) (s-temps (none-of) zero) (s-progs (none-of) zero) (s-err-flag (none-of) zero))) (defn CUR-EXPR (position expr) (if (nlistp position) expr (cur-expr (cdr position) (get (car position) expr)))) (defn BUTLAST (list) (firstn (sub1 (length list)) list)) (disable butlast) (defn LAST (l) (if (listp l) (if (listp (cdr l)) (last (cdr l)) l) nil)) (defn DV (pos increment) (append pos (list increment))) (disable dv) (defn NX (pos) (append (butlast pos) (list (add1 (car (last pos)))))) (disable nx) ;; We prepend all user names with U-. This is to avoid name conflicts. ;; We used to just make sure the main program was not one of the names ;; specified to LOGIC->S (by using GENSYM). However we needed to know that ;; it was not a SUBRP. This made the correctness theorem almost useless, ;; because it had an hypothesis of the form: ;; (not (subrp (car (gensym (unpack 'main) nil pnames)))) ;; This could not in general be reduced. Also we will probably need to have ;; our own functions. The names of these functions should start with I-. ;; U- is for User, I- for Internal. (defn USER-FNAME-PREFIX () (list (car (unpack 'U-)) (cadr (unpack 'U-)))) (defn USER-FNAME (name) (pack (append (user-fname-prefix) (unpack name)))) (disable user-fname) (defn USER-FNAMEP (name) (and (litatom name) (equal (car (unpack name)) (car (user-fname-prefix))) (equal (cadr (unpack name)) (cadr (user-fname-prefix))))) (disable user-fnamep) (defn LOGIC-FNAME (name) (pack (cddr (unpack name)))) (disable logic-fname) (defn S-FORMALS (s-program) (cadr s-program)) (disable s-formals) (defn S-TEMP-LIST (s-program) (caddr s-program)) (disable s-temp-list) (defn S-BODY (s-program) (cadddr s-program)) (disable s-body) (defn S-PROG (s) (definition (s-pname s) (s-progs s))) (disable s-prog) (defn S-EXPR (s) (cur-expr (s-pos s) (s-body (s-prog s)))) (disable s-expr) (defn S-EXPR-LIST (s) (restn (car (last (s-pos s))) (cur-expr (butlast (s-pos s)) (s-body (s-prog s))))) (disable s-expr-list) (prove-lemma GET-ANYTHING-NIL (rewrite) (implies (not (listp lst)) (equal (get anything lst) 0)) ((enable get))) (disable get-anything-nil) (prove-lemma GET-CONS (rewrite) (implies (not (zerop k)) (equal (get k (cons anything list)) (get (sub1 k) list))) ((enable get))) (disable get-cons) (prove-lemma GET-LARGE-INDEX (rewrite) (implies (not (lessp n (length list))) (equal (get n list) 0)) ((enable get get-anything-nil))) (disable get-large-index) (prove-lemma GET-ZEROP (rewrite) (implies (zerop n) (equal (get n list) (car list))) ((enable get))) (defn S-SET-POS (s pos) (s-state (s-pname s) pos (s-ans s) (s-params s) (s-temps s) (s-progs s) (s-err-flag s))) (prove-lemma S-ACCESSORS-S-SET-POS (rewrite) (and (equal (s-pname (s-set-pos s pos)) (s-pname s)) (equal (s-pos (s-set-pos s pos)) pos) (equal (s-ans (s-set-pos s pos)) (s-ans s)) (equal (s-params (s-set-pos s pos)) (s-params s)) (equal (s-temps (s-set-pos s pos)) (s-temps s)) (equal (s-progs (s-set-pos s pos)) (s-progs s)) (equal (s-err-flag (s-set-pos s pos)) (s-err-flag s)))) (disable s-set-pos) (defn S-SET-TEMPS (state new-temps) (s-state (s-pname state) (s-pos state) (s-ans state) (s-params state) new-temps (s-progs state) (s-err-flag state))) (prove-lemma S-ACCESSORS-S-SET-TEMPS (rewrite) (and (equal (s-pname (s-set-temps state temps)) (s-pname state)) (equal (s-pos (s-set-temps state temps)) (s-pos state)) (equal (s-ans (s-set-temps state temps)) (s-ans state)) (equal (s-temps (s-set-temps state temps)) temps) (equal (s-params (s-set-temps state temps)) (s-params state)) (equal (s-progs (s-set-temps state temps)) (s-progs state)) (equal (s-err-flag (s-set-temps state temps)) (s-err-flag state)))) (disable s-set-temps) (defn S-SET-ERROR (state flag) (s-state (s-pname state) (s-pos state) (s-ans state) (s-params state) (s-temps state) (s-progs state) flag)) (prove-lemma S-ACCESSORS-S-SET-ERROR (rewrite) (and (equal (s-pname (s-set-error state flag)) (s-pname state)) (equal (s-pos (s-set-error state flag)) (s-pos state)) (equal (s-ans (s-set-error state flag)) (s-ans state)) (equal (s-temps (s-set-error state flag)) (s-temps state)) (equal (s-params (s-set-error state flag)) (s-params state)) (equal (s-progs (s-set-error state flag)) (s-progs state)) (equal (s-err-flag (s-set-error state flag)) flag))) (disable s-set-error) (defn S-CHANGE-TEMP (s expr value) (s-set-temps s (put-assoc (list t value) expr (s-temps s)))) (prove-lemma S-ACCESSORS-S-CHANGE-TEMP (rewrite) (and (equal (s-pname (s-change-temp s e v)) (s-pname s)) (equal (s-pos (s-change-temp s e v)) (s-pos s)) (equal (s-ans (s-change-temp s e v)) (s-ans s)) (equal (s-params (s-change-temp s e v)) (s-params s)) (equal (s-progs (s-change-temp s e v)) (s-progs s)) (equal (s-err-flag (s-change-temp s e v)) (s-err-flag s)))) (disable s-change-temp) (defn S-SET-ANS (state ans) (s-state (s-pname state) (s-pos state) ans (s-params state) (s-temps state) (s-progs state) (s-err-flag state))) (prove-lemma S-ACCESSORS-S-SET-ANS (rewrite) (and (equal (s-pname (s-set-ans s ans)) (s-pname s)) (equal (s-pos (s-set-ans s ans)) (s-pos s)) (equal (s-ans (s-set-ans s ans)) ans) (equal (s-params (s-set-ans s ans)) (s-params s)) (equal (s-temps (s-set-ans s ans)) (s-temps s)) (equal (s-progs (s-set-ans s ans)) (s-progs s)) (equal (s-err-flag (s-set-ans s ans)) (s-err-flag s)))) (disable s-set-ans) (defn S-EVAL-DO-TEMP-FETCH (state) (if (s-temp-setp (cadr (s-expr state)) (s-temps state)) (s-set-ans state (s-temp-value (cadr (s-expr state)) (s-temps state))) (s-set-error state 'temp-fetch-not-set))) (prove-lemma S-ACCESSORS-S-EVAL-DO-TEMP-FETCH (rewrite) (and (equal (s-pname (s-eval-do-temp-fetch state)) (s-pname state)) (equal (s-pos (s-eval-do-temp-fetch state)) (s-pos state)) (equal (s-ans (s-eval-do-temp-fetch state)) (if (s-temp-setp (cadr (s-expr state)) (s-temps state)) (s-temp-value (cadr (s-expr state)) (s-temps state)) (s-ans state))) (equal (s-params (s-eval-do-temp-fetch state)) (s-params state)) (equal (s-temps (s-eval-do-temp-fetch state)) (s-temps state)) (equal (s-progs (s-eval-do-temp-fetch state)) (s-progs state)) (equal (s-err-flag (s-eval-do-temp-fetch state)) (if (s-temp-setp (cadr (s-expr state)) (s-temps state)) (s-err-flag state) 'temp-fetch-not-set)))) (disable s-eval-do-temp-fetch) (defn MAKE-TEMPS-ENTRIES (list) (if (listp list) (cons (list (car list) f nil) (make-temps-entries (cdr list))) nil)) (defn S-FUN-CALL-STATE (s pname) (s-state (user-fname pname) nil (s-ans s) (pairlist (s-formals (assoc (user-fname pname) (s-progs s))) (s-ans s)) (make-temps-entries (s-temp-list (assoc (user-fname pname) (s-progs s)))) (s-progs s) 'run)) (prove-lemma S-ACCESSORS-S-FUN-CALL-STATE (rewrite) (and (equal (s-pname (s-fun-call-state s pname)) (user-fname pname)) (equal (s-pos (s-fun-call-state s pname)) nil) (equal (s-ans (s-fun-call-state s pname)) (s-ans s)) (equal (s-params (s-fun-call-state s pname)) (pairlist (s-formals (assoc (user-fname pname) (s-progs s))) (s-ans s))) (equal (s-temps (s-fun-call-state s pname)) (make-temps-entries (s-temp-list (assoc (user-fname pname) (s-progs s))))) (equal (s-progs (s-fun-call-state s pname)) (s-progs s)) (equal (s-err-flag (s-fun-call-state s pname)) 'run))) (disable s-fun-call-state) (defn S-SET-EXPR (s1 s2 pos) (s-state (s-pname s2) pos (s-ans s1) (s-params s1) (s-temps s1) (s-progs s2) (s-err-flag s1))) (prove-lemma S-ACCESSORS-S-SET-EXPR (rewrite) (and (equal (s-pname (s-set-expr s1 s2 pos)) (s-pname s2)) (equal (s-pos (s-set-expr s1 s2 pos)) pos) (equal (s-ans (s-set-expr s1 s2 pos)) (s-ans s1)) (equal (s-params (s-set-expr s1 s2 pos)) (s-params s1)) (equal (s-temps (s-set-expr s1 s2 pos)) (s-temps s1)) (equal (s-progs (s-set-expr s1 s2 pos)) (s-progs s2)) (equal (s-err-flag (s-set-expr s1 s2 pos)) (s-err-flag s1)))) (disable s-set-expr) (prove-lemma LESSP-NUMBER-CONS-RESTN-GET (rewrite) (implies (lessp n (length x)) (lessp (number-cons (get n x)) (number-cons (restn n x)))) ((enable get))) (prove-lemma GET-ADD1-OPENER (rewrite) (equal (get (add1 x) list) (get x (cdr list))) ((enable get))) (prove-lemma RESTN-ADD1-OPENER (rewrite) (implies (listp list) (equal (restn (add1 x) list) (restn x (cdr list))))) (prove-lemma RESTN-CDR (rewrite) (implies (lessp n (length x)) (equal (restn n (cdr x)) (cdr (restn n x))))) (disable restn-cdr) (prove-lemma CAR-RESTN-GET (rewrite) (equal (car (restn n list)) (get n list)) ((enable get get-anything-nil))) (prove-lemma S-PROG-S-SET-EXPR (rewrite) (equal (s-prog (s-set-expr s1 s2 pos)) (s-prog s2)) ((enable s-prog))) (prove-lemma S-PROG-S-SET-POS (rewrite) (equal (s-prog (s-set-pos s pos)) (s-prog s)) ((enable s-prog))) (prove-lemma CUR-EXPR-APPEND (rewrite) (equal (cur-expr (append pos1 pos2) body) (cur-expr pos2 (cur-expr pos1 body)))) (prove-lemma S-EXPR-S-SET-EXPR (rewrite) (equal (s-expr (s-set-expr s1 s2 (dv (s-pos s2) n))) (get n (s-expr s2))) ((enable s-expr s-prog dv))) (prove-lemma S-EXPR-S-SET-POS-T (rewrite) (equal (s-expr (s-set-pos s (dv (s-pos s) n))) (get n (s-expr s))) ((enable s-expr dv))) (prove-lemma BUTLAST-APPEND (rewrite) (implies (listp l2) (equal (butlast (append l1 l2)) (append l1 (butlast l2)))) ((enable butlast))) (prove-lemma RESTN-SUB1-LENGTH-LAST (rewrite) (implies (and (equal n (sub1 (length l))) (listp l)) (equal (restn n l) (last l))) ((enable restn last length) (enable-theory ground-zero) (disable-theory t))) (prove-lemma APPEND-BUTLAST-LASTCDR (rewrite) (implies (listp x) (equal (append (butlast x) (last x)) x)) ((enable butlast) (use (append-firstn-restn (i (sub1 (length x))) (l x))) (disable append-firstn-restn))) (prove-lemma NOT-LISTP-CDR-LAST (rewrite) (equal (listp (cdr (last x))) f)) (prove-lemma LISTP-LAST-LISTP (rewrite) (equal (listp (last x)) (listp x))) (prove-lemma CUR-EXPR-LAST (rewrite) (implies (and (listp pos) (lessp (car (last pos)) (length body))) (equal (cur-expr (last pos) body) (get (car (last pos)) body))) ((expand (cur-expr (last pos) body)))) (prove-lemma NUMBER-CONS-CUR-EXPR (rewrite) (implies (and (lessp (car (last pos)) (length (cur-expr (butlast pos) body))) (listp pos)) (lessp (number-cons (cur-expr pos body)) (number-cons (restn (car (last pos)) (cur-expr (butlast pos) body))))) ((use (cur-expr-append (pos1 (butlast pos)) (pos2 (last pos)) (body body))) (disable cur-expr-append))) (prove-lemma LAST-APPEND (rewrite) (implies (listp y) (equal (last (append x y)) (last y)))) (prove-lemma BUTLAST-SINGLETON-LIST (rewrite) (equal (butlast (list x)) nil) ((enable butlast))) (prove-lemma LAST-NX (rewrite) (implies (listp pos) (equal (last (nx pos)) (list (add1 (car (last pos)))))) ((enable nx))) (prove-lemma BUTLAST-NX (rewrite) (implies (listp pos) (equal (butlast (nx pos)) (butlast pos))) ((enable butlast nx))) (prove-lemma CUR-EXPR-PLIST (rewrite) (equal (cur-expr (plist pos) body) (cur-expr pos body))) (prove-lemma LAST-DV (rewrite) (equal (last (dv pos n)) (list n)) ((enable dv))) (prove-lemma BUTLAST-DV (rewrite) (equal (butlast (dv pos n)) (plist pos)) ((enable dv))) (prove-lemma S-EXPR-LIST-S-S-SET-EXPR-NX (rewrite) (implies (and (listp (s-pos s)) (listp (s-expr-list s))) (equal (s-expr-list (s-set-expr s1 s (nx (s-pos s)))) (cdr (s-expr-list s)))) ((enable s-expr-list restn-cdr))) (prove-lemma LESSP-NUMBER-CONS-S-EXPR-S-EXPR-LIST (rewrite) (implies (and (listp (s-pos s)) (listp (s-expr-list s))) (lessp (number-cons (s-expr s)) (number-cons (s-expr-list s)))) ((enable s-expr s-expr-list))) (prove-lemma S-EXPR-LIST-S-SET-POS-DV (rewrite) (equal (s-expr-list (s-set-pos s (dv (s-pos s) n))) (restn n (s-expr s))) ((enable s-expr-list s-expr))) ;; if flag is 'list then state contains a list of expressions, ;; otherwise it is just one. ;; Returns a s-state. If flag is LIST the S-ANS of the s-state is ;; a list results. Otherwise S-ANS of the result is the answer. (defn S-EVAL (flag s c) (cond ((not (equal (s-err-flag s) 'run)) s) ((equal flag 'list) (if (nlistp (s-pos s)) (s-set-error s 'bad-list-position) (if (listp (s-expr-list s)) (let ((car-s (s-eval t s c))) (let ((cdr-s (s-eval 'list (s-set-expr car-s s (nx (s-pos s))) c))) (s-set-ans cdr-s (cons (s-ans car-s) (s-ans cdr-s))))) (s-set-ans s nil)))) ((zerop c) (s-set-error s 'out-of-time)) ((litatom (s-expr s)) (s-set-ans s (value (s-expr s) (s-params s)))) ((nlistp (s-expr s)) (s-set-error s 'bad-expression)) ((equal (car (s-expr s)) 'if) (let ((test (s-eval t (s-set-pos s (dv (s-pos s) 1)) c))) (if (equal (s-err-flag test) 'run) (if (s-ans test) (s-eval t (s-set-expr test s (dv (s-pos s) 2)) c) (s-eval t (s-set-expr test s (dv (s-pos s) 3)) c)) test))) ((equal (car (s-expr s)) (s-temp-eval)) (let ((new-s (s-eval t (s-set-pos s (dv (s-pos s) 1)) c))) (s-change-temp new-s (cadr (s-expr s)) (s-ans new-s)))) ((equal (car (s-expr s)) (s-temp-test)) (if (s-temp-setp (cadr (s-expr s)) (s-temps s)) (s-eval-do-temp-fetch s) (let ((new-s (s-eval t (s-set-pos s (dv (s-pos s) 1)) c))) (s-change-temp new-s (cadr (s-expr s)) (s-ans new-s))))) ((equal (car (s-expr s)) (s-temp-fetch)) (s-eval-do-temp-fetch s)) ((equal (car (s-expr s)) 'quote) (s-set-ans s (cadr (s-expr s)))) ((not (equal (s-err-flag (s-eval 'list (s-set-pos s (dv (s-pos s) 1)) c)) 'run)) (s-eval 'list (s-set-pos s (dv (s-pos s) 1)) c)) ((subrp (car (s-expr s))) (let ((arg-s (s-eval 'list (s-set-pos s (dv (s-pos s) 1)) c))) (s-set-ans arg-s (apply-subr (car (s-expr s)) (s-ans arg-s))))) ((litatom (car (s-expr s))) (let ((arg-s (s-eval 'list (s-set-pos s (dv (s-pos s) 1)) c))) (let ((new-s (s-eval t (s-fun-call-state arg-s (car (s-expr s))) (sub1 c)))) (if (equal (s-err-flag new-s) 'run) (s-set-expr (s-set-ans arg-s (s-ans new-s)) s (s-pos s)) new-s)))) (t (s-set-error s 'bad-instruction))) ((ord-lessp (cons (add1 c) (if (equal flag 'list) (number-cons (s-expr-list s)) (number-cons (s-expr s))))))) (prove-lemma S-PROGS-S-EVAL (rewrite) (equal (s-progs (s-eval flag state clock)) (s-progs state))) (prove-lemma S-PARAMS-S-EVAL (rewrite) (implies (equal (s-err-flag (s-eval flag state clock)) 'run) (equal (s-params (s-eval flag state clock)) (s-params state)))) (prove-lemma S-PNAME-S-EVAL (rewrite) (implies (equal (s-err-flag (s-eval flag state clock)) 'run) (equal (s-pname (s-eval flag state clock)) (s-pname state)))) ;; Takes body and expands away temporary variables. ;; BODY is a S-STATE expression. ;; Returns the expanded body (defn S-EXPAND-TEMPS (flag body) (cond ((equal flag 'list) (if (listp body) (cons (s-expand-temps t (car body)) (s-expand-temps 'list (cdr body))) nil)) ((nlistp body) body) ((or (equal (car body) (s-temp-eval)) (equal (car body) (s-temp-fetch)) (equal (car body) (s-temp-test))) (s-expand-temps t (cadr body))) ((equal (car body) 'quote) body) (t (cons (car body) (s-expand-temps 'list (cdr body))))) ((lessp (number-cons body)))) (defn SUBR-ARITY-ALIST () '((ADD1 1) (ADD-TO-SET 2) (AND 2) (APPEND 2) (APPLY-SUBR 2) (APPLY$ 2) (ASSOC 2) (BODY 1) (CAR 1) (CDR 1) (CONS 2) (COUNT 1) (DIFFERENCE 2) (EQUAL 2) (EVAL$ 3) (FALSE 0) (FALSEP 1) (FIX 1) (FIX-COST 2) (FOR 6) (FORMALS 1) (GEQ 2) (GREATERP 2) (IF 3) (IFF 2) (IMPLIES 2) (LEQ 2) (LESSP 2) (LISTP 1) (LITATOM 1) (MAX 2) (MEMBER 2) (MINUS 1) (NEGATIVEP 1) (NEGATIVE-GUTS 1) (NLISTP 1) (NOT 1) (NUMBERP 1) (OR 2) (ORDINALP 1) (ORD-LESSP 2) (PACK 1) (PAIRLIST 2) (PLUS 2) (QUANTIFIER-INITIAL-VALUE 1) (QUANTIFIER-OPERATION 3) (QUOTIENT 2) (REMAINDER 2) (STRIP-CARS 1) (SUB1 1) (SUBRP 1) (SUM-CDRS 1) (TIMES 2) (TRUE 0) (TRUEP 1) (UNION 2) (UNPACK 1) (V&C$ 3) (V&C-APPLY$ 2) (ZERO 0) (ZEROP 1))) (defn ARITY (function) (if (subrp function) (cadr (assoc function (subr-arity-alist))) (if (equal function 'quote) 1 (length (formals function))))) (disable arity) (defn S-PROPER-EXPRP (flag expr p-names formals temp-list) (cond ((equal flag 'list) (if (listp expr) (and (s-proper-exprp t (car expr) p-names formals temp-list) (s-proper-exprp 'list (cdr expr) p-names formals temp-list)) (equal expr nil))) ((listp expr) (cond ((not (plistp expr)) f) ((or (equal (car expr) (s-temp-fetch)) (equal (car expr) (s-temp-eval)) (equal (car expr) (s-temp-test))) (and (member (cadr expr) temp-list) (equal (length expr) 2) (s-proper-exprp t (cadr expr) p-names formals temp-list))) ((equal (car expr) 'quote) (equal (length (cdr expr)) (arity (car expr)))) ((subrp (car expr)) (and (equal (length (cdr expr)) (arity (car expr))) (not (member (car expr) p-names)) (s-proper-exprp 'list (cdr expr) p-names formals temp-list))) ((body (car expr)) (and (equal (length (cdr expr)) (arity (car expr))) (member (car expr) p-names) (s-proper-exprp 'list (cdr expr) p-names formals temp-list))) (t f))) ((litatom expr) (member expr formals)) (t f))) (defn S-PROGRAMS-PROPERP (programs program-names) (if (listp programs) (and (all-litatoms (s-formals (car programs))) (s-proper-exprp t (s-body (car programs)) program-names (s-formals (car programs)) (s-temp-list (car programs))) (s-programs-properp (cdr programs) program-names)) t)) (defn S-PROGRAMS-OKP (programs) (if (listp programs) (and (not (equal (s-formals (car programs)) f)) (user-fnamep (car (car programs))) (equal (s-formals (car programs)) (formals (logic-fname (car (car programs))))) (equal (s-expand-temps t (s-body (car programs))) (body (logic-fname (car (car programs))))) (s-programs-okp (cdr programs))) t)) (defn TEMPS-OKP (temps params c) (if (listp temps) (and (or (not (cadr (car temps))) (and (l-eval t (s-expand-temps t (car (car temps))) params c) (equal (car (l-eval t (s-expand-temps t (car (car temps))) params c)) (caddr (car temps))))) (temps-okp (cdr temps) params c)) t)) (defn GOOD-POSP1 (pos expr) (cond ((nlistp pos) t) ((nlistp expr) f) ((equal (car expr) (s-temp-fetch)) ;; If (CAR EXPR) is (S-TEMP-FETCH) then we can not dive in. f) ((or (equal (car expr) (s-temp-eval)) (equal (car expr) (s-temp-test))) (and (equal (car pos) 1) (good-posp1 (cdr pos) (cadr expr)))) ((equal (car expr) 'quote) ;; If (CAR EXPR) is QUOTE then we dove into a quoted expr f) (t (and (not (zerop (car pos))) (lessp (car pos) (length expr)) (good-posp1 (cdr pos) (get (car pos) expr)))))) (disable good-posp1) (defn GOOD-POSP-LIST (n expr) (cond ((nlistp expr) f) ((or (equal (car expr) (s-temp-fetch)) (equal (car expr) (s-temp-eval)) (equal (car expr) (s-temp-test)) (equal (car expr) 'quote)) f) (t (and (not (zerop n)) (not (lessp (length expr) n)))))) (defn GOOD-POSP (flag pos expr) (if (equal flag 'list) (and (good-posp-list (car (last pos)) (cur-expr (butlast pos) expr)) (good-posp1 (butlast pos) expr)) (good-posp1 pos expr))) (disable good-posp) (defn ALL-USER-FNAMESP (list) (if (listp list) (and (user-fnamep (car list)) (all-user-fnamesp (cdr list))) t)) (defn STRIP-LOGIC-FNAMES (list) (if (listp list) (cons (logic-fname (caar list)) (strip-logic-fnames (cdr list))) nil)) ;; This is a bit bogus. We check S-PROGRAMS-OKP of the CDR of S-PROGS. This ;; is because S-PROGRAMS-OKP checks that BODY and FORMALS are defined on ;; the names of the PROGRAMS. Therefore it is NECESSARY that the expression ;; given to the compiler be the first program in S-PROGS. ;; Note that all functions calls must be defined, but can not be the ;; first program. (defn S-GOOD-STATEP (s c) (and (definedp (s-pname s) (s-progs s)) (equal (car (car (s-progs s))) 'main) (s-programs-properp (s-progs s) (strip-logic-fnames (cdr (s-progs s)))) (s-programs-okp (cdr (s-progs s))) (equal (strip-cars (s-temps s)) (plist (s-temp-list (s-prog s)))) (equal (s-err-flag s) 'run) (temps-okp (s-temps s) (s-params s) c))) (prove-lemma S-GOOD-STATEP-BACKCHAINER-1 (rewrite) (implies (s-good-statep s c) (definedp (s-pname s) (s-progs s))) ((disable s-proper-exprp s-programs-properp s-programs-okp temps-okp))) (prove-lemma NOT-USER-FNAMEP-NOT-DEFINEDP-S-PROGRAMS-OKP () (implies (and (not (user-fnamep name)) (definedp name progs)) (not (s-programs-okp progs)))) (prove-lemma S-GOOD-STATEP-BACKCHAINER-2 (rewrite) (implies (s-good-statep s c) (not (definedp 'MAIN (cdr (s-progs s))))) ((disable s-proper-exprp s-programs-properp s-programs-okp temps-okp) (use (not-user-fnamep-not-definedp-s-programs-okp (name 'main) (progs (cdr (s-progs s))))))) (disable s-good-statep-backchainer-2) (prove-lemma S-GOOD-STATEP-BACKCHAINER-2-5 (rewrite) (implies (s-good-statep s c) (equal (caar (s-progs s)) 'MAIN)) ((disable s-proper-exprp s-programs-properp s-programs-okp temps-okp))) (disable s-good-statep-backchainer-2-5) (prove-lemma S-GOOD-STATEP-BACKCHAINER-3 (rewrite) (implies (s-good-statep s c) (s-programs-properp (s-progs s) (strip-logic-fnames (cdr (s-progs s))))) ((disable s-proper-exprp s-programs-properp s-programs-okp temps-okp))) (prove-lemma S-GOOD-STATEP-BACKCHAINER-4 (rewrite) (implies (s-good-statep s c) (s-programs-okp (cdr (s-progs s)))) ((disable s-proper-exprp s-programs-properp s-programs-okp temps-okp))) (prove-lemma S-GOOD-STATEP-BACKCHAINER-5 (rewrite) (implies (s-good-statep s c) (temps-okp (s-temps s) (s-params s) c)) ((disable s-proper-exprp s-programs-properp s-programs-okp temps-okp))) (prove-lemma S-GOOD-STATEP-BACKCHAINER-6 (rewrite) (implies (s-good-statep s c) (equal (s-err-flag s) 'run)) ((disable s-proper-exprp s-programs-properp s-programs-okp temps-okp))) (prove-lemma S-GOOD-STATEP-STRIP-CARS-TEMPS (rewrite) (implies (s-good-statep s c) (equal (strip-cars (s-temps s)) (plist (s-temp-list (s-prog s))))) ((disable s-proper-exprp s-programs-properp s-programs-okp temps-okp))) (prove-lemma S-GOOD-STATEP-S-SET-POS (rewrite) (equal (s-good-statep (s-set-pos s pos) c) (s-good-statep s c)) ((disable definedp s-programs-okp s-programs-properp temps-okp))) (prove-lemma TEMPS-OKP-PUT-ASSOC (rewrite) (implies (and (temps-okp temps params c) (l-eval t (s-expand-temps t expr) params c)) (temps-okp (put-assoc (list t (car (l-eval t (s-expand-temps t expr) params c))) expr temps) params c)) ((disable l-eval))) (prove-lemma S-PROG-S-SET-TEMPS (rewrite) (equal (s-prog (s-set-temps s new-temps)) (s-prog s)) ((enable s-prog))) (prove-lemma S-GOOD-STATEP-S-CHANGE-TEMP (rewrite) (let ((expr (cadr (s-expr s))) (s1 (s-eval t (s-set-pos s (dv (s-pos s) 1)) c))) (implies (and (s-good-statep s1 c) (l-eval t (s-expand-temps t expr) (s-params s) c) (equal x (car (l-eval t (s-expand-temps t expr) (s-params s) c)))) (s-good-statep (s-change-temp s1 expr x) c))) ((enable s-change-temp) (disable l-eval s-proper-exprp s-programs-properp s-programs-okp temps-okp))) (prove-lemma S-PROG-S-SET-ANS (rewrite) (equal (s-prog (s-set-ans s ans)) (s-prog s)) ((enable s-prog))) (prove-lemma S-GOOD-STATEP-S-SET-ANS (rewrite) (equal (s-good-statep (s-set-ans s ans) c) (s-good-statep s c)) ((disable definedp s-programs-okp s-programs-properp))) (prove-lemma S-GOOD-STATEP-S-SET-EXPR (rewrite) (implies (and (s-good-statep s1 c) (s-good-statep s2 c) (equal (s-prog s1) (s-prog s2))) (s-good-statep (s-set-expr s1 s2 pos) c)) ((enable s-good-statep-backchainer-2 s-good-statep-strip-cars-temps) (expand (s-good-statep (s-set-expr s1 s2 pos) c)) (disable definedp s-programs-okp s-programs-properp temps-okp))) (disable s-good-statep-strip-cars-temps) (prove-lemma S-PROGRAMS-PROPERP-S-PROPER-EXPRP () (implies (and (s-programs-properp progs program-names) (member prog progs)) (s-proper-exprp t (s-body prog) program-names (s-formals prog) (s-temp-list prog))) ((disable s-proper-exprp))) (prove-lemma S-GOOD-STATEP-S-PROPER-EXPRP (rewrite) (implies (s-good-statep s c) (s-proper-exprp t (s-body (s-prog s)) (strip-logic-fnames (cdr (s-progs s))) (s-formals (s-prog s)) (s-temp-list (s-prog s)))) ((enable s-prog) (use (s-programs-properp-s-proper-exprp (progs (s-progs s)) (program-names (strip-logic-fnames (cdr (s-progs s)))) (prog (s-prog s)))) (disable s-proper-exprp s-programs-properp))) (prove-lemma S-GOOD-STATEP-S-TEMP-LIST () (implies (s-good-statep s c) (equal (member x (s-temp-list (s-prog s))) (definedp x (s-temps s)))) ((disable member-plist) (use (member-strip-cars-definedp (x x) (y (s-temps s))) (member-plist (y (s-temp-list (s-prog s))) (x x))))) (disable s-good-statep) (prove-lemma S-PROPER-EXPRP-LIST-S-PROPER-GET-T (rewrite) (implies (and (lessp n (length expr)) (plistp expr) (s-proper-exprp 'list expr p-names formals temp-list)) (s-proper-exprp t (get n expr) p-names formals temp-list)) ((enable get) (induct (get n expr)))) (prove-lemma S-PROPER-EXPRP-T-S-PROPER-GET-T (rewrite) (implies (and (not (equal (car expr) (s-temp-fetch))) (not (equal (car expr) (s-temp-eval))) (not (equal (car expr) (s-temp-test))) (not (equal (car expr) 'quote)) (s-proper-exprp t expr p-names formals temp-list) (not (zerop n)) (lessp n (length expr))) (s-proper-exprp t (get n expr) p-names formals temp-list)) ((enable get-cons) (expand (s-proper-exprp t expr p-names formals temp-list)))) (disable s-proper-exprp-list-s-proper-get-t) (prove-lemma S-PROPER-EXPRP-S-PROPER-EXPRP-CUR-EXPR (rewrite) (implies (and (s-proper-exprp t body p-names formals temp-list) (good-posp1 pos body)) (s-proper-exprp t (cur-expr pos body) p-names formals temp-list)) ((enable good-posp1))) (prove-lemma S-GOOD-STATEP-S-PROPER-EXPRP-CUR-EXPR () (implies (and (s-good-statep s c) (good-posp1 (s-pos s) (s-body (s-prog s)))) (s-proper-exprp t (s-expr s) (strip-logic-fnames (cdr (s-progs s))) (s-formals (s-prog s)) (s-temp-list (s-prog s)))) ((enable s-expr) (use (s-proper-exprp-s-proper-exprp-cur-expr (body (s-body (s-prog s))) (p-names (strip-logic-fnames (cdr (s-progs s)))) (formals (s-formals (s-prog s))) (temp-list (s-temp-list (s-prog s))) (pos (s-pos s)))) (disable s-proper-exprp s-programs-properp))) (prove-lemma S-PROPER-EXPRP-DEFINEDP () (implies (and (s-proper-exprp t body p-names formals temp-list) (or (equal (car body) (s-temp-eval)) (equal (car body) (s-temp-fetch)) (equal (car body) (s-temp-test)))) (member (cadr body) temp-list))) (prove-lemma S-GOOD-STATEP-DEFINEDP-TEMPS (rewrite) (implies (and (s-good-statep s c) (good-posp1 (s-pos s) (s-body (s-prog s))) (or (equal (car (s-expr s)) (s-temp-eval)) (equal (car (s-expr s)) (s-temp-fetch)) (equal (car (s-expr s)) (s-temp-test)))) (definedp (cadr (s-expr s)) (s-temps s))) ((enable s-expr) (use (s-good-statep-s-proper-exprp-cur-expr (s s) (c c)) (s-good-statep-s-temp-list (s s) (x (cadr (s-expr s)))) (s-proper-exprp-definedp (body (s-expr s)) (p-names (strip-logic-fnames (cdr (s-progs s)))) (formals (s-formals (s-prog s))) (temp-list (s-temp-list (s-prog s))))))) (prove-lemma STRIP-CARS-S-TEMPS-S-EVAL (rewrite) (implies (equal (s-err-flag (s-eval flag state clock)) 'run) (equal (strip-cars (s-temps (s-eval flag state clock))) (strip-cars (s-temps state)))) ((enable s-change-temp))) (prove-lemma TEMPS-OKP-MAKE-TEMPS-ENTRIES (rewrite) (temps-okp (make-temps-entries x) params c)) (prove-lemma L-EVAL-FLAG-NOT-LIST () (implies (not (equal flag 'list)) (equal (l-eval flag expr params clock) (l-eval t expr params clock)))) (prove-lemma STRIP-CARS-MAKE-TEMPS-ENTRIES (rewrite) (equal (strip-cars (make-temps-entries x)) (plist x))) (prove-lemma S-ERR-FLAG-S-EVAL-FLAG-LIST-FLAG-T (rewrite) (implies (and (equal (s-err-flag (s-eval 'list (s-set-expr (s-eval t s c) s (nx (s-pos s))) c)) 'run) (listp (s-expr-list s))) (equal (s-err-flag (s-eval t s c)) 'run)) ((do-not-induct t))) (prove-lemma GOOD-POSP1-APPEND (rewrite) (equal (good-posp1 (append pos1 pos2) body) (and (good-posp1 pos1 body) (good-posp1 pos2 (cur-expr pos1 body)))) ((induct (good-posp1 pos1 body)) (enable good-posp1))) (prove-lemma CUR-EXPR-NLISTP (rewrite) (implies (nlistp expr) (equal (listp (cur-expr pos expr)) f)) ((enable get-anything-nil))) (prove-lemma GOOD-POSP1-NLISTP (rewrite) (implies (not (listp pos)) (good-posp1 pos body)) ((enable good-posp1))) (prove-lemma GOOD-POSP1-LIST-GOOD-POSP-LIST-T (rewrite) (implies (and (good-posp1 (butlast pos) body) (good-posp-list (car (last pos)) (cur-expr (butlast pos) body)) (listp (restn (car (last pos)) (cur-expr (butlast pos) body))) (listp pos)) (good-posp1 pos body)) ((use (good-posp1-append (pos1 (butlast pos)) (pos2 (last pos)) (body body))) (expand (good-posp1 (last pos) (cur-expr (butlast pos) body))) (disable cur-expr))) (prove-lemma GOOD-POSP-FLAG-NOT-LIST-GOOD-POSP1 (rewrite) (implies (not (equal flag 'list)) (equal (good-posp flag pos body) (good-posp1 pos body))) ((enable good-posp))) (prove-lemma GOOD-POSP-LIST-T (rewrite) (implies (and (good-posp 'list (s-pos s) (s-body (s-prog s))) (listp (s-expr-list s)) (listp (s-pos s))) (good-posp1 (s-pos s) (s-body (s-prog s)))) ((enable good-posp s-expr-list) (disable good-posp-list))) (prove-lemma S-PROG-S-EVAL-DO-S-TEMP-FETCH (rewrite) (equal (s-prog (s-eval-do-temp-fetch state)) (s-prog state)) ((enable s-prog))) (prove-lemma S-PROG-S-EVAL (rewrite) (implies (equal (s-err-flag (s-eval flag s c)) 'run) (equal (s-prog (s-eval flag s c)) (s-prog s))) ((enable s-prog))) (prove-lemma GOOD-POSP-LIST-NX (rewrite) (implies (and (good-posp 'list (s-pos s) (s-body (s-prog s))) (listp (s-pos s)) (listp (s-expr-list s))) (good-posp 'list (nx (s-pos s)) (s-body (s-prog s)))) ((enable good-posp s-expr-list))) (prove-lemma CAR-S-EXPR-LIST-S-EXPR (rewrite) (implies (and (listp (s-expr-list s)) (listp (s-pos s))) (equal (car (s-expr-list s)) (s-expr s))) ((enable s-expr-list s-expr) (use (cur-expr-append (pos1 (butlast (s-pos s))) (pos2 (last (s-pos s))) (body (s-body (s-prog s))))) (disable cur-expr-append))) (prove-lemma L-EVAL-S-EXPAND-TEMPS-FLAG-LIST-FACT-1 () (equal (l-eval 'list (s-expand-temps 'list body) params clock) (if (listp body) (cons (l-eval t (s-expand-temps t (car body)) params clock) (l-eval 'list (s-expand-temps 'list (cdr body)) params clock)) nil))) ;; The rewrite rule l-eval-s-expand-temps-flag-list-fact-1 had body ;; in place of (restn (car (last (s-pos s))) (s-expr s)), but this cause ;; infinite rewriting, so I changed it to block rewriting after doing ;; it once. (prove-lemma L-EVAL-S-EXPAND-TEMPS-FLAG-LIST-S-EXPR-FACT-1 (rewrite) (equal (l-eval 'list (s-expand-temps 'list (s-expr-list s)) params clock) (if (listp (s-expr-list s)) (cons (l-eval t (s-expand-temps t (car (s-expr-list s))) params clock) (l-eval 'list (s-expand-temps 'list (cdr (s-expr-list s))) params clock)) nil)) ((use (l-eval-s-expand-temps-flag-list-fact-1 (body (s-expr-list s)) (params params) (clock clock))) (disable l-eval s-expand-temps))) (prove-lemma L-EVAL-S-EXPAND-TEMPS-LITATOM-FACT-1 (rewrite) (implies (and (not (zerop clock)) (litatom body) (not (equal flag 'list))) (equal (l-eval flag (s-expand-temps flag body) params clock) (list (cdr (assoc body params)))))) (prove-lemma S-PROPER-EXPRP-LENGTH-CUR-EXPR () (implies (and (s-proper-exprp t expr p-names formals temp-list) (listp expr) (or (subrp (car expr)) (body (car expr))) (not (equal (car expr) 'quote))) (equal (length expr) (add1 (arity (car expr))))) ((disable s-proper-exprp) (expand (s-proper-exprp t expr p-names formals temp-list)))) (prove-lemma GOOD-POSP1-CONS-LESSP-4-IF (rewrite) (implies (and (equal (car (s-expr s)) 'if) (s-good-statep s c)) (and (equal (good-posp1 (dv (s-pos s) 1) (s-body (s-prog s))) (good-posp1 (s-pos s) (s-body (s-prog s)))) (equal (good-posp1 (dv (s-pos s) 2) (s-body (s-prog s))) (good-posp1 (s-pos s) (s-body (s-prog s)))) (equal (good-posp1 (dv (s-pos s) 3) (s-body (s-prog s))) (good-posp1 (s-pos s) (s-body (s-prog s)))))) ((enable dv s-expr) (expand (good-posp1 '(1) (cur-expr (s-pos s) (s-body (s-prog s)))) (good-posp1 '(2) (cur-expr (s-pos s) (s-body (s-prog s)))) (good-posp1 '(3) (cur-expr (s-pos s) (s-body (s-prog s))))) (use (s-proper-exprp-length-cur-expr (expr (s-expr s)) (p-names (strip-logic-fnames (cdr (s-progs s)))) (formals (s-formals (s-prog s))) (temp-list (s-temp-list (s-prog s)))) (s-good-statep-s-proper-exprp-cur-expr (s s) (c c))) (disable cur-expr s-proper-exprp))) (prove-lemma L-EVAL-IF-FACT-1 (rewrite) (implies (and (equal (car expr) 'if) (not (equal flag 'list))) (equal (l-eval flag (s-expand-temps flag expr) params clock) (if (l-eval t (s-expand-temps t (cadr expr)) params clock) (if (car (l-eval t (s-expand-temps t (cadr expr)) params clock)) (l-eval t (s-expand-temps t (caddr expr)) params clock) (l-eval t (s-expand-temps t (cadddr expr)) params clock)) f))) ((expand (s-expand-temps flag expr)))) (prove-lemma S-GOOD-STATEP-S-EVAL-DO-TEMP-FETCH (rewrite) (implies (and (s-good-statep s c) (s-temp-setp (cadr (s-expr s)) (s-temps s))) (s-good-statep (s-eval-do-temp-fetch s) c)) ((enable s-good-statep get-anything-nil))) (prove-lemma GOOD-POSP1-DV-1-TEMPS (rewrite) (implies (and (or (equal (car (s-expr s)) (s-temp-eval)) (equal (car (s-expr s)) (s-temp-test))) (good-posp1 (s-pos s) (s-body (s-prog s)))) (good-posp1 (dv (s-pos s) 1) (s-body (s-prog s)))) ((enable dv s-expr) (expand (good-posp1 '(1) (cur-expr (s-pos s) (s-body (s-prog s))))))) (prove-lemma S-EVAL-L-EVAL-S-TEMPS (rewrite) (implies (and (not (equal flag 'list)) (or (equal (car expr) (s-temp-eval)) (equal (car expr) (s-temp-fetch)) (equal (car expr) (s-temp-test)))) (equal (l-eval flag (s-expand-temps flag expr) params clock) (l-eval t (s-expand-temps t (cadr expr)) params clock))) ((use (l-eval-flag-not-list (flag flag) (expr (s-expand-temps t (cadr expr))) (params params))))) (prove-lemma L-EVAL-QUOTE-FACT-1 (rewrite) (implies (and (equal (car expr) 'quote) (not (equal flag 'list)) (not (zerop clock))) (equal (l-eval flag (s-expand-temps flag expr) params clock) (list (cadr expr))))) (prove-lemma LISTP-NOT-LESSP-LENGTH-1 (rewrite) (implies (listp x) (equal (lessp (length x) 1) f))) (disable listp-not-lessp-length-1) (prove-lemma GOOD-POSP1-PLIST (rewrite) (equal (good-posp1 (plist pos) body) (good-posp1 pos body)) ((enable good-posp1))) (prove-lemma GOOD-POSP-DV-1-FUNCALL (rewrite) (implies (and (listp (s-expr s)) (not (equal (car (s-expr s)) 'if)) (not (equal (car (s-expr s)) (s-temp-eval))) (not (equal (car (s-expr s)) (s-temp-test))) (not (equal (car (s-expr s)) (s-temp-fetch))) (not (equal (car (s-expr s)) 'quote)) (good-posp1 (s-pos s) (s-body (s-prog s)))) (good-posp 'list (dv (s-pos s) 1) (s-body (s-prog s)))) ((enable dv s-expr good-posp good-posp1 listp-not-lessp-length-1) (expand (cur-expr (s-pos s) (s-body (s-prog s))) (cur-expr nil (s-body (s-prog s)))) (disable cur-expr))) (prove-lemma L-EVAL-S-EXPAND-TEMPS-SUBRP-FACT-1 (rewrite) (implies (and (subrp (car e)) (not (equal (car e) 'if)) (not (zerop clock)) (not (member f (l-eval 'list (s-expand-temps 'list (cdr e)) params clock))) (not (equal flag 'list))) (equal (l-eval flag (s-expand-temps flag e) params clock) (list (apply-subr (car e) (strip-cars (l-eval 'list (s-expand-temps 'list (cdr e)) params clock)))))) ((expand (s-expand-temps flag e)) (disable s-expand-temps))) (prove-lemma LOGIC-FNAME-USER-FNAME-IDENTITY (rewrite) (implies (litatom x) (equal (logic-fname (user-fname x)) x)) ((enable logic-fname user-fname))) (prove-lemma USER-FNAME-LOGIC-FNAME-IDENTITY (rewrite) (implies (user-fnamep x) (equal (user-fname (logic-fname x)) x)) ((enable logic-fname user-fname user-fnamep))) (prove-lemma MEMBER-STRIP-LOGIC-FNAMES-DEFINEDP (rewrite) (implies (and (all-user-fnamesp (strip-cars y)) (litatom x)) (equal (member x (strip-logic-fnames y)) (definedp (user-fname x) y)))) (prove-lemma S-PROGRAMS-OKP-ALL-USER-FNAMESP-STRIP-CARS (rewrite) (implies (s-programs-okp programs) (all-user-fnamesp (strip-cars programs)))) (prove-lemma S-PROPER-EXPRP-DEFINEDP-PROGRAMS () (implies (and (s-proper-exprp t body (strip-logic-fnames programs) formals temp-list) (listp body) (s-programs-okp programs) (not (subrp (car body))) (not (equal (car body) 'quote)) (litatom (car body))) (definedp (user-fname (car body)) programs)) ((enable member-strip-cars-definedp))) (prove-lemma S-GOOD-STATEP-S-FUN-CALL-STATE (rewrite) (implies (and (s-good-statep s1 c) (s-good-statep s2 c) (listp (s-expr s1)) (not (equal (car (s-expr s1)) 'if)) (not (equal (car (s-expr s1)) 'quote)) (not (subrp (car (s-expr s1)))) (litatom (car (s-expr s1))) (good-posp1 (s-pos s1) (s-body (s-prog s1))) (equal (s-progs s1) (s-progs s2))) (s-good-statep (s-fun-call-state s2 (car (s-expr s1))) (sub1 c))) ((use (s-proper-exprp-definedp-programs (body (s-expr s1)) (programs (cdr (s-progs s1))) (temp-list (s-temp-list (s-prog s1))) (formals (s-formals (s-prog s1)))) (s-good-statep-s-proper-exprp-cur-expr (s s1) (c c))) (expand (s-good-statep (s-fun-call-state s2 (car (s-expr s1))) (sub1 c)) (s-prog (s-fun-call-state s2 (car (s-expr s1)))) (definedp (user-fname (car (s-expr s1))) (s-progs s1))) (enable s-good-statep-backchainer-2-5 s-good-statep-strip-cars-temps) (disable definedp s-programs-okp s-programs-properp temps-okp))) (prove-lemma GOOD-POSP1-FLAG-NOT-LIST-NIL (rewrite) (good-posp1 nil body) ((enable good-posp1))) (prove-lemma L-EVAL-S-EXPAND-TEMPS-NOT-SUBRP-FACT-1 (rewrite) (implies (and (not (subrp (car e))) (listp e) (not (listp (car e))) (not (zerop clock)) (not (equal (car e) 'quote)) (not (member f (l-eval 'list (s-expand-temps 'list (cdr e)) params clock))) (not (equal flag 'list))) (equal (l-eval flag (s-expand-temps flag e) params clock) (l-eval t (body (car e)) (pairlist (formals (car e)) (strip-cars (l-eval 'list (s-expand-temps 'list (cdr e)) params clock))) (sub1 clock)))) ((expand (s-expand-temps flag e) (l-eval flag (cons (car e) (s-expand-temps 'list (cdr e))) params clock)))) (prove-lemma S-PROGRAMS-OKP-FORMALS-BODY () (implies (and (s-programs-okp progs) (member prog progs)) (and (equal (s-formals prog) (formals (logic-fname (car prog)))) (equal (s-expand-temps t (s-body prog)) (body (logic-fname (car prog))))))) (prove-lemma S-GOOD-STATEP-NOT-CAR-S-EXPR-CAAR-S-PROGS (rewrite) (implies (and (good-posp1 (s-pos s) (s-body (s-prog s))) (listp (s-expr s)) (not (equal (car (s-expr s)) 'quote)) (not (subrp (car (s-expr s)))) (litatom (car (s-expr s))) (listp (s-progs s)) (equal (user-fname (car (s-expr s))) (caar (s-progs s)))) (not (s-good-statep s c))) ((enable s-expr s-good-statep-backchainer-2 s-good-statep-backchainer-2-5) (use (s-proper-exprp-definedp-programs (body (s-expr s)) (programs (cdr (s-progs s))) (formals (s-formals (s-prog s))) (temp-list (s-temp-list (s-prog s)))) (s-good-statep-s-proper-exprp-cur-expr (s s) (c c))))) (disable s-good-statep-not-car-s-expr-caar-s-progs) (prove-lemma S-EXPAND-TEMPS-S-EXPR-S-FUN-CALL-STATE (rewrite) (implies (and (s-good-statep s1 c) (s-good-statep s2 c) (listp (s-expr s1)) (good-posp1 (s-pos s1) (s-body (s-prog s1))) (not (equal (car (s-expr s1)) 'quote)) (not (subrp (car (s-expr s1)))) (litatom (car (s-expr s1))) (equal (s-progs s1) (s-progs s2))) (equal (s-expand-temps t (s-expr (s-fun-call-state s2 (car (s-expr s1))))) (body (car (s-expr s1))))) ((enable s-expr s-prog s-good-statep-not-car-s-expr-caar-s-progs) (expand (assoc (user-fname (car (cur-expr (s-pos s1) (s-body (assoc (s-pname s1) (s-progs s1)))))) (s-progs s1))) (use (s-programs-okp-formals-body (progs (cdr (s-progs s1))) (program-names (strip-logic-fnames (cdr (s-progs s1)))) (prog (assoc (user-fname (car (s-expr s1))) (s-progs s1)))) (s-proper-exprp-definedp-programs (body (s-expr s1)) (programs (cdr (s-progs s1))) (formals (s-formals (s-prog s1))) (temp-list (s-temp-list (s-prog s1)))) (s-good-statep-s-proper-exprp-cur-expr (s s1) (c c))) (disable s-expand-temps s-proper-exprp s-good-statep-s-proper-exprp))) (prove-lemma S-GOOD-STATEP-FORMALS (rewrite) (implies (and (s-good-statep s c) (listp (s-expr s)) (not (equal (car (s-expr s)) 'if)) (not (equal (car (s-expr s)) 'quote)) (not (subrp (car (s-expr s)))) (good-posp1 (s-pos s) (s-body (s-prog s))) (litatom (car (s-expr s)))) (equal (s-formals (assoc (user-fname (car (s-expr s))) (s-progs s))) (formals (car (s-expr s))))) ((use (s-programs-okp-formals-body (progs (cdr (s-progs s))) (prog (assoc (user-fname (car (s-expr s))) (s-progs s)))) (s-proper-exprp-definedp-programs (body (s-expr s)) (programs (cdr (s-progs s))) (formals (s-formals (s-prog s))) (temp-list (s-temp-list (s-prog s)))) (s-good-statep-s-proper-exprp-cur-expr (s s) (c c))) (enable s-good-statep-not-car-s-expr-caar-s-progs s-good-statep-backchainer-2))) (prove-lemma DEFINEDP-TEMPS-OKP () (implies (and (temps-okp temps params c) (definedp expr temps) (s-temp-setp expr temps)) (and (l-eval t (s-expand-temps t expr) params c) (equal (car (l-eval t (s-expand-temps t expr) params c)) (s-temp-value expr temps)))) ((enable s-temp-setp))) (prove-lemma L-EVAL-S-EVAL-DO-TEMP-FETCH-FACT-1 (rewrite) (implies (and (good-posp1 (s-pos s) (s-body (s-prog s))) (listp (s-expr s)) (or (equal (car (s-expr s)) (s-temp-fetch)) (equal (car (s-expr s)) (s-temp-test))) (s-temp-setp (cadr (s-expr s)) (s-temps s)) (s-good-statep s c)) (and (l-eval t (s-expand-temps t (cadr (s-expr s))) (s-params s) c) (equal (car (l-eval t (s-expand-temps t (cadr (s-expr s))) (s-params s) c)) (s-ans (s-eval-do-temp-fetch s))))) ((enable s-eval-do-temp-fetch) (use (definedp-temps-okp (temps (s-temps s)) (c c) (expr (cadr (s-expr s))) (params (s-params s)))) (disable s-expand-temps))) (prove-lemma S-EVAL-L-EVAL-EQUIVALENCE () (implies (and (s-good-statep s c) (good-posp flag (s-pos s) (s-body (s-prog s))) (equal (s-err-flag (s-eval flag s c)) 'run)) (and (s-good-statep (s-eval flag s c) c) (if (equal flag 'list) (and (not (member f (l-eval flag (s-expand-temps flag (s-expr-list s)) (s-params s) c))) (equal (s-ans (s-eval flag s c)) (strip-cars (l-eval flag (s-expand-temps flag (s-expr-list s)) (s-params s) c)))) (and (l-eval flag (s-expand-temps flag (s-expr s)) (s-params s) c) (equal (s-ans (s-eval flag s c)) (car (l-eval flag (s-expand-temps flag (s-expr s)) (s-params s) c))))))) ((induct (s-eval flag s c)) (disable s-eval l-eval s-expand-temps) (expand (s-eval flag s c) (s-eval 'list s c) (s-eval flag s 0)) (do-not-induct t))) (prove-lemma S-EVAL-S-GOOD-STATEP (rewrite) (implies (and (s-good-statep s c) (good-posp flag (s-pos s) (s-body (s-prog s))) (equal (s-err-flag (s-eval flag s c)) 'run)) (s-good-statep (s-eval flag s c) c)) ((do-not-induct t) (use (s-eval-l-eval-equivalence (flag flag) (s s) (c c))))) (prove-lemma S-EVAL-L-EVAL-FLAG-T (rewrite) (implies (and (s-good-statep s c) (good-posp1 (s-pos s) (s-body (s-prog s))) (equal (s-err-flag (s-eval t s c)) 'run)) (and (l-eval t (s-expand-temps t (s-expr s)) (s-params s) c) (equal (s-ans (s-eval t s c)) (car (l-eval t (s-expand-temps t (s-expr s)) (s-params s) c))))) ((do-not-induct t) (use (s-eval-l-eval-equivalence (flag t) (s s) (c c))))) (defn S-COLLECT-ALL-TEMPS (flag expr) (if (equal flag 'list) (if (listp expr) (append (s-collect-all-temps t (car expr)) (s-collect-all-temps 'list (cdr expr))) nil) (if (listp expr) (cond ((or (equal (car expr) (s-temp-test)) (equal (car expr) (s-temp-eval))) (cons (cadr expr) (s-collect-all-temps t (cadr expr)))) ((equal (car expr) (s-temp-fetch)) (s-collect-all-temps t (cadr expr))) ((equal (car expr) 'quote) nil) ((equal (car expr) 'if) (append (s-collect-all-temps t (cadr expr)) (bagint (s-collect-all-temps t (caddr expr)) (s-collect-all-temps t (cadddr expr))))) (t (s-collect-all-temps 'list (cdr expr)))) nil))) ;; This takes an expression (appropriate for s-eval) and makes sure ;; that all the temp-fetch forms will have the setp flag set. ;; temp-set is a set of expressions that can be assumed to have been evaluated (defn S-ALL-TEMPS-SETP (flag expr temp-set) (if (equal flag 'list) (if (listp expr) (and (s-all-temps-setp t (car expr) temp-set) (s-all-temps-setp 'list (cdr expr) (append (s-collect-all-temps t (car expr)) temp-set))) t) (if (listp expr) (cond ((or (equal (car expr) (s-temp-eval)) (equal (car expr) (s-temp-test))) (s-all-temps-setp t (cadr expr) temp-set)) ((equal (car expr) (s-temp-fetch)) (member (cadr expr) temp-set)) ((equal (car expr) 'quote) t) ((equal (car expr) 'if) (if (s-all-temps-setp t (cadr expr) temp-set) (let ((test-temp-set (s-collect-all-temps t (cadr expr)))) (and (s-all-temps-setp t (caddr expr) (append test-temp-set temp-set)) (s-all-temps-setp t (cadddr expr) (append test-temp-set temp-set)))) f)) (t (s-all-temps-setp 'list (cdr expr) temp-set))) t))) (defn TEMP-ALIST-TO-SET-1 (alist acc) ;; returns all the things that assoc to t, except those in acc (if (listp alist) (if (and (listp (car alist)) (cadar alist) (not (member (caar alist) acc))) (cons (caar alist) (temp-alist-to-set-1 (cdr alist) (cons (caar alist) acc))) (temp-alist-to-set-1 (cdr alist) (cons (caar alist) acc))) nil)) (prove-lemma TEMP-ALIST-TO-SET-1-GIVES-MEMBERS (rewrite) (equal (member x (temp-alist-to-set-1 alist acc)) (and (listp (assoc x alist)) (s-temp-setp x alist) (not (member x acc)))) ((enable s-temp-setp))) (defn TEMP-ALIST-TO-SET (alist) (temp-alist-to-set-1 alist nil)) (disable TEMP-ALIST-TO-SET) (prove-lemma TEMP-ALIST-TO-SET-GIVES-MEMBERS (rewrite) (equal (member x (temp-alist-to-set alist)) (and (listp (assoc x alist)) (s-temp-setp x alist))) ((enable temp-alist-to-set))) (defn S-CHECK-TEMPS-SETP-1 (exprs temp-set) (if (listp exprs) (and (or (not (member (car exprs) temp-set)) (subsetp (s-collect-all-temps t (car exprs)) temp-set)) (s-check-temps-setp-1 (cdr exprs) temp-set)) t)) (defn GOOD-ALISTP (alist) (if (listp alist) (and (listp (car alist)) (good-alistp (cdr alist))) t)) (prove-lemma GOOD-ALISTP-LISTP-ASSOC (rewrite) (implies (good-alistp alist) (iff (definedp expr alist) (listp (assoc expr alist))))) (disable GOOD-ALISTP-LISTP-ASSOC) (prove-lemma GOOD-ALISTP-PUT-ASSOC (rewrite) (implies (good-alistp alist) (good-alistp (put-assoc val expr alist)))) (defn S-CHECK-TEMPS-SETP (temp-alist) (and (good-alistp temp-alist) (s-check-temps-setp-1 (strip-cars temp-alist) (temp-alist-to-set temp-alist)))) (disable S-CHECK-TEMPS-SETP) (defn S-ALL-PROGS-TEMPS-SETP (progs) (if (listp progs) (and (s-all-temps-setp t (s-body (car progs)) nil) (s-check-temps-setp (make-temps-entries (s-temp-list (car progs)))) (s-all-progs-temps-setp (cdr progs))) t)) (disable S-ALL-PROGS-TEMPS-SETP) (prove-lemma SUBSETP-MEMBER (rewrite) (implies (and (subsetp set1 set2) (member x set1)) (member x set2))) (disable SUBSETP-MEMBER) (prove-lemma SUBSETP-APPEND-1 (rewrite) (equal (subsetp (append set1 set2) set3) (and (subsetp set1 set3) (subsetp set2 set3)))) (prove-lemma SUBSETP-CONS (rewrite) (implies (subsetp set1 set2) (subsetp set1 (cons x set2)))) (prove-lemma SUBSETP-REFLEXIVE (rewrite) (subsetp set set)) (prove-lemma SUBSETP-APPEND-2 (rewrite) (implies (or (subsetp set1 set2) (subsetp set1 set3)) (subsetp set1 (append set2 set3))) ((induct (append set1 set2)))) (prove-lemma TEMP-ALIST-TO-SET-1-SUBSETP () (implies (subsetp acc1 acc2) (subsetp (temp-alist-to-set-1 temp-alist acc2) (temp-alist-to-set-1 temp-alist acc1))) ((enable subsetp-member))) (prove-lemma TEMP-ALIST-TO-SET-1-NLISTP (rewrite) (implies (not (listp (temp-alist-to-set-1 alist acc))) (equal (temp-alist-to-set-1 alist acc) nil))) (prove-lemma TEMP-ALIST-TO-SET-1-CONS-NIL (rewrite) (implies (equal (temp-alist-to-set-1 temp-alist acc) nil) (equal (temp-alist-to-set-1 temp-alist (cons x acc)) nil)) ((use (temp-alist-to-set-1-subsetp (acc1 acc) (acc2 (cons x acc)) (temp-alist temp-alist))))) (prove-lemma TEMP-ALIST-TO-SET-1-MAKE-TEMP-ENTRIES (rewrite) (equal (temp-alist-to-set-1 (make-temps-entries temp-alist) acc) nil)) (prove-lemma TEMP-ALIST-TO-SET-MAKE-TEMP-ENTRIES (rewrite) (equal (temp-alist-to-set (make-temps-entries temp-alist)) nil) ((enable temp-alist-to-set) (use (temp-alist-to-set-1-make-temp-entries (temp-alist temp-alist) (acc nil))))) (prove-lemma S-ALL-TEMPS-SETP-SUBSETP () (implies (and (subsetp temp-set1 temp-set2) (s-all-temps-setp flag expr temp-set1)) (s-all-temps-setp flag expr temp-set2)) ((enable subsetp-member))) (prove-lemma SUBSETP-TRANSISTIVE (rewrite) (implies (and (subsetp set1 set2) (subsetp set2 set3)) (subsetp set1 set3)) ((enable subsetp-member))) (disable subsetp-transistive) (prove-lemma S-TEMP-SETP-PUT-ASSOC-1 (rewrite) (iff (s-temp-setp expr1 (put-assoc (cons t anything) expr2 temp-alist)) (if (equal expr1 expr2) t (s-temp-setp expr1 temp-alist))) ((enable s-temp-setp))) (prove-lemma LISTP-ASSOC-FACT-1 (rewrite) (implies (listp (assoc expr1 temp-alist)) (listp (assoc expr1 (put-assoc (cons x y) expr2 temp-alist))))) (prove-lemma SUBSETP-TEMP-ALIST-TO-SET-PUT-ASSOC-1 (rewrite) (implies (definedp expr temp-alist) (equal (subsetp set1 (temp-alist-to-set (put-assoc (cons t anything) expr temp-alist))) (subsetp set1 (cons expr (temp-alist-to-set temp-alist)))))) (prove-lemma SUBSETP-TEMP-ALIST-TO-SET-S-CHANGE-TEMP (rewrite) (implies (definedp expr (s-temps st)) (equal (subsetp set1 (temp-alist-to-set (s-temps (s-change-temp st expr val)))) (subsetp set1 (cons expr (temp-alist-to-set (s-temps st)))))) ((enable s-change-temp))) (prove-lemma NOT-DEFINEDP-PUT-ASSOC (rewrite) (implies (not (definedp expr temp-alist)) (equal (put-assoc anything expr temp-alist) temp-alist))) (prove-lemma SUBSETP-TRANS-FACT-2 (rewrite) (implies (subsetp set (temp-alist-to-set (s-temps st))) (subsetp set (temp-alist-to-set (s-temps (s-change-temp st expr value))))) ((use (subsetp-temp-alist-to-set-s-change-temp (expr expr) (st st) (val value) (temp-alist (s-temps st)) (set1 (temp-alist-to-set (s-temps st))))) (disable subsetp-temp-alist-to-set-s-change-temp) (enable s-change-temp subsetp-transistive))) (prove-lemma S-EVAL-TEMPS-SUBSETP (rewrite) (implies (equal (s-err-flag (s-eval flag s c)) 'run) (subsetp (temp-alist-to-set (s-temps s)) (temp-alist-to-set (s-temps (s-eval flag s c))))) ((enable subsetp-transistive))) (prove-lemma SUBSETP-DELETE (rewrite) (implies (subsetp set1 set2) (subsetp (delete x set1) set2))) (prove-lemma SUBSETP-BAGINT (rewrite) (implies (or (subsetp set1 set3) (subsetp set2 set3)) (subsetp (bagint set1 set2) set3)) ((enable subsetp-member))) (prove-lemma L-EVAL-ZEROP-CLOCK (rewrite) (implies (and (zerop clock) (not (equal flag 'list))) (equal (l-eval flag expr params clock) f))) (prove-lemma S-EVAL-TEMPS-SUBSETP-S-SET-POS (rewrite) (implies (equal (s-err-flag (s-eval t (s-set-pos s pos) c)) 'run) (subsetp (temp-alist-to-set (s-temps s)) (temp-alist-to-set (s-temps (s-eval t (s-set-pos s pos) c))))) ((use (s-eval-temps-subsetp (s (s-set-pos s pos)) (flag t) (c c))) (disable s-eval-temps-subsetp))) (prove-lemma S-ALL-TEMPS-SETP-SUBSETP-IF-CADDR (rewrite) (let ((test (s-eval t (s-set-pos s (dv (s-pos s) 1)) c))) (let ((set1 (s-collect-all-temps t (cadr (s-expr s)))) (set2 (temp-alist-to-set (s-temps test))) (set3 (temp-alist-to-set (s-temps s)))) (implies (and (equal (s-err-flag test) 'run) (equal (car (s-expr s)) 'if) (s-all-temps-setp t (caddr (s-expr s)) (append set1 set3)) (subsetp set1 set2)) (s-all-temps-setp t (caddr (s-expr s)) set2)))) ((use (s-all-temps-setp-subsetp (expr (caddr (s-expr s))) (flag t) (temp-set1 (append (s-collect-all-temps t (cadr (s-expr s))) (temp-alist-to-set (s-temps s)))) (temp-set2 (temp-alist-to-set (s-temps (s-eval t (s-set-pos s (dv (s-pos s) 1)) c)))))) (enable subsetp-transistive))) (prove-lemma S-ALL-TEMPS-SETP-SUBSETP-IF-CADDDR (rewrite) (let ((test (s-eval t (s-set-pos s (dv (s-pos s) 1)) c))) (let ((set1 (s-collect-all-temps t (cadr (s-expr s)))) (set2 (temp-alist-to-set (s-temps test))) (set3 (temp-alist-to-set (s-temps s)))) (implies (and (equal (s-err-flag test) 'run) (equal (car (s-expr s)) 'if) (s-all-temps-setp t (cadddr (s-expr s)) (append set1 set3)) (subsetp (s-collect-all-temps t (cadr (s-expr s))) set2)) (s-all-temps-setp t (cadddr (s-expr s)) set2)))) ((use (s-all-temps-setp-subsetp (expr (cadddr (s-expr s))) (flag t) (temp-set1 (append (s-collect-all-temps t (cadr (s-expr s))) (temp-alist-to-set (s-temps s)))) (temp-set2 (temp-alist-to-set (s-temps (s-eval t (s-set-pos s (dv (s-pos s) 1)) c)))))) (enable subsetp-transistive))) (prove-lemma S-EVAL-TEMPS-SUBSETP-S-SET-EXPR (rewrite) (implies (equal (s-err-flag (s-eval t (s-set-expr s1 s2 e) c)) 'run) (subsetp (temp-alist-to-set (s-temps s1)) (temp-alist-to-set (s-temps (s-eval t (s-set-expr s1 s2 e) c))))) ((use (s-eval-temps-subsetp (s (s-set-expr s1 s2 e)) (flag t) (c c))) (disable s-eval-temps-subsetp))) (prove-lemma S-EVAL-L-EVAL-FLAG-RUN-HELPER-1 (rewrite) (let ((test (s-eval t (s-set-pos s (dv (s-pos s) 1)) c))) (implies (and (equal (s-err-flag s) 'run) (equal (car (s-expr s)) 'if) (equal (s-err-flag test) 'run) (equal (s-err-flag (s-eval t (s-set-expr test s (dv (s-pos s) 2)) c)) 'run) (subsetp (s-collect-all-temps t (caddr (s-expr s))) (temp-alist-to-set (s-temps (s-eval t (s-set-expr test s (dv (s-pos s) 2)) c)))) (subsetp (s-collect-all-temps t (cadr (s-expr s))) (temp-alist-to-set (s-temps test)))) (subsetp (s-collect-all-temps t (cadr (s-expr s))) (temp-alist-to-set (s-temps (s-eval t (s-set-expr test s (dv (s-pos s) 2)) c)))))) ((do-not-induct t) (enable subsetp-transistive))) (disable S-EVAL-L-EVAL-FLAG-RUN-HELPER-1) (prove-lemma S-EVAL-L-EVAL-FLAG-RUN-HELPER-2 (rewrite) (let ((test (s-eval t (s-set-pos s (dv (s-pos s) 1)) c))) (implies (and (equal (s-err-flag s) 'run) (equal (car (s-expr s)) 'if) (equal (s-err-flag test) 'run) (equal (s-err-flag (s-eval t (s-set-expr test s (dv (s-pos s) 3)) clock)) 'run) (subsetp (s-collect-all-temps t (cadddr (s-expr s))) (temp-alist-to-set (s-temps (s-eval t (s-set-expr test s (dv (s-pos s) 3)) clock)))) (subsetp (s-collect-all-temps t (cadr (s-expr s))) (temp-alist-to-set (s-temps test)))) (subsetp (s-collect-all-temps t (cadr (s-expr s))) (temp-alist-to-set (s-temps (s-eval t (s-set-expr test s (dv (s-pos s) 3)) clock)))))) ((do-not-induct t) (enable subsetp-transistive))) (disable S-EVAL-L-EVAL-FLAG-RUN-HELPER-2) (prove-lemma S-TEMP-SETP-S-CHANGE-TEMP (rewrite) (iff (s-temp-setp expr1 (s-temps (s-change-temp state expr2 value))) (if (equal expr1 expr2) t (s-temp-setp expr1 (s-temps state)))) ((enable s-change-temp))) (prove-lemma S-GOOD-STATEP-LISTP-ASSOC-TEMPS (rewrite) (implies (and (s-good-statep s c) (s-check-temps-setp (s-temps s)) (or (equal (car (s-expr s)) (s-temp-fetch)) (equal (car (s-expr s)) (s-temp-eval)) (equal (car (s-expr s)) (s-temp-test))) (good-posp1 (s-pos s) (s-body (s-prog s)))) (listp (assoc (cadr (s-expr s)) (s-temps s)))) ((use (s-proper-exprp-definedp (body (s-expr s)) (p-names (strip-logic-fnames (cdr (s-progs s)))) (formals (s-formals (s-prog s1))) (temp-list (s-temp-list (s-prog s)))) (good-alistp-listp-assoc (alist (s-temps s)) (expr (cadr (s-expr s))))) (enable s-check-temps-setp) (disable s-proper-exprp))) (prove-lemma LISTP-ASSOC-S-CHANGE-TEMP (rewrite) (implies (and (s-good-statep s1 c) (or (equal (car (s-expr s1)) (s-temp-fetch)) (equal (car (s-expr s1)) (s-temp-eval)) (equal (car (s-expr s1)) (s-temp-test))) (good-posp1 (s-pos s1) (s-body (s-prog s1))) (equal (strip-cars (s-temps s1)) (strip-cars (s-temps s2)))) (listp (assoc (cadr (s-expr s1)) (s-temps (s-change-temp s2 (cadr (s-expr s1)) value))))) ((enable s-change-temp) (use (s-proper-exprp-definedp (body (s-expr s1)) (p-names (strip-logic-fnames (cdr (s-progs s1)))) (formals (s-formals (s-prog s1))) (temp-list (s-temp-list (s-prog s1)))) (s-good-statep-strip-cars-temps (s s1) (c c)) (member-strip-cars-definedp (x (cadr (s-expr s1))) (y (s-temps s2))) (member-plist (x (cadr (s-expr s1))) (y (s-temp-list (s-prog s1)))) (s-good-statep-s-proper-exprp-cur-expr (s s1) (c c))) (disable s-proper-exprp member-plist))) (prove-lemma S-CHECK-TEMPS-SETP-1-CONS-NON-MEMBER (rewrite) (implies (and (s-check-temps-setp-1 temp-list temp-set) (not (member expr temp-list))) (s-check-temps-setp-1 temp-list (cons expr temp-set)))) (prove-lemma S-CHECK-TEMPS-SETP-1-CONS-MEMBER () (implies (and (s-check-temps-setp-1 temp-list temp-set) (member expr temp-list) (subsetp (s-collect-all-temps t expr) temp-set)) (s-check-temps-setp-1 temp-list (cons expr temp-set)))) (prove-lemma S-CHECK-TEMPS-SETP-1-PUT-ASSOC () (implies (and (definedp expr temp-alist) (s-check-temps-setp-1 temp-list (cons expr (temp-alist-to-set temp-alist)))) (s-check-temps-setp-1 temp-list (temp-alist-to-set (put-assoc (cons t any) expr temp-alist))))) (prove-lemma S-CHECK-TEMPS-SETP-PUT-ASSOC (rewrite) (let ((cadr-s (s-eval t (s-set-pos s (dv (s-pos s) 1)) c))) (implies (and (s-good-statep s c) (good-posp1 (s-pos s) (s-body (s-prog s))) (s-check-temps-setp (s-temps cadr-s)) (subsetp (s-collect-all-temps t (cadr (s-expr s))) (temp-alist-to-set (s-temps cadr-s))) (or (equal (car (s-expr s)) (s-temp-test)) (equal (car (s-expr s)) (s-temp-eval)))) (s-check-temps-setp (s-temps (s-change-temp cadr-s (cadr (s-expr s)) value))))) ((use (s-check-temps-setp-1-cons-member (temp-list (strip-cars (s-temps (s-eval t (s-set-pos s (dv (s-pos s) 1)) c)))) (temp-set (temp-alist-to-set (s-temps (s-eval t (s-set-pos s (dv (s-pos s) 1)) c)))) (expr (cadr (s-expr s)))) (s-check-temps-setp-1-put-assoc (temp-list (strip-cars (s-temps (s-eval t (s-set-pos s (dv (s-pos s) 1)) c)))) (temp-alist (s-temps (s-eval t (s-set-pos s (dv (s-pos s) 1)) c))) (expr (cadr (s-expr s))) (any (list value)))) (enable s-check-temps-setp good-alistp-listp-assoc s-change-temp member-strip-cars-definedp) (disable s-check-temps-setp-1 s-eval subsetp))) (prove-lemma MEMBER-CHECK-S-TEMP-SETP-1-SUBSETP () (implies (and (s-check-temps-setp-1 temp-list set) (member expr set) (member expr temp-list)) (subsetp (s-collect-all-temps t expr) set))) (prove-lemma S-EVAL-L-EVAL-FLAG-RUN-HELPER-3 (rewrite) (implies (and (s-check-temps-setp (s-temps s)) (s-temp-setp (cadr (s-expr s)) (s-temps s)) (s-good-statep s c) (good-posp1 (s-pos s) (s-body (s-prog s))) (or (equal (car (s-expr s)) (s-temp-test)) (equal (car (s-expr s)) (s-temp-fetch)))) (subsetp (s-collect-all-temps t (cadr (s-expr s))) (temp-alist-to-set (s-temps s)))) ((enable s-check-temps-setp member-strip-cars-definedp) (use (member-check-s-temp-setp-1-subsetp (temp-list (strip-cars (s-temps s))) (set (temp-alist-to-set (s-temps s))) (expr (cadr (s-expr s))))) (do-not-induct t))) (prove-lemma S-EVAL-L-EVAL-FLAG-RUN-HELPER-5 (rewrite) (implies (and (member f (l-eval 'list (s-expand-temps 'list (cdr (s-expr state))) (s-params state) clock)) (listp (s-expr state)) (not (equal (car (s-expr state)) 'if)) (not (equal (car (s-expr state)) 'quote)) (not (equal (car (s-expr state)) (s-temp-eval))) (not (equal (car (s-expr state)) (s-temp-fetch))) (not (equal (car (s-expr state)) (s-temp-test))) (not (equal flag 'list))) (not (l-eval flag (s-expand-temps flag (s-expr state)) (s-params state) clock)))) (prove-lemma S-CHECK-TEMPS-SETP-MEMBER-PROGS () (implies (and (s-all-progs-temps-setp progs) (member x progs)) (s-check-temps-setp (make-temps-entries (s-temp-list x)))) ((enable s-all-progs-temps-setp))) (prove-lemma S-ALL-TEMPS-SETP-MEMBER-PROGS () (implies (and (s-all-progs-temps-setp progs) (member x progs)) (s-all-temps-setp t (s-body x) nil)) ((enable s-all-progs-temps-setp))) (prove-lemma S-CHECK-TEMPS-SETP-S-ALL-PROGS-TEMPS-SETP (rewrite) (implies (and (s-all-progs-temps-setp (s-progs s)) (not (subrp (car (s-expr s)))) (litatom (car (s-expr s))) (listp (s-expr s)) (not (equal (car (s-expr s)) 'quote)) (s-good-statep s c) (good-posp1 (s-pos s) (s-body (s-prog s)))) (s-check-temps-setp (make-temps-entries (s-temp-list (assoc (user-fname (car (s-expr s))) (s-progs s)))))) ((enable s-expr member-strip-cars-definedp) (use (s-check-temps-setp-member-progs (progs (s-progs s)) (x (assoc (user-fname (car (s-expr s))) (s-progs s)))) (s-proper-exprp-definedp-programs (body (s-expr s)) (programs (cdr (s-progs s))) (formals (s-formals (s-prog s))) (temp-list (s-temp-list (s-prog s)))) (s-proper-exprp-s-proper-exprp-cur-expr (body (s-body (s-prog s))) (p-names (strip-logic-fnames (cdr (s-progs s)))) (formals (s-formals (s-prog s))) (temp-list (s-temp-list (s-prog s))) (pos (s-pos s)))) (expand (definedp (user-fname (car (cur-expr (s-pos s) (s-body (s-prog s))))) (s-progs s))) (do-not-induct t))) (prove-lemma S-EVAL-L-EVAL-FLAG-RUN-HELPER-6 (rewrite) (implies (and (l-eval flag (s-expand-temps flag (s-expr s)) (s-params s) c) (not (equal flag 'list)) (listp (s-expr s)) (not (equal (car (s-expr s)) (s-temp-eval))) (not (equal (car (s-expr s)) (s-temp-test))) (not (equal (car (s-expr s)) (s-temp-fetch))) (not (subrp (car (s-expr s)))) (not (equal (car (s-expr s)) 'if)) (litatom (car (s-expr s))) (not (equal (car (s-expr s)) 'quote)) (s-good-statep s c) (good-posp1 (s-pos s) (s-body (s-prog s))) (equal (s-err-flag (s-eval 'list (s-set-pos s (dv (s-pos s) 1)) c)) 'run)) (l-eval t (body (car (s-expr s))) (pairlist (formals (car (s-expr s))) (s-ans (s-eval 'list (s-set-pos s (dv (s-pos s) 1)) c))) (sub1 c))) ((use (s-eval-l-eval-equivalence (flag 'list) (s (s-set-pos s (dv (s-pos s) 1))) (c c))) (expand (l-eval flag (cons (car (s-expr s)) (s-expand-temps 'list (cdr (s-expr s)))) (s-params s) c)))) (prove-lemma S-ALL-TEMPS-SETP-S-ALL-PROGS-TEMPS-SETP (rewrite) (implies (and (s-all-progs-temps-setp (s-progs s1)) (not (subrp (car (s-expr s1)))) (litatom (car (s-expr s1))) (not (equal (car (s-expr s1)) 'quote)) (s-good-statep s1 c) (good-posp1 (s-pos s1) (s-body (s-prog s1))) (equal (s-progs s1) (s-progs s2))) (s-all-temps-setp t (s-expr (s-fun-call-state s2 (car (s-expr s1)))) nil)) ((enable s-expr member-strip-cars-definedp) (use (s-all-temps-setp-member-progs (progs (s-progs s1)) (x (assoc (user-fname (car (s-expr s1))) (s-progs s1)))) (s-proper-exprp-definedp-programs (body (s-expr s1)) (programs (cdr (s-progs s1))) (formals (s-formals (s-prog s1))) (temp-list (s-temp-list (s-prog s1)))) (s-proper-exprp-s-proper-exprp-cur-expr (body (s-body (s-prog s1))) (p-names (strip-logic-fnames (cdr (s-progs s1)))) (formals (s-formals (s-prog s))) (temp-list (s-temp-list (s-prog s1))) (pos (s-pos s1))) (member-assoc (name (user-fname (car (s-expr s1)))) (alist (s-progs s1)))) (expand (s-prog (s-fun-call-state s2 (car (cur-expr (s-pos s1) (s-body (s-prog s1))))))) (disable member-assoc) (do-not-induct t))) (prove-lemma S-PROPER-EXPRP-FACT-2 (rewrite) (implies (and (good-posp1 (s-pos s) (s-body (s-prog s))) (not (litatom (s-expr s))) (not (listp (s-expr s)))) (not (s-good-statep s c))) ((use (s-proper-exprp-s-proper-exprp-cur-expr (body (s-body (s-prog s))) (p-names (strip-logic-fnames (cdr (s-progs s)))) (formals (s-formals (s-prog s))) (temp-list (s-temp-list (s-prog s))) (pos (s-pos s))) (s-good-statep-s-proper-exprp (s s) (c c))) (enable s-expr) (disable s-good-statep-s-proper-exprp s-proper-exprp-s-proper-exprp-cur-expr))) (prove-lemma S-ALL-TEMPS-SETP-SUBSETP-FLAG-LIST (rewrite) (implies (and (equal (s-err-flag (s-eval t s c)) 'run) (listp (s-expr-list s)) (listp (s-pos s)) (subsetp (s-collect-all-temps t (s-expr s)) (temp-alist-to-set (s-temps (s-eval t s c)))) (s-all-temps-setp 'list (cdr (s-expr-list s)) (append (s-collect-all-temps t (s-expr s)) (temp-alist-to-set (s-temps s))))) (s-all-temps-setp 'list (cdr (s-expr-list s)) (temp-alist-to-set (s-temps (s-eval t s c))))) ((use (s-all-temps-setp-subsetp (expr (cdr (s-expr-list s))) (flag 'list) (temp-set1 (append (s-collect-all-temps t (s-expr s)) (temp-alist-to-set (s-temps s)))) (temp-set2 (temp-alist-to-set (s-temps (s-eval t s c)))))))) (prove-lemma NOT-S-GOOD-STATEP-BAD-CAR-EXPR (rewrite) (implies (and (listp (s-expr s)) (not (equal (car (s-expr s)) 'if)) (not (equal (car (s-expr s)) (s-temp-eval))) (not (equal (car (s-expr s)) (s-temp-test))) (not (equal (car (s-expr s)) (s-temp-fetch))) (not (equal (car (s-expr s)) 'quote)) (not (litatom (car (s-expr s)))) (good-posp1 (s-pos s) (s-body (s-prog s)))) (not (s-good-statep s c))) ((use (s-proper-exprp-s-proper-exprp-cur-expr (body (s-body (s-prog s))) (p-names (strip-logic-fnames (cdr (s-progs s)))) (formals (s-formals (s-prog s))) (temp-list (s-temp-list (s-prog s))) (pos (s-pos s))) (s-good-statep-s-proper-exprp (s s) (c c))) (enable s-expr) (disable s-proper-exprp-s-proper-exprp-cur-expr))) (prove-lemma S-EVAL-L-EVAL-FLAG-RUN-HELPER-7 (rewrite) (implies (and (equal (s-err-flag (s-eval 'list (s-set-expr (s-eval t s c) s (nx (s-pos s))) c)) 'run) (listp (s-expr-list s)) (listp (s-pos s)) (subsetp (s-collect-all-temps t (s-expr s)) (temp-alist-to-set (s-temps (s-eval t s c)))) (subsetp (s-collect-all-temps 'list (cdr (s-expr-list s))) (temp-alist-to-set (s-temps (s-eval 'list (s-set-expr (s-eval t s c) s (nx (s-pos s))) c))))) (subsetp (s-collect-all-temps t (s-expr s)) (temp-alist-to-set (s-temps (s-eval 'list (s-set-expr (s-eval t s c) s (nx (s-pos s))) c))))) ((enable subsetp-transistive) (use (s-eval-temps-subsetp (flag 'list) (s (s-set-expr (s-eval t s c) s (nx (s-pos s)))) (c c))) (do-not-induct t))) (prove-lemma NOT-LISTP-POS-NOT-GOOD-POSP (rewrite) (implies (not (listp pos)) (not (good-posp 'list pos body))) ((enable good-posp))) (prove-lemma S-EVAL-L-EVAL-FLAG-RUN () (implies (and (s-good-statep s c) (good-posp flag (s-pos s) (s-body (s-prog s))) (s-all-temps-setp flag (if (equal flag 'list) (s-expr-list s) (s-expr s)) (temp-alist-to-set (s-temps s))) (s-all-progs-temps-setp (s-progs s)) (if (equal flag 'list) (not (member f (l-eval flag (s-expand-temps flag (s-expr-list s)) (s-params s) c))) (l-eval flag (s-expand-temps flag (s-expr s)) (s-params s) c)) (s-check-temps-setp (s-temps s))) (and (equal (s-err-flag (s-eval flag s c)) 'run) (s-check-temps-setp (s-temps (s-eval flag s c))) (subsetp (s-collect-all-temps flag (if (equal flag 'list) (s-expr-list s) (s-expr s))) (temp-alist-to-set (s-temps (s-eval flag s c)))))) ((disable l-eval s-collect-all-temps s-all-temps-setp s-eval s-expand-temps) (enable s-eval-l-eval-flag-run-helper-1 s-eval-l-eval-flag-run-helper-2) (expand (s-eval flag s c) (s-eval 'list s c) (s-eval flag s 0) (s-collect-all-temps flag (s-expr s)) (s-collect-all-temps 'list (s-expr-list s)) (s-all-temps-setp flag (s-expr s) (temp-alist-to-set (s-temps s))) (s-all-temps-setp 'list (s-expr-list s) (temp-alist-to-set (s-temps s)))) (induct (s-eval flag s c)))) (defn S-CONSTRUCT-PROGRAMS (fun-list) (if (listp fun-list) (cons (list (user-fname (car fun-list)) ; name (formals (car fun-list)) ; formals nil ; temps (body (car fun-list))) (s-construct-programs (cdr fun-list))) nil)) (defn DELETE-ALL (x l) (if (listp l) (if (equal x (car l)) (delete-all x (cdr l)) (cons (car l) (delete-all x (cdr l)))) l)) (prove-lemma DELETE-ALL-NON-DECREASING-COUNT (rewrite) (not (lessp (count l) (count (delete-all x l))))) (defn REMOVE-DUPLICATES (l) (if (listp l) (cons (car l) (remove-duplicates (delete-all (car l) (cdr l)))) l)) (defn LOGIC->S (expr alist fun-names) (s-state 'main nil nil alist nil (cons (list 'main (strip-cars alist) nil expr) (s-construct-programs (remove-duplicates fun-names))) 'run)) ; (setq st (logic->s '(plus (length (app '(a) x)) '2) ; '((x . (b c))) ; '(app length))) (defn L-PROPER-EXPRP (flag body program-names formals) (cond ((equal flag 'list) (if (listp body) (and (l-proper-exprp t (car body) program-names formals) (l-proper-exprp 'list (cdr body) program-names formals)) (equal body nil))) ((listp body) (cond ((not (plistp body)) f) ((equal (car body) 'quote) (equal (length (cdr body)) (arity (car body)))) ((subrp (car body)) (and (equal (length (cdr body)) (arity (car body))) (not (member (car body) program-names)) (l-proper-exprp 'list (cdr body) program-names formals))) ((body (car body)) (and (equal (length (cdr body)) (arity (car body))) (member (car body) program-names) (l-proper-exprp 'list (cdr body) program-names formals))) (t f))) ((litatom body) (member body formals)) (t f))) (defn L-PROPER-PROGRAMSP-1 (program-names all-program-names) (if (listp program-names) (and (formals (car program-names)) (all-litatoms (formals (car program-names))) (l-proper-exprp t (body (car program-names)) all-program-names (formals (car program-names))) (l-proper-programsp-1 (cdr program-names) all-program-names)) t)) (defn L-PROPER-PROGRAMSP (program-names) (l-proper-programsp-1 program-names program-names)) (disable L-PROPER-PROGRAMSP) (prove-lemma DEFINEDP-ASSOC-FACT-1 (rewrite) (implies (not (definedp expr alist)) (not (assoc expr alist)))) (disable DEFINEDP-ASSOC-FACT-1) (defn ALL-LITATOMS-NOT-PLIST (list) (if (listp list) (and (litatom (car list)) (all-litatoms-not-plist (cdr list))) t)) (prove-lemma STRIP-LOGIC-FNAMES-S-CONSTRUCT-PROGRAMS (rewrite) (implies (all-litatoms-not-plist program-names) (equal (strip-logic-fnames (s-construct-programs program-names)) (plist program-names)))) (prove-lemma L-PROPER-EXPR-FUNCTIONS-DEFINEDP-S-PROPER-EXPR (rewrite) (implies (l-proper-exprp flag prog all-program-names formals) (s-proper-exprp flag prog all-program-names formals temp-list))) (prove-lemma S-PROGRAMS-PROPERP-S-CONSTRUCT-PROGRAMS (rewrite) (implies (l-proper-programsp-1 program-names all-program-names) (s-programs-properp (s-construct-programs program-names) all-program-names)) ((enable s-body s-formals s-temp-list))) (prove-lemma S-PROPER-EXPRP-PLIST (rewrite) (equal (s-proper-exprp flag expr (plist program-names) formals temp-list) (s-proper-exprp flag expr program-names formals temp-list)) ((disable append-plist-lastcdr))) (prove-lemma S-PROPER-PROGRAMSP-PLIST (rewrite) (equal (s-programs-properp programs (plist program-names)) (s-programs-properp programs program-names)) ((disable append-plist-lastcdr))) (prove-lemma S-EXPAND-TEMPS-BODY-EQUAL-BODY (rewrite) (implies (l-proper-exprp flag expr all-program-names formals) (equal (s-expand-temps flag expr) expr))) (prove-lemma L-PROPER-PROGRAMSP-1-DELETE-ALL (rewrite) (implies (l-proper-programsp-1 program-names all-program-names) (l-proper-programsp-1 (delete-all name program-names) all-program-names))) (prove-lemma USER-FNAMEP-USER-FNAME (rewrite) (user-fnamep (user-fname x)) ((enable user-fname user-fnamep))) (prove-lemma LOGIC-FNAME-USER-FNAME-IDENTITY-FORMALS (rewrite) (implies (formals x) (equal (logic-fname (user-fname x)) x)) ((use (logic-fname-user-fname-identity (x x))) (disable logic-fname-user-fname-identity))) (prove-lemma S-PROGRAMS-OKP-S-CONSTRUCT-PROGRAMS (rewrite) (implies (l-proper-programsp-1 program-names all-program-names) (s-programs-okp (s-construct-programs (remove-duplicates program-names)))) ((enable s-body s-formals s-temp-list))) (disable logic-fname-user-fname-identity-formals) (prove-lemma S-EVAL-L-EVAL-FLAG-RUN-FLAG-T (rewrite) (implies (and (s-good-statep s c) (good-posp flag (s-pos s) (s-body (s-prog s))) (s-all-temps-setp flag (s-expr s) (temp-alist-to-set (s-temps s))) (s-all-progs-temps-setp (s-progs s)) (l-eval flag (s-expand-temps flag (s-expr s)) (s-params s) c) (s-check-temps-setp (s-temps s)) (not (equal flag 'list))) (and (equal (s-err-flag (s-eval flag s c)) 'run) (s-check-temps-setp (s-temps (s-eval flag s c))) (subsetp (s-collect-all-temps flag (s-expr s)) (temp-alist-to-set (s-temps (s-eval flag s c)))))) ((use (s-eval-l-eval-flag-run (flag flag) (s s) (c c))))) (prove-lemma L-PROPER-EXPR-S-ALL-TEMPS-SETP (rewrite) (implies (l-proper-exprp flag expr prog-names formals) (s-all-temps-setp flag expr temp-set))) (prove-lemma L-PROPER-PROGRAMSP-1-S-ALL-PROGS-TEMPS-SETP () (implies (l-proper-programsp-1 program-names all-program-names) (s-all-progs-temps-setp (s-construct-programs program-names))) ((enable s-all-progs-temps-setp s-body s-temp-list))) (prove-lemma L-PROPER-PROGRAMSP-S-ALL-PROGS-TEMPS-SETP (rewrite) (implies (l-proper-programsp program-names) (s-all-progs-temps-setp (s-construct-programs program-names))) ((enable l-proper-programsp) (use (l-proper-programsp-1-s-all-progs-temps-setp (all-program-names program-names) (program-names program-names))))) (prove-lemma MEMBER-DELETE-ALL (rewrite) (equal (member x (delete-all y l)) (if (member x l) (not (equal x y)) f))) (prove-lemma MEMBER-REMOVE-DUPLICATES (rewrite) (equal (member e (remove-duplicates x)) (member e x))) (prove-lemma S-PROPER-EXPRP-REMOVE-DUPLICATES (rewrite) (equal (s-proper-exprp flag expr (remove-duplicates prog-names) formals temp-list) (s-proper-exprp flag expr prog-names formals temp-list))) (prove-lemma L-PROPER-EXPRP-REMOVE-DUPLICATES (rewrite) (equal (l-proper-exprp flag expr (remove-duplicates prog-names) formals) (l-proper-exprp flag expr prog-names formals))) (prove-lemma L-PROPER-PROGRAMS-REMOVE-DUPLICATES-ARG2 (rewrite) (equal (l-proper-programsp-1 program-names (remove-duplicates all-program-names)) (l-proper-programsp-1 program-names all-program-names))) (prove-lemma L-PROPER-PROGRAMS-REMOVE-DUPLICATES-ARG1 (rewrite) (implies (l-proper-programsp-1 program-names all-program-names) (l-proper-programsp-1 (remove-duplicates program-names) all-program-names))) (prove-lemma ALL-LITATOMS-NOT-PLIST-DELETE-ALL (rewrite) (implies (all-litatoms-not-plist list) (all-litatoms-not-plist (delete-all x list)))) (prove-lemma ALL-LITATOMS-NOT-PLIST-REMOVE-DUPLICATES (rewrite) (implies (all-litatoms-not-plist list) (all-litatoms-not-plist (remove-duplicates list)))) (prove-lemma ALL-LITATOMS-NOT-PLIST-LR-PROPER-PROGRAMSP-1 (rewrite) (implies (l-proper-programsp-1 prog-names all-prog-names) (all-litatoms-not-plist prog-names))) (prove-lemma S-GOOD-STATE-S-CONSTRUCT-PROGRAMS (rewrite) (implies (and (l-proper-programsp prog-names) (l-proper-exprp t expr prog-names (strip-cars alist)) (all-litatoms (strip-cars alist))) (s-good-statep (s-state 'main nil nil alist nil (cons (list 'main (strip-cars alist) nil expr) (s-construct-programs (remove-duplicates prog-names))) 'run) c)) ((enable l-proper-programsp s-body s-formals s-good-statep s-prog s-temp-list))) (prove-lemma L-PROPER-PROGRAMSP-REMOVE-DUPLICATES (rewrite) (implies (l-proper-programsp program-names) (l-proper-programsp (remove-duplicates program-names))) ((enable l-proper-programsp))) (prove-lemma LOGIC->S-OK () (implies (and (l-proper-exprp t expr program-names (strip-cars alist)) (l-proper-programsp program-names) (all-litatoms (strip-cars alist)) (l-eval t expr alist clock)) (equal (s-ans (s-eval t (logic->s expr alist program-names) clock)) (car (l-eval t expr alist clock)))) ((disable s-eval l-eval) (enable s-body s-all-progs-temps-setp s-expr good-posp s-prog s-temp-list))) (prove-lemma LOGIC->S-OK-REALLY () (implies (and (l-proper-exprp t expr program-names (strip-cars alist)) (l-proper-programsp program-names) (all-litatoms (strip-cars alist)) (v&c$ t expr alist) (lessp (cdr (v&c$ t expr alist)) clock)) (equal (s-ans (s-eval t (logic->s expr alist program-names) clock)) (car (v&c$ t expr alist)))) ((disable s-eval l-eval logic->s v&c$) (use (logic->s-ok (expr expr) (program-names program-names) (clock clock) (alist alist)) (l-eval-not-f-v&c$-equivalence (flag t) (expr expr) (alist alist) (clock clock)) (v&c$-l-eval-equivalence (flag t) (expr expr) (alist alist) (clock clock))))) (make-lib "app-c-d-e" t)