#|
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
; ------------------------------------------------------------

Event: Start with the initial nqthm theory.

Definition: delete (x, l) = if listp (l)

then if x = car (l) then cdr (l)

else cons (car (l), delete (x, cdr (l))) endif else l endif

Definition: bagdiff (x, y) = if listp (y)

then if car (y) ∈ x then bagdiff (delete (car (y), x), cdr (y))

else bagdiff (x, cdr (y)) endif else x endif Definition: bagint (x, y) = if listp (x)

then if car (x) ∈ y then cons (car (x), bagint (cdr (x), delete (car (x), y))) else bagint (cdr (x), y) endif

else nil endif

Definition: occurrences (x, l) = if listp (l)

then if x = car (l) then 1 + occurrences (x, cdr (l))

else occurrences (x, cdr (l)) endif else 0 endif

Definition: subbagp (x, y) = if listp (x)

then if car (x) ∈ y then subbagp (cdr (x), delete (car (x), y))

else f endif else t endif

Theorem: listp-delete listp (delete (x, l)) = if listp (l) then (x ≠ car (l)) ∨ listp (cdr (l))

else f endif

Event: Disable listp-delete.

Theorem: delete-non-member (x ∉ y) → (delete (x, y) = y)

Theorem: delete-delete delete (y, delete (x, z)) = delete (x, delete (y, z))

Theorem: equal-occurrences-zero (occurrences (x, l) = 0) = (x ∉ l)

Theorem: member-non-list (¬ listp (l)) → (x ∉ l)

Theorem: member-delete (x ∈ delete (y, l)) = if x ∈ l

then if x = y then 1 < occurrences (x, l)

else t endif else f endif Theorem: member-delete-implies-membership (x ∈ delete (y, l)) → (x ∈ l)

Theorem: occurrences-delete occurrences (x, delete (y, l)) = if x = y

then if x ∈ l then occurrences (x, l) − 1

else 0 endif else occurrences (x, l) endif

Theorem: member-bagdiff (x ∈ bagdiff (a, b)) = (occurrences (x, b) < occurrences (x, a))

Theorem: bagdiff-delete bagdiff (delete (e, x), y) = delete (e, bagdiff (x, y))

Theorem: subbagp-delete subbagp (x, delete (u, y)) → subbagp (x, y)

Theorem: subbagp-cdr1 subbagp (x, y) → subbagp (cdr (x), y)

Theorem: subbagp-cdr2 subbagp (x, cdr (y)) → subbagp (x, y)

Theorem: subbagp-bagint1 subbagp (bagint (x, y), x)

Theorem: subbagp-bagint2 subbagp (bagint (x, y), y)

Theorem: occurrences-bagint occurrences (x, bagint (a, b)) = if occurrences (x, a) < occurrences (x, b) then occurrences (x, a)

else occurrences (x, b) endif

Theorem: occurrences-bagdiff occurrences (x, bagdiff (a, b)) = (occurrences (x, a) − occurrences (x, b))

Theorem: member-bagint (x ∈ bagint (a, b)) = ((x ∈ a) ∧ (x ∈ b))

Event: Let us define the theory bags to consist of the following events: occurrencesbagint, bagdiff-delete, occurrences-bagdiff, member-bagint, member-bagdiff, subbagpbagint2, 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 ----------

Theorem: equal-plus-0 ((a + b) = 0) = ((a ≃ 0) ∧ (b ≃ 0))

Theorem: plus-cancellation ((a + b) = (a + c)) = (fix (b) = fix (c))

Event: Disable plus-cancellation.

Theorem: equal-difference-0 (((x − y) = 0) = (y ≮ x)) ∧ ((0 = (x − y)) = (y ≮ x))

Theorem: difference-cancellation ((x − y) = (z − y)) = if x < y then y ≮ z

elseif z < y then y ≮ x else fix (x) = fix (z) endif

Event: Disable difference-cancellation.

; ---------- PLUS ----------

Theorem: commutativity-of-plus (x + y) = (y + x)

Theorem: commutativity2-of-plus (x + (y + z)) = (y + (x + z))

Theorem: plus-zero-arg2 (y ≃ 0) → ((x + y) = fix (x))

Theorem: plus-add1-arg1 ((1 + a) + b) = (1 + (a + b))

Theorem: plus-add1-arg2 (x + (1 + y)) = if y ∈ N then 1 + (x + y)

else 1 + x endif

Theorem: associativity-of-plus ((x + y) + z) = (x + (y + z))

Theorem: plus-difference-arg1 ((a − b) + c) = if b < a then (a + c) − b

else 0 + c endif

Theorem: plus-difference-arg2 (a + (b − c)) = if c < b then (a + b) − c

else a + 0 endif

; ---------- 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.

Theorem: difference-plus-cancellation-proof ((x + y) − x) = fix (y)

Theorem: difference-plus-cancellation (((x + y) − x) = fix (y)) ∧ (((y + x) − x) = fix (y))

Event: Disable difference-plus-cancellation.

Theorem: difference-plus-plus-cancellation-proof ((x + y) − (x + z)) = (y − z)

Theorem: difference-plus-plus-cancellation (((x + y) − (x + z)) = (y − z)) ∧ (((y + x) − (x + z)) = (y − z)) ∧ (((x + y) − (z + x)) = (y − z)) ∧ (((y + x) − (z + x)) = (y − z))

Event: Disable difference-plus-plus-cancellation.

Theorem: difference-plus-plus-cancellation-hack ((w + x + a) − (y + z + a)) = ((w + x) − (y + z))

Event: 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.

Theorem: diff-sub1-arg2 (a − (b − 1)) = if b ≃ 0 then fix (a)

elseif a < b then 0 else 1 + (a − b) endif

Event: Disable diff-sub1-arg2.

Theorem: diff-diff-arg1 ((x − y) − z) = (x − (y + z))

Theorem: diff-diff-arg2 (a − (b − c)) = if b < c then fix (a)

else (a + c) − b endif

; 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.

Theorem: diff-diff-diff ((b ≤ a) ∧ (d ≤ c)) → (((a − b) − (c − d)) = ((a + d) − (b + c)))

Event: Disable diff-diff-diff.

Theorem: difference-lessp-arg1 (a < b) → ((a − b) = 0)

Event: Disable difference-lessp-arg1.

; --------------------------------------------------------------------------------
; Meta Lemmas to Cancel PLUS and DIFFERENCE expressions
; --------------------------------------------------------------------------------
; ---------- PLUS-TREE and PLUS-FRINGE ----------

Definition: plus-fringe (x) = if listp (x) ∧ (car (x) = 'plus)

then append (plus-fringe (cadr (x)), plus-fringe (caddr (x)))

else cons (x, nil) endif

Definition: plus-tree (l) = if l ≃ nil then ''0

elseif cdr (l) ≃ nil then list ('fix, car (l))

elseif cddr (l) ≃ nil then list ('plus, car (l), cadr (l))

else list ('plus, car (l), plus-tree (cdr (l))) endif Theorem: numberp-eval$-plus (listp (x) ∧ (car (x) = 'plus)) → (eval$ (t, x, a) ∈ N)

Event: Disable numberp-eval$-plus.

Theorem: numberp-eval$-plus-tree eval$ (t, plus-tree (l), a) ∈ N

Event: Disable numberp-eval$-plus-tree.

Theorem: member-implies-plus-tree-greatereqp (x ∈ y) → (eval$ (t, plus-tree (y), a) ≮ eval$ (t, x, a))

Event: Disable member-implies-plus-tree-greatereqp.

Theorem: plus-tree-delete eval$ (t, plus-tree (delete (x, y)), a) = if x ∈ y then eval$ (t, plus-tree (y), a) − eval$ (t, x, a)

else eval$ (t, plus-tree (y), a) endif

Event: Disable plus-tree-delete.

Theorem: subbagp-implies-plus-tree-greatereqp subbagp (x, y) → (eval$ (t, plus-tree (y), a) ≮ eval$ (t, plus-tree (x), a))

Event: Disable subbagp-implies-plus-tree-greatereqp.

Theorem: plus-tree-bagdiff subbagp (x, y) → (eval$ (t, plus-tree (bagdiff (y, x)), a)

= (eval$ (t, plus-tree (y), a) − eval$ (t, plus-tree (x), a)))

Event: Disable plus-tree-bagdiff.

Theorem: numberp-eval$-bridge (eval$ (t, z, a) = eval$ (t, plus-tree (x), a)) → (eval$ (t, z, a) ∈ N)

Event: Disable numberp-eval$-bridge.

Theorem: bridge-to-subbagp-implies-plus-tree-greatereqp (subbagp (y, plus-fringe (z)) ∧ (eval$ (t, z, a) = eval$ (t, plus-tree (plus-fringe (z)), a))) → ((eval$ (t, z, a) < eval$ (t, plus-tree (y), a)) = f)

Event: Disable bridge-to-subbagp-implies-plus-tree-greatereqp.

Theorem: eval$-plus-tree-append eval$ (t, plus-tree (append (x, y)), a) = (eval$ (t, plus-tree (x), a) + eval$ (t, plus-tree (y), a))

Event: Disable eval$-plus-tree-append.

Theorem: plus-tree-plus-fringe eval$ (t, plus-tree (plus-fringe (x)), a) = fix (eval$ (t, x, a))

Event: Disable plus-tree-plus-fringe.

Theorem: member-implies-numberp ((c ∈ plus-fringe (x)) ∧ (eval$ (t, c, a) ∈ N)) → (eval$ (t, x, a) ∈ N)

Event: Disable member-implies-numberp.

Theorem: cadr-eval$-list (car (eval$ ('list, x, a)) = eval$ (t, car (x), a)) ∧ (cdr (eval$ ('list, x, a))

= if listp (x) then eval$ ('list, cdr (x), a) else 0 endif)

Event: Disable cadr-eval$-list.

Theorem: eval$-quote eval$ (t, cons ('quote, args), a) = car (args)

Event: Disable eval$-quote.

Theorem: listp-eval$ listp (eval$ ('list, x, a)) = listp (x)

Event: 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))

;

Definition: cancel-equal-plus (x) = if listp (x) ∧ (car (x) = 'equal)

then if listp (cadr (x)) ∧ (caadr (x) = 'plus) ∧ listp (caddr (x)) ∧ (caaddr (x) = 'plus)

then 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))))))

elseif listp (cadr (x)) ∧ (caadr (x) = 'plus) ∧ (caddr (x) ∈ plus-fringe (cadr (x)))

then list ('if, list ('numberp, caddr (x)),

                 list ('equal,

plus-tree (delete (caddr (x), plus-fringe (cadr (x)))),

                     ''0),

list ('quote, f))

elseif listp (caddr (x)) ∧ (caaddr (x) = 'plus) ∧ (cadr (x) ∈ plus-fringe (caddr (x)))

then list ('if, list ('numberp, cadr (x)),

                 list ('equal,
                     ''0,

plus-tree (delete (cadr (x), plus-fringe (caddr (x))))), list ('quote, f))

else x endif else x endif

Theorem: correctness-of-cancel-equal-plus eval$ (t, x, a) = eval$ (t, cancel-equal-plus (x), a)

; ---------- 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.

Definition: cancel-difference-plus (x) = if listp (x) ∧ (car (x) = 'difference)

then if listp (cadr (x)) ∧ (caadr (x) = 'plus) ∧ listp (caddr (x)) ∧ (caaddr (x) = 'plus)

         then 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))))))

elseif listp (cadr (x))

∧ (caadr (x) = 'plus)

∧ (caddr (x) ∈ plus-fringe (cadr (x))) then plus-tree (delete (caddr (x), plus-fringe (cadr (x)))) elseif listp (caddr (x))

∧ (caaddr (x) = 'plus)

∧ (cadr (x) ∈ plus-fringe (caddr (x))) then ''0 else x endif

else x endif

Theorem: correctness-of-cancel-difference-plus eval$ (t, x, a) = eval$ (t, cancel-difference-plus (x), a)

; ---------- 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.

Theorem: difference-elim ((y ∈ N) ∧ (y ≮ x)) → ((x + (y − x)) = y)

Theorem: difference-leq-arg1 (a ≤ b) → ((a − b) = 0)

Theorem: difference-add1-arg2 (a − (1 + b)) = if b < a then (a − b) − 1

else 0 endif

Theorem: difference-sub1-arg2 (a − (b − 1)) = if b ≃ 0 then fix (a)

elseif a < b then 0 else 1 + (a − b) endif

Theorem: difference-difference-arg1 ((x − y) − z) = (x − (y + z))

Theorem: difference-difference-arg2 (a − (b − c)) = if b < c then fix (a)

else (a + c) − b endif

Theorem: difference-x-x (x − x) = 0

; ---------- LESSP ----------

Theorem: lessp-difference-cancellation ((a − c) < (b − c)) = if c ≤ a then a < b

else c < b endif

Event: 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

Definition: cancel-lessp-plus (x) = if listp (x) ∧ (car (x) = 'lessp)

then if listp (cadr (x)) ∧ (caadr (x) = 'plus) ∧ listp (caddr (x))

∧ (caaddr (x) = 'plus) then 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))))))

elseif listp (cadr (x)) ∧ (caadr (x) = 'plus) ∧ (caddr (x) ∈ plus-fringe (cadr (x)))

then list ('quote, f) elseif listp (caddr (x))

∧ (caaddr (x) = 'plus)

∧ (cadr (x) ∈ plus-fringe (caddr (x))) then list ('not,

                 list ('zerop,

plus-tree (delete (cadr (x), plus-fringe (caddr (x))))))

else x endif else x endif

Theorem: correctness-of-cancel-lessp-plus eval$ (t, x, a) = eval$ (t, cancel-lessp-plus (x), a)

; 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)

Event: Let us define the theory addition to consist of the following events: 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, differenceadd1-arg2, difference-sub1-arg2, difference-difference-arg1, difference-difference-arg2, difference-x-x, correctness-of-cancel-lessp-plus.

; ---------- TIMES ----------

Theorem: equal-times-0 ((x ∗ y) = 0) = ((x ≃ 0) ∨ (y ≃ 0))

Theorem: equal-times-1 ((a ∗ b) = 1) = ((a = 1) ∧ (b = 1))

;(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)))))

Theorem: equal-sub1-0 ((x − 1) = 0) = ((x ≃ 0) ∨ (x = 1))

Theorem: times-zero (y ≃ 0) → ((x ∗ y) = 0)

Theorem: times-add1 (x ∗ (1 + y)) = if y ∈ N then x + (x ∗ y)

else fix (x) endif

Theorem: commutativity-of-times (y ∗ x) = (x ∗ y)

Theorem: times-distributes-over-plus-proof (x ∗ (y + z)) = ((x ∗ y) + (x ∗ z))

Theorem: times-distributes-over-plus ((x ∗ (y + z)) = ((x ∗ y) + (x ∗ z))) ∧ (((x + y) ∗ z) = ((x ∗ z) + (y ∗ z)))

Theorem: commutativity2-of-times (x ∗ y ∗ z) = (y ∗ x ∗ z)

Theorem: associativity-of-times ((x ∗ y) ∗ z) = (x ∗ y ∗ z)

Theorem: times-distributes-over-difference-proof ((a − b) ∗ c) = ((a ∗ c) − (b ∗ c))

Theorem: times-distributes-over-difference (((a − b) ∗ c) = ((a ∗ c) − (b ∗ c))) ∧ ((a ∗ (b − c)) = ((a ∗ b) − (a ∗ c)))

Theorem: times-quotient-proof ((x ≄ 0) ∧ ((y mod x) = 0)) → (((y ÷ x) ∗ x) = fix (y))

Theorem: times-quotient ((y ≄ 0) ∧ ((x mod y) = 0)) → ((((x ÷ y) ∗ y) = fix (x)) ∧ ((y ∗ (x ÷ y)) = fix (x)))

Theorem: times-1-arg1 (1 ∗ x) = fix (x)

Theorem: lessp-times1-proof ((a < b) ∧ (c ≄ 0)) → ((a < (b ∗ c)) = t)

Theorem: lessp-times1 ((a < b) ∧ (c ≄ 0)) → (((a < (b ∗ c)) = t) ∧ ((a < (c ∗ b)) = t))

Theorem: lessp-times2-proof ((a ≤ b) ∧ (c ≄ 0)) → (((b ∗ c) < a) = f)

Theorem: lessp-times2 ((a ≤ b) ∧ (c ≄ 0)) → ((((b ∗ c) < a) = f) ∧ (((c ∗ b) < a) = f))

Theorem: lessp-times3-proof1 ((a ≄ 0) ∧ (1 < b)) → (a < (a ∗ b))

Theorem: lessp-times3-proof2 (a < (a ∗ b)) → ((a ≄ 0) ∧ (1 < b))

Theorem: lessp-times3 ((a < (a ∗ b)) = ((a ≄ 0) ∧ (1 < b))) ∧ ((a < (b ∗ a)) = ((a ≄ 0) ∧ (1 < b)))

Theorem: lessp-times-cancellation-proof ((x ∗ z) < (y ∗ z)) = ((z ≄ 0) ∧ (x < y))

Theorem: lessp-times-cancellation1 (((x ∗ z) < (y ∗ z)) = ((z ≄ 0) ∧ (x < y))) ∧ (((z ∗ x) < (y ∗ z)) = ((z ≄ 0) ∧ (x < y))) ∧ (((x ∗ z) < (z ∗ y)) = ((z ≄ 0) ∧ (x < y))) ∧ (((z ∗ x) < (z ∗ y)) = ((z ≄ 0) ∧ (x < y)))

Event: Disable lessp-times-cancellation1.

Theorem: lessp-plus-times-proof (x < a) → (((x + (a ∗ b)) < (a ∗ c)) = (b < c))

Theorem: lessp-plus-times1 (((a + (b ∗ c)) < b) = ((a < b) ∧ (c ≃ 0))) ∧ (((a + (c ∗ b)) < b) = ((a < b) ∧ (c ≃ 0))) ∧ ((((c ∗ b) + a) < b) = ((a < b) ∧ (c ≃ 0))) ∧ ((((b ∗ c) + a) < b) = ((a < b) ∧ (c ≃ 0)))

Theorem: lessp-plus-times2 ((a ≄ 0) ∧ (x < a)) → ((((x + (a ∗ b)) < (a ∗ c)) = (b < c))

∧ (((x + (b ∗ a)) < (a ∗ c)) = (b < c))

∧ (((x + (a ∗ b)) < (c ∗ a)) = (b < c))
∧ (((x + (b ∗ a)) < (c ∗ a)) = (b < c))
∧ ((((a ∗ b) + x) < (a ∗ c)) = (b < c))
∧ ((((b ∗ a) + x) < (a ∗ c)) = (b < c))
∧ ((((a ∗ b) + x) < (c ∗ a)) = (b < c))
∧ ((((b ∗ a) + x) < (c ∗ a)) = (b < c)))

Theorem: lessp-1-times (1 < (a ∗ b)) = (¬ ((a ≃ 0) ∨ (b ≃ 0) ∨ ((a = 1) ∧ (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))

Definition: times-tree (x) = if x ≃ nil then ''1

elseif cdr (x) ≃ nil then list ('fix, car (x))

elseif cddr (x) ≃ nil then list ('times, car (x), cadr (x))

else list ('times, car (x), times-tree (cdr (x))) endif Definition: times-fringe (x) = if listp (x) ∧ (car (x) = 'times)

then append (times-fringe (cadr (x)), times-fringe (caddr (x)))

else cons (x, nil) endif

Definition: or-zerop-tree (x) = if x ≃ nil then '(false)

elseif cdr (x) ≃ nil then list ('zerop, car (x))

elseif cddr (x) ≃ nil

then list ('or, list ('zerop, car (x)), list ('zerop, cadr (x))) else list ('or, list ('zerop, car (x)), or-zerop-tree (cdr (x))) endif

Definition: and-not-zerop-tree (x) = if x ≃ nil then '(true)

elseif cdr (x) ≃ nil then list ('not, list ('zerop, car (x)))

else list ('and, list ('not, list ('zerop, car (x))), and-not-zerop-tree (cdr (x))) endif

Theorem: numberp-eval$-times (car (x) = 'times) → (eval$ (t, x, a) ∈ N)

Event: Disable numberp-eval$-times.

Theorem: eval$-times (car (x) = 'times) → (eval$ (t, x, a) = (eval$ (t, cadr (x), a) ∗ eval$ (t, caddr (x), a)))

Event: Disable eval$-times.

Theorem: eval$-or (car (x) = 'or) → (eval$ (t, x, a) = (eval$ (t, cadr (x), a) ∨ eval$ (t, caddr (x), a)))

Event: Disable eval$-or.

Theorem: eval$-equal (car (x) = 'equal) → (eval$ (t, x, a) = (eval$ (t, cadr (x), a) = eval$ (t, caddr (x), a)))

Event: Disable eval$-equal.

Theorem: eval$-lessp (car (x) = 'lessp) → (eval$ (t, x, a) = (eval$ (t, cadr (x), a) < eval$ (t, caddr (x), a)))

Event: Disable eval$-lessp.

Theorem: eval$-quotient

 (car (x) = 'quotient)

→ (eval$ (t, x, a) = (eval$ (t, cadr (x), a) ÷ eval$ (t, caddr (x), a)))

Event: Disable eval$-quotient.

Theorem: eval$-if (car (x) = 'if) → (eval$ (t, x, a)

= if eval$ (t, cadr (x), a) then eval$ (t, caddr (x), a) else eval$ (t, cadddr (x), a) endif)

Event: Disable eval$-if.

Theorem: numberp-eval$-times-tree eval$ (t, times-tree (x), a) ∈ N

Event: Disable numberp-eval$-times-tree.

Theorem: lessp-times-arg1 (a ≄ 0) → (((a ∗ x) ≮ (a ∗ y)) = (x ≮ y))

Theorem: infer-equality-from-not-lessp ((a ∈ N) ∧ (b ∈ N)) → (((a ≮ b) ∧ (b ≮ a)) = (a = b))

Theorem: equal-times-arg1 (a ≄ 0) → (((a ∗ x) = (a ∗ y)) = (fix (x) = fix (y)))

Event: Disable equal-times-arg1.

Theorem: equal-times-bridge ((a ∗ b) = (c ∗ (a ∗ d))) = ((a ≃ 0) ∨ (fix (b) = (c ∗ d)))

Event: Disable equal-times-bridge.

Theorem: eval$-times-member (e ∈ x) → (eval$ (t, times-tree (x), a)

= (eval$ (t, e, a) ∗ eval$ (t, times-tree (delete (e, x)), a)))

Event: Disable eval$-times-member.

Theorem: zerop-makes-times-tree-zero ((¬ eval$ (t, and-not-zerop-tree (x), a)) ∧ subbagp (x, y)) → (eval$ (t, times-tree (y), a) = 0)

Event: Disable zerop-makes-times-tree-zero.

Theorem: or-zerop-tree-is-not-zerop-tree eval$ (t, or-zerop-tree (x), a) = (¬ eval$ (t, and-not-zerop-tree (x), a))

Event: Disable or-zerop-tree-is-not-zerop-tree.

Theorem: zerop-makes-times-tree-zero2 (eval$ (t, or-zerop-tree (x), a) ∧ subbagp (x, y)) → (eval$ (t, times-tree (y), a) = 0)

Event: Disable zerop-makes-times-tree-zero2.

Theorem: times-tree-append eval$ (t, times-tree (append (x, y)), a) = (eval$ (t, times-tree (x), a) ∗ eval$ (t, times-tree (y), a))

Event: Disable times-tree-append.

Theorem: times-tree-of-times-fringe eval$ (t, times-tree (times-fringe (x)), a) = fix (eval$ (t, x, a))

Event: Disable times-tree-of-times-fringe.

Definition: cancel-lessp-times (x) = if (car (x) = 'lessp)

∧ (caadr (x) = 'times) ∧ (caaddr (x) = 'times)

then let inboth be bagint (times-fringe (cadr (x)),

times-fringe (caddr (x)))

in

if listp (inboth) then 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))))

else x endif endlet else x endif

Theorem: eval$-lessp-times-tree-bagdiff (subbagp (x, y) ∧ subbagp (x, z) ∧ eval$ (t, and-not-zerop-tree (x), a)) → ((eval$ (t, times-tree (bagdiff (y, x)), a)

< eval$ (t, times-tree (bagdiff (z, x)), a))

= (eval$ (t, times-tree (y), a) < eval$ (t, times-tree (z), a)))

Event: Disable eval$-lessp-times-tree-bagdiff.

Theorem: zerop-makes-lessp-false-bridge ((car (x) = 'times) ∧ (car (y) = 'times) ∧ (¬ eval$ (t,

and-not-zerop-tree (bagint (times-fringe (x), times-fringe (y))), a)))

→ (((eval$ (t, cadr (x), a) ∗ eval$ (t, caddr (x), a))

< (eval$ (t, cadr (y), a) ∗ eval$ (t, caddr (y), a)))

= f)

Event: Disable zerop-makes-lessp-false-bridge.

Theorem: correctness-of-cancel-lessp-times eval$ (t, x, a) = eval$ (t, cancel-lessp-times (x), a)

Definition: cancel-equal-times (x) = if (car (x) = 'equal)

∧ (caadr (x) = 'times) ∧ (caaddr (x) = 'times)

then let inboth be bagint (times-fringe (cadr (x)),

times-fringe (caddr (x)))

in

if listp (inboth) then list ('or,

or-zerop-tree (inboth),

                 list ('equal,

times-tree (bagdiff (times-fringe (cadr (x)), inboth)), times-tree (bagdiff (times-fringe (caddr (x)), inboth))))

else x endif endlet else x endif

Theorem: zerop-makes-equal-true-bridge ((car (x) = 'times) ∧ (car (y) = 'times) ∧ eval$ (t, or-zerop-tree (bagint (times-fringe (x), times-fringe (y))), a)) → (((eval$ (t, cadr (x), a) ∗ eval$ (t, caddr (x), a))

= (eval$ (t, cadr (y), a) ∗ eval$ (t, caddr (y), a)))

= t)

Event: Disable zerop-makes-equal-true-bridge.

Theorem: eval$-equal-times-tree-bagdiff (subbagp (x, y) ∧ subbagp (x, z) ∧ (¬ eval$ (t, or-zerop-tree (x), a))) → ((eval$ (t, times-tree (bagdiff (y, x)), a)

= eval$ (t, times-tree (bagdiff (z, x)), a))

= (eval$ (t, times-tree (y), a) = eval$ (t, times-tree (z), a)))

Event: Disable eval$-equal-times-tree-bagdiff.

Theorem: cancel-equal-times-preserves-inequality (subbagp (z, x) ∧ subbagp (z, y) ∧ (eval$ (t, times-tree (x), a) ≠ eval$ (t, times-tree (y), a))) → (eval$ (t, times-tree (bagdiff (x, z)), a)

≠ eval$ (t, times-tree (bagdiff (y, z)), a))

Event: Disable cancel-equal-times-preserves-inequality.

Theorem: cancel-equal-times-preserves-inequality-bridge ((car (x) = 'times) ∧ (car (y) = 'times) ∧ ((eval$ (t, cadr (x), a) ∗ eval$ (t, caddr (x), a))

≠ (eval$ (t, cadr (y), a) ∗ eval$ (t, caddr (y), a)))) → (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))

Event: Disable cancel-equal-times-preserves-inequality-bridge.

Theorem: correctness-of-cancel-equal-times eval$ (t, x, a) = eval$ (t, cancel-equal-times (x), a)

; 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)

Event: Let us define the theory multiplication to consist of the following events: equal-times-0, equal-times-1, equal-sub1-0, times-zero, times-add1, commutativityof-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 ----------

Theorem: lessp-remainder ((x mod y) < y) = (y ≄ 0)

Theorem: remainder-noop (a < b) → ((a mod b) = fix (a))

Theorem: remainder-of-non-number (a ∉ N) → ((a mod n) = (0 mod n))

Theorem: remainder-zero (x ≃ 0) → ((y mod x) = fix (y))

Theorem: plus-remainder-times-quotient ((x mod y) + (y ∗ (x ÷ y))) = fix (x)

Event: Disable plus-remainder-times-quotient.

Theorem: remainder-quotient-elim ((y ≄ 0) ∧ (x ∈ N)) → (((x mod y) + (y ∗ (x ÷ y))) = x)

; (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))))

Theorem: remainder-add1 ((a mod b) = 0) → (((1 + a) mod b) = (1 mod b))

Theorem: remainder-plus-proof ((b mod c) = 0) → (((a + b) mod c) = (a mod c))

Theorem: remainder-plus ((a mod c) = 0) → ((((a + b) mod c) = (b mod c))

∧ (((b + a) mod c) = (b mod c))

∧ (((x + y + a) mod c) = ((x + y) mod c)))

Theorem: equal-remainder-plus-0-proof ((a mod c) = 0) → ((((a + b) mod c) = 0) = ((b mod c) = 0))

Theorem: equal-remainder-plus-0 ((a mod c) = 0) → (((((a + b) mod c) = 0) = ((b mod c) = 0))

∧ ((((b + a) mod c) = 0) = ((b mod c) = 0)) ∧ ((((x + y + a) mod c) = 0)

= (((x + y) mod c) = 0)))

Theorem: equal-remainder-plus-remainder-proof (a < c) → ((((a + b) mod c) = (b mod c)) = (a ≃ 0))

Theorem: equal-remainder-plus-remainder (a < c) → (((((a + b) mod c) = (b mod c)) = (a ≃ 0))

∧ ((((b + a) mod c) = (b mod c)) = (a ≃ 0)))

Event: Disable equal-remainder-plus-remainder.

Theorem: remainder-times1-proof ((b mod c) = 0) → (((a ∗ b) mod c) = 0)

Theorem: remainder-times1 ((b mod c) = 0) → ((((a ∗ b) mod c) = 0) ∧ (((b ∗ a) mod c) = 0))

Theorem: remainder-times1-instance-proof ((x ∗ y) mod y) = 0

Theorem: remainder-times1-instance (((x ∗ y) mod y) = 0) ∧ (((x ∗ y) mod x) = 0)

Theorem: remainder-times-times-proof ((x ∗ y) mod (x ∗ z)) = (x ∗ (y mod z))

Theorem: remainder-times-times (((x ∗ y) mod (x ∗ z)) = (x ∗ (y mod z))) ∧ (((x ∗ z) mod (y ∗ z)) = ((x mod y) ∗ z))

Event: Disable remainder-times-times.

Theorem: remainder-times2-proof ((a mod z) = 0) → ((a mod (z ∗ y)) = (z ∗ ((a ÷ z) mod y)))

Theorem: remainder-times2 ((a mod z) = 0) → (((a mod (y ∗ z)) = (z ∗ ((a ÷ z) mod y)))

∧ ((a mod (z ∗ y)) = (z ∗ ((a ÷ z) mod y))))

Theorem: remainder-times2-instance (((x ∗ y) mod (x ∗ z)) = (x ∗ (y mod z))) ∧ (((x ∗ z) mod (y ∗ z)) = ((x mod y) ∗ z))

Theorem: remainder-difference1 ((a mod c) = (b mod c)) → (((a − b) mod c) = ((a mod c) − (b mod c)))

Definition: double-remainder-induction (a, b, c) = if c ≃ 0 then 0

elseif a < c then 0 elseif b < c then 0 else double-remainder-induction (a − c, b − c, c) endif

Theorem: remainder-difference2 (((a mod c) = 0) ∧ ((b mod c) ≠ 0)) → (((a − b) mod c)

= if b < a then c − (b mod c) else 0 endif)

Theorem: remainder-difference3 (((b mod c) = 0) ∧ ((a mod c) ≠ 0)) → (((a − b) mod c)

= if b < a then a mod c else 0 endif)

Event: Disable remainder-difference3.

Theorem: equal-remainder-difference-0 (((a − b) mod c) = 0) = if b ≤ a then (a mod c) = (b mod c)

else t endif

Event: Disable equal-remainder-difference-0.

Theorem: lessp-plus-fact (((b mod x) = 0) ∧ ((c mod x) = 0) ∧ (b < c) ∧ (a < x)) → (((a + b) < c) = t)

Event: Disable lessp-plus-fact.

Theorem: remainder-plus-fact (((b mod x) = 0) ∧ ((c mod x) = 0) ∧ (a < x)) → (((a + b) mod c) = (a + (b mod c)))

Theorem: remainder-plus-times-times-proof (a < b) → (((a + (b ∗ c)) mod (b ∗ d))

= (a + ((b ∗ c) mod (b ∗ d))))

Theorem: remainder-plus-times-times (a < b) → ((((a + (b ∗ c)) mod (b ∗ d))

= (a + ((b ∗ c) mod (b ∗ d)))) ∧ (((a + (c ∗ b)) mod (d ∗ b))

= (a + ((c ∗ b) mod (d ∗ b)))))

; REMAINDER-PLUS-TIMES-TIMES-INSTANCE is the completion of the rules
; TIMES-DISTRIBUTES-OVER-PLUS, REMAINDER-TIMES-TIMES and REMAINDER-PLUS-TIMES-TIMES

Theorem: remainder-plus-times-times-instance (a < b) → ((((a + (b ∗ c) + (b ∗ d)) mod (b ∗ e))

= (a + (b ∗ ((c + d) mod e))))

∧ (((a + (c ∗ b) + (d ∗ b)) mod (e ∗ b)) = (a + (b ∗ ((c + d) mod e)))))

Theorem: remainder-remainder ((b mod a) = 0) → (((n mod b) mod a) = (n mod a))

Theorem: remainder-1-arg1 (1 mod x) = if x = 1 then 0

else 1 endif

Theorem: remainder-1-arg2 (y mod 1) = 0

Theorem: remainder-x-x (x mod x) = 0

Theorem: transitivity-of-divides (((a mod b) = 0) ∧ ((b mod c) = 0)) → ((a mod c) = 0)

; 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))

Event: Let us define the theory remainders to consist of the following events: lessp-remainder, remainder-noop, remainder-of-non-number, remainder-zero, remainderquotient-elim, remainder-add1, remainder-plus, equal-remainder-plus-0, remaindertimes1, remainder-times1-instance, remainder-times2, remainder-times2-instance, remainder-difference1, remainder-difference2, remainder-plus-times-times, remainderplus-times-times-instance, remainder-remainder, remainder-1-arg1, remainder-1-arg2, remainder-x-x.

; ---------- QUOTIENT, DIVIDES  ----------

Theorem: quotient-noop (b = 1) → ((a ÷ b) = fix (a))

Theorem: quotient-of-non-number (a ∉ N) → ((a ÷ n) = (0 ÷ n))

Theorem: quotient-zero (x ≃ 0) → ((y ÷ x) = 0)

Theorem: quotient-add1 ((a mod b) = 0) → (((1 + a) ÷ b)

= if b = 1 then 1 + (a ÷ b) else a ÷ b endif)

Theorem: equal-quotient-0 ((a ÷ b) = 0) = ((b ≃ 0) ∨ (a < b))

Theorem: quotient-sub1 ((a ≄ 0) ∧ (b ≄ 0)) → (((a − 1) ÷ b)

= if (a mod b) = 0 then (a ÷ b) − 1 else a ÷ b endif)

Theorem: quotient-plus-proof ((b mod c) = 0) → (((a + b) ÷ c) = ((a ÷ c) + (b ÷ c)))

Theorem: quotient-plus ((a mod c) = 0) → ((((a + b) ÷ c) = ((a ÷ c) + (b ÷ c)))

∧ (((b + a) ÷ c) = ((a ÷ c) + (b ÷ c)))

∧ (((x + y + a) ÷ c)
= (((x + y) ÷ c) + (a ÷ c))))

; 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.

Theorem: quotient-times-instance-temp-proof ((y ∗ x) ÷ y) = if y ≃ 0 then 0

else fix (x) endif

Theorem: quotient-times-instance-temp (((y ∗ x) ÷ y) = if y ≃ 0 then 0

else fix (x) endif) ∧ (((x ∗ y) ÷ y)

= if y ≃ 0 then 0 else fix (x) endif)

Event: Disable quotient-times-instance-temp.

Theorem: quotient-times-proof ((a mod c) = 0) → (((a ∗ b) ÷ c) = (b ∗ (a ÷ c)))

Theorem: quotient-times ((a mod c) = 0) → ((((a ∗ b) ÷ c) = (b ∗ (a ÷ c)))

∧ (((b ∗ a) ÷ c) = (b ∗ (a ÷ c))))

Theorem: quotient-times-instance (((y ∗ x) ÷ y) = if y ≃ 0 then 0

else fix (x) endif) ∧ (((x ∗ y) ÷ y)

= if y ≃ 0 then 0 else fix (x) endif)

Theorem: quotient-times-times-proof ((x ∗ y) ÷ (x ∗ z)) = if x ≃ 0 then 0

else y ÷ z endif

Theorem: quotient-times-times (((x ∗ y) ÷ (x ∗ z)) = if x ≃ 0 then 0

else y ÷ z endif) ∧ (((x ∗ z) ÷ (y ∗ z))

= if z ≃ 0 then 0 else x ÷ y endif)

Event: Disable quotient-times-times.

Theorem: quotient-difference1 ((a mod c) = (b mod c)) → (((a − b) ÷ c) = ((a ÷ c) − (b ÷ c)))

Theorem: quotient-lessp-arg1 (a < b) → ((a ÷ b) = 0)

Theorem: quotient-difference2 (((a mod c) = 0) ∧ ((b mod c) ≠ 0)) → (((a − b) ÷ c)

= if b < a then (a ÷ c) − (1 + (b ÷ c)) else 0 endif)

Theorem: quotient-difference3 (((b mod c) = 0) ∧ ((a mod c) ≠ 0)) → (((a − b) ÷ c)

= if b < a then (a ÷ c) − (b ÷ c) else 0 endif)

Theorem: remainder-equals-its-first-argument (a = (a mod b)) = ((a ∈ N) ∧ ((b ≃ 0) ∨ (a < b)))

Event: Disable remainder-equals-its-first-argument.

Theorem: quotient-remainder-times ((x mod (a ∗ b)) ÷ a) = ((x ÷ a) mod b)

Theorem: quotient-remainder ((c mod a) = 0) → (((b mod c) ÷ a) = ((b ÷ a) mod (c ÷ a)))

Theorem: quotient-remainder-instance ((x mod (a ∗ b)) ÷ a) = ((x ÷ a) mod b)

Theorem: quotient-plus-fact (((b mod x) = 0) ∧ ((c mod x) = 0) ∧ (a < x)) → (((a + b) ÷ c) = (b ÷ c))

Theorem: quotient-plus-times-times-proof (a < b) → (((a + (b ∗ c)) ÷ (b ∗ d)) = ((b ∗ c) ÷ (b ∗ d)))

Theorem: quotient-plus-times-times (a < b) → ((((a + (b ∗ c)) ÷ (b ∗ d)) = ((b ∗ c) ÷ (b ∗ d)))

∧ (((a + (b ∗ c)) ÷ (b ∗ d))

= ((b ∗ c) ÷ (b ∗ d))))

; QUOTIENT-PLUS-TIMES-TIMES-INSTANCE is the completion of the rules
; QUOTIENT-TIMES-TIMES, QUOTIENT-PLUS-TIMES-TIMES and TIMES-DISTRIBUTES-OVER-PLUS

Theorem: quotient-plus-times-times-instance (a < b) → ((((a + (b ∗ c) + (b ∗ d)) ÷ (b ∗ e))

= if b ≃ 0 then 0

else (c + d) ÷ e endif) ∧ (((a + (c ∗ b) + (d ∗ b)) ÷ (e ∗ b))

= if b ≃ 0 then 0 else (d + c) ÷ e endif))

Theorem: quotient-quotient ((b ÷ a) ÷ c) = (b ÷ (a ∗ c))

Theorem: leq-quotient (a < b) → ((a ÷ c) ≤ (b ÷ c))

Theorem: quotient-1-arg2 (n ÷ 1) = fix (n)

Theorem: quotient-1-arg1-casesplit (n ≃ 0) ∨ (n = 1) ∨ (1 < n)

Theorem: quotient-1-arg1 (1 ÷ n) = if n = 1 then 1

else 0 endif Theorem: quotient-x-x (x ≄ 0) → ((x ÷ x) = 1)

Theorem: lessp-quotient ((i ÷ j ) < i) = ((i ≄ 0) ∧ (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))
;;

Definition: cancel-quotient-times (x) = if (car (x) = 'quotient)

∧ (caadr (x) = 'times) ∧ (caaddr (x) = 'times)

then let inboth be bagint (times-fringe (cadr (x)),

times-fringe (caddr (x)))

in

if listp (inboth) then 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))

else x endif endlet else x endif

Theorem: zerop-makes-quotient-zero-bridge ((car (x) = 'times) ∧ (car (y) = 'times) ∧ (¬ eval$ (t,

and-not-zerop-tree (bagint (times-fringe (x), times-fringe (y))), a)))

→ (((eval$ (t, cadr (x), a) ∗ eval$ (t, caddr (x), a)) ÷ (eval$ (t, cadr (y), a) ∗ eval$ (t, caddr (y), a))) = 0)

Event: Disable zerop-makes-quotient-zero-bridge.

Theorem: eval$-quotient-times-tree-bagdiff (subbagp (x, y) ∧ subbagp (x, z) ∧ eval$ (t, and-not-zerop-tree (x), a)) → ((eval$ (t, times-tree (bagdiff (y, x)), a)

÷ eval$ (t, times-tree (bagdiff (z, x)), a))

= (eval$ (t, times-tree (y), a) ÷ eval$ (t, times-tree (z), a)))

Event: Disable eval$-quotient-times-tree-bagdiff.

Theorem: correctness-of-cancel-quotient-times eval$ (t, x, a) = eval$ (t, cancel-quotient-times (x), a)

; 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))

Event: Let us define the theory quotients to consist of the following events: quotient-noop, quotient-of-non-number, quotient-zero, quotient-add1, equal-quotient-0, quotient-sub1, quotient-plus, quotient-times, quotient-times-instance, quotientdifference1, quotient-lessp-arg1, quotient-difference2, quotient-difference3, quotientremainder-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

Definition: exp (i, j ) = if j ≃ 0 then 1

else i ∗ exp (i, j − 1) endif

Definition: log (base, n) = if base < 2 then 0

elseif n ≃ 0 then 0

else 1 + log (base, n ÷ base) endif

Definition: gcd (x, y) = if x ≃ 0 then fix (y)

elseif y ≃ 0 then x

elseif x < y then gcd (x, y − x)

else gcd (x − y, y) endif

Theorem: remainder-exp (k ≄ 0) → ((exp (n, k) mod n) = 0)

Definition: double-number-induction (i, j ) = if i ≃ 0 then 0

elseif j ≃ 0 then 0

else double-number-induction (i − 1, j − 1) endif

Theorem: remainder-exp-exp (i ≤ j ) → ((exp (a, j ) mod exp (a, i)) = 0)

Theorem: quotient-exp (k ≄ 0) → ((exp (n, k) ÷ n)

= if n ≃ 0 then 0 else exp (n, k − 1) endif)

Theorem: exp-zero (k ≃ 0) → (exp (n, k) = 1)

Theorem: exp-add1 exp (n, 1 + k) = (n ∗ exp (n, k))

Theorem: exp-plus exp (i, j + k) = (exp (i, j ) ∗ exp (i, k))

Theorem: exp-0-arg1 exp (0, k) = if k ≃ 0 then 1

else 0 endif

Theorem: exp-1-arg1 exp (1, k) = 1

Theorem: exp-0-arg2 exp (n, 0) = 1

Theorem: exp-times exp (i ∗ j , k) = (exp (i, k) ∗ exp (j , k))

Theorem: exp-exp exp (exp (i, j ), k) = exp (i, j ∗ k)

Theorem: equal-exp-0 (exp (n, k) = 0) = ((n ≃ 0) ∧ (k ≄ 0))

Theorem: equal-exp-1 (exp (n, k) = 1) = if k ≃ 0 then t

else n = 1 endif

Theorem: exp-difference ((c ≤ b) ∧ (a ≄ 0)) → (exp (a, b − c) = (exp (a, b) ÷ exp (a, c)))

Event: Let us define the theory exponentiation to consist of the following events: 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, remainderexp-exp, remainder-exp.

Theorem: equal-log-0 (log (base, n) = 0) = ((base < 2) ∨ (n ≃ 0))

Theorem: log-0 (n ≃ 0) → (log (base, n) = 0)

Theorem: log-1 (1 < base) → (log (base, 1) = 1)

Definition: double-log-induction (base, a, b) = if base < 2 then 0

elseif a ≃ 0 then 0 elseif b ≃ 0 then 0 else double-log-induction (base, a ÷ base, b ÷ base) endif Theorem: leq-log-log (n ≤ m) → (log (c, n) ≤ log (c, m))

Theorem: log-quotient (1 < c) → (log (c, n ÷ c) = (log (c, n) − 1))

Theorem: log-quotient-times-proof (1 < c) → (log (c, n ÷ (c ∗ m)) = (log (c, n ÷ m) − 1))

Theorem: log-quotient-times (1 < c) → ((log (c, n ÷ (c ∗ m)) = (log (c, n ÷ m) − 1))

∧ (log (c, n ÷ (m ∗ c)) = (log (c, n ÷ m) − 1)))

Theorem: log-quotient-exp (1 < c) → (log (c, n ÷ exp (c, m)) = (log (c, n) − m))

Theorem: log-times-proof ((1 < c) ∧ (n ≄ 0)) → (log (c, c ∗ n) = (1 + log (c, n)))

Theorem: log-times ((1 < c) ∧ (n ≄ 0)) → ((log (c, c ∗ n) = (1 + log (c, n)))

∧ (log (c, n ∗ c) = (1 + log (c, n))))

Theorem: log-times-exp-proof ((1 < c) ∧ (n ≄ 0)) → (log (c, n ∗ exp (c, m)) = (log (c, n) + m))

Theorem: log-times-exp ((1 < c) ∧ (n ≄ 0)) → ((log (c, n ∗ exp (c, m)) = (log (c, n) + m))

∧ (log (c, exp (c, m) ∗ n) = (log (c, n) + m)))

Theorem: log-exp (1 < c) → (log (c, exp (c, n)) = (1 + n))

Event: Let us define the theory logs to consist of the following events: log-exp, log-times-exp, log-times, log-quotient-exp, log-quotient-times, log-quotient, log-1, log-0, equal-log-0, exp-exp.

Theorem: commutativity-of-gcd gcd (b, a) = gcd (a, b)

Definition: single-number-induction (n) = if n ≃ 0 then 0

else single-number-induction (n − 1) endif Theorem: gcd-0 (gcd (0, x) = fix (x)) ∧ (gcd (x, 0) = fix (x))

Theorem: gcd-1 (gcd (1, x) = 1) ∧ (gcd (x, 1) = 1)

Theorem: equal-gcd-0 (gcd (a, b) = 0) = ((a ≃ 0) ∧ (b ≃ 0))

Theorem: lessp-gcd (b ≄ 0) → (((b < gcd (a, b)) = f) ∧ ((b < gcd (b, a)) = f))

Theorem: gcd-plus-instance-temp-proof gcd (a, a + b) = gcd (a, b)

Theorem: gcd-plus-instance-temp (gcd (a, a + b) = gcd (a, b)) ∧ (gcd (a, b + a) = gcd (a, b))

Theorem: gcd-plus-proof ((b mod a) = 0) → (gcd (a, b + c) = gcd (a, c))

Theorem: gcd-plus ((b mod a) = 0) → ((gcd (a, b + c) = gcd (a, c))

∧ (gcd (a, c + b) = gcd (a, c)) ∧ (gcd (b + c, a) = gcd (a, c)) ∧ (gcd (c + b, a) = gcd (a, c)))

Theorem: gcd-plus-instance (gcd (a, a + b) = gcd (a, b)) ∧ (gcd (a, b + a) = gcd (a, b))

Theorem: remainder-gcd ((a mod gcd (a, b)) = 0) ∧ ((b mod gcd (a, b)) = 0)

Theorem: distributivity-of-times-over-gcd-proof gcd (x ∗ z, y ∗ z) = (z ∗ gcd (x, y))

Theorem: distributivity-of-times-over-gcd (gcd (x ∗ z, y ∗ z) = (z ∗ gcd (x, y))) ∧ (gcd (z ∗ x, y ∗ z) = (z ∗ gcd (x, y))) ∧ (gcd (x ∗ z, z ∗ y) = (z ∗ gcd (x, y))) ∧ (gcd (z ∗ x, z ∗ y) = (z ∗ gcd (x, y)))

Theorem: gcd-is-the-greatest ((x ≄ 0) ∧ (y ≄ 0) ∧ ((x mod z) = 0) ∧ ((y mod z) = 0)) → (z ≤ gcd (x, y))

Theorem: common-divisor-divides-gcd (((x mod z) = 0) ∧ ((y mod z) = 0)) → ((gcd (x, y) mod z) = 0)

; 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.

Theorem: associativity-of-gcd-zero-case ((a ≃ 0) ∨ (b ≃ 0) ∨ (c ≃ 0)) → (gcd (gcd (a, b), c) = gcd (a, gcd (b, c)))

Theorem: associativity-of-gcd gcd (gcd (a, b), c) = gcd (a, gcd (b, c))

Theorem: commutativity2-of-gcd-zero-case ((a ≃ 0) ∨ (b ≃ 0) ∨ (c ≃ 0)) → (gcd (b, gcd (a, c)) = gcd (a, gcd (b, c)))

Theorem: commutativity2-of-gcd gcd (b, gcd (a, c)) = gcd (a, gcd (b, c))

Theorem: gcd-x-x gcd (x, x) = fix (x)

Theorem: gcd-idempotence (gcd (x, gcd (x, y)) = gcd (x, y)) ∧ (gcd (y, gcd (x, y)) = gcd (x, y))

Event: Let us define the theory gcds to consist of the following events: commutativity2of-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, remaindergcd, gcd-plus, gcd-plus-instance, gcd-1, commutativity-of-gcd.

Event: Let us define the theory naturals to consist of the following events: 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))))))
|#

Definition: integerp (x) = if x ∈ N then t

elseif negativep (x) then negative-guts (x) ≄ 0 else f endif

Definition: fix-int (x) = if integerp (x) then x

else 0 endif

;; Even though I'll include a definition for izerop here, I'll
;; often avoid using it.

Definition: izerop (i) = (fix-int (i) = 0)

#| old version:
(defn izerop (i)
  (if (integerp i)
      (equal i 0)
      t))
|#

Definition: ilessp (i, j ) = if negativep (i)

then if negativep (j ) then negative-guts (j ) < negative-guts (i) elseif i = (− 0) then 0 < j else t endif elseif negativep (j ) then f else i < j endif

Definition: ileq (i, j ) = (¬ ilessp (j , i))

Definition: iplus (x, y) = if negativep (x)

then if negativep (y)

then if (negative-guts (x) ≃ 0) ∧ (negative-guts (y) ≃ 0) then 0 else − (negative-guts (x) + negative-guts (y)) endif elseif y < negative-guts (x) then − (negative-guts (x) − y) else y − negative-guts (x) endif

elseif negativep (y)

then if x < negative-guts (y) then − (negative-guts (y) − x)

else x − negative-guts (y) endif else x + y endif

Definition: ineg (x) = if negativep (x) then negative-guts (x)

elseif x ≃ 0 then 0

else − x endif

Definition: idifference (x, y) = iplus (x, ineg (y))

Definition: iabs (i) = if negativep (i) then negative-guts (i)

else fix (i) endif

Definition: itimes (i, j ) = if negativep (i)

then if negativep (j ) then negative-guts (i) ∗ negative-guts (j )

else fix-int (− (negative-guts (i) ∗ j )) endif elseif negativep (j ) then fix-int (− (i ∗ negative-guts (j ))) else i ∗ j endif Definition: iquotient (i, j ) = if fix-int (j ) = 0 then 0

elseif negativep (i) then if negativep (j )

then if (negative-guts (i) mod negative-guts (j )) = 0 then negative-guts (i) ÷ negative-guts (j ) else 1 + (negative-guts (i) ÷ negative-guts (j )) endif

elseif (negative-guts (i) mod j ) = 0 then fix-int (− (negative-guts (i) ÷ j )) else fix-int (− (1 + (negative-guts (i) ÷ j ))) endif elseif negativep (j ) then fix-int (− (i ÷ negative-guts (j ))) else i ÷ j endif

Definition: iremainder (i, j ) = idifference (i, itimes (j , iquotient (i, j )))

Definition: idiv (i, j ) = if fix-int (j ) = 0 then 0

elseif negativep (i)

then if negativep (j ) then negative-guts (i) ÷ negative-guts (j ) elseif (negative-guts (i) mod j ) = 0 then fix-int (− (negative-guts (i) ÷ j )) else fix-int (− (1 + (negative-guts (i) ÷ j ))) endif

elseif negativep (j )

then if (i mod negative-guts (j )) = 0 then fix-int (− (i ÷ negative-guts (j ))) else fix-int (− (1 + (i ÷ negative-guts (j )))) endif

else i ÷ j endif

Definition: imod (i, j ) = idifference (fix-int (i), itimes (j , idiv (i, j )))

Definition: iquo (i, j ) = if fix-int (j ) = 0 then 0

elseif negativep (i)

then if negativep (j ) then negative-guts (i) ÷ negative-guts (j )

else fix-int (− (negative-guts (i) ÷ j )) endif elseif negativep (j ) then fix-int (− (i ÷ negative-guts (j ))) else i ÷ j endif

Definition: irem (i, j ) = idifference (fix-int (i), itimes (j , iquo (i, j )))

; ---------- DEFTHEORY events for definitions ----------

Event: Let us define the theory integer-defns to consist of the following events: integerp, fix-int, ilessp, iplus, ineg, iabs, itimes, iquotient, iremainder, idiv, imod, iquo, irem. Event: Let us define the theory all-integer-defns to consist of the following events: integerp, fix-int, izerop, ilessp, ileq, iplus, ineg, idifference, iabs, itimes, iquotient, iremainder, idiv, imod, iquo, irem. Event: Disable integerp. Event: Disable fix-int. Event: Disable ilessp. Event: Disable iplus. Event: Disable ineg. Event: Disable iabs. Event: 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 ----------

Theorem: integerp-fix-int integerp (fix-int (x)) Theorem: integerp-iplus integerp (iplus (x, y)) Theorem: integerp-idifference integerp (idifference (x, y))

Theorem: integerp-ineg integerp (ineg (x))

Theorem: integerp-iabs integerp (iabs (x))

Theorem: integerp-itimes integerp (itimes (x, y))

; ---------- 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.

Theorem: fix-int-remover integerp (x) → (fix-int (x) = x)

Theorem: fix-int-fix-int fix-int (fix-int (x)) = fix-int (x)

Theorem: fix-int-iplus fix-int (iplus (a, b)) = iplus (a, b)

Theorem: fix-int-idifference fix-int (idifference (a, b)) = idifference (a, b)

Theorem: fix-int-ineg fix-int (ineg (x)) = ineg (x)

Theorem: fix-int-iabs fix-int (iabs (x)) = iabs (x)

Theorem: fix-int-itimes fix-int (itimes (x, y)) = itimes (x, y)

; ---------- INEG ----------

Theorem: ineg-iplus ineg (iplus (a, b)) = iplus (ineg (a), ineg (b))

Theorem: ineg-ineg ineg (ineg (x)) = fix-int (x)

Theorem: ineg-fix-int ineg (fix-int (x)) = ineg (x) Theorem: ineg-of-non-integerp (¬ integerp (x)) → (ineg (x) = 0)

;; I don't want the backchaining to slow down the prover.

Event: Disable ineg-of-non-integerp.

Theorem: ineg-0 ineg (0) = 0

; ---------- IPLUS ----------
;; The first two of these really aren't necessary, in light
;; of the cancellation metalemma.

Theorem: iplus-left-id (¬ integerp (x)) → (iplus (x, y) = fix-int (y))

;; I don't want the backchaining to slow down the prover.

Event: Disable iplus-left-id.

Theorem: iplus-right-id (¬ integerp (y)) → (iplus (x, y) = fix-int (x))

;; I don't want the backchaining to slow down the prover.

Event: Disable iplus-right-id.

Theorem: iplus-0-left iplus (0, x) = fix-int (x) Theorem: iplus-0-right iplus (x, 0) = fix-int (x) Theorem: commutativity2-of-iplus iplus (x, iplus (y, z)) = iplus (y, iplus (x, z)) Theorem: commutativity-of-iplus iplus (x, y) = iplus (y, x)

Theorem: associativity-of-iplus iplus (iplus (x, y), z) = iplus (x, iplus (y, z))

Theorem: iplus-cancellation-1 (iplus (a, b) = iplus (a, c)) = (fix-int (b) = fix-int (c))

Theorem: iplus-cancellation-2 (iplus (b, a) = iplus (c, a)) = (fix-int (b) = fix-int (c))

Theorem: iplus-ineg1 iplus (ineg (a), a) = 0

Theorem: iplus-ineg2 iplus (a, ineg (a)) = 0

Theorem: iplus-fix-int1 iplus (fix-int (a), b) = iplus (a, b)

Theorem: iplus-fix-int2 iplus (a, fix-int (b)) = iplus (a, b)

; ---------- IDIFFERENCE ----------
;; mostly omitted, but I'll keep a few

Theorem: idifference-fix-int1 idifference (fix-int (a), b) = idifference (a, b)

Theorem: idifference-fix-int2 idifference (a, fix-int (b)) = idifference (a, b)

; --------------------------------------------------------------------------------
; 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))))
|#

Definition: cancel-ineg-aux (x, y) = if listp (x)

then if car (x) = 'ineg

then if y = cadr (x) then ''0 elseif listp (y) then if car (y) = 'iplus

then if cadr (y) = cadr (x) then list ('fix-int, caddr (y)) elseif cancel-ineg-aux (x, caddr (y)) then list ('iplus, cadr (y), cancel-ineg-aux (x, caddr (y)))

else f endif else f endif

else f endif elseif y ≃ nil then f elseif car (y) = 'ineg then if x = cadr (y) then ''0

else f endif elseif car (y) = 'iplus then if listp (cadr (y))

then if caadr (y) = 'ineg

then if x = cadadr (y)

then list ('fix-int, caddr (y)) elseif cancel-ineg-aux (x, caddr (y)) then list ('iplus,

cadr (y),

cancel-ineg-aux (x, caddr (y)))

else f endif elseif cancel-ineg-aux (x, caddr (y)) then list ('iplus, cadr (y), cancel-ineg-aux (x, caddr (y))) else f endif

elseif cancel-ineg-aux (x, caddr (y))

then list ('iplus, cadr (y), cancel-ineg-aux (x, caddr (y))) else f endif

else f endif elseif y ≃ nil then f elseif car (y) = 'ineg then if x = cadr (y) then ''0

else f endif elseif car (y) = 'iplus then if listp (cadr (y))

then if caadr (y) = 'ineg

then if x = cadadr (y) then list ('fix-int, caddr (y)) elseif cancel-ineg-aux (x, caddr (y)) then list ('iplus, cadr (y), cancel-ineg-aux (x, caddr (y))) else f endif

elseif cancel-ineg-aux (x, caddr (y))

then list ('iplus, cadr (y), cancel-ineg-aux (x, caddr (y))) else f endif

elseif cancel-ineg-aux (x, caddr (y)) then list ('iplus, cadr (y), cancel-ineg-aux (x, caddr (y))) else f endif

else f endif

#| 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))
|#

Definition: cancel-ineg (x) = if listp (x)

then if car (x) = 'iplus

then if cancel-ineg-aux (cadr (x), caddr (x)) then cancel-ineg-aux (cadr (x), caddr (x)) else x endif

else x endif else x endif

;; It seems a big win to turn off eval$.  I'll leave the recursive step out in
;; hopes that rewrite-eval$ handles it OK.

Theorem: eval$-list-cons eval$ ('list, cons (x, y), a) = cons (eval$ (t, x, a), eval$ ('list, y, a))

Theorem: eval$-list-nlistp (x ≃ nil) → (eval$ ('list, x, a) = nil)

Theorem: eval$-litatom litatom (x) → (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.

Event: Enable eval$-quote.

Theorem: eval$-other ((¬ litatom (x)) ∧ (x ≃ nil)) → (eval$ (t, x, a) = x)

Event: 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.

Definition: eval$-cancel-ineg-aux-fn (x, y, a) = if listp (x) ∧ (car (x) = 'ineg)

then if y = cadr (x) then 0

else let y1 be cadr (y),

y2 be caddr (y) in if y1 = cadr (x) then fix-int (eval$ (t, y2 , a)) elseif listp (y) then iplus (eval$ (t, y1 , a),

eval$-cancel-ineg-aux-fn (x, y2 , a))

else 0 endif endlet endif

else if car (y) = 'ineg then 0 else let y1 be cadr (y),

y2 be caddr (y) in if listp (y1 )

∧ (car (y1 ) = 'ineg) ∧ (x = cadr (y1 )) then fix-int (eval$ (t, y2 , a)) elseif listp (y) then iplus (eval$ (t, y1 , a),

eval$-cancel-ineg-aux-fn (x, y2 , a))

else 0 endif endlet endif endif

Theorem: eval$-cancel-ineg-aux-is-its-fn (cancel-ineg-aux (x, y) ≠ f) → (eval$ (t, cancel-ineg-aux (x, y), a) = eval$-cancel-ineg-aux-fn (x, y, a))

Theorem: iplus-ineg3 iplus (ineg (x), iplus (x, y)) = fix-int (y)

Theorem: iplus-ineg4 iplus (x, iplus (ineg (x), y)) = fix-int (y)

Theorem: iplus-ineg-promote iplus (y, ineg (x)) = iplus (ineg (x), y)

Theorem: iplus-x-y-ineg-x iplus (x, iplus (y, ineg (x))) = fix-int (y)

Event: Disable iplus-ineg-promote.

Theorem: correctness-of-cancel-ineg-aux (cancel-ineg-aux (x, y) ≠ f) → (eval$-cancel-ineg-aux-fn (x, y, a) = iplus (eval$ (t, x, a), eval$ (t, y, a)))

Theorem: correctness-of-cancel-ineg eval$ (t, x, a) = eval$ (t, cancel-ineg (x), a)

Event: 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)))
|#

Definition: iplus-fringe (x) = if listp (x)

then if car (x) = 'iplus then append (iplus-fringe (cadr (x)), iplus-fringe (caddr (x))) else list (x) endif

else list (x) endif

Theorem: lessp-count-listp-cdr listp (cdr (x)) → (count (cdr (x)) < count (x))

Definition: iplus-tree-rec (l) = if cdr (l) ≃ nil then car (l)

else list ('iplus, car (l), iplus-tree-rec (cdr (l))) endif

Definition: iplus-tree (l) = if listp (l)

then if listp (cdr (l)) then iplus-tree-rec (l) else list ('fix-int, car (l)) endif

else ''0 endif

Definition: iplus-list (x) = if listp (x) then iplus (car (x), iplus-list (cdr (x)))

else 0 endif

Theorem: integerp-iplus-list integerp (iplus-list (x))

Theorem: eval$-iplus-tree-rec eval$ (t, iplus-tree-rec (x), a) = if listp (x)

then if listp (cdr (x)) then iplus-list (eval$ ('list, x, a))

else eval$ (t, car (x), a) endif else 0 endif

Theorem: eval$-iplus-tree eval$ (t, iplus-tree (x), a) = iplus-list (eval$ ('list, x, a))

Theorem: eval$-list-append 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))
|#

Definition: cancel-iplus (x) = if listp (x) then if car (x) = 'equal

then if listp (cadr (x))

then if caadr (x) = 'iplus

then if listp (caddr (x))

then if caaddr (x) = 'iplus

then if listp (bagint (iplus-fringe (cadr (x)),

iplus-fringe (caddr (x))))

then 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))))))

else x endif elseif caddr (x) ∈ iplus-fringe (cadr (x)) then list ('if,

list ('integerp, caddr (x)),

         cons ('equal,

cons (iplus-tree (delete (caddr (x),

iplus-fringe (cadr (x)))),

                  '('0))),

list ('quote, f))

else x endif elseif caddr (x) ∈ iplus-fringe (cadr (x)) then list ('if,

list ('integerp, caddr (x)),

    cons ('equal,

cons (iplus-tree (delete (caddr (x),

iplus-fringe (cadr (x)))),

             '('0))),

list ('quote, f))

else x endif elseif listp (caddr (x)) then if caaddr (x) = 'iplus

then if cadr (x) ∈ iplus-fringe (caddr (x))

then list ('if, list ('integerp, cadr (x)),

         list ('equal,
            ''0,

iplus-tree (delete (cadr (x),

iplus-fringe (caddr (x))))),

list ('quote, f))

else x endif

else x endif else x endif

elseif listp (caddr (x)) then if caaddr (x) = 'iplus

then if cadr (x) ∈ iplus-fringe (caddr (x))

then list ('if, list ('integerp, cadr (x)),

                  list ('equal,
                      ''0,

iplus-tree (delete (cadr (x),

iplus-fringe (caddr (x))))),

list ('quote, f))

else x endif else x endif

else x endif else x endif

else x endif

Theorem: eval$-cancel-iplus eval$ (t, cancel-iplus (x), a) = if listp (x) ∧ (car (x) = 'equal)

then if listp (cadr (x)) ∧ (caadr (x) = 'iplus) ∧ listp (caddr (x)) ∧ (caaddr (x) = 'iplus)

then let xs be iplus-fringe (cadr (x)),

ys be iplus-fringe (caddr (x)) in let bagint be bagint (xs, ys) in if listp (bagint) then iplus-list (eval$ ('list,

bagdiff (xs,

bagint (xs, ys)), a))

= iplus-list (eval$ ('list,

bagdiff (ys,

bagint (xs,

ys)),

a))

else eval$ (t, x, a) endif endlet endlet elseif listp (cadr (x))

∧ (caadr (x) = 'iplus) ∧ (caddr (x) ∈ iplus-fringe (cadr (x))) then if integerp (eval$ (t, caddr (x), a)) then iplus-list (eval$ ('list,

delete (caddr (x), iplus-fringe (cadr (x))), a))

                   = 0

else f endif elseif listp (caddr (x))

∧ (caaddr (x) = 'iplus)

∧ (cadr (x) ∈ iplus-fringe (caddr (x))) then if integerp (eval$ (t, cadr (x), a))

then 0 = iplus-list (eval$ ('list,

delete (cadr (x),

iplus-fringe (caddr (x))), a))

else f endif else eval$ (t, x, a) endif

else eval$ (t, x, a) endif

Event: Disable cancel-iplus.

Theorem: eval$-iplus-list-delete (z ∈ y) → (iplus-list (eval$ ('list, delete (z, y), a))

= idifference (iplus-list (eval$ ('list, y, a)), eval$ (t, z, a)))

Theorem: eval$-iplus-list-bagdiff subbagp (x, y) → (iplus-list (eval$ ('list, bagdiff (y, x), a))

= idifference (iplus-list (eval$ ('list, y, a)), iplus-list (eval$ ('list, x, a))))

Theorem: iplus-list-append iplus-list (append (x, y)) = iplus (iplus-list (x), iplus-list (y))

Event: Disable iplus-tree.

;; because we want to use EVAL$-IPLUS-TREE for now

Theorem: not-integerp-implies-not-equal-iplus (¬ integerp (a)) → ((a = iplus (b, c)) = f)

Theorem: iplus-list-eval$-fringe iplus-list (eval$ ('list, iplus-fringe (x), a)) = fix-int (eval$ (t, x, a))

;; The following two lemmas aren't needed but they sure do
;; shorten the total proof time!!!

Theorem: iplus-ineg5-lemma-1 integerp (x) → ((x = iplus (y, iplus (ineg (z), w)))

= (x = iplus (ineg (z), iplus (y, w))))

Theorem: iplus-ineg5-lemma-2 (integerp (x) ∧ integerp (v)) → ((x = iplus (ineg (z), v)) = (iplus (x, z) = v))

Theorem: iplus-ineg5 integerp (x) → ((x = iplus (y, iplus (ineg (z), w))) = (iplus (x, z) = iplus (y, w)))

Event: Disable iplus-ineg5-lemma-1.

Event: Disable iplus-ineg5-lemma-2.

Theorem: iplus-ineg6 integerp (x) → ((x = iplus (y, iplus (w, ineg (z)))) = (iplus (x, z) = iplus (y, w)))

Theorem: eval$-iplus (listp (x) ∧ (car (x) = 'iplus)) → (eval$ (t, x, a) = iplus (eval$ (t, cadr (x), a), eval$ (t, caddr (x), a)))

Theorem: iplus-ineg7 (0 = iplus (x, ineg (y))) = (fix-int (y) = fix-int (x))

Theorem: correctness-of-cancel-iplus eval$ (t, x, a) = eval$ (t, cancel-iplus (x), a)

Event: Disable iplus-ineg5.

Event: 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.

Theorem: ilessp-fix-int-1 ilessp (fix-int (x), y) = ilessp (x, y)

Theorem: ilessp-fix-int-2 ilessp (x, fix-int (y)) = ilessp (x, y)

;; 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.

Definition: make-cancel-iplus-inequality-1 (x, y)

= list ('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))
|#

Definition: cancel-iplus-ilessp-1 (x) = if listp (x)

then if car (x) = 'ilessp

then make-cancel-iplus-inequality-1 (iplus-fringe (cadr (x)),

iplus-fringe (caddr (x)))

else x endif else x endif

;; 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.

Theorem: lessp-difference-plus-arg1 (w < ((w + y) − x)) = (x < y)

Theorem: lessp-difference-plus-arg1-commuted (w < ((y + w) − x)) = (x < y)

Theorem: iplus-cancellation-1-for-ilessp ilessp (iplus (a, b), iplus (a, c)) = ilessp (b, c)

Theorem: iplus-cancellation-2-for-ilessp ilessp (iplus (b, a), iplus (c, a)) = ilessp (b, c)

Theorem: correctness-of-cancel-iplus-ilessp-lemma eval$ (t, x, a) = eval$ (t, cancel-iplus-ilessp-1 (x), a)

Definition: iplus-tree-no-fix-int (l) = if listp (l) then iplus-tree-rec (l)

else ''0 endif

Theorem: eval$-ilessp-iplus-tree-no-fix-int 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))

Event: Disable iplus-tree-no-fix-int.

Theorem: make-cancel-iplus-inequality-simplifier eval$ (t, make-cancel-iplus-inequality-1 (x, y), a) = eval$ (t,

         list ('ilessp,

iplus-tree-no-fix-int (bagdiff (x, bagint (x, y))), iplus-tree-no-fix-int (bagdiff (y, bagint (x, y)))),

a)

#| 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.

Definition: cancel-iplus-ilessp (x) = if listp (x)

then if car (x) = 'ilessp

then if listp (bagint (iplus-fringe (cadr (x)),

iplus-fringe (caddr (x))))

then 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))))))

else x endif else x endif

else x endif

Event: Disable make-cancel-iplus-inequality-1.

Theorem: correctness-of-cancel-iplus-ilessp eval$ (t, x, a) = eval$ (t, cancel-iplus-ilessp (x), a)

; ---------- Multiplication ----------

Theorem: itimes-zero1 (fix-int (x) = 0) → (itimes (x, y) = 0)

Theorem: itimes-0-left itimes (0, y) = 0

;; I don't want the backchaining to slow down the prover.

Event: Disable itimes-zero1.

Theorem: itimes-zero2 (fix-int (y) = 0) → (itimes (x, y) = 0)

Theorem: itimes-0-right itimes (x, 0) = 0

;; I don't want the backchaining to slow down the prover.

Event: Disable itimes-zero2.

Theorem: itimes-fix-int1 itimes (fix-int (a), b) = itimes (a, b)

Theorem: itimes-fix-int2 itimes (a, fix-int (b)) = itimes (a, b)

Theorem: commutativity-of-itimes itimes (x, y) = itimes (y, x)

Theorem: itimes-distributes-over-iplus-proof itimes (x, iplus (y, z)) = iplus (itimes (x, y), itimes (x, z))

Theorem: itimes-distributes-over-iplus (itimes (x, iplus (y, z)) = iplus (itimes (x, y), itimes (x, z))) ∧ (itimes (iplus (x, y), z) = iplus (itimes (x, z), itimes (y, z)))

Theorem: commutativity2-of-itimes itimes (x, itimes (y, z)) = itimes (y, itimes (x, z))

Theorem: associativity-of-itimes itimes (itimes (x, y), z) = itimes (x, itimes (y, z))

Theorem: equal-itimes-0 (itimes (x, y) = 0) = ((fix-int (x) = 0) ∨ (fix-int (y) = 0))

Theorem: equal-itimes-1 (itimes (a, b) = 1) = (((a = 1) ∧ (b = 1)) ∨ ((a = -1) ∧ (b = -1)))

Theorem: equal-itimes-minus-1 (itimes (a, b) = -1) = (((a = -1) ∧ (b = 1)) ∨ ((a = 1) ∧ (b = -1)))

Theorem: itimes-1-arg1 itimes (1, x) = fix-int (x)

; ---------- Division ----------

Theorem: quotient-remainder-uniqueness ((a = (r + (b ∗ q))) ∧ (r < b)) → ((fix (r) = (a mod b)) ∧ (fix (q) = (a ÷ b)))

; 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.

Theorem: division-theorem-part1 integerp (i) → (iplus (iremainder (i, j ), itimes (j , iquotient (i, j ))) = i)

Theorem: division-theorem-part2 (integerp (j ) ∧ (j ≠ 0)) → (¬ ilessp (iremainder (i, j ), 0))

Theorem: division-theorem-part3 (integerp (j ) ∧ (j ≠ 0)) → ilessp (iremainder (i, j ), iabs (j ))

Theorem: division-theorem (integerp (i) ∧ integerp (j ) ∧ (j ≠ 0)) → ((iplus (iremainder (i, j ), itimes (j , iquotient (i, j ))) = i)

∧ (¬ ilessp (iremainder (i, j ), 0)) ∧ ilessp (iremainder (i, j ), iabs (j )))

Theorem: quotient-difference-lessp-arg2 (((a mod c) = 0) ∧ (b < c)) → (((a − b) ÷ c)

= if b ≃ 0 then a ÷ c elseif b < a then (a ÷ c) − (1 + (b ÷ c)) else 0 endif)

Theorem: iquotient-iremainder-uniqueness (integerp (i) ∧ integerp (j ) ∧ integerp (r) ∧ integerp (q) ∧ (j ≠ 0) ∧ (i = iplus (r, itimes (j , q))) ∧ (¬ ilessp (r, 0)) ∧ ilessp (r, iabs (j ))) → ((r = iremainder (i, j )) ∧ (q = iquotient (i, j )))

; 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.

Theorem: division-theorem-for-truncate-to-neginf-part1 integerp (i) → (iplus (imod (i, j ), itimes (j , idiv (i, j ))) = i)

Theorem: division-theorem-for-truncate-to-neginf-part2 ilessp (0, j ) → ((¬ ilessp (imod (i, j ), 0)) ∧ ilessp (imod (i, j ), j ))

Theorem: division-theorem-for-truncate-to-neginf-part3 (integerp (j ) ∧ ilessp (j , 0)) → ((¬ ilessp (0, imod (i, j ))) ∧ ilessp (j , imod (i, j )))

Theorem: division-theorem-for-truncate-to-neginf (integerp (i) ∧ integerp (j ) ∧ (j ≠ 0)) → ((iplus (imod (i, j ), itimes (j , idiv (i, j ))) = i)

∧ if ilessp (0, j ) then (¬ ilessp (imod (i, j ), 0)) ∧ ilessp (imod (i, j ), j ) else (¬ ilessp (0, imod (i, j )))

∧ ilessp (j , imod (i, j )) endif)

Theorem: idiv-imod-uniqueness (integerp (i) ∧ integerp (j ) ∧ integerp (r) ∧ integerp (q) ∧ (j ≠ 0) ∧ (i = iplus (r, itimes (j , q))) ∧ if ilessp (0, j ) then (¬ ilessp (r, 0)) ∧ ilessp (r, j )

else (¬ ilessp (0, r)) ∧ ilessp (j , r) endif) → ((r = imod (i, j )) ∧ (q = idiv (i, j )))

; 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.

Theorem: division-theorem-for-truncate-to-zero-part1 integerp (i) → (iplus (irem (i, j ), itimes (j , iquo (i, j ))) = i)

Theorem: division-theorem-for-truncate-to-zero-part2 (integerp (i) ∧ integerp (j ) ∧ (j ≠ 0) ∧ (¬ ilessp (i, 0))) → ((¬ ilessp (irem (i, j ), 0)) ∧ ilessp (irem (i, j ), iabs (j )))

Theorem: division-theorem-for-truncate-to-zero-part3 (integerp (i) ∧ integerp (j ) ∧ (j ≠ 0) ∧ ilessp (i, 0)) → ((¬ ilessp (0, irem (i, j ))) ∧ ilessp (ineg (iabs (j )), irem (i, j )))

Theorem: division-theorem-for-truncate-to-zero (integerp (i) ∧ integerp (j ) ∧ (j ≠ 0)) → ((iplus (irem (i, j ), itimes (j , iquo (i, j ))) = i)

∧ if ¬ ilessp (i, 0) then (¬ ilessp (irem (i, j ), 0))

∧ ilessp (irem (i, j ), iabs (j )) else (¬ ilessp (0, irem (i, j )))

∧ ilessp (ineg (iabs (j )), irem (i, j )) endif)

Theorem: iquo-irem-uniqueness (integerp (i) ∧ integerp (j ) ∧ integerp (r) ∧ integerp (q) ∧ (j ≠ 0) ∧ (i = iplus (r, itimes (j , q))) ∧ if ¬ ilessp (i, 0) then (¬ ilessp (r, 0)) ∧ ilessp (r, iabs (j ))

else (¬ ilessp (0, r)) ∧ ilessp (ineg (iabs (j )), r) endif) → ((r = irem (i, j )) ∧ (q = iquo (i, j )))

; ---------- Multiplication Facts

Theorem: itimes-ineg-1 itimes (ineg (x), y) = ineg (itimes (x, y))

Theorem: itimes-ineg-2 itimes (x, ineg (y)) = ineg (itimes (x, y))

Theorem: itimes-cancellation-1 (itimes (a, b) = itimes (a, c)) = ((fix-int (a) = 0) ∨ (fix-int (b) = fix-int (c)))

Theorem: itimes-cancellation-2 (itimes (b, a) = itimes (c, a)) = ((fix-int (a) = 0) ∨ (fix-int (b) = fix-int (c)))

Theorem: itimes-cancellation-3 (itimes (a, b) = itimes (c, a)) = ((fix-int (a) = 0) ∨ (fix-int (b) = fix-int (c)))

; ---------- Division Facts

Theorem: integerp-iquotient integerp (iquotient (i, j ))

Theorem: integerp-iremainder integerp (iremainder (i, j ))

Theorem: integerp-idiv integerp (idiv (i, j ))

Theorem: integerp-imod integerp (imod (i, j ))

Theorem: integerp-iquo integerp (iquo (i, j ))

Theorem: integerp-irem integerp (irem (i, j ))

Theorem: iquotient-fix-int1 iquotient (fix-int (i), j ) = iquotient (i, j )

Theorem: iquotient-fix-int2 iquotient (i, fix-int (j )) = iquotient (i, j )

Theorem: iremainder-fix-int1 iremainder (fix-int (i), j ) = iremainder (i, j )

Theorem: iremainder-fix-int2 iremainder (i, fix-int (j )) = iremainder (i, j )

Theorem: idiv-fix-int1 idiv (fix-int (i), j ) = idiv (i, j )

Theorem: idiv-fix-int2 idiv (i, fix-int (j )) = idiv (i, j )

Theorem: imod-fix-int1 imod (fix-int (i), j ) = imod (i, j )

Theorem: imod-fix-int2 imod (i, fix-int (j )) = imod (i, j )

Theorem: iquo-fix-int1 iquo (fix-int (i), j ) = iquo (i, j )

Theorem: iquo-fix-int2 iquo (i, fix-int (j )) = iquo (i, j )

Theorem: irem-fix-int1 irem (fix-int (i), j ) = irem (i, j )

Theorem: irem-fix-int2 irem (i, fix-int (j )) = irem (i, j )

Theorem: fix-int-iquotient fix-int (iquotient (i, j )) = iquotient (i, j )

Theorem: fix-int-iremainder fix-int (iremainder (i, j )) = iremainder (i, j )

Theorem: fix-int-idiv fix-int (idiv (i, j )) = idiv (i, j )

Theorem: fix-int-imod fix-int (imod (i, j )) = imod (i, j )

Theorem: fix-int-iquo fix-int (iquo (i, j )) = iquo (i, j )

Theorem: fix-int-irem fix-int (irem (i, j )) = irem (i, j )

Event: Disable iquotient.

Event: Disable iremainder.

Event: Disable idiv.

Event: Disable imod.

Event: Disable iquo.

Event: 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)))
|#

Definition: itimes-fringe (x) = if listp (x)

then if car (x) = 'itimes then append (itimes-fringe (cadr (x)), itimes-fringe (caddr (x))) else list (x) endif

else list (x) endif

Definition: itimes-tree-rec (l) = if cdr (l) ≃ nil then car (l)

else list ('itimes, car (l), itimes-tree-rec (cdr (l))) endif

Definition: itimes-tree (l) = if listp (l)

then if listp (cdr (l)) then itimes-tree-rec (l) else list ('fix-int, car (l)) endif

else ''1 endif

Definition: itimes-list (x) = if listp (x) then itimes (car (x), itimes-list (cdr (x)))

else 1 endif

Theorem: integerp-itimes-list integerp (itimes-list (x))

Theorem: eval$-itimes-tree-rec listp (x) → (eval$ (t, itimes-tree-rec (x), a)

= if listp (cdr (x)) then itimes-list (eval$ ('list, x, a)) else eval$ (t, car (x), a) endif)

;; The following allows us to pretty much ignore itimes-tree forever.  (Notice
;; that it is disabled immediately below.)

Theorem: eval$-itimes-tree eval$ (t, itimes-tree (x), a) = itimes-list (eval$ ('list, x, a))

Event: Disable itimes-tree.

;; because we want to use EVAL$-ITIMES-TREE for now

Definition: make-cancel-itimes-equality (x, y, in-both) = list ('if,

list ('equal, itimes-tree (in-both), ''0), list ('quote, t),

       list ('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))
|#

Definition: cancel-itimes (x) = if listp (x)

then if car (x) = 'equal

then if listp (cadr (x))

then if caadr (x) = 'itimes

then if listp (caddr (x))

then if caaddr (x) = 'itimes

then if listp (bagint (itimes-fringe (cadr (x)),

itimes-fringe (caddr (x)))) then make-cancel-itimes-equality (itimes-fringe (cadr (x)),

itimes-fringe (caddr (x)),

bagint (itimes-fringe (cadr (x)),

itimes-fringe (caddr (x))))

else x endif elseif caddr (x) ∈ itimes-fringe (cadr (x)) then list ('if,

list ('integerp, caddr (x)),

make-cancel-itimes-equality (itimes-fringe (cadr (x)), list (caddr (x)), list (caddr (x))),

list ('quote, f))

else x endif elseif caddr (x) ∈ itimes-fringe (cadr (x)) then list ('if,

list ('integerp, caddr (x)),

make-cancel-itimes-equality (itimes-fringe (cadr (x)), list (caddr (x)), list (caddr (x))),

list ('quote, f))

else x endif elseif listp (caddr (x)) then if caaddr (x) = 'itimes

then if cadr (x) ∈ itimes-fringe (caddr (x))

then list ('if, list ('integerp, cadr (x)), make-cancel-itimes-equality (list (cadr (x)),

itimes-fringe (caddr (x)), list (cadr (x))),

list ('quote, f))

else x endif else x endif

else x endif elseif listp (caddr (x)) then if caaddr (x) = 'itimes

then if cadr (x) ∈ itimes-fringe (caddr (x))

then list ('if, list ('integerp, cadr (x)), make-cancel-itimes-equality (list (cadr (x)),

itimes-fringe (caddr (x)), list (cadr (x))),

list ('quote, f))

else x endif else x endif

else x endif else x endif

else x endif

Theorem: itimes-list-append itimes-list (append (x, y)) = itimes (itimes-list (x), itimes-list (y))

Theorem: itimes-list-eval$-fringe itimes-list (eval$ ('list, itimes-fringe (x), a)) = fix-int (eval$ (t, x, a))

Theorem: integerp-eval$-itimes (car (x) = 'itimes) → integerp (eval$ (t, x, a))

Theorem: not-integerp-implies-not-equal-itimes (¬ integerp (a)) → ((a = itimes (b, c)) = f)

Theorem: itimes-list-eval$-delete (z ∈ y) → (itimes-list (eval$ ('list, y, a))

= itimes (eval$ (t, z, a), itimes-list (eval$ ('list, delete (z, y), a))))

Theorem: itimes-list-bagdiff subbagp (x, y) → (itimes-list (eval$ ('list, y, a))

= itimes (itimes-list (eval$ ('list, bagdiff (y, x), a)), itimes-list (eval$ ('list, x, a))))

Theorem: equal-itimes-list-eval$-list-delete ((c ∈ y) ∧ (fix-int (eval$ (t, c, a)) ≠ 0)) → ((x = itimes-list (eval$ ('list, delete (c, y), a)))

= (integerp (x)

∧ (itimes (x, eval$ (t, c, a)) = itimes-list (eval$ ('list, y, a)))))

Event: 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).

Theorem: member-append (a ∈ append (x, y)) = ((a ∈ x) ∨ (a ∈ y))

Theorem: member-izerop-itimes-fringe ((z ∈ itimes-fringe (x)) ∧ (fix-int (eval$ (t, z, a)) = 0)) → (fix-int (eval$ (t, x, a)) = 0)

Theorem: correctness-of-cancel-itimes-hack-1 ((w ∈ itimes-fringe (cons ('itimes, x1 ))) ∧ (fix-int (eval$ (t, w, a)) = 0) ∧ (fix-int (eval$ (t, car (x1 ), a)) ≠ 0)) → (fix-int (eval$ (t, cadr (x1 ), a)) = 0)

Event: Enable eval$-equal.

Theorem: eval$-make-cancel-itimes-equality eval$ (t, make-cancel-itimes-equality (x, y, in-both), a) = if eval$ (t, list ('equal, itimes-tree (in-both), ''0), a) then t

else itimes-list (eval$ ('list, bagdiff (x, in-both), a)) = itimes-list (eval$ ('list, bagdiff (y, in-both), a)) endif

Event: 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.

Theorem: eval$-make-cancel-itimes-equality-1 eval$ (t, make-cancel-itimes-equality (list (x), y, list (x)), a) = if fix-int (eval$ (t, x, a)) = 0 then t

else 1 = itimes-list (eval$ ('list, delete (x, y), a)) endif

Theorem: equal-fix-int (fix-int (x) = x) = integerp (x)

;; Here's another special case that I hope helps with the clausifier problem.

Theorem: eval$-make-cancel-itimes-equality-2 eval$ (t, make-cancel-itimes-equality (x, list (y), list (y)), a) = if fix-int (eval$ (t, y, a)) = 0 then t

else 1 = itimes-list (eval$ ('list, delete (y, x), a)) endif

Theorem: eval$-equal-itimes-tree-itimes-fringe-0 (eval$ (t, list ('equal, itimes-tree (itimes-fringe (x)), ''0), a) ∧ (car (x) = 'itimes)) → (eval$ (t, x, a) = 0)

Theorem: izerop-eval-of-member-implies-itimes-list-0 ((z ∈ y) ∧ (fix-int (eval$ (t, z, a)) = 0)) → (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))))
|#

Definition: subsetp (x, y) = if x ≃ nil then t

elseif car (x) ∈ y then subsetp (cdr (x), y)

else f endif

Theorem: subsetp-implies-itimes-list-eval$-equals-0 (subsetp (x, y) ∧ (itimes-list (eval$ ('list, x, a)) = 0)) → (itimes-list (eval$ ('list, y, a)) = 0)

Theorem: subbagp-subsetp subbagp (x, y) → subsetp (x, y)

Theorem: equal-0-itimes-list-eval$-bagint-1 (itimes-list (eval$ ('list, bagint (x, y), a)) = 0) → (itimes-list (eval$ ('list, x, a)) = 0)

Theorem: equal-0-itimes-list-eval$-bagint-2 (itimes-list (eval$ ('list, bagint (x, y), a)) = 0) → (itimes-list (eval$ ('list, y, a)) = 0)

Theorem: correctness-of-cancel-itimes-hack-2 (listp (u) ∧ (car (u) = 'itimes) ∧ listp (v) ∧ (car (v) = 'itimes) ∧ (eval$ (t, u, a) ≠ eval$ (t, v, a))) → (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)))

Theorem: correctness-of-cancel-itimes-hack-3-lemma ((u = itimes (a, b)) ∧ (fix-int (a) ≠ 0)) → ((u = itimes (a, c)) = (fix-int (b) = fix-int (c)))

Theorem: correctness-of-cancel-itimes-hack-3 (listp (u) ∧ (car (u) = 'itimes) ∧ listp (v) ∧ (car (v) = 'itimes) ∧ (eval$ (t, u, a) = eval$ (t, v, a)) ∧ (¬ eval$ (t,

            list ('equal,

itimes-tree (bagint (itimes-fringe (u), itimes-fringe (v))),

                ''0),

a)))

→ ((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)

Event: Disable correctness-of-cancel-itimes-hack-3-lemma.

Theorem: correctness-of-cancel-itimes eval$ (t, x, a) = eval$ (t, cancel-itimes (x), a)

; ---------- 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.

Definition: itimes-tree-no-fix-int (l) = if listp (l) then itimes-tree-rec (l)

else ''1 endif

;; The following allows us to pretty much ignore
;; itimes-tree-no-fix-int forever.  (Notice that it is disabled
;; immediately below.)

Theorem: eval$-itimes-tree-no-fix-int-1 ilessp (eval$ (t, itimes-tree-no-fix-int (x), a), y) = ilessp (eval$ (t, itimes-tree (x), a), y)

Theorem: eval$-itimes-tree-no-fix-int-2 ilessp (y, eval$ (t, itimes-tree-no-fix-int (x), a)) = ilessp (y, eval$ (t, itimes-tree (x), a))

Event: 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.

Definition: make-cancel-itimes-inequality (x, y, in-both) = list ('if,

list ('ilessp, itimes-tree-no-fix-int (in-both), ''0),

       list ('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 ('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))
|#

Definition: cancel-itimes-ilessp (x) = if listp (x)

then if car (x) = 'ilessp

then if listp (bagint (itimes-fringe (cadr (x)),

itimes-fringe (caddr (x)))) then make-cancel-itimes-inequality (itimes-fringe (cadr (x)),

itimes-fringe (caddr (x)),

bagint (itimes-fringe (cadr (x)),

itimes-fringe (caddr (x))))

else x endif else x endif

else x endif

Theorem: eval$-make-cancel-itimes-inequality 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)

then 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))

elseif eval$ (t, list ('ilessp, ''0, itimes-tree-no-fix-int (in-both)), a) then 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))

else f endif

Event: Disable make-cancel-itimes-inequality.

Theorem: listp-bagint-with-singleton-implies-member listp (bagint (y, list (z))) → (z ∈ y)

Theorem: itimes-list-eval$-list-0 (0 ∈ x) → (itimes-list (eval$ ('list, x, a)) = 0)

Theorem: ilessp-itimes-right-positive ilessp (0, x) → (ilessp (y, z) = ilessp (itimes (y, x), itimes (z, x)))

Theorem: correctness-of-cancel-itimes-ilessp-hack-1 (subbagp (bag, x) ∧ subbagp (bag, y) ∧ ilessp (0, itimes-list (eval$ ('list, bag, a)))) → (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))))

Theorem: listp-bagint-with-singleton-member listp (bagint (y, list (z))) = (z ∈ y)

Theorem: correctness-of-cancel-itimes-ilessp-hack-2-lemma (0 ∈ itimes-fringe (w)) → (eval$ (t, w, a) = 0)

Theorem: correctness-of-cancel-itimes-ilessp-hack-2 (0 ∈ itimes-fringe (w)) → (¬ ilessp (eval$ (t, w, a), 0))

Event: 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.

Theorem: ilessp-trichotomy (¬ ilessp (x, y)) → (ilessp (y, x) = (fix-int (x) ≠ fix-int (y)))

Theorem: correctness-of-cancel-itimes-ilessp-hack-3-lemma-1 ((0 = itimes-list (eval$ ('list, bag, a))) ∧ subsetp (bag, z)) → (itimes-list (eval$ ('list, z, a)) = 0)

Theorem: correctness-of-cancel-itimes-ilessp-hack-3-lemma-2 ((0 = itimes-list (eval$ ('list, bag, a))) ∧ subsetp (bag, itimes-fringe (x))) → (fix-int (eval$ (t, x, a)) = 0)

Theorem: same-fix-int-implies-not-ilessp (fix-int (x) = fix-int (y)) → (¬ ilessp (x, y))

Theorem: correctness-of-cancel-itimes-ilessp-hack-3 ((¬ ilessp (itimes-list (eval$ ('list, bag, a)), 0)) ∧ (¬ ilessp (0, itimes-list (eval$ ('list, bag, a)))) ∧ subbagp (bag, itimes-fringe (w)) ∧ subbagp (bag, itimes-fringe (v))) → (¬ ilessp (eval$ (t, w, a), eval$ (t, v, a)))

Theorem: ilessp-itimes-right-negative ilessp (x, 0) → (ilessp (y, z) = ilessp (itimes (z, x), itimes (y, x)))

Theorem: correctness-of-cancel-itimes-ilessp-hack-4 (subbagp (bag, x) ∧ subbagp (bag, y) ∧ ilessp (itimes-list (eval$ ('list, bag, a)), 0)) → (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))))

Event: Disable ilessp-trichotomy.

Event: Disable same-fix-int-implies-not-ilessp.

Theorem: correctness-of-cancel-itimes-ilessp eval$ (t, x, a) = eval$ (t, cancel-itimes-ilessp (x), a)

;; I think that the following lemma is safe because it won't be
;; called at all during relieve-hyps.

Theorem: ilessp-strict ilessp (x, y) → (¬ ilessp (y, x))

; ---------- 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.

Event: Disable eval$-cancel-iplus. Event: Disable eval$-iplus. Event: Disable lessp-count-listp-cdr. Event: Disable eval$-iplus-tree-rec. Event: Disable eval$-iplus-tree.

;;(disable eval$-list-append) ;; Nice rule -- I'll keep it enabled

Event: Disable iplus-list-eval$-fringe. Event: Disable eval$-iplus-list-bagdiff. Event: Disable lessp-difference-plus-arg1. Event: Disable lessp-difference-plus-arg1-commuted. Event: Disable correctness-of-cancel-iplus-ilessp-lemma. Event: Disable eval$-ilessp-iplus-tree-no-fix-int. Event: Disable make-cancel-iplus-inequality-simplifier. Event: Disable quotient-difference-lessp-arg2. Event: Disable eval$-itimes-tree-rec. Event: Disable eval$-itimes-tree.

Event: Disable itimes-list-eval$-fringe. Event: Disable integerp-eval$-itimes. Event: Disable itimes-list-bagdiff. Event: Disable equal-itimes-list-eval$-list-delete. Event: Disable member-izerop-itimes-fringe. Event: Disable correctness-of-cancel-itimes-hack-1. Event: Disable eval$-make-cancel-itimes-equality. Event: Disable eval$-make-cancel-itimes-equality-1. Event: Disable eval$-make-cancel-itimes-equality-2. Event: Disable eval$-equal-itimes-tree-itimes-fringe-0. Event: Disable izerop-eval-of-member-implies-itimes-list-0. Event: Disable subsetp-implies-itimes-list-eval$-equals-0. Event: Disable equal-0-itimes-list-eval$-bagint-1. Event: Disable equal-0-itimes-list-eval$-bagint-2. Event: Disable correctness-of-cancel-itimes-hack-2. Event: Disable correctness-of-cancel-itimes-hack-3-lemma. Event: Disable correctness-of-cancel-itimes-hack-3. Event: Disable eval$-itimes-tree-no-fix-int-1.

Event: Disable eval$-itimes-tree-no-fix-int-2. Event: Disable eval$-make-cancel-itimes-inequality. Event: Disable listp-bagint-with-singleton-implies-member. Event: Disable itimes-list-eval$-list-0. Event: Disable correctness-of-cancel-itimes-ilessp-hack-1. Event: Disable listp-bagint-with-singleton-member. Event: Disable correctness-of-cancel-itimes-ilessp-hack-2. Event: Disable correctness-of-cancel-itimes-ilessp-hack-3-lemma-1. Event: Disable correctness-of-cancel-itimes-ilessp-hack-3-lemma-2. Event: Disable correctness-of-cancel-itimes-ilessp-hack-3. Event: 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)))
|#

Definition: itimes-tree-ineg (l) = if listp (l)

then if car (l) = list ('quote, -1)

then if listp (cdr (l)) then list ('ineg, itimes-tree-rec (cdr (l)))

else car (l) endif else itimes-tree-rec (l) endif

else ''1 endif

Definition: itimes-factors (x) = if listp (x)

then if car (x) = 'itimes then append (itimes-factors (cadr (x)), itimes-factors (caddr (x))) elseif car (x) = 'iplus then let bag1 be itimes-factors (cadr (x)),

bag2 be itimes-factors (caddr (x)) in let inboth be bagint (bag1 , bag2 ) in if listp (inboth) then cons (list ('iplus,

itimes-tree-ineg (bagdiff (bag1 ,

inboth)),

itimes-tree-ineg (bagdiff (bag2 ,

inboth))),

inboth) else list (x) endif endlet endlet

elseif car (x) = 'ineg

then cons (list ('quote, -1), itimes-factors (cadr (x)))

else list (x) endif else list (x) endif Theorem: itimes–1 itimes (-1, x) = ineg (x)

;; 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.

Theorem: equal-ineg-ineg (ineg (x) = ineg (y)) = (fix-int (x) = fix-int (y))

Theorem: ilessp-ineg-ineg ilessp (ineg (x), ineg (y)) = ilessp (y, x)

Theorem: fix-int-eval$-itimes-tree-rec listp (x) → (fix-int (eval$ (t, itimes-tree-rec (x), a))

= itimes-list (eval$ ('list, x, a)))

Theorem: eval$-itimes-tree-ineg fix-int (eval$ (t, itimes-tree-ineg (x), a)) = itimes-list (eval$ ('list, x, a))

;; Now I want the above lemma to apply, but it doesn't, so the
;; following three lemmas are used instead.

Theorem: ineg-eval$-itimes-tree-ineg ineg (eval$ (t, itimes-tree-ineg (x), a)) = ineg (itimes-list (eval$ ('list, x, a)))

Theorem: iplus-eval$-itimes-tree-ineg (iplus (eval$ (t, itimes-tree-ineg (x), a), y) = iplus (itimes-list (eval$ ('list, x, a)), y)) ∧ (iplus (y, eval$ (t, itimes-tree-ineg (x), a))

= iplus (y, itimes-list (eval$ ('list, x, a))))

Theorem: itimes-eval$-itimes-tree-ineg (itimes (eval$ (t, itimes-tree-ineg (x), a), y) = itimes (itimes-list (eval$ ('list, x, a)), y)) ∧ (itimes (y, eval$ (t, itimes-tree-ineg (x), a))

= itimes (y, itimes-list (eval$ ('list, x, a))))

Event: 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.

Definition: iplus-or-itimes-term (x) = if listp (x)

then case on car (x): case = iplus then t case = itimes then t case = ineg then if listp (cadr (x)) then car (cadr (x)) = 'itimes

else f endif otherwise f endcase

else f endif

Definition: cancel-itimes-factors (x) = if listp (x) ∧ (car (x) = 'equal)

then let bagint be bagint (itimes-factors (cadr (x)),

itimes-factors (caddr (x)))

in let new-equality be make-cancel-itimes-equality (itimes-factors (cadr (x)),

itimes-factors (caddr (x)), bagint)

in if iplus-or-itimes-term (cadr (x)) then if listp (bagint)

then if iplus-or-itimes-term (caddr (x)) then new-equality else list ('if,

                  list ('integerp,

caddr (x)), new-equality, list ('quote, f)) endif

else x endif elseif iplus-or-itimes-term (caddr (x)) then if listp (bagint)

then list ('if, list ('integerp, cadr (x)), new-equality, list ('quote, f))

else x endif else x endif endlet endlet

else x endif

;; The following was generated with the nqthm-macroexpand macro defined above.

;; 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))
 (OTHERWISE X)))
  (T X))
 X)
     X))

Theorem: cancel-itimes-factors-expanded-cancel-itimes-factors cancel-itimes-factors-expanded (x) = cancel-itimes-factors (x)

Event: Disable cancel-itimes-factors-expanded.

Event: Disable iplus-or-itimes-term.

Theorem: equal-itimes-list-eval$-list-delete-new-1 (fix-int (eval$ (t, elt, a)) ≠ 0) → ((x = itimes-list (eval$ ('list, delete (elt, bag), a)))

= if elt ∈ bag

then integerp (x)

∧ (itimes (x, eval$ (t, elt, a))

= itimes-list (eval$ ('list, bag, a)))

else x = itimes-list (eval$ ('list, bag, a)) endif)

Theorem: equal-itimes-list-eval$-list-delete-new-2 (fix-int (eval$ (t, elt, a)) ≠ 0) → ((itimes-list (eval$ ('list, delete (elt, bag), a)) = x)

= if elt ∈ bag

then integerp (x)

∧ (itimes (x, eval$ (t, elt, a))

= itimes-list (eval$ ('list, bag, a)))

else x = itimes-list (eval$ ('list, bag, a)) endif)

Theorem: itimes-itimes-list-eval$-list-delete (x ∈ bag) → (itimes (eval$ (t, x, a), itimes-list (eval$ ('list, delete (x, bag), a)))

= itimes-list (eval$ ('list, bag, a)))

Theorem: equal-itimes-list-eval$-list-bagdiff (subbagp (in-both, bag1 ) ∧ subbagp (in-both, bag2 ) ∧ (itimes-list (eval$ ('list, in-both, a)) ≠ 0)) → ((itimes-list (eval$ ('list, bagdiff (bag1 , in-both), a))

= itimes-list (eval$ ('list, bagdiff (bag2 , in-both), a)))

= (itimes-list (eval$ ('list, bag1 , a)) = itimes-list (eval$ ('list, bag2 , a))))

Theorem: membership-of-0-implies-itimes-list-is-0 (0 ∈ x) → (itimes-list (x) = 0)

Theorem: member-0-eval$-list (0 ∈ x) → (0 ∈ eval$ ('list, x, a))

Theorem: itimes-list-eval$-factors-lemma 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))

Theorem: itimes-list-eval$-factors-lemma-prime 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))

Theorem: itimes-list-eval$-factors itimes-list (eval$ ('list, itimes-factors (x), a)) = fix-int (eval$ (t, x, a))

Theorem: iplus-or-itimes-term-integerp-eval$ iplus-or-itimes-term (x) → integerp (eval$ (t, x, a))

Theorem: eval$-list-bagint-0 (itimes-list (eval$ ('list, bagint (x, y), a)) = 0) → ((itimes-list (eval$ ('list, x, a)) = 0)

∧ (itimes-list (eval$ ('list, y, a)) = 0))

Theorem: eval$-list-bagint-0-implies-equal ((itimes-list (eval$ ('list, bagint (itimes-factors (v), itimes-factors (w)), a)) = 0) ∧ integerp (eval$ (t, v, a)) ∧ integerp (eval$ (t, w, a))) → ((eval$ (t, v, a) = eval$ (t, w, a)) = t)

Theorem: correctness-of-cancel-itimes-factors eval$ (t, x, a) = eval$ (t, cancel-itimes-factors-expanded (x), a)

;; OK -- now, the lessp case, finally.  Ugh!

Definition: cancel-itimes-ilessp-factors (x) = if listp (x) then if car (x) = 'ilessp

then if listp (bagint (itimes-factors (cadr (x)),

itimes-factors (caddr (x)))) then make-cancel-itimes-inequality (itimes-factors (cadr (x)),

itimes-factors (caddr (x)),

bagint (itimes-factors (cadr (x)),

itimes-factors (caddr (x))))

else x endif else x endif

else x endif

Theorem: bagint-singleton bagint (x, list (y)) = if y ∈ x then list (y)

else nil endif

Theorem: izerop-ilessp-0-relationship (fix-int (x) = 0) = ((¬ ilessp (x, 0)) ∧ (¬ ilessp (0, x)))

Theorem: ilessp-itimes-list-eval$-list-delete-helper-1 ilessp (0, w) → (ilessp (itimes (x, w), itimes (w, u)) = ilessp (x, u))

Theorem: ilessp-itimes-list-eval$-list-delete-helper-2 ilessp (w, 0) → (ilessp (itimes (w, u), itimes (x, w)) = ilessp (x, u))

Theorem: ilessp-itimes-list-eval$-list-delete ((z ∈ y) ∧ (fix-int (eval$ (t, z, a)) ≠ 0)) → (ilessp (x, itimes-list (eval$ ('list, delete (z, y), a)))

= if ilessp (0, eval$ (t, z, a))

then ilessp (itimes (x, eval$ (t, z, a)),

itimes-list (eval$ ('list, y, a)))

elseif ilessp (eval$ (t, z, a), 0)

then ilessp (itimes-list (eval$ ('list, y, a)),

itimes (x, eval$ (t, z, a)))

else f endif)

Theorem: ilessp-itimes-list-eval$-list-delete-prime-helper-1 ilessp (0, w) → (ilessp (itimes (w, u), itimes (x, w)) = ilessp (u, x))

Theorem: ilessp-itimes-list-eval$-list-delete-prime-helper-2 ilessp (w, 0) → (ilessp (itimes (x, w), itimes (w, u)) = ilessp (u, x))

Theorem: ilessp-itimes-list-eval$-list-delete-prime ((z ∈ y) ∧ (fix-int (eval$ (t, z, a)) ≠ 0)) → (ilessp (itimes-list (eval$ ('list, delete (z, y), a)), x)

= if ilessp (0, eval$ (t, z, a))

then ilessp (itimes-list (eval$ ('list, y, a)),

itimes (x, eval$ (t, z, a)))

elseif ilessp (eval$ (t, z, a), 0)

then ilessp (itimes (x, eval$ (t, z, a)),

itimes-list (eval$ ('list, y, a)))

else f endif)

;; **** 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.

Theorem: ilessp-0-itimes ilessp (0, itimes (x, y)) = ((ilessp (0, x) ∧ ilessp (0, y)) ∨ (ilessp (x, 0) ∧ ilessp (y, 0)))

Theorem: ilessp-itimes-0 ilessp (itimes (x, y), 0) = ((ilessp (0, x) ∧ ilessp (y, 0)) ∨ (ilessp (x, 0) ∧ ilessp (0, y)))

Theorem: ilessp-itimes-list-eval$-list-bagdiff (subbagp (in-both, bag1 ) ∧ subbagp (in-both, bag2 ) ∧ (itimes-list (eval$ ('list, in-both, a)) ≠ 0)) → (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))) then ilessp (itimes-list (eval$ ('list, bag1 , a)),

itimes-list (eval$ ('list, bag2 , a)))

else ilessp (itimes-list (eval$ ('list, bag2 , a)), itimes-list (eval$ ('list, bag1 , a))) endif)

Theorem: zero-ilessp-implies-not-equal ilessp (0, x) → (0 ≠ x)

Theorem: ilessp-itimes-list-eval$-list-bagdiff-corollary-1 (subbagp (in-both, bag1 ) ∧ subbagp (in-both, bag2 ) ∧ ilessp (0, itimes-list (eval$ ('list, in-both, a)))) → (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))))

Theorem: ilessp-zero-implies-not-equal ilessp (x, 0) → (0 ≠ x)

Theorem: ilessp-itimes-list-eval$-list-bagdiff-corollary-2 (subbagp (in-both, bag1 ) ∧ subbagp (in-both, bag2 ) ∧ ilessp (itimes-list (eval$ ('list, in-both, a)), 0)) → (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))))

Theorem: member-0-itimes-factors-yields-0 (eval$ (t, w, a) ≠ 0) → (0 ∉ itimes-factors (w))

Theorem: member-0-itimes-factors-yields-0-ilessp-consequence-1 ilessp (eval$ (t, w, a), 0) → (0 ∉ itimes-factors (w))

Theorem: member-0-itimes-factors-yields-0-ilessp-consequence-2 ilessp (0, eval$ (t, w, a)) → (0 ∉ itimes-factors (w))

#|
(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!).

Event: Enable ilessp-trichotomy.

Event: Disable izerop-ilessp-0-relationship.

Theorem: eval$-list-bagint-0-for-ilessp ((¬ ilessp (itimes-list (eval$ ('list, bagint (x, y), a)), 0)) ∧ (¬ ilessp (0, itimes-list (eval$ ('list, bagint (x, y), a))))) → ((fix-int (itimes-list (eval$ ('list, x, a))) = 0)

∧ (fix-int (itimes-list (eval$ ('list, y, a))) = 0))

Theorem: eval$-list-bagint-0-implies-equal-for-ilessp-lemma ((¬ ilessp (itimes-list (eval$ ('list,

bagint (itimes-factors (v), itimes-factors (w)), a)),

0))

∧ (¬ ilessp (0,

itimes-list (eval$ ('list,

bagint (itimes-factors (v),

itimes-factors (w)), a)))))

→ (fix-int (eval$ (t, v, a)) = fix-int (eval$ (t, w, a)))

Theorem: equal-fix-int-to-ilessp (fix-int (x) = fix-int (y)) → (¬ ilessp (x, y))

Theorem: eval$-list-bagint-0-implies-equal-for-ilessp ((¬ ilessp (itimes-list (eval$ ('list,

bagint (itimes-factors (v), itimes-factors (w)), a)),

0))

∧ (¬ ilessp (0,

itimes-list (eval$ ('list,

bagint (itimes-factors (v),

itimes-factors (w)), a)))))

→ ((¬ ilessp (eval$ (t, v, a), eval$ (t, w, a)))

∧ (¬ ilessp (eval$ (t, w, a), 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.

Event: Disable ilessp-trichotomy.

Theorem: correctness-of-cancel-itimes-ilessp-factors eval$ (t, x, a) = eval$ (t, cancel-itimes-ilessp-factors (x), a)

;; OK -- now, the zero cases.

Event: Enable lessp-count-listp-cdr.

Definition: disjoin-equalities-with-0 (factors) = if listp (cdr (factors))

then list ('or, list ('equal, list ('fix-int, car (factors)), ''0), disjoin-equalities-with-0 (cdr (factors))) else list ('equal, list ('fix-int, car (factors)), ''0) endif

Event: Disable lessp-count-listp-cdr.

Definition: cancel-factors-0 (x) = if listp (x)

then if car (x) = 'equal

then if cadr (x) = ''0

then let factors be itimes-factors (caddr (x)) in if listp (cdr (factors)) then disjoin-equalities-with-0 (factors) else x endif endlet

elseif caddr (x) = ''0

then let factors be itimes-factors (cadr (x)) in if listp (cdr (factors)) then disjoin-equalities-with-0 (factors) else x endif endlet

else x endif else x endif

else x endif

Definition: some-eval$s-to-0 (x, a) = if listp (x) then (fix-int (eval$ (t, car (x), a)) = 0) ∨ some-eval$s-to-0 (cdr (x), a)

else f endif

Theorem: eval$-disjoin-equalities-with-0 listp (lst) → (eval$ (t, disjoin-equalities-with-0 (lst), a)

= some-eval$s-to-0 (lst, a))

Theorem: some-eval$s-to-0-append some-eval$s-to-0 (append (x, y), a) = (some-eval$s-to-0 (x, a) ∨ some-eval$s-to-0 (y, a))

Theorem: some-eval$s-to-0-eliminator some-eval$s-to-0 (x, a) = (itimes-list (eval$ ('list, x, a)) = 0)

Theorem: listp-cdr-factors-implies-integerp listp (cdr (itimes-factors (v))) → integerp (eval$ (t, v, a))

Theorem: correctness-of-cancel-factors-0 eval$ (t, x, a) = eval$ (t, cancel-factors-0 (x), a)

;; and now for inequalities...

Event: Enable lessp-count-listp-cdr.

Definition: conjoin-inequalities-with-0 (factors, parity) = if listp (cdr (factors))

then if parity

then 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)))

else 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))) endif

elseif parity then list ('ilessp, ''0, car (factors))

else list ('ilessp, car (factors), ''0) endif Event: Disable lessp-count-listp-cdr.

Definition: cancel-factors-ilessp-0 (x) = if listp (x)

then if car (x) = 'ilessp

then if cadr (x) = ''0

then let factors be itimes-factors (caddr (x)) in if listp (cdr (factors)) then conjoin-inequalities-with-0 (factors, t) else x endif endlet

elseif caddr (x) = ''0

then let factors be itimes-factors (cadr (x)) in if listp (cdr (factors)) then conjoin-inequalities-with-0 (factors, f) else x endif endlet

else x endif else x endif

else x endif

Theorem: conjoin-inequalities-with-0-eliminator listp (x) → (eval$ (t, conjoin-inequalities-with-0 (x, parity), a)

= if parity then ilessp (0, itimes-list (eval$ ('list, x, a))) else ilessp (itimes-list (eval$ ('list, x, a)), 0) endif)

Theorem: correctness-of-cancel-factors-ilessp-0 eval$ (t, x, a) = eval$ (t, cancel-factors-ilessp-0 (x), a)

Event: Disable equal-itimes-list-eval$-list-delete-new-1.

Event: Disable equal-itimes-list-eval$-list-delete-new-2.

Event: Disable itimes-itimes-list-eval$-list-delete.

Event: Disable equal-itimes-list-eval$-list-bagdiff.

Event: Disable itimes-list-eval$-factors-lemma.

Event: Disable itimes-list-eval$-factors-lemma-prime.

Event: Disable itimes-list-eval$-factors. Event: Disable iplus-or-itimes-term-integerp-eval$. Event: Disable eval$-list-bagint-0. Event: Disable eval$-list-bagint-0-implies-equal. Event: Disable izerop-ilessp-0-relationship. Event: Disable ilessp-itimes-list-eval$-list-delete-helper-1. Event: Disable ilessp-itimes-list-eval$-list-delete-helper-2. Event: Disable ilessp-itimes-list-eval$-list-delete. Event: Disable ilessp-itimes-list-eval$-list-delete-prime-helper-1. Event: Disable ilessp-itimes-list-eval$-list-delete-prime-helper-2. Event: Disable ilessp-itimes-list-eval$-list-delete-prime. Event: Disable ilessp-0-itimes. Event: Disable ilessp-itimes-0. Event: 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:

Event: Disable correctness-of-cancel-itimes.

Event: 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.

Event: Disable not-integerp-implies-not-equal-iplus.

Event: Disable not-integerp-implies-not-equal-itimes.

Event: Disable subbagp-subsetp.

Event: Disable eval$-list-bagint-0-implies-equal-for-ilessp.

; ---------- Cancel ineg terms from equalities and inequalities ----------

Definition: split-out-ineg-terms (x) = if listp (x)

then let pair be split-out-ineg-terms (cdr (x)),

a be car (x) in if listp (a) then if car (a) = 'ineg

then cons (car (pair), cons (cadr (a), cdr (pair))) elseif (car (a) = 'quote)

∧ negativep (cadr (a))

∧ (negative-guts (cadr (a)) ≠ 0) then cons (car (pair),

cons (list ('quote, negative-guts (cadr (a))),

cdr (pair))) else cons (cons (a, car (pair)), cdr (pair)) endif else cons (cons (a, car (pair)), cdr (pair)) endif endlet

else cons (nil, nil) endif

Definition: remove-inegs (x, y) = let xpair be split-out-ineg-terms (x),

ypair be split-out-ineg-terms (y) in if listp (cdr (xpair)) ∨ listp (cdr (ypair)) then cons (append (cdr (ypair), car (xpair)),

append (cdr (xpair), car (ypair)))

else f endif endlet

Definition: iplus-or-ineg-term (x) = (listp (x) ∧ ((car (x) = 'ineg) ∨ (car (x) = 'iplus)))

Definition: make-cancel-ineg-terms-equality (x) = let new-fringes be remove-inegs (iplus-fringe (cadr (x)),

iplus-fringe (caddr (x)))

in

if new-fringes

then if iplus-or-ineg-term (cadr (x))

then if iplus-or-ineg-term (caddr (x))

then list ('equal, iplus-tree (car (new-fringes)), iplus-tree (cdr (new-fringes)))

else list ('if, list ('integerp, caddr (x)),

                     list ('equal,

iplus-tree (car (new-fringes)), iplus-tree (cdr (new-fringes))),

list ('quote, f)) endif

elseif iplus-or-ineg-term (caddr (x)) then list ('if,

list ('integerp, cadr (x)),

                 list ('equal,

iplus-tree (car (new-fringes)), iplus-tree (cdr (new-fringes))),

list ('quote, f))

else x endif else x endif endlet

Definition: cancel-ineg-terms-from-equality (x) = if listp (x) ∧ (car (x) = 'equal)

then make-cancel-ineg-terms-equality (x)

else x endif

;; The following was created from nqthm-macroexpand with arguments
;; and or make-cancel-ineg-terms-equality iplus-or-ineg-term

Definition: cancel-ineg-terms-from-equality-expanded (x) = if listp (x)

then if car (x) = 'equal

then if remove-inegs (iplus-fringe (cadr (x)),

iplus-fringe (caddr (x)))

then if listp (cadr (x))

then case on car (car (cdr (x))): case = ineg then if listp (caddr (x))

then case on car (car (cdr (cdr (x)))): case = ineg then 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))))))

case = iplus then 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)) endcase

else 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)) endif

case = iplus then if listp (caddr (x))

then case on car (car (cdr (cdr (x)))): case = ineg then 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))))))

case = iplus then 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)) endcase

else 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)) endif

otherwise if listp (caddr (x))

then case on car (car (cdr (cdr (x)))): case = ineg then 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))

case = iplus then 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 endcase else x endif endcase

elseif listp (caddr (x)) then case on car (car (cdr (cdr (x)))):

case = ineg then 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))

case = iplus then 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 endcase else x endif

else x endif else x endif

else x endif

Theorem: cancel-ineg-terms-from-equality-cancel-ineg-terms-from-equality-expanded cancel-ineg-terms-from-equality-expanded (x) = cancel-ineg-terms-from-equality (x)

Event: Disable cancel-ineg-terms-from-equality-expanded.

Theorem: integerp-eval$-iplus-or-ineg-term iplus-or-ineg-term (x) → integerp (eval$ (t, x, a))

Event: Disable iplus-or-ineg-term.

Theorem: eval$-iplus-list-car-remove-inegs remove-inegs (x, y) → (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))))

Theorem: eval$-iplus-list-cdr-remove-inegs remove-inegs (x, y) → (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))))

Theorem: minus-ineg ((x ∈ N) ∧ (x ≠ 0)) → ((− x) = ineg (x))

Theorem: iplus-list-eval$-car-split-out-ineg-terms 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)))

Event: Disable remove-inegs.

Theorem: correctness-of-cancel-ineg-terms-from-equality eval$ (t, x, a) = eval$ (t, cancel-ineg-terms-from-equality-expanded (x), a)

Definition: make-cancel-ineg-terms-inequality (x) = let new-fringes be remove-inegs (iplus-fringe (cadr (x)),

iplus-fringe (caddr (x)))

in

if new-fringes

then list ('ilessp, iplus-tree (car (new-fringes)), iplus-tree (cdr (new-fringes)))

else x endif endlet

Definition: cancel-ineg-terms-from-inequality (x) = if listp (x) ∧ (car (x) = 'ilessp)

then if iplus-or-ineg-term (cadr (x)) then make-cancel-ineg-terms-inequality (x) elseif iplus-or-ineg-term (caddr (x)) then make-cancel-ineg-terms-inequality (x) else x endif

else x endif

;; The following was created from nqthm-macroexpand with arguments
;; and or make-cancel-ineg-terms-inequality iplus-or-ineg-term

Definition: cancel-ineg-terms-from-inequality-expanded (x) = if listp (x)

then if car (x) = 'ilessp

then if listp (cadr (x))

then case on car (car (cdr (x))): case = ineg then if remove-inegs (iplus-fringe (cadr (x)),

iplus-fringe (caddr (x)))

then 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))))))

else x endif case = iplus then if remove-inegs (iplus-fringe (cadr (x)),

iplus-fringe (caddr (x)))

then 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))))))

else x endif otherwise if listp (caddr (x))

then case on car (car (cdr (cdr (x)))): case = ineg then if remove-inegs (iplus-fringe (cadr (x)),

iplus-fringe (caddr (x)))

then 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))))))

else x endif case = iplus then if remove-inegs (iplus-fringe (cadr (x)),

iplus-fringe (caddr (x)))

then 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))))))

else x endif otherwise x endcase

else x endif endcase

elseif listp (caddr (x))

then case on car (car (cdr (cdr (x)))): case = ineg then if remove-inegs (iplus-fringe (cadr (x)),

iplus-fringe (caddr (x)))

then 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))))))

else x endif case = iplus then if remove-inegs (iplus-fringe (cadr (x)),

iplus-fringe (caddr (x)))

then 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))))))

else x endif otherwise x endcase

else x endif else x endif

else x endif

Theorem: cancel-ineg-terms-from-inequality-cancel-ineg-terms-from-inequality-expanded cancel-ineg-terms-from-inequality-expanded (x) = cancel-ineg-terms-from-inequality (x)

Event: Disable cancel-ineg-terms-from-inequality-expanded.

Theorem: correctness-of-cancel-ineg-terms-from-inequality eval$ (t, x, a) = eval$ (t, cancel-ineg-terms-from-inequality-expanded (x), a)

Event: Disable minus-ineg.

Event: 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.

Theorem: plus-iplus ((i ∈ N) ∧ (j ∈ N)) → ((i + j ) = iplus (i, j ))

Theorem: iplus-constants iplus (1 + i, iplus (1 + j , x)) = iplus ((1 + i) + (1 + j ), x)

Theorem: numberp-is-integerp (w ∈ N) → integerp (w)

Theorem: difference-idifference ((x ∈ N) ∧ (y ∈ N) ∧ (x ≤ y)) → ((y − x) = idifference (y, x))

Theorem: cancel-constants-equal-lemma ((m ∈ N) ∧ (n ∈ N)) → ((iplus (m, x) = iplus (n, y))

= if m < n then fix-int (x) = iplus (n − m, y) else iplus (m − n, x) = fix-int (y) endif)

Theorem: cancel-constants-equal (iplus (1 + i, x) = iplus (1 + j , y)) = if i < j then fix-int (x) = iplus (j − i, y)

else iplus (i − j , x) = fix-int (y) endif

Theorem: ilessp-add1 (y ∈ N) → (ilessp (x, 1 + y) = (¬ ilessp (y, x)))

Theorem: ilessp-add1-iplus (y ∈ N) → (ilessp (x, iplus (1 + y, z)) = (¬ ilessp (iplus (y, z), x)))

Theorem: cancel-constants-ilessp-lemma-1 ((m ∈ N) ∧ (n ∈ N)) → (ilessp (iplus (m, x), iplus (n, y))

= if m < n then ilessp (x, iplus (n − m, y)) else ilessp (iplus (m − n, x), y) endif)

Theorem: cancel-constants-ilessp-lemma-2 ((m ∈ N) ∧ (n ∈ N)) → (ilessp (iplus (m, x), iplus (n, y))

= if m < n then ¬ ilessp (iplus ((n − m) − 1, y), x) else ilessp (iplus (m − n, x), y) endif)

Theorem: cancel-constants-ilessp ilessp (iplus (1 + i, x), iplus (1 + j , y)) = if i < j then ¬ ilessp (iplus ((j − i) − 1, y), x)

else ilessp (iplus (i − j , x), y) endif

Event: Disable plus-iplus.

Event: Disable numberp-is-integerp.

Event: 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.

Event: Let us define the theory integers to consist of the following events: ileq, idifference, integerp-fix-int, integerp-iplus, integerp-idifference, integerpineg, 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, iplusfix-int1, iplus-fix-int2, idifference-fix-int1, idifference-fix-int2, iplus-list, eval$- list-append, iplus-list-append, iplus-ineg3, iplus-ineg4, correctness-of-cancel-iplus, ilessp-fix-int-1, ilessp-fix-int-2, iplus-cancellation-1-for-ilessp, iplus-cancellation-2-for-ilessp, correctness-of-cancel-iplus-ilessp, itimes-0-left, itimes-0-right, itimesfix-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, quotientremainder-uniqueness, division-theorem, 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, iquotientfix-int2, iremainder-fix-int1, iremainder-fix-int2, idiv-fix-int1, idiv-fix-int2, imodfix-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, fixint-irem, itimes-list, itimes-list-append, member-append, equal-fix-int, subsetp, correctness-of-cancel-itimes, correctness-of-cancel-itimes-ilessp, ilessp-strict, eval$- list-cons, eval$-list-nlistp, eval$-litatom, eval$-quote, eval$-other, iplus-x-y-ineg-x, correctness-of-cancel-ineg, integerp-iplus-list, eval$-iplus-list-delete, eval$-iplus-list-bagdiff, itimes-tree-ineg, itimes-factors, itimes–1, equal-ineg-ineg, ilessp-ineg-ineg, fix-int-eval$-itimes-tree-rec, eval$-itimes-tree-ineg, ineg-eval$-itimes-tree-ineg, iplus-eval$-itimes-tree-ineg, itimes-eval$-itimes-tree-ineg, iplus-or-itimes-term, cancel-itimes-factors, cancel-itimes-factors-expanded, cancel-itimes-factors-expanded-cancel-itimes-factors, membership-of-0-implies-itimes-list-is-0, member-0-eval$-list, correctness-of-cancel-itimes-factors, cancel-itimes-ilessp-factors, bagintsingleton, ilessp-itimes-list-eval$-list-bagdiff, ilessp-itimes-list-eval$-list-bagdiff-corollary-1, member-0-itimes-factors-yields-0, member-0-itimes-factors-yields-0-ilessp-consequence-1, member-0-itimes-factors-yields-0-ilessp-consequence-2, ilesspitimes-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, correctness-of-cancel-factors-0, conjoin-inequalities-with-0, cancel-factors-ilessp-0, split-out-ineg-terms, correctness-of-cancel-ineg-terms-from-equality, correctness-of-cancel-ineg-terms-from-inequality, iplus-constants, cancel-constants-equal, ilessp-add1, ilessp-add1-iplus, cancel-constants-ilessp.

; ------------------------------------------------------------
; was lists.events
; ------------------------------------------------------------

; --------------------------------------------------------------------------------
; Basic Functions on Lists
; --------------------------------------------------------------------------------
; --------------------------------- DEFINITIONS ----------------------------------
; Besides these functions, the theory of lists assumes APPEND is defined.

Definition: firstn (n, l) = if ¬ listp (l) then nil

elseif n ≃ 0 then nil

else cons (car (l), firstn (n − 1, cdr (l))) endif Definition: init (value, length) = if length ≃ 0 then nil

else cons (value, init (value, length − 1)) endif

Definition: lastcdr (l) = if ¬ listp (l) then l

else lastcdr (cdr (l)) endif

Definition: length (l) = if ¬ listp (l) then 0

else 1 + length (cdr (l)) endif

Definition: plist (l) = if ¬ listp (l) then nil

else cons (car (l), plist (cdr (l))) endif

Definition: plistp (l) = if ¬ listp (l) then l = nil

else plistp (cdr (l)) endif

Definition: restn (n, l) = if ¬ listp (l) then l

elseif n ≃ 0 then l

else restn (n − 1, cdr (l)) endif

Definition: reverse (l) = if ¬ listp (l) then nil

else append (reverse (cdr (l)), list (car (l))) endif

; --------------------------------- THEOREMS ------------------------------------
; ---------- LISTP ----------

Theorem: listp-append listp (append (a, b)) = (listp (a) ∨ listp (b))

Theorem: listp-firstn listp (firstn (n, l)) = (listp (l) ∧ (n ≄ 0))

Theorem: listp-init listp (init (val, n)) = (n ≄ 0)

Theorem: listp-lastcdr listp (lastcdr (l)) = f

Theorem: listp-plist listp (plist (l)) = listp (l)

Theorem: listp-restn listp (restn (n, l)) = (n < length (l))

Theorem: listp-reverse listp (reverse (l)) = listp (l)

; ---------- plistp ----------

Theorem: plistp-nlistp (l ≃ nil) → (plistp (l) = (l = nil))

Theorem: plistp-cons plistp (cons (a, l)) = plistp (l)

Theorem: plistp-append plistp (append (a, b)) = plistp (b)

Theorem: plistp-firstn plistp (firstn (n, l))

Theorem: plistp-init plistp (init (val, n))

Theorem: plistp-lastcdr plistp (lastcdr (l)) = plistp (l)

Theorem: plistp-plist plistp (plist (l))

Theorem: plistp-restn plistp (restn (n, l)) = plistp (l)

Theorem: plistp-reverse plistp (reverse (a))

; ---------- LENGTH ----------

Theorem: equal-length-0 (length (l) = 0) = (¬ listp (l))

Theorem: length-nlistp (x ≃ nil) → (length (x) = 0)

Theorem: length-cons length (cons (a, x)) = (1 + length (x))

Theorem: length-append length (append (a, b)) = (length (a) + length (b))

Theorem: length-firstn length (firstn (n, l)) = if n ≤ length (l) then fix (n)

else length (l) endif

Theorem: length-init length (init (bit, n)) = fix (n)

Theorem: length-lastcdr length (lastcdr (l)) = 0

Theorem: length-plist length (plist (l)) = length (l)

Theorem: length-restn length (restn (n, l)) = (length (l) − n)

Theorem: length-reverse length (reverse (l)) = length (l)

; ---------- APPEND ----------

Theorem: append-left-id (¬ listp (a)) → (append (a, b) = b)

Theorem: append-nil append (a, nil) = plist (a)

Theorem: associativity-of-append append (append (a, b), c) = append (a, append (b, c))

Theorem: associativity-of-append-inverse append (a, append (b, c)) = append (append (a, b), c)

Event: Disable associativity-of-append-inverse.

Theorem: append-firstn-restn append (firstn (i, l), restn (i, l)) = l

Theorem: append-init-list append (init (v, n), list (v)) = init (v, 1 + n)

Theorem: append-init-init append (init (v, i), init (v, j )) = init (v, i + j )

Theorem: append-lastcdr-arg1 append (lastcdr (a), b) = b

Theorem: append-lastcdr-arg2 append (l, lastcdr (l)) = l

Theorem: append-plist append (plist (a), b) = append (a, b)

Theorem: append-plist-lastcdr append (plist (l), lastcdr (l)) = l

; ---------- FIRSTN ----------

Theorem: firstn-with-large-index (length (l) ≤ n) → (firstn (n, l) = plist (l))

Theorem: firstn-with-non-number-index (n ∉ N) → (firstn (n, l) = firstn (0, l))

Theorem: firstn-nlistp (¬ listp (l)) → (firstn (n, l) = nil)

Theorem: firstn-0 firstn (0, l) = nil

Theorem: firstn-cons firstn (n, cons (a, b)) = if n ≃ 0 then nil

else cons (a, firstn (n − 1, b)) endif

Theorem: firstn-append firstn (n, append (a, b)) = if n ≤ length (a) then firstn (n, a)

else append (a, firstn (n − length (a), b)) endif Theorem: firstn-firstn firstn (i, firstn (n, l)) = if i < n then firstn (i, l)

else firstn (n, l) endif

Theorem: firstn-init firstn (n, init (v, i)) = if n < i then init (v, n)

else init (v, i) endif

Theorem: firstn-lastcdr firstn (n, lastcdr (l)) = nil

Theorem: firstn-plist firstn (n, plist (l)) = firstn (n, l)

; FIRSTN-RESTN has no obvious reduction.

; ---------- INIT ----------

Theorem: car-init (n ≄ 0) → (car (init (v, n)) = v)

Theorem: init-with-non-number-index (n ∉ N) → (init (v, n) = init (v, 0))

Theorem: init-add1 init (x, 1 + n) = cons (x, init (x, n))

Theorem: init-0 init (v, 0) = nil

; ---------- LASTCDR ----------

Theorem: lastcdr-nlistp (¬ listp (l)) → (lastcdr (l) = l)

Theorem: lastcdr-cons lastcdr (cons (a, l)) = lastcdr (l)

Theorem: lastcdr-append lastcdr (append (a, b)) = lastcdr (b)

Theorem: lastcdr-firstn lastcdr (firstn (n, l)) = nil

Theorem: lastcdr-init lastcdr (init (v, i)) = nil

Theorem: lastcdr-lastcdr lastcdr (lastcdr (l)) = lastcdr (l)

Theorem: lastcdr-plist lastcdr (plist (l)) = nil

Theorem: lastcdr-restn lastcdr (restn (n, l)) = lastcdr (l)

Theorem: lastcdr-reverse lastcdr (reverse (l)) = nil

; ---------- PLIST ----------

Theorem: equal-plist plistp (l) → (plist (l) = l)

Theorem: plist-nlistp (¬ listp (x)) → (plist (x) = nil)

Theorem: plist-cons plist (cons (a, l)) = cons (a, plist (l))

Theorem: plist-append plist (append (a, b)) = append (a, plist (b))

Theorem: plist-firstn plist (firstn (n, l)) = firstn (n, l)

Theorem: plist-init plist (init (v, i)) = init (v, i)

Theorem: plist-lastcdr plist (lastcdr (l)) = nil

Theorem: plist-plist plist (plist (l)) = plist (l)

Theorem: plist-restn plist (restn (n, l)) = restn (n, plist (l))

Theorem: plist-reverse plist (reverse (l)) = reverse (l)

; ---------- RESTN ----------

Theorem: restn-with-non-number-index (n ∉ N) → (restn (n, l) = restn (0, l))

Theorem: restn-with-large-index (length (l) ≤ n) → (restn (n, l) = lastcdr (l))

Theorem: restn-nlistp (¬ listp (l)) → (restn (n, l) = l)

Theorem: restn-0 restn (0, l) = l

Theorem: restn-cons restn (n, cons (a, b)) = if n ≃ 0 then cons (a, b)

else restn (n − 1, b) endif

Theorem: restn-append restn (n, append (a, b)) = if n ≤ length (a) then append (restn (n, a), b)

else restn (n − length (a), b) endif

Theorem: restn-firstn restn (n, firstn (i, l)) = if i ≤ n then nil

else firstn (i − n, restn (n, l)) endif

Theorem: restn-init restn (n, init (v, i)) = init (v, i − n)

Theorem: restn-lastcdr restn (n, lastcdr (l)) = lastcdr (l)

Theorem: restn-plist restn (n, plist (l)) = plist (restn (n, l))

Event: Disable restn-plist.

Theorem: restn-restn restn (i, restn (j , l)) = restn (j + i, l)

; ---------- REVERSE ----------

Theorem: reverse-nlistp (¬ listp (l)) → (reverse (l) = nil)

Theorem: reverse-cons reverse (cons (a, l)) = append (reverse (l), list (a))

Theorem: reverse-append reverse (append (a, b)) = append (reverse (b), reverse (a))

Theorem: reverse-init reverse (init (v, n)) = init (v, n)

Theorem: reverse-lastcdr reverse (lastcdr (l)) = nil

Theorem: reverse-plist reverse (plist (l)) = reverse (l)

Theorem: reverse-reverse plistp (l) → (reverse (reverse (l)) = l)

; ----------------------------------------------------------------------

Event: Let us define the theory lists to consist of the following events: appendfirstn-restn, append-init-init, append-init-list, append-lastcdr-arg1, append-lastcdr-arg2, append-left-id, append-nil, append-plist, append-plist-lastcdr, associativityof-append, car-init, equal-length-0, equal-plist, firstn-0, firstn-append, firstncons, 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, lengthcons, length-firstn, length-init, length-lastcdr, length-nlistp, length-plist, lengthrestn, length-reverse, listp-append, listp-firstn, listp-init, listp-lastcdr, listpplist, listp-restn, listp-reverse, plist-append, plist-cons, plist-firstn, plist-init, plist-lastcdr, plist-nlistp, plist-plist, plist-restn, plist-reverse, plistp-append, plistpcons, plistp-firstn, plistp-init, plistp-lastcdr, plistp-nlistp, plistp-plist, plistprestn, 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, reversenlistp, reverse-plist, reverse-reverse.

; ------------------------------------------------------------
; was piton-basis.events
; ------------------------------------------------------------

;; The following stuff is from Piton, defs.events

Event: Add the shell p-state, with recognizer function symbol p-statep and 9 accessors: p-pc, with type restriction (none-of) and default value zero; p-ctrl-stk, with type restriction (none-of) and default value zero; p-temp-stk, with type restriction (none-of) and default value zero; p-prog-segment, with type restriction (none-of) and default value zero; p-data-segment, with type restriction (noneof) and default value zero; p-max-ctrl-stk-size, with type restriction (none-of) and default value zero; p-max-temp-stk-size, with type restriction (none-of) and default value zero; p-word-size, with type restriction (none-of) and default value zero; p-psw, with type restriction (none-of) and default value 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.

Definition: 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:

Definition: errorp (psw) = ((psw ≠ 'run) ∧ (psw ≠ 'halt))

; Association lists.

Definition: put-assoc (val, name, alist) = if alist ≃ nil then alist

elseif name = caar (alist) then cons (cons (name, val), cdr (alist))

else cons (car (alist), put-assoc (val, name, cdr (alist))) endif

; The following function determines whether name is bound in alist.

Definition: definedp (name, alist) = if alist ≃ nil then f

elseif name = caar (alist) then t else definedp (name, cdr (alist)) endif

; This function is used to obtain the definition of a Piton variable
; or subroutine name.

Definition: definition (name, alist) = assoc (name, alist)

; These two functions are used for manipulating Piton variable values.

Definition: value (name, alist) = cdr (definition (name, alist))

Definition: put-value (val, name, alist) = put-assoc (val, name, alist)

; This function is used to strip the values out of an alist.

Definition: strip-cdrs (alist) = if alist ≃ nil then nil

else cons (cdr (car (alist)), strip-cdrs (cdr (alist))) endif

Definition: strip-cadrs (alist) = if alist ≃ nil then nil

else cons (cadr (car (alist)), strip-cadrs (cdr (alist))) endif

; Piton programs.
; When I fetch the definitions of programs from the prog-segment I
; want to decompose them into the following pieces:

Definition: name (d) = car (d)

Definition: formal-vars (d) = cadr (d)

Definition: temp-var-dcls (d) = caddr (d)

Definition: program-body (d) = cdddr (d)

; The ``locals'' of a program is the union of the formal-vars
; and the temporaries.

Definition: 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'').

Definition: adp-name (adp) = car (adp)

Definition: 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

Definition: adpp (x, segment) = (listp (x)

∧ (adp-offset (x) ∈ N)

∧ definedp (adp-name (x), segment)

∧ (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).

Definition: pcpp (x, segment) = (listp (x)

∧ (adp-offset (x) ∈ N)

∧ definedp (adp-name (x), segment)

∧ (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.

Definition: add-adp (adp, n) = cons (adp-name (adp), adp-offset (adp) + n)

Definition: add1-adp (adp) = add-adp (adp, 1)

Definition: sub-adp (adp, n) = cons (adp-name (adp), adp-offset (adp) − n)

Definition: sub1-adp (adp) = sub-adp (adp, 1)

Definition: get (n, lst) = if n ≃ 0 then car (lst)

else get (n − 1, cdr (lst)) endif

Definition: put (val, n, lst) = if n ≃ 0

then if listp (lst) then cons (val, cdr (lst))

else list (val) endif else cons (car (lst), put (val, n − 1, cdr (lst))) endif

Definition: fetch-adp (adp, segment) = get (adp-offset (adp), value (adp-name (adp), segment))

Definition: 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":

Definition: rget (n, lst) = get ((length (lst) − n) − 1, lst)

; The corresponding put function:

Definition: rput (val, n, lst) = put (val, (length (lst) − n) − 1, 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.

Definition: tag (type, obj ) = list (type, obj )

Definition: type (const) = car (const)

Definition: 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.

Definition: addressp (x, segment) = adpp (untag (x), segment)

Definition: area-name (x) = adp-name (untag (x))

Definition: offset (x) = adp-offset (untag (x))

Definition: add-addr (addr, n) = tag (type (addr), add-adp (untag (addr), n))

Definition: add1-addr (addr) = add-addr (addr, 1)

Definition: sub-addr (addr, n) = tag (type (addr), sub-adp (untag (addr), n))

Definition: sub1-addr (addr) = sub-addr (addr, 1)

Definition: fetch (addr, segment) = fetch-adp (untag (addr), segment)

Definition: 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).

Definition: booleanp (x) = ((x = 't) ∨ (x = 'f))

Definition: bool (x) = tag ('bool,

if x then 't else 'f endif)

; Because we know we only apply the boolean operators to booleanps we
; can skimp on the tests.

Definition: or-bool (x, y) = if x = 'f then y

else 't endif

Definition: and-bool (x, y) = if x = 'f then 'f

else y endif

Definition: not-bool (x) = if x = 'f then 't

else 'f endif

; *** 14-12-87/jsm:  The following defn was added during the proofs
; for i->m.

Definition: xor-bool (x, y) = if x = 'f then y

elseif y = 'f then 't else 'f endif

; Naturals

Definition: small-naturalp (i, word-size) = ((i ∈ N) ∧ (i < exp (2, word-size)))

Definition: bool-to-nat (flg) = if flg = 'f then 0

else 1 endif

; *** 16-12-87/jsm:  "fix-small" was renamed "fix-small-natural" so that
; a parallel "fix-small-integer" could be defined.

Definition: fix-small-natural (n, word-size) = (n mod 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))))

Definition: small-integerp (i, word-size) = (integerp (i)

∧ (¬ ilessp (i, − exp (2, word-size − 1))) ∧ ilessp (i, exp (2, word-size − 1)))

;; 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))))

Definition: inegate (i) = ineg (i)

;; IDIFFERENCE is defined in integers.events
;(defn idifference (i j)
;  (iplus i (inegate j)))

Definition: fix-small-integer (i, word-size) = if small-integerp (i, word-size) then i

elseif negativep (i) then iplus (i, exp (2, word-size))

else iplus (i, − exp (2, word-size)) endif

; Bit vectors

Definition: bitp (x) = ((x = 0) ∨ (x = 1))

Definition: bit-vectorp (x, n) = if x ≃ nil then (x = nil) ∧ (n ≃ 0)

else (n ≄ 0) ∧ bitp (car (x)) ∧ bit-vectorp (cdr (x), n − 1) endif Definition: or-bit (bit1 , bit2 ) = if bit1 = 0

then if bit2 = 0 then 0 else 1 endif

else 1 endif

Definition: not-bit (bit) = if bit = 0 then 1

else 0 endif

Definition: and-bit (bit1 , bit2 ) = if bit1 = 0 then 0

elseif bit2 = 0 then 0

else 1 endif

Definition: xor-bit (bit1 , bit2 ) = if bit1 = 0

then if bit2 = 0 then 0 else 1 endif elseif bit2 = 0 then 1 else 0 endif

Definition: or-bitv (a, b) = if a ≃ nil then nil

else cons (or-bit (car (a), car (b)), or-bitv (cdr (a), cdr (b))) endif

Definition: not-bitv (a) = if a ≃ nil then nil

else cons (not-bit (car (a)), not-bitv (cdr (a))) endif

Definition: and-bitv (a, b) = if a ≃ nil then nil

else cons (and-bit (car (a), car (b)), and-bitv (cdr (a), cdr (b))) endif

Definition: xor-bitv (a, b) = if a ≃ nil then nil

else cons (xor-bit (car (a), car (b)), xor-bitv (cdr (a), cdr (b))) endif Definition: all-but-last (a) = if a ≃ nil then nil

elseif cdr (a) ≃ nil then nil

else cons (car (a), all-but-last (cdr (a))) endif

Definition: rsh-bitv (a) = cons (0, all-but-last (a))

Definition: lsh-bitv (a) = append (cdr (a), list (0))

Definition: all-zero-bitvp (a) = if listp (a) then (car (a) = 0) ∧ all-zero-bitvp (cdr (a))

else t endif

; Stacks

Definition: push (x, stk) = cons (x, stk)

Definition: top (stk) = car (stk)

Definition: pop (stk) = cdr (stk)

Definition: popn (n, x) = if n ≃ 0 then x

else popn (n − 1, cdr (x)) endif

Definition: top1 (stk) = top (pop (stk))

Definition: 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:

Definition: dl (lab, comment, ins) = list ('dl, lab, comment, ins)

; The following function recognizes labelled items:

Definition: labelledp (x) = (car (x) = 'dl)

; This function extracts the instruction from the labelling.

Definition: unlabel (x) = if labelledp (x) then cadddr (x)

else x endif

; 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.

Event: Disable unlabel.

; The following function determines whether x is defined as a label
; in lst.

Definition: find-labelp (x, lst) = if lst ≃ nil then f

elseif labelledp (car (lst)) ∧ (x = cadr (car (lst))) then t else find-labelp (x, cdr (lst)) endif

; This function counts the number of items in lst before the first
; one labelled x.

Definition: find-label (x, lst) = if lst ≃ nil then 0

elseif labelledp (car (lst)) ∧ (x = cadr (car (lst))) then 0 else 1 + find-label (x, cdr (lst)) endif

; Generally we convert labels into tagged PCs.  We use the following
; function:

Definition: 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.

Definition: all-find-labelp (lab-lst, lst) = if lab-lst ≃ nil then t

else find-labelp (car (lab-lst), lst)

∧ all-find-labelp (cdr (lab-lst), lst) endif

;  P-Level Primitives

Definition: p-objectp (x, p) = (listp (x)

∧ (cddr (x) = nil) ∧ case on type (x): case = nat then small-naturalp (untag (x), p-word-size (p)) case = int then small-integerp (untag (x), p-word-size (p)) case = bitv then bit-vectorp (untag (x), p-word-size (p)) case = bool then booleanp (untag (x)) case = addr then adpp (untag (x), p-data-segment (p)) case = pc then pcpp (untag (x), p-prog-segment (p)) case = subr then definedp (untag (x), p-prog-segment (p)) otherwise f endcase)

Definition: p-objectp-type (type, x, p) = ((type (x) = type) ∧ p-objectp (x, p))

Definition: all-p-objectps (lst, p) = if lst ≃ nil then lst = nil

else p-objectp (car (lst), p) ∧ all-p-objectps (cdr (lst), p) endif

; The following function checks that it is ok to increment
; the pc by 1.

Definition: add1-p-pc (p) = add1-addr (p-pc (p))

Definition: add1-p-pcp (p) = pcpp (untag (add1-p-pc (p)), p-prog-segment (p))

Definition: p-current-program (p) = definition (area-name (p-pc (p)), p-prog-segment (p))

Definition: p-current-instruction (p) = unlabel (get (offset (p-pc (p)), program-body (p-current-program (p))))

Definition: p-frame (bindings, ret-pc) = list (bindings, ret-pc)

Definition: bindings (frame) = car (frame)

Definition: ret-pc (frame) = cadr (frame)

Definition: p-frame-size (frame) = (2 + length (bindings (frame)))

Definition: p-ctrl-stk-size (ctrl-stk) = if ctrl-stk ≃ nil then 0

else p-frame-size (top (ctrl-stk)) + p-ctrl-stk-size (cdr (ctrl-stk)) endif

Definition: local-varp (var, ctrl-stk) = definedp (var, bindings (top (ctrl-stk)))

Definition: local-var-value (var, ctrl-stk) = value (var, bindings (top (ctrl-stk)))

Definition: 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)))))

Definition: first-n (n, x) = if n ≃ 0 then nil

else cons (car (x), first-n (n − 1, cdr (x))) endif

Definition: pair-formal-vars-with-actuals (formal-vars, temp-stk) = 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.

Definition: pair-temps-with-initial-values (temp-var-dcls) = if temp-var-dcls ≃ nil then nil

else cons (cons (caar (temp-var-dcls), cadar (temp-var-dcls)), pair-temps-with-initial-values (cdr (temp-var-dcls))) endif

Definition: 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.

Definition: p-call-okp (ins, p) = ((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))))

∧ (length (p-temp-stk (p))

≮ length (formal-vars (definition (cadr (ins), p-prog-segment (p))))))

Definition: 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!

Definition: icode-call (ins, pcn, program)

= list ('(cpush *),

tag ('pc, cons (name (program), 1 + 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.

Definition: generate-prelude1 (temp-var-dcls) = if temp-var-dcls ≃ nil then nil

else cons ('(cpush *),

cons (cadr (car (temp-var-dcls)), generate-prelude1 (cdr (temp-var-dcls)))) endif

Definition: generate-prelude2 (formal-vars) = if formal-vars ≃ nil then nil

    else cons ('(cpush <tsp>+),

generate-prelude2 (cdr (formal-vars))) endif Definition: 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

Definition: find-position-of-var (var, lst) = if lst ≃ nil then 0

elseif var = car (lst) then 0

else 1 + find-position-of-var (var, cdr (lst)) endif

Definition: offset-from-csp (var, program) = find-position-of-var (var, local-vars (program))

;  We now define

Definition: 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.

Definition: p-ret-okp (ins, p) = t

Definition: p-ret-step (ins, p) = if listp (pop (p-ctrl-stk (p)))

then 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)

else p-halt (p, 'halt) endif

Definition: 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.

Definition: p-locn-okp (ins, p) = (p-objectp-type ('nat, local-var-value (cadr (ins), p-ctrl-stk (p)), p)

∧ (untag (local-var-value (cadr (ins), p-ctrl-stk (p))) < length (bindings (top (p-ctrl-stk (p))))) ∧ (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:

Definition: p-locn-step (ins, p) = p-state (add1-p-pc (p),

p-ctrl-stk (p),

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)

Definition: icode-locn (ins, pcn, program)

= list ('(move x *),

tag ('nat, offset-from-csp (cadr (ins), program)),

'(add x{n} csp),
'(move x <x{s}>),
'(add x{n} csp),
'(tpush <x{s}>))
;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.

Definition: p-push-constant-okp (ins, p) = (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.

Definition: unabbreviate-constant (c, p) = if c = 'pc then add1-p-pc (p)

elseif c ≃ nil then pc (c, p-current-program (p))

else c endif

Definition: 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)

Definition: icode-push-constant (ins, pcn, program)

= list ('(tpush *),

if cadr (ins) = 'pc then tag ('pc, cons (name (program), 1 + pcn)) elseif cadr (ins) ≃ nil then pc (cadr (ins), program) else cadr (ins) endif)

;  (PUSH-LOCAL var)     Push the value of the local variable var onto
;                       the temp-stk.

Definition: p-push-local-okp (ins, p) = (length (p-temp-stk (p)) < p-max-temp-stk-size (p))

Definition: 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)

Definition: icode-push-local (ins, pcn, program)

= list ('(move x *),

tag ('nat, offset-from-csp (cadr (ins), program)),

       '(add x{n} csp),
       '(tpush <x{s}>))
;push value of var onto tsp

;  (PUSH-GLOBAL var)    Push the value of the global variable var onto
;                       temp-stk.

Definition: p-push-global-okp (ins, p) = (length (p-temp-stk (p)) < p-max-temp-stk-size (p))

Definition: 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)

Definition: icode-push-global (ins, pcn, program)

= list ('(move x *),

tag ('addr, cons (cadr (ins), 0)),

       '(tpush <x{a}>))
;  (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.

Definition: p-push-ctrl-stk-free-size-okp (ins, p) = (length (p-temp-stk (p)) < p-max-temp-stk-size (p))

Definition: p-push-ctrl-stk-free-size-step (ins, p) = p-state (add1-p-pc (p),

p-ctrl-stk (p), push (tag ('nat,

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)

Definition: icode-push-ctrl-stk-free-size (ins, pcn, program)

= '((move x *)
      (sys-addr (full-ctrl-stk-addr . 0))
      (move x <x{s}>)
      (tpush csp)
      (sub <tsp>{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.

Definition: p-push-temp-stk-free-size-okp (ins, p) = (length (p-temp-stk (p)) < p-max-temp-stk-size (p))

Definition: p-push-temp-stk-free-size-step (ins, p) = p-state (add1-p-pc (p),

p-ctrl-stk (p), push (tag ('nat,

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)

Definition: icode-push-temp-stk-free-size (ins, pcn, program)

= '((move x *)
      (sys-addr (full-temp-stk-addr . 0))
      (move x <x{s}>)
      (tpush tsp)
      (sub <tsp>{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.

Definition: p-push-temp-stk-index-okp (ins, p) = ((length (p-temp-stk (p)) < p-max-temp-stk-size (p))

∧ (cadr (ins) < length (p-temp-stk (p))))

Definition: p-push-temp-stk-index-step (ins, p) = p-state (add1-p-pc (p),

p-ctrl-stk (p),

push (tag ('nat, (length (p-temp-stk (p)) − cadr (ins)) − 1),

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_<z>_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.

Definition: icode-push-temp-stk-index (ins, pcn, program)

= list ('(move y tsp),
       '(move x *),
       '(sys-addr (empty-temp-stk-addr . 0)),
       '(move x <x{s}>),
       '(sub <z> x{s} y{s}),
       '(tpush x),
       '(move x *),

tag ('nat, 1 + cadr (ins)),

       '(sub <tsp>{n} x{n}))
;  (JUMP-IF-TEMP-STK-FULL lab)
;                      If the temp-stk is full, jump to lab.

Definition: p-jump-if-temp-stk-full-okp (ins, p) = t

Definition: p-jump-if-temp-stk-full-step (ins, p) = p-state (if length (p-temp-stk (p)) = p-max-temp-stk-size (p)

then pc (cadr (ins), p-current-program (p)) else add1-p-pc (p) endif, 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)

Definition: icode-jump-if-temp-stk-full (ins, pcn, program)

= list ('(move x tsp),

'(move y *),
'(sys-addr (full-temp-stk-addr . 0)),
'(move y <y{s}>),
'(sub <z> 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.

Definition: p-jump-if-temp-stk-empty-okp (ins, p) = t

Definition: p-jump-if-temp-stk-empty-step (ins, p) = p-state (if length (p-temp-stk (p)) ≃ 0

then pc (cadr (ins), p-current-program (p)) else add1-p-pc (p) endif, 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)

Definition: icode-jump-if-temp-stk-empty (ins, pcn, program)

= list ('(move y tsp),
'(move x *),
'(sys-addr (empty-temp-stk-addr . 0)),
'(move x <x{s}>),
'(sub <z> x{s} y{s}),
'(move x *),

pc (cadr (ins), program),

'(jump-z x))
;  (POP)                Pop top of temp-stk and discard

Definition: p-pop-okp (ins, p) = listp (p-temp-stk (p))

Definition: 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)

Definition: icode-pop (ins, pcn, program) = '((tpop x))

;  (POP* n)                Pop temp-stk n times.

Definition: p-pop*-okp (ins, p) = (length (p-temp-stk (p)) ≮ cadr (ins))

Definition: 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)

Definition: 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).

Definition: p-popn-okp (ins, p)

= (listp (p-temp-stk (p))

∧ p-objectp-type ('nat, top (p-temp-stk (p)), p) ∧ (length (p-temp-stk (p)) ≮ (1 + untag (top (p-temp-stk (p))))))

Definition: 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)

Definition: 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.

Definition: p-pop-local-okp (ins, p) = listp (p-temp-stk (p))

Definition: 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)

Definition: icode-pop-local (ins, pcn, program)

= list ('(move x *),

tag ('nat, offset-from-csp (cadr (ins), program)),

'(add x{n} csp),
'(tpop <x{s}>))

;  (POP-GLOBAL var)     Pop top of temp-stk and put the value into the global
;                       variable var.

Definition: p-pop-global-okp (ins, p) = listp (p-temp-stk (p))

Definition: 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)

Definition: icode-pop-global (ins, pcn, program)

= list ('(move x *),

tag ('addr, cons (cadr (ins), 0)),

       '(tpop <x{a}>))
;  (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.

Definition: p-pop-locn-okp (ins, p) = (p-objectp-type ('nat, local-var-value (cadr (ins), p-ctrl-stk (p)), p)

∧ (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.

Definition: put-value-indirect (val, n, lst) = if listp (lst)

then if n ≃ 0 then cons (cons (caar (lst), val), cdr (lst))

else cons (car (lst), put-value-indirect (val, n − 1, cdr (lst))) endif else lst endif

Definition: 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))

Definition: p-pop-locn-step (ins, p) = p-state (add1-p-pc (p),

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)

Definition: icode-pop-locn (ins, pcn, program)

= list ('(move x *),

tag ('nat, offset-from-csp (cadr (ins), program)),

       '(add x{n} csp),
       '(move x <x{s}>),
       '(add x{n} csp),
       '(tpop <x{s}>))
;  (POP-CALL)           Pop temp-stk to obtain a subroutine name and
;                       call that subroutine.

Definition: p-pop-call-okp (ins, p) = (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)))

Definition: 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))

Definition: icode-pop-call (ins, pcn, program)

= list ('(tpop x),
       '(cpush *),

tag ('pc, cons (name (program), 1 + 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.

Definition: p-fetch-temp-stk-okp (ins, p) = (listp (p-temp-stk (p))

∧ p-objectp-type ('nat, top (p-temp-stk (p)), p)

∧ (untag (top (p-temp-stk (p))) < length (p-temp-stk (p))))

Definition: 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)

Definition: icode-fetch-temp-stk (ins, pcn, program)

= '((tpop y)
      (incr y y{n})
      (move x *)
      (sys-addr (empty-temp-stk-addr . 0))
      (move x <x{s}>)
      (sub x{s} y{n})
      (tpush <x{s}>))
;   (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.

Definition: p-deposit-temp-stk-okp (ins, p) = (listp (p-temp-stk (p))

∧ listp (pop (p-temp-stk (p)))

∧ p-objectp-type ('nat, top (p-temp-stk (p)), p) ∧ (untag (top (p-temp-stk (p)))

< length (pop (pop (p-temp-stk (p))))))

Definition: 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)

Definition: icode-deposit-temp-stk (ins, pcn, program)

= '((tpop y)
      (incr y y{n})
      (move x *)
      (sys-addr (empty-temp-stk-addr . 0))
      (move x <x{s}>)
      (sub x{s} y{n})
      (tpop <x{s}>))
;  (JUMP lab)           Jump to the location named by lab in the current
;                       program.

Definition: p-jump-okp (ins, p) = t

Definition: 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)

Definition: 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.

Definition: p-jump-case-okp (ins, p) = (listp (p-temp-stk (p))

∧ p-objectp-type ('nat, top (p-temp-stk (p)), p) ∧ (untag (top (p-temp-stk (p))) < length (cdr (ins))))

Definition: 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)

Definition: jump *-lst (lst, program) = if lst ≃ nil then nil

else cons ('(jump *),

cons (pc (car (lst), program), jump *-lst (cdr (lst), program))) endif

Definition: 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.

Definition: p-pushj-okp (ins, p) = (length (p-temp-stk (p)) < p-max-temp-stk-size (p))

Definition: 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)

Definition: icode-pushj (ins, pcn, program)

= list ('(tpush *),

tag ('pc, cons (name (program), 1 + 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!

Definition: p-popj-okp (ins, p) = (listp (p-temp-stk (p))

∧ p-objectp-type ('pc, top (p-temp-stk (p)), p)

∧ (area-name (top (p-temp-stk (p))) = area-name (p-pc (p))))

Definition: 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)

Definition: 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.

Definition: p-set-local-okp (ins, p) = listp (p-temp-stk (p))

Definition: 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)

Definition: icode-set-local (ins, pcn, program)

= list ('(move x *),

tag ('nat, offset-from-csp (cadr (ins), program)),

       '(add x{n} csp),
       '(move <x{s}> <tsp>))
;  (SET-GLOBAL var)     Set the global variable var to the top of the temp-stk
;                       but do not pop the temp-stk.

Definition: p-set-global-okp (ins, p) = listp (p-temp-stk (p))

Definition: 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)

Definition: icode-set-global (ins, pcn, program)

= list ('(move x *),

tag ('addr, cons (cadr (ins), 0)),

       '(move <x{a}> <tsp>))
; (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.

Definition: p-test-and-jump-okp (ins, type, test, p) = (listp (p-temp-stk (p)) ∧ p-objectp-type (type, top (p-temp-stk (p)), p))

Definition: p-test-and-jump-step (test, lab, p) = if test

then 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)

else 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) endif

; (TEST-NAT-AND-JUMP flg lab)
;                          flg                test
;                          ZERO          jump if x is 0
;                      NOT-ZERO          jump if x is not 0

Definition: p-test-natp (flg, x) = case on flg:

case = zero then x = 0 otherwise x ≠ 0 endcase

Definition: 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)

Definition: 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)

Definition: icode-test-nat-and-jump (ins, pcn, program) = case on cadr (ins):

case = zero

then list ('(tpop{n} <z> y),

            '(move x *),

pc (caddr (ins), program),

            '(jump-z x))

otherwise list ('(tpop{n} <z> y),

                 '(move x *),

pc (caddr (ins), program),

                 '(jump-nz x)) endcase
; (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

Definition: p-test-intp (flg, x) = case on flg:

case = zero then x = 0 case = not-zero then x ≠ 0 case = neg then negativep (x) case = not-neg then ¬ negativep (x) case = pos then (x ∈ N) ∧ (x ≠ 0) otherwise (x = 0) ∨ negativep (x) endcase

Definition: 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)

Definition: 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)

Definition: icode-test-int-and-jump (ins, pcn, program) = case on cadr (ins):

case = zero

then list ('(tpop{i} <zn> y),

            '(move x *),

pc (caddr (ins), program),

            '(jump-z x))

case = not-zero

then list ('(tpop{i} <zn> y),

             '(move x *),

pc (caddr (ins), program),

             '(jump-nz x))

case = neg

then list ('(tpop{i} <zn> y),

             '(move x *),

pc (caddr (ins), program),

             '(jump-n x))

case = not-neg

then list ('(tpop{i} <zn> y),

             '(move x *),

pc (caddr (ins), program),

             '(jump-nn x))

case = pos

then list ('(tpop{i} <zn> y),

             '(move x *),

tag ('pc, cons (name (program), 1 + pcn)),

             '(jump-n x),
             '(jump-z x),
             '(jump *),

pc (caddr (ins), program))

otherwise list ('(tpop{i} <zn> y),

                 '(move x *),

pc (caddr (ins), program),

                 '(jump-n x),
                 '(jump-z x)) endcase
; (TEST-BOOL-AND-JUMP flg lab)
;                          flg                test
;                          T            jump if x is T
;                          F            jump if x is F

Definition: p-test-boolp (flg, x) = case on flg:

case = t then x = 't otherwise x = 'f endcase

Definition: 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)

Definition: 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)

Definition: icode-test-bool-and-jump (ins, pcn, program) = case on cadr (ins):

case = t

then list ('(tpop{b} <z> y),

            '(move x *),

pc (caddr (ins), program),

            '(jump-nz x))

otherwise list ('(tpop{b} <z> y),

                 '(move x *),

pc (caddr (ins), program),

                 '(jump-z x)) endcase
; (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

Definition: p-test-bitvp (flg, x) = case on flg:

case = all-zero

then all-zero-bitvp (x)

otherwise ¬ all-zero-bitvp (x) endcase

Definition: 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)

Definition: 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)

Definition: icode-test-bitv-and-jump (ins, pcn, program) = case on cadr (ins):

case = all-zero

then list ('(tpop{v} <z> y),

            '(move x *),

pc (caddr (ins), program),

            '(jump-z x))

otherwise list ('(tpop{v} <z> y),

                 '(move x *),

pc (caddr (ins), program),

                 '(jump-nz x)) endcase
;   (NO-OP)             Do nothing.  Advance the pc to the next instruction.

Definition: p-no-op-okp (ins, p) = t

Definition: 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)

Definition: 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.

Definition: p-add-addr-okp (ins, p) = (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))

Definition: 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)

Definition: icode-add-addr (ins, pcn, program)

= '((tpop x) (add <tsp>{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.

Definition: p-sub-addr-okp (ins, p) = (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) ∧ (offset (top1 (p-temp-stk (p))) ≮ untag (top (p-temp-stk (p)))))

Definition: 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)

Definition: icode-sub-addr (ins, pcn, program)

= '((tpop x) (sub <tsp>{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.

Definition: p-eq-okp (ins, p) = (listp (p-temp-stk (p))

∧ listp (pop (p-temp-stk (p))) ∧ (type (top (p-temp-stk (p))) = type (top1 (p-temp-stk (p)))))

Definition: p-eq-step (ins, p) = p-state (add1-p-pc (p),

p-ctrl-stk (p), push (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)

Definition: icode-eq (ins, pcn, program)

= '((tpop x)
      (xor <z> <tsp> x)
      (xor <tsp> <tsp>)
      (move-z <tsp> *)
      (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.

Definition: p-lt-addr-okp (ins, p) = (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) ∧ (area-name (top (p-temp-stk (p)))

= area-name (top1 (p-temp-stk (p)))))

Definition: p-lt-addr-step (ins, p) = p-state (add1-p-pc (p),

p-ctrl-stk (p),

push (bool (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)

Definition: icode-lt-addr (ins, pcn, program)

= '((tpop x)
      (sub <c> <tsp>{a} x{a})
      (xor <tsp> <tsp>)
      (move-c <tsp> *)
      (bool t))
;   (FETCH)             Pop top of temp-stk.  The result must

;                       be an address.  Push the contents of that
;                       address onto temp-stk.

Definition: p-fetch-okp (ins, p) = (listp (p-temp-stk (p))

∧ p-objectp-type ('addr, top (p-temp-stk (p)), p))

Definition: 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)

Definition: icode-fetch (ins, pcn, program) = '((tpop x) (tpush <x{a}>))

;   (DEPOSIT)           Pop top and top1 off of temp-stk.  top must be
;                       an address.  Deposit top1 into the address.

Definition: p-deposit-okp (ins, p) = (listp (p-temp-stk (p))

∧ listp (pop (p-temp-stk (p)))

∧ p-objectp-type ('addr, top (p-temp-stk (p)), p))

Definition: 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)

Definition: icode-deposit (ins, pcn, program) = '((tpop x) (tpop <x{a}>))

;   (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.

Definition: p-add-int-okp (ins, p) = (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)))

Definition: 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)

Definition: icode-add-int (ins, pcn, program)

= '((tpop x) (add <tsp>{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.

Definition: p-add-int-with-carry-okp (ins, p) = (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))

Definition: p-add-int-with-carry-step (ins, p) = let sum be iplus (bool-to-nat (untag (top2 (p-temp-stk (p)))),

iplus (untag (top1 (p-temp-stk (p))),

untag (top (p-temp-stk (p)))))

in

p-state (add1-p-pc (p), p-ctrl-stk (p), push (tag ('int, fix-small-integer (sum, p-word-size (p))),

push (bool (¬ 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) endlet

Definition: icode-add-int-with-carry (ins, pcn, program)

= '((tpop x)
      (tpop y)
      (asr <c> <tsp> <tsp>{b})
      (addc <v> x{i} y{i})
      (move-v <tsp> *)
      (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.

Definition: p-add1-int-okp (ins, p) = (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)))

Definition: 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)

Definition: icode-add1-int (ins, pcn, program) = '((incr <tsp> <tsp>{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.

Definition: p-sub-int-okp (ins, p) = (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)))

Definition: 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)

Definition: icode-sub-int (ins, pcn, program)

= '((tpop x) (sub <tsp>{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.

Definition: p-sub-int-with-carry-okp (ins, p) = (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))

Definition: p-sub-int-with-carry-step (ins, p) = let diff be idifference (untag (top1 (p-temp-stk (p))),

iplus (untag (top (p-temp-stk (p))), bool-to-nat (untag (top2 (p-temp-stk (p)))))) in p-state (add1-p-pc (p),

p-ctrl-stk (p), push (tag ('int, fix-small-integer (diff , p-word-size (p))),

push (bool (¬ 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) endlet

Definition: icode-sub-int-with-carry (ins, pcn, program)

= '((tpop y)
(tpop x)
(asr <c> <tsp> <tsp>{b})
(subb <v> x{i} y{i})
(move-v <tsp> *)
(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.

Definition: p-sub1-int-okp (ins, p) = (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)))

Definition: 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)

Definition: icode-sub1-int (ins, pcn, program) = '((decr <tsp> <tsp>{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.

Definition: p-neg-int-okp (ins, p) = (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)))

Definition: 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)

Definition: icode-neg-int (ins, pcn, program) = '((neg <tsp> <tsp>{i}))

;   (LT-INT)            Pop top and top1 off of temp-stk, and push T or F
;                       according to whether top1 < top.

Definition: p-lt-int-okp (ins, p) = (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))

Definition: 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<y iff (xor n-flg v-flg).

Definition: icode-lt-int (ins, pcn, program)

= '((tpop x)
      (sub <nv> <tsp>{i} x{i})
      (move <tsp> *)
      (bool f)
      (move-v <tsp> *)
      (bool t)
      (move x *)
      (bool f)
      (move-n x *)
      (bool t)
      (xor <tsp>{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_<pc+1> 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.

Definition: p-int-to-nat-okp (ins, p) = (listp (p-temp-stk (p))

∧ p-objectp-type ('int, top (p-temp-stk (p)), p) ∧ (¬ negativep (untag (top (p-temp-stk (p))))))

Definition: 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)

Definition: 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.

Definition: p-add-nat-okp (ins, p) = (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 (untag (top1 (p-temp-stk (p)))

+ untag (top (p-temp-stk (p))), p-word-size (p)))

Definition: p-add-nat-step (ins, p) = let sum be untag (top1 (p-temp-stk (p)))

+ untag (top (p-temp-stk (p)))

in

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) endlet

Definition: icode-add-nat (ins, pcn, program)

= '((tpop x) (add <tsp>{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.

Definition: p-add-nat-with-carry-okp (ins, p) = (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))

Definition: p-add-nat-with-carry-step (ins, p) = let sum be bool-to-nat (untag (top2 (p-temp-stk (p))))

+ untag (top1 (p-temp-stk (p)))

+ untag (top (p-temp-stk (p)))

in p-state (add1-p-pc (p),

p-ctrl-stk (p), push (tag ('nat, fix-small-natural (sum, p-word-size (p))),

push (bool (¬ 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) endlet

Definition: icode-add-nat-with-carry (ins, pcn, program)

= '((tpop x)
(tpop y)
(asr <c> <tsp> <tsp>{b})
(addc <c> x{n} y{n})
(move-c <tsp> *)
(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.

Definition: p-add1-nat-okp (ins, p) = (listp (p-temp-stk (p))

∧ p-objectp-type ('nat, top (p-temp-stk (p)), p)

∧ small-naturalp (1 + untag (top (p-temp-stk (p))), p-word-size (p)))

Definition: p-add1-nat-step (ins, p) = let sum be 1 + untag (top (p-temp-stk (p)))

in

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) endlet

Definition: icode-add1-nat (ins, pcn, program) = '((incr <tsp> <tsp>{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.

Definition: p-sub-nat-okp (ins, p) = (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) ∧ (untag (top1 (p-temp-stk (p))) ≮ untag (top (p-temp-stk (p)))))

Definition: p-sub-nat-step (ins, p) = let y be untag (top (p-temp-stk (p))),

x be untag (top1 (p-temp-stk (p))) in p-state (add1-p-pc (p),

p-ctrl-stk (p),

push (tag ('nat, 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) endlet

Definition: icode-sub-nat (ins, pcn, program)

= '((tpop x) (sub <tsp>{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.

Definition: p-sub-nat-with-carry-okp (ins, p) = (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))

Definition: p-sub-nat-with-carry-step (ins, p)

= let y be untag (top (p-temp-stk (p))), x be untag (top1 (p-temp-stk (p))), c be bool-to-nat (untag (top2 (p-temp-stk (p))))

in

p-state (add1-p-pc (p), p-ctrl-stk (p), push (tag ('nat,

if x < (y + c)

then exp (2, p-word-size (p)) − ((y + c) − x) else x − (y + c) endif),

push (bool (x < (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) endlet

Definition: icode-sub-nat-with-carry (ins, pcn, program)

= '((tpop y)
      (tpop x)
      (asr <c> <tsp> <tsp>{b})
      (subb <c> x{n} y{n})
      (move-c <tsp> *)
      (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.

Definition: p-sub1-nat-okp (ins, p) = (listp (p-temp-stk (p))

∧ p-objectp-type ('nat, top (p-temp-stk (p)), p) ∧ (untag (top (p-temp-stk (p))) ≄ 0))

Definition: p-sub1-nat-step (ins, p)

= p-state (add1-p-pc (p), p-ctrl-stk (p), push (tag ('nat, 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)

Definition: icode-sub1-nat (ins, pcn, program) = '((decr <tsp> <tsp>{n}))

;   (LT-NAT)            Pop top and top1 off of temp-stk, and push T or F
;                       according to whether top1 < top.

Definition: p-lt-nat-okp (ins, p) = (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))

Definition: p-lt-nat-step (ins, p) = p-state (add1-p-pc (p),

p-ctrl-stk (p), push (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)

Definition: icode-lt-nat (ins, pcn, program)

= '((tpop x)
(sub <c> <tsp>{n} x{n})
(xor <tsp> <tsp>)
(move-c <tsp> *)
(bool t))

;   (MULT2-NAT)         Pop top of temp-stk, multiply by 2 and push
;                       the result, which must be a small-naturalp.

Definition: p-mult2-nat-okp (ins, p) = (listp (p-temp-stk (p))

∧ p-objectp-type ('nat, top (p-temp-stk (p)), p) ∧ small-naturalp (2 ∗ untag (top (p-temp-stk (p))), p-word-size (p)))

Definition: p-mult2-nat-step (ins, p) = let prod be 2 ∗ untag (top (p-temp-stk (p)))

in

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) endlet

Definition: icode-mult2-nat (ins, pcn, program) = '((add <tsp> <tsp>{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.

Definition: p-mult2-nat-with-carry-out-okp (ins, p) = (listp (p-temp-stk (p))

∧ p-objectp-type ('nat, top (p-temp-stk (p)), p)

∧ (length (p-temp-stk (p)) < p-max-temp-stk-size (p)))

Definition: p-mult2-nat-with-carry-out-step (ins, p) = let prod be 2 ∗ untag (top (p-temp-stk (p))) in p-state (add1-p-pc (p),

p-ctrl-stk (p), push (tag ('nat, fix-small-natural (prod, p-word-size (p))),

push (bool (¬ 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) endlet

Definition: icode-mult2-nat-with-carry-out (ins, pcn, program)

= '((tpop x)
(add <c> x x{n})
(tpush *)
(bool f)
(move-c <tsp> *)
(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.

Definition: p-div2-nat-okp (ins, p) = (listp (p-temp-stk (p))

∧ p-objectp-type ('nat, top (p-temp-stk (p)), p) ∧ (length (p-temp-stk (p)) < p-max-temp-stk-size (p)))

Definition: p-div2-nat-step (ins, p) = let quo be untag (top (p-temp-stk (p))) ÷ 2,

rem be untag (top (p-temp-stk (p))) mod 2 in 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) endlet

Definition: icode-div2-nat (ins, pcn, program)

= '((tpop <c> x)
      (lsr <c> x x{n})
      (tpush x)
      (tpush *)
      (nat 0)
      (move-c <tsp> *)
      (nat 1))
;   (OR-BITV)           Pop top and top1 off of temp-stk, or them together
;                       and push the result.

Definition: p-or-bitv-okp (ins, p) = (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))

Definition: 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)

Definition: icode-or-bitv (ins, pcn, program) = '((tpop x) (or <tsp>{v} x{v}))

;   (AND-BITV)          Pop top and top1 off of temp-stk, and them together
;                       and push the result.

Definition: p-and-bitv-okp (ins, p) = (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))

Definition: 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)

Definition: icode-and-bitv (ins, pcn, program)

= '((tpop x) (and <tsp>{v} x{v}))
;   (NOT-BITV)          Pop top of temp-stk, not it, and push the result.

Definition: p-not-bitv-okp (ins, p) = (listp (p-temp-stk (p))

∧ p-objectp-type ('bitv, top (p-temp-stk (p)), p))

Definition: 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)

Definition: icode-not-bitv (ins, pcn, program) = '((not <tsp> <tsp>{v}))

;   (XOR-BITV)          Pop top and top1 off of temp-stk, xor them,
;                       and push the result.

Definition: p-xor-bitv-okp (ins, p) = (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))

Definition: 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)

Definition: icode-xor-bitv (ins, pcn, program)

= '((tpop x) (xor <tsp>{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.

Definition: p-rsh-bitv-okp (ins, p) = (listp (p-temp-stk (p))

∧ p-objectp-type ('bitv, top (p-temp-stk (p)), p))

Definition: 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)

Definition: icode-rsh-bitv (ins, pcn, program) = '((lsr <tsp> <tsp>{v}))

;   (LSH-BITV)          Pop top of temp-stk, shift it left 1, bringing
;                       a 0 in at the btm, and push the result.

Definition: p-lsh-bitv-okp (ins, p) = (listp (p-temp-stk (p))

∧ p-objectp-type ('bitv, top (p-temp-stk (p)), p))

Definition: 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)

Definition: icode-lsh-bitv (ins, pcn, program) = '((add <tsp> <tsp>{v}))

;   (OR-BOOL)           Pop top and top1 off of temp-stk, or them together
;                       and push the result.

Definition: p-or-bool-okp (ins, p)

= (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))

Definition: 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)

Definition: icode-or-bool (ins, pcn, program) = '((tpop x) (or <tsp>{b} x{b}))

;   (AND-BOOL)          Pop top and top1 off of temp-stk, and them together
;                       and push the result.
;

Definition: p-and-bool-okp (ins, p) = (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))

Definition: 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)

Definition: icode-and-bool (ins, pcn, program)

= '((tpop x) (and <tsp>{b} x{b}))
;   (NOT-BOOL)          Pop top of temp-stk, not it, and push the result.

Definition: p-not-bool-okp (ins, p) = (listp (p-temp-stk (p))

∧ p-objectp-type ('bool, top (p-temp-stk (p)), p))

Definition: p-not-bool-step (ins, p) = p-state (add1-p-pc (p),

p-ctrl-stk (p),

push (tag ('bool, 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)

Definition: icode-not-bool (ins, pcn, program)

= '((xor <tsp>{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.

Definition: piton-opcodes

= '(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.

Definition: 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:

Definition: p-ins-okp (ins, p) = case on car (ins):

case = call then p-call-okp (ins, p) case = ret then p-ret-okp (ins, p) case = locn then p-locn-okp (ins, p) case = push-constant then p-push-constant-okp (ins, p) case = push-local then p-push-local-okp (ins, p) case = push-global then p-push-global-okp (ins, p) case = push-ctrl-stk-free-size then p-push-ctrl-stk-free-size-okp (ins, p) case = push-temp-stk-free-size then p-push-temp-stk-free-size-okp (ins, p) case = push-temp-stk-index then p-push-temp-stk-index-okp (ins, p) case = jump-if-temp-stk-full then p-jump-if-temp-stk-full-okp (ins, p) case = jump-if-temp-stk-empty then p-jump-if-temp-stk-empty-okp (ins, p) case = pop then p-pop-okp (ins, p) case = pop* then p-pop*-okp (ins, p) case = popn then p-popn-okp (ins, p) case = pop-local then p-pop-local-okp (ins, p) case = pop-global then p-pop-global-okp (ins, p) case = pop-locn then p-pop-locn-okp (ins, p) case = pop-call then p-pop-call-okp (ins, p) case = fetch-temp-stk then p-fetch-temp-stk-okp (ins, p) case = deposit-temp-stk then p-deposit-temp-stk-okp (ins, p) case = jump then p-jump-okp (ins, p) case = jump-case then p-jump-case-okp (ins, p) case = pushj then p-pushj-okp (ins, p) case = popj then p-popj-okp (ins, p) case = set-local then p-set-local-okp (ins, p) case = set-global then p-set-global-okp (ins, p) case = test-nat-and-jump then p-test-nat-and-jump-okp (ins, p) case = test-int-and-jump then p-test-int-and-jump-okp (ins, p) case = test-bool-and-jump then p-test-bool-and-jump-okp (ins, p) case = test-bitv-and-jump then p-test-bitv-and-jump-okp (ins, p) case = no-op then p-no-op-okp (ins, p) case = add-addr then p-add-addr-okp (ins, p) case = sub-addr then p-sub-addr-okp (ins, p) case = eq then p-eq-okp (ins, p) case = lt-addr then p-lt-addr-okp (ins, p) case = fetch then p-fetch-okp (ins, p) case = deposit then p-deposit-okp (ins, p) case = add-int then p-add-int-okp (ins, p) case = add-int-with-carry then p-add-int-with-carry-okp (ins, p) case = add1-int then p-add1-int-okp (ins, p) case = sub-int then p-sub-int-okp (ins, p) case = sub-int-with-carry then p-sub-int-with-carry-okp (ins, p) case = sub1-int then p-sub1-int-okp (ins, p) case = neg-int then p-neg-int-okp (ins, p) case = lt-int then p-lt-int-okp (ins, p) case = int-to-nat then p-int-to-nat-okp (ins, p) case = add-nat then p-add-nat-okp (ins, p) case = add-nat-with-carry then p-add-nat-with-carry-okp (ins, p) case = add1-nat then p-add1-nat-okp (ins, p) case = sub-nat then p-sub-nat-okp (ins, p) case = sub-nat-with-carry then p-sub-nat-with-carry-okp (ins, p) case = sub1-nat then p-sub1-nat-okp (ins, p) case = lt-nat then p-lt-nat-okp (ins, p) case = mult2-nat then p-mult2-nat-okp (ins, p) case = mult2-nat-with-carry-out then p-mult2-nat-with-carry-out-okp (ins, p) case = div2-nat then p-div2-nat-okp (ins, p) case = or-bitv then p-or-bitv-okp (ins, p) case = and-bitv then p-and-bitv-okp (ins, p) case = not-bitv then p-not-bitv-okp (ins, p) case = xor-bitv then p-xor-bitv-okp (ins, p) case = rsh-bitv then p-rsh-bitv-okp (ins, p) case = lsh-bitv then p-lsh-bitv-okp (ins, p) case = or-bool then p-or-bool-okp (ins, p) case = and-bool then p-and-bool-okp (ins, p) case = not-bool then p-not-bool-okp (ins, p) otherwise f endcase

; 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.

Definition: p-ins-step (ins, p) = case on car (ins):

case = call then p-call-step (ins, p) case = ret then p-ret-step (ins, p) case = locn then p-locn-step (ins, p) case = push-constant then p-push-constant-step (ins, p) case = push-local then p-push-local-step (ins, p) case = push-global then p-push-global-step (ins, p) case = push-ctrl-stk-free-size then p-push-ctrl-stk-free-size-step (ins, p) case = push-temp-stk-free-size then p-push-temp-stk-free-size-step (ins, p) case = push-temp-stk-index then p-push-temp-stk-index-step (ins, p) case = jump-if-temp-stk-full then p-jump-if-temp-stk-full-step (ins, p) case = jump-if-temp-stk-empty then p-jump-if-temp-stk-empty-step (ins, p) case = pop then p-pop-step (ins, p) case = pop* then p-pop*-step (ins, p) case = popn then p-popn-step (ins, p) case = pop-local then p-pop-local-step (ins, p) case = pop-global then p-pop-global-step (ins, p) case = pop-locn then p-pop-locn-step (ins, p) case = pop-call then p-pop-call-step (ins, p) case = fetch-temp-stk then p-fetch-temp-stk-step (ins, p) case = deposit-temp-stk then p-deposit-temp-stk-step (ins, p) case = jump then p-jump-step (ins, p) case = jump-case then p-jump-case-step (ins, p) case = pushj then p-pushj-step (ins, p) case = popj then p-popj-step (ins, p) case = set-local then p-set-local-step (ins, p) case = set-global then p-set-global-step (ins, p) case = test-nat-and-jump then p-test-nat-and-jump-step (ins, p) case = test-int-and-jump then p-test-int-and-jump-step (ins, p) case = test-bool-and-jump then p-test-bool-and-jump-step (ins, p) case = test-bitv-and-jump then p-test-bitv-and-jump-step (ins, p) case = no-op then p-no-op-step (ins, p) case = add-addr then p-add-addr-step (ins, p) case = sub-addr then p-sub-addr-step (ins, p) case = eq then p-eq-step (ins, p) case = lt-addr then p-lt-addr-step (ins, p) case = fetch then p-fetch-step (ins, p) case = deposit then p-deposit-step (ins, p) case = add-int then p-add-int-step (ins, p) case = add-int-with-carry then p-add-int-with-carry-step (ins, p) case = add1-int then p-add1-int-step (ins, p) case = sub-int then p-sub-int-step (ins, p) case = sub-int-with-carry then p-sub-int-with-carry-step (ins, p) case = sub1-int then p-sub1-int-step (ins, p) case = neg-int then p-neg-int-step (ins, p) case = lt-int then p-lt-int-step (ins, p) case = int-to-nat then p-int-to-nat-step (ins, p) case = add-nat then p-add-nat-step (ins, p) case = add-nat-with-carry then p-add-nat-with-carry-step (ins, p) case = add1-nat then p-add1-nat-step (ins, p) case = sub-nat then p-sub-nat-step (ins, p) case = sub-nat-with-carry then p-sub-nat-with-carry-step (ins, p) case = sub1-nat then p-sub1-nat-step (ins, p) case = lt-nat then p-lt-nat-step (ins, p) case = mult2-nat then p-mult2-nat-step (ins, p) case = mult2-nat-with-carry-out then p-mult2-nat-with-carry-out-step (ins, p) case = div2-nat then p-div2-nat-step (ins, p) case = or-bitv then p-or-bitv-step (ins, p) case = and-bitv then p-and-bitv-step (ins, p) case = not-bitv then p-not-bitv-step (ins, p) case = xor-bitv then p-xor-bitv-step (ins, p) case = rsh-bitv then p-rsh-bitv-step (ins, p) case = lsh-bitv then p-lsh-bitv-step (ins, p) case = or-bool then p-or-bool-step (ins, p) case = and-bool then p-and-bool-step (ins, p) case = not-bool then p-not-bool-step (ins, p) otherwise p-halt (p, 'run) endcase

; 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.

Definition: p-step1 (ins, p) = if p-ins-okp (ins, p) then p-ins-step (ins, p)

else p-halt (p, x-y-error-msg ('p, car (ins))) endif

; Of course, we are only interested in executing the current
; instruction of a state.  That is what we call stepping the state.

Definition: p-step (p) = if p-psw (p) = 'run then p-step1 (p-current-instruction (p), p)

else p endif

; 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.

Definition: p (p, n) = if n ≃ 0 then p

else p (p-step (p), n − 1) endif

; 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:

Definition: 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.

Definition: icode1 (ins, pcn, prog) = case on car (ins):

case = call then icode-call (ins, pcn, prog) case = ret then icode-ret (ins, pcn, prog) case = locn then icode-locn (ins, pcn, prog) case = push-constant then icode-push-constant (ins, pcn, prog) case = push-local then icode-push-local (ins, pcn, prog) case = push-global then icode-push-global (ins, pcn, prog) case = push-ctrl-stk-free-size then icode-push-ctrl-stk-free-size (ins, pcn, prog) case = push-temp-stk-free-size then icode-push-temp-stk-free-size (ins, pcn, prog) case = push-temp-stk-index then icode-push-temp-stk-index (ins, pcn, prog) case = jump-if-temp-stk-full then icode-jump-if-temp-stk-full (ins, pcn, prog) case = jump-if-temp-stk-empty then icode-jump-if-temp-stk-empty (ins, pcn, prog) case = pop then icode-pop (ins, pcn, prog) case = pop* then icode-pop* (ins, pcn, prog) case = popn then icode-popn (ins, pcn, prog) case = pop-local then icode-pop-local (ins, pcn, prog) case = pop-global then icode-pop-global (ins, pcn, prog) case = pop-locn then icode-pop-locn (ins, pcn, prog) case = pop-call then icode-pop-call (ins, pcn, prog) case = fetch-temp-stk then icode-fetch-temp-stk (ins, pcn, prog) case = deposit-temp-stk then icode-deposit-temp-stk (ins, pcn, prog) case = jump then icode-jump (ins, pcn, prog) case = jump-case then icode-jump-case (ins, pcn, prog) case = pushj then icode-pushj (ins, pcn, prog) case = popj then icode-popj (ins, pcn, prog) case = set-local then icode-set-local (ins, pcn, prog) case = set-global then icode-set-global (ins, pcn, prog) case = test-nat-and-jump then icode-test-nat-and-jump (ins, pcn, prog) case = test-int-and-jump then icode-test-int-and-jump (ins, pcn, prog) case = test-bool-and-jump then icode-test-bool-and-jump (ins, pcn, prog) case = test-bitv-and-jump then icode-test-bitv-and-jump (ins, pcn, prog) case = no-op then icode-no-op (ins, pcn, prog) case = add-addr then icode-add-addr (ins, pcn, prog) case = sub-addr then icode-sub-addr (ins, pcn, prog) case = eq then icode-eq (ins, pcn, prog) case = lt-addr then icode-lt-addr (ins, pcn, prog) case = fetch then icode-fetch (ins, pcn, prog) case = deposit then icode-deposit (ins, pcn, prog) case = add-int then icode-add-int (ins, pcn, prog) case = add-int-with-carry then icode-add-int-with-carry (ins, pcn, prog) case = add1-int then icode-add1-int (ins, pcn, prog) case = sub-int then icode-sub-int (ins, pcn, prog) case = sub-int-with-carry then icode-sub-int-with-carry (ins, pcn, prog) case = sub1-int then icode-sub1-int (ins, pcn, prog) case = neg-int then icode-neg-int (ins, pcn, prog) case = lt-int then icode-lt-int (ins, pcn, prog) case = int-to-nat then icode-int-to-nat (ins, pcn, prog) case = add-nat then icode-add-nat (ins, pcn, prog) case = add-nat-with-carry then icode-add-nat-with-carry (ins, pcn, prog) case = add1-nat then icode-add1-nat (ins, pcn, prog) case = sub-nat then icode-sub-nat (ins, pcn, prog) case = sub-nat-with-carry then icode-sub-nat-with-carry (ins, pcn, prog) case = sub1-nat then icode-sub1-nat (ins, pcn, prog) case = lt-nat then icode-lt-nat (ins, pcn, prog) case = mult2-nat then icode-mult2-nat (ins, pcn, prog) case = mult2-nat-with-carry-out then icode-mult2-nat-with-carry-out (ins, pcn, prog) case = div2-nat then icode-div2-nat (ins, pcn, prog) case = or-bitv then icode-or-bitv (ins, pcn, prog) case = and-bitv then icode-and-bitv (ins, pcn, prog) case = not-bitv then icode-not-bitv (ins, pcn, prog) case = xor-bitv then icode-xor-bitv (ins, pcn, prog) case = rsh-bitv then icode-rsh-bitv (ins, pcn, prog) case = lsh-bitv then icode-lsh-bitv (ins, pcn, prog) case = or-bool then icode-or-bool (ins, pcn, prog) case = and-bool then icode-and-bool (ins, pcn, prog) case = not-bool then icode-not-bool (ins, pcn, prog) otherwise '((error)) endcase

; 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.

Definition: dl-block (lab, comment, block) = cons (dl (lab, comment, car (block)), cdr (block))

Definition: 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.

Definition: icompile-program-body (lst, pcn, program) = if lst ≃ nil then nil

else append (icode (car (lst), pcn, program), icompile-program-body (cdr (lst), 1 + pcn, program)) endif

; To icompile a program we sandwich the icompiled body between the prelude
; and postlude.

Definition: 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.

Definition: icompile (programs) = if programs ≃ nil then nil

else cons (icompile-program (car (programs)), icompile (cdr (programs))) endif

; 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.

Definition: proper-p-call-instructionp (ins, name, p) = ((length (ins) = 2) ∧ definedp (cadr (ins), p-prog-segment (p)))

Definition: proper-p-ret-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-locn-instructionp (ins, name, p) = ((length (ins) = 2)

∧ (cadr (ins) ∈ local-vars (definition (name, p-prog-segment (p)))))

Definition: proper-p-push-constant-instructionp (ins, name, p) = ((length (ins) = 2)

∧ (p-objectp (cadr (ins), p) ∨ (cadr (ins) = 'pc) ∨ find-labelp (cadr (ins),

program-body (definition (name, p-prog-segment (p))))))

Definition: proper-p-push-local-instructionp (ins, name, p) = ((length (ins) = 2)

∧ (cadr (ins) ∈ local-vars (definition (name, p-prog-segment (p)))))

Definition: proper-p-push-global-instructionp (ins, name, p) = ((length (ins) = 2) ∧ definedp (cadr (ins), p-data-segment (p)))

Definition: proper-p-push-ctrl-stk-free-size-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-push-temp-stk-free-size-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-push-temp-stk-index-instructionp (ins, name, p) = ((length (ins) = 2) ∧ small-naturalp (cadr (ins), p-word-size (p)))

Definition: proper-p-jump-if-temp-stk-full-instructionp (ins, name, p) = ((length (ins) = 2)

∧ find-labelp (cadr (ins), program-body (definition (name, p-prog-segment (p)))))

Definition: proper-p-jump-if-temp-stk-empty-instructionp (ins, name, p) = ((length (ins) = 2)

∧ find-labelp (cadr (ins), program-body (definition (name, p-prog-segment (p)))))

Definition: proper-p-pop-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-pop*-instructionp (ins, name, p) = ((length (ins) = 2) ∧ small-naturalp (cadr (ins), p-word-size (p)))

Definition: proper-p-popn-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-pop-local-instructionp (ins, name, p) = ((length (ins) = 2)

∧ (cadr (ins) ∈ local-vars (definition (name, p-prog-segment (p)))))

Definition: proper-p-pop-global-instructionp (ins, name, p) = ((length (ins) = 2) ∧ definedp (cadr (ins), p-data-segment (p)))

Definition: proper-p-pop-locn-instructionp (ins, name, p) = ((length (ins) = 2)

∧ (cadr (ins) ∈ local-vars (definition (name, p-prog-segment (p)))))

Definition: proper-p-pop-call-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-fetch-temp-stk-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-deposit-temp-stk-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-jump-instructionp (ins, name, p) = ((length (ins) = 2)

∧ find-labelp (cadr (ins), program-body (definition (name, p-prog-segment (p)))))

Definition: proper-p-jump-case-instructionp (ins, name, p) = (listp (cdr (ins))

∧ all-find-labelp (cdr (ins),

program-body (definition (name, p-prog-segment (p)))))

Definition: proper-p-pushj-instructionp (ins, name, p) = ((length (ins) = 2)

∧ find-labelp (cadr (ins), program-body (definition (name, p-prog-segment (p)))))

Definition: proper-p-popj-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-set-local-instructionp (ins, name, p) = ((length (ins) = 2)

∧ (cadr (ins) ∈ local-vars (definition (name, p-prog-segment (p)))))

Definition: proper-p-set-global-instructionp (ins, name, p) = ((length (ins) = 2) ∧ definedp (cadr (ins), p-data-segment (p)))

Definition: proper-p-test-nat-and-jump-instructionp (ins, name, p) = ((length (ins) = 3)

∧ find-labelp (caddr (ins), program-body (definition (name, p-prog-segment (p)))))

Definition: proper-p-test-int-and-jump-instructionp (ins, name, p) = ((length (ins) = 3)

∧ find-labelp (caddr (ins), program-body (definition (name, p-prog-segment (p)))))

Definition: proper-p-test-bool-and-jump-instructionp (ins, name, p) = ((length (ins) = 3)

∧ find-labelp (caddr (ins), program-body (definition (name, p-prog-segment (p)))))

Definition: proper-p-test-bitv-and-jump-instructionp (ins, name, p) = ((length (ins) = 3)

∧ find-labelp (caddr (ins), program-body (definition (name, p-prog-segment (p)))))

Definition: proper-p-no-op-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-add-addr-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-sub-addr-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-eq-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-lt-addr-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-fetch-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-deposit-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-add-int-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-add-int-with-carry-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-add1-int-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-sub-int-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-sub-int-with-carry-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-sub1-int-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-neg-int-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-lt-int-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-int-to-nat-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-add-nat-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-add-nat-with-carry-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-add1-nat-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-sub-nat-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-sub-nat-with-carry-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-sub1-nat-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-lt-nat-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-mult2-nat-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-mult2-nat-with-carry-out-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-div2-nat-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-or-bitv-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-and-bitv-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-not-bitv-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-xor-bitv-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-rsh-bitv-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-lsh-bitv-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-or-bool-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-and-bool-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-not-bool-instructionp (ins, name, p) = (length (ins) = 1)

Definition: proper-p-instructionp (ins, name, p) = (plistp (ins)

∧ case on car (ins): case = call then proper-p-call-instructionp (ins, name, p) case = ret then proper-p-ret-instructionp (ins, name, p) case = locn then proper-p-locn-instructionp (ins, name, p) case = push-constant then proper-p-push-constant-instructionp (ins, name, p) case = push-local then proper-p-push-local-instructionp (ins, name, p) case = push-global then proper-p-push-global-instructionp (ins, name, p) case = push-ctrl-stk-free-size then proper-p-push-ctrl-stk-free-size-instructionp (ins,

name, p)

case = push-temp-stk-free-size then proper-p-push-temp-stk-free-size-instructionp (ins,

name, p)

case = push-temp-stk-index then proper-p-push-temp-stk-index-instructionp (ins, name, p) case = jump-if-temp-stk-full then proper-p-jump-if-temp-stk-full-instructionp (ins, name, p) case = jump-if-temp-stk-empty then proper-p-jump-if-temp-stk-empty-instructionp (ins,

name, p)

case = pop then proper-p-pop-instructionp (ins, name, p) case = pop* then proper-p-pop*-instructionp (ins, name, p) case = popn then proper-p-popn-instructionp (ins, name, p) case = pop-local then proper-p-pop-local-instructionp (ins, name, p) case = pop-global then proper-p-pop-global-instructionp (ins, name, p) case = pop-locn then proper-p-pop-locn-instructionp (ins, name, p) case = pop-call then proper-p-pop-call-instructionp (ins, name, p) case = fetch-temp-stk then proper-p-fetch-temp-stk-instructionp (ins, name, p) case = deposit-temp-stk then proper-p-deposit-temp-stk-instructionp (ins, name, p) case = jump then proper-p-jump-instructionp (ins, name, p) case = jump-case then proper-p-jump-case-instructionp (ins, name, p) case = pushj then proper-p-pushj-instructionp (ins, name, p) case = popj then proper-p-popj-instructionp (ins, name, p) case = set-local then proper-p-set-local-instructionp (ins, name, p) case = set-global then proper-p-set-global-instructionp (ins, name, p) case = test-nat-and-jump then proper-p-test-nat-and-jump-instructionp (ins, name, p) case = test-int-and-jump then proper-p-test-int-and-jump-instructionp (ins, name, p) case = test-bool-and-jump then proper-p-test-bool-and-jump-instructionp (ins, name, p) case = test-bitv-and-jump then proper-p-test-bitv-and-jump-instructionp (ins, name, p) case = no-op then proper-p-no-op-instructionp (ins, name, p) case = add-addr then proper-p-add-addr-instructionp (ins, name, p) case = sub-addr then proper-p-sub-addr-instructionp (ins, name, p) case = eq then proper-p-eq-instructionp (ins, name, p) case = lt-addr then proper-p-lt-addr-instructionp (ins, name, p) case = fetch then proper-p-fetch-instructionp (ins, name, p) case = deposit then proper-p-deposit-instructionp (ins, name, p) case = add-int then proper-p-add-int-instructionp (ins, name, p) case = add-int-with-carry then proper-p-add-int-with-carry-instructionp (ins, name, p) case = add1-int then proper-p-add1-int-instructionp (ins, name, p) case = sub-int then proper-p-sub-int-instructionp (ins, name, p) case = sub-int-with-carry then proper-p-sub-int-with-carry-instructionp (ins, name, p) case = sub1-int then proper-p-sub1-int-instructionp (ins, name, p) case = neg-int then proper-p-neg-int-instructionp (ins, name, p) case = lt-int then proper-p-lt-int-instructionp (ins, name, p) case = int-to-nat then proper-p-int-to-nat-instructionp (ins, name, p) case = add-nat then proper-p-add-nat-instructionp (ins, name, p) case = add-nat-with-carry then proper-p-add-nat-with-carry-instructionp (ins, name, p) case = add1-nat then proper-p-add1-nat-instructionp (ins, name, p) case = sub-nat then proper-p-sub-nat-instructionp (ins, name, p) case = sub-nat-with-carry then proper-p-sub-nat-with-carry-instructionp (ins, name, p) case = sub1-nat then proper-p-sub1-nat-instructionp (ins, name, p) case = lt-nat then proper-p-lt-nat-instructionp (ins, name, p) case = mult2-nat then proper-p-mult2-nat-instructionp (ins, name, p) case = mult2-nat-with-carry-out then proper-p-mult2-nat-with-carry-out-instructionp (ins,

name, p)

case = div2-nat then proper-p-div2-nat-instructionp (ins, name, p) case = or-bitv then proper-p-or-bitv-instructionp (ins, name, p) case = and-bitv then proper-p-and-bitv-instructionp (ins, name, p) case = not-bitv then proper-p-not-bitv-instructionp (ins, name, p) case = xor-bitv then proper-p-xor-bitv-instructionp (ins, name, p) case = rsh-bitv then proper-p-rsh-bitv-instructionp (ins, name, p) case = lsh-bitv then proper-p-lsh-bitv-instructionp (ins, name, p) case = or-bool then proper-p-or-bool-instructionp (ins, name, p) case = and-bool then proper-p-and-bool-instructionp (ins, name, p) case = not-bool then proper-p-not-bool-instructionp (ins, name, p) otherwise f endcase)

Definition: legal-labelp (ins) = (labelledp (ins) → litatom (cadr (ins)))

; The following predicate recognizes lists of properly labeled
; proper instructions.

Definition: proper-labeled-p-instructionsp (lst, name, p) = if lst ≃ nil then lst = nil

else legal-labelp (car (lst))

∧ proper-p-instructionp (unlabel (car (lst)), name, p)

∧ proper-labeled-p-instructionsp (cdr (lst), name, p) endif

; 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.

Definition: fall-off-proofp (lst) = (car (unlabel (get (length (lst) − 1, lst)))

    ∈ '(ret jump jump-case popj))

Definition: proper-p-program-bodyp (lst, name, p) = (listp (lst)

∧ proper-labeled-p-instructionsp (lst, name, p)

∧ fall-off-proofp (lst))

Definition: all-litatoms (lst) = if lst ≃ nil then lst = nil

else litatom (car (lst)) ∧ all-litatoms (cdr (lst)) endif

Definition: proper-p-temp-var-dclsp (temp-var-dcls, p) = if temp-var-dcls ≃ nil then t

else litatom (car (car (temp-var-dcls)))

∧ p-objectp (cadr (car (temp-var-dcls)), p)

∧ proper-p-temp-var-dclsp (cdr (temp-var-dcls), p) endif Definition: proper-p-programp (prog, p) = (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))

Definition: proper-p-prog-segmentp (segment, p) = if segment ≃ nil then segment = nil

else proper-p-programp (car (segment), p) ∧ proper-p-prog-segmentp (cdr (segment), p) endif

Definition: proper-p-alistp (alist, p) = if alist ≃ nil then alist = nil

else listp (car (alist))

∧ litatom (caar (alist))

∧ p-objectp (cdr (car (alist)), p)

∧ proper-p-alistp (cdr (alist), p) endif

Definition: proper-p-framep (frame, name, p) = (listp (frame)

∧ listp (cdr (frame)) ∧ (cddr (frame) = nil) ∧ proper-p-alistp (bindings (frame), p) ∧ (strip-cars (bindings (frame))

= local-vars (definition (name, p-prog-segment (p)))) ∧ p-objectp-type ('pc, ret-pc (frame), p))

Definition: proper-p-ctrl-stkp (ctrl-stk, name, p) = if ctrl-stk ≃ nil then ctrl-stk = nil

else proper-p-framep (top (ctrl-stk), name, p) ∧ proper-p-ctrl-stkp (pop (ctrl-stk),

area-name (ret-pc (top (ctrl-stk))),

p) endif

Definition: proper-p-temp-stkp (temp-stk, p) = if temp-stk ≃ nil then temp-stk = nil

else p-objectp (top (temp-stk), p)

∧ proper-p-temp-stkp (pop (temp-stk), p) endif Definition: proper-p-area (area, p) = (litatom (car (area))

∧ listp (cdr (area))

∧ all-p-objectps (cdr (area), p))

Definition: proper-p-data-segmentp (data-segment, p) = if data-segment ≃ nil then data-segment = nil

else proper-p-area (car (data-segment), p) ∧ (¬ definedp (caar (data-segment), cdr (data-segment))) ∧ proper-p-data-segmentp (cdr (data-segment), p) endif

; 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.

Definition: proper-p-statep (p) = (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)

∧ (p-max-ctrl-stk-size (p) ≮ p-ctrl-stk-size (p-ctrl-stk (p))) ∧ proper-p-temp-stkp (p-temp-stk (p), p) ∧ (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) ∧ (p-max-ctrl-stk-size (p) ∈ N) ∧ (p-max-temp-stk-size (p) ∈ N) ∧ (p-word-size (p) ∈ N) ∧ (p-max-ctrl-stk-size (p) < exp (2, p-word-size (p))) ∧ (p-max-temp-stk-size (p) < exp (2, p-word-size (p))) ∧ (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.

Definition: segment-length (segment) = if segment ≃ nil then 0

else length (cdr (car (segment))) + segment-length (cdr (segment)) endif

Definition: total-p-system-size (p) = (segment-length (icompile (p-prog-segment (p)))

+ segment-length (p-data-segment (p)) + (1 + p-max-ctrl-stk-size (p)) + (1 + p-max-temp-stk-size (p)) + 3)

Definition: p-loadablep (p) = (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.

Definition: 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))))

Definition: 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))))

Definition: 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))
|#

Definition: signature (area) = cons (car (area), length (area))

Definition: same-signature (segment1 , segment2 ) = if listp (segment1 )

then listp (segment2 )

∧ (signature (car (segment1 )) = signature (car (segment2 ))) ∧ same-signature (cdr (segment1 ), cdr (segment2 ))

else segment2 ≃ nil endif

;; ***** 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.

Theorem: type-tag type (tag (x, y)) = x

Theorem: untag-tag untag (tag (x, y)) = y

Theorem: equal-tags (tag (type, x) = tag (type, y)) = (x = y)

Theorem: cddr-tag cddr (tag (type, obj )) = nil Event: Disable type.

Event: Disable tag.

Event: Disable untag.

; Error messages are irrelevant as long as they are not 'run or 'halt.

Theorem: not-equal-x-y-error-msg-run x-y-error-msg (x, y) ≠ 'run

Theorem: not-equal-x-y-error-msg-halt x-y-error-msg (x, y) ≠ 'halt

Event: Disable x-y-error-msg.

Theorem: p-objectp-opener ((type (x) = 'nat) → (p-objectp (x, p)

= ((cddr (x) = nil)

∧ small-naturalp (untag (x), p-word-size (p)))))

∧ ((type (x) = 'int)

→ (p-objectp (x, p)

= ((cddr (x) = nil)

∧ small-integerp (untag (x), p-word-size (p)))))

∧ ((type (x) = 'bitv)

→ (p-objectp (x, p)

= ((cddr (x) = nil)

∧ bit-vectorp (untag (x), p-word-size (p)))))

∧ ((type (x) = 'bool)

→ (p-objectp (x, p)

= ((cddr (x) = nil) ∧ booleanp (untag (x)))))

∧ ((type (x) = 'addr)

→ (p-objectp (x, p)

= ((cddr (x) = nil)

∧ adpp (untag (x), p-data-segment (p)))))

∧ ((type (x) = 'pc)

→ (p-objectp (x, p)

= ((cddr (x) = nil)

∧ pcpp (untag (x), p-prog-segment (p)))))

∧ ((type (x) = 'subr)

→ (p-objectp (x, p)

= ((cddr (x) = nil)

∧ definedp (untag (x), p-prog-segment (p)))))

Event: Disable p-objectp. Event: Disable name. Event: Disable formal-vars. Event: Disable temp-var-dcls. Event: Disable program-body. Theorem: bindings-p-frame bindings (p-frame (alist, pc)) = alist Theorem: ret-pc-p-frame ret-pc (p-frame (alist, pc)) = pc Event: Disable bindings. Event: Disable ret-pc. Event: Disable p-frame. Event: Disable proper-p-instructionp. Event: Disable legal-labelp. Theorem: proper-labeled-p-instructionsp-implies-labelp-and-instructionp (proper-labeled-p-instructionsp (lst, name, p) ∧ (x ∈ lst)) → (legal-labelp (x) ∧ proper-p-instructionp (unlabel (x), name, p)) Theorem: proper-p-prog-segmentp-implies-proper-p-programp (proper-p-prog-segmentp (segment, p) ∧ (prog ∈ segment)) → proper-p-programp (prog, p)

; Added disable to speed up proof, AF

Theorem: member-assoc definedp (name, alist) → (assoc (name, alist) ∈ alist)

Theorem: name-assoc definedp (name, alist) → (name (assoc (name, alist)) = name)

Theorem: member-get (n < length (lst)) → (get (n, lst) ∈ lst)

Theorem: proper-p-statep-implies-proper-p-instructionp (proper-p-prog-segmentp (p-prog-segment (p), p) ∧ definedp (car (untag (p-pc (p))), p-prog-segment (p)) ∧ (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)

; 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.

Event: Disable p-loadablep.

Definition: proper-p-statep1 (p) = (p-statep (p)

∧ (type (p-pc (p)) = 'pc)

∧ listp (p-pc (p))

∧ (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)))) ∧ (cddr (car (p-ctrl-stk (p))) = nil) ∧ proper-p-alistp (bindings (car (p-ctrl-stk (p))), p) ∧ (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))))))

∧ (type (ret-pc (car (p-ctrl-stk (p)))) = 'pc) ∧ listp (ret-pc (car (p-ctrl-stk (p)))) ∧ (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))

Theorem: proper-p-statep-restructuring proper-p-statep (p) = (proper-p-statep1 (p)

∧ (cdr (untag (p-pc (p))) ∈ N) ∧ (cdr (untag (p-pc (p)))

< length (program-body (assoc (car (untag (p-pc (p))),

p-prog-segment (p)))))

∧ (cdr (untag (ret-pc (car (p-ctrl-stk (p))))) ∈ N) ∧ (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)))))

∧ (p-max-ctrl-stk-size (p) ≮ p-ctrl-stk-size (p-ctrl-stk (p))) ∧ (p-max-temp-stk-size (p) ≮ length (p-temp-stk (p))) ∧ (p-max-ctrl-stk-size (p) ∈ N) ∧ (p-max-temp-stk-size (p) ∈ N) ∧ (p-word-size (p) ∈ N) ∧ (p-max-ctrl-stk-size (p) < exp (2, p-word-size (p))) ∧ (p-max-temp-stk-size (p) < exp (2, p-word-size (p))) ∧ (0 < p-word-size (p)) ∧ proper-p-instructionp (p-current-instruction (p),

car (untag (p-pc (p))), p))

Theorem: proper-p-statep1-properties proper-p-statep1 (p) → (p-statep (p)

∧ (type (p-pc (p)) = 'pc) ∧ listp (p-pc (p)) ∧ (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)))) ∧ (cddr (car (p-ctrl-stk (p))) = nil) ∧ proper-p-alistp (bindings (car (p-ctrl-stk (p))), p) ∧ (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))))))

∧ (type (ret-pc (car (p-ctrl-stk (p)))) = 'pc) ∧ listp (ret-pc (car (p-ctrl-stk (p)))) ∧ (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))

Event: Disable proper-p-statep.

Event: Disable proper-p-statep1.

Event: Disable p-current-instruction.

; Now I provide a simple delayed opener for proper-p-instructionp:

Theorem: proper-p-instructionp-opener (car (ins) = pack (xxx)) → (proper-p-instructionp (ins, name, p)

= (plistp (ins)

∧ case on car (ins): case = call then proper-p-call-instructionp (ins, name, p) case = ret then proper-p-ret-instructionp (ins, name, p) case = locn then proper-p-locn-instructionp (ins, name, p) case = push-constant then proper-p-push-constant-instructionp (ins, name, p) case = push-local then proper-p-push-local-instructionp (ins, name, p) case = push-global then proper-p-push-global-instructionp (ins, name, p) case = push-ctrl-stk-free-size then proper-p-push-ctrl-stk-free-size-instructionp (ins,

name, p)

case = push-temp-stk-free-size then proper-p-push-temp-stk-free-size-instructionp (ins,

name, p)

case = push-temp-stk-index then proper-p-push-temp-stk-index-instructionp (ins,

name, p)

case = jump-if-temp-stk-full then proper-p-jump-if-temp-stk-full-instructionp (ins,

name, p)

case = jump-if-temp-stk-empty then proper-p-jump-if-temp-stk-empty-instructionp (ins,

name, p)

case = pop then proper-p-pop-instructionp (ins, name, p) case = pop* then proper-p-pop*-instructionp (ins, name, p) case = popn then proper-p-popn-instructionp (ins, name, p) case = pop-local then proper-p-pop-local-instructionp (ins, name, p) case = pop-global then proper-p-pop-global-instructionp (ins, name, p) case = pop-locn then proper-p-pop-locn-instructionp (ins, name, p) case = pop-call then proper-p-pop-call-instructionp (ins, name, p) case = fetch-temp-stk then proper-p-fetch-temp-stk-instructionp (ins, name, p)

case = deposit-temp-stk then proper-p-deposit-temp-stk-instructionp (ins,

name, p)

case = jump then proper-p-jump-instructionp (ins, name, p) case = jump-case then proper-p-jump-case-instructionp (ins, name, p) case = pushj then proper-p-pushj-instructionp (ins, name, p) case = popj then proper-p-popj-instructionp (ins, name, p) case = set-local then proper-p-set-local-instructionp (ins, name, p) case = set-global then proper-p-set-global-instructionp (ins, name, p) case = test-nat-and-jump then proper-p-test-nat-and-jump-instructionp (ins,

name, p)

case = test-int-and-jump then proper-p-test-int-and-jump-instructionp (ins,

name, p)

case = test-bool-and-jump then proper-p-test-bool-and-jump-instructionp (ins,

name, p)

case = test-bitv-and-jump then proper-p-test-bitv-and-jump-instructionp (ins,

name, p)

case = no-op then proper-p-no-op-instructionp (ins, name, p) case = add-addr then proper-p-add-addr-instructionp (ins, name, p) case = sub-addr then proper-p-sub-addr-instructionp (ins, name, p) case = eq then proper-p-eq-instructionp (ins, name, p) case = lt-addr then proper-p-lt-addr-instructionp (ins, name, p) case = fetch then proper-p-fetch-instructionp (ins, name, p) case = deposit then proper-p-deposit-instructionp (ins, name, p) case = add-int then proper-p-add-int-instructionp (ins, name, p) case = add-int-with-carry then proper-p-add-int-with-carry-instructionp (ins,

name, p)

case = add1-int then proper-p-add1-int-instructionp (ins, name, p) case = sub-int then proper-p-sub-int-instructionp (ins, name, p) case = sub-int-with-carry then proper-p-sub-int-with-carry-instructionp (ins,

name, p)

case = sub1-int then proper-p-sub1-int-instructionp (ins, name, p) case = neg-int then proper-p-neg-int-instructionp (ins, name, p) case = lt-int then proper-p-lt-int-instructionp (ins, name, p) case = int-to-nat then proper-p-int-to-nat-instructionp (ins, name, p) case = add-nat then proper-p-add-nat-instructionp (ins, name, p) case = add-nat-with-carry then proper-p-add-nat-with-carry-instructionp (ins,

name, p)

case = add1-nat then proper-p-add1-nat-instructionp (ins, name, p) case = sub-nat then proper-p-sub-nat-instructionp (ins, name, p) case = sub-nat-with-carry then proper-p-sub-nat-with-carry-instructionp (ins,

name, p)

case = sub1-nat then proper-p-sub1-nat-instructionp (ins, name, p) case = lt-nat then proper-p-lt-nat-instructionp (ins, name, p) case = mult2-nat then proper-p-mult2-nat-instructionp (ins, name, p) case = mult2-nat-with-carry-out then proper-p-mult2-nat-with-carry-out-instructionp (ins,

name, p)

case = div2-nat then proper-p-div2-nat-instructionp (ins, name, p) case = or-bitv then proper-p-or-bitv-instructionp (ins, name, p) case = and-bitv then proper-p-and-bitv-instructionp (ins, name, p) case = not-bitv then proper-p-not-bitv-instructionp (ins, name, p) case = xor-bitv then proper-p-xor-bitv-instructionp (ins, name, p) case = rsh-bitv then proper-p-rsh-bitv-instructionp (ins, name, p) case = lsh-bitv then proper-p-lsh-bitv-instructionp (ins, name, p) case = or-bool then proper-p-or-bool-instructionp (ins, name, p) case = and-bool then proper-p-and-bool-instructionp (ins, name, p) case = not-bool then proper-p-not-bool-instructionp (ins, name, p) otherwise f endcase))

Theorem: length-put-assoc length (put-assoc (val, name, alist)) = length (alist)

Theorem: assoc-put-assoc-1 (name1 ≠ name2 ) → (assoc (name1 , put-assoc (val, name2 , alist)) = assoc (name1 , alist))

Theorem: assoc-put-assoc-2 definedp (name, alist) → (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

Theorem: same-signature-put-assoc-1 (litatom (name) ∧ (length (val) = length (value (name, segment1 )))) → (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

Theorem: same-signature-put-assoc-2 (litatom (name) ∧ (length (val) = length (value (name, segment2 )))) → (same-signature (segment1 , put-assoc (val, name, segment2 ))

= same-signature (segment1 , segment2 ))

Event: Disable same-signature.

; Now I want to disable get and put so that they are only manipulated by
; the lemmas we have proved.

Event: Disable get.

Event: Disable put.

Theorem: length-first-n length (first-n (n, x)) = fix (n)

Theorem: same-signature-implies-equal-lengths same-signature (segment1 , segment2 ) → (length (cdr (assoc (name, segment1 )))

= length (cdr (assoc (name, segment2 ))))

Theorem: same-signature-implies-equal-definedp same-signature (segment1 , segment2 ) → (definedp (name, segment1 ) = definedp (name, segment2 ))

Theorem: same-signature-reflexive-generalized same-signature (segment, segment)

Theorem: definedp-put-assoc definedp (name1 , put-assoc (val, name2 , alist)) = definedp (name1 , alist)

Theorem: p-objectp-type-opener (p-objectp-type ('nat, x, p) = ((type (x) = 'nat)

∧ (cddr (x) = nil)

∧ small-naturalp (untag (x), p-word-size (p)))) ∧ (p-objectp-type ('int, x, p)

= ((type (x) = 'int) ∧ (cddr (x) = nil)

∧ small-integerp (untag (x), p-word-size (p))))

∧ (p-objectp-type ('bitv, x, p)

= ((type (x) = 'bitv) ∧ (cddr (x) = nil) ∧ bit-vectorp (untag (x), p-word-size (p))))

∧ (p-objectp-type ('bool, x, p)

= ((type (x) = 'bool) ∧ (cddr (x) = nil) ∧ booleanp (untag (x))))

∧ (p-objectp-type ('addr, x, p)

= ((type (x) = 'addr) ∧ (cddr (x) = nil) ∧ adpp (untag (x), p-data-segment (p))))

∧ (p-objectp-type ('pc, x, p)

= ((type (x) = 'pc) ∧ (cddr (x) = nil) ∧ pcpp (untag (x), p-prog-segment (p))))

∧ (p-objectp-type ('subr, x, p)

= ((type (x) = 'subr) ∧ (cddr (x) = nil) ∧ definedp (untag (x), p-prog-segment (p))))

Event: Disable p-objectp-type.

;; This is from Piton but with PROPERP instead of PLISTP

Theorem: proper-p-alistp-append plistp (a) → (proper-p-alistp (append (a, b), p)

= (proper-p-alistp (a, p) ∧ proper-p-alistp (b, p)))

Theorem: strip-cars-put-assoc 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:

Theorem: proper-p-alistp-pairlist (all-litatoms (formals) ∧ all-p-objectps (actuals, p) ∧ (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:

Theorem: all-litatoms-formal-vars-generalized (proper-p-prog-segmentp (segment, p) ∧ definedp (name, segment)) → all-litatoms (formal-vars (assoc (name, segment)))

Theorem: all-litatoms-formal-vars (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))))

; 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:

Theorem: proper-p-prog-segmentp-implies-proper-p-temp-var-dclsp (proper-p-prog-segmentp (segment, p) ∧ definedp (name, segment)) → proper-p-temp-var-dclsp (temp-var-dcls (assoc (name, segment)), p)

Theorem: proper-p-alistp-pair-temps-with-initial-values proper-p-temp-var-dclsp (var-dcls, p) → proper-p-alistp (pair-temps-with-initial-values (var-dcls), p)

Event: Disable p-call-okp.

Event: Disable p-call-step.

Event: Disable p-ret-okp.

Event: Disable p-ret-step.

Event: Disable p-locn-okp.

Event: Disable p-locn-step.

Event: Disable p-push-constant-okp.

Event: Disable p-push-constant-step. Event: Disable p-push-local-okp. Event: Disable p-push-local-step. Event: Disable p-push-global-okp. Event: Disable p-push-global-step. Event: Disable p-push-ctrl-stk-free-size-okp. Event: Disable p-push-ctrl-stk-free-size-step. Event: Disable p-push-temp-stk-free-size-okp. Event: Disable p-push-temp-stk-free-size-step. Event: Disable p-push-temp-stk-index-okp. Event: Disable p-push-temp-stk-index-step. Event: Disable p-jump-if-temp-stk-full-okp. Event: Disable p-jump-if-temp-stk-full-step. Event: Disable p-jump-if-temp-stk-empty-okp. Event: Disable p-jump-if-temp-stk-empty-step. Event: Disable p-pop-okp. Event: Disable p-pop-step. Event: Disable p-pop*-okp.

Event: Disable p-pop*-step. Event: Disable p-popn-okp. Event: Disable p-popn-step. Event: Disable p-pop-local-okp. Event: Disable p-pop-local-step. Event: Disable p-pop-global-okp. Event: Disable p-pop-global-step. Event: Disable p-pop-locn-okp. Event: Disable p-pop-locn-step. Event: Disable p-pop-call-okp. Event: Disable p-pop-call-step. Event: Disable p-fetch-temp-stk-okp. Event: Disable p-fetch-temp-stk-step. Event: Disable p-deposit-temp-stk-okp. Event: Disable p-deposit-temp-stk-step. Event: Disable p-jump-okp. Event: Disable p-jump-step. Event: Disable p-jump-case-okp.

Event: Disable p-jump-case-step. Event: Disable p-pushj-okp. Event: Disable p-pushj-step. Event: Disable p-popj-okp. Event: Disable p-popj-step. Event: Disable p-set-local-okp. Event: Disable p-set-local-step. Event: Disable p-set-global-okp. Event: Disable p-set-global-step. Event: Disable p-test-nat-and-jump-okp. Event: Disable p-test-nat-and-jump-step. Event: Disable p-test-int-and-jump-okp. Event: Disable p-test-int-and-jump-step. Event: Disable p-test-bool-and-jump-okp. Event: Disable p-test-bool-and-jump-step. Event: Disable p-test-bitv-and-jump-okp. Event: Disable p-test-bitv-and-jump-step. Event: Disable p-no-op-okp.

Event: Disable p-no-op-step. Event: Disable p-add-addr-okp. Event: Disable p-add-addr-step. Event: Disable p-sub-addr-okp. Event: Disable p-sub-addr-step. Event: Disable p-eq-okp. Event: Disable p-eq-step. Event: Disable p-lt-addr-okp. Event: Disable p-lt-addr-step. Event: Disable p-fetch-okp. Event: Disable p-fetch-step. Event: Disable p-deposit-okp. Event: Disable p-deposit-step. Event: Disable p-add-int-okp. Event: Disable p-add-int-step. Event: Disable p-add-int-with-carry-okp. Event: Disable p-add-int-with-carry-step. Event: Disable p-add1-int-okp.

Event: Disable p-add1-int-step. Event: Disable p-sub-int-okp. Event: Disable p-sub-int-step. Event: Disable p-sub-int-with-carry-okp. Event: Disable p-sub-int-with-carry-step. Event: Disable p-sub1-int-okp. Event: Disable p-sub1-int-step. Event: Disable p-neg-int-okp. Event: Disable p-neg-int-step. Event: Disable p-lt-int-okp. Event: Disable p-lt-int-step. Event: Disable p-int-to-nat-okp. Event: Disable p-int-to-nat-step. Event: Disable p-add-nat-okp. Event: Disable p-add-nat-step. Event: Disable p-add-nat-with-carry-okp. Event: Disable p-add-nat-with-carry-step. Event: Disable p-add1-nat-okp.

Event: Disable p-add1-nat-step. Event: Disable p-sub-nat-okp. Event: Disable p-sub-nat-step. Event: Disable p-sub-nat-with-carry-okp. Event: Disable p-sub-nat-with-carry-step. Event: Disable p-sub1-nat-okp. Event: Disable p-sub1-nat-step. Event: Disable p-lt-nat-okp. Event: Disable p-lt-nat-step. Event: Disable p-mult2-nat-okp. Event: Disable p-mult2-nat-step. Event: Disable p-mult2-nat-with-carry-out-okp. Event: Disable p-mult2-nat-with-carry-out-step. Event: Disable p-div2-nat-okp. Event: Disable p-div2-nat-step. Event: Disable p-or-bitv-okp. Event: Disable p-or-bitv-step. Event: Disable p-and-bitv-okp.

Event: Disable p-and-bitv-step. Event: Disable p-not-bitv-okp. Event: Disable p-not-bitv-step. Event: Disable p-xor-bitv-okp. Event: Disable p-xor-bitv-step. Event: Disable p-rsh-bitv-okp. Event: Disable p-rsh-bitv-step. Event: Disable p-lsh-bitv-okp. Event: Disable p-lsh-bitv-step. Event: Disable p-or-bool-okp. Event: Disable p-or-bool-step. Event: Disable p-and-bool-okp. Event: Disable p-and-bool-step. Event: Disable p-not-bool-okp. Event: Disable p-not-bool-step. Definition: p-ins-okp2 (ins, p) = case on car (ins):

case = eq

then p-eq-okp (ins, p)

case = lt-addr then p-lt-addr-okp (ins, p) case = fetch then p-fetch-okp (ins, p) case = deposit then p-deposit-okp (ins, p) case = add-int then p-add-int-okp (ins, p) case = add-int-with-carry then p-add-int-with-carry-okp (ins, p) case = add1-int then p-add1-int-okp (ins, p) case = sub-int then p-sub-int-okp (ins, p) case = sub-int-with-carry then p-sub-int-with-carry-okp (ins, p) case = sub1-int then p-sub1-int-okp (ins, p) case = neg-int then p-neg-int-okp (ins, p) case = lt-int then p-lt-int-okp (ins, p) case = int-to-nat then p-int-to-nat-okp (ins, p) case = add-nat then p-add-nat-okp (ins, p) case = add-nat-with-carry then p-add-nat-with-carry-okp (ins, p) case = add1-nat then p-add1-nat-okp (ins, p) case = sub-nat then p-sub-nat-okp (ins, p) case = sub-nat-with-carry then p-sub-nat-with-carry-okp (ins, p) case = sub1-nat then p-sub1-nat-okp (ins, p) case = lt-nat then p-lt-nat-okp (ins, p) case = mult2-nat then p-mult2-nat-okp (ins, p) case = mult2-nat-with-carry-out then p-mult2-nat-with-carry-out-okp (ins, p) case = div2-nat then p-div2-nat-okp (ins, p) case = or-bitv then p-or-bitv-okp (ins, p) case = and-bitv then p-and-bitv-okp (ins, p) case = not-bitv then p-not-bitv-okp (ins, p) case = xor-bitv then p-xor-bitv-okp (ins, p) case = rsh-bitv then p-rsh-bitv-okp (ins, p) case = lsh-bitv then p-lsh-bitv-okp (ins, p) case = or-bool then p-or-bool-okp (ins, p) case = and-bool then p-and-bool-okp (ins, p) case = not-bool then p-not-bool-okp (ins, p) otherwise f endcase

Definition: p-ins-okp1 (ins, p) = case on car (ins):

case = call then p-call-okp (ins, p) case = ret then p-ret-okp (ins, p) case = locn then p-locn-okp (ins, p) case = push-constant then p-push-constant-okp (ins, p) case = push-local then p-push-local-okp (ins, p) case = push-global then p-push-global-okp (ins, p) case = push-ctrl-stk-free-size then p-push-ctrl-stk-free-size-okp (ins, p) case = push-temp-stk-free-size then p-push-temp-stk-free-size-okp (ins, p) case = push-temp-stk-index then p-push-temp-stk-index-okp (ins, p) case = jump-if-temp-stk-full then p-jump-if-temp-stk-full-okp (ins, p) case = jump-if-temp-stk-empty then p-jump-if-temp-stk-empty-okp (ins, p) case = pop then p-pop-okp (ins, p) case = pop* then p-pop*-okp (ins, p) case = popn then p-popn-okp (ins, p) case = pop-local then p-pop-local-okp (ins, p) case = pop-global then p-pop-global-okp (ins, p) case = pop-locn then p-pop-locn-okp (ins, p) case = pop-call then p-pop-call-okp (ins, p) case = fetch-temp-stk then p-fetch-temp-stk-okp (ins, p) case = deposit-temp-stk then p-deposit-temp-stk-okp (ins, p) case = jump then p-jump-okp (ins, p) case = jump-case then p-jump-case-okp (ins, p) case = pushj then p-pushj-okp (ins, p) case = popj then p-popj-okp (ins, p) case = set-local then p-set-local-okp (ins, p) case = set-global then p-set-global-okp (ins, p) case = test-nat-and-jump then p-test-nat-and-jump-okp (ins, p) case = test-int-and-jump then p-test-int-and-jump-okp (ins, p) case = test-bool-and-jump then p-test-bool-and-jump-okp (ins, p) case = test-bitv-and-jump then p-test-bitv-and-jump-okp (ins, p) case = no-op then p-no-op-okp (ins, p) case = add-addr then p-add-addr-okp (ins, p) case = sub-addr then p-sub-addr-okp (ins, p)

otherwise p-ins-okp2 (ins, p) endcase

Theorem: p-ins-okp-is-p-ins-okp1 p-ins-okp (ins, p) = p-ins-okp1 (ins, p)

Event: Disable p-ins-okp.

Event: Disable p-ins-okp-is-p-ins-okp1.

Definition: p-ins-step2 (ins, p) = case on car (ins):

case = eq then p-eq-step (ins, p) case = lt-addr then p-lt-addr-step (ins, p) case = fetch then p-fetch-step (ins, p) case = deposit then p-deposit-step (ins, p) case = add-int then p-add-int-step (ins, p) case = add-int-with-carry then p-add-int-with-carry-step (ins, p) case = add1-int then p-add1-int-step (ins, p) case = sub-int then p-sub-int-step (ins, p) case = sub-int-with-carry then p-sub-int-with-carry-step (ins, p) case = sub1-int then p-sub1-int-step (ins, p) case = neg-int then p-neg-int-step (ins, p) case = lt-int then p-lt-int-step (ins, p) case = int-to-nat then p-int-to-nat-step (ins, p) case = add-nat then p-add-nat-step (ins, p) case = add-nat-with-carry then p-add-nat-with-carry-step (ins, p) case = add1-nat then p-add1-nat-step (ins, p) case = sub-nat then p-sub-nat-step (ins, p) case = sub-nat-with-carry then p-sub-nat-with-carry-step (ins, p) case = sub1-nat then p-sub1-nat-step (ins, p) case = lt-nat then p-lt-nat-step (ins, p) case = mult2-nat then p-mult2-nat-step (ins, p) case = mult2-nat-with-carry-out then p-mult2-nat-with-carry-out-step (ins, p) case = div2-nat then p-div2-nat-step (ins, p) case = or-bitv then p-or-bitv-step (ins, p) case = and-bitv then p-and-bitv-step (ins, p) case = not-bitv then p-not-bitv-step (ins, p) case = xor-bitv then p-xor-bitv-step (ins, p) case = rsh-bitv then p-rsh-bitv-step (ins, p) case = lsh-bitv then p-lsh-bitv-step (ins, p) case = or-bool then p-or-bool-step (ins, p) case = and-bool then p-and-bool-step (ins, p) case = not-bool then p-not-bool-step (ins, p) otherwise p-halt (p, 'run) endcase

Definition: p-ins-step1 (ins, p) = case on car (ins):

case = call then p-call-step (ins, p) case = ret then p-ret-step (ins, p) case = locn then p-locn-step (ins, p) case = push-constant then p-push-constant-step (ins, p) case = push-local then p-push-local-step (ins, p) case = push-global then p-push-global-step (ins, p) case = push-ctrl-stk-free-size then p-push-ctrl-stk-free-size-step (ins, p) case = push-temp-stk-free-size then p-push-temp-stk-free-size-step (ins, p) case = push-temp-stk-index then p-push-temp-stk-index-step (ins, p) case = jump-if-temp-stk-full then p-jump-if-temp-stk-full-step (ins, p) case = jump-if-temp-stk-empty then p-jump-if-temp-stk-empty-step (ins, p) case = pop then p-pop-step (ins, p) case = pop* then p-pop*-step (ins, p) case = popn then p-popn-step (ins, p) case = pop-local then p-pop-local-step (ins, p) case = pop-global then p-pop-global-step (ins, p) case = pop-locn then p-pop-locn-step (ins, p) case = pop-call then p-pop-call-step (ins, p) case = fetch-temp-stk then p-fetch-temp-stk-step (ins, p) case = deposit-temp-stk then p-deposit-temp-stk-step (ins, p) case = jump then p-jump-step (ins, p) case = jump-case then p-jump-case-step (ins, p) case = pushj then p-pushj-step (ins, p) case = popj then p-popj-step (ins, p) case = set-local then p-set-local-step (ins, p) case = set-global then p-set-global-step (ins, p) case = test-nat-and-jump then p-test-nat-and-jump-step (ins, p) case = test-int-and-jump then p-test-int-and-jump-step (ins, p) case = test-bool-and-jump then p-test-bool-and-jump-step (ins, p) case = test-bitv-and-jump then p-test-bitv-and-jump-step (ins, p) case = no-op then p-no-op-step (ins, p) case = add-addr then p-add-addr-step (ins, p) case = sub-addr then p-sub-addr-step (ins, p) otherwise p-ins-step2 (ins, p) endcase

Theorem: p-ins-step-is-p-ins-step1 p-ins-step (ins, p) = p-ins-step1 (ins, p)

Event: Disable p-ins-step.

Event: 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.

Theorem: p-ins-okp2-backchainer p-ins-okp2 (ins, p) → (((car (ins) = 'eq) → p-eq-okp (ins, p))

∧ ((car (ins) = 'lt-addr) → p-lt-addr-okp (ins, p)) ∧ ((car (ins) = 'fetch) → p-fetch-okp (ins, p)) ∧ ((car (ins) = 'deposit) → p-deposit-okp (ins, p)) ∧ ((car (ins) = 'add-int) → p-add-int-okp (ins, p))

∧ ((car (ins) = 'add-int-with-carry)

→ p-add-int-with-carry-okp (ins, p)) ∧ ((car (ins) = 'add1-int) → p-add1-int-okp (ins, p)) ∧ ((car (ins) = 'sub-int) → p-sub-int-okp (ins, p))

∧ ((car (ins) = 'sub-int-with-carry)

→ p-sub-int-with-carry-okp (ins, p)) ∧ ((car (ins) = 'sub1-int) → p-sub1-int-okp (ins, p)) ∧ ((car (ins) = 'neg-int) → p-neg-int-okp (ins, p)) ∧ ((car (ins) = 'lt-int) → p-lt-int-okp (ins, p)) ∧ ((car (ins) = 'int-to-nat) → p-int-to-nat-okp (ins, p)) ∧ ((car (ins) = 'add-nat) → p-add-nat-okp (ins, p))

∧ ((car (ins) = 'add-nat-with-carry)

→ p-add-nat-with-carry-okp (ins, p)) ∧ ((car (ins) = 'add1-nat) → p-add1-nat-okp (ins, p)) ∧ ((car (ins) = 'sub-nat) → p-sub-nat-okp (ins, p))

∧ ((car (ins) = 'sub-nat-with-carry)

→ p-sub-nat-with-carry-okp (ins, p)) ∧ ((car (ins) = 'sub1-nat) → p-sub1-nat-okp (ins, p)) ∧ ((car (ins) = 'lt-nat) → p-lt-nat-okp (ins, p)) ∧ ((car (ins) = 'mult2-nat) → p-mult2-nat-okp (ins, p))

∧ ((car (ins) = 'mult2-nat-with-carry-out)

→ p-mult2-nat-with-carry-out-okp (ins, p)) ∧ ((car (ins) = 'div2-nat) → p-div2-nat-okp (ins, p)) ∧ ((car (ins) = 'or-bitv) → p-or-bitv-okp (ins, p)) ∧ ((car (ins) = 'and-bitv) → p-and-bitv-okp (ins, p)) ∧ ((car (ins) = 'not-bitv) → p-not-bitv-okp (ins, p)) ∧ ((car (ins) = 'xor-bitv) → p-xor-bitv-okp (ins, p)) ∧ ((car (ins) = 'rsh-bitv) → p-rsh-bitv-okp (ins, p)) ∧ ((car (ins) = 'lsh-bitv) → p-lsh-bitv-okp (ins, p)) ∧ ((car (ins) = 'or-bool) → p-or-bool-okp (ins, p)) ∧ ((car (ins) = 'and-bool) → p-and-bool-okp (ins, p)) ∧ ((car (ins) = 'not-bool) → p-not-bool-okp (ins, p)))

Event: Disable p-ins-okp2.

Theorem: p-ins-okp-backchainer p-ins-okp (ins, p) → (((car (ins) = 'call) → p-call-okp (ins, p))

∧ ((car (ins) = 'ret) → p-ret-okp (ins, p)) ∧ ((car (ins) = 'locn) → p-locn-okp (ins, p))

∧ ((car (ins) = 'push-constant)

→ p-push-constant-okp (ins, p)) ∧ ((car (ins) = 'push-local) → p-push-local-okp (ins, p)) ∧ ((car (ins) = 'push-global) → p-push-global-okp (ins, p))

∧ ((car (ins) = 'push-ctrl-stk-free-size)

→ p-push-ctrl-stk-free-size-okp (ins, p))

∧ ((car (ins) = 'push-temp-stk-free-size)

→ p-push-temp-stk-free-size-okp (ins, p))

∧ ((car (ins) = 'push-temp-stk-index)

→ p-push-temp-stk-index-okp (ins, p))

∧ ((car (ins) = 'jump-if-temp-stk-full)

→ p-jump-if-temp-stk-full-okp (ins, p))

∧ ((car (ins) = 'jump-if-temp-stk-empty)

→ p-jump-if-temp-stk-empty-okp (ins, p)) ∧ ((car (ins) = 'pop) → p-pop-okp (ins, p)) ∧ ((car (ins) = 'pop*) → p-pop*-okp (ins, p)) ∧ ((car (ins) = 'popn) → p-popn-okp (ins, p)) ∧ ((car (ins) = 'pop-local) → p-pop-local-okp (ins, p)) ∧ ((car (ins) = 'pop-global) → p-pop-global-okp (ins, p)) ∧ ((car (ins) = 'pop-locn) → p-pop-locn-okp (ins, p)) ∧ ((car (ins) = 'pop-call) → p-pop-call-okp (ins, p))

∧ ((car (ins) = 'fetch-temp-stk)

→ p-fetch-temp-stk-okp (ins, p))

∧ ((car (ins) = 'deposit-temp-stk)

→ p-deposit-temp-stk-okp (ins, p)) ∧ ((car (ins) = 'jump) → p-jump-okp (ins, p)) ∧ ((car (ins) = 'jump-case) → p-jump-case-okp (ins, p)) ∧ ((car (ins) = 'pushj) → p-pushj-okp (ins, p)) ∧ ((car (ins) = 'popj) → p-popj-okp (ins, p)) ∧ ((car (ins) = 'set-local) → p-set-local-okp (ins, p)) ∧ ((car (ins) = 'set-global) → p-set-global-okp (ins, p))

∧ ((car (ins) = 'test-nat-and-jump)

→ p-test-nat-and-jump-okp (ins, p))

∧ ((car (ins) = 'test-int-and-jump)

→ p-test-int-and-jump-okp (ins, p))

∧ ((car (ins) = 'test-bool-and-jump)

→ p-test-bool-and-jump-okp (ins, p))

∧ ((car (ins) = 'test-bitv-and-jump)

→ p-test-bitv-and-jump-okp (ins, p)) ∧ ((car (ins) = 'no-op) → p-no-op-okp (ins, p)) ∧ ((car (ins) = 'add-addr) → p-add-addr-okp (ins, p)) ∧ ((car (ins) = 'sub-addr) → p-sub-addr-okp (ins, p)))

; 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.

Theorem: p-ins-okp-exhausted (p-ins-okp (ins, p) ∧ (car (ins) ≠ 'call) ∧ (car (ins) ≠ 'ret) ∧ (car (ins) ≠ 'locn)

∧ (car (ins) ≠ 'push-constant)

∧ (car (ins) ≠ 'push-local)

∧ (car (ins) ≠ 'push-global)
∧ (car (ins) ≠ 'push-ctrl-stk-free-size)
∧ (car (ins) ≠ 'push-temp-stk-free-size)
∧ (car (ins) ≠ 'push-temp-stk-index)
∧ (car (ins) ≠ 'jump-if-temp-stk-full)
∧ (car (ins) ≠ 'jump-if-temp-stk-empty)

∧ (car (ins) ≠ 'pop) ∧ (car (ins) ≠ 'pop*) ∧ (car (ins) ≠ 'popn) ∧ (car (ins) ≠ 'pop-local) ∧ (car (ins) ≠ 'pop-global) ∧ (car (ins) ≠ 'pop-locn) ∧ (car (ins) ≠ 'pop-call)

∧ (car (ins) ≠ 'fetch-temp-stk)
∧ (car (ins) ≠ 'deposit-temp-stk)

∧ (car (ins) ≠ 'jump) ∧ (car (ins) ≠ 'jump-case) ∧ (car (ins) ≠ 'pushj) ∧ (car (ins) ≠ 'popj) ∧ (car (ins) ≠ 'set-local) ∧ (car (ins) ≠ 'set-global)

∧ (car (ins) ≠ 'test-nat-and-jump)
∧ (car (ins) ≠ 'test-int-and-jump)
∧ (car (ins) ≠ 'test-bool-and-jump)
∧ (car (ins) ≠ 'test-bitv-and-jump)

∧ (car (ins) ≠ 'no-op) ∧ (car (ins) ≠ 'add-addr) ∧ (car (ins) ≠ 'sub-addr)) → p-ins-okp2 (ins, p)

Theorem: p-ins-okp2-exhausted (p-ins-okp2 (ins, p) ∧ (car (ins) ≠ 'eq) ∧ (car (ins) ≠ 'lt-addr) ∧ (car (ins) ≠ 'fetch) ∧ (car (ins) ≠ 'deposit) ∧ (car (ins) ≠ 'add-int)

∧ (car (ins) ≠ 'add-int-with-carry)

∧ (car (ins) ≠ 'add1-int) ∧ (car (ins) ≠ 'sub-int)

∧ (car (ins) ≠ 'sub-int-with-carry)

∧ (car (ins) ≠ 'sub1-int) ∧ (car (ins) ≠ 'neg-int) ∧ (car (ins) ≠ 'lt-int) ∧ (car (ins) ≠ 'int-to-nat) ∧ (car (ins) ≠ 'add-nat)

∧ (car (ins) ≠ 'add-nat-with-carry)

∧ (car (ins) ≠ 'add1-nat) ∧ (car (ins) ≠ 'sub-nat)

∧ (car (ins) ≠ 'sub-nat-with-carry)

∧ (car (ins) ≠ 'sub1-nat) ∧ (car (ins) ≠ 'lt-nat) ∧ (car (ins) ≠ 'mult2-nat)

∧ (car (ins) ≠ 'mult2-nat-with-carry-out)

∧ (car (ins) ≠ 'div2-nat) ∧ (car (ins) ≠ 'or-bitv) ∧ (car (ins) ≠ 'and-bitv) ∧ (car (ins) ≠ 'not-bitv) ∧ (car (ins) ≠ 'xor-bitv) ∧ (car (ins) ≠ 'rsh-bitv) ∧ (car (ins) ≠ 'lsh-bitv) ∧ (car (ins) ≠ 'or-bool) ∧ (car (ins) ≠ 'and-bool)) → ((car (ins) = 'not-bool) = t)

Event: Disable p-ins-step2.

Theorem: transitivity-of-same-signature (same-signature (segment1 , segment2 ) ∧ same-signature (segment2 , segment3 ))

→ same-signature (segment1 , segment3 )

;; ***** End stuff from p-r.events *****
;; The next two lemmas are from big-add.events by J Moore.

Theorem: p-opener (p (s, 0) = s) ∧ (p (p-state (pc, ctrl, temp, prog, data, max-ctrl, max-temp, word-size, psw),

1 + n) = p (p-step (p-state (pc,

ctrl, temp, prog, data, max-ctrl, max-temp, word-size, psw)),

n))

Event: Disable p-opener.

Event: Disable p.

Theorem: p-step1-opener p-step1 (cons (opcode, operands), p) = if p-ins-okp (cons (opcode, operands), p)

then p-ins-step (cons (opcode, operands), p) else p-halt (p, x-y-error-msg ('p, opcode)) endif

Event: Disable p-step1-opener.

Event: Disable p-step1.

;; ***** End stuff from big-add.events *****

Event: Disable same-signature-implies-equal-lengths.

Event: Disable same-signature-implies-equal-definedp.

Event: Disable transitivity-of-same-signature.

;; The following axioms are proven in Piton (in p-r).

Axiom: p-step-preserves-proper-p-statep (proper-p-statep (p) ∧ (¬ errorp (p-psw (p-step (p))))) → proper-p-statep (p-step (p))

Axiom: once-errorp-always-errorp-step (¬ errorp (p-psw (p-step (p)))) → (¬ errorp (p-psw (p)))

Axiom: once-errorp-always-errorp (¬ errorp (p-psw (p (p, n)))) → (¬ errorp (p-psw (p)))

Axiom: p-preserves-proper-p-statep (proper-p-statep (p) ∧ (¬ 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.

Definition: p-invariant1 (p0 , p1 ) = ((p-prog-segment (p0 ) = p-prog-segment (p1 ))

∧ (p-max-ctrl-stk-size (p0 ) = p-max-ctrl-stk-size (p1 )) ∧ (p-max-temp-stk-size (p0 ) = p-max-temp-stk-size (p1 )) ∧ (p-word-size (p0 ) = p-word-size (p1 )))

Definition: p-invariant (p0 , p1 ) = (same-signature (p-data-segment (p0 ), p-data-segment (p1 ))

∧ p-invariant1 (p0 , p1 ))

Theorem: p-invariant-opener 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))

Theorem: p-invariant1-opener 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)

Event: Disable p-invariant.

Event: 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.

Theorem: no-op-preserves-p-invariant (car (ins) = 'no-op) → p-invariant (p-no-op-step (ins, p), p)

Theorem: push-global-preserves-p-invariant

 (car (ins) = 'push-global)

→ p-invariant (p-push-global-step (ins, p), p)

;; The following is inspired by the lemma length-put of Piton.

Theorem: my-length-put length (put (val, n, lst)) = if n < length (lst) then length (lst)

else 1 + n endif

Event: Disable my-length-put.

Theorem: proper-p-statep-proper-implies-proper-p-instructionp proper-p-statep (p) → proper-p-instructionp (p-current-instruction (p), car (untag (p-pc (p))), p)

Theorem: definedp-p-data-segment-implies-listp-generalized (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

Theorem: definedp-p-data-segment-implies-listp-1 (proper-p-statep (p) ∧ definedp (name, p-data-segment (p))) → listp (cdr (assoc (name, p-data-segment (p))))

Event: Disable definedp-p-data-segment-implies-listp-1.

Theorem: definedp-p-data-segment-implies-litatom-generalized (proper-p-data-segmentp (segment, p) ∧ definedp (name, segment)) → litatom (name)

Theorem: definedp-p-data-segment-implies-litatom (proper-p-statep (p) ∧ definedp (name, p-data-segment (p))) → litatom (name)

Theorem: pop-global-preserves-p-invariant1 (car (ins) = 'pop-global) → p-invariant1 (p-pop-global-step (ins, p), p)

Theorem: pop-global-preserves-p-same-signature-data-segment let new-p be p-pop-global-step (p-current-instruction (p), p) in ((p-psw (p) = 'run) ∧ (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)) endlet

Theorem: push-local-preserves-p-invariant (car (ins) = 'push-local) → p-invariant (p-push-local-step (ins, p), p)

Theorem: pop-local-preserves-p-invariant (car (ins) = 'pop-local) → p-invariant (p-pop-local-step (ins, p), p)

Theorem: deposit-preserves-p-invariant1 (car (ins) = 'deposit) → p-invariant1 (p-deposit-step (ins, p), p)

Theorem: deposit-preserves-same-signature-data-segment let new-p be p-deposit-step (p-current-instruction (p), p) in ((p-psw (p) = 'run) ∧ (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)) endlet

Theorem: add1-nat-preserves-p-invariant (car (ins) = 'add1-nat) → p-invariant (p-add1-nat-step (ins, p), p)

Theorem: add-addr-preserves-p-invariant (car (ins) = 'add-addr) → p-invariant (p-add-addr-step (ins, p), p)

Theorem: add-nat-with-carry-preserves-p-invariant

(car (ins) = 'add-nat-with-carry)

→ p-invariant (p-add-nat-with-carry-step (ins, p), p)

Theorem: mult2-nat-with-carry-out-preserves-p-invariant

(car (ins) = 'mult2-nat-with-carry-out)

→ p-invariant (p-mult2-nat-with-carry-out-step (ins, p), p)

Theorem: fetch-temp-stk-preserves-p-invariant

(car (ins) = 'fetch-temp-stk)

→ p-invariant (p-fetch-temp-stk-step (ins, p), p)

Theorem: deposit-temp-stk-preserves-p-invariant

(car (ins) = 'deposit-temp-stk)

→ p-invariant (p-deposit-temp-stk-step (ins, p), p)

Theorem: pop*-preserves-p-invariant (car (ins) = 'pop*) → p-invariant (p-pop*-step (ins, p), p)

Theorem: popn-preserves-p-invariant (car (ins) = 'popn) → p-invariant (p-popn-step (ins, p), p)

; 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.

Theorem: set-local-preserves-p-invariant (car (ins) = 'set-local) → p-invariant (p-set-local-step (ins, p), p)

Theorem: set-global-preserves-p-invariant1 (car (ins) = 'set-global) → p-invariant1 (p-set-global-step (ins, p), p)

Theorem: set-global-preserves-same-signature-data-segment let new-p be p-set-global-step (p-current-instruction (p), p) in ((p-psw (p) = 'run) ∧ (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)) endlet

Theorem: push-constant-preserves-p-invariant

(car (ins) = 'push-constant)

→ p-invariant (p-push-constant-step (ins, p), p)

Theorem: push-ctrl-stk-free-size-preserves-p-invariant

(car (ins) = 'push-ctrl-stk-free-size)

→ p-invariant (p-push-ctrl-stk-free-size-step (ins, p), p)

Theorem: push-temp-stk-free-size-preserves-p-invariant

(car (ins) = 'push-temp-stk-free-size)

→ p-invariant (p-push-temp-stk-free-size-step (ins, p), p)

Theorem: push-temp-stk-index-preserves-p-invariant

(car (ins) = 'push-temp-stk-index)

→ p-invariant (p-push-temp-stk-index-step (ins, p), p)

Theorem: pop-preserves-p-invariant (car (ins) = 'pop) → p-invariant (p-pop-step (ins, p), p)

Theorem: jump-preserves-p-invariant (car (ins) = 'jump) → p-invariant (p-jump-step (ins, p), p)

Theorem: pushj-preserves-p-invariant (car (ins) = 'pushj) → p-invariant (p-pushj-step (ins, p), p)

Theorem: popj-preserves-p-invariant (car (ins) = 'popj) → p-invariant (p-popj-step (ins, p), p)

Theorem: sub-addr-preserves-p-invariant (car (ins) = 'sub-addr) → p-invariant (p-sub-addr-step (ins, p), p)

Theorem: eq-preserves-p-invariant (car (ins) = 'eq) → p-invariant (p-eq-step (ins, p), p)

Theorem: lt-addr-preserves-p-invariant (car (ins) = 'lt-addr) → p-invariant (p-lt-addr-step (ins, p), p)

Theorem: fetch-preserves-p-invariant (car (ins) = 'fetch) → p-invariant (p-fetch-step (ins, p), p)

Theorem: add-int-preserves-p-invariant (car (ins) = 'add-int) → p-invariant (p-add-int-step (ins, p), p)

Theorem: add-int-with-carry-preserves-p-invariant

(car (ins) = 'add-int-with-carry)

→ p-invariant (p-add-int-with-carry-step (ins, p), p)

Theorem: add1-int-preserves-p-invariant (car (ins) = 'add1-int) → p-invariant (p-add1-int-step (ins, p), p)

Theorem: sub-int-preserves-p-invariant (car (ins) = 'sub-int) → p-invariant (p-sub-int-step (ins, p), p)

Theorem: sub-int-with-carry-preserves-p-invariant

(car (ins) = 'sub-int-with-carry)

→ p-invariant (p-sub-int-with-carry-step (ins, p), p)

Theorem: sub1-int-preserves-p-invariant (car (ins) = 'sub1-int) → p-invariant (p-sub1-int-step (ins, p), p)

Theorem: neg-int-preserves-p-invariant (car (ins) = 'neg-int) → p-invariant (p-neg-int-step (ins, p), p)

Theorem: lt-int-preserves-p-invariant (car (ins) = 'lt-int) → p-invariant (p-lt-int-step (ins, p), p)

Theorem: int-to-nat-preserves-p-invariant (car (ins) = 'int-to-nat) → p-invariant (p-int-to-nat-step (ins, p), p)

Theorem: add-nat-preserves-p-invariant (car (ins) = 'add-nat) → p-invariant (p-add-nat-step (ins, p), p)

Theorem: sub-nat-preserves-p-invariant (car (ins) = 'sub-nat) → p-invariant (p-sub-nat-step (ins, p), p)

Theorem: sub-nat-with-carry-preserves-p-invariant

(car (ins) = 'sub-nat-with-carry)

→ p-invariant (p-sub-nat-with-carry-step (ins, p), p)

Theorem: sub1-nat-preserves-p-invariant (car (ins) = 'sub1-nat) → p-invariant (p-sub1-nat-step (ins, p), p)

Theorem: lt-nat-preserves-p-invariant (car (ins) = 'lt-nat) → p-invariant (p-lt-nat-step (ins, p), p)

Theorem: mult2-nat-preserves-p-invariant (car (ins) = 'mult2-nat) → p-invariant (p-mult2-nat-step (ins, p), p)

Theorem: div2-nat-preserves-p-invariant (car (ins) = 'div2-nat) → p-invariant (p-div2-nat-step (ins, p), p)

Theorem: or-bitv-preserves-p-invariant (car (ins) = 'or-bitv) → p-invariant (p-or-bitv-step (ins, p), p)

Theorem: and-bitv-preserves-p-invariant (car (ins) = 'and-bitv) → p-invariant (p-and-bitv-step (ins, p), p)

Theorem: not-bitv-preserves-p-invariant (car (ins) = 'not-bitv) → p-invariant (p-not-bitv-step (ins, p), p)

Theorem: xor-bitv-preserves-p-invariant (car (ins) = 'xor-bitv) → p-invariant (p-xor-bitv-step (ins, p), p)

Theorem: rsh-bitv-preserves-p-invariant (car (ins) = 'rsh-bitv) → p-invariant (p-rsh-bitv-step (ins, p), p)

Theorem: lsh-bitv-preserves-p-invariant (car (ins) = 'lsh-bitv) → p-invariant (p-lsh-bitv-step (ins, p), p)

Theorem: or-bool-preserves-p-invariant (car (ins) = 'or-bool) → p-invariant (p-or-bool-step (ins, p), p)

Theorem: and-bool-preserves-p-invariant (car (ins) = 'and-bool) → p-invariant (p-and-bool-step (ins, p), p)

Theorem: not-bool-preserves-p-invariant (car (ins) = 'not-bool) → p-invariant (p-not-bool-step (ins, p), p)

Theorem: jump-if-temp-stk-full-preserves-p-invariant

(car (ins) = 'jump-if-temp-stk-full)

→ p-invariant (p-jump-if-temp-stk-full-step (ins, p), p)

Theorem: jump-if-temp-stk-empty-preserves-p-invariant

(car (ins) = 'jump-if-temp-stk-empty)

→ p-invariant (p-jump-if-temp-stk-empty-step (ins, p), p)

Theorem: test-nat-and-jump-preserves-p-invariant

(car (ins) = 'test-nat-and-jump)

→ p-invariant (p-test-nat-and-jump-step (ins, p), p)

Theorem: test-int-and-jump-preserves-p-invariant

(car (ins) = 'test-int-and-jump)

→ p-invariant (p-test-int-and-jump-step (ins, p), p)

Theorem: test-bool-and-jump-preserves-p-invariant

(car (ins) = 'test-bool-and-jump)

→ p-invariant (p-test-bool-and-jump-step (ins, p), p)

Theorem: test-bitv-and-jump-preserves-p-invariant

(car (ins) = 'test-bitv-and-jump)

→ p-invariant (p-test-bitv-and-jump-step (ins, p), p)

Theorem: pop-locn-preserves-p-invariant (car (ins) = 'pop-locn) → p-invariant (p-pop-locn-step (ins, p), p)

Theorem: locn-preserves-p-invariant (car (ins) = 'locn) → p-invariant (p-locn-step (ins, p), p)

Theorem: jump-case-preserves-p-invariant (car (ins) = 'jump-case) → p-invariant (p-jump-case-step (ins, p), p)

Theorem: call-preserves-p-invariant (car (ins) = 'call) → p-invariant (p-call-step (ins, p), p)

Theorem: pop-call-preserves-p-invariant (car (ins) = 'pop-call) → p-invariant (p-pop-call-step (ins, p), p)

Theorem: ret-preserves-p-invariant (car (ins) = 'ret) → p-invariant (p-ret-step (ins, p), p)

Theorem: p-invariant-p-invariant1 p-invariant (p0 , p1 ) → p-invariant1 (p0 , p1 )

Theorem: p-ins-step2-preserves-p-invariant1 p-invariant1 (p-ins-step2 (ins, p), p)

Theorem: p-ins-step-preserves-p-invariant1 p-invariant1 (p-ins-step (ins, p), p)

Event: Disable p-invariant-p-invariant1.

Theorem: p-invariant1-reflexive p-invariant1 (p, p)

Theorem: p-invariant1-p-halt (p-invariant1 (p0 , p-halt (p1 , error-message)) = p-invariant1 (p0 , p1 )) ∧ (p-invariant1 (p-halt (p0 , error-message), p1 ) = p-invariant1 (p0 , p1 ))

Theorem: p-step-preserves-p-invariant1 p-invariant1 (p-step (p), p)

Theorem: transitivity-of-p-invariant1 (p-invariant1 (p0 , p1 ) ∧ p-invariant1 (p1 , p2 )) → p-invariant1 (p0 , p2 )

Theorem: p-preserves-p-invariant1 p-invariant1 (p (p, n), p)

Event: Disable transitivity-of-p-invariant1.

Theorem: p-preserves-p-resources (p-prog-segment (p (p, n)) = p-prog-segment (p)) ∧ (p-max-ctrl-stk-size (p (p, n)) = p-max-ctrl-stk-size (p)) ∧ (p-max-temp-stk-size (p (p, n)) = p-max-temp-stk-size (p)) ∧ (p-word-size (p (p, n)) = p-word-size (p))

Theorem: p-invariant-same-signature-data-segments p-invariant (p0 , p1 ) → same-signature (p-data-segment (p0 ), p-data-segment (p1 ))

Theorem: p-ins-step2-preserves-same-signature-data-segment let new-p be p-ins-step2 (p-current-instruction (p), p) in ((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)) endlet

Theorem: p-ins-step-preserves-same-signature-data-segment ((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))

Event: Disable p-invariant-same-signature-data-segments.

Theorem: p-step-preserves-same-signature-data-segment (proper-p-statep (p) ∧ (¬ errorp (p-psw (p-step (p))))) → same-signature (p-data-segment (p-step (p)), p-data-segment (p))

Theorem: p-preserves-same-signature-data-segment (proper-p-statep (p) ∧ (¬ errorp (p-psw (p (p, n))))) → same-signature (p-data-segment (p (p, n)), p-data-segment (p))

;; Finally enable the Piton -okp and -step functions, we want them for later.

Event: Enable p-call-okp. Event: Enable p-call-step. Event: Enable p-ret-okp. Event: Enable p-ret-step. Event: Enable p-locn-okp. Event: Enable p-locn-step. Event: Enable p-push-constant-okp. Event: Enable p-push-constant-step. Event: Enable p-push-local-okp. Event: Enable p-push-local-step. Event: Enable p-push-global-okp. Event: Enable p-push-global-step. Event: Enable p-push-ctrl-stk-free-size-okp. Event: Enable p-push-ctrl-stk-free-size-step. Event: Enable p-push-temp-stk-free-size-okp. Event: Enable p-push-temp-stk-free-size-step. Event: Enable p-push-temp-stk-index-okp. Event: Enable p-push-temp-stk-index-step.

Event: Enable p-jump-if-temp-stk-full-okp. Event: Enable p-jump-if-temp-stk-full-step. Event: Enable p-jump-if-temp-stk-empty-okp. Event: Enable p-jump-if-temp-stk-empty-step. Event: Enable p-pop-okp. Event: Enable p-pop-step. Event: Enable p-pop*-okp. Event: Enable p-pop*-step. Event: Enable p-popn-okp. Event: Enable p-popn-step. Event: Enable p-pop-local-okp. Event: Enable p-pop-local-step. Event: Enable p-pop-global-okp. Event: Enable p-pop-global-step. Event: Enable p-pop-locn-okp. Event: Enable p-pop-locn-step. Event: Enable p-pop-call-okp. Event: Enable p-pop-call-step.

Event: Enable p-fetch-temp-stk-okp. Event: Enable p-fetch-temp-stk-step. Event: Enable p-deposit-temp-stk-okp. Event: Enable p-deposit-temp-stk-step. Event: Enable p-jump-okp. Event: Enable p-jump-step. Event: Enable p-jump-case-okp. Event: Enable p-jump-case-step. Event: Enable p-pushj-okp. Event: Enable p-pushj-step. Event: Enable p-popj-okp. Event: Enable p-popj-step. Event: Enable p-set-local-okp. Event: Enable p-set-local-step. Event: Enable p-set-global-okp. Event: Enable p-set-global-step. Event: Enable p-test-nat-and-jump-okp. Event: Enable p-test-nat-and-jump-step.

Event: Enable p-test-int-and-jump-okp. Event: Enable p-test-int-and-jump-step. Event: Enable p-test-bool-and-jump-okp. Event: Enable p-test-bool-and-jump-step. Event: Enable p-test-bitv-and-jump-okp. Event: Enable p-test-bitv-and-jump-step. Event: Enable p-no-op-okp. Event: Enable p-no-op-step. Event: Enable p-add-addr-okp. Event: Enable p-add-addr-step. Event: Enable p-sub-addr-okp. Event: Enable p-sub-addr-step. Event: Enable p-eq-okp. Event: Enable p-eq-step. Event: Enable p-lt-addr-okp. Event: Enable p-lt-addr-step. Event: Enable p-fetch-okp. Event: Enable p-fetch-step.

Event: Enable p-deposit-okp. Event: Enable p-deposit-step. Event: Enable p-add-int-okp. Event: Enable p-add-int-step. Event: Enable p-add-int-with-carry-okp. Event: Enable p-add-int-with-carry-step. Event: Enable p-add1-int-okp. Event: Enable p-add1-int-step. Event: Enable p-sub-int-okp. Event: Enable p-sub-int-step. Event: Enable p-sub-int-with-carry-okp. Event: Enable p-sub-int-with-carry-step. Event: Enable p-sub1-int-okp. Event: Enable p-sub1-int-step. Event: Enable p-neg-int-okp. Event: Enable p-neg-int-step. Event: Enable p-lt-int-okp. Event: Enable p-lt-int-step.

Event: Enable p-int-to-nat-okp. Event: Enable p-int-to-nat-step. Event: Enable p-add-nat-okp. Event: Enable p-add-nat-step. Event: Enable p-add-nat-with-carry-okp. Event: Enable p-add-nat-with-carry-step. Event: Enable p-add1-nat-okp. Event: Enable p-add1-nat-step. Event: Enable p-sub-nat-okp. Event: Enable p-sub-nat-step. Event: Enable p-sub-nat-with-carry-okp. Event: Enable p-sub-nat-with-carry-step. Event: Enable p-sub1-nat-okp. Event: Enable p-sub1-nat-step. Event: Enable p-lt-nat-okp. Event: Enable p-lt-nat-step. Event: Enable p-mult2-nat-okp. Event: Enable p-mult2-nat-step.

Event: Enable p-mult2-nat-with-carry-out-okp. Event: Enable p-mult2-nat-with-carry-out-step. Event: Enable p-div2-nat-okp. Event: Enable p-div2-nat-step. Event: Enable p-or-bitv-okp. Event: Enable p-or-bitv-step. Event: Enable p-and-bitv-okp. Event: Enable p-and-bitv-step. Event: Enable p-not-bitv-okp. Event: Enable p-not-bitv-step. Event: Enable p-xor-bitv-okp. Event: Enable p-xor-bitv-step. Event: Enable p-rsh-bitv-okp. Event: Enable p-rsh-bitv-step. Event: Enable p-lsh-bitv-okp. Event: Enable p-lsh-bitv-step. Event: Enable p-or-bool-okp. Event: Enable p-or-bool-step.

Event: Enable p-and-bool-okp.

Event: Enable p-and-bool-step.

Event: Enable p-not-bool-okp.

Event: Enable p-not-bool-step.

Event: Enable p-ins-step.

Event: 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:
;; -------------------------------------------------------------------------

Definition: app (x, y) = if listp (x) then cons (car (x), app (cdr (x), y))

else y endif

Definition: rev (x) = if listp (x) then app (rev (cdr (x)), list (car (x)))

else nil endif

Definition: frev (x, y) = if listp (x) then frev (cdr (x), cons (car (x), y))

else y endif

;; -------------------------------------------------------------------------
;; End functions for testing
;; Returns a list containing the value or F.

Definition: l-eval (flag, expr, alist, clk) = if flag = 'list

then if listp (expr)

then cons (l-eval (t, car (expr), alist, clk),

l-eval ('list, cdr (expr), alist, clk))

else nil endif elseif clk ≃ 0 then f elseif litatom (expr) then list (cdr (assoc (expr, alist))) elseif expr ≃ nil then list (expr) elseif car (expr) = 'quote then list (cadr (expr)) elseif car (expr) = 'if then let test be l-eval (t, cadr (expr), alist, clk)

in if test then if car (test) then l-eval (t, caddr (expr), alist, clk) else l-eval (t, cadddr (expr), alist, clk) endif

else f endif endlet elseif f ∈ l-eval ('list, cdr (expr), alist, clk) then f elseif subrp (car (expr)) then list (apply-subr (car (expr),

strip-cars (l-eval ('list, cdr (expr), alist, clk))))

else l-eval (t, body (car (expr)), pairlist (formals (car (expr)),

strip-cars (l-eval ('list, cdr (expr), alist, clk))),

clk − 1) endif

Definition: remove-costs (list) = if listp (list) then cons (list (caar (list)), remove-costs (cdr (list)))

else nil endif

Theorem: strip-cars-remove-costs strip-cars (remove-costs (l)) = strip-cars (l)

Theorem: member-strip-cars-definedp (x ∈ strip-cars (y)) = definedp (x, y)

Event: Disable member-strip-cars-definedp.

Theorem: member-plist (x ∈ plist (y)) = (x ∈ y)

Theorem: car-assoc definedp (x, y) → (car (assoc (x, y)) = x)

Theorem: v&c$-l-eval-equivalence (((flag = 'list) ∧ (f ∉ l-eval (flag, expr, alist, clock))) ∨ ((flag ≠ 'list) ∧ (l-eval (flag, expr, alist, clock) ≠ f))) → ((l-eval (flag, expr, alist, clock)

= if flag = 'list then remove-costs (v&c$ (flag, expr, alist))

else list (car (v&c$ (flag, expr, alist))) endif) ∧ (((flag = 'list) ∧ (f ∉ v&c$ (flag, expr, alist)))

∨ ((flag ≠ 'list) ∧ (v&c$ (flag, expr, alist) ≠ f))))

Theorem: cdr-v&c$-lessp-if-cadr v&c-apply$ ('if, cons (v&c$ (t, test, alist), v&c$ ('list, branches, alist))) → (cdr (v&c$ (t, test, alist))

< cdr (v&c-apply$ ('if,

cons (v&c$ (t, test, alist), v&c$ ('list, branches, alist)))))

Theorem: cdr-v&c$-lessp-if-caddr (v&c-apply$ ('if, cons (v&c$ (t, test, alist), v&c$ ('list, branches, alist))) ∧ car (v&c$ (t, test, alist))) → (cdr (v&c$ (t, car (branches), alist))

< cdr (v&c-apply$ ('if,

cons (v&c$ (t, test, alist), v&c$ ('list, branches, alist)))))

Theorem: cdr-v&c$-lessp-if-cadddr (v&c-apply$ ('if, cons (v&c$ (t, test, alist), v&c$ ('list, branches, alist))) ∧ (¬ car (v&c$ (t, test, alist)))) → (cdr (v&c$ (t, cadr (branches), alist))

< cdr (v&c-apply$ ('if,

cons (v&c$ (t, test, alist), v&c$ ('list, branches, alist)))))

Theorem: v&c$-f-l-eval-f-if-helper-1 ((clock ≄ 0) ∧ listp (expr) ∧ (car (expr) = 'if) ∧ l-eval (t, cadr (expr), alist, clock) ∧ v&c$ (t, cadr (expr), alist) ∧ (¬ 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)) → (¬ l-eval (t, caddr (expr), alist, clock))

Event: Disable v&c$-f-l-eval-f-if-helper-1.

Theorem: v&c$-f-l-eval-f-if-helper-2 ((clock ≄ 0) ∧ listp (expr) ∧ (car (expr) = 'if) ∧ l-eval (t, cadr (expr), alist, clock) ∧ v&c$ (t, cadr (expr), alist) ∧ (¬ 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, cadddr (expr), alist)) → (¬ l-eval (t, cadddr (expr), alist, clock))

Event: Disable v&c$-f-l-eval-f-if-helper-2.

Theorem: v&c$-f-l-eval-flag-list (f ∉ l-eval ('list, expr, alist, clock)) → (strip-cars (v&c$ ('list, expr, alist))

= strip-cars (l-eval ('list, expr, alist, clock)))

Event: Disable v&c$-f-l-eval-flag-list.

Theorem: v&c$-f-l-eval-f (((flag = 'list) ∧ (f ∈ v&c$ (flag, expr, alist))) ∨ ((flag ≠ 'list) ∧ (v&c$ (flag, expr, alist) = f))) → (((flag = 'list) ∧ (f ∈ l-eval (flag, expr, alist, clock)))

∨ ((flag ≠ 'list) ∧ (l-eval (flag, expr, alist, clock) = f)))

Theorem: l-eval-v&c$-flag-not-list ((¬ v&c$ (flag, expr, alist)) ∧ (flag ≠ 'list)) → (l-eval (flag, expr, alist, clock) = f)

Event: Disable l-eval-v&c$-flag-not-list.

Theorem: l-eval-v&c$-flag-list (f ∈ v&c$ ('list, expr, alist)) → (f ∈ l-eval ('list, expr, alist, clock))

Theorem: v&c$-l-eval-flag-list (f ∉ l-eval ('list, expr, alist, clock)) → (f ∉ v&c$ ('list, expr, alist))

Theorem: member-f-v&c$-fact-1 (listp (expr) ∧ (car (expr) ≠ 'quote) ∧ (car (expr) ≠ 'if) ∧ (f ∈ v&c$ ('list, cdr (expr), alist)) ∧ (flag ≠ 'list)) → (¬ v&c$ (flag, expr, alist))

Theorem: sum-cdrs-v&c$-list-fact-1 (v&c-apply$ (fun, v&c$ ('list, arg-list, alist)) ∧ (fun ≠ 'quote) ∧ (fun ≠ 'if)) → (sum-cdrs (v&c$ ('list, arg-list, alist))

< cdr (v&c-apply$ (fun, v&c$ ('list, arg-list, alist))))

Theorem: subrp-expr-v&c-apply$ (subrp (x) ∧ (x ≠ 'if) ∧ (f ∉ args)) → (car (v&c-apply$ (x, args)) = apply-subr (x, strip-cars (args)))

Theorem: not-subrp-expr-v&c-apply$ ((¬ subrp (x)) ∧ (f ∉ args)) → (car (v&c-apply$ (x, args))

= car (v&c$ (t, body (x), pairlist (formals (x), strip-cars (args)))))

Theorem: v&c$-body-lessp-fact-1 ((¬ subrp (fun)) ∧ v&c-apply$ (fun, args)) → (cdr (v&c$ (t, body (fun), pairlist (formals (fun), strip-cars (args))))

< cdr (v&c-apply$ (fun, args)))

Theorem: v&c$-not-subrp-expand-1 (v&c-apply$ (fun, args) ∧ (¬ subrp (fun))) → v&c$ (t, body (fun), pairlist (formals (fun), strip-cars (args)))

Theorem: not-member-remove-costs (¬ listp (x)) → (x ∉ remove-costs (list))

Theorem: l-eval-not-f-v&c$-equivalence (((flag = 'list) ∧ (f ∉ v&c$ (flag, expr, alist)) ∧ (sum-cdrs (v&c$ (flag, expr, alist)) < clock)) ∨ ((flag ≠ 'list)

∧ (v&c$ (flag, expr, alist) ≠ f)

∧ (cdr (v&c$ (flag, expr, alist)) < clock))) → ((l-eval (flag, expr, alist, clock)

= if flag = 'list then remove-costs (v&c$ (flag, expr, alist))

else list (car (v&c$ (flag, expr, alist))) endif) ∧ (((flag = 'list) ∧ (f ∉ v&c$ (flag, expr, alist)))

∨ ((flag ≠ 'list) ∧ (v&c$ (flag, expr, alist) ≠ f))))

; ------------------------------------------------------------
; was s-eval1.events
; ------------------------------------------------------------

Event: Disable pack-equal.

Definition: number-cons (x) = if listp (x) then 1 + (number-cons (car (x)) + number-cons (cdr (x)))

else 0 endif

Theorem: number-cons-car listp (x) → (number-cons (car (x)) < number-cons (x))

Theorem: number-cons-cdr listp (x) → (number-cons (cdr (x)) < number-cons (x))

Theorem: number-cons-cadr-caddr-cadddr listp (x) → ((number-cons (cadr (x)) < number-cons (x))

∧ (number-cons (caddr (x)) < number-cons (x)) ∧ (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 (<parameter name> . <value>)
;; S-TEMPS:  an alist with entries of form (<expr> <flag> <value>)
;; S-PROGS: an alist with entires of form
;;          (<program name> <formals> <temps> <body>)
;; 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.

Definition: s-temp-eval = '(temp-eval)

Definition: s-temp-fetch = '(temp-fetch)

Definition: s-temp-test = '(temp-test)

Definition: s-temp-setp (expr, temps) = cadr (assoc (expr, temps))

Event: Disable s-temp-setp.

Definition: s-temp-value (expr, temps) = caddr (assoc (expr, temps))

Event: Add the shell s-state, with recognizer function symbol s-statep and 7 accessors: s-pname, with type restriction (none-of) and default value zero; s-pos, with type restriction (none-of) and default value zero; s-ans, with type restriction (none-of) and default value zero; s-params, with type restriction (none-of) and default value zero; s-temps, with type restriction (none-of) and default value zero; s-progs, with type restriction (none-of) and default value zero; s-err-flag, with type restriction (none-of) and default value zero.

Definition: cur-expr (position, expr) = if position ≃ nil then expr

else cur-expr (cdr (position), get (car (position), expr)) endif

Definition: butlast (list) = firstn (length (list) − 1, list)

Event: Disable butlast.

Definition: last (l) = if listp (l)

then if listp (cdr (l)) then last (cdr (l))

else l endif else nil endif

Definition: dv (pos, increment) = append (pos, list (increment))

Event: Disable dv.

Definition: nx (pos) = append (butlast (pos), list (1 + car (last (pos))))

Event: 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.

Definition: user-fname-prefix = list (car (unpack ('u-)), cadr (unpack ('u-)))

Definition: user-fname (name) = pack (append (user-fname-prefix, unpack (name)))

Event: Disable user-fname.

Definition: user-fnamep (name) = (litatom (name)

∧ (car (unpack (name)) = car (user-fname-prefix)) ∧ (cadr (unpack (name)) = cadr (user-fname-prefix)))

Event: Disable user-fnamep.

Definition: logic-fname (name) = pack (cddr (unpack (name)))

Event: Disable logic-fname.

Definition: s-formals (s-program) = cadr (s-program)

Event: Disable s-formals.

Definition: s-temp-list (s-program) = caddr (s-program)

Event: Disable s-temp-list.

Definition: s-body (s-program) = cadddr (s-program)

Event: Disable s-body.

Definition: s-prog (s) = definition (s-pname (s), s-progs (s))

Event: Disable s-prog.

Definition: s-expr (s) = cur-expr (s-pos (s), s-body (s-prog (s)))

Event: Disable s-expr.

Definition: s-expr-list (s) = restn (car (last (s-pos (s))),

cur-expr (butlast (s-pos (s)), s-body (s-prog (s))))

Event: Disable s-expr-list.

Theorem: get-anything-nil (¬ listp (lst)) → (get (anything, lst) = 0)

Event: Disable get-anything-nil.

Theorem: get-cons (k ≄ 0) → (get (k, cons (anything, list)) = get (k − 1, list))

Event: Disable get-cons.

Theorem: get-large-index (n ≮ length (list)) → (get (n, list) = 0)

Event: Disable get-large-index.

Theorem: get-zerop (n ≃ 0) → (get (n, list) = car (list))

Definition: 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))

Theorem: s-accessors-s-set-pos (s-pname (s-set-pos (s, pos)) = s-pname (s)) ∧ (s-pos (s-set-pos (s, pos)) = pos) ∧ (s-ans (s-set-pos (s, pos)) = s-ans (s)) ∧ (s-params (s-set-pos (s, pos)) = s-params (s)) ∧ (s-temps (s-set-pos (s, pos)) = s-temps (s)) ∧ (s-progs (s-set-pos (s, pos)) = s-progs (s)) ∧ (s-err-flag (s-set-pos (s, pos)) = s-err-flag (s))

Event: Disable s-set-pos.

Definition: 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))

Theorem: s-accessors-s-set-temps (s-pname (s-set-temps (state, temps)) = s-pname (state)) ∧ (s-pos (s-set-temps (state, temps)) = s-pos (state)) ∧ (s-ans (s-set-temps (state, temps)) = s-ans (state)) ∧ (s-temps (s-set-temps (state, temps)) = temps) ∧ (s-params (s-set-temps (state, temps)) = s-params (state)) ∧ (s-progs (s-set-temps (state, temps)) = s-progs (state)) ∧ (s-err-flag (s-set-temps (state, temps)) = s-err-flag (state))

Event: Disable s-set-temps.

Definition: 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)

Theorem: s-accessors-s-set-error (s-pname (s-set-error (state, flag)) = s-pname (state)) ∧ (s-pos (s-set-error (state, flag)) = s-pos (state)) ∧ (s-ans (s-set-error (state, flag)) = s-ans (state)) ∧ (s-temps (s-set-error (state, flag)) = s-temps (state)) ∧ (s-params (s-set-error (state, flag)) = s-params (state)) ∧ (s-progs (s-set-error (state, flag)) = s-progs (state)) ∧ (s-err-flag (s-set-error (state, flag)) = flag)

Event: Disable s-set-error.

Definition: s-change-temp (s, expr, value) = s-set-temps (s, put-assoc (list (t, value), expr, s-temps (s)))

Theorem: s-accessors-s-change-temp (s-pname (s-change-temp (s, e, v)) = s-pname (s)) ∧ (s-pos (s-change-temp (s, e, v)) = s-pos (s)) ∧ (s-ans (s-change-temp (s, e, v)) = s-ans (s)) ∧ (s-params (s-change-temp (s, e, v)) = s-params (s)) ∧ (s-progs (s-change-temp (s, e, v)) = s-progs (s)) ∧ (s-err-flag (s-change-temp (s, e, v)) = s-err-flag (s))

Event: Disable s-change-temp.

Definition: 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))

Theorem: s-accessors-s-set-ans (s-pname (s-set-ans (s, ans)) = s-pname (s)) ∧ (s-pos (s-set-ans (s, ans)) = s-pos (s)) ∧ (s-ans (s-set-ans (s, ans)) = ans) ∧ (s-params (s-set-ans (s, ans)) = s-params (s)) ∧ (s-temps (s-set-ans (s, ans)) = s-temps (s)) ∧ (s-progs (s-set-ans (s, ans)) = s-progs (s)) ∧ (s-err-flag (s-set-ans (s, ans)) = s-err-flag (s))

Event: Disable s-set-ans.

Definition: s-eval-do-temp-fetch (state) = if s-temp-setp (cadr (s-expr (state)), s-temps (state))

then s-set-ans (state, s-temp-value (cadr (s-expr (state)), s-temps (state))) else s-set-error (state, 'temp-fetch-not-set) endif

Theorem: s-accessors-s-eval-do-temp-fetch (s-pname (s-eval-do-temp-fetch (state)) = s-pname (state)) ∧ (s-pos (s-eval-do-temp-fetch (state)) = s-pos (state)) ∧ (s-ans (s-eval-do-temp-fetch (state))

= if s-temp-setp (cadr (s-expr (state)), s-temps (state)) then s-temp-value (cadr (s-expr (state)), s-temps (state)) else s-ans (state) endif)

∧ (s-params (s-eval-do-temp-fetch (state)) = s-params (state)) ∧ (s-temps (s-eval-do-temp-fetch (state)) = s-temps (state)) ∧ (s-progs (s-eval-do-temp-fetch (state)) = s-progs (state)) ∧ (s-err-flag (s-eval-do-temp-fetch (state))

= if s-temp-setp (cadr (s-expr (state)), s-temps (state)) then s-err-flag (state)

        else 'temp-fetch-not-set endif)

Event: Disable s-eval-do-temp-fetch.

Definition: make-temps-entries (list) = if listp (list)

then cons (list (car (list), f, nil), make-temps-entries (cdr (list))) else nil endif

Definition: 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)

Theorem: s-accessors-s-fun-call-state (s-pname (s-fun-call-state (s, pname)) = user-fname (pname)) ∧ (s-pos (s-fun-call-state (s, pname)) = nil) ∧ (s-ans (s-fun-call-state (s, pname)) = s-ans (s)) ∧ (s-params (s-fun-call-state (s, pname))

= pairlist (s-formals (assoc (user-fname (pname), s-progs (s))),

s-ans (s)))

∧ (s-temps (s-fun-call-state (s, pname))

= make-temps-entries (s-temp-list (assoc (user-fname (pname),

s-progs (s)))))

∧ (s-progs (s-fun-call-state (s, pname)) = s-progs (s)) ∧ (s-err-flag (s-fun-call-state (s, pname)) = 'run)

Event: Disable s-fun-call-state.

Definition: 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 ))

Theorem: s-accessors-s-set-expr (s-pname (s-set-expr (s1 , s2 , pos)) = s-pname (s2 )) ∧ (s-pos (s-set-expr (s1 , s2 , pos)) = pos) ∧ (s-ans (s-set-expr (s1 , s2 , pos)) = s-ans (s1 )) ∧ (s-params (s-set-expr (s1 , s2 , pos)) = s-params (s1 )) ∧ (s-temps (s-set-expr (s1 , s2 , pos)) = s-temps (s1 )) ∧ (s-progs (s-set-expr (s1 , s2 , pos)) = s-progs (s2 )) ∧ (s-err-flag (s-set-expr (s1 , s2 , pos)) = s-err-flag (s1 ))

Event: Disable s-set-expr.

Theorem: lessp-number-cons-restn-get (n < length (x)) → (number-cons (get (n, x)) < number-cons (restn (n, x)))

Theorem: get-add1-opener get (1 + x, list) = get (x, cdr (list))

Theorem: restn-add1-opener listp (list) → (restn (1 + x, list) = restn (x, cdr (list)))

Theorem: restn-cdr (n < length (x)) → (restn (n, cdr (x)) = cdr (restn (n, x)))

Event: Disable restn-cdr.

Theorem: car-restn-get car (restn (n, list)) = get (n, list)

Theorem: s-prog-s-set-expr s-prog (s-set-expr (s1 , s2 , pos)) = s-prog (s2 )

Theorem: s-prog-s-set-pos s-prog (s-set-pos (s, pos)) = s-prog (s)

Theorem: cur-expr-append cur-expr (append (pos1 , pos2 ), body) = cur-expr (pos2 , cur-expr (pos1 , body))

Theorem: s-expr-s-set-expr s-expr (s-set-expr (s1 , s2 , dv (s-pos (s2 ), n))) = get (n, s-expr (s2 ))

Theorem: s-expr-s-set-pos-t s-expr (s-set-pos (s, dv (s-pos (s), n))) = get (n, s-expr (s))

Theorem: butlast-append listp (l2 ) → (butlast (append (l1 , l2 )) = append (l1 , butlast (l2 )))

Theorem: restn-sub1-length-last ((n = (length (l) − 1)) ∧ listp (l)) → (restn (n, l) = last (l))

Theorem: append-butlast-lastcdr listp (x) → (append (butlast (x), last (x)) = x)

Theorem: not-listp-cdr-last listp (cdr (last (x))) = f

Theorem: listp-last-listp listp (last (x)) = listp (x)

Theorem: cur-expr-last (listp (pos) ∧ (car (last (pos)) < length (body))) → (cur-expr (last (pos), body) = get (car (last (pos)), body))

Theorem: number-cons-cur-expr ((car (last (pos)) < length (cur-expr (butlast (pos), body))) ∧ listp (pos)) → (number-cons (cur-expr (pos, body))

< number-cons (restn (car (last (pos)), cur-expr (butlast (pos), body))))

Theorem: last-append listp (y) → (last (append (x, y)) = last (y))

Theorem: butlast-singleton-list butlast (list (x)) = nil

Theorem: last-nx listp (pos) → (last (nx (pos)) = list (1 + car (last (pos))))

Theorem: butlast-nx listp (pos) → (butlast (nx (pos)) = butlast (pos))

Theorem: cur-expr-plist cur-expr (plist (pos), body) = cur-expr (pos, body)

Theorem: last-dv last (dv (pos, n)) = list (n)

Theorem: butlast-dv butlast (dv (pos, n)) = plist (pos)

Theorem: s-expr-list-s-s-set-expr-nx (listp (s-pos (s)) ∧ listp (s-expr-list (s))) → (s-expr-list (s-set-expr (s1 , s, nx (s-pos (s)))) = cdr (s-expr-list (s)))

Theorem: lessp-number-cons-s-expr-s-expr-list (listp (s-pos (s)) ∧ listp (s-expr-list (s))) → (number-cons (s-expr (s)) < number-cons (s-expr-list (s)))

Theorem: s-expr-list-s-set-pos-dv s-expr-list (s-set-pos (s, dv (s-pos (s), n))) = restn (n, s-expr (s))

;; 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.

Definition: s-eval (flag, s, c) = if s-err-flag (s) ≠ 'run then s

elseif flag = 'list

then if s-pos (s) ≃ nil then s-set-error (s, 'bad-list-position) elseif listp (s-expr-list (s)) then let car-s be s-eval (t, s, c)

in

let cdr-s be s-eval ('list,

s-set-expr (car-s, s, nx (s-pos (s))),

c)

in

s-set-ans (cdr-s,

cons (s-ans (car-s), s-ans (cdr-s))) endlet endlet

else s-set-ans (s, nil) endif elseif c ≃ 0 then s-set-error (s, 'out-of-time) elseif litatom (s-expr (s)) then s-set-ans (s, value (s-expr (s), s-params (s))) elseif s-expr (s) ≃ nil then s-set-error (s, 'bad-expression) elseif car (s-expr (s)) = 'if then let test be s-eval (t, s-set-pos (s, dv (s-pos (s), 1)), c)

in

if s-err-flag (test) = 'run

then if s-ans (test) then s-eval (t, s-set-expr (test, s, dv (s-pos (s), 2)), c) else s-eval (t,

s-set-expr (test, s, dv (s-pos (s), 3)),

c) endif

else test endif endlet elseif car (s-expr (s)) = s-temp-eval then let new-s be s-eval (t, s-set-pos (s, dv (s-pos (s), 1)), c)

in s-change-temp (new-s, cadr (s-expr (s)), s-ans (new-s)) endlet

elseif car (s-expr (s)) = s-temp-test then if s-temp-setp (cadr (s-expr (s)), s-temps (s))

then s-eval-do-temp-fetch (s) else let new-s be s-eval (t,

s-set-pos (s, dv (s-pos (s), 1)), c)

in

s-change-temp (new-s, cadr (s-expr (s)), s-ans (new-s)) endlet endif

elseif car (s-expr (s)) = s-temp-fetch then s-eval-do-temp-fetch (s) elseif car (s-expr (s)) = 'quote then s-set-ans (s, cadr (s-expr (s))) elseif s-err-flag (s-eval ('list, s-set-pos (s, dv (s-pos (s), 1)), c))

≠ 'run

then s-eval ('list, s-set-pos (s, dv (s-pos (s), 1)), c) elseif subrp (car (s-expr (s))) then let arg-s be s-eval ('list, s-set-pos (s, dv (s-pos (s), 1)), c)

in s-set-ans (arg-s, apply-subr (car (s-expr (s)), s-ans (arg-s))) endlet

elseif litatom (car (s-expr (s))) then let arg-s be s-eval ('list, s-set-pos (s, dv (s-pos (s), 1)), c)

in let new-s be s-eval (t,

s-fun-call-state (arg-s,

car (s-expr (s))),

c − 1)

in if s-err-flag (new-s) = 'run then s-set-expr (s-set-ans (arg-s, s-ans (new-s)),

s,

s-pos (s))

else new-s endif endlet endlet else s-set-error (s, 'bad-instruction) endif

Theorem: s-progs-s-eval s-progs (s-eval (flag, state, clock)) = s-progs (state)

Theorem: s-params-s-eval (s-err-flag (s-eval (flag, state, clock)) = 'run) → (s-params (s-eval (flag, state, clock)) = s-params (state))

Theorem: s-pname-s-eval (s-err-flag (s-eval (flag, state, clock)) = 'run) → (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

Definition: s-expand-temps (flag, body) = if flag = 'list

then if listp (body)

then cons (s-expand-temps (t, car (body)),

s-expand-temps ('list, cdr (body)))

else nil endif elseif body ≃ nil then body elseif (car (body) = s-temp-eval)

∨ (car (body) = s-temp-fetch) ∨ (car (body) = s-temp-test)

then s-expand-temps (t, cadr (body)) elseif car (body) = 'quote then body else cons (car (body), s-expand-temps ('list, cdr (body))) endif

Definition: 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))

Definition: arity (function) = if subrp (function) then cadr (assoc (function, subr-arity-alist))

elseif function = 'quote then 1 else length (formals (function)) endif

Event: Disable arity.

Definition: s-proper-exprp (flag, expr, p-names, formals, temp-list) = if flag = 'list

then if listp (expr)

then s-proper-exprp (t, car (expr), p-names, formals, temp-list)

∧ s-proper-exprp ('list, cdr (expr), p-names, formals, temp-list)

else expr = nil endif elseif listp (expr) then if ¬ plistp (expr) then f

elseif (car (expr) = s-temp-fetch)

∨ (car (expr) = s-temp-eval) ∨ (car (expr) = s-temp-test)

then (cadr (expr) ∈ temp-list)

∧ (length (expr) = 2) ∧ s-proper-exprp (t,

cadr (expr), p-names, formals, temp-list)

elseif car (expr) = 'quote then length (cdr (expr)) = arity (car (expr)) elseif subrp (car (expr)) then (length (cdr (expr)) = arity (car (expr)))

∧ (car (expr) ∉ p-names) ∧ s-proper-exprp ('list,

cdr (expr), p-names, formals,

temp-list)

elseif body (car (expr)) then (length (cdr (expr)) = arity (car (expr)))

∧ (car (expr) ∈ p-names) ∧ s-proper-exprp ('list,

cdr (expr), p-names, formals, temp-list)

else f endif elseif litatom (expr) then expr ∈ formals else f endif

Definition: s-programs-properp (programs, program-names) = if listp (programs)

then 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) else t endif

Definition: s-programs-okp (programs) = if listp (programs)

then (s-formals (car (programs)) ≠ f)

∧ user-fnamep (car (car (programs))) ∧ (s-formals (car (programs))

= formals (logic-fname (car (car (programs))))) ∧ (s-expand-temps (t, s-body (car (programs)))

= body (logic-fname (car (car (programs))))) ∧ s-programs-okp (cdr (programs))

else t endif

Definition: temps-okp (temps, params, c) = if listp (temps)

then ((¬ cadr (car (temps)))

∨ (l-eval (t, s-expand-temps (t, car (car (temps))), params, c)

∧ (car (l-eval (t, s-expand-temps (t, car (car (temps))), params,

= caddr (car (temps)))))

∧ temps-okp (cdr (temps), params, c) else t endif

Definition: good-posp1 (pos, expr) = if pos ≃ nil then t

elseif expr ≃ nil then f

elseif car (expr) = s-temp-fetch then f

elseif (car (expr) = s-temp-eval) ∨ (car (expr) = s-temp-test) then (car (pos) = 1) ∧ good-posp1 (cdr (pos), cadr (expr)) elseif car (expr) = 'quote then f else (car (pos) ≄ 0)

∧ (car (pos) < length (expr))

∧ good-posp1 (cdr (pos), get (car (pos), expr)) endif

Event: Disable good-posp1.

Definition: good-posp-list (n, expr) = if expr ≃ nil then f

elseif (car (expr) = s-temp-fetch)

∨ (car (expr) = s-temp-eval) ∨ (car (expr) = s-temp-test) ∨ (car (expr) = 'quote) then f

else (n ≄ 0) ∧ (length (expr) ≮ n) endif

Definition: good-posp (flag, pos, expr) = if flag = 'list

then good-posp-list (car (last (pos)), cur-expr (butlast (pos), expr))

∧ good-posp1 (butlast (pos), expr) else good-posp1 (pos, expr) endif

Event: Disable good-posp.

Definition: all-user-fnamesp (list) = if listp (list)

then user-fnamep (car (list)) ∧ all-user-fnamesp (cdr (list))

else t endif

Definition: strip-logic-fnames (list) = if listp (list)

then cons (logic-fname (caar (list)), strip-logic-fnames (cdr (list)))

else nil endif

;; 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.

Definition: s-good-statep (s, c) = (definedp (s-pname (s), s-progs (s))

∧ (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)))

∧ (strip-cars (s-temps (s)) = plist (s-temp-list (s-prog (s))))

∧ (s-err-flag (s) = 'run)

∧ temps-okp (s-temps (s), s-params (s), c))

Theorem: s-good-statep-backchainer-1 s-good-statep (s, c) → definedp (s-pname (s), s-progs (s))

Theorem: not-user-fnamep-not-definedp-s-programs-okp ((¬ user-fnamep (name)) ∧ definedp (name, progs)) → (¬ s-programs-okp (progs))

Theorem: s-good-statep-backchainer-2 s-good-statep (s, c) → (¬ definedp ('main, cdr (s-progs (s))))

Event: Disable s-good-statep-backchainer-2.

Theorem: s-good-statep-backchainer-2-5 s-good-statep (s, c) → (caar (s-progs (s)) = 'main)

Event: Disable s-good-statep-backchainer-2-5.

Theorem: s-good-statep-backchainer-3 s-good-statep (s, c) → s-programs-properp (s-progs (s), strip-logic-fnames (cdr (s-progs (s))))

Theorem: s-good-statep-backchainer-4 s-good-statep (s, c) → s-programs-okp (cdr (s-progs (s)))

Theorem: s-good-statep-backchainer-5 s-good-statep (s, c) → temps-okp (s-temps (s), s-params (s), c)

Theorem: s-good-statep-backchainer-6 s-good-statep (s, c) → (s-err-flag (s) = 'run)

Theorem: s-good-statep-strip-cars-temps s-good-statep (s, c) → (strip-cars (s-temps (s)) = plist (s-temp-list (s-prog (s))))

Theorem: s-good-statep-s-set-pos s-good-statep (s-set-pos (s, pos), c) = s-good-statep (s, c)

Theorem: temps-okp-put-assoc (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)

Theorem: s-prog-s-set-temps s-prog (s-set-temps (s, new-temps)) = s-prog (s)

Theorem: s-good-statep-s-change-temp let expr be cadr (s-expr (s)),

s1 be s-eval (t, s-set-pos (s, dv (s-pos (s), 1)), c) in (s-good-statep (s1 , c) ∧ l-eval (t, s-expand-temps (t, expr), s-params (s), c) ∧ (x = car (l-eval (t, s-expand-temps (t, expr), s-params (s), c)))) → s-good-statep (s-change-temp (s1 , expr, x), c) endlet

Theorem: s-prog-s-set-ans s-prog (s-set-ans (s, ans)) = s-prog (s)

Theorem: s-good-statep-s-set-ans s-good-statep (s-set-ans (s, ans), c) = s-good-statep (s, c)

Theorem: s-good-statep-s-set-expr (s-good-statep (s1 , c) ∧ s-good-statep (s2 , c) ∧ (s-prog (s1 ) = s-prog (s2 ))) → s-good-statep (s-set-expr (s1 , s2 , pos), c)

Event: Disable s-good-statep-strip-cars-temps.

Theorem: s-programs-properp-s-proper-exprp (s-programs-properp (progs, program-names) ∧ (prog ∈ progs)) → s-proper-exprp (t,

s-body (prog), program-names, s-formals (prog), s-temp-list (prog))

Theorem: s-good-statep-s-proper-exprp 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)))

Theorem: s-good-statep-s-temp-list s-good-statep (s, c) → ((x ∈ s-temp-list (s-prog (s))) = definedp (x, s-temps (s)))

Event: Disable s-good-statep.

Theorem: s-proper-exprp-list-s-proper-get-t ((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)

Theorem: s-proper-exprp-t-s-proper-get-t ((car (expr) ≠ s-temp-fetch) ∧ (car (expr) ≠ s-temp-eval) ∧ (car (expr) ≠ s-temp-test) ∧ (car (expr) ≠ 'quote) ∧ s-proper-exprp (t, expr, p-names, formals, temp-list) ∧ (n ≄ 0) ∧ (n < length (expr))) → s-proper-exprp (t, get (n, expr), p-names, formals, temp-list)

Event: Disable s-proper-exprp-list-s-proper-get-t.

Theorem: s-proper-exprp-s-proper-exprp-cur-expr (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)

Theorem: s-good-statep-s-proper-exprp-cur-expr (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)))

Theorem: s-proper-exprp-definedp (s-proper-exprp (t, body, p-names, formals, temp-list) ∧ ((car (body) = s-temp-eval)

∨ (car (body) = s-temp-fetch) ∨ (car (body) = s-temp-test)))

→ (cadr (body) ∈ temp-list)

Theorem: s-good-statep-definedp-temps (s-good-statep (s, c) ∧ good-posp1 (s-pos (s), s-body (s-prog (s))) ∧ ((car (s-expr (s)) = s-temp-eval)

∨ (car (s-expr (s)) = s-temp-fetch) ∨ (car (s-expr (s)) = s-temp-test)))

→ definedp (cadr (s-expr (s)), s-temps (s))

Theorem: strip-cars-s-temps-s-eval (s-err-flag (s-eval (flag, state, clock)) = 'run) → (strip-cars (s-temps (s-eval (flag, state, clock)))

= strip-cars (s-temps (state)))

Theorem: temps-okp-make-temps-entries temps-okp (make-temps-entries (x), params, c)

Theorem: l-eval-flag-not-list (flag ≠ 'list) → (l-eval (flag, expr, params, clock) = l-eval (t, expr, params, clock))

Theorem: strip-cars-make-temps-entries strip-cars (make-temps-entries (x)) = plist (x)

Theorem: s-err-flag-s-eval-flag-list-flag-t ((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))) → (s-err-flag (s-eval (t, s, c)) = 'run)

Theorem: good-posp1-append good-posp1 (append (pos1 , pos2 ), body) = (good-posp1 (pos1 , body) ∧ good-posp1 (pos2 , cur-expr (pos1 , body)))

Theorem: cur-expr-nlistp (expr ≃ nil) → (listp (cur-expr (pos, expr)) = f)

Theorem: good-posp1-nlistp (¬ listp (pos)) → good-posp1 (pos, body)

Theorem: good-posp1-list-good-posp-list-t (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)

Theorem: good-posp-flag-not-list-good-posp1 (flag ≠ 'list) → (good-posp (flag, pos, body) = good-posp1 (pos, body))

Theorem: good-posp-list-t (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)))

Theorem: s-prog-s-eval-do-s-temp-fetch s-prog (s-eval-do-temp-fetch (state)) = s-prog (state)

Theorem: s-prog-s-eval (s-err-flag (s-eval (flag, s, c)) = 'run) → (s-prog (s-eval (flag, s, c)) = s-prog (s))

Theorem: good-posp-list-nx (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)))

Theorem: car-s-expr-list-s-expr (listp (s-expr-list (s)) ∧ listp (s-pos (s))) → (car (s-expr-list (s)) = s-expr (s))

Theorem: l-eval-s-expand-temps-flag-list-fact-1 l-eval ('list, s-expand-temps ('list, body), params, clock) = if listp (body)

then cons (l-eval (t, s-expand-temps (t, car (body)), params, clock),

l-eval ('list, s-expand-temps ('list, cdr (body)), params, clock))

else nil endif

;; 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.

Theorem: l-eval-s-expand-temps-flag-list-s-expr-fact-1 l-eval ('list, s-expand-temps ('list, s-expr-list (s)), params, clock) = if listp (s-expr-list (s))

then 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))

else nil endif

Theorem: l-eval-s-expand-temps-litatom-fact-1 ((clock ≄ 0) ∧ litatom (body) ∧ (flag ≠ 'list)) → (l-eval (flag, s-expand-temps (flag, body), params, clock)

= list (cdr (assoc (body, params))))

Theorem: s-proper-exprp-length-cur-expr (s-proper-exprp (t, expr, p-names, formals, temp-list) ∧ listp (expr) ∧ (subrp (car (expr)) ∨ body (car (expr))) ∧ (car (expr) ≠ 'quote)) → (length (expr) = (1 + arity (car (expr))))

Theorem: good-posp1-cons-lessp-4-if ((car (s-expr (s)) = 'if) ∧ s-good-statep (s, c)) → ((good-posp1 (dv (s-pos (s), 1), s-body (s-prog (s)))

= good-posp1 (s-pos (s), s-body (s-prog (s)))) ∧ (good-posp1 (dv (s-pos (s), 2), s-body (s-prog (s))) = good-posp1 (s-pos (s), s-body (s-prog (s)))) ∧ (good-posp1 (dv (s-pos (s), 3), s-body (s-prog (s))) = good-posp1 (s-pos (s), s-body (s-prog (s)))))

Theorem: l-eval-if-fact-1 ((car (expr) = 'if) ∧ (flag ≠ 'list)) → (l-eval (flag, s-expand-temps (flag, expr), params, clock)

= if l-eval (t, s-expand-temps (t, cadr (expr)), params, clock)

then if car (l-eval (t, s-expand-temps (t, cadr (expr)), params, clock))

then l-eval (t, s-expand-temps (t, caddr (expr)), params, clock) else l-eval (t,

s-expand-temps (t, cadddr (expr)), params, clock) endif

else f endif)

Theorem: s-good-statep-s-eval-do-temp-fetch (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)

Theorem: good-posp1-dv-1-temps (((car (s-expr (s)) = s-temp-eval) ∨ (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)))

Theorem: s-eval-l-eval-s-temps ((flag ≠ 'list) ∧ ((car (expr) = s-temp-eval)

∨ (car (expr) = s-temp-fetch) ∨ (car (expr) = s-temp-test)))

→ (l-eval (flag, s-expand-temps (flag, expr), params, clock)

= l-eval (t, s-expand-temps (t, cadr (expr)), params, clock))

Theorem: l-eval-quote-fact-1 ((car (expr) = 'quote) ∧ (flag ≠ 'list) ∧ (clock ≄ 0)) → (l-eval (flag, s-expand-temps (flag, expr), params, clock)

= list (cadr (expr)))

Theorem: listp-not-lessp-length-1 listp (x) → ((length (x) < 1) = f)

Event: Disable listp-not-lessp-length-1.

Theorem: good-posp1-plist good-posp1 (plist (pos), body) = good-posp1 (pos, body)

Theorem: good-posp-dv-1-funcall (listp (s-expr (s)) ∧ (car (s-expr (s)) ≠ 'if) ∧ (car (s-expr (s)) ≠ s-temp-eval) ∧ (car (s-expr (s)) ≠ s-temp-test) ∧ (car (s-expr (s)) ≠ s-temp-fetch) ∧ (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)))

Theorem: l-eval-s-expand-temps-subrp-fact-1 (subrp (car (e)) ∧ (car (e) ≠ 'if) ∧ (clock ≄ 0) ∧ (f ∉ l-eval ('list, s-expand-temps ('list, cdr (e)), params, clock)) ∧ (flag ≠ 'list)) → (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)))))

Theorem: logic-fname-user-fname-identity litatom (x) → (logic-fname (user-fname (x)) = x)

Theorem: user-fname-logic-fname-identity user-fnamep (x) → (user-fname (logic-fname (x)) = x)

Theorem: member-strip-logic-fnames-definedp (all-user-fnamesp (strip-cars (y)) ∧ litatom (x)) → ((x ∈ strip-logic-fnames (y)) = definedp (user-fname (x), y))

Theorem: s-programs-okp-all-user-fnamesp-strip-cars s-programs-okp (programs) → all-user-fnamesp (strip-cars (programs))

Theorem: s-proper-exprp-definedp-programs (s-proper-exprp (t, body, strip-logic-fnames (programs), formals, temp-list) ∧ listp (body) ∧ s-programs-okp (programs) ∧ (¬ subrp (car (body))) ∧ (car (body) ≠ 'quote) ∧ litatom (car (body))) → definedp (user-fname (car (body)), programs)

Theorem: s-good-statep-s-fun-call-state (s-good-statep (s1 , c) ∧ s-good-statep (s2 , c) ∧ listp (s-expr (s1 )) ∧ (car (s-expr (s1 )) ≠ 'if) ∧ (car (s-expr (s1 )) ≠ 'quote) ∧ (¬ subrp (car (s-expr (s1 )))) ∧ litatom (car (s-expr (s1 ))) ∧ good-posp1 (s-pos (s1 ), s-body (s-prog (s1 ))) ∧ (s-progs (s1 ) = s-progs (s2 ))) → s-good-statep (s-fun-call-state (s2 , car (s-expr (s1 ))), c − 1)

Theorem: good-posp1-flag-not-list-nil good-posp1 (nil, body)

Theorem: l-eval-s-expand-temps-not-subrp-fact-1 ((¬ subrp (car (e))) ∧ listp (e) ∧ (¬ listp (car (e))) ∧ (clock ≄ 0) ∧ (car (e) ≠ 'quote) ∧ (f ∉ l-eval ('list, s-expand-temps ('list, cdr (e)), params, clock)) ∧ (flag ≠ 'list)) → (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))),

clock − 1))

Theorem: s-programs-okp-formals-body (s-programs-okp (progs) ∧ (prog ∈ progs)) → ((s-formals (prog) = formals (logic-fname (car (prog))))

∧ (s-expand-temps (t, s-body (prog)) = body (logic-fname (car (prog)))))

Theorem: s-good-statep-not-car-s-expr-caar-s-progs (good-posp1 (s-pos (s), s-body (s-prog (s))) ∧ listp (s-expr (s)) ∧ (car (s-expr (s)) ≠ 'quote) ∧ (¬ subrp (car (s-expr (s)))) ∧ litatom (car (s-expr (s))) ∧ listp (s-progs (s)) ∧ (user-fname (car (s-expr (s))) = caar (s-progs (s)))) → (¬ s-good-statep (s, c))

Event: Disable s-good-statep-not-car-s-expr-caar-s-progs.

Theorem: s-expand-temps-s-expr-s-fun-call-state (s-good-statep (s1 , c) ∧ s-good-statep (s2 , c) ∧ listp (s-expr (s1 ))

∧ good-posp1 (s-pos (s1 ), s-body (s-prog (s1 ))) ∧ (car (s-expr (s1 )) ≠ 'quote) ∧ (¬ subrp (car (s-expr (s1 )))) ∧ litatom (car (s-expr (s1 ))) ∧ (s-progs (s1 ) = s-progs (s2 ))) → (s-expand-temps (t, s-expr (s-fun-call-state (s2 , car (s-expr (s1 )))))

= body (car (s-expr (s1 ))))

Theorem: s-good-statep-formals (s-good-statep (s, c) ∧ listp (s-expr (s)) ∧ (car (s-expr (s)) ≠ 'if) ∧ (car (s-expr (s)) ≠ 'quote) ∧ (¬ subrp (car (s-expr (s)))) ∧ good-posp1 (s-pos (s), s-body (s-prog (s))) ∧ litatom (car (s-expr (s)))) → (s-formals (assoc (user-fname (car (s-expr (s))), s-progs (s)))

= formals (car (s-expr (s))))

Theorem: definedp-temps-okp (temps-okp (temps, params, c) ∧ definedp (expr, temps) ∧ s-temp-setp (expr, temps)) → (l-eval (t, s-expand-temps (t, expr), params, c)

∧ (car (l-eval (t, s-expand-temps (t, expr), params, c))

= s-temp-value (expr, temps)))

Theorem: l-eval-s-eval-do-temp-fetch-fact-1 (good-posp1 (s-pos (s), s-body (s-prog (s))) ∧ listp (s-expr (s)) ∧ ((car (s-expr (s)) = s-temp-fetch)

∨ (car (s-expr (s)) = s-temp-test)) ∧ s-temp-setp (cadr (s-expr (s)), s-temps (s)) ∧ s-good-statep (s, c)) → (l-eval (t, s-expand-temps (t, cadr (s-expr (s))), s-params (s), c)

∧ (car (l-eval (t, s-expand-temps (t, cadr (s-expr (s))), s-params (s), c)) = s-ans (s-eval-do-temp-fetch (s))))

Theorem: s-eval-l-eval-equivalence (s-good-statep (s, c) ∧ good-posp (flag, s-pos (s), s-body (s-prog (s))) ∧ (s-err-flag (s-eval (flag, s, c)) = 'run)) → (s-good-statep (s-eval (flag, s, c), c)

∧ if flag = 'list then (f ∉ l-eval (flag, s-expand-temps (flag, s-expr-list (s)), s-params (s), c)) ∧ (s-ans (s-eval (flag, s, c))

= strip-cars (l-eval (flag,

s-expand-temps (flag,

s-expr-list (s)),

s-params (s),

c)))

else l-eval (flag, s-expand-temps (flag, s-expr (s)), s-params (s), c)

∧ (s-ans (s-eval (flag, s, c)) = car (l-eval (flag,

s-expand-temps (flag,

s-expr (s)),

s-params (s), c))) endif)

Theorem: s-eval-s-good-statep (s-good-statep (s, c) ∧ good-posp (flag, s-pos (s), s-body (s-prog (s))) ∧ (s-err-flag (s-eval (flag, s, c)) = 'run)) → s-good-statep (s-eval (flag, s, c), c)

Theorem: s-eval-l-eval-flag-t (s-good-statep (s, c) ∧ good-posp1 (s-pos (s), s-body (s-prog (s))) ∧ (s-err-flag (s-eval (t, s, c)) = 'run)) → (l-eval (t, s-expand-temps (t, s-expr (s)), s-params (s), c)

∧ (s-ans (s-eval (t, s, c)) = car (l-eval (t,

s-expand-temps (t, s-expr (s)), s-params (s), c))))

Definition: s-collect-all-temps (flag, expr) = if flag = 'list

then if listp (expr)

then append (s-collect-all-temps (t, car (expr)),

s-collect-all-temps ('list, cdr (expr)))

else nil endif elseif listp (expr) then if (car (expr) = s-temp-test) ∨ (car (expr) = s-temp-eval)

then cons (cadr (expr), s-collect-all-temps (t, cadr (expr))) elseif car (expr) = s-temp-fetch then s-collect-all-temps (t, cadr (expr)) elseif car (expr) = 'quote then nil elseif car (expr) = 'if then append (s-collect-all-temps (t, cadr (expr)),

bagint (s-collect-all-temps (t, caddr (expr)),

s-collect-all-temps (t, cadddr (expr))))

else s-collect-all-temps ('list, cdr (expr)) endif else nil endif

;; 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

Definition: s-all-temps-setp (flag, expr, temp-set) = if flag = 'list

then if listp (expr)

then 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))

else t endif elseif listp (expr) then if (car (expr) = s-temp-eval) ∨ (car (expr) = s-temp-test)

then s-all-temps-setp (t, cadr (expr), temp-set) elseif car (expr) = s-temp-fetch then cadr (expr) ∈ temp-set elseif car (expr) = 'quote then t elseif car (expr) = 'if then if s-all-temps-setp (t, cadr (expr), temp-set)

then let test-temp-set be s-collect-all-temps (t,

cadr (expr))

in

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)) endlet

else f endif else s-all-temps-setp ('list, cdr (expr), temp-set) endif

else t endif

Definition: temp-alist-to-set-1 (alist, acc) = if listp (alist)

then if listp (car (alist)) ∧ cadar (alist) ∧ (caar (alist) ∉ acc)

then cons (caar (alist),

temp-alist-to-set-1 (cdr (alist), cons (caar (alist), acc)))

else temp-alist-to-set-1 (cdr (alist), cons (caar (alist), acc)) endif else nil endif

Theorem: temp-alist-to-set-1-gives-members (x ∈ temp-alist-to-set-1 (alist, acc)) = (listp (assoc (x, alist)) ∧ s-temp-setp (x, alist) ∧ (x ∉ acc))

Definition: temp-alist-to-set (alist) = temp-alist-to-set-1 (alist, nil)

Event: Disable temp-alist-to-set.

Theorem: temp-alist-to-set-gives-members (x ∈ temp-alist-to-set (alist)) = (listp (assoc (x, alist)) ∧ s-temp-setp (x, alist))

Definition: s-check-temps-setp-1 (exprs, temp-set) = if listp (exprs)

then ((car (exprs) ∉ temp-set)

∨ subsetp (s-collect-all-temps (t, car (exprs)), temp-set))

∧ s-check-temps-setp-1 (cdr (exprs), temp-set) else t endif

Definition: good-alistp (alist) = if listp (alist) then listp (car (alist)) ∧ good-alistp (cdr (alist))

else t endif

Theorem: good-alistp-listp-assoc good-alistp (alist) → (definedp (expr, alist) ↔ listp (assoc (expr, alist)))

Event: Disable good-alistp-listp-assoc.

Theorem: good-alistp-put-assoc good-alistp (alist) → good-alistp (put-assoc (val, expr, alist))

Definition: s-check-temps-setp (temp-alist) = (good-alistp (temp-alist)

∧ s-check-temps-setp-1 (strip-cars (temp-alist), temp-alist-to-set (temp-alist)))

Event: Disable s-check-temps-setp.

Definition: s-all-progs-temps-setp (progs) = if listp (progs)

then 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))

else t endif

Event: Disable s-all-progs-temps-setp.

Theorem: subsetp-member (subsetp (set1 , set2 ) ∧ (x ∈ set1 )) → (x ∈ set2 )

Event: Disable subsetp-member.

Theorem: subsetp-append-1 subsetp (append (set1 , set2 ), set3 ) = (subsetp (set1 , set3 ) ∧ subsetp (set2 , set3 ))

Theorem: subsetp-cons subsetp (set1 , set2 ) → subsetp (set1 , cons (x, set2 ))

Theorem: subsetp-reflexive subsetp (set, set)

Theorem: subsetp-append-2 (subsetp (set1 , set2 ) ∨ subsetp (set1 , set3 )) → subsetp (set1 , append (set2 , set3 ))

Theorem: temp-alist-to-set-1-subsetp subsetp (acc1 , acc2 ) → subsetp (temp-alist-to-set-1 (temp-alist, acc2 ),

temp-alist-to-set-1 (temp-alist, acc1 ))

Theorem: temp-alist-to-set-1-nlistp (¬ listp (temp-alist-to-set-1 (alist, acc))) → (temp-alist-to-set-1 (alist, acc) = nil)

Theorem: temp-alist-to-set-1-cons-nil (temp-alist-to-set-1 (temp-alist, acc) = nil) → (temp-alist-to-set-1 (temp-alist, cons (x, acc)) = nil)

Theorem: temp-alist-to-set-1-make-temp-entries temp-alist-to-set-1 (make-temps-entries (temp-alist), acc) = nil

Theorem: temp-alist-to-set-make-temp-entries temp-alist-to-set (make-temps-entries (temp-alist)) = nil

Theorem: s-all-temps-setp-subsetp (subsetp (temp-set1 , temp-set2 ) ∧ s-all-temps-setp (flag, expr, temp-set1 )) → s-all-temps-setp (flag, expr, temp-set2 )

Theorem: subsetp-transistive (subsetp (set1 , set2 ) ∧ subsetp (set2 , set3 )) → subsetp (set1 , set3 )

Event: Disable subsetp-transistive.

Theorem: s-temp-setp-put-assoc-1 s-temp-setp (expr1 , put-assoc (cons (t, anything), expr2 , temp-alist)) ↔ if expr1 = expr2 then t

else s-temp-setp (expr1 , temp-alist) endif

Theorem: listp-assoc-fact-1 listp (assoc (expr1 , temp-alist)) → listp (assoc (expr1 , put-assoc (cons (x, y), expr2 , temp-alist)))

Theorem: subsetp-temp-alist-to-set-put-assoc-1 definedp (expr, temp-alist) → (subsetp (set1 ,

temp-alist-to-set (put-assoc (cons (t, anything), expr, temp-alist))) = subsetp (set1 , cons (expr, temp-alist-to-set (temp-alist))))

Theorem: subsetp-temp-alist-to-set-s-change-temp definedp (expr, s-temps (st)) → (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)))))

Theorem: not-definedp-put-assoc (¬ definedp (expr, temp-alist)) → (put-assoc (anything, expr, temp-alist) = temp-alist)

Theorem: subsetp-trans-fact-2 subsetp (set, temp-alist-to-set (s-temps (st))) → subsetp (set, temp-alist-to-set (s-temps (s-change-temp (st, expr, value))))

Theorem: s-eval-temps-subsetp (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))))

Theorem: subsetp-delete subsetp (set1 , set2 ) → subsetp (delete (x, set1 ), set2 )

Theorem: subsetp-bagint (subsetp (set1 , set3 ) ∨ subsetp (set2 , set3 )) → subsetp (bagint (set1 , set2 ), set3 )

Theorem: l-eval-zerop-clock ((clock ≃ 0) ∧ (flag ≠ 'list)) → (l-eval (flag, expr, params, clock) = f)

Theorem: s-eval-temps-subsetp-s-set-pos (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))))

Theorem: s-all-temps-setp-subsetp-if-caddr let test be s-eval (t, s-set-pos (s, dv (s-pos (s), 1)), c) in let set1 be s-collect-all-temps (t, cadr (s-expr (s))),

set2 be temp-alist-to-set (s-temps (test)), set3 be temp-alist-to-set (s-temps (s))

in ((s-err-flag (test) = 'run) ∧ (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 ) endlet endlet

Theorem: s-all-temps-setp-subsetp-if-cadddr let test be s-eval (t, s-set-pos (s, dv (s-pos (s), 1)), c) in let set1 be s-collect-all-temps (t, cadr (s-expr (s))),

set2 be temp-alist-to-set (s-temps (test)), set3 be temp-alist-to-set (s-temps (s))

in ((s-err-flag (test) = 'run) ∧ (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 ) endlet endlet Theorem: s-eval-temps-subsetp-s-set-expr (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))))

Theorem: s-eval-l-eval-flag-run-helper-1 let test be s-eval (t, s-set-pos (s, dv (s-pos (s), 1)), c) in ((s-err-flag (s) = 'run) ∧ (car (s-expr (s)) = 'if) ∧ (s-err-flag (test) = 'run) ∧ (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)))) endlet

Event: Disable s-eval-l-eval-flag-run-helper-1.

Theorem: s-eval-l-eval-flag-run-helper-2 let test be s-eval (t, s-set-pos (s, dv (s-pos (s), 1)), c) in ((s-err-flag (s) = 'run) ∧ (car (s-expr (s)) = 'if) ∧ (s-err-flag (test) = 'run) ∧ (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)))) endlet

Event: Disable s-eval-l-eval-flag-run-helper-2.

Theorem: s-temp-setp-s-change-temp s-temp-setp (expr1 , s-temps (s-change-temp (state, expr2 , value))) ↔ if expr1 = expr2 then t

else s-temp-setp (expr1 , s-temps (state)) endif

Theorem: s-good-statep-listp-assoc-temps (s-good-statep (s, c) ∧ s-check-temps-setp (s-temps (s)) ∧ ((car (s-expr (s)) = s-temp-fetch)

∨ (car (s-expr (s)) = s-temp-eval) ∨ (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)))

Theorem: listp-assoc-s-change-temp (s-good-statep (s1 , c) ∧ ((car (s-expr (s1 )) = s-temp-fetch)

∨ (car (s-expr (s1 )) = s-temp-eval) ∨ (car (s-expr (s1 )) = s-temp-test))

∧ good-posp1 (s-pos (s1 ), s-body (s-prog (s1 ))) ∧ (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))))

Theorem: s-check-temps-setp-1-cons-non-member (s-check-temps-setp-1 (temp-list, temp-set) ∧ (expr ∉ temp-list)) → s-check-temps-setp-1 (temp-list, cons (expr, temp-set))

Theorem: s-check-temps-setp-1-cons-member (s-check-temps-setp-1 (temp-list, temp-set) ∧ (expr ∈ temp-list) ∧ subsetp (s-collect-all-temps (t, expr), temp-set)) → s-check-temps-setp-1 (temp-list, cons (expr, temp-set))

Theorem: s-check-temps-setp-1-put-assoc (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)))

Theorem: s-check-temps-setp-put-assoc let cadr-s be s-eval (t, s-set-pos (s, dv (s-pos (s), 1)), c) in (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)))

∧ ((car (s-expr (s)) = s-temp-test)

∨ (car (s-expr (s)) = s-temp-eval))) → s-check-temps-setp (s-temps (s-change-temp (cadr-s,

cadr (s-expr (s)), value))) endlet

Theorem: member-check-s-temp-setp-1-subsetp (s-check-temps-setp-1 (temp-list, set) ∧ (expr ∈ set) ∧ (expr ∈ temp-list)) → subsetp (s-collect-all-temps (t, expr), set)

Theorem: s-eval-l-eval-flag-run-helper-3 (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))) ∧ ((car (s-expr (s)) = s-temp-test)

∨ (car (s-expr (s)) = s-temp-fetch))) → subsetp (s-collect-all-temps (t, cadr (s-expr (s))),

temp-alist-to-set (s-temps (s)))

Theorem: s-eval-l-eval-flag-run-helper-5 ((f ∈ l-eval ('list,

s-expand-temps ('list, cdr (s-expr (state))), s-params (state), clock))

∧ listp (s-expr (state)) ∧ (car (s-expr (state)) ≠ 'if) ∧ (car (s-expr (state)) ≠ 'quote) ∧ (car (s-expr (state)) ≠ s-temp-eval) ∧ (car (s-expr (state)) ≠ s-temp-fetch) ∧ (car (s-expr (state)) ≠ s-temp-test) ∧ (flag ≠ 'list)) → (¬ l-eval (flag,

s-expand-temps (flag, s-expr (state)), s-params (state), clock))

Theorem: s-check-temps-setp-member-progs (s-all-progs-temps-setp (progs) ∧ (x ∈ progs)) → s-check-temps-setp (make-temps-entries (s-temp-list (x)))

Theorem: s-all-temps-setp-member-progs (s-all-progs-temps-setp (progs) ∧ (x ∈ progs)) → s-all-temps-setp (t, s-body (x), nil)

Theorem: s-check-temps-setp-s-all-progs-temps-setp (s-all-progs-temps-setp (s-progs (s)) ∧ (¬ subrp (car (s-expr (s)))) ∧ litatom (car (s-expr (s))) ∧ listp (s-expr (s)) ∧ (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)))))

Theorem: s-eval-l-eval-flag-run-helper-6 (l-eval (flag, s-expand-temps (flag, s-expr (s)), s-params (s), c) ∧ (flag ≠ 'list) ∧ listp (s-expr (s)) ∧ (car (s-expr (s)) ≠ s-temp-eval) ∧ (car (s-expr (s)) ≠ s-temp-test) ∧ (car (s-expr (s)) ≠ s-temp-fetch) ∧ (¬ subrp (car (s-expr (s)))) ∧ (car (s-expr (s)) ≠ 'if) ∧ litatom (car (s-expr (s)))

∧ (car (s-expr (s)) ≠ 'quote) ∧ s-good-statep (s, c) ∧ good-posp1 (s-pos (s), s-body (s-prog (s))) ∧ (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))), c − 1)

Theorem: s-all-temps-setp-s-all-progs-temps-setp (s-all-progs-temps-setp (s-progs (s1 )) ∧ (¬ subrp (car (s-expr (s1 )))) ∧ litatom (car (s-expr (s1 ))) ∧ (car (s-expr (s1 )) ≠ 'quote) ∧ s-good-statep (s1 , c) ∧ good-posp1 (s-pos (s1 ), s-body (s-prog (s1 ))) ∧ (s-progs (s1 ) = s-progs (s2 ))) → s-all-temps-setp (t, s-expr (s-fun-call-state (s2 , car (s-expr (s1 )))), nil)

Theorem: s-proper-exprp-fact-2 (good-posp1 (s-pos (s), s-body (s-prog (s))) ∧ (¬ litatom (s-expr (s))) ∧ (¬ listp (s-expr (s)))) → (¬ s-good-statep (s, c))

Theorem: s-all-temps-setp-subsetp-flag-list ((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))))

Theorem: not-s-good-statep-bad-car-expr (listp (s-expr (s)) ∧ (car (s-expr (s)) ≠ 'if) ∧ (car (s-expr (s)) ≠ s-temp-eval) ∧ (car (s-expr (s)) ≠ s-temp-test)

∧ (car (s-expr (s)) ≠ s-temp-fetch) ∧ (car (s-expr (s)) ≠ 'quote) ∧ (¬ litatom (car (s-expr (s)))) ∧ good-posp1 (s-pos (s), s-body (s-prog (s)))) → (¬ s-good-statep (s, c))

Theorem: s-eval-l-eval-flag-run-helper-7 ((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))))

Theorem: not-listp-pos-not-good-posp (¬ listp (pos)) → (¬ good-posp ('list, pos, body))

Theorem: s-eval-l-eval-flag-run (s-good-statep (s, c) ∧ good-posp (flag, s-pos (s), s-body (s-prog (s))) ∧ s-all-temps-setp (flag,

if flag = 'list then s-expr-list (s) else s-expr (s) endif, temp-alist-to-set (s-temps (s)))

∧ s-all-progs-temps-setp (s-progs (s)) ∧ if flag = 'list

then f ∉ l-eval (flag, s-expand-temps (flag, s-expr-list (s)), s-params (s), c)

else l-eval (flag, s-expand-temps (flag, s-expr (s)), s-params (s), c) endif ∧ s-check-temps-setp (s-temps (s))) → ((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 flag = 'list then s-expr-list (s) else s-expr (s) endif),

temp-alist-to-set (s-temps (s-eval (flag, s, c)))))

Definition: s-construct-programs (fun-list) = if listp (fun-list)

then cons (list (user-fname (car (fun-list)), formals (car (fun-list)), nil, body (car (fun-list))),

s-construct-programs (cdr (fun-list)))

else nil endif

Definition: delete-all (x, l) = if listp (l)

then if x = car (l) then delete-all (x, cdr (l))

else cons (car (l), delete-all (x, cdr (l))) endif else l endif

Theorem: delete-all-non-decreasing-count count (l) ≮ count (delete-all (x, l))

Definition: remove-duplicates (l) = if listp (l)

then cons (car (l), remove-duplicates (delete-all (car (l), cdr (l)))) else l endif

Definition: 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)))

Definition: l-proper-exprp (flag, body, program-names, formals) = if flag = 'list

then if listp (body)

then l-proper-exprp (t, car (body), program-names, formals)

∧ l-proper-exprp ('list, cdr (body), program-names, formals)

else body = nil endif elseif listp (body) then if ¬ plistp (body) then f

elseif car (body) = 'quote then length (cdr (body)) = arity (car (body)) elseif subrp (car (body)) then (length (cdr (body)) = arity (car (body)))

∧ (car (body) ∉ program-names) ∧ l-proper-exprp ('list,

cdr (body),

program-names, formals)

elseif body (car (body)) then (length (cdr (body)) = arity (car (body)))

∧ (car (body) ∈ program-names) ∧ l-proper-exprp ('list,

cdr (body),

program-names, formals)

else f endif elseif litatom (body) then body ∈ formals else f endif

Definition: l-proper-programsp-1 (program-names, all-program-names) = if listp (program-names)

then 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)

else t endif

Definition: l-proper-programsp (program-names) = l-proper-programsp-1 (program-names, program-names)

Event: Disable l-proper-programsp.

Theorem: definedp-assoc-fact-1 (¬ definedp (expr, alist)) → (¬ assoc (expr, alist))

Event: Disable definedp-assoc-fact-1.

Definition: all-litatoms-not-plist (list) = if listp (list)

then litatom (car (list)) ∧ all-litatoms-not-plist (cdr (list))

else t endif

Theorem: strip-logic-fnames-s-construct-programs all-litatoms-not-plist (program-names) → (strip-logic-fnames (s-construct-programs (program-names))

= plist (program-names))

Theorem: l-proper-expr-functions-definedp-s-proper-expr l-proper-exprp (flag, prog, all-program-names, formals) → s-proper-exprp (flag, prog, all-program-names, formals, temp-list)

Theorem: s-programs-properp-s-construct-programs l-proper-programsp-1 (program-names, all-program-names) → s-programs-properp (s-construct-programs (program-names),

all-program-names)

Theorem: s-proper-exprp-plist s-proper-exprp (flag, expr, plist (program-names), formals, temp-list) = s-proper-exprp (flag, expr, program-names, formals, temp-list)

Theorem: s-proper-programsp-plist s-programs-properp (programs, plist (program-names)) = s-programs-properp (programs, program-names)

Theorem: s-expand-temps-body-equal-body l-proper-exprp (flag, expr, all-program-names, formals) → (s-expand-temps (flag, expr) = expr)

Theorem: l-proper-programsp-1-delete-all l-proper-programsp-1 (program-names, all-program-names) → l-proper-programsp-1 (delete-all (name, program-names), all-program-names)

Theorem: user-fnamep-user-fname user-fnamep (user-fname (x))

Theorem: logic-fname-user-fname-identity-formals formals (x) → (logic-fname (user-fname (x)) = x)

Theorem: s-programs-okp-s-construct-programs l-proper-programsp-1 (program-names, all-program-names) → s-programs-okp (s-construct-programs (remove-duplicates (program-names)))

Event: Disable logic-fname-user-fname-identity-formals.

Theorem: s-eval-l-eval-flag-run-flag-t (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)) ∧ (flag ≠ 'list)) → ((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)))))

Theorem: l-proper-expr-s-all-temps-setp l-proper-exprp (flag, expr, prog-names, formals) → s-all-temps-setp (flag, expr, temp-set)

Theorem: l-proper-programsp-1-s-all-progs-temps-setp l-proper-programsp-1 (program-names, all-program-names) → s-all-progs-temps-setp (s-construct-programs (program-names))

Theorem: l-proper-programsp-s-all-progs-temps-setp l-proper-programsp (program-names) → s-all-progs-temps-setp (s-construct-programs (program-names))

Theorem: member-delete-all (x ∈ delete-all (y, l)) = if x ∈ l then x ≠ y

else f endif Theorem: member-remove-duplicates (e ∈ remove-duplicates (x)) = (e ∈ x)

Theorem: s-proper-exprp-remove-duplicates s-proper-exprp (flag, expr, remove-duplicates (prog-names), formals, temp-list) = s-proper-exprp (flag, expr, prog-names, formals, temp-list)

Theorem: l-proper-exprp-remove-duplicates l-proper-exprp (flag, expr, remove-duplicates (prog-names), formals) = l-proper-exprp (flag, expr, prog-names, formals)

Theorem: l-proper-programs-remove-duplicates-arg2 l-proper-programsp-1 (program-names, remove-duplicates (all-program-names)) = l-proper-programsp-1 (program-names, all-program-names)

Theorem: l-proper-programs-remove-duplicates-arg1 l-proper-programsp-1 (program-names, all-program-names) → l-proper-programsp-1 (remove-duplicates (program-names),

all-program-names)

Theorem: all-litatoms-not-plist-delete-all all-litatoms-not-plist (list) → all-litatoms-not-plist (delete-all (x, list))

Theorem: all-litatoms-not-plist-remove-duplicates all-litatoms-not-plist (list) → all-litatoms-not-plist (remove-duplicates (list))

Theorem: all-litatoms-not-plist-lr-proper-programsp-1 l-proper-programsp-1 (prog-names, all-prog-names) → all-litatoms-not-plist (prog-names)

Theorem: s-good-state-s-construct-programs (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)

Theorem: l-proper-programsp-remove-duplicates l-proper-programsp (program-names) → l-proper-programsp (remove-duplicates (program-names))

Theorem: logic->s-ok (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)) → (s-ans (s-eval (t, logic->s (expr, alist, program-names), clock))

= car (l-eval (t, expr, alist, clock)))

Theorem: logic->s-ok-really (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) ∧ (cdr (v&c$ (t, expr, alist)) < clock)) → (s-ans (s-eval (t, logic->s (expr, alist, program-names), clock))

= car (v&c$ (t, expr, alist)))

Event: Make the library "app-c-d-e" and compile it.

Index

add-addr, 130, 174 add-addr-preserves-p-invariant, 263 add-adp, 128–130 add-int-preserves-p-invariant, 265 add-int-with-carry-preserves-p-i

nvariant, 265 add-nat-preserves-p-invariant, 265 add-nat-with-carry-preserves-p-i

nvariant, 263 add1-addr, 130, 139, 142 add1-adp, 129 add1-int-preserves-p-invariant, 265 add1-nat-preserves-p-invariant, 263 add1-p-pc, 139, 149, 151–161, 163,

165–168, 173–199 add1-p-pcp, 139 addition, 13 addressp, 130 adp-name, 128–130 adp-offset, 128–130 adpp, 128, 130, 138, 229, 239 all-but-last, 136 all-find-labelp, 138, 215 all-integer-defns, 44 all-litatoms, 222, 223, 239, 240, 296,

321, 324, 325 all-litatoms-formal-vars, 240 all-litatoms-formal-vars-genera

lized, 240 all-litatoms-not-plist, 322, 324 all-litatoms-not-plist-delete-a

ll, 324 all-litatoms-not-plist-lr-prope

r-programsp-1, 324 all-litatoms-not-plist-remove-d

uplicates, 324 all-p-objectps, 138, 224, 239 all-user-fnamesp, 297, 305 all-zero-bitvp, 136, 172 and-bit, 135 and-bitv, 135, 195 and-bitv-preserves-p-invariant, 266 and-bool, 132, 198 and-bool-preserves-p-invariant, 266 and-not-zerop-tree, 17, 19, 20, 31,

32 app, 276 append-butlast-lastcdr, 290 append-firstn-restn, 120 append-init-init, 120 append-init-list, 120 append-lastcdr-arg1, 120 append-lastcdr-arg2, 120 append-left-id, 119 append-nil, 119 append-plist, 120 append-plist-lastcdr, 120 area-name, 130, 139, 166, 176, 223,

225 arity, 295, 296, 303, 321 assoc-put-assoc-1, 237 assoc-put-assoc-2, 237 associativity-of-append, 119 associativity-of-append-inverse, 119 associativity-of-gcd, 37 associativity-of-gcd-zero-case, 37 associativity-of-iplus, 47 associativity-of-itimes, 62 associativity-of-plus, 5 associativity-of-times, 14 augment-displayed-p-state, 226

bagdiff, 1, 3, 8, 10, 11, 13, 20–22, 31, 32, 55–57, 59–61, 70, 73, 75–79, 83, 96, 97, 99, 100

bagdiff-delete, 3

bagint, 2, 3, 10, 11, 13, 19–22, 31, 55, 56, 59–61, 71, 75–78, 83, 86, 97, 98, 101, 309, 313 bagint-singleton, 98 bags, 3 bindings, 139, 149, 160, 161, 223,

226, 230, 231, 233 bindings-p-frame, 230 bit-vectorp, 134, 138, 229, 239 bitp, 134 bool, 132, 175, 176, 179, 182, 184,

187, 190, 191, 193 bool-to-nat, 133, 179, 181, 186, 190 booleanp, 132, 138, 229, 239 bridge-to-subbagp-implies-plus-t

ree-greatereqp, 8 butlast, 283, 284, 290, 291, 297, 302 butlast-append, 290 butlast-dv, 291 butlast-nx, 290 butlast-singleton-list, 290

cadr-eval$-list, 9 call-preserves-p-invariant, 267 cancel-constants-equal, 114 cancel-constants-equal-lemma, 114 cancel-constants-ilessp, 115 cancel-constants-ilessp-lemma-1, 114 cancel-constants-ilessp-lemma-2, 115 cancel-difference-plus, 11 cancel-equal-plus, 10 cancel-equal-times, 20, 22 cancel-equal-times-preserves-ineq

uality, 21 uality-bridge, 21

cancel-factors-0, 102, 103 cancel-factors-ilessp-0, 104 cancel-ineg, 50, 52 cancel-ineg-aux, 48–52 cancel-ineg-terms-from-equality, 107,

110 -cancel-ineg-terms-from-equality-

expanded, 110 -expanded, 107, 108, 110, 111

cancel-ineg-terms-from-inequalit y, 111, 113 y-cancel-ineg-terms-from-inequality-

expanded, 113

y-expanded, 112, 113 cancel-iplus, 54, 56, 58 cancel-iplus-ilessp, 61 cancel-iplus-ilessp-1, 59, 60 cancel-itimes, 71, 76 cancel-itimes-factors, 86, 96 cancel-itimes-factors-expanded, 96, 97 cancel-itimes-factors-expanded-

cancel-itimes-factors, 96 cancel-itimes-ilessp, 77, 79 cancel-itimes-ilessp-factors, 97, 102 cancel-lessp-plus, 12, 13 cancel-lessp-times, 19, 20 cancel-quotient-times, 31, 32 car-assoc, 278 car-init, 121 car-restn-get, 289 car-s-expr-list-s-expr, 302 cddr-tag, 228 cdr-v&c$-lessp-if-cadddr, 278 cdr-v&c$-lessp-if-caddr, 278 cdr-v&c$-lessp-if-cadr, 278 common-divisor-divides-gcd, 37 commutativity-of-gcd, 35 commutativity-of-iplus, 46 commutativity-of-itimes, 62 commutativity-of-plus, 5 commutativity-of-times, 14 commutativity2-of-gcd, 37 commutativity2-of-gcd-zero-case, 37 commutativity2-of-iplus, 46 commutativity2-of-itimes, 62 commutativity2-of-plus, 5 commutativity2-of-times, 14 conjoin-inequalities-with-0, 103, 104 conjoin-inequalities-with-0-eli

minator, 104 correctness-of-cancel-difference

-plus, 11 correctness-of-cancel-equal-plu

s, 10 correctness-of-cancel-equal-time

s, 22 correctness-of-cancel-factors-0, 103 correctness-of-cancel-factors-i

lessp-0, 104 correctness-of-cancel-ineg, 52 correctness-of-cancel-ineg-aux, 52 correctness-of-cancel-ineg-term

s-from-equality, 111 s-from-inequality, 113

correctness-of-cancel-iplus, 58 correctness-of-cancel-iplus-ile

ssp, 61 ssp-lemma, 60

correctness-of-cancel-itimes, 76 correctness-of-cancel-itimes-fa

ctors, 97 correctness-of-cancel-itimes-ha

ck-1, 73 ck-2, 75 ck-3, 75 ck-3-lemma, 75

correctness-of-cancel-itimes-ile ssp, 79 ssp-factors, 102 ssp-hack-1, 78 ssp-hack-2, 78 ssp-hack-2-lemma, 78 ssp-hack-3, 79 ssp-hack-3-lemma-1, 79 ssp-hack-3-lemma-2, 79 ssp-hack-4, 79

correctness-of-cancel-lessp-plu

s, 13 correctness-of-cancel-lessp-time

s, 20 correctness-of-cancel-quotient-ti

mes, 32 cur-expr, 283, 284, 289, 290, 297,

300–302 cur-expr-append, 289 cur-expr-last, 290 cur-expr-nlistp, 302 cur-expr-plist, 290

definedp, 126, 128, 138, 139, 213– 215, 224, 230–233, 237–240, 262, 277, 278, 298, 300, 301, 305, 307, 310, 312, 316, 322

definedp-assoc-fact-1, 322 definedp-p-data-segment-implies

-listp-1, 262

-listp-generalized, 262 -litatom, 262 -litatom-generalized, 262

definedp-put-assoc, 238 definedp-temps-okp, 307 definition, 127, 128, 139, 142, 208,

213–216, 223, 284 delete, 1–3, 8, 10, 11, 13, 18, 55–57,

72–74, 96, 98, 313 delete-all, 320, 323, 324 delete-all-non-decreasing-count, 320 delete-delete, 2 delete-non-member, 2 deposit, 130, 160, 167, 177 deposit-adp, 129, 130 deposit-preserves-p-invariant1, 262 deposit-preserves-same-signature

-data-segment, 262 deposit-temp-stk-preserves-p-inv

ariant, 263 diff-diff-arg1, 7 diff-diff-arg2, 7 diff-diff-diff, 7 diff-sub1-arg2, 6 difference-add1-arg2, 12 difference-cancellation, 5 difference-difference-arg1, 12 difference-difference-arg2, 12 difference-elim, 11 difference-idifference, 114 difference-leq-arg1, 11 difference-lessp-arg1, 7 difference-plus-cancellation, 6 difference-plus-cancellation-pr

oof, 6 difference-plus-plus-cancellati

on, 6 on-hack, 6 on-proof, 6 difference-sub1-arg2, 12 difference-x-x, 12 disjoin-equalities-with-0, 102, 103 display-p-state, 225, 226 distributivity-of-times-over-gc

d, 36 d-proof, 36

div2-nat-preserves-p-invariant, 266 division-theorem, 63 division-theorem-for-truncate-t

o-neginf, 64 o-neginf-part1, 64 o-neginf-part2, 64 o-neginf-part3, 64 o-zero, 65 o-zero-part1, 65 o-zero-part2, 65 o-zero-part3, 65

division-theorem-part1, 63 division-theorem-part2, 63 division-theorem-part3, 63 dl, 137, 147, 148, 212 dl-block, 212 double-log-induction, 34 double-number-induction, 33 double-remainder-induction, 25 dv, 283, 290–292, 299, 303, 304, 313–

316, 318

eq-preserves-p-invariant, 264 equal-0-itimes-list-eval$-bagi

nt-1, 75 nt-2, 75

equal-difference-0, 5 equal-exp-0, 34 equal-exp-1, 34 equal-fix-int, 74 equal-fix-int-to-ilessp, 101 equal-gcd-0, 36 equal-ineg-ineg, 84 equal-itimes-0, 62 equal-itimes-1, 62 equal-itimes-list-eval$-list-b

agdiff, 96 equal-itimes-list-eval$-list-de

lete, 73

lete-new-1, 96 lete-new-2, 96

equal-itimes-minus-1, 63 equal-length-0, 119 equal-log-0, 34 equal-occurrences-zero, 2 equal-plist, 122 equal-plus-0, 4 equal-quotient-0, 27 equal-remainder-difference-0, 25 equal-remainder-plus-0, 23 equal-remainder-plus-0-proof, 23 equal-remainder-plus-remainder, 24 equal-remainder-plus-remainder-p

roof, 23 equal-sub1-0, 14 equal-tags, 228 equal-times-0, 14 equal-times-1, 14 equal-times-arg1, 18 equal-times-bridge, 18 errorp, 126, 260, 268 eval$-cancel-ineg-aux-fn, 51, 52 eval$-cancel-ineg-aux-is-its-f

n, 51 eval$-cancel-iplus, 56 eval$-disjoin-equalities-with-

0, 103 eval$-equal, 17 eval$-equal-itimes-tree-itimes

-fringe-0, 74 eval$-equal-times-tree-bagdiff, 21 eval$-if, 18 eval$-ilessp-iplus-tree-no-fix

-int, 60 eval$-iplus, 58 eval$-iplus-list-bagdiff, 57 eval$-iplus-list-car-remove-ine

gs, 111 eval$-iplus-list-cdr-remove-ine

gs, 111 eval$-iplus-list-delete, 57 eval$-iplus-tree, 53 eval$-iplus-tree-rec, 53 eval$-itimes-tree, 70 eval$-itimes-tree-ineg, 84 eval$-itimes-tree-no-fix-int-1, 76 eval$-itimes-tree-no-fix-int-2, 76 eval$-itimes-tree-rec, 69 eval$-lessp, 18 eval$-lessp-times-tree-bagdiff, 20 eval$-list-append, 53 eval$-list-bagint-0, 97 eval$-list-bagint-0-for-ilessp, 101 eval$-list-bagint-0-implies-eq

ual, 97 ual-for-ilessp, 101 ual-for-ilessp-lemma, 101

eval$-list-cons, 50 eval$-list-nlistp, 50 eval$-litatom, 50 eval$-make-cancel-itimes-equalit

y, 73 y-1, 74 y-2, 74

eval$-make-cancel-itimes-inequ

ality, 77 eval$-or, 17 eval$-other, 51 eval$-plus-tree-append, 9 eval$-quote, 9 eval$-quotient, 18 eval$-quotient-times-tree-bagdi

ff, 32 eval$-times, 17 eval$-times-member, 18 exp, 33–35, 133, 134, 190, 225, 232 exp-0-arg1, 34 exp-0-arg2, 34 exp-1-arg1, 34 exp-add1, 33 exp-difference, 34 exp-exp, 34 exp-plus, 33 exp-times, 34 exp-zero, 33 exponentiation, 34

fall-off-proofp, 222 fetch, 130, 153, 177 fetch-adp, 129, 130 fetch-preserves-p-invariant, 265 fetch-temp-stk-preserves-p-inva

riant, 263 find-label, 137, 138 find-labelp, 137, 138, 213–216 find-position-of-var, 148 first-n, 140, 238 firstn, 116–123, 283 firstn-0, 120 firstn-append, 120 firstn-cons, 120 firstn-firstn, 121 firstn-init, 121 firstn-lastcdr, 121 firstn-nlistp, 120 firstn-plist, 121 firstn-with-large-index, 120 firstn-with-non-number-index, 120 fix-int, 41–47, 51, 52, 57–59, 61–63,

66–68, 72–75, 78, 79, 84, 96–98, 101, 103, 114

fix-int-eval$-itimes-tree-rec, 84 fix-int-fix-int, 45 fix-int-iabs, 45 fix-int-idifference, 45 fix-int-idiv, 68 fix-int-imod, 68 fix-int-ineg, 45 fix-int-iplus, 45 fix-int-iquo, 68 fix-int-iquotient, 67 fix-int-irem, 68 fix-int-iremainder, 68 fix-int-itimes, 45 fix-int-remover, 45 fix-small-integer, 134, 179, 182 fix-small-natural, 133, 187, 193 formal-vars, 127, 142, 147, 208, 223,

231, 233, 240 frev, 276

gcd, 33, 35–37 gcd-0, 36 gcd-1, 36 gcd-idempotence, 37 gcd-is-the-greatest, 36 gcd-plus, 36 gcd-plus-instance, 36 gcd-plus-instance-temp, 36 gcd-plus-instance-temp-proof, 36 gcd-plus-proof, 36 gcd-x-x, 37 gcds, 37 generate-postlude, 148, 212 generate-prelude, 147, 212 generate-prelude1, 146, 147 generate-prelude2, 146, 147 get, 129, 139, 149, 165, 222, 231,

283, 285, 289, 290, 297, 300 get-add1-opener, 289 get-anything-nil, 285 get-cons, 285 get-large-index, 285 get-zerop, 285 good-alistp, 310, 311 good-alistp-listp-assoc, 310 good-alistp-put-assoc, 310 good-posp, 297, 302, 304, 307, 308,

319, 323 good-posp-dv-1-funcall, 304 good-posp-flag-not-list-good-po

sp1, 302 good-posp-list, 297, 302 good-posp-list-nx, 302 good-posp-list-t, 302 good-posp1, 297, 300–308, 315–319 good-posp1-append, 301 good-posp1-cons-lessp-4-if, 303 good-posp1-dv-1-temps, 304 good-posp1-flag-not-list-nil, 306 good-posp1-list-good-posp-list-t, 302 good-posp1-nlistp, 302 good-posp1-plist, 304 iabs, 42, 45, 63–66 icode, 212 icode-add-addr, 174, 210 icode-add-int, 178, 210 icode-add-int-with-carry, 179, 211 icode-add-nat, 186, 211 icode-add-nat-with-carry, 187, 211 icode-add1-int, 180, 211 icode-add1-nat, 188, 211 icode-and-bitv, 195, 211 icode-and-bool, 199, 212 icode-call, 146, 209 icode-deposit, 178, 210 icode-deposit-temp-stk, 164, 210 icode-div2-nat, 194, 211 icode-eq, 176, 210 icode-fetch, 177, 210 icode-fetch-temp-stk, 163, 210 icode-int-to-nat, 185, 211 icode-jump, 164, 210 icode-jump-case, 165, 210 icode-jump-if-temp-stk-empty, 157,

209 icode-jump-if-temp-stk-full, 156, 209 icode-locn, 149, 209 icode-lsh-bitv, 197, 212 icode-lt-addr, 176, 210 icode-lt-int, 184, 211 icode-lt-nat, 191, 211 icode-mult2-nat, 192, 211 icode-mult2-nat-with-carry-out, 193,

211 icode-neg-int, 183, 211 icode-no-op, 173, 210 icode-not-bitv, 196, 211 icode-not-bool, 199, 212 icode-or-bitv, 194, 211 icode-or-bool, 198, 212 icode-pop, 158, 209 icode-pop*, 158, 209 icode-pop-call, 162, 210 icode-pop-global, 160, 209 icode-pop-local, 159, 209 icode-pop-locn, 161, 210 icode-popj, 166, 210 icode-popn, 159, 209 icode-push-constant, 151, 209 icode-push-ctrl-stk-free-size, 154, 209 icode-push-global, 153, 209 icode-push-local, 152, 209 icode-push-temp-stk-free-size, 155, 209 icode-push-temp-stk-index, 156, 209 icode-pushj, 166, 210 icode-ret, 148, 209 icode-rsh-bitv, 197, 212 icode-set-global, 167, 210 icode-set-local, 167, 210 icode-sub-addr, 175, 210 icode-sub-int, 181, 211 icode-sub-int-with-carry, 182, 211 icode-sub-nat, 189, 211 icode-sub-nat-with-carry, 190, 211 icode-sub1-int, 183, 211 icode-sub1-nat, 191, 211 icode-test-bitv-and-jump, 172, 210 icode-test-bool-and-jump, 172, 210 icode-test-int-and-jump, 170, 210 icode-test-nat-and-jump, 169, 210 icode-xor-bitv, 196, 211 icode1, 209, 212 icompile, 213, 225 icompile-program, 212, 213 icompile-program-body, 212 idifference, 42–45, 47, 57, 114, 180–

182 idifference-fix-int1, 47 idifference-fix-int2, 47 idiv, 43, 64–68 idiv-fix-int1, 67 idiv-fix-int2, 67 idiv-imod-uniqueness, 65 ileq, 42 ilessp, 42, 59, 60, 63–66, 76, 78, 79,

84, 98–101, 104, 114, 115, 133, 184

ilessp-0-itimes, 99 ilessp-add1, 114 ilessp-add1-iplus, 114 ilessp-fix-int-1, 59 ilessp-fix-int-2, 59 ilessp-ineg-ineg, 84 ilessp-itimes-0, 99 ilessp-itimes-list-eval$-list-

bagdiff, 99

bagdiff-corollary-1, 99 bagdiff-corollary-2, 100 delete, 98 delete-helper-1, 98 delete-helper-2, 98 delete-prime, 98 delete-prime-helper-1, 98 delete-prime-helper-2, 98 ilessp-itimes-right-negative, 79 ilessp-itimes-right-positive, 78 ilessp-strict, 79 ilessp-trichotomy, 78 ilessp-zero-implies-not-equal, 100 imod, 43, 64, 65, 67, 68 imod-fix-int1, 67 imod-fix-int2, 67 ineg, 42, 45–47, 51, 52, 58, 65, 66, 84, 111, 134

ineg-0, 46

ineg-eval$-itimes-tree-ineg, 84

ineg-fix-int, 46 ineg-ineg, 45 ineg-iplus, 45 ineg-of-non-integerp, 46 inegate, 134, 183 infer-equality-from-not-lessp, 18 init, 117–124 init-0, 121 init-add1, 121 init-with-non-number-index, 121 int-to-nat-preserves-p-invariant, 265 integer-defns, 44 integerp, 41, 44–46, 53, 57, 58, 63–

67, 69, 72–74, 96, 97, 103, 110, 114, 133 integerp-eval$-iplus-or-ineg-te

rm, 110 integerp-eval$-itimes, 72 integerp-fix-int, 44 integerp-iabs, 45 integerp-idifference, 44 integerp-idiv, 66 integerp-imod, 67 integerp-ineg, 45 integerp-iplus, 44 integerp-iplus-list, 53 integerp-iquo, 67 integerp-iquotient, 66 integerp-irem, 67 integerp-iremainder, 66 integerp-itimes, 45 integerp-itimes-list, 69 integers, 116 iplus, 42, 44–47, 51–53, 57, 58, 60,

62–66, 84, 111, 114, 115, 134, 178–181

iplus-0-left, 46 iplus-0-right, 46 iplus-cancellation-1, 47 iplus-cancellation-1-for-ilessp, 60 iplus-cancellation-2, 47 iplus-cancellation-2-for-ilessp, 60 iplus-constants, 114 iplus-eval$-itimes-tree-ineg, 84 iplus-fix-int1, 47 iplus-fix-int2, 47 iplus-fringe, 52, 53, 55–57, 59, 61,

107–113 iplus-ineg-promote, 52 iplus-ineg1, 47 iplus-ineg2, 47 iplus-ineg3, 51 iplus-ineg4, 52 iplus-ineg5, 58 iplus-ineg5-lemma-1, 58 iplus-ineg5-lemma-2, 58 iplus-ineg6, 58 iplus-ineg7, 58 iplus-left-id, 46 iplus-list, 53, 56, 57, 111 iplus-list-append, 57 iplus-list-eval$-car-split-out

-ineg-terms, 111 iplus-list-eval$-fringe, 57 iplus-or-ineg-term, 107, 110, 111 iplus-or-itimes-term, 85, 86, 97 iplus-or-itimes-term-integerp-ev

al$, 97 iplus-right-id, 46 iplus-tree, 53, 55, 56, 59, 60, 107–

113 iplus-tree-no-fix-int, 60, 61 iplus-tree-rec, 53, 60 iplus-x-y-ineg-x, 52 iquo, 43, 65–68 iquo-fix-int1, 67 iquo-fix-int2, 67 iquo-irem-uniqueness, 66 iquotient, 43, 63, 64, 66, 67 iquotient-fix-int1, 67 iquotient-fix-int2, 67 iquotient-iremainder-uniqueness, 64 irem, 43, 65–68 irem-fix-int1, 67 irem-fix-int2, 67 iremainder, 43, 63, 64, 66–68 iremainder-fix-int1, 67 iremainder-fix-int2, 67 itimes, 42, 43, 45, 61–66, 69, 72, 73, 75, 78, 79, 84, 96–99

itimes–1, 84 itimes-0-left, 62 itimes-0-right, 62 itimes-1-arg1, 63 itimes-cancellation-1, 66 itimes-cancellation-2, 66 itimes-cancellation-3, 66 itimes-distributes-over-iplus, 62 itimes-distributes-over-iplus-p

roof, 62 itimes-eval$-itimes-tree-ineg, 84 itimes-factors, 83, 86, 97, 98, 100–

104 itimes-fix-int1, 62 itimes-fix-int2, 62 itimes-fringe, 69, 71–79 itimes-ineg-1, 66 itimes-ineg-2, 66 itimes-itimes-list-eval$-list-

delete, 96 itimes-list, 69, 70, 72–76, 78, 79, 84,

96–101, 103, 104 itimes-list-append, 72 itimes-list-bagdiff, 73 itimes-list-eval$-delete, 72 itimes-list-eval$-factors, 97 itimes-list-eval$-factors-lemm

a, 97 a-prime, 97

itimes-list-eval$-fringe, 72 itimes-list-eval$-list-0, 78 itimes-tree, 69, 70, 73–76 itimes-tree-ineg, 83, 84 itimes-tree-no-fix-int, 76–78 itimes-tree-rec, 69, 76, 83, 84 itimes-zero1, 61 itimes-zero2, 62 izerop, 41 izerop-eval-of-member-implies-iti

mes-list-0, 74 izerop-ilessp-0-relationship, 98

jump-case-preserves-p-invariant, 267 jump-if-temp-stk-empty-preserve

s-p-invariant, 266 jump-if-temp-stk-full-preserves

-p-invariant, 266 jump-preserves-p-invariant, 264 jump *-lst, 165

l-eval, 277–281, 296, 297, 299, 301–

308, 313, 317–319, 323, 325 l-eval-flag-not-list, 301 l-eval-if-fact-1, 303 l-eval-not-f-v&c$-equivalence, 280 l-eval-quote-fact-1, 304 l-eval-s-eval-do-temp-fetch-fact

-1, 307 l-eval-s-expand-temps-flag-list

-fact-1, 302

-s-expr-fact-1, 303 l-eval-s-expand-temps-litatom-f

act-1, 303 l-eval-s-expand-temps-not-subrp

-fact-1, 306 l-eval-s-expand-temps-subrp-fact

-1, 305 l-eval-v&c$-flag-list, 279 l-eval-v&c$-flag-not-list, 279 l-eval-zerop-clock, 313 l-proper-expr-functions-definedp

-s-proper-expr, 322 l-proper-expr-s-all-temps-setp, 323 l-proper-exprp, 321–325 l-proper-exprp-remove-duplicate

s, 324 l-proper-programs-remove-duplic

ates-arg1, 324 ates-arg2, 324

l-proper-programsp, 322–325 l-proper-programsp-1, 321–324 l-proper-programsp-1-delete-all, 323 l-proper-programsp-1-s-all-prog

s-temps-setp, 323 l-proper-programsp-remove-dupli

cates, 325 l-proper-programsp-s-all-progs-te

mps-setp, 323 labelledp, 137, 222 last, 283, 284, 290, 297, 302 last-append, 290 last-dv, 290 last-nx, 290 lastcdr, 117–124 lastcdr-append, 121 lastcdr-cons, 121 lastcdr-firstn, 122 lastcdr-init, 122 lastcdr-lastcdr, 122 lastcdr-nlistp, 121 lastcdr-plist, 122 lastcdr-restn, 122 lastcdr-reverse, 122 legal-labelp, 222, 230 length, 117–120, 123, 128, 129, 139,

140, 142, 148, 149, 151–160, 162–165, 192, 193, 213–218, 222, 225, 228, 231, 232, 237– 239, 261, 283, 285, 289, 290, 295–297, 300, 303, 304, 321

length-append, 119 length-cons, 119 length-first-n, 238 length-firstn, 119 length-init, 119 length-lastcdr, 119 length-nlistp, 119 length-plist, 119 length-put-assoc, 237 length-restn, 119 length-reverse, 119 leq-log-log, 35 leq-quotient, 30 lessp-1-times, 16 lessp-count-listp-cdr, 53 lessp-difference-cancellation, 12 lessp-difference-plus-arg1, 60 lessp-difference-plus-arg1-comm

uted, 60 lessp-gcd, 36 lessp-number-cons-restn-get, 289 lessp-number-cons-s-expr-s-expr

-list, 291 lessp-plus-fact, 25 lessp-plus-times-proof, 16 lessp-plus-times1, 16 lessp-plus-times2, 16 lessp-quotient, 31 lessp-remainder, 22 lessp-times-arg1, 18 lessp-times-cancellation-proof, 15 lessp-times-cancellation1, 15 lessp-times1, 15 lessp-times1-proof, 15 lessp-times2, 15 lessp-times2-proof, 15 lessp-times3, 15 lessp-times3-proof1, 15 lessp-times3-proof2, 15 listp-append, 117 listp-assoc-fact-1, 312 listp-assoc-s-change-temp, 315 listp-bagint-with-singleton-imp

lies-member, 78 listp-bagint-with-singleton-mem

ber, 78 listp-cdr-factors-implies-intege

rp, 103 listp-delete, 2 listp-eval$, 9 listp-firstn, 117 listp-init, 118 listp-last-listp, 290 listp-lastcdr, 118 listp-not-lessp-length-1, 304 listp-plist, 118 listp-restn, 118 listp-reverse, 118 lists, 124 local-var-value, 139, 149, 152, 160,

161 local-varp, 139 local-vars, 127, 148, 213–215, 223 locn-preserves-p-invariant, 267 log, 33–35 log-0, 34 log-1, 34 log-exp, 35 log-quotient, 35 log-quotient-exp, 35 log-quotient-times, 35 log-quotient-times-proof, 35 log-times, 35 log-times-exp, 35 log-times-exp-proof, 35 log-times-proof, 35 logic->s, 320, 325 logic->s-ok, 325 logic->s-ok-really, 325 logic-fname, 284, 296, 298, 305, 306,

323 logic-fname-user-fname-identity, 305

-formals, 323 logs, 35 lsh-bitv, 136, 197 lsh-bitv-preserves-p-invariant, 266 lt-addr-preserves-p-invariant, 264 lt-int-preserves-p-invariant, 265 lt-nat-preserves-p-invariant, 265

make-cancel-ineg-terms-equality, 107 make-cancel-ineg-terms-inequalit

y, 111 make-cancel-iplus-inequality-1, 59, 60 make-cancel-iplus-inequality-si

mplifier, 60 make-cancel-itimes-equality, 70–74,

86 make-cancel-itimes-inequality, 77, 98 make-p-call-frame, 140, 142, 208 make-temps-entries, 288, 301, 311,

312, 317 member-0-eval$-list, 97 member-0-itimes-factors-yields-

0-ilessp-consequence-1, 100 0-ilessp-consequence-2, 100 0, 100

member-append, 73 member-assoc, 231 member-bagdiff, 3 member-bagint, 3 member-check-s-temp-setp-1-subsetp,

316 member-delete, 2 member-delete-all, 323 member-delete-implies-membership,

3 member-f-v&c$-fact-1, 280 member-get, 231 member-implies-numberp, 9 member-implies-plus-tree-greate

reqp, 8 member-izerop-itimes-fringe, 73 member-non-list, 2 member-plist, 278 member-remove-duplicates, 324 member-strip-cars-definedp, 277 member-strip-logic-fnames-define

dp, 305 membership-of-0-implies-itimes-

list-is-0, 97 minus-ineg, 111 mult2-nat-preserves-p-invariant, 266 mult2-nat-with-carry-out-preserve

s-p-invariant, 263 multiplication, 22 my-length-put, 261

name, 127, 138, 146–148, 151, 162,

166, 171, 212, 223, 231 name-assoc, 231 naturals, 37 neg-int-preserves-p-invariant, 265 no-op-preserves-p-invariant, 261 not-bit, 135 not-bitv, 135, 195 not-bitv-preserves-p-invariant, 266 not-bool, 132, 199 not-bool-preserves-p-invariant, 266 not-definedp-put-assoc, 312 not-equal-x-y-error-msg-halt, 229 not-equal-x-y-error-msg-run, 229 not-integerp-implies-not-equal-ip

lus, 57 not-integerp-implies-not-equal-iti

mes, 72 not-listp-cdr-last, 290 not-listp-pos-not-good-posp, 319 not-member-remove-costs, 280 not-s-good-statep-bad-car-expr, 318 not-subrp-expr-v&c-apply$, 280 not-user-fnamep-not-definedp-s-p

rograms-okp, 298 number-cons, 281, 289–291 number-cons-cadr-caddr-cadddr, 281 number-cons-car, 281 number-cons-cdr, 281 number-cons-cur-expr, 290 numberp-eval$-bridge, 8 numberp-eval$-plus, 8 numberp-eval$-plus-tree, 8 numberp-eval$-times, 17 numberp-eval$-times-tree, 18 numberp-is-integerp, 114 nx, 283, 290, 291, 301, 302, 319

occurrences, 2, 3 occurrences-bagdiff, 3 occurrences-bagint, 3 occurrences-delete, 3 offset, 130, 139, 175, 176 offset-from-csp, 148, 150, 152, 159,

161, 167 once-errorp-always-errorp, 260 once-errorp-always-errorp-step, 260 or-bit, 135 or-bitv, 135, 194 or-bitv-preserves-p-invariant, 266 or-bool, 132, 198 or-bool-preserves-p-invariant, 266 or-zerop-tree, 17, 19–21 or-zerop-tree-is-not-zerop-tree, 19

p, 207, 226, 259, 260, 268 p-add-addr-okp, 174, 202, 250, 256 p-add-addr-step, 174, 205, 254, 263 p-add-int-okp, 178, 202, 248, 255 p-add-int-step, 178, 206, 251, 265 p-add-int-with-carry-okp, 179, 202,

248, 255 p-add-int-with-carry-step, 179, 206,

251, 265 p-add-nat-okp, 185, 203, 248, 255 p-add-nat-step, 186, 206, 251, 265 p-add-nat-with-carry-okp, 186, 203,

248, 255 p-add-nat-with-carry-step, 186, 206,

251, 263 p-add1-int-okp, 180, 202, 248, 255 p-add1-int-step, 180, 206, 251, 265 p-add1-nat-okp, 188, 203, 248, 255 p-add1-nat-step, 188, 206, 252, 263 p-and-bitv-okp, 195, 203, 249, 255 p-and-bitv-step, 195, 207, 252, 266 p-and-bool-okp, 198, 203, 249, 255 p-and-bool-step, 198, 207, 252, 266 p-call-okp, 142, 162, 201, 249, 255 p-call-step, 142, 162, 204, 252, 267 p-ctrl-stk, 126, 142, 148, 149, 151–

168, 173–199, 224–226, 231– 233

p-ctrl-stk-size, 139, 142, 154, 225,

232 p-current-instruction, 139, 207, 226, 231, 232, 261–264, 268 p-current-program, 139, 151, 156, 157,

164, 165, 168 p-data-segment, 126, 138, 142, 148,

149, 151–168, 173–199, 214, 215, 225, 226, 229, 232, 233, 239, 260, 262–264, 268 p-deposit-okp, 177, 202, 248, 255,

263 p-deposit-step, 177, 206, 251, 262 p-deposit-temp-stk-okp, 163, 201, 250,

256 p-deposit-temp-stk-step, 163, 205, 253,

263 p-div2-nat-okp, 193, 203, 248, 255 p-div2-nat-step, 193, 206, 252, 266 p-eq-okp, 175, 202, 247, 254 p-eq-step, 175, 205, 251, 264 p-fetch-okp, 177, 202, 248, 255 p-fetch-step, 177, 206, 251, 265 p-fetch-temp-stk-okp, 162, 201, 250,

256 p-fetch-temp-stk-step, 162, 163, 205,

253, 263 p-frame, 139, 140, 161, 226, 230 p-frame-size, 139 p-halt, 126, 148, 207, 252, 259, 267 p-ins-okp, 201, 207, 251, 255, 257,

259, 268 p-ins-okp-backchainer, 255 p-ins-okp-exhausted, 257 p-ins-okp-is-p-ins-okp1, 251 p-ins-okp1, 249, 251 p-ins-okp2, 247, 251, 254, 258, 268 p-ins-okp2-backchainer, 254 p-ins-okp2-exhausted, 258 p-ins-step, 204, 207, 254, 259, 267,

268 p-ins-step-is-p-ins-step1, 254 p-ins-step-preserves-p-invariant

1, 267 p-ins-step-preserves-same-signat

ure-data-segment, 268 p-ins-step1, 252, 254 p-ins-step2, 251, 254, 267, 268 p-ins-step2-preserves-p-invaria

nt1, 267 p-ins-step2-preserves-same-sign

ature-data-segment, 268 p-int-to-nat-okp, 185, 203, 248, 255 p-int-to-nat-step, 185, 206, 251, 265 p-invariant, 260–268 p-invariant-opener, 260 p-invariant-p-invariant1, 267 p-invariant-same-signature-data

-segments, 268 p-invariant1, 260–263, 267, 268 p-invariant1-opener, 261 p-invariant1-p-halt, 267 p-invariant1-reflexive, 267 p-jump-case-okp, 164, 202, 250, 256 p-jump-case-step, 165, 205, 253, 267 p-jump-if-temp-stk-empty-okp, 157,

201, 249, 256 p-jump-if-temp-stk-empty-step, 157,

204, 253, 266 p-jump-if-temp-stk-full-okp, 156, 201,

249, 256 p-jump-if-temp-stk-full-step, 156, 204,

253, 266 p-jump-okp, 164, 202, 250, 256 p-jump-step, 164, 205, 253, 264 p-loadablep, 225 p-locn-okp, 149, 201, 249, 255 p-locn-step, 149, 204, 252, 267 p-lsh-bitv-okp, 197, 203, 249, 255 p-lsh-bitv-step, 197, 207, 252, 266 p-lt-addr-okp, 176, 202, 248, 255 p-lt-addr-step, 176, 205, 251, 264 p-lt-int-okp, 183, 203, 248, 255 p-lt-int-step, 184, 206, 251, 265 p-lt-nat-okp, 191, 203, 248, 255 p-lt-nat-step, 191, 206, 252, 265 p-max-ctrl-stk-size, 126, 142, 148,

149, 151–168, 173–199, 225, 226, 232, 260, 261, 268

p-max-temp-stk-size, 126, 142, 148, 149, 151–168, 173–199, 225, 226, 232, 260, 261, 268

p-mult2-nat-okp, 192, 203, 248, 255 p-mult2-nat-step, 192, 206, 252, 266 p-mult2-nat-with-carry-out-okp, 192, 203, 248, 255

p-mult2-nat-with-carry-out-step, 192,

206, 252, 263 p-neg-int-okp, 183, 203, 248, 255 p-neg-int-step, 183, 206, 251, 265 p-no-op-okp, 173, 202, 250, 256 p-no-op-step, 173, 205, 254, 261 p-not-bitv-okp, 195, 203, 249, 255 p-not-bitv-step, 195, 207, 252, 266 p-not-bool-okp, 199, 204, 249, 255 p-not-bool-step, 199, 207, 252, 266 p-objectp, 138, 213, 222, 223, 229,

230 p-objectp-opener, 229 p-objectp-type, 138, 149, 159–164,

166, 168, 174–183, 185, 186, 188–199, 223, 224, 238, 239

p-objectp-type-opener, 238

p-opener, 259

p-or-bitv-okp, 194, 203, 249, 255 p-or-bitv-step, 194, 206, 252, 266 p-or-bool-okp, 197, 203, 249, 255 p-or-bool-step, 198, 207, 252, 266 p-pc, 126, 139, 142, 162, 166, 224– 226, 231–233, 261 p-pop*-okp, 158, 201, 250, 256 p-pop*-step, 158, 204, 253, 263 p-pop-call-okp, 161, 201, 250, 256 p-pop-call-step, 162, 205, 253, 267 p-pop-global-okp, 160, 201, 250, 256,

262 p-pop-global-step, 160, 205, 253, 262 p-pop-local-okp, 159, 201, 250, 256 p-pop-local-step, 159, 205, 253, 262 p-pop-locn-okp, 160, 201, 250, 256 p-pop-locn-step, 161, 205, 253, 267 p-pop-okp, 157, 201, 250, 256 p-pop-step, 157, 158, 204, 253, 264 p-popj-okp, 166, 202, 250, 256 p-popj-step, 166, 205, 253, 264 p-popn-okp, 158, 201, 250, 256 p-popn-step, 159, 205, 253, 263 p-preserves-p-invariant1, 268 p-preserves-p-resources, 268 p-preserves-proper-p-statep, 260 p-preserves-same-signature-data

-segment, 268 p-prog-segment, 126, 138, 139, 142,

148, 149, 151–168, 173–199, 213–216, 223, 225, 226, 229– 233, 239, 240, 260, 261, 268

p-psw, 207, 226, 260, 262–264, 268 p-push-constant-okp, 151, 201, 249,

256 p-push-constant-step, 151, 204, 253,

264 p-push-ctrl-stk-free-size-okp, 153, 201,

249, 256 p-push-ctrl-stk-free-size-step, 153, 204,

253, 264 p-push-global-okp, 153, 201, 249, 256 p-push-global-step, 153, 204, 253, 261 p-push-local-okp, 152, 201, 249, 256 p-push-local-step, 152, 204, 253, 262 p-push-temp-stk-free-size-okp, 154,

201, 249, 256 p-push-temp-stk-free-size-step, 154,

204, 253, 264 p-push-temp-stk-index-okp, 155, 201,

249, 256 p-push-temp-stk-index-step, 155, 204,

253, 264 p-pushj-okp, 165, 202, 250, 256 p-pushj-step, 165, 205, 253, 264 p-ret-okp, 148, 201, 249, 255 p-ret-step, 148, 204, 252, 267 p-rsh-bitv-okp, 196, 203, 249, 255 p-rsh-bitv-step, 196, 207, 252, 266 p-set-global-okp, 167, 202, 250, 256,

264 p-set-global-step, 167, 205, 254, 263,

264 p-set-local-okp, 166, 202, 250, 256 p-set-local-step, 166, 205, 253, 263 p-state, 125, 126, 142, 148, 149, 151–

168, 173–199, 208, 226, 259– 261

p-statep, 224, 231, 232 p-step, 207, 259, 260, 267, 268 p-step-preserves-p-invariant1, 267 p-step-preserves-proper-p-statep, 260 p-step-preserves-same-signature

-data-segment, 268 p-step1, 207, 259 p-step1-opener, 259 p-sub-addr-okp, 174, 202, 250, 256 p-sub-addr-step, 175, 205, 254, 264 p-sub-int-okp, 180, 202, 248, 255 p-sub-int-step, 180, 181, 206, 251,

265 p-sub-int-with-carry-okp, 181, 202,

248, 255 p-sub-int-with-carry-step, 181, 206,

251, 265 p-sub-nat-okp, 188, 203, 248, 255 p-sub-nat-step, 189, 206, 252, 265 p-sub-nat-with-carry-okp, 189, 203,

248, 255 p-sub-nat-with-carry-step, 189, 206,

252, 265 p-sub1-int-okp, 182, 203, 248, 255 p-sub1-int-step, 182, 206, 251, 265 p-sub1-nat-okp, 190, 203, 248, 255 p-sub1-nat-step, 190, 206, 252, 265 p-temp-stk, 126, 142, 148, 149, 151–

199, 225, 226, 232, 233 p-test-and-jump-okp, 168–172 p-test-and-jump-step, 168–172 p-test-bitv-and-jump-okp, 172, 202,

250, 256 p-test-bitv-and-jump-step, 172, 205,

254, 267 p-test-bitvp, 172 p-test-bool-and-jump-okp, 171, 202,

250, 256 p-test-bool-and-jump-step, 171, 205,

254, 267 p-test-boolp, 171 p-test-int-and-jump-okp, 170, 202,

250, 256 p-test-int-and-jump-step, 170, 205,

254, 266 p-test-intp, 170 p-test-nat-and-jump-okp, 169, 202,

250, 256 p-test-nat-and-jump-step, 169, 205,

254, 266 p-test-natp, 169 p-word-size, 126, 138, 142, 148, 149,

151–168, 173–199, 214, 225, 226, 229, 232, 238, 239, 260, 261, 268

p-xor-bitv-okp, 196, 203, 249, 255 p-xor-bitv-step, 196, 207, 252, 266 p0, 208 pair-formal-vars-with-actuals, 140 pair-temps-with-initial-values, 140, 240 pc, 138, 151, 156, 157, 164–166, 168–

173 pcpp, 128, 138, 139, 229, 239 piton-opcodes, 200 plist, 117–124, 278, 290, 291, 298,

299, 301, 304, 322 plist-append, 122 plist-cons, 122 plist-firstn, 122 plist-init, 122 plist-lastcdr, 122 plist-nlistp, 122 plist-plist, 122 plist-restn, 122 plist-reverse, 123 plistp, 117, 118, 122, 124, 218, 233,

239, 295, 300, 321 plistp-append, 118 plistp-cons, 118 plistp-firstn, 118 plistp-init, 118 plistp-lastcdr, 118 plistp-nlistp, 118 plistp-plist, 118 plistp-restn, 118 plistp-reverse, 118 plus-add1-arg1, 5 plus-add1-arg2, 5 plus-cancellation, 4 plus-difference-arg1, 5 plus-difference-arg2, 5 plus-fringe, 7–11, 13 plus-iplus, 114 plus-remainder-times-quotient, 23 plus-tree, 7–11, 13 plus-tree-bagdiff, 8 plus-tree-delete, 8 plus-tree-plus-fringe, 9 plus-zero-arg2, 5 pop, 136, 139, 148, 158–163, 165,

166, 168, 174–199, 223, 225, 226

pop*-preserves-p-invariant, 263 pop-call-preserves-p-invariant, 267 pop-global-preserves-p-invariant

1, 262 pop-global-preserves-p-same-sig

nature-data-segment, 262 pop-local-preserves-p-invariant, 262 pop-locn-preserves-p-invariant, 267 pop-preserves-p-invariant, 264 popj-preserves-p-invariant, 264 popn, 136, 142, 158, 159 popn-preserves-p-invariant, 263 program-body, 127, 128, 138, 139,

148, 212–216, 223, 231, 232 proper-labeled-p-instructionsp, 222,

230 proper-labeled-p-instructionsp-i

mplies-labelp-and-instructionp,

230 proper-p-add-addr-instructionp, 216,

220, 235 proper-p-add-int-instructionp, 216, 220,

236 proper-p-add-int-with-carry-inst

ructionp, 217, 220, 236 proper-p-add-nat-instructionp, 217,

221, 236 proper-p-add-nat-with-carry-inst

ructionp, 217, 221, 236 proper-p-add1-int-instructionp, 217,

220, 236 proper-p-add1-nat-instructionp, 217,

221, 236 proper-p-alistp, 223, 231, 233, 239,

240 proper-p-alistp-append, 239 proper-p-alistp-pair-temps-with

-initial-values, 240 proper-p-alistp-pairlist, 239 proper-p-and-bitv-instructionp, 218,

221, 237 proper-p-and-bool-instructionp, 218,

222, 237 proper-p-area, 224 proper-p-call-instructionp, 213, 218,

233 proper-p-ctrl-stkp, 223, 225, 232, 233 proper-p-data-segmentp, 224, 225, 232,

233, 262 proper-p-deposit-instructionp, 216,

220, 236 proper-p-deposit-temp-stk-instr

uctionp, 215, 219, 235 proper-p-div2-nat-instructionp, 218,

221, 237 proper-p-eq-instructionp, 216, 220,

235 proper-p-fetch-instructionp, 216, 220,

236 proper-p-fetch-temp-stk-instructi

onp, 215, 219, 235 proper-p-framep, 223, 225 proper-p-instructionp, 218, 222, 230–

233, 261 proper-p-instructionp-opener, 233 proper-p-int-to-nat-instructionp, 217,

221, 236 proper-p-jump-case-instructionp, 215,

220, 235 proper-p-jump-if-temp-stk-empty -instructionp, 214, 219, 234 proper-p-jump-if-temp-stk-full-i nstructionp, 214, 219, 234 proper-p-jump-instructionp, 215, 220,

235 proper-p-locn-instructionp, 213, 219,

234 proper-p-lsh-bitv-instructionp, 218,

221, 237 proper-p-lt-addr-instructionp, 216, 220,

235 proper-p-lt-int-instructionp, 217, 221,

236 proper-p-lt-nat-instructionp, 218, 221,

236 proper-p-mult2-nat-instructionp, 218,

221, 237 proper-p-mult2-nat-with-carry-o

ut-instructionp, 218, 221, 237 proper-p-neg-int-instructionp, 217, 221,

236 proper-p-no-op-instructionp, 216, 220,

235 proper-p-not-bitv-instructionp, 218,

221, 237 proper-p-not-bool-instructionp, 218,

222, 237 proper-p-or-bitv-instructionp, 218, 221,

237 proper-p-or-bool-instructionp, 218, 221,

237 proper-p-pop*-instructionp, 214, 219,

234 proper-p-pop-call-instructionp, 215,

219, 234 proper-p-pop-global-instructionp, 214,

219, 234 proper-p-pop-instructionp, 214, 219,

234 proper-p-pop-local-instructionp, 214,

219, 234 proper-p-pop-locn-instructionp, 215,

219, 234 proper-p-popj-instructionp, 215, 220,

235 proper-p-popn-instructionp, 214, 219,

234 proper-p-prog-segmentp, 223, 225, 230–

233, 240 proper-p-prog-segmentp-implies-p

roper-p-programp, 230 roper-p-temp-var-dclsp, 240

proper-p-program-bodyp, 222, 223 proper-p-programp, 223, 230 proper-p-push-constant-instructi

onp, 213, 219, 234 proper-p-push-ctrl-stk-free-size

-instructionp, 214, 219, 234 proper-p-push-global-instructio

np, 214, 219, 234 proper-p-push-local-instructionp, 213,

219, 234 proper-p-push-temp-stk-free-size

-instructionp, 214, 219, 234 proper-p-push-temp-stk-index-in

structionp, 214, 219, 234 proper-p-pushj-instructionp, 215, 220,

235 proper-p-ret-instructionp, 213, 219,

233 proper-p-rsh-bitv-instructionp, 218,

221, 237 proper-p-set-global-instructionp, 215,

220, 235 proper-p-set-local-instructionp, 215,

220, 235 proper-p-statep, 224, 232, 260–264,

268 proper-p-statep-implies-proper-p

-instructionp, 231 proper-p-statep-proper-implies-p

roper-p-instructionp, 261 proper-p-statep-restructuring, 232 proper-p-statep1, 231, 232 proper-p-statep1-properties, 232 proper-p-sub-addr-instructionp, 216,

220, 235 proper-p-sub-int-instructionp, 217, 220,

236 proper-p-sub-int-with-carry-inst

ructionp, 217, 220, 236 proper-p-sub-nat-instructionp, 217,

221, 236 proper-p-sub-nat-with-carry-inst

ructionp, 217, 221, 236 proper-p-sub1-int-instructionp, 217,

221, 236 proper-p-sub1-nat-instructionp, 217,

221, 236 proper-p-temp-stkp, 223, 225, 232,

233 proper-p-temp-var-dclsp, 222, 223,

240 proper-p-test-bitv-and-jump-inst

ructionp, 216, 220, 235 proper-p-test-bool-and-jump-inst

ructionp, 216, 220, 235 proper-p-test-int-and-jump-inst

ructionp, 216, 220, 235 proper-p-test-nat-and-jump-inst

ructionp, 216, 220, 235 proper-p-xor-bitv-instructionp, 218,

221, 237 ps, 226 push, 136, 139, 142, 149, 151–155,

161, 163, 165, 174–199, 208, 226

push-constant-preserves-p-invari

ant, 264 push-ctrl-stk-free-size-preserve

s-p-invariant, 264 push-global-preserves-p-invaria

nt, 261 push-local-preserves-p-invariant, 262 push-temp-stk-free-size-preserve

s-p-invariant, 264 push-temp-stk-index-preserves-p

-invariant, 264 pushj-preserves-p-invariant, 264 put, 129, 261 put-assoc, 126, 127, 237–239, 286,

299, 310, 312, 316 put-value, 127, 129, 139 put-value-indirect, 161

quotient-1-arg1, 30 quotient-1-arg1-casesplit, 30 quotient-1-arg2, 30 quotient-add1, 27 quotient-difference-lessp-arg2, 63 quotient-difference1, 29 quotient-difference2, 29 quotient-difference3, 29 quotient-exp, 33 quotient-lessp-arg1, 29 quotient-noop, 27 quotient-of-non-number, 27 quotient-plus, 28 quotient-plus-fact, 30 quotient-plus-proof, 27 quotient-plus-times-times, 30 quotient-plus-times-times-insta

nce, 30 quotient-plus-times-times-proof, 30 quotient-quotient, 30 quotient-remainder, 29 quotient-remainder-instance, 30 quotient-remainder-times, 29 quotient-remainder-uniqueness, 63 quotient-sub1, 27 quotient-times, 28 quotient-times-instance, 28 quotient-times-instance-temp, 28 quotient-times-instance-temp-pr

oof, 28 quotient-times-proof, 28 quotient-times-times, 29 quotient-times-times-proof, 29 quotient-x-x, 31 quotient-zero, 27 quotients, 32

remainder-1-arg1, 26 remainder-1-arg2, 26 remainder-add1, 23 remainder-difference1, 24 remainder-difference2, 25 remainder-difference3, 25 remainder-equals-its-first-argu

ment, 29 remainder-exp, 33 remainder-exp-exp, 33 remainder-gcd, 36 remainder-noop, 22 remainder-of-non-number, 22 remainder-plus, 23 remainder-plus-fact, 25 remainder-plus-proof, 23 remainder-plus-times-times, 26 remainder-plus-times-times-inst

ance, 26 remainder-plus-times-times-proo

f, 25 remainder-quotient-elim, 23 remainder-remainder, 26 remainder-times-times, 24 remainder-times-times-proof, 24 remainder-times1, 24 remainder-times1-instance, 24 remainder-times1-instance-proof, 24 remainder-times1-proof, 24 remainder-times2, 24 remainder-times2-instance, 24 remainder-times2-proof, 24 remainder-x-x, 26 remainder-zero, 22 remainders, 27 remove-costs, 277, 278, 280, 281 remove-duplicates, 320, 323–325 remove-inegs, 106–113 restn, 117–120, 122, 123, 284, 289–

291, 302 restn-0, 123 restn-add1-opener, 289 restn-append, 123 restn-cdr, 289 restn-cons, 123 restn-firstn, 123 restn-init, 123 restn-lastcdr, 123 restn-nlistp, 123 restn-plist, 123 restn-restn, 123 restn-sub1-length-last, 290 restn-with-large-index, 123 restn-with-non-number-index, 123 ret-pc, 139, 148, 161, 223, 225, 226,

230, 232, 233 ret-pc-p-frame, 230 ret-preserves-p-invariant, 267 rev, 276 reverse, 117–119, 122–124, 140, 147 reverse-append, 124 reverse-cons, 124 reverse-init, 124 reverse-lastcdr, 124 reverse-nlistp, 124 reverse-plist, 124 reverse-reverse, 124 rget, 129, 163 rput, 129, 163 rsh-bitv, 136, 197 rsh-bitv-preserves-p-invariant, 266

s-accessors-s-change-temp, 287 s-accessors-s-eval-do-temp-fetc

h, 287 s-accessors-s-fun-call-state, 288 s-accessors-s-set-ans, 287 s-accessors-s-set-error, 286 s-accessors-s-set-expr, 289 s-accessors-s-set-pos, 285 s-accessors-s-set-temps, 286 s-all-progs-temps-setp, 311, 317–319,

323 s-all-temps-setp, 309–313, 317–319,

323 s-all-temps-setp-member-progs, 317 s-all-temps-setp-s-all-progs-te

mps-setp, 318 s-all-temps-setp-subsetp, 312 s-all-temps-setp-subsetp-flag-li

st, 318 s-all-temps-setp-subsetp-if-cad

ddr, 313 dr, 313

s-ans, 285–289, 291, 292, 307, 308,

318, 325 s-body, 284, 296, 300–308, 311, 315–

319, 323 s-change-temp, 286, 287, 292, 299, 312, 315, 316

s-check-temps-setp, 311, 315–317, 319,

320, 323 s-check-temps-setp-1, 310, 311, 315,

316 s-check-temps-setp-1-cons-membe

r, 316 s-check-temps-setp-1-cons-non-me

mber, 315 s-check-temps-setp-1-put-assoc, 316 s-check-temps-setp-member-progs, 317 s-check-temps-setp-put-assoc, 316 s-check-temps-setp-s-all-progs-te

mps-setp, 317 s-collect-all-temps, 308–310, 313–316,

318–320, 323 s-construct-programs, 320, 322–324 s-err-flag, 285–289, 291–293, 298, 299,

301, 302, 307, 308, 313, 314, 318, 319, 323 s-err-flag-s-eval-flag-list-fla

g-t, 301 s-eval, 291–293, 299, 301, 302, 307,

308, 313–316, 318–320, 323, 325 s-eval-do-temp-fetch, 287, 288, 292,

302, 304, 307 s-eval-l-eval-equivalence, 307 s-eval-l-eval-flag-run, 319 s-eval-l-eval-flag-run-flag-t, 323 s-eval-l-eval-flag-run-helper-1, 314 s-eval-l-eval-flag-run-helper-2, 314 s-eval-l-eval-flag-run-helper-3, 316 s-eval-l-eval-flag-run-helper-5, 317 s-eval-l-eval-flag-run-helper-6, 317 s-eval-l-eval-flag-run-helper-7, 319 s-eval-l-eval-flag-t, 308 s-eval-l-eval-s-temps, 304 s-eval-s-good-statep, 308 s-eval-temps-subsetp, 313 s-eval-temps-subsetp-s-set-expr, 314 s-eval-temps-subsetp-s-set-pos, 313 s-expand-temps, 293, 296, 299, 302–

308, 317, 319, 322, 323 s-expand-temps-body-equal-body, 322 s-expand-temps-s-expr-s-fun-cal

l-state, 306 s-expr, 284, 287, 288, 290–292, 299,

301–308, 313–320, 323 s-expr-list, 284, 291, 301–303, 308,

318–320 s-expr-list-s-s-set-expr-nx, 291 s-expr-list-s-set-pos-dv, 291 s-expr-s-set-expr, 290 s-expr-s-set-pos-t, 290 s-formals, 284, 288, 296, 300, 301,

306, 307 s-fun-call-state, 288, 292, 305, 307,

318 s-good-state-s-construct-progra

ms, 324 s-good-statep, 298–301, 303–308, 315–

319, 323, 324 s-good-statep-backchainer-1, 298 s-good-statep-backchainer-2, 298 s-good-statep-backchainer-2-5, 298 s-good-statep-backchainer-3, 298 s-good-statep-backchainer-4, 299 s-good-statep-backchainer-5, 299 s-good-statep-backchainer-6, 299 s-good-statep-definedp-temps, 301 s-good-statep-formals, 307 s-good-statep-listp-assoc-temps, 315 s-good-statep-not-car-s-expr-ca

ar-s-progs, 306 s-good-statep-s-change-temp, 299 s-good-statep-s-eval-do-temp-fet

ch, 304 s-good-statep-s-fun-call-state, 305 s-good-statep-s-proper-exprp, 300 s-good-statep-s-proper-exprp-cu

r-expr, 301 s-good-statep-s-set-ans, 299 s-good-statep-s-set-expr, 299 s-good-statep-s-set-pos, 299 s-good-statep-s-temp-list, 300 s-good-statep-strip-cars-temps, 299 s-params, 285–289, 291, 293, 298,

299, 307, 308, 317, 319, 323 s-params-s-eval, 293 s-pname, 284–289, 293, 298 s-pname-s-eval, 293 s-pos, 284–292, 299, 301–308, 313–

319, 323 s-prog, 284, 289, 298–308, 315–319,

323 s-prog-s-eval, 302 s-prog-s-eval-do-s-temp-fetch, 302 s-prog-s-set-ans, 299 s-prog-s-set-expr, 289 s-prog-s-set-pos, 289 s-prog-s-set-temps, 299 s-programs-okp, 296, 298, 299, 305,

306, 323 s-programs-okp-all-user-fnamesp

-strip-cars, 305 s-programs-okp-formals-body, 306 s-programs-okp-s-construct-prog

rams, 323 s-programs-properp, 296, 298, 300,

322 s-programs-properp-s-construct-p

rograms, 322 s-programs-properp-s-proper-exp

rp, 300 s-progs, 284–289, 293, 298–301, 305–

307, 317–319, 323 s-progs-s-eval, 293 s-proper-exprp, 295, 296, 300, 301,

303, 305, 322, 324 s-proper-exprp-definedp, 301 s-proper-exprp-definedp-program

s, 305 s-proper-exprp-fact-2, 318 s-proper-exprp-length-cur-expr, 303 s-proper-exprp-list-s-proper-get

-t, 300 s-proper-exprp-plist, 322 s-proper-exprp-remove-duplicate

s, 324 s-proper-exprp-s-proper-exprp-c

ur-expr, 300 s-proper-exprp-t-s-proper-get-t, 300 s-proper-programsp-plist, 322 s-set-ans, 287, 291, 292, 299 s-set-error, 286, 287, 291, 292 s-set-expr, 288–292, 299, 301, 314,

315, 319 s-set-pos, 285, 289–292, 299, 313,

314, 316, 318 s-set-temps, 285, 286, 299 s-state, 282, 285–289, 320, 324 s-temp-eval, 282, 292, 293, 295, 297,

300, 301, 304, 309, 315–318 s-temp-fetch, 282, 292, 293, 295, 297,

300, 301, 304, 307, 309, 315– 317, 319

s-temp-list, 284, 288, 296, 298–301,

311, 317 s-temp-setp, 282, 287, 288, 292, 304,

307, 310, 312, 315, 316 s-temp-setp-put-assoc-1, 312 s-temp-setp-s-change-temp, 315 s-temp-test, 282, 292, 293, 295, 297,

300, 301, 304, 307, 309, 315– 318

s-temp-value, 282, 287, 307 s-temps, 285–289, 292, 298–301, 304,

307, 312–316, 318–320, 323 same-fix-int-implies-not-ilessp, 79 same-signature, 228, 237, 238, 258–

260, 262–264, 268 same-signature-implies-equal-de

finedp, 238 same-signature-implies-equal-le

ngths, 238 same-signature-put-assoc-1, 237 same-signature-put-assoc-2, 238 same-signature-reflexive-genera

lized, 238 segment-length, 225 set-global-preserves-p-invariant

1, 263 set-global-preserves-same-signat

ure-data-segment, 264 set-local-preserves-p-invariant, 263 set-local-var-indirect, 161 set-local-var-value, 139, 159, 166 signature, 228 single-number-induction, 35 small-integerp, 133, 134, 138, 178–

180, 182, 183, 229, 239 small-naturalp, 133, 138, 185, 187,

188, 192, 193, 214, 229, 238 some-eval$s-to-0, 102, 103 some-eval$s-to-0-append, 103 some-eval$s-to-0-eliminator, 103 split-out-ineg-terms, 106, 111 strip-cadrs, 127 strip-cars-make-temps-entries, 301 strip-cars-put-assoc, 239 strip-cars-remove-costs, 277 strip-cars-s-temps-s-eval, 301 strip-cdrs, 127 strip-logic-fnames, 297, 298, 300, 301,

305, 322 strip-logic-fnames-s-construct-p

rograms, 322 sub-addr, 130, 175 sub-addr-preserves-p-invariant, 264 sub-adp, 129, 130 sub-int-preserves-p-invariant, 265 sub-int-with-carry-preserves-p-i

nvariant, 265 sub-nat-preserves-p-invariant, 265 sub-nat-with-carry-preserves-p-i

nvariant, 265 sub1-addr, 130 sub1-adp, 129 sub1-int-preserves-p-invariant, 265 sub1-nat-preserves-p-invariant, 265 subbagp, 2, 3, 8, 19–21, 32, 57, 73,

75, 78, 79, 96, 99, 100 subbagp-bagint1, 3 subbagp-bagint2, 3 subbagp-cdr1, 3 subbagp-cdr2, 3 subbagp-delete, 3 subbagp-implies-plus-tree-greate

reqp, 8 subbagp-subsetp, 75 subr-arity-alist, 293, 295 subrp-expr-v&c-apply$, 280 subsetp, 74, 75, 79, 310–316, 318–

320, 323 subsetp-append-1, 311 subsetp-append-2, 311 subsetp-bagint, 313 subsetp-cons, 311 subsetp-delete, 313 subsetp-implies-itimes-list-eva

l$-equals-0, 74 subsetp-member, 311 subsetp-reflexive, 311 subsetp-temp-alist-to-set-put-a

ssoc-1, 312 subsetp-temp-alist-to-set-s-cha

nge-temp, 312 subsetp-trans-fact-2, 312 subsetp-transistive, 312 sum-cdrs-v&c$-list-fact-1, 280

tag, 130, 132, 138, 142, 146, 148, 150–156, 158–162, 166, 167, 171, 178–183, 185–199, 228 temp-alist-to-set, 310–316, 318–320,

323 temp-alist-to-set-1, 310–312 temp-alist-to-set-1-cons-nil, 312 temp-alist-to-set-1-gives-membe

rs, 310 temp-alist-to-set-1-make-temp-e

ntries, 312 temp-alist-to-set-1-nlistp, 311 temp-alist-to-set-1-subsetp, 311 temp-alist-to-set-gives-members, 310 temp-alist-to-set-make-temp-ent

ries, 312 temp-var-dcls, 127, 142, 147, 208, 223, 232, 233, 240

temps-okp, 296–299, 301, 307

temps-okp-make-temps-entries, 301 temps-okp-put-assoc, 299 test-bitv-and-jump-preserves-p-i

nvariant, 267 test-bool-and-jump-preserves-p-i

nvariant, 267 test-int-and-jump-preserves-p-i

nvariant, 266 test-nat-and-jump-preserves-p-i

nvariant, 266 times-1-arg1, 15 times-add1, 14 times-distributes-over-differen

ce, 15

ce-proof, 14 times-distributes-over-plus, 14 times-distributes-over-plus-pro

of, 14 times-fringe, 17, 19–22, 31 times-quotient, 15 times-quotient-proof, 15 times-tree, 16, 18–22, 31, 32 times-tree-append, 19 times-tree-of-times-fringe, 19 times-zero, 14 top, 136, 139, 148, 149, 159–172, 174–199, 223, 225, 226 top1, 136, 163, 174–181, 183–186,

189–191, 194–196, 198 top2, 136, 179, 181, 186, 189, 190 total-p-system-size, 225 transitivity-of-divides, 26 transitivity-of-p-invariant1, 268 transitivity-of-same-signature, 258 type, 130, 138, 175, 228, 229, 231–

233, 238, 239 type-tag, 228

unabbreviate-constant, 151 unlabel, 137, 139, 212, 222, 230 untag, 130, 138, 139, 149, 159–165,

169–172, 174, 175, 178–199, 228–233, 238, 239, 261

untag-tag, 228 user-fname, 284, 288, 305–307, 317,

320, 323 user-fname-logic-fname-identity, 305 user-fname-prefix, 283, 284 user-fnamep, 284, 296–298, 305, 323 user-fnamep-user-fname, 323

v&c$-body-lessp-fact-1, 280 v&c$-f-l-eval-f, 279 v&c$-f-l-eval-f-if-helper-1, 278 v&c$-f-l-eval-f-if-helper-2, 279 v&c$-f-l-eval-flag-list, 279 v&c$-l-eval-equivalence, 278 v&c$-l-eval-flag-list, 280 v&c$-not-subrp-expand-1, 280 value, 127–129, 139, 237, 238, 291

x-y-error-msg, 200, 207, 229, 259 xor-bit, 135 xor-bitv, 135, 196 xor-bitv-preserves-p-invariant, 266 xor-bool, 132

zero-ilessp-implies-not-equal, 99 zerop-makes-equal-true-bridge, 21 zerop-makes-lessp-false-bridge, 20 zerop-makes-quotient-zero-bridge, 31 zerop-makes-times-tree-zero, 19 zerop-makes-times-tree-zero2, 19