diff options
Diffstat (limited to 'books/workshops/1999/embedded/Proof-Of-Contribution')
12 files changed, 18354 insertions, 0 deletions
diff --git a/books/workshops/1999/embedded/Proof-Of-Contribution/CRT.lisp b/books/workshops/1999/embedded/Proof-Of-Contribution/CRT.lisp new file mode 100644 index 0000000..4a95ba1 --- /dev/null +++ b/books/workshops/1999/embedded/Proof-Of-Contribution/CRT.lisp @@ -0,0 +1,836 @@ +;;;*************************************************************** +;;;An ACL2 Proof of the Chinese Remainder Theorem +;;;David M. Russinoff +;;;April, 1999 +;;;*************************************************************** + +(in-package "ACL2") + + + +(include-book "../../../../arithmetic/mod-gcd") + +(include-book "../../../../rtl/rel1/lib1/basic") + +(include-book "../../../../rtl/rel1/support/fp") + +(in-theory (disable rem)) + +(defun g-c-d (x y) (nonneg-int-gcd x y)) + + +(defun rel-prime (x y) + (= (g-c-d x y) 1)) + +(defun rel-prime-all (x l) + (if (endp l) + t + (and (rel-prime x (car l)) + (rel-prime-all x (cdr l))))) + +(defun rel-prime-moduli (l) + (if (endp l) + t + (and (integerp (car l)) + (>= (car l) 2) + (rel-prime-all (car l) (cdr l)) + (rel-prime-moduli (cdr l))))) + +(defun congruent (x y m) + (= (rem x m) (rem y m))) + +(defun congruent-all (x a m) + (declare (xargs :measure (acl2-count m))) + (if (endp m) + t + (and (congruent x (car a) (car m)) + (congruent-all x (cdr a) (cdr m))))) + +(defun natp-all (l) + (if (endp l) + t + (and (natp (car l)) + (natp-all (cdr l))))) + +#| +(defthm chinese-remainder-theorem + (implies (and (natp-all a) + (rel-prime-moduli m) + (= (len a) (len m))) + (and (natp (crt a m)) + (congruent-all (crt a m) a m)))) +|# + + +(defun a (x y) (nonneg-int-gcd-multiplier1 x y)) + +(defun b (x y) (nonneg-int-gcd-multiplier2 x y)) + + +(defun c (x l) + (if (endp l) + 0 + (- (+ (a x (car l)) + (c x (cdr l))) + (* (a x (car l)) + (c x (cdr l)) + x)))) + +(defun d (x l) + (if (endp l) + 1 + (* (b x (car l)) + (d x (cdr l))))) + +(defun prod (l) + (if (endp l) + 1 + (* (car l) (prod (cdr l))))) + +(defun one-mod (x l) (* (d x l) (prod l) (d x l) (prod l))) + +(defun crt1 (a m l) + (if (endp a) + 0 + (+ (* (car a) (one-mod (car m) (remove (car m) l))) + (crt1 (cdr a) (cdr m) l)))) + +(defun crt (a m) (crt1 a m m)) + +(defthm g-c-d-type + (implies (and (integerp x) (integerp y)) + (integerp (g-c-d x y))) + :rule-classes (:type-prescription)) + +(defthm A-B-THM + (implies (and (integerp x) (>= x 0) + (integerp y) (>= y 0)) + (= (+ (* (a x y) x) + (* (b x y) y)) + (g-c-d x y))) + :hints (("Goal" :use Linear-combination-for-nonneg-int-gcd)) + :rule-classes ()) + +(defthm hack-1 + (implies (and (rationalp a) + (rationalp b) + (= x a) + (= y b)) + (= (* a b) (* x y))) + :rule-classes ()) + +(defthm hack-2 + (implies (and (rationalp a) + (rationalp b) + (rationalp x) + (rationalp y) + (rationalp c) + (rationalp d) + (rationalp l) + (= 1 (+ (* a x) (* b y))) + (= 1 (+ (* c x) (* d l)))) + (= 1 + (+ (* a x) + (* c x) + (* b d y l) + (- (* x x a c))))) + :rule-classes () + :hints (("Goal" :use ((:instance hack-1 + (x (* b y)) + (y (* d l)) + (a (- 1 (* a x))) + (b (- 1 (* c x)))))))) + +(defthm c-type + (implies (and (integerp x) + (natp-all l)) + (rationalp (c x l))) + :rule-classes (:type-prescription)) + +(defthm prod-type + (implies (natp-all l) + (rationalp (prod l))) + :rule-classes (:type-prescription)) + +(defthm C-D-THM + (implies (and (natp x) + (natp-all l) + (rel-prime-all x l)) + (= (+ (* (c x l) x) + (* (d x l) (prod l))) + 1)) + :rule-classes () + :hints (("Subgoal *1/4" :use ((:instance a-b-thm (y (car l))) + (:instance hack-2 + (a (a x (car l))) + (b (b x (car l))) + (y (car l)) + (l (prod (cdr l))) + (c (c x (cdr l))) + (d (d x (cdr l)))))))) + +(defthm c-int + (implies (and (integerp x) + (natp-all l)) + (integerp (c x l))) + :rule-classes ()) + +(in-theory (disable rel-prime rel-prime-all rel-prime-moduli one-mod crt1 crt a b c d prod)) + +(defthm hack-3 + (implies (= x y) + (= (* x x) (* y y))) + :rule-classes ()) + +(defthm hack-4 + (implies (and (rationalp c) + (rationalp d) + (rationalp m) + (rationalp p) + (= (+ (* c m) (* d p)) 1)) + (= (* d p d p) + (* (1+ (* m c (- (* c m) 2)))))) + :rule-classes () + :hints (("Goal" :use ((:instance hack-3 (x (* d p)) (y (- 1 (* c m)))))))) + +(defthm one-mod-alt + (implies (and (natp m) + (> m 1) + (natp-all l) + (rel-prime-all m l)) + (= (one-mod m l) + (1+ (* m (c m l) (- (* (c m l) m) 2))))) + :rule-classes () + :hints (("Goal" :in-theory (enable one-mod) + :use ((:instance c-int (x m)) + (:instance c-d-thm (x m)) + (:instance hack-4 + (c (c m l)) + (d (d m l)) + (p (prod l))))))) + +(defthm hack-5 + (implies (and (integerp m) + (integerp c) + (integerp cm) + (>= m 2) + (>= c 1) + (>= cm 0)) + (natp (* m c cm))) + :rule-classes ()) + +(defthm hack-6 + (implies (and (integerp c) + (>= c 1) + (integerp m) + (> m 1)) + (natp (1+ (* m c (- (* c m) 2))))) + :rule-classes () + :hints (("Goal" :use ((:instance hack-5 (cm (- (* c m) 2))))))) + +(defthm hack-7 + (implies (and (integerp m) + (integerp c) + (integerp cm) + (>= m 2) + (< c 0) + (< cm 0)) + (natp (* m c cm))) + :rule-classes ()) + +(defthm hack-8 + (implies (and (integerp c) + (< c 1) + (integerp m) + (> m 1)) + (natp (1+ (* m c (- (* c m) 2))))) + :rule-classes () + :hints (("Goal" :use ((:instance hack-7 (cm (- (* c m) 2))))))) + +(defthm hack-9 + (implies (and (integerp c) + (integerp m) + (> m 1)) + (natp (1+ (* m c (- (* c m) 2))))) + :rule-classes () + :hints (("Goal" :use (hack-6 hack-8)))) + +(defthm ONE-MOD-NAT + (implies (and (natp x) + (> x 1) + (natp-all l) + (rel-prime-all x l)) + (natp (one-mod x l))) + :rule-classes () + :hints (("Goal" :use ((:instance one-mod-alt (m x)) + (:instance c-int) + (:instance hack-9 (m x) (c (c x l))))))) + +(defthm hack-10 + (implies (and (integerp m) + (> m 1) + (integerp p) + (>= (1+ (* m p)) 0)) + (>= p 0)) + :rule-classes ()) + +(defthm hack-11 + (implies (and (integerp m) + (> m 1) + (integerp c) + (>= (1+ (* m c (- (* c m) 2))) 0)) + (>= (* c (- (* c m) 2)) 0)) + :rule-classes () + :hints (("Goal" :use ((:instance hack-10 (p (* c (- (* c m) 2)))))))) + +(defthm rem-one-mod-m-1 + (implies (and (natp m) + (> m 1) + (natp-all l) + (rel-prime-all m l)) + (>= (* (c m l) (- (* (c m l) m) 2)) + 0)) + :rule-classes () + :hints (("Goal" :use (one-mod-alt + (:instance one-mod-nat (x m)) + (:instance c-int (x m)) + (:instance hack-11 (c (c m l))))))) + +(defthm REM-ONE-MOD-1 + (implies (and (natp x) + (> x 1) + (natp-all l) + (rel-prime-all x l)) + (= (rem (one-mod x l) x) 1)) + :rule-classes () + :hints (("Goal" :use (one-mod-nat + (:instance one-mod-alt (m x)) + (:instance rem-one-mod-m-1 (m x)) + (:instance c-int) + (:instance rem< (m 1) (n x)) + (:instance rem+ + (m 1) + (n x) + (a (* (c x l) + (- (* (c x l) x) + 2)))))))) + +; Matt K.: Removed definition of remove1 (defined in ACL2 starting with +; v2-9-4). + +(defthm prod-factor + (implies (and (natp-all l) + (member x l)) + (= (prod l) + (* x (prod (remove1 x l))))) + :rule-classes () + :hints (("Goal" :in-theory (enable prod)))) + +(defthm one-mod-factor + (implies (and (integerp m) + (natp-all l) + (member x l)) + (= (one-mod m l) + (* x (d m l) (prod (remove1 x l)) (d m l) (prod l)))) + :rule-classes () + :hints (("Goal" :in-theory (enable one-mod) + :use (prod-factor)))) + +(defthm prod-int + (implies (natp-all l) + (integerp (prod l))) + :rule-classes (:type-prescription) + :hints (("Goal" :in-theory (enable prod)))) + +(defthm natp-remove1 + (implies (natp-all l) + (natp-all (remove1 x l)))) + +(defthm hack-12 + (implies (and (integerp a) + (integerp b) + (integerp c) + (integerp d)) + (integerp (* a b c d))) + :rule-classes ()) + +(defthm rem-one-mod-x-1 + (implies (and (natp m) + (> m 1) + (natp-all l)) + (INTEGERP (* (PROD L) + (D M L) + (D M L) + (PROD (REMOVE1 X L))))) + :hints (("Goal" :in-theory (disable prod-int) + :use (prod-int + (:instance prod-int (l (remove1 x l))) + (:instance hack-12 + (a (prod l)) + (b (d m l)) + (c (d m l)) + (d (prod (remove1 x l)))))))) + +(defthm rem-one-mod-x-2 + (implies (and (natp m) + (> m 1) + (natp-all l) + (rel-prime-all m l) + (member x l) + (integerp x) + (> x 0)) + (= (rem (one-mod m l) x) 0)) + :rule-classes () + :hints (("Goal" :use (one-mod-factor + (:instance one-mod-nat (x m)) + (:instance divides-rem-0 + (n x) + (a (* (d m l) (prod (remove1 x l)) (d m l) (prod l)))))))) + +(defthm modulus-pos + (implies (and (rel-prime-moduli l) + (member x l)) + (and (integerp x) + (> x 1))) + :rule-classes () + :hints (("Goal" :in-theory (enable rel-prime-moduli)))) + +(defthm moduli-natp-all + (implies (rel-prime-moduli l) + (natp-all l)) + :hints (("Goal" :in-theory (enable rel-prime-moduli)))) + +(defthm REM-ONE-MOD-0 + (implies (and (natp x) + (> x 1) + (rel-prime-moduli l) + (rel-prime-all x l) + (member y l)) + (= (rem (one-mod x l) y) 0)) + :rule-classes () + :hints (("Goal" :use ((:instance rem-one-mod-x-2 (m x) (x y)) + (:instance modulus-pos (x y)))))) + +(defthm rem0+0 + (implies (and (natp a) + (natp b) + (natp c) + (natp n) + (> n 0) + (= (rem a n) 0) + (= (rem c n) 0)) + (= (rem (+ (* a b) c) n) 0)) + :rule-classes () + :hints (("Goal" :use ((:instance rem+rem (a (* a b)) (b c)) + (:instance n<=fl (n 0) (x (/ a n))) + (:instance divides-rem-0 (a (* (fl (/ a n)) b))) + (:instance fl-rem-0 (m a)))))) + +(defthm rel-prime-all-remove + (implies (rel-prime-all m l) + (rel-prime-all m (remove x l))) + :hints (("Goal" :in-theory (enable rel-prime-all)))) + +(defthm rel-prime-remove + (implies (rel-prime-moduli l) + (rel-prime-moduli (remove x l))) + :hints (("Goal" :in-theory (enable rel-prime-moduli)))) + +(defthm member-remove + (implies (and (member x l) + (not (eql x y))) + (member x (remove y l)))) + +(defun sublistp (m l) + (if (endp m) + t + (and (member (car m) l) + (sublistp (cdr m) l)))) + +(defthm member-sublistp + (implies (and (sublistp m l) + (member x m)) + (member x l))) + +(defthm g-c-d-commutative + (implies (and (natp x) (natp y)) + (= (g-c-d x y) (g-c-d y x))) + :rule-classes ()) + +(defthm rel-prime-all-rel-prime + (implies (and (rel-prime-all x l) + (member y l)) + (rel-prime x y)) + :rule-classes () + :hints (("Goal" :in-theory (enable rel-prime-all)))) + +(defthm rel-prime-all-moduli-remove + (implies (and (rel-prime-moduli l) + (member x l)) + (rel-prime-all x (remove x l))) + :hints (("Goal" :in-theory (enable rel-prime-all rel-prime-moduli)) + ("Subgoal *1/7''" :use ((:instance rel-prime-all-rel-prime + (x (car l)) + (l (cdr l)) + (y x)) + (:instance g-c-d-commutative (y (car l)))) + :in-theory (enable rel-prime)) + ("Subgoal *1/7'''" :in-theory (disable rel-prime) + :use (:instance rel-prime (x (car l)) (y x))) + ("Subgoal *1/7.2'''" + :in-theory (enable rel-prime) + :use ( + (:instance g-c-d-commutative (y l1)))) + ("Subgoal *1.1/5" :use ((:instance g-c-d-commutative (y l1)))))) + +(defthm rel-prime-modulus-nat + (implies (and (member x l) + (rel-prime-moduli l)) + (and (natp x) (> x 1))) + :rule-classes () + :hints (("Goal" :in-theory (enable rel-prime-moduli)))) + +(defthm REM-CRT1 + (implies (and (natp-all a) + (rel-prime-moduli m) + (= (len a) (len m)) + (rel-prime-moduli l) + (sublistp m l) + (member x l) + (not (member x m))) + (and (natp (crt1 a m l)) + (= (rem (crt1 a m l) x) 0))) + :rule-classes () + :hints (("Goal" :in-theory (enable rel-prime-moduli crt1)) + ("Subgoal *1/1" :use (modulus-pos + (:instance rem< (m 0) (n x)))) + ("Subgoal *1/3" :use ((:instance rem0+0 + (n x) + (a (one-mod (car m) (remove (car m) l))) + (b (car a)) + (c (crt1 (cdr a) (cdr m) l))) + (:instance rel-prime-modulus-nat) + (:instance rem-one-mod-0 + (x (car m)) + (y x) + (l (remove (car m) l))) + (:instance one-mod-nat + (x (car m)) + (l (remove (car m) l))))))) + +(defthm rem0+1-1 + (implies (and (natp a) + (natp b) + (natp c) + (natp n) + (> n 0)) + (= (rem (* a (1+ (* (fl (/ b n)) n))) n) + (rem a n))) + :rule-classes () + :hints (("Goal" :use ((:instance n<=fl (n 0) (x (/ b n))) + (:instance rem+ (a (* a (fl (/ b n)))) (m a)))))) + +(defthm rem0+1-2 + (implies (and (natp a) + (natp b) + (natp c) + (natp n) + (= (rem b n) 1) + (> n 0)) + (= (rem (* a (+ (rem b n) (* (fl (/ b n)) n))) n) + (rem a n))) + :rule-classes () + :hints (("Goal" :use (rem0+1-1)))) + +(defthm rem0+1-3 + (implies (and (natp a) + (natp b) + (natp c) + (natp n) + (= (rem b n) 1) + (> n 0)) + (= (rem (* a b) n) + (rem (* a (+ (rem b n) (* (fl (/ b n)) n))) n))) + :rule-classes () + :hints (("Goal" :use ((:instance rem-fl (m b)))))) + +(defthm rem0+1-4 + (implies (and (natp a) + (natp b) + (natp c) + (natp n) + (= (rem b n) 1) + (> n 0)) + (= (rem (* a b) n) + (rem a n))) + :rule-classes () + :hints (("Goal" :in-theory (disable a9 unicity-of-1) + :use (rem0+1-2 + rem0+1-3)))) + +(defthm rem0+1 + (implies (and (natp a) + (natp b) + (natp c) + (natp n) + (> n 0) + (= (rem b n) 1) + (= (rem c n) 0)) + (= (rem (+ (* a b) c) n) (rem a n))) + :rule-classes () + :hints (("Goal" :use (rem0+1-4 + (:instance rem+rem (a (* a b)) (b c)))))) + + +;;; In order to prove rel-prime-not-eql, I seemingly had to add the lemmas +;;; nonneg-mod-x-x-is-0 and nonneg-gcd-x-x-is-x. + +(defthm nonneg-mod-x-x-is-0 + (implies (natp x) + (= (nonneg-int-mod x x) 0)) + :rule-classes nil) + +(defthm nonneg-gcd-x-x-is-x + (implies (natp x) + (= (nonneg-int-gcd x x) x)) + :hints (("Goal" :in-theory (disable nonneg-int-gcd) + :use ( (:instance nonneg-int-gcd (y x)) + nonneg-mod-x-x-is-0 + (:instance nonneg-int-gcd (y 0))))) + :rule-classes nil) + +(local (in-theory (disable commutativity-of-nonneg-int-gcd))) + +(defthm rel-prime-not-eql + (implies (and (natp x) + (natp y) + (> x 1) + (rel-prime x y)) + (not (= x y))) + :rule-classes () + :hints (("Subgoal *1/4.2" :in-theory nil) + ("Subgoal *1/4.1" :in-theory (current-theory 'ground-zero) + :use (:instance nonneg-int-gcd (y 0))) + ("Subgoal *1/3" :in-theory '((:definition natp)) :use nonneg-gcd-x-x-is-x) + ("Subgoal *1/2" :in-theory '((:definition natp)) :use nonneg-gcd-x-x-is-x) + ("Subgoal *1/1" :in-theory '((:definition natp)) :use nonneg-gcd-x-x-is-x) + ("Goal" :in-theory (enable rel-prime g-c-d)))) + +(defthm not-member-rel-prime-all + (implies (and (natp x) + (> x 1) + (rel-prime-all x m)) + (not (member x m))) + :hints (("Goal" :in-theory (enable rel-prime-all)) + ("Subgoal *1/2'4'" :use ((:instance rel-prime-not-eql (x m1) (y m1)))))) + +(defun cong0-all (x l) + (if (endp l) + t + (and (= (rem x (car l)) 0) + (cong0-all x (cdr l))))) + +(defthm cong0-1 + (implies (and (natp a) + (natp m) + (> m 1) + (sublistp l1 l) + (rel-prime-all m l1) + (rel-prime-moduli l1) + (rel-prime-all m l) + (rel-prime-moduli l)) + (cong0-all (* a (one-mod m l)) l1)) + :rule-classes () + :hints (("Goal" :in-theory (enable rel-prime-all rel-prime-moduli)) + ("Subgoal *1/6" :use ((:instance rem-one-mod-0 (x m) (y (car l1))) + (:instance one-mod-nat (x m)) + (:instance rem< (m 0) (n (car l1))) + (:instance rem0+0 (c 0) (a (one-mod m l)) (b a) (n (car l1))))))) + +(defun sublistp-induct (n l) + (declare (xargs :measure (acl2-count (nthcdr n l)) + :hints (("Goal''" :induct (nthcdr n l))))) + (if (and (natp n) (< n (len l))) + (sublistp-induct (1+ n) l) + t)) + + +(defthm sublistp-last + (sublistp (nthcdr (len l) l) m) + :hints (("Goal" :induct (len l)))) + +(defthm nthcdr+1 + (implies (natp n) + (equal (NTHCDR (+ 1 N) L) + (cdr (nthcdr n l))))) + +(defthm member-car-nthcdr + (IMPLIES (AND (INTEGERP N) + (<= 0 N) + (< N (LEN L))) + (MEMBER (CAR (NTHCDR N L)) L))) + +(defthm sublistp-nthcdr + (implies (and (natp n) + (<= n (len l))) + (sublistp (nthcdr n l) l)) + :rule-classes () + :hints (("Goal" :induct (sublistp-induct n l)))) + +(defthm sublistp-l-l + (sublistp l l) + :hints (("Goal" :use ((:instance sublistp-nthcdr (n 0)))))) + +(defthm sublistp-remove + (implies (and (sublistp m l) + (not (member x m))) + (sublistp m (remove x l)))) + +(defun distinctp (l) + (if (endp l) + t + (and (not (member (car l) (cdr l))) + (distinctp (cdr l))))) + +(defthm sublistp-cdr-remove + (implies (and (sublistp m l) + (distinctp m) + (consp m)) + (sublistp (cdr m) (remove (car m) l)))) + +(defthm rel-prime-sublist + (implies (and (rel-prime-all x l) + (sublistp m l)) + (rel-prime-all x m)) + :rule-classes () + :hints (("Goal" :in-theory (enable rel-prime-all)))) + +(defthm rel-prime-moduli-sublist + (implies (and (rel-prime-moduli l) + (distinctp m) + (sublistp m l)) + (rel-prime-moduli m)) + :rule-classes () + :hints (("Goal" :in-theory (enable rel-prime-moduli rel-prime-all)) + ("Subgoal *1/7" :use ((:instance rel-prime-modulus-nat (x (car m))))) + ("Subgoal *1/6" :use ((:instance rel-prime-modulus-nat (x (car m))))) + ("Subgoal *1/5" :use ((:instance rel-prime-sublist (x (car m)) (m (cdr m)) (l (remove (car m) l))))))) + +(defthm cong0-2 + (implies (and (natp a) + (sublistp m l) + (distinctp m) + (rel-prime-moduli l)) + (cong0-all (* a (one-mod (car m) (remove (car m) l))) (cdr m))) + :rule-classes () + :hints (("Goal" :in-theory (enable rel-prime-moduli rel-prime-all) + :use ((:instance cong0-1 (m (car m)) (l (remove (car m) l)) (l1 (cdr m))) + (:instance rel-prime-all-moduli-remove (x (car m))) + (:instance rel-prime-moduli-sublist) + (:instance rel-prime-modulus-nat (x (car m))))))) + +(defthm cong0-3 + (implies (and (rel-prime-moduli m) + (natp x) + (natp y) + (natp-all a) + (cong0-all x m) + (= (len a) (len m)) + (congruent-all y a m)) + (congruent-all (+ x y) a m)) + :rule-classes () + :hints (("Goal" :in-theory (enable rel-prime-moduli)) + ("Subgoal *1/8" :use ((:instance rem< (m 1) (n (car m))) + (:instance rem0+1 + (a y) + (b 1) + (c x) + (n (car m))))))) + +(defthm natp-crt1 + (implies (and (natp-all a) + (rel-prime-moduli m) + (= (len a) (len m)) + (rel-prime-moduli l) + (distinctp m) + (sublistp m l)) + (natp (crt1 a m l))) + :rule-classes () + :hints (("Goal" :in-theory (enable rel-prime-moduli crt1)) + ("Subgoal *1/2" :use ((:instance one-mod-nat + (x (car m)) + (l (remove (car m) l))))))) + +(defthm crt1-lemma + (implies (and (natp-all a) + (rel-prime-moduli m) + (distinctp m) + (= (len a) (len m)) + (rel-prime-moduli l) + (sublistp m l)) + (congruent-all (crt1 a m l) a m)) + :rule-classes () + :hints (("Goal" :in-theory (enable congruent-all rel-prime-moduli crt1)) + ("Subgoal *1/8" :use ((:instance rem0+1 + (a (car a)) + (n (car m)) + (b (ONE-MOD (CAR M) (REMOVE (CAR M) L))) + (c (CRT1 (CDR A) (CDR M) L))) + (:instance rem-one-mod-1 + (x (car m)) + (l (remove (car m) l))) + (:instance one-mod-nat + (x (car m)) + (l (remove (car m) l))) + (:instance rem-crt1 + (a (cdr a)) + (m (cdr m)) + (x (car m))))) + ("Subgoal *1/7" :use ((:instance natp-crt1 (a (cdr a)) (m (cdr m))) + (:instance cong0-2 (a (car a))) + (:instance one-mod-nat + (x (car m)) + (l (remove (car m) l))) + (:instance cong0-3 + (y (CRT1 (CDR A) (CDR M) L)) + (a (cdr a)) + (m (cdr m)) + (x (* (CAR A) (ONE-MOD (CAR M) (REMOVE (CAR M) L))))))))) + +(defthm distinctp-rel-prime-moduli + (implies (rel-prime-moduli m) + (distinctp m)) + :hints (("Goal" :in-theory (enable rel-prime-moduli rel-prime-all)))) + +(in-theory (disable distinctp)) + +(defthm CRT1-THM + (implies (and (natp-all a) + (rel-prime-moduli m) + (= (len a) (len m)) + (rel-prime-moduli l) + (sublistp m l)) + (congruent-all (crt1 a m l) a m)) + :rule-classes () + :hints (("Goal" :use (crt1-lemma)))) + +(defthm chinese-remainder-theorem + (implies + (and (natp-all values) + (rel-prime-moduli rns) + (= (len values) (len rns))) + (and (natp (crt values rns)) + (congruent-all (crt values rns) values rns))) + :rule-classes () + :hints (("Goal" :in-theory (enable crt) + :use ((:instance natp-crt1 (a values) (l rns) (m rns)) + (:instance crt1-thm (a values) (l rns) (m rns)))))) + + + + + + + + + diff --git a/books/workshops/1999/embedded/Proof-Of-Contribution/CRTcorollaries.lisp b/books/workshops/1999/embedded/Proof-Of-Contribution/CRTcorollaries.lisp new file mode 100644 index 0000000..c9439c8 --- /dev/null +++ b/books/workshops/1999/embedded/Proof-Of-Contribution/CRTcorollaries.lisp @@ -0,0 +1,1365 @@ + + + + +(in-package "ACL2") + +(include-book "CRT") + +(in-theory (disable g-c-d)) + +(defthm pg-hack-1 + (implies (and (integerp v) (= gcd 1)) (= (* v gcd) v)) + :rule-classes nil) + +(defthm pg-hack-2 + (implies + (and + (natp x) + (natp y) + (integerp v) + (= (g-c-d x y) 1)) + (= (* v (+ (* (A X Y) X) (* (B X Y) Y))) v)) + :hints (("Goal" :in-theory '((:definition natp)) + :use (a-b-thm + (:instance pg-hack-1 (gcd (+ (* (A X Y) X) (* (B X Y) Y))))))) + :rule-classes nil) + + +(defthm pg-hack-3 + (implies + (and + (integerp a) + (integerp b) + (natp x) + (natp y) + (> x 0) + (> y 0) + (integerp v)) + (= (* v (+ (* A X) (* B Y)) (/ (* x y))) + (+ (* (/ v y) a) (* (/ v x) b)))) + :rule-classes nil) + + +(defthm pg-hack-4 + (implies + (and + (natp x) + (natp y) + (> x 0) + (> y 0) + (integerp v)) + (= (* v (+ (* (A X Y) X) (* (B X Y) Y)) (/ (* x y))) + (+ (* (/ v y) (a x y)) (* (/ v x) (b x y))))) + :hints (("Goal" :use ((:instance pg-hack-3 (a (a x y)) (b (b x y))) + (:type-prescription a) + (:type-prescription b)))) + :rule-classes nil) + + +(defthm pg-hack-5 + (implies + (and + (integerp v1) + (integerp v2) + (integerp v3) + (integerp v4)) + (integerp (+ (* v1 v2) (* v3 v4)))) + :rule-classes nil) + + +(defthm pg-hack-6 + (implies + (and + (integerp (/ v y)) + (integerp (/ v x))) + (integerp (+ (* (/ v y) (a x y)) (* (/ v x) (b x y))))) + :hints (("Goal" :use ( (:instance pg-hack-5 (v1 (/ v y)) (v2 (a x y)) (v3 (/ v x)) (v4 (b x y))) + (:type-prescription a) + (:type-prescription b)))) + :rule-classes nil) + +(defthm pg-hack-7 +(IMPLIES + (AND + (equal decomp-a-b + V) + (equal (* decomp-a-b + div) + res) + (INTEGERP res)) + (INTEGERP (* V div))) +:hints (("Goal" :in-theory nil)) +:rule-classes nil) + + + +(defthm divides-both + (implies + (and + (natp x) + (natp y) + (> x 0) + (> y 0) + (integerp v) + (integerp (/ v y)) + (integerp (/ v x)) + (rel-prime x y)) + (integerp (/ v (* x y)))) + :hints (("Goal" :in-theory (current-theory 'ground-zero) + :use (rel-prime + pg-hack-2 + pg-hack-4 + pg-hack-6 + (:instance pg-hack-7 (div (/ (* X Y))) + (res (+ (* (* V (/ Y)) (A X Y)) (* (* V (/ X)) (B X Y)))) + (decomp-a-b (* V (+ (* (A X Y) X) (* (B X Y) Y))))))))) + +(defun posp-all (l) + (if (endp l) + t + (and (posp (car l)) + (posp-all (cdr l))))) + + + + + +(defthm mod-0-intp + (implies + (and + (natp n) + (posp d)) + (equal (integerp (/ n d)) (equal (nonneg-int-mod n d) 0))) + :hints (("Goal" :use (:instance Left-nonneg-int-mod-* (n d) (j (/ n d)))))) + + + +(defthm only-divisor-of-coprimes-is-1 + (implies + (and + (natp y) + (natp x) + (posp z) + (rel-prime x y) + (integerp (/ x z)) + (integerp (/ y z))) + (= z 1)) + :hints (("Goal" :use (rel-prime g-c-d + (:instance Nonneg-int-gcd-is-LARGEST-common-divisor-<= (d z))))) + :rule-classes nil) + + +(defthm integer-div-of-factor + (implies + (and + (natp a) + (natp b) + (natp c) + (rel-prime a b) + (integerp (/ (* b c) a))) + (integerp (/ c a))) + :hints (("Goal" :use + ((:instance rel-prime (x a) (y b)) + (:instance g-c-d (x a) (y b)) + (:instance mod-0-intp (n c) (d a)) + (:instance mod-0-intp (n (* b c)) (d a)) + (:instance Divisor-of-product-divides-factor (y b) (z a) (x c)))))) + + + +(defthm ck1 + (implies + (and + (integerp x) + (posp y) + (integerp (/ x y))) + (= x (* (/ x y) y))) + :rule-classes nil) + +(defthm ck2 + (implies + (and + (integerp c) + (= (+ (* a x) (* b y)) 1)) + (= (* c (+ (* a x) (* b y))) c)) + :rule-classes nil) + +(defthm ck3 + (implies + (and + (integerp c)) + (= (+ (* c a x) (* c b y)) + (* c (+ (* a x) (* b y))))) + :rule-classes nil) + +(defthm ck4 + (implies + (and + (integerp c) + (= (+ (* a x) (* b y)) 1)) + (= (+ (* c a x) (* c b y)) c)) + :hints (("Goal" :use (ck2 ck3))) + :rule-classes nil) + + + + +(defthm ck5 + (implies + (and + (natp m) + (natp n) + (natp k) + (rel-prime m n)) + (= k (+ (* k (a m n) m) (* k (b m n) n)))) + :hints (("Goal" :use ( + (:instance ck4 (a (a m n)) (b (b m n)) (x m) (y n) (c k)) + (:instance a-b-thm (x m) (y n)) + (:instance rel-prime (x m) (y n))))) + :rule-classes nil) + +(defthm ck6 + (implies + (and + (natp m) + (natp n) + (natp k) + (posp cd) + (integerp (/ m cd)) + (integerp (/ (* n k) cd)) + (rel-prime m n)) + (= k (+ (* k (a m n) (/ m cd) cd) (* (b m n) (/ (* n k) cd) cd)))) + :hints (("Goal" :use ( + ck5 + (:instance ck1 (x m) (y cd)) + (:instance ck1 (x (* n k)) (y cd))))) + :rule-classes nil) + +(defthm ck7 + (implies + (and + (natp m) + (natp n) + (natp k) + (posp cd) + (integerp (/ m cd)) + (integerp (/ (* n k) cd)) + (rel-prime m n)) + (= k (* cd (+ (* k (a m n) (/ m cd) ) (* (b m n) (/ (* n k) cd)))))) + :hints (("Goal" :use ck6)) + :rule-classes nil) + +(defthm ck8 + (implies + (and + (natp m) + (natp n) + (natp k) + (posp cd) + (integerp (/ m cd)) + (integerp (/ (* n k) cd)) + (rel-prime m n)) + (integerp (+ (* k (a m n) (/ m cd) ) (* (b m n) (/ (* n k) cd))))) + :rule-classes nil) + +(defthm ck9 + (implies + (and + (natp m) + (natp n) + (natp k) + (posp cd) + (integerp (/ m cd)) + (integerp (/ (* n k) cd)) + (rel-prime m n)) + (= (/ k cd) (+ (* k (a m n) (/ m cd) ) (* (b m n) (/ (* n k) cd))))) + :hints (("Goal" :use ( ck8 ck7))) + :rule-classes nil) + + +(defthm integer-div-of-factor-due + (implies + (and + (natp m) + (natp n) + (natp k) + (posp cd) + (integerp (/ m cd)) + (integerp (/ (* n k) cd)) + (rel-prime m n)) + (integerp (/ k cd))) + :hints (("Goal" :in-theory nil :use ( ck8 ck9))) + :rule-classes nil) + + + +(defthm gcd-divides-both + (implies + (and + (natp x) + (posp y)) + (and + (integerp (/ x (g-c-d x y))) + (integerp (/ y (g-c-d x y))))) + :hints (("Goal" :in-theory (enable g-c-d)))) + + +(defthm divboth1 + (implies + (and + (posp x) + (posp y) + (natp v) + (rel-prime v x) + (rel-prime v y)) + (and + (integerp (/ v (g-c-d v (* x y)))) + (integerp (/ (* x y) (g-c-d v (* x y)))))) + :hints (("Goal" :use ((:instance gcd-divides-both (x v) (y (* x y))))))) + + +(defthm divboth2 + (implies + (and + (posp n) + (posp k) + (natp m) + (rel-prime m n) + (rel-prime m k)) + (and + (integerp (/ m (g-c-d m (* n k)))) + (integerp (/ k (g-c-d m (* n k)))))) + :hints (("Goal" :use ( + (:instance g-c-d (x m) (y (* n k))) + (:instance Nonneg-int-gcd->-0 (n m) (d (* n k))) + (:instance divboth1 (v m) (x n) (y k)) + (:instance integer-div-of-factor-due (cd (g-c-d m (* n k)))))))) + + +(defthm prime-of-product + (implies + (and + (posp n) + (posp k) + (natp m) + (rel-prime m n) + (rel-prime m k)) + (rel-prime m (* n k))) + :hints (("Goal" :in-theory (enable rel-prime) + :use ( divboth2 + (:instance g-c-d (x m) (y (* n k))) + (:instance Nonneg-int-gcd->-0 (n m) (d (* n k))) + (:instance only-divisor-of-coprimes-is-1 + (z (g-c-d m (* n k))) + (x m) + (y k)))))) + + + + +(defun divided-by-all (k m) + (if (endp m) + t + (and + (integerp (/ k (car m))) + (divided-by-all k (cdr m))))) + + +(in-theory (enable prod rel-prime rel-prime-moduli)) + +(defthm helper + (implies + (and + (not (endp m)) + (posp-all m)) + (and + (posp-all (cdr m)) + (posp (car m)) + (posp (prod m)) + (posp (prod (cdr m))))) + :rule-classes nil) + +(defthm helper2 + (implies + (and + (not (endp m)) + (rel-prime-all el m)) + (and + (rel-prime el (car m)) + (rel-prime-all el (cdr m)))) + :hints (("Goal" :use (:instance rel-prime-all (x el) (l m)))) + :rule-classes nil) + + +(defthm rel-prime-of-product + (implies + (and + (posp-all m) + (natp el) + (rel-prime-all el m)) + (rel-prime el (prod m))) + :hints ( ("Goal" :in-theory (disable rel-prime natp) :induct (len m)) + ("Subgoal *1/2''" :use ( (:instance rel-prime (x el) (y 1)) + (:instance g-c-d (x el) (y 1)) + (:instance Nonneg-int-gcd-1-right (x el)))) + ("Subgoal *1/1'" :use + (helper + helper2 + (:instance prod (l m)) + (:instance prime-of-product (n (car m)) (k (prod (cdr m))) (m el)))))) + + +(defthm helper3 + (implies + (and + (not (endp m)) + (rel-prime-moduli m)) + (and + (rel-prime-moduli (cdr m)) + (posp-all (cdr m)) + (natp (car m)) + (< 0 (car m))))) + + + +(defthm diff-prod-means-cong-all-mod-list-inv-00 + (implies + (and + (rel-prime-moduli m) + (integerp v) + (divided-by-all v m)) + (integerp (/ v (prod m)))) + :hints (("Goal" :induct (len m)) + ("Subgoal *1/1" + :in-theory '((:definition posp) (:definition natp)) + :use + ( + helper + helper3 + (:instance natp-all (l m)) + (:instance posp-all (l m)) + (:instance prod (l m)) + (:instance rel-prime-moduli (l m)) + (:instance divided-by-all (k v)) + (:instance rel-prime-of-product (el (car m)) (m (cdr m))) + (:instance divides-both (x (car m)) (y (prod (cdr m)))))))) + + + + + +(in-theory + (union-theories (current-theory 'ground-zero) + '((:definition prod) + (:definition natp) + (:definition natp-all) + (:definition congruent) + (:definition congruent-all) + (:definition posp) + (:executable-counterpart prod) + (:type-prescription prod) + (:induction prod) + (:executable-counterpart posp) + (:type-prescription posp) + (:definition posp-all) + (:executable-counterpart posp-all) + (:type-prescription posp-all) + (:induction posp-all) + (:definition divided-by-all) + (:executable-counterpart divided-by-all) + (:type-prescription divided-by-all) + (:induction divided-by-all) ))) + + +(include-book "../../../../arithmetic/top-with-meta") + +(include-book "Minimal-Mod-Lemmas") + +(in-theory (disable mod-x-y-=-x-exp)) + +(in-theory (disable mod)) + +(defthm r-mod-mod + (implies + (and + (integerp x) + (integerp z) + (integerp i) + (> i 0) + (> z 0)) + (equal (mod (mod x (* i z)) z) + (mod x z))) + :hints (("Goal" :use (:instance rewrite-mod-mod-exp (y (* i z)))))) + +(defthm r-mod-mod-cancel + (implies + (and + (integerp x) + (integerp z) + (> z 0)) + (equal (mod (mod x z) z) (mod x z)))) + + + + + +(defun posp-all (l) + (if (endp l) + t + (and (posp (car l)) + (posp-all (cdr l))))) + + + +(defun divided-by-all (k m) + (if (endp m) + t + (and + (integerp (/ k (car m))) + (divided-by-all k (cdr m))))) + + + + +(defthm product-divided-by-all + (implies + (posp-all m) + (divided-by-all (prod m) m)) + :hints (("Subgoal *1/1.2''" + :induct t) + ("Goal" + :in-theory (disable commutativity-of-*) + :induct (len m)))) + + + +(defthm prod-is-pos + (implies + (posp-all m) + (posp (prod m)))) + +(defun congruent-mod (x y m) + (= (mod x m) (mod y m))) + + +(defun congruent-all-mod (x a m) + (declare (xargs :measure (len m))) + (if (endp m) + t + (and (congruent-mod x (car a) (car m)) + (congruent-all-mod x (cdr a) (cdr m))))) + +(defthm any-number-which-divided-by-all-has-same-congruence + (implies + (and + (equal (len y) (len m)) + (integerp x) + (posp k) + (posp-all m) + (divided-by-all k m)) + (equal + (congruent-all-mod (mod x k) y m) + (congruent-all-mod x y m)))) + + +(defthm modulo-prod-has-same-congruence + (implies + (and + (equal (len y) (len m)) + (integerp x) + (posp-all m)) + (equal + (congruent-all-mod (mod x (prod m)) y m) + (congruent-all-mod x y m)))) + + + + +(defthm nonint-equ-modneg-2 + (implies + (and + (integerp x) + (integerp y) + (not (integerp (/ x y)))) + (equal (mod (- x) y) (- y (mod x y)))) + :hints (("Goal" :in-theory (enable mod))) + :rule-classes nil) + +(defthm int-equ-modneg + (implies + (and + (integerp x) + (integerp y) + (not (equal y 0)) + (integerp (/ x y))) + (and + (equal (mod x y) 0) + (equal (mod (- x) y) 0))) + :rule-classes nil) + + + + + +(defthm mod--nin + (implies + (and (integerp x) + (integerp y) + (integerp z) + (not (integerp (/ y z))) + (not (equal z 0))) + (equal (mod (- x y) z) + (mod (- (mod x z) (mod y z)) z))) + :hints (("Goal" + :use ( + (:instance mod-+-exp (y (- y))) + (:instance nonint-equ-modneg-2 (x y) (y z)) + (:instance cancel-mod-+-exp + (i (/ z z)) + (x z) + (y (- (mod x z) (mod y z)))) + (:instance integerp-mod-exp (i x) (j z)) + (:instance integerp-mod-exp (i y) (j z)) ) + :in-theory '( + (:rewrite inverse-of-*) + (:rewrite associativity-of-+) + (:rewrite commutativity-of-+)))) + :rule-classes nil) + + +(defthm mod--in + (implies + (and (integerp x) + (integerp y) + (integerp z) + (integerp (/ y z)) + (not (equal z 0))) + (equal (mod (- x y) z) + (mod (- (mod x z) (mod y z)) z))) + :hints (("Goal" :in-theory (enable mod))) + :rule-classes nil) + +(defthm mod-- + (implies + (and (force (integerp x)) + (force (integerp y)) + (force (integerp z)) + (force (not (equal z 0)))) + (equal (mod (- x y) z) + (mod (- (mod x z) (mod y z)) z))) + :hints (("Goal" :use (mod--nin mod--in)))) + +;;; new stuff + +#| + +(defthm mod-of-0-is-0 + (implies + (and + (integerp m) + (not (equal m 0))) + (= (mod 0 m) 0)) + :rule-classes nil) + + +(defthm int-as-int2-+-diff-times-k2 + (implies + (and + (integerp a) + (integerp b1) + (integerp b2) + (integerp m) + (not (equal m 0))) + (= (* a b1) (+ (* a b2) (* a (/ (- b1 b2) m) m)))) + :rule-classes nil) + + +(defthm integerp-k-dividing + (implies + (and + (= (- (mod b1 m) (mod b2 m)) 0) + (integerp b1) + (integerp b2) + (integerp m) + (not (equal m 0))) + (integerp (/ (- b1 b2) m))) + :hints (("Goal" :in-theory nil + :use (mod-of-0-is-0 + (:instance mod-=-0-exp (x (- b1 b2)) (y m)) + (:instance mod-- (x b1) (y b2) (z m))))) + :rule-classes nil) + +(defthm integerp-k-dividing2 + (implies + (and + (= (- (mod b1 m) (mod b2 m)) 0) + (integerp a) + (integerp b1) + (integerp b2) + (integerp m) + (not (equal m 0))) + (integerp (* a (/ (- b1 b2) m)))) + :hints (("Goal" :in-theory nil :use integerp-k-dividing)) + :rule-classes nil) + + +(defthm congruence-holds-on-product + (implies + (and + (= (mod b1 m) (mod b2 m)) + (integerp a) + (integerp b1) + (integerp b2) + (integerp m) + (not (equal m 0))) + (equal (mod (* a b1) m) (mod (* a b2) m))) + :hints (("Goal" + :use + (integerp-k-dividing2 + int-as-int2-+-diff-times-k2 + (:instance mod-x+i*y-y-exp (x (* a b2)) (y m) (i (* a (/ (- b1 b2) m)))))))) + +(thm + (implies + (and + (integerp a) + (integerp b) + (integerp m) + (not (equal m 0))) + (= (mod (mod b m) m) (mod b m))) + :hints (("Goal" + :use + ( (:instance fix (x m)) + (:instance r-mod-mod (x b) (i 1) (z m)))))) + +(defthm congruence-holds-on-product-i + (implies + (and + (integerp a) + (integerp b) + (posp m)) ;;; per rilassare questo in m <> 0 va rilassato rewrite-mod-mod-exp, e quindi r-mod-mod + (equal (mod (* a (mod b m)) m) (mod (* a b) m))) + :hints (("Goal" + :use + ( + (:instance r-mod-mod (x b) (i 1) (z m)) + (:instance congruence-holds-on-product (b1 (mod b m)) (b2 b)))))) + + + +(defun times (a b) + (if (zp b) + 0 + (+ a (times a (1- b))))) + +(defthm times-is-* + (implies + (and + (integerp a) + (natp b)) + (= (times a b) (* a b))) + :rule-classes nil) + +(defun times2 (a b) + (if (< 0 b) + (times a (- b)) + (times a b))) + +(defthm openup-times + (implies + (not (zp y)) + (equal (times x y) (+ (times x (1- y)) x))) + :rule-classes nil) + + + +(thm + (IMPLIES + (AND + (integerp y) + (integerp z) + (posp z)) ;;; see before + (equal (mod (times (mod x z) (mod y z)) z) + (mod (times (mod x z) (mod (+ (mod (1- y) z) (mod 1 z)) z)) z))) + :hints (("Subgoal 2" :in-theory '((:definition posp))) + ("Goal" :use ( + (:theorem (implies (integerp y) (equal y (+ (1- y) 1)))) + (:instance mod-+-exp (x (1- y)) (y 1) (z z)))))) + + + +(defthm h1 + (implies + (and + (integerp x) + (posp z)) + (natp (mod x z))) + :rule-classes nil) + + +(defthm h2 + (IMPLIES + (AND + (integerp x) + (integerp y) + (integerp z) + (posp z)) ;;; see before +(and + (integerp (mod x z)) + (INTEGERP (+ (MOD (+ -1 Y) Z) (MOD 1 Z))) + (natp (mod (+ (mod (1- y) z) (mod 1 z)) z)))) +:hints (("Goal" :in-theory '((:definition posp) (:definition natp) ) + :use ( h1 + (:instance h1 (x (1- y))) + (:instance h1 (x 1)) + (:instance h1 (x (+ (mod (1- y) z) (mod 1 z))))))) +:rule-classes nil) + +(defthm h3 + (IMPLIES + (AND + (integerp x) + (integerp y) + (integerp z) + (posp z)) ;;; see before + (equal + (mod (times (mod x z) (mod (+ (mod (1- y) z) (mod 1 z)) z)) z) + (mod (* (mod x z) (+ (mod (1- y) z) (mod 1 z)) ) z))) + :hints (("Goal" + :in-theory '((:definition natp) (:definition posp)) + :use + ( h2 + (:instance times-is-* (b (mod (+ (mod (1- y) z) (mod 1 z)) z)) (a (mod x z))) + (:instance congruence-holds-on-product-i (b (+ (mod (1- y) z) (mod 1 z))) (a (mod x z)) (m z))))) + :rule-classes nil) + + +(defthm mod-of-1-is-1 + (implies + (and + (integerp z) + (> z 1)) + (equal (mod 1 z) 1)) + :hints (("Goal" :use (:instance mod-x-y-=-x-exp (x 1) (y z)))) + :rule-classes nil) + +(defthm sss1 + (implies + (integerp x) + (equal (* x 1) x)) + :rule-classes nil) + +(defthm h5->1 + (IMPLIES + (AND + (integerp x) + (integerp y) + (integerp z) + (> z 1)) + (equal (mod (times (mod x z) (mod y z)) z) + (mod (+ (* (mod x z) (mod (1- y) z)) (mod x z) ) z))) + :hints (("Subgoal 2" :in-theory '((:definition posp) + (:rewrite distributivity) + (:rewrite commutativity-of-*) + (:rewrite unicity-of-1))) + ("Goal" :use ( mod-of-1-is-1 + h3 + h2 + (:instance sss1 (x (mod x z))) + (:theorem (implies (integerp y) (equal y (+ (1- y) 1)))) + (:instance mod-+-exp (x (1- y)) (y 1) (z z)))))) + + +(defthm h5-=1 + (IMPLIES + (AND + (integerp x) + (integerp y) + (integerp z) + (= z 1)) + (equal (mod (times (mod x z) (mod y z)) z) + (mod (+ (* (mod x z) (mod (1- y) z)) (mod x z) ) z)))) + + +(defthm h5->=1 + (IMPLIES + (AND + (integerp x) + (integerp y) + (posp z)) + (equal (mod (times (mod x z) (mod y z)) z) + (mod (+ (* (mod x z) (mod (1- y) z)) (mod x z) ) z))) + :hints (("Goal" :in-theory '((:definition posp)) :use (h5-=1 h5->1)))) + + +(defthm h6 + (implies + (and + (integerp a) + (integerp b) + (posp m)) + (equal (mod (+ a b) m) + (mod (+ (mod a m) b) m))) + :hints (("Goal" + :in-theory '((:definition fix) + (:rewrite unicity-of-1) + (:definition posp)) + :use + ( (:instance integerp-mod-exp (i a) (j m)) + (:instance mod-+-exp (x (mod a m)) (y b) (z m)) + (:instance mod-+-exp (x a) (y b) (z m)) + (:instance r-mod-mod (x a) (i 1) (z m))))) + :rule-classes nil) + + + +;;; here now. + +(defthm h7 + (IMPLIES + (AND + (NOT (ZP Y)) + (EQUAL (MOD (TIMES X (+ -1 Y)) Z) + (MOD (TIMES (MOD X Z) (MOD (+ -1 Y) Z)) Z)) + (integerp x) + (integerp y) (INTEGERP (* (MOD X Z) (MOD (+ -1 Y) Z))) + (posp z)) + (equal (mod (times (mod x z) (mod y z)) z) + (mod (+ (mod (* (mod x z) (mod (1- y) z)) z) (mod x z) ) z))) + :hints (("Goal" + :in-theory nil + :use + (h5->=1 + h2 + ;h3 + (:instance h6 + (a (* (mod x z) (mod (1- y) z))) + (b (mod x z)) + (m z)))))) + + + +(thm + (IMPLIES + (AND + (NOT (ZP Y)) + (EQUAL (MOD (TIMES X (+ -1 Y)) Z) + (MOD (TIMES (MOD X Z) (MOD (+ -1 Y) Z)) Z)) + (equal (mod (times x y) z) (mod (times (mod x z) (mod y z)) z)))) + +(thm + (implies + (and + (integerp x) + (integerp y) + (integerp z) + (not (equal z 0))) + (equal (mod (times x y) z) (mod (times (mod x z) (mod y z)) z))) + :hints (("Subgoal *1/3" :use + ( openup-times + (:instance mod-+-exp (x (times x (1- y))) (y x) (z z)) + +;;; end new stuff + +|# + +(defun congruent-all-mod-list (l1 l2 m) + (declare (xargs :measure (len m))) + (if (endp m) + t + (and + (congruent-mod (car l1) (car l2) (car m)) + (congruent-all-mod-list (cdr l1) (cdr l2) (cdr m))))) + +(defthm cong-all-mod-implies-cong-all-mod-list + (implies + (and + (congruent-all-mod v1 l1 m) + (congruent-all-mod v1 l2 m)) + (congruent-all-mod-list l1 l2 m))) + + +(defthm rel-prime-is-pos + (implies + (rel-prime-moduli m) + (and + (posp-all m) + (posp (prod m)))) + :hints (("Goal" :in-theory (enable rel-prime-moduli))) + :rule-classes :forward-chaining) + + +(defthm s-sily + (implies + (integerp (/ a b)) + (integerp (/ (- a) b))) + :rule-classes nil) + + +(defthm axp1 + (implies + (and + (integerp v1) + (integerp v2) + (posp (prod m)) + (integerp (/ (- v1 v2) (prod m)))) + (and + (integerp (/ (- v2 v1) (prod m))) + (equal v2 (+ v1 (* (/ (- v2 v1) (prod m)) (prod m)))))) + :hints (("Goal" :use (:instance s-sily (a (- v1 v2)) (b (prod m))))) + :rule-classes nil) + + +(defthm diff-prod-means-cong-all-mod-list + (implies + (and + (rel-prime-moduli m) + (integerp v1) + (integerp v2) + (natp-all l1) + (natp-all l2) + (equal (len l1) (len m)) + (equal (len l2) (len m)) + (congruent-all-mod v1 l1 m) + (congruent-all-mod v2 l2 m) + (integerp (/ (- v1 v2) (prod m)))) + (congruent-all-mod-list l1 l2 m)) + :hints (("Goal" + :in-theory '((:definition posp) + (:rewrite unicity-of-1)) + :use + ( axp1 + rel-prime-is-pos + cong-all-mod-implies-cong-all-mod-list + (:instance mod-x+i*y-y-exp (i (/ (- v2 v1) (prod m))) (x v1) (y (prod m))) + (:instance r-mod-mod (x v1) (i 1) (z (prod m))) + (:instance modulo-prod-has-same-congruence (x v1) (y l2)) + (:instance modulo-prod-has-same-congruence (x v2) (y l2)))))) + + +(defthm same-congruence-over-conglist + (implies + (congruent-all-mod-list l1 l2 m) + (equal + (congruent-all-mod v l1 m) + (congruent-all-mod v l2 m))) + :rule-classes nil) + +(defun cong-sg-val (v1 v2 m) + (if + (endp m) + t + (and + (congruent-mod v1 v2 (car m)) + (cong-sg-val v1 v2 (cdr m))))) + + +(defthm same-cong-lists-means-same-mods + (implies + (and + (equal (len l) (len m)) + (congruent-all-mod v1 l m) + (congruent-all-mod v2 l m)) + (cong-sg-val v1 v2 m))) + +(defthm mod-of-0 + (implies (posp carm) (equal (mod 0 carm) 0)) + :rule-classes nil) + + +(defthm same-cong-vals-implies-diff-has-cong-to-zero + (implies + (and + (posp-all m) + (integerp v1) + (integerp v2)) + (implies + (cong-sg-val v1 v2 m) + (cong-sg-val (- v1 v2) 0 m))) + :hints (("Goal" + :in-theory (disable mod-=-0-exp mod-- mod-+-exp cancel-mod-+-exp rewrite-mod-mod-exp r-mod-mod-cancel integerp-mod-exp) + :induct (len m)) + ("Subgoal *1/1" :use ( + (:instance mod-of-0 (carm (car m))) + (:instance mod-- (x v1) (y v2) (z (car m))))))) + + +(defthm cong-0-is-divided-by-all + (implies + (and + (integerp v) + (posp-all m)) + (equal (cong-sg-val v 0 m) (divided-by-all v m))) + :hints (("Goal" :induct (len m)) + ("Subgoal *1/1" :use ((:instance mod-of-0 (carm (car m))) + (:instance mod-=-0-exp (x v) (y (car m)))) + :in-theory (disable MOD-=-0-EXP))) + :rule-classes nil) + + + + +(in-theory (enable diff-prod-means-cong-all-mod-list-inv-00)) + + + + +(defthm diff-prod-means-cong-all-mod-list-inv + (implies + (and + (rel-prime-moduli m) + (integerp v1) + (integerp v2) + (natp-all l1) + (natp-all l2) + (equal (len l1) (len m)) + (equal (len l2) (len m)) + (congruent-all-mod v1 l1 m) + (congruent-all-mod v2 l2 m) + (congruent-all-mod-list l1 l2 m)) + (integerp (/ (- v1 v2) (prod m)))) + :hints (("Goal" :use ( rel-prime-is-pos + (:instance cong-0-is-divided-by-all (v (- v1 v2))) + (:instance same-congruence-over-conglist (v v2)) + (:instance same-cong-vals-implies-diff-has-cong-to-zero (v1 v1) (v2 v2)) + (:instance diff-prod-means-cong-all-mod-list-inv-00 (v (- v1 v2))))))) + + + +(defthm myax + (implies + (and + (rel-prime-moduli m) + (integerp v1) + (integerp v2) + (natp-all l1) + (natp-all l2) + (equal (len l1) (len m)) + (equal (len l2) (len m)) + (congruent-all-mod v1 l1 m) + (congruent-all-mod v2 l2 m)) + (equal + (congruent-all-mod-list l1 l2 m) + (integerp (/ (- v1 v2) (prod m))))) + :hints (("Goal" :use (diff-prod-means-cong-all-mod-list + diff-prod-means-cong-all-mod-list-inv)))) + + +(defthm sil1 + (implies + (and + (integerp a) + (posp b) + (integerp (/ a b))) + (equal a (* (/ a b) b))) + :rule-classes nil) + +(defthm casesofresdiv + (implies + (and + (posp prod) + (integerp resdiv)) + (and + (implies (equal resdiv 0) (equal (* resdiv prod) 0)) + (implies (< resdiv 0) (< (* resdiv prod) 0)) + (implies (> resdiv 0) (>= (* resdiv prod) prod))))) + + +(defthm a-number-in-arange-is-0-if-no-rest + (implies + (and + (natp v) + (posp prod) + (< v prod) + (integerp (/ v prod))) + (equal v 0)) + :hints (("Goal" :use (:instance sil1 (a v) (b prod))) + ("Goal''" :use (:instance casesofresdiv (resdiv (/ v prod))))) + :rule-classes nil) + + +(defthm equality-in-range-1 + (implies + (and + (posp prod) + (natp v1) + (natp v2) + (< v1 prod) + (< v2 prod) + (integerp (/ (abs (- v1 v2)) prod))) + (equal v1 v2)) + :hints (("Goal" :use (:instance a-number-in-arange-is-0-if-no-rest + (v (abs (- v1 v2)))))) + :rule-classes nil) + + +(defthm sil2 + (iff (integerp (/ (abs a) b)) (integerp (/ a b))) + :rule-classes nil) + +(defthm equality-in-range-2 + (implies + (and + (posp prod) + (natp v1) + (natp v2) + (< v1 prod) + (< v2 prod) + (integerp (/ (- v1 v2) prod))) + (equal v1 v2)) + :hints (("Goal" :use (equality-in-range-1 + (:instance sil2 (a (- v1 v2)) (b prod))))) + :rule-classes nil) + + +(defthm unique-inversion + (implies + (and + (rel-prime-moduli m) + (natp v1) + (natp v2) + (< v1 (prod m)) + (< v2 (prod m)) + (natp-all l) + (equal (len l) (len m)) + (congruent-all-mod v1 l m) + (congruent-all-mod v2 l m)) + (equal v1 v2)) + :hints (("Goal" :use + ( (:instance myax (l1 l) (l2 l)) + (:instance equality-in-range-2 (prod (prod m)))))) + :rule-classes nil) + +(defun build-values-by-rns (gem-value rns) + (if (endp rns) + nil + (cons (mod gem-value (car rns)) + (build-values-by-rns gem-value (cdr rns))))) + + +(defthm values-built-by-rns-are-congruent-indeed + (implies + (and + (integerp val) + (posp-all m)) + (congruent-all-mod val (build-values-by-rns val m) m))) + + +(defthm congruent-all-same-with-mod + (implies + (and + (natp-all l) + (posp-all m) + (natp x)) + (equal + (congruent-all x l m) + (congruent-all-mod x l m))) + :hints (("Goal" :in-theory (enable mod rem))) + :rule-classes nil) + +(defun crtmod (a m) + (mod (crt a m) (prod m))) + + +(defthm sils2 + (implies + (and + (posp (prod m)) + (natp (crt a m))) + (< (crtmod a m) (prod m)))) + +(defthm sils1 + (implies + (and + (posp m) + (natp a)) + (natp (mod a m))) + :hints (("Goal" :in-theory '((:rewrite integerp-mod-exp) + (:definition natp) + (:definition posp)) + :use ( (:instance mod-type-exp (x a) (y m)) + (:instance mod-=-0-exp (x a) (y m)))))) + + + +(defthm chinese-remainder-2 + (implies + (and + (natp-all a) + (rel-prime-moduli m) + (= (len a) (len m))) + (and + (natp (crtmod a m)) + (< (crtmod a m) (prod m)) + (congruent-all-mod (crtmod a m) a m))) + :hints (("Goal" :use + ( (:instance chinese-remainder-theorem (values a) (rns m)) + sils2 + (:instance congruent-all-same-with-mod + (l a) + (x (crt a m))) + (:instance modulo-prod-has-same-congruence + (y a) + (x (crt a m))))))) + + +(defthm lemma-x + (implies + (and + (natp val) + (rel-prime-moduli m)) + (and + (natp-all (build-values-by-rns val m)) + (= (len (build-values-by-rns val m)) (len m)))) + :hints (("Goal" :in-theory (enable rel-prime-moduli)))) + + +(defthm crt-inversion + (implies + (and + (rel-prime-moduli rns) + (natp val) + (< val (prod rns))) + (equal (crtmod (build-values-by-rns val rns) rns) val)) + :hints (("Goal" + :use ( (:instance chinese-remainder-2 (a (build-values-by-rns val rns)) (m rns)) + (:instance lemma-x (m rns)) + (:instance values-built-by-rns-are-congruent-indeed (m rns)) + (:instance unique-inversion + (m rns) + (v1 val) + (v2 (crtmod (build-values-by-rns val rns) rns)) + (l (build-values-by-rns val rns))))))) + + + + + + + +;;;;;;;;;; Corollaries for inversion +;;;;; They are further developed/used in Proof-Of-Plus and Proof-Of-Minus + + +(defthm any-number-which-divides-makes-same-residues + (implies + (and + (integerp x) + (posp k) + (posp-all m) + (divided-by-all k m)) + (equal + (build-values-by-rns (mod x k) m) + (build-values-by-rns x m)))) + +(defthm mod-prod-makes-same-residues + (implies + (and + (integerp x) + (posp-all m)) + (equal + (build-values-by-rns (mod x (prod m)) m) + (build-values-by-rns x m)))) + + diff --git a/books/workshops/1999/embedded/Proof-Of-Contribution/Disjoint-lists.lisp b/books/workshops/1999/embedded/Proof-Of-Contribution/Disjoint-lists.lisp new file mode 100644 index 0000000..0353ca0 --- /dev/null +++ b/books/workshops/1999/embedded/Proof-Of-Contribution/Disjoint-lists.lisp @@ -0,0 +1,504 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Theorems about disjunctness of lists +;;;; +;;;; Load with (ld "Disjoint-lists.lisp") +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(in-package "ACL2") + + +(include-book "Proof-Of-Equiv-From-M-Corr") + +;; +;; Boolean version of member-equal function. +;; +;; The call (member-equal el l) returns the tail of the list +;; l, starting from the el element (if any). Thus, one cannot compare +;; member-equalities upon different lists. E.g., +;; (equal (member-equal el l) (member-equal el (append l l2))) +;; does not hold - also when el belongs to l. +;; This justified our redesign of the member-equal function. +;; + + +(defun in-range (idx l) + (and + (integerp idx) + (>= idx 0) + (< idx (len l)))) + +(defun member-equal-bool (el l) + (declare (xargs :guard (true-listp l))) + (cond ((endp l) nil) + ((equal el (car l)) t) + (t (member-equal-bool el (cdr l))))) + + +;; +;; Predicate for the absence of duplicates within a list. +;; + +(defun no-duplicates-p (l) + (if (endp l) + t + (and (not (member-equal-bool (car l) (cdr l))) + (no-duplicates-p (cdr l))))) + + +(defthm no-dup-1 + (implies + (and + (in-range idx l) + (not (member-equal-bool el l))) + (not (equal el (nth idx l))))) + + +(defthm no-dup-3 + (implies + (and + (in-range idx l) + (in-range idx2 l) + (not (equal idx idx2)) + (no-duplicates-p l)) + (not (equal (nth idx2 l) (nth idx l))))) + + +;; +;; Main properties for the property of absence of duplicates +;; + +;; +;; Name : no-duplicates-of-append-no-duplicates-incomponents +;; Statement : (no-duplicates (l1 * l2)) ---> (no-duplicates-p l1) ^ (no-duplicates-p l1) +;; + + +;; +;; Name : no-duplicates-in-append-imply-different-elements-in-components +;; Statement : (no-duplicates (l1 * l2)) ^ (el1 in l1) ^ (el2 in l2) ---> el1 <> el2 +;; + +;; +;; Name : no-duplicates-in-append-imply-different-elements-in-components-2 +;; Statement : (no-duplicates (l1 * l2)) ^ (el in l1) ---> (el not-in l2) +;; + + + +(defthm no-member-of-append-no-member-of-components + (implies (not (member-equal-bool el (append l1 l2))) + (and + (not (member-equal-bool el l1)) + (not (member-equal-bool el l2))))) + +(defthm no-duplicates-of-append-no-duplicates-incomponents + (implies (no-duplicates-p (append l1 l2)) + (and + (no-duplicates-p l1) + (no-duplicates-p l2)))) + + +(defthm no-duplicates-in-append-imply-different-elements-in-components-2 + (implies (and + (no-duplicates-p (append l1 l2)) + (member-equal-bool el1 l1)) + (not (member-equal-bool el1 l2)))) + + + + +;; +;; Disjunction property between lists. +;; Two list are defined disjunct if their append contains no duplicates. +;; + + +(defun no-intersection-p (l1 l2) + (no-duplicates-p (append l1 l2))) + + +;; +;; Main properties of disjunction properties: +;; + + +;; +;; Name : disjoint-sets-have-no-common-els-2 +;; Statement : (no-intersection-p l1 l2) ^ (el in l2) ---> (el not-in l1) +;; + + + +(defthm disjoint-sets-have-no-common-els-2 + (implies + (and + (no-intersection-p l1 l2) + (member-equal-bool el l2)) + (not (member-equal-bool el l1)))) + + + + + + +;; +;; Generalized append function. +;; It receives a list of lists, and return the append of the lists it contains. +;; +;; The main theorem we intend to prove is that, whenever a generalized append of lists +;; contains no duplicates, each pair of lists is disjunct. +;; +;; The idea of the theorem is the following. +;; Consider the i-th and j-th lists contained into the ll list of lists. We assume i < j. +;; We first that the i-th list is contained within the generalized append of +;; the first i elements of ll, which we call append-first-i-of-ll. +;; But, since i < j, the i-th list is also contained within the generalized append of +;; the first j elements of ll, which we call append-first-j-of-ll. +;; We then prove that the j-th list is contained within the generalized append of +;; the last |ll|-j elements of ll, which we call append-last-ll-j-of-ll. +;; But the generalized append of ll, append-ll, results from appending append-first-j-of-ll and +;; append-last-ll-j-of-ll; thus, since append-ll is free of duplicates, +;; append-first-j-of-ll and append-last-ll-j-of-ll are disjoint - that is, they contain no common elements. +;; This implies that the i-th and j-th lists are disjoint as well. +;; +;; +;; +;; append-first-i-of-ll append-last-ll-j-of-ll +;; | | +;; | append-first-j-of-ll V +;; |----+-----------------------------------|----------------| +;; | | | | +;; | V | | +;; |---------| | | +;; | | | | +;; | | | | +;; /---------------------------------------------------------\ +;; | | | | | | +;; \---------------------------------------------------------/ +;; ^ ^ +;; | | +;; i-th j-th +;; list list +;; + +(defun append-lists (list-of-lists) + (if (endp list-of-lists) + nil + (append (car list-of-lists) + (append-lists (cdr list-of-lists))))) + + + +;; +;; Function extracting the first n elements of a list +;; (taken from public Acl-2 list book) +;; + +(defun firstn (n l) + (declare (xargs :measure (nfix n) + :guard (and (integerp n) (<= 0 n) + (true-listp l)))) + (cond ((endp l) nil) + ((zp n) nil) + (t (cons (car l) (firstn (1- n) (cdr l)))))) + + +;; +;; Main properties of function taking the first n elements of a list +;; + +;; +;; Name : append-lists-firstn-nthcdr, append-lists-firstn-nthcdr-2 +;; Statement : (true-listp l) ---> (append-lists l) = (append-lists (firstn n l)) * (append-lists (nthcdr n l)) +;; + + + +(defthm append-lists-firstn-nthcdr + (implies + (true-listp l) + (equal (append (append-lists (firstn n l)) (append-lists (nthcdr n l))) + (append-lists l)))) + +(defthm append-lists-firstn-nthcdr-2 + (implies + (true-listp l) + (equal (append-lists l) + (append (append-lists (firstn n l)) (append-lists (nthcdr n l)))))) + +(in-theory (disable append-lists-firstn-nthcdr-2)) + + +;; +;; Lemmas to the proof +;; + + +;; +;; Name : member-of-nth-entry-of-ll-is-member-of-append-of-first-n-entries-in-excess +;; Statement : (0 <= idx1 < idx2 < |l|) ^ (el1 in (nth idx1 ll)) ---> (el1 in (append-lists (firstn idx2 ll))) +;; + +;; +;; Name : member-of-nth-entry-of-ll-is-member-of-append-of-nthcdr-n-entries +;; Statement : (0 <= idx1 < |l|) ^ (el1 in (nth idx1 ll)) ---> (el1 in (append-lists (nthcdr idx1 ll))) +;; + +;; +;; Name : no-duplicates-in-append-means-partitioning +;; Statement : (true-listp ll) ^ (0 <= idx2 < |l|) ^ (no-duplicates-p (append-lists ll)) ---> +;; (no-intersection-p (append-lists (firstn idx2 ll)) (append-lists (nthcdr idx2 ll)))) +;; + + + +(defthm member-of-nth-entry-of-ll-is-member-of-append-of-first-n-entries-in-excess + (implies + (and + (in-range idx1 ll) + (in-range idx2 ll) + (< idx1 idx2) + (member-equal-bool el1 (nth idx1 ll))) + (member-equal-bool el1 (append-lists (firstn idx2 ll))))) + +(defthm member-of-nth-entry-of-ll-is-member-of-append-of-nthcdr-n-entries + (implies + (and + (in-range idx1 ll) + (member-equal-bool el1 (nth idx1 ll))) + (member-equal-bool el1 (append-lists (nthcdr idx1 ll))))) + +(in-theory (disable + member-of-nth-entry-of-ll-is-member-of-append-of-nthcdr-n-entries + ;member-of-nth-entry-of-ll-is-member-of-append-of-first-n-entries + append-lists-firstn-nthcdr)) + + +(defthm no-duplicates-in-append-means-partitioning + (implies + (and + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (in-range idx2 ll)) + (no-intersection-p (append-lists (firstn idx2 ll)) + (append-lists (nthcdr idx2 ll)))) + :hints (("Goal" :use (:instance append-lists-firstn-nthcdr-2 (l ll) (n idx2))))) + +(in-theory (disable no-duplicates-in-append-means-partitioning no-intersection-p)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Main theorem (in four equivalent forms) +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + +;; +;; Name : generalized-disjunctivity-of-els-2 +;; Statement : (no-duplicates-p (append-lists ll)) ^ (0 <= idx1 <= idx2 < |ll|) ^ +;; (el1 in (nth idx1 ll)) ---> (el1 not-in (nth idx2 ll)) +;; + +;; +;; Name : different-list-indexes-are-different +;; Statement : (no-duplicates-p (append-lists ll)) ^ (0 <= idx1 < |ll|) ^ (0 <= idx2 < |ll|) ^ +;; (idx1 <> idx2) ^ (el1 in (nth idx1 ll)) ^ (el2 in (nth idx2 ll)) ---> el1 <> el2 +;; + +;; +;; Name : different-list-indexes-are-different-2 +;; Statement : (no-duplicates-p (append-lists ll)) ^ (0 <= idx1 < |ll|) ^ (0 <= idx2 < |ll|) ^ +;; (el1 in (nth idx1 ll)) ---> (el2 not-in (nth idx2 ll)) +;; + + + +(defthm generalized-disjunctivity-of-els-2 + (implies (and + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (in-range idx1 ll) + (in-range idx2 ll) + (< idx1 idx2) + (member-equal-bool el1 (nth idx1 ll))) + (not (member-equal-bool el1 (nth idx2 ll)))) + :hints (("Goal" :use ((:instance no-duplicates-in-append-means-partitioning (ll ll) (idx2 idx2)) + (:instance member-of-nth-entry-of-ll-is-member-of-append-of-nthcdr-n-entries (el1 el1) (idx1 idx2) (ll ll)) + (:instance member-of-nth-entry-of-ll-is-member-of-append-of-first-n-entries-in-excess + (el1 el1) (idx1 idx1) (idx2 idx2) (ll ll)))))) + + + + +(defthm different-list-indexes-are-different + (implies + (and + (in-range idx1 ll) + (in-range idx2 ll)) + (equal + (not (equal idx1 idx2)) + (or + (< idx1 idx2) + (< idx2 idx1)))) + :hints (("Goal" :in-theory (enable in-range)))) + +(in-theory (disable in-range)) + + +(defthm generalized-disjunctivity-unordered-2 + (implies (and + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (in-range idx1 ll) + (in-range idx2 ll) + (not (equal idx1 idx2)) + (member-equal-bool el1 (nth idx1 ll))) + (not (member-equal-bool el1 (nth idx2 ll)))) + :hints (("Goal" :use ((:instance different-list-indexes-are-different + (idx1 idx1) (idx2 idx2) (ll ll)) + (:instance generalized-disjunctivity-of-els-2 + (ll ll) (idx1 idx1) (idx2 idx2) (el1 el1)))))) + + +(defthm in-range-is-member-eq-bool + (implies + (in-range idx l) + (member-equal-bool (nth idx l) l)) + :hints (("Goal" :in-theory (enable in-range member-equal-bool)))) + + + +(defthm l1 + (implies + (and + (true-listp ll) + (in-range idx1 ll)) + (and + (true-listp (nthcdr idx1 ll)) + (equal (car (nthcdr idx1 ll)) (nth idx1 ll) ) + (equal (cdr (nthcdr idx1 ll)) (nthcdr (1+ idx1) ll)))) + :hints (("Goal" :in-theory (enable in-range)))) + +(defthm append-lists-car-cdr + (implies + (true-listp ll) + (equal (append-lists ll) + (append + (car ll) + (append-lists (cdr ll)))))) + +(in-theory (disable append-lists-car-cdr)) + +(defthm append-lists-first-middle-end + (implies + (and + (in-range idx1 ll) + (true-listp ll)) + (equal (append-lists ll) + (append + (append-lists (firstn idx1 ll)) + (append + (nth idx1 ll) + (append-lists (nthcdr (1+ idx1) ll)))))) +:hints (("Goal" :use (l1 + (:instance append-lists-firstn-nthcdr-2 (l ll) (n idx1)) + (:instance append-lists-car-cdr (ll (nthcdr idx1 ll))))))) + + +(defthm no-duplicates-l1-l2-l3-means-no-duplicates-l2 + (implies + (no-duplicates-p (append l1 (append l2 l3))) + (no-duplicates-p l2)) + :hints (("Goal" :use + ((:instance no-duplicates-of-append-no-duplicates-incomponents (l1 l1) (l2 (append l2 l3))) + (:instance no-duplicates-of-append-no-duplicates-incomponents (l1 l2) (l2 l3)))))) + + +(defthm no-duplicates-all-implies-no-duplicates-one + (implies (and + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (in-range idx1 ll)) + (no-duplicates-p (nth idx1 ll)))) + + +(in-theory (disable + no-dup-1 + no-dup-3 + no-member-of-append-no-member-of-components + no-duplicates-of-append-no-duplicates-incomponents + no-duplicates-in-append-imply-different-elements-in-components-2 + disjoint-sets-have-no-common-els-2 + append-lists-firstn-nthcdr + append-lists-firstn-nthcdr-2 + member-of-nth-entry-of-ll-is-member-of-append-of-nthcdr-n-entries + member-of-nth-entry-of-ll-is-member-of-append-of-first-n-entries-in-excess + member-of-nth-entry-of-ll-is-member-of-append-of-nthcdr-n-entries + no-duplicates-in-append-means-partitioning + generalized-disjunctivity-of-els-2 + different-list-indexes-are-different + in-range-is-member-eq-bool + l1 + append-lists-car-cdr + append-lists-first-middle-end + no-duplicates-l1-l2-l3-means-no-duplicates-l2 + no-duplicates-all-implies-no-duplicates-one)) + + +(in-theory (enable in-range)) + +(defthm no-member-holds-on-firstn + (implies + (not (member-equal-bool el l)) + (not (member-equal-bool el (firstn idx l)))) + :rule-classes nil) + +(defthm no-duplicates-means-an-element-not-before-neither-after + (implies + (and + (in-range idx l) + (no-duplicates-p l)) + (and + (not (member-equal-bool (nth idx l) (nthcdr (1+ idx) l))) + (not (member-equal-bool (nth idx l) (firstn idx l))))) + :hints (("Goal" :in-theory (enable no-dup-1)))) + +(defthm firstns-do-not-contain-nth-el + (implies + (and + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (in-range gem1 ll) + (in-range gem2 ll) + (in-range idx (nth gem1 ll)) + (in-range idx (nth gem2 ll))) + (not (member-equal-bool (nth idx (nth gem2 ll)) (firstn idx (nth gem1 ll))))) + :hints (("Goal" + :in-theory (enable in-range-is-member-eq-bool + no-duplicates-means-an-element-not-before-neither-after + no-duplicates-all-implies-no-duplicates-one) + :cases ( (equal gem1 gem2))) + ("Subgoal 2" + :use ((:instance no-member-holds-on-firstn + (el (nth idx (nth gem2 ll))) (l (nth gem1 ll))) + (:instance generalized-disjunctivity-unordered-2 + (idx1 gem1) (idx2 gem2) (el1 (nth idx (nth gem2 ll)))))))) + + + +(defthm no-duplicates-means-an-element-does-not-appear-after-its-position + (implies + (and + (no-duplicates-p l) + (in-range idx l)) + (not (member-equal-bool (nth idx l) (cdr (nthcdr idx l))))) + :rule-classes nil) + + + + diff --git a/books/workshops/1999/embedded/Proof-Of-Contribution/Generic.lisp b/books/workshops/1999/embedded/Proof-Of-Contribution/Generic.lisp new file mode 100644 index 0000000..8aa3aa6 --- /dev/null +++ b/books/workshops/1999/embedded/Proof-Of-Contribution/Generic.lisp @@ -0,0 +1,100 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Section 1: preliminary definitions and lemmas +;; (some are taken from Boyer and Moore's ``small machine'' +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(in-package "ACL2") + +(defthm constant-fold-+ + (implies (acl2::syntaxp (and (quotep x) (quotep y))) + (equal (+ x (+ y z)) (+ (+ x y) z)))) + +(defthm commutativity2-of-+ + (equal (+ x y z) (+ y x z)) + :hints (("goal" :use ((:instance acl2::associativity-of-+ + (acl2::x y) + (acl2::y x) + (acl2::z z)) + (:instance acl2::associativity-of-+ + (acl2::x x) + (acl2::y y) + (acl2::z z)) + (:instance acl2::commutativity-of-+ + (acl2::x x) + (acl2::y y))) + :in-theory (disable acl2::associativity-of-+ + acl2::commutativity-of-+)))) + +(defthm commutativity2-of-* + (equal (* x y z) (* y x z)) + :hints (("goal" :use ((:instance acl2::associativity-of-* + (acl2::x y) + (acl2::y x) + (acl2::z z)) + (:instance acl2::associativity-of-* + (acl2::x x) + (acl2::y y) + (acl2::z z)) + (:instance acl2::commutativity-of-* + (acl2::x x) + (acl2::y y))) + :in-theory (disable acl2::associativity-of-* + acl2::commutativity-of-*)))) +#| +(defthm plus-right-id + (equal (+ x 0) (acl2::fix x))) +|# + +(defthm *-0 (equal (* 0 x) 0)) + +#| +(defthm +-cancellation1 + (equal (+ i j (* -1 i) k) + (+ j k))) +|# + + +;; +;; in-range (idx l) predicate: true iff 0 <= idx < |l| +;; natp(n) predicate: true iff n is natural number +;; firstn (n l) head of n elements of l +;; equal-elements (el l) predicate: true iff l = < el el el ... el > +;; + +#| +(defun in-range (idx l) + (and + (integerp idx) + (>= idx 0) + (< idx (len l)))) +|# + + + + + +(defun equal-elements (el l) + (if (endp l) + (null l) + (and + (equal el (car l)) + (equal-elements el (cdr l))))) +#| +(defthm equal-elements-means-every-elements-matches + (implies + (and + (in-range idx l) + (equal-elements el l)) + (equal (nth idx l) el))) +|# + +;;; +;;; Definition of a constant residue number system for the Gem2Rtm translation. +;;; + +(defconst *rns* '(11 13 15 17 19)) + + + diff --git a/books/workshops/1999/embedded/Proof-Of-Contribution/Mapping.lisp b/books/workshops/1999/embedded/Proof-Of-Contribution/Mapping.lisp new file mode 100644 index 0000000..db4681e --- /dev/null +++ b/books/workshops/1999/embedded/Proof-Of-Contribution/Mapping.lisp @@ -0,0 +1,107 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Section 3: Recognizer for Gem-to-Rtm variable mapping +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; According to the fact that the verifier operates over a black-box Gem2Rtm compiler, +;;; we do not provide a constructive definition of a variable mapping between two programs. +;;; +;;; Rather, we recognize an object to be a mapping if it obeys a set of properties. +;;; +;;; The properties are the following: +;;; +;;; - A mapping must be an associative list, where the key to each entry is a Gem variable address, +;;; and the content is either an Rtm variable address, or a tuple of Rtm variable addresses. We say +;;; that the entries of such associative list have the following `type': +;;; - 'Bool if the number of Rtm addresses is 1 +;;; - 'Int if the number of Rtm addresses is |rns| +;;; +;;; - A mapping must feature a correct arity for each entry w.r.t. the Gem and Rtm memories if maps: +;;; - it must map one Gem boolean to one Rtm variable, and +;;; - it must map one Gem integer to |rns| Rtm variables +;;; +;;; - A mapping must not contain duplicate Gem variables +;;; +;;; A similar property to the last one must hold for the Rtm variables featured by a mapping. I.e., +;;; no Rtm duplicates are allowed. We shall insert such property later on, when +;;; they will be necessary (e.g. when proving properties about translations of +;;; Gem instructions). +;;; + + + + +;;; +;;; Subsection 3.1 : +;;; +;;; Accessors on the elements of a mapping: +;;; +;;; (gemvar-0 m) retrieves the gem variable of the first entry of the mapping +;;; (rtmboolvar-0 m) retrieves the rtm variable of the first entry of the mapping +;;; (supposed to be related to a boolean gem variable) +;;; (rtmintvars-0 m) retrieves the rtm variables of the first entry of the mapping +;;; (supposed to be related to an integer gem variable) +;;; (gemvar-i m) retrieves the gem variable of the i-th entry of the mapping +;;; (rtmboolvar-i m) retrieves the rtm variable of the i-th entry of the mapping +;;; (supposed to be related to a boolean gem variable) +;;; (rtmintvars-i m) retrieves the rtm variables of the i-th entry of the mapping +;;; (supposed to be related to an integer gem variable) +;;; +;;; + +(in-package "ACL2") + + +;; PGNEW + +(include-book "Generic") + +(include-book "Memory-Assoc") + +(defun gemvar-0 (m) + (car (car m))) + + +(defun rtmintvars-0 (m) + (cdr (car m))) + +;;; +;;; Recognizers for entries of a mapping: +;;; + +(defun type-0 (m) + (cond + ( (and + (true-listp (rtmintvars-0 m)) + (equal (len (rtmintvars-0 m)) 1)) + 'bool) + ( (and + (true-listp (rtmintvars-0 m)) + (equal (len (rtmintvars-0 m)) (len *rns*))) + 'int) + ( t + 'wrong-typing))) + + +(defun correct-type (type) + (or + (equal type 'int) + (equal type 'bool))) + + + + + + + + + + + + + + + + + diff --git a/books/workshops/1999/embedded/Proof-Of-Contribution/Memory-Assoc.lisp b/books/workshops/1999/embedded/Proof-Of-Contribution/Memory-Assoc.lisp new file mode 100644 index 0000000..5c4af06 --- /dev/null +++ b/books/workshops/1999/embedded/Proof-Of-Contribution/Memory-Assoc.lisp @@ -0,0 +1,455 @@ + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Section 2: Memory definitions +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; +;;; Although actual Gem and Rtm memories are not typed, they contain values of typed +;;; variables (for Gem, booleans and 'long' integers; for Rtm, only 'short' integers). +;;; In order to simplify our proofs (by not to have to refer to variable declaration +;;; lists to recognize the types of variables into memories), we define memories as being +;;; typed. +;;; +;;; First we define the notion of (Gem or Rtm) typed memory cell, by providing a +;;; recognizer, a constructor and a set of accessors to the typed cell's elements. +;;; +;;; Then we define a (Gem or Rtm) typed memory as a list of typed cells: +;;; we provide an accessor, a constructor and a recognizer. +;;; +;;; Finally we define accessors that 'slice' memories, extracting only +;;; the types, the values or the attributes of the cells. +;;; + + +;;; +;;; Typed memory cell +;;; +;;; A typed memory cell is a three-elements list of the form < value attribute type >, +;;; where : +;;; - value is an integer +;;; - attribute is one of 'input, 'output +;;; - type is one of 'int, 'bool +;;; + + +(in-package "ACL2") + +(defun make-cell (value attribute type-var) + (list value attribute type-var)) + +(defun var-value (memcell) + (car memcell)) + +(defun var-attribute (memcell) + (cadr memcell)) + +(defun var-type (memcell) + (caddr memcell)) + + +(defthm var-attribute-retrieves-attribute + (equal (var-attribute (make-cell value attribute type)) attribute)) + + +(defun my-or-3 (a b c) (or a b c)) + +(defun my-or-2 (a b) (or a b)) + + +(defun is-mem-cell-p (memcell) + (and + (true-listp memcell) + (equal (len memcell) 3) + (integerp (var-value memcell)) + (my-or-3 + (equal (var-attribute memcell) 'input) + (equal (var-attribute memcell) 'output) + (equal (var-attribute memcell) 'internal)) + (my-or-2 + (equal (var-type memcell) 'int) + (and + (my-or-2 + (equal (var-value memcell) 0) + (equal (var-value memcell) 1)) + (equal (var-type memcell) 'bool))))) + + +(defthm non-boolean-cell-is-integer + (implies + (and + (is-mem-cell-p cell) + (not (equal (var-type cell) 'bool))) + (equal (var-type cell) 'int))) + +(defthm non-integer-cell-is-boolean + (implies + (and + (is-mem-cell-p cell) + (not (equal (var-type cell) 'int))) + (equal (var-type cell) 'bool))) + + + + +;;; +;;; Memory accessor, constructor, recognizer +;;; +;;; - (get-cell pos mem) : retrieves pos-th element of the mem memory list +;;; - (put-cell pos cell mem) : puts the cell at position pos in the mem memory list +;;; (nil elements are inserted if necessary) +;;; + + +(defun put-cell (position cell typed-mem) + (cons (cons position cell) typed-mem)) + + +#| +(defun put-cell (position cell typed-mem) + (cond + ( (endp typed-mem) + (cons (cons position cell) typed-mem) ) + ( (equal (caar typed-mem) position) + (cons (cons position cell) (cdr typed-mem) ) ) + ( t + (cons (car typed-mem) (put-cell position cell (cdr typed-mem)))))) +|# + + +(defun get-cell (pos mem) (cdr (assoc-equal pos mem))) + + + +(defthm get-retrieves-put-value + (equal (get-cell position (put-cell position cell typed-mem)) cell)) + + +(defthm put-cell-does-not-change-other-vars + (implies + (not (equal var1 var2)) + (equal (get-cell var1 (put-cell var2 val mem)) (get-cell var1 mem)))) + + + + +(defthm put-keeps-alistp + (implies + (alistp mem) + (alistp (put-cell position cell mem)))) + + + + + + +;;; +;;; +;;; Memory slicing accessors: var-attributes, var-values and var-types +;;; They retrieve only the corresponding components of a list of memory cells. +;;; + + +(in-theory (disable var-attribute var-type var-value)) + +(defun var-attributes (vars mem) + (if (endp vars) + nil + (cons + (var-attribute (get-cell (car vars) mem)) + (var-attributes (cdr vars) mem)))) + + +(defun var-values (vars typed-mem) + (if + (endp vars) + nil + (cons (var-value (get-cell (car vars) typed-mem)) + (var-values (cdr vars) typed-mem)))) + + + +(defthm var-values-of-1-variable-is-one-element-list-of-var-value + (implies + (and + (true-listp vars) + (equal (len vars) 1)) + (equal + (var-values vars mem) + (list (var-value (get-cell (car vars) mem))))) + :hints ( + ("Subgoal *1/2.2" :use (:theorem + (implies + (and + (true-listp vars) + (equal (len vars) 1)) + (and + (equal (len (cdr vars)) 0) + (true-listp (cdr vars)))))))) + + + + + +(defun equal-wrt-vars (vars mem1 mem2) + (cond + ( (endp vars) + t ) + ( (equal + (get-cell (caar vars) mem1) + (get-cell (caar vars) mem2)) + (equal-wrt-vars (cdr vars) mem1 mem2)) + ( t + nil))) + + + + +(defthm equality-wrt-vars-means-every-var-has-same-value + (implies + (and + (assoc-equal v vars) + (equal-wrt-vars vars mem1 mem2)) + (equal + (get-cell v mem1) + (get-cell v mem2)))) + + +(defun equal-memories (mem1 mem2) + (and + (equal-wrt-vars mem1 mem1 mem2) + (equal-wrt-vars mem2 mem1 mem2))) + + + +(defthm a-variable-of-either-memory-is-equal-if-memories-are-equal + (implies + (and + (or + (assoc-equal v mem1) + (assoc-equal v mem2)) + (equal-memories mem1 mem2)) + (equal + (get-cell v mem1) + (get-cell v mem2))) + :hints (("Goal" :use + ((:instance equality-wrt-vars-means-every-var-has-same-value (vars mem1)) + (:instance equality-wrt-vars-means-every-var-has-same-value (vars mem2)))))) + + +(defthm a-variable-of-neither-memory-is-equal-if-memories-are-equal + (implies + (and + (not (assoc-equal v mem1)) + (not (assoc-equal v mem2)) + (equal-memories mem1 mem2)) + (equal + (get-cell v mem1) + (get-cell v mem2)))) + + +(defthm equal-memories-means-all-possible-variables-match-no-matter-what + (implies + (equal-memories mem1 mem2) + (equal + (get-cell v mem1) + (get-cell v mem2))) + :hints (("Goal" :use (a-variable-of-neither-memory-is-equal-if-memories-are-equal + a-variable-of-either-memory-is-equal-if-memories-are-equal)))) + + + + + +(defthm equal-wrt-vars-reflexive + (equal-wrt-vars vars mem mem)) + +(defthm equal-wrt-vars-commutative + (iff + (equal-wrt-vars vars mem1 mem2) + (equal-wrt-vars vars mem2 mem1))) + +(defthm equal-wrt-vars-transitive + (implies + (and + (equal-wrt-vars vars mem1 mem2) + (equal-wrt-vars vars mem2 mem3)) + (equal-wrt-vars vars mem1 mem3))) + + + + +(defthm equal-memories-reflexive + (equal-memories mem mem)) + + +(defthm equal-memories-commutative + (iff + (equal-memories mem1 mem2) + (equal-memories mem2 mem1))) + + + + +(defthm equal-memories-extends-to-all-vars + (implies + (equal-memories mem1 mem2) + (equal-wrt-vars mem3 mem1 mem2)) +:hints (("Subgoal *1/3" :use (:instance equal-memories-means-all-possible-variables-match-no-matter-what + (v (caar mem3)))))) + + + + + + + +(defthm equal-memories-transitive + (implies + (and + (equal-memories mem1 mem2) + (equal-memories mem2 mem3)) + (equal-memories mem1 mem3)) + :hints (("Goal" :use + ((:instance equal-memories (mem1 mem1) (mem2 mem2)) + (:instance equal-memories-extends-to-all-vars) + (:instance equal-wrt-vars-transitive (vars mem3)))))) + + + + + + +(defun retrieve-vars (vars mem) + (if (endp vars) + nil + (put-cell (caar vars) (get-cell (caar vars) mem) (retrieve-vars (cdr vars) mem)))) + +(defthm retrieving-vars-has-equality + (equal-wrt-vars vars (retrieve-vars vars mem) mem)) + +(defun same-caars-p (l1 l2) + (if (or + (endp l1) + (endp l2)) + (and + (endp l1) + (endp l2)) + (and + (equal (caar l1) (caar l2)) + (same-caars-p (cdr l1) (cdr l2))))) + +(defthm same-caars-commutative + (iff (same-caars-p l1 l2) (same-caars-p l2 l1))) + + +(defthm if-same-caars-same-equality-wrt-vars + (implies + (same-caars-p vars1 vars2) + (iff + (equal-wrt-vars vars1 mem1 mem2) + (equal-wrt-vars vars2 mem1 mem2)))) + +(defthm retrieve-gets-same-vars + (same-caars-p (retrieve-vars vars mem) vars)) + + +(defthm equal-wrt-vars-of-retrieve-vars + (equal-wrt-vars (retrieve-vars vars mem) (retrieve-vars vars mem) mem) + :hints (("Goal" + :use ((:instance if-same-caars-same-equality-wrt-vars + (vars1 (retrieve-vars vars mem)) + (vars2 vars) + (mem1 (retrieve-vars vars mem)) + (mem2 mem)))))) + + + + + +(defun vars-inclusion (vars1 vars2) + (if (endp vars1) + t + (and + (assoc-equal (caar vars1) vars2) + (vars-inclusion (cdr vars1) vars2)))) + + +(defthm goal1-40 + (implies + (and + (not (endp vars2)) + (equal-wrt-vars vars1 mem1 mem2) + (vars-inclusion vars2 vars1)) + (equal (get-cell (caar vars2) mem1) + (get-cell (caar vars2) mem2)))) + +(defthm vars-inclusion-keeps-equality + (implies + (and + (equal-wrt-vars vars1 mem1 mem2) + (vars-inclusion vars2 vars1)) + (equal-wrt-vars vars2 mem1 mem2)) + :hints (("Subgoal *1/4" :use goal1-40))) + + + + + +(defthm vars-inclusio + (implies + (vars-inclusion mem vars) + (equal-wrt-vars mem (retrieve-vars vars mem) mem)) +:hints (("Goal" :use + (:instance vars-inclusion-keeps-equality + (vars1 vars) + (vars2 mem) + (mem1 (retrieve-vars vars mem)) + (mem2 mem))))) + + +(defthm retrieving-keeps-equality + (implies + (and + (vars-inclusion mem vars) + (vars-inclusion vars mem)) + (equal-memories (retrieve-vars vars mem) mem)) +:hints (("Subgoal 2" :use + (vars-inclusio + (:instance equal-wrt-vars-commutative + (vars mem) + (mem1 mem) + (mem2 (retrieve-vars vars mem))))) + ("Subgoal 1" :use + (equal-wrt-vars-of-retrieve-vars + (:instance equal-wrt-vars-commutative + (vars (retrieve-vars vars mem)) + (mem1 mem) + (mem2 (retrieve-vars vars mem))))))) + + + +(in-theory (disable + get-cell + equal-memories-extends-to-all-vars + goal1-40 + vars-inclusio)) + +;;; cleanup things + +(in-theory (disable + equality-wrt-vars-means-every-var-has-same-value + a-variable-of-either-memory-is-equal-if-memories-are-equal + a-variable-of-neither-memory-is-equal-if-memories-are-equal + equal-memories-means-all-possible-variables-match-no-matter-what + equal-wrt-vars-commutative + equal-wrt-vars-transitive + equal-memories-transitive + equal-memories-reflexive + equal-memories-commutative + equal-memories-extends-to-all-vars + retrieving-keeps-equality)) + + diff --git a/books/workshops/1999/embedded/Proof-Of-Contribution/Minimal-Mod-Lemmas.lisp b/books/workshops/1999/embedded/Proof-Of-Contribution/Minimal-Mod-Lemmas.lisp new file mode 100644 index 0000000..2cd94a5 --- /dev/null +++ b/books/workshops/1999/embedded/Proof-Of-Contribution/Minimal-Mod-Lemmas.lisp @@ -0,0 +1,143 @@ +(in-package "ACL2") + + +(local (include-book "private-qr-lemmas")) + + +(defthm rewrite-mod-mod-exp + (implies + (and (equal i (/ y z)) + (integerp i) + (integerp x) + (integerp y) + (integerp z) + (> y 0) + (> z 0)) + (equal (mod (mod x y) z) + (mod x z))) + :hints (("Goal" + :in-theory nil + :use rewrite-mod-mod))) + +(defthm mod-=-0-exp + (implies + (and + (integerp x) + (integerp y) + (not (equal y 0))) + (equal (equal (mod x y) 0) + (integerp (/ x y)))) + :hints (("Goal" + :in-theory nil + :use mod-=-0))) + + +(defthm mod-type-exp + (implies + (and + (integerp x) + (integerp y) + (not (equal y 0))) + (and + (equal (< (mod x y) 0) + (and (< y 0) + (not (integerp (/ x y))))) + (equal (> (mod x y) 0) + (and (> y 0) + (not (integerp (/ x y))))))) + :hints (("Goal" + :in-theory nil + :use mod-type))) + + +(defthm integerp-mod-exp + (implies + (and (integerp i) + (integerp j)) + (integerp (mod i j))) + :hints (("Goal" + :in-theory nil + :use integerp-mod))) + + +(defthm mod-bounds-exp + (and + (implies + (and (> y 0) + (integerp x) + (integerp y) + (not (equal y 0))) + (< (mod x y) y)) + (implies + (and (< y 0) + (integerp x) + (integerp y) + (not (equal y 0))) + (> (mod x y) y))) + :hints (("Goal" + :in-theory nil + :use mod-bounds))) + +(defthm mod-+-exp + (implies + (and (integerp x) + (integerp y) + (integerp z) + (not (equal z 0))) + (equal (mod (+ x y) z) + (mod (+ (mod x z) (mod y z)) z))) + :hints (("Goal" + :in-theory nil + :use mod-+))) + + + + + +(defthm cancel-mod-+-exp + (implies + (and (equal i (/ x z)) + (integerp i) + (integerp x) + (integerp y) + (integerp z) + (not (equal z 0))) + (and + (equal (mod (+ x y) z) + (mod y z)) + (equal (mod (+ y x) z) + (mod y z)))) + :hints (("Goal" + :in-theory nil + :use cancel-mod-+))) + +(defthm mod-x+i*y-y-exp + (implies + (and + (integerp i) + (integerp x) + (integerp y) + (not (equal y 0))) + (equal (mod (+ x (* i y)) y) + (mod x y))) + :hints (("Goal" + :in-theory nil + :use mod-x+i*y-y))) + +(defthm mod-x-y-=-x-exp + (implies + (and + (integerp x) + (integerp y) + (not (equal y 0))) + (equal (equal (mod x y) x) + (or (and (>= x 0) (> y 0) (< x y)) + (and (<= x 0) (< y 0) (> x y))))) + :hints (("Goal" + :in-theory nil + :use mod-x-y-=-x))) + + + + + diff --git a/books/workshops/1999/embedded/Proof-Of-Contribution/Proof-Of-Correctness-OneCycle.lisp b/books/workshops/1999/embedded/Proof-Of-Contribution/Proof-Of-Correctness-OneCycle.lisp new file mode 100644 index 0000000..75da482 --- /dev/null +++ b/books/workshops/1999/embedded/Proof-Of-Contribution/Proof-Of-Correctness-OneCycle.lisp @@ -0,0 +1,7828 @@ + +(in-package "ACL2") + +(include-book "Disjoint-lists") + +; The following is commented out starting with v2-7 because a more general +; macro e/d is now part of ACL2. +; (defmacro e/d (enable disable) +; `(union-theories ',enable (disable ,@disable))) + +(defun in-range (idx l) + (and + (integerp idx) + (>= idx 0) + (< idx (len l)))) + +(in-theory (enable in-range)) +(in-theory (disable mod floor)) + +(defun mlambda-fn (args form) + (declare (xargs :guard (symbol-listp args))) + (cond ((atom form) + (cond ((member form args) form) + (t (list 'QUOTE form)))) + (t (list 'CONS (mlambda-fn args (car form)) + (mlambda-fn args (cdr form)))))) + +(defmacro mlambda (args form) + (declare (xargs :guard (symbol-listp args))) + (mlambda-fn args form)) + + +(defmacro qr-guard (x y) + (mlambda (x y) + (and (force (rationalp x)) + (force (rationalp y)) + (force (not (equal 0 y)))))) + +(defun type-expected (vars) + (cond + ( (and (true-listp vars) + (equal (len vars) 1)) + 'Bool) + ( (and (true-listp vars) + (equal (len vars) (len *rns*))) + 'Int) + ( t + 'Wrong-Typing))) + + +(defthm IN-RANGE-I-ON-M-IMPLIES-IN-RANGE-I-1-ON-CDR-M + (IMPLIES (AND (IN-RANGE IDX M) + (NOT (ENDP M)) + (NOT (ZP IDX))) + (IN-RANGE (1- IDX) (CDR M)))) + +(defun positivep (v) + (and + (integerp v) + (> v 0))) + + +(defun positive-list (l) + (if (endp l) + (null l) + (and (positivep (car l)) + (positive-list (cdr l))))) + + +(defun boolean-to-int (bool) + (if bool 1 0)) + +(defun int-to-bool (int) + (equal int 1)) + +(defun make-n-list (el n) + (if + (zp n) + nil + (cons el (make-n-list el (1- n))))) + +(defun eventually-make-list (l n) + (if (equal (len l) 1) + (make-n-list (car l) n) + l)) + +(defun double-induct (idx n) + (if (zp idx) (+ idx n) + (double-induct (1- idx) (1- n)))) + +(defthm el-of-makelist-is-el + (implies + (and + (integerp n) + (in-range idx (make-n-list el n))) + (equal + (nth idx (make-n-list el n)) + el)) + :hints (("Goal" :induct (double-induct idx n)) + ("Subgoal *1/1" :use make-n-list))) + + + + + + +(in-theory (disable my-or-3 my-or-2)) + + + + + +(defun opcode (ins) (nth 0 ins)) +(defun par1 (ins) (nth 1 ins)) +(defun par2 (ins) (nth 2 ins)) +(defun par3 (ins) (nth 3 ins)) +(defun par4 (ins) (nth 4 ins)) + + +(defun mem (s) (car s)) +(defun pcc (s) (cadr s)) +(defun code (s) (cddr s)) + +(defun make-state (mem pcc code) + (cons mem (cons pcc code))) + + +(defun initial-state (prog) + (make-state (car prog) 0 (cdr prog))) + + + + + + +(defun gem-instruction-p (instr mem) + (and + (true-listp instr) + (or + (and + (equal (opcode instr) 'gem-add) + (equal (len instr) 4) + (is-mem-cell-p (get-cell (par1 instr) mem)) + (is-mem-cell-p (get-cell (par2 instr) mem)) + (is-mem-cell-p (get-cell (par3 instr) mem)) + (equal (var-type (get-cell (par1 instr) mem)) 'Int) ) + (and + (equal (opcode instr) 'gem-sub) + (equal (len instr) 4) + (is-mem-cell-p (get-cell (par1 instr) mem)) + (is-mem-cell-p (get-cell (par2 instr) mem)) + (is-mem-cell-p (get-cell (par3 instr) mem)) + (equal (var-type (get-cell (par1 instr) mem)) 'Int) + (equal (var-type (get-cell (par2 instr) mem)) 'Int) + (equal (var-type (get-cell (par3 instr) mem)) 'Int) ) + (and + (equal (opcode instr) 'gem-equ) + (equal (len instr) 4) + (is-mem-cell-p (get-cell (par1 instr) mem)) + (is-mem-cell-p (get-cell (par2 instr) mem)) + (is-mem-cell-p (get-cell (par3 instr) mem)) + (equal (var-type (get-cell (par1 instr) mem)) 'Bool) ) + ))) + + +(defun gem-instruction-list-p (instlist mem) + (if + (endp instlist) + (null instlist) + (and + (gem-instruction-p (car instlist) mem) + (gem-instruction-list-p (cdr instlist) mem)))) + + +(defun gem-program-p (prog) + (and + (true-listp prog) + (equal (len prog) 2) + (is-typed-amem-p (car prog)) + (bounded-amem-p (car prog)) + (gem-instruction-list-p (cdr prog) (car prog)))) + + +(defun gem-statep (x) + (and (consp x) + (consp (cdr x)) + (integerp (pcc x)) + (is-typed-amem-p (mem x)) + (bounded-amem-p (mem x)) ;;; new + (gem-instruction-list-p (code x) (mem x)))) + + +(defthm nth-instruction-of-gem-list-is-gem-instruction + (implies + (gem-instruction-list-p gl mem) + (or + (null (nth idx gl)) + (gem-instruction-p (nth idx gl) mem))) + :hints (("Goal" :in-theory (disable gem-instruction-p))) + :rule-classes nil) + +(defthm an-instruction-of-gem-program-is-null-or-gem-instruction + (implies + (gem-statep st) + (or + (null (nth (pcc st) (code st))) + (gem-instruction-p (nth (pcc st) (code st)) (mem st)))) + :hints (("Goal" :in-theory (disable code mem pcc gem-instruction-list-p gem-instruction-p) + :use (:instance nth-instruction-of-gem-list-is-gem-instruction + (gl (code st)) + (idx (pcc st)) + (mem (mem st))))) + :rule-classes nil) + + + + + + + + + + + +(defun rtm-instruction-p (instr mem) + (and + (true-listp instr) + (or + (and + (equal (opcode instr) 'rtm-add) + (equal (len instr) 4) + (is-mem-cell-p (get-cell (par1 instr) mem)) + (is-mem-cell-p (get-cell (par2 instr) mem)) + (is-mem-cell-p (get-cell (par3 instr) mem)) + (equal (var-type (get-cell (par1 instr) mem)) 'Int) + (equal (var-type (get-cell (par2 instr) mem)) 'Int) + (equal (var-type (get-cell (par3 instr) mem)) 'Int) + (positivep (par4 instr))) + (and + (equal (opcode instr) 'rtm-sub) + (equal (len instr) 4) + (is-mem-cell-p (get-cell (par1 instr) mem)) + (is-mem-cell-p (get-cell (par2 instr) mem)) + (is-mem-cell-p (get-cell (par3 instr) mem)) + (equal (var-type (get-cell (par1 instr) mem)) 'Int) + (equal (var-type (get-cell (par2 instr) mem)) 'Int) + (equal (var-type (get-cell (par3 instr) mem)) 'Int) + (positivep (par4 instr))) + (and + (equal (opcode instr) 'rtm-equ) + (equal (len instr) 4) + (is-mem-cell-p (get-cell (par1 instr) mem)) + (is-mem-cell-p (get-cell (par2 instr) mem)) + (is-mem-cell-p (get-cell (par3 instr) mem)) + (equal (var-type (get-cell (par1 instr) mem)) 'Int) + (equal (var-type (get-cell (par2 instr) mem)) 'Int) + (equal (var-type (get-cell (par3 instr) mem)) 'Int)) + (and + (equal (opcode instr) 'rtm-or) + (equal (len instr) 4) + (is-mem-cell-p (get-cell (par1 instr) mem)) + (is-mem-cell-p (get-cell (par2 instr) mem)) + (is-mem-cell-p (get-cell (par3 instr) mem)) + (equal (var-type (get-cell (par1 instr) mem)) 'Int) + (equal (var-type (get-cell (par2 instr) mem)) 'Int) + (equal (var-type (get-cell (par3 instr) mem)) 'Int)) + (and + (equal (opcode instr) 'rtm-and) + (equal (len instr) 4) + (is-mem-cell-p (get-cell (par1 instr) mem)) + (is-mem-cell-p (get-cell (par2 instr) mem)) + (is-mem-cell-p (get-cell (par3 instr) mem)) + (equal (var-type (get-cell (par1 instr) mem)) 'Int) + (equal (var-type (get-cell (par2 instr) mem)) 'Int) + (equal (var-type (get-cell (par3 instr) mem)) 'Int))))) + +(defun rtm-instruction-list-p (instlist mem) + (if + (endp instlist) + (null instlist) + (and + (rtm-instruction-p (car instlist) mem) + (rtm-instruction-list-p (cdr instlist) mem)))) + + +(defun rtm-program-p (prog) + (and + (true-listp prog) + (equal (len prog) 2) + (is-typed-amem-p (car prog)) + (rtm-instruction-list-p (cdr prog) (car prog)))) + + + + +(defun rtm-statep (x) + (and (consp x) + (consp (cdr x)) + (integerp (pcc x)) + (is-typed-amem-p (mem x)) + (rtm-instruction-list-p (code x) (mem x)))) + + + + + + + +(defthm nth-instruction-of-rtm-list-is-rtm-instruction + (implies + (rtm-instruction-list-p gl mem) + (or + (null (nth idx gl)) + (rtm-instruction-p (nth idx gl) mem))) + :hints (("Goal" :in-theory (disable rtm-instruction-p))) + :rule-classes nil) + +(defthm an-instruction-of-rtm-program-is-null-or-rtm-instruction + (implies + (rtm-statep st) + (or + (null (nth (pcc st) (code st))) + (rtm-instruction-p (nth (pcc st) (code st)) (mem st)))) + :hints (("Goal" :in-theory (disable code mem pcc rtm-instruction-list-p rtm-instruction-p) + :use (:instance nth-instruction-of-rtm-list-is-rtm-instruction + (gl (code st)) + (idx (pcc st)) + (mem (mem st))))) + :rule-classes nil) + + + + + + +(defun sum-and-update (c1 c2 c3 prime mem) + (make-cell + (mod + (+ + (var-value (get-cell c2 mem)) + (var-value (get-cell c3 mem))) + prime) + (var-attribute (get-cell c1 mem)) + (var-type (get-cell c1 mem)))) + + +(DEFUN SUM-AND-UPDATE-NOREST (C1 C2 C3 MEM) + (MAKE-CELL (mod + (+ (VAR-VALUE (GET-CELL C2 MEM)) + (VAR-VALUE (GET-CELL C3 MEM))) + (prod *rns*)) + (VAR-ATTRIBUTE (GET-CELL C1 MEM)) + (VAR-TYPE (GET-CELL C1 MEM)))) + +(defun sub-and-update (c1 c2 c3 prime mem) + (make-cell + (mod + (- + (var-value (get-cell c2 mem)) + (var-value (get-cell c3 mem))) + prime) + (var-attribute (get-cell c1 mem)) + (var-type (get-cell c1 mem)))) + + +(DEFUN SUB-AND-UPDATE-NOREST (C1 C2 C3 MEM) + (MAKE-CELL (mod + (- (VAR-VALUE (GET-CELL C2 MEM)) + (VAR-VALUE (GET-CELL C3 MEM))) + (prod *rns*)) + (VAR-ATTRIBUTE (GET-CELL C1 MEM)) + (VAR-TYPE (GET-CELL C1 MEM)))) + + + +(defun and-update (c1 c2 c3 mem) + (make-cell + (boolean-to-int + (and + (int-to-bool (var-value (get-cell c2 mem))) + (int-to-bool (var-value (get-cell c3 mem))))) + (var-attribute (get-cell c1 mem)) + (var-type (get-cell c1 mem)))) + +(defun or-update (c1 c2 c3 mem) + (make-cell + (boolean-to-int + (or + (int-to-bool (var-value (get-cell c2 mem))) + (int-to-bool (var-value (get-cell c3 mem))))) + (var-attribute (get-cell c1 mem)) + (var-type (get-cell c1 mem)))) + +(defun gen-eq-update (c1 c2 c3 mem) + (make-cell + (boolean-to-int + (equal + (var-value (get-cell c2 mem)) + (var-value (get-cell c3 mem)))) + (var-attribute (get-cell c1 mem)) + (var-type (get-cell c1 mem)))) + + + + + +(defthm sum-and-update-returns-a-mem-cell + (implies + (and + (equal (var-type (get-cell c1 mem)) 'Int) ; This is added to account for booleans + (is-mem-cell-p (get-cell c1 mem)) + (is-mem-cell-p (get-cell c2 mem)) + (is-mem-cell-p (get-cell c3 mem)) + (positivep prime)) + (is-mem-cell-p (sum-and-update c1 c2 c3 prime mem))) + :hints (("Goal" :in-theory (enable mod make-cell var-type var-attribute var-value))) + :rule-classes :forward-chaining) + +#| +(defthm gcd-unfold + (equal (g-c-d x y) + (IF (ZP X) + Y + (IF (ZP Y) + X + (IF (<= X Y) + (G-C-D X (- Y X)) + (G-C-D (- X Y) Y))))) + :hints (("Goal" :in-theory (enable g-c-d nonneg-int-gcd + (:executable-counterpart nonneg-int-gcd) + (:induction nonneg-int-gcd))))) +|# + + +(defthm posp-all-unfold + (equal (posp-all l) + (IF (ENDP L) + T + (AND (POSP (CAR L)) + (POSP-ALL (CDR L))))) + :hints (("Goal" :in-theory (enable posp-all)))) + +(defun integer>1-listp (l) + (if (endp l) + (null l) + (and (integerp (car l)) + (> (car l) 1) + (integer>1-listp (cdr l))))) + + +(defthm int>1-unfold + (equal (integer>1-listp l) + (IF (ENDP L) + (NULL L) + (AND (INTEGERP (CAR L)) + (> (CAR L) 1) + (INTEGER>1-LISTP (CDR L)))))) + + +(defthm fact-bout-rns + (and + (integer-listp *rns*) + (rel-prime-moduli *rns*) + (posp-all *rns*) + (integer>1-listp *rns*) + (not (null *rns*)) + (natp (prod *rns*)) + (> (prod *rns*) 1)) + :hints (("Goal" :in-theory (enable prod posp rel-prime-moduli rel-prime-all rel-prime g-c-d (:executable-counterpart nonneg-int-gcd)))) + :rule-classes nil) + +(in-theory (disable + ;gcd-unfold + posp-all-unfold int>1-unfold)) + +(defthm greater-one-means-greater-zero + (implies (integer>1-listp rns) (posp-all rns)) + :hints (("Goal" + :in-theory (enable posp-all posp))) + :rule-classes nil) + +(DEFTHM SILS1A + (IMPLIES (AND (POSP M) (INTEGERP A)) + (NATP (MOD A M))) + :HINTS + (("Goal" :IN-THEORY + '((:REWRITE INTEGERP-MOD-EXP) + (:DEFINITION NATP) + (:DEFINITION POSP)) + :USE + ((:INSTANCE MOD-TYPE-EXP (X A) (Y M)) + (:INSTANCE MOD-=-0-EXP (X A) (Y M))))) + :rule-classes nil) + +(defthm sum-and-update-norest-returns-a-mem-cell + (implies + (and + (equal (var-type (get-cell c1 mem)) 'Int) + (is-mem-cell-p (get-cell c1 mem)) + (is-mem-cell-p (get-cell c2 mem)) + (is-mem-cell-p (get-cell c3 mem))) + (and + (is-mem-cell-p (sum-and-update-norest c1 c2 c3 mem)) + (bounded-value (sum-and-update-norest c1 c2 c3 mem)) + (equal (var-type (sum-and-update-norest c1 c2 c3 mem)) 'Int)) ) + :hints (("Goal" + :use (fact-bout-rns + (:instance sils1a + (a (+ (var-value (get-cell c2 mem)) (var-value (get-cell c3 mem)))) + (m (prod *rns*))) + (:instance mod-bounds-exp + (x (+ (var-value (get-cell c2 mem)) (var-value (get-cell c3 mem)))) + (y (prod *rns*)))) + :in-theory (enable posp make-cell var-type var-attribute var-value))) + :rule-classes :forward-chaining) + + +(defthm sub-and-update-returns-a-mem-cell + (implies + (and + (equal (var-type (get-cell c1 mem)) 'Int) + (is-mem-cell-p (get-cell c1 mem)) + (is-mem-cell-p (get-cell c2 mem)) + (is-mem-cell-p (get-cell c3 mem)) + (positivep prime) ) + (is-mem-cell-p (sub-and-update c1 c2 c3 prime mem))) + :hints (("Goal" :in-theory (enable mod make-cell var-type var-attribute var-value))) + :rule-classes :forward-chaining) + + +(defthm sub-and-update-norest-returns-a-mem-cell + (implies + (and + (equal (var-type (get-cell c1 mem)) 'Int) + (is-mem-cell-p (get-cell c1 mem)) + (is-mem-cell-p (get-cell c2 mem)) + (is-mem-cell-p (get-cell c3 mem))) + (and + (is-mem-cell-p (sub-and-update-norest c1 c2 c3 mem)) + (bounded-value (sub-and-update-norest c1 c2 c3 mem)) + (equal (var-type (sub-and-update-norest c1 c2 c3 mem)) 'Int)) ) + :hints (("Goal" + :use (fact-bout-rns + (:instance sils1a + (a (- (var-value (get-cell c2 mem)) (var-value (get-cell c3 mem)))) + (m (prod *rns*))) + (:instance mod-bounds-exp + (x (- (var-value (get-cell c2 mem)) (var-value (get-cell c3 mem)))) + (y (prod *rns*)))) + :in-theory (enable posp make-cell var-type var-attribute var-value))) + :rule-classes :forward-chaining) + + +(defthm and-update-returns-a-mem-cell + (implies + (and + (is-mem-cell-p (get-cell c1 mem)) + (is-mem-cell-p (get-cell c2 mem)) + (is-mem-cell-p (get-cell c3 mem))) + (is-mem-cell-p (and-update c1 c2 c3 mem))) + :hints (("Goal" :in-theory (enable my-or-2 make-cell var-type var-attribute var-value))) + :rule-classes :forward-chaining) + +(defthm or-update-returns-a-mem-cell + (implies + (and + (is-mem-cell-p (get-cell c1 mem)) + (is-mem-cell-p (get-cell c2 mem)) + (is-mem-cell-p (get-cell c3 mem))) + (is-mem-cell-p (or-update c1 c2 c3 mem))) + :hints (("Goal" :in-theory (enable my-or-2 make-cell var-type var-attribute var-value))) + :rule-classes :forward-chaining) + +(defthm gen-eq-update-returns-a-mem-cell + (implies + (and + (is-mem-cell-p (get-cell c1 mem)) + (is-mem-cell-p (get-cell c2 mem)) + (is-mem-cell-p (get-cell c3 mem))) + (and + (bounded-value (gen-eq-update c1 c2 c3 mem)) + (is-mem-cell-p (gen-eq-update c1 c2 c3 mem)))) + :hints (("Goal" + :use (fact-bout-rns + (:instance sils1a + (a (boolean-to-int (equal (var-value (get-cell c2 mem)) (var-value (get-cell c3 mem))))) + (m (prod *rns*))) + (:instance mod-bounds-exp + (x (boolean-to-int (equal (var-value (get-cell c2 mem)) (var-value (get-cell c3 mem))))) + (y (prod *rns*)))) + :in-theory (enable posp my-or-2 make-cell var-type var-attribute var-value))) + :rule-classes :forward-chaining) + + + + + + + + + + + +(defun gem-add (a b c s) + (make-state + (put-cell a + (sum-and-update-norest a b c (mem s)) + (mem s)) + (1+ (pcc s)) + (code s))) + +(defun gem-sub (a b c s) + (make-state + (put-cell a + (sub-and-update-norest a b c (mem s)) + (mem s)) + (1+ (pcc s)) + (code s))) + +(defun rtm-add (a b c d s) + (make-state + (put-cell a + (sum-and-update a b c d (mem s)) + (mem s)) + (1+ (pcc s)) + (code s))) + +(defun rtm-sub (a b c d s) + (make-state + (put-cell a + (sub-and-update a b c d (mem s)) + (mem s)) + (1+ (pcc s)) + (code s))) + + +(defun rtm-and (a b c s) + (make-state + (put-cell a + (and-update a b c (mem s)) + (mem s)) + (1+ (pcc s)) + (code s))) + +(defun rtm-or (a b c s) + (make-state + (put-cell a + (or-update a b c (mem s)) + (mem s)) + (1+ (pcc s)) + (code s))) + +(defun generic-eql (a b c s) + (make-state + (put-cell a + (gen-eq-update a b c (mem s)) + (mem s)) + (1+ (pcc s)) + (code s))) + + + +(defun execute-instruction (st) + (let + ((op (opcode (nth (pcc st) (code st)))) + (ins (nth (pcc st) (code st)))) + (case op + (gem-add (gem-add (par1 ins) (par2 ins) (par3 ins) st)) + (gem-sub (gem-sub (par1 ins) (par2 ins) (par3 ins) st)) + (gem-equ (generic-eql (par1 ins) (par2 ins) (par3 ins) st)) + (rtm-add (rtm-add (par1 ins) (par2 ins) (par3 ins) (par4 ins) st)) + (rtm-sub (rtm-sub (par1 ins) (par2 ins) (par3 ins) (par4 ins) st)) + (rtm-and (rtm-and (par1 ins) (par2 ins) (par3 ins) st)) + (rtm-or (rtm-or (par1 ins) (par2 ins) (par3 ins) st)) + (rtm-equ (generic-eql (par1 ins) (par2 ins) (par3 ins) st)) + (otherwise st)))) + + +(defun execute-n-instructions (st n) + (if + (zp n) + st + (execute-n-instructions + (execute-instruction st) + (1- n)))) + + + +(defthm instruction-incrementing-pvv + (implies + (>= (pcc st) 0) + (>= (pcc (execute-instruction st)) 0))) + + + + +(defthm in-range-instruction-is-gem-instruction + (implies + (and + (in-range pcc code) + (gem-instruction-list-p code mem)) + (gem-instruction-p (nth pcc code) mem)) + :hints (("Goal" :in-theory (disable gem-instruction-p))) + :rule-classes :forward-chaining) + + + +(defthm in-range-instruction-is-rtmm-instruction + (implies + (and + (in-range pcc code) + (rtm-instruction-list-p code mem)) + (rtm-instruction-p (nth pcc code) mem)) + :hints (("Goal" :in-theory (disable rtm-instruction-p))) + :rule-classes :forward-chaining) + + + + + +(defthm null-not-in-range + (implies + (and + (integerp idx) + (>= idx 0) + (not (in-range idx l))) + (null (nth idx l))) + :rule-classes :forward-chaining) + +(defthm pcc-not-in-range-means-null-instruction + (implies + (and + (or + (gem-statep st) + (rtm-statep st)) + (>= (pcc st) 0) + (not (in-range (pcc st) (code st)))) + (null (nth (pcc st) (code st)))) + :hints (("Goal" :cases ( (gem-statep st) (rtm-statep st)))) + :rule-classes :forward-chaining) + +(defthm null-opcode-implies-execution-does-not-touch-state + (implies + (null (nth (pcc st) (code st))) + (equal (execute-instruction st) st))) + +(defthm execute-not-in-range-instruction-retrieves-same-state + (implies + (and + (or + (gem-statep st) + (rtm-statep st) ) + (>= (pcc st) 0) + (not (in-range (pcc st) (code st)))) + (equal (execute-instruction st) st)) + :hints (("Goal" :cases ( (gem-statep st) (rtm-statep st) )) + ("Subgoal 2" :use ((:instance gem-statep (x st)) + null-opcode-implies-execution-does-not-touch-state + pcc-not-in-range-means-null-instruction)) + ("Subgoal 1" :use ((:instance rtm-statep (x st)) + null-opcode-implies-execution-does-not-touch-state + pcc-not-in-range-means-null-instruction)))) + +(in-theory (disable null-opcode-implies-execution-does-not-touch-state + execute-not-in-range-instruction-retrieves-same-state)) + + +(defthm execute-instruction-does-not-touch-code (equal (code (execute-instruction st)) (code st))) + +(defthm execute-n-instruction-does-not-touch-code (equal (code (execute-n-instructions st n)) (code st))) + +(defthm execute-n-instruction-decomposition + (implies + (and + (integerp n1) + (integerp n2) + (>= n1 0) + (>= n2 0)) + (equal + (execute-n-instructions st (+ n1 n2)) + (execute-n-instructions (execute-n-instructions st n1) n2))) + :hints (("Goal" :in-theory (disable execute-instruction member-equal)))) + + +(defthm putting-a-new-cell-preserves-typed-amem + (implies + (and + (is-typed-amem-p mem) + (is-mem-cell-p new-cell)) + (is-typed-amem-p (put-cell c new-cell mem))) +:hints (("Goal" :in-theory (enable put-cell)))) + +(defthm no-influence-of-putting-mem-cells + (implies + (and + (is-mem-cell-p cell) + (is-mem-cell-p (get-cell c1 mem))) + (is-mem-cell-p (get-cell c1 (put-cell pos cell mem)))) + :hints ( ("Goal" :in-theory (enable put-cell get-cell) ))) + + +(defthm putting-a-new-bounded-cell-preserves-boundedness + (implies + (and + (bounded-amem-p mem) + (bounded-value new-cell)) + (bounded-amem-p (put-cell c new-cell mem))) +:hints (("Goal" :in-theory (enable put-cell)))) + +(defthm no-influence-of-putting-bounded-cells + (implies + (and + (bounded-value cell) + (bounded-value (get-cell c1 mem))) + (bounded-value (get-cell c1 (put-cell pos cell mem)))) + :hints ( ("Goal" :in-theory (enable put-cell get-cell) ))) + + + +(defthm putting-an-existing-cell-does-not-change-var-inclusion-right + (implies + (is-mem-cell-p (get-cell v mem)) + (iff (vars-inclusion m mem) (vars-inclusion m (put-cell v anyvalue mem)))) + :hints (("Goal" :in-theory (enable put-cell get-cell is-mem-cell-p)))) + +(defthm putting-an-existing-cell-does-not-change-var-inclusion-left + (implies + (is-mem-cell-p (get-cell v mem)) + (iff (vars-inclusion mem m) (vars-inclusion (put-cell v anyvalue mem) m))) + :hints (("Goal" :in-theory (enable put-cell get-cell is-mem-cell-p)))) + + + +(defthm execute-instruction-is-type-and-attribute-invariant-on-any-var + (and + (equal (var-attribute (get-cell cell (mem st))) + (var-attribute (get-cell cell (mem (execute-instruction st))))) + (equal (var-type (get-cell cell (mem st))) + (var-type (get-cell cell (mem (execute-instruction st)))))) + :hints (("Goal" :in-theory (enable put-cell get-cell make-cell mem make-state var-attribute var-type)))) + + + +(in-theory (disable + putting-an-existing-cell-does-not-change-var-inclusion-left + putting-an-existing-cell-does-not-change-var-inclusion-right + )) + + + + + + +;;(ld "Properties-of-Execute-Gem-Instruction-New.lisp" :ld-error-action :error) + + + +(defthm any-mem-cell-is-conserved-after-execute-instruction-on-gemstate + (implies (and + (gem-statep st) + (is-mem-cell-p (get-cell anycell (mem st)))) + (is-mem-cell-p (get-cell anycell (mem (execute-instruction st))))) +:hints (("Goal" :cases ( (null (nth (pcc st) (code st))) (gem-instruction-p (nth (pcc st) (code st)) (mem st)))) + ("Subgoal 3" :use an-instruction-of-gem-program-is-null-or-gem-instruction) + ("Subgoal 1" :use (execute-instruction + (:instance sum-and-update-norest-returns-a-mem-cell + (c1 (par1 (nth (pcc st) (code st)))) + (c2 (par2 (nth (pcc st) (code st)))) + (c3 (par3 (nth (pcc st) (code st)))) + (mem (mem st))) + (:instance sub-and-update-norest-returns-a-mem-cell + (c1 (par1 (nth (pcc st) (code st)))) + (c2 (par2 (nth (pcc st) (code st)))) + (c3 (par3 (nth (pcc st) (code st)))) + (mem (mem st))) + (:instance gen-eq-update-returns-a-mem-cell + (c1 (par1 (nth (pcc st) (code st)))) + (c2 (par2 (nth (pcc st) (code st)))) + (c3 (par3 (nth (pcc st) (code st)))) + (mem (mem st)))) + :in-theory (disable bounded-value put-cell get-cell execute-instruction + sum-and-update-norest sub-and-update-norest gen-eq-update + par1 par2 par3 par4 member-equal nth rtm-add rtm-sub is-mem-cell-p)))) + +(defthm any-bounded-cell-is-bounded-after-execute-instruction-on-gemstate + (implies (and + (gem-statep st) + (bounded-value (get-cell anycell (mem st)))) + (bounded-value (get-cell anycell (mem (execute-instruction st))))) +:hints (("Goal" :cases ( (null (nth (pcc st) (code st))) (gem-instruction-p (nth (pcc st) (code st)) (mem st)))) + ("Subgoal 3" :use an-instruction-of-gem-program-is-null-or-gem-instruction) + ("Subgoal 1" :use (execute-instruction + (:instance sum-and-update-norest-returns-a-mem-cell + (c1 (par1 (nth (pcc st) (code st)))) + (c2 (par2 (nth (pcc st) (code st)))) + (c3 (par3 (nth (pcc st) (code st)))) + (mem (mem st))) + (:instance sub-and-update-norest-returns-a-mem-cell + (c1 (par1 (nth (pcc st) (code st)))) + (c2 (par2 (nth (pcc st) (code st)))) + (c3 (par3 (nth (pcc st) (code st)))) + (mem (mem st))) + (:instance gen-eq-update-returns-a-mem-cell + (c1 (par1 (nth (pcc st) (code st)))) + (c2 (par2 (nth (pcc st) (code st)))) + (c3 (par3 (nth (pcc st) (code st)))) + (mem (mem st)))) + :in-theory (disable bounded-value put-cell get-cell execute-instruction bounded-value + sum-and-update-norest sub-and-update-norest gen-eq-update + par1 par2 par3 par4 member-equal nth rtm-add rtm-sub is-mem-cell-p)))) + +#| +(defthm execute-instruction-is-type-and-attribute-invariant-on-any-var + (and + (equal (var-attribute (get-cell cell (mem st))) + (var-attribute (get-cell cell (mem (execute-instruction st))))) + (equal (var-type (get-cell cell (mem st))) + (var-type (get-cell cell (mem (execute-instruction st)))))) + :hints (("Goal" :in-theory (enable put-cell get-cell make-cell mem make-state var-attribute var-type)))) +|# + +(defthm any-gem-instruction-is-conserved-by-execution + (implies + (and + (gem-statep st) + (gem-instruction-p instr (mem st))) + (gem-instruction-p instr (mem (execute-instruction st)))) + :hints (("Goal" + :in-theory '((:definition gem-instruction-p)) + :use + ( + (:instance any-mem-cell-is-conserved-after-execute-instruction-on-gemstate + (anycell (par1 instr))) + (:instance any-mem-cell-is-conserved-after-execute-instruction-on-gemstate + (anycell (par2 instr))) + (:instance any-mem-cell-is-conserved-after-execute-instruction-on-gemstate + (anycell (par3 instr))) + (:instance execute-instruction-is-type-and-attribute-invariant-on-any-var + (cell (par1 instr))) + (:instance execute-instruction-is-type-and-attribute-invariant-on-any-var + (cell (par2 instr))) + (:instance execute-instruction-is-type-and-attribute-invariant-on-any-var + (cell (par3 instr))))))) + + + +(defthm a-gem-instruction-list-is-such-after-execute-instruction + (implies + (and + (gem-statep st) + (gem-instruction-list-p instrlist (mem st))) + (gem-instruction-list-p instrlist (mem (execute-instruction st)))) + :hints (("Goal" + :induct (gem-instruction-list-p instrlist (mem st)) ;(len instrlist) + :in-theory (disable execute-instruction)) + ("Subgoal *1/3" :use (:instance gem-instruction-list-p (instlist instrlist) (mem (mem st)))) + ("Subgoal *1/2" + :in-theory (union-theories (current-theory 'ground-zero) '((:definition gem-instruction-list-p))) + :use (:instance any-gem-instruction-is-conserved-by-execution (instr (car instrlist)))))) + + + + +(defthm execute-gem-retrieves-a-memory + (implies + (and + (gem-statep st) + (gem-instruction-p (nth (pcc st) (code st)) (mem st))) + (and + (bounded-amem-p (mem (execute-instruction st))) + (is-typed-amem-p (mem (execute-instruction st))))) + :hints (("Goal" + :in-theory (disable is-mem-cell-p sum-and-update-norest sub-and-update-norest gen-eq-update) + :use ( + (:instance gen-eq-update-returns-a-mem-cell + (c1 (par1 (nth (pcc st) (code st)))) + (c2 (par2 (nth (pcc st) (code st)))) + (c3 (par3 (nth (pcc st) (code st)))) + (mem (mem st))) + (:instance sum-and-update-norest-returns-a-mem-cell + (c1 (par1 (nth (pcc st) (code st)))) + (c2 (par2 (nth (pcc st) (code st)))) + (c3 (par3 (nth (pcc st) (code st)))) + (mem (mem st))) + (:instance sub-and-update-norest-returns-a-mem-cell + (c1 (par1 (nth (pcc st) (code st)))) + (c2 (par2 (nth (pcc st) (code st)))) + (c3 (par3 (nth (pcc st) (code st)))) + (mem (mem st))))))) + + + +(defthm executing-gem-instruction-retrieves-a-gem-state-from-gem-state + (implies + (gem-statep st) + (gem-statep (execute-instruction st))) + :hints (("Goal" :cases ( (null (nth (pcc st) (code st))) (gem-instruction-p (nth (pcc st) (code st)) (mem st)))) + ("Subgoal 3" :use an-instruction-of-gem-program-is-null-or-gem-instruction) + ("Subgoal 1" + :use ( + (:instance a-gem-instruction-list-is-such-after-execute-instruction (instrlist (code st))) + (:instance execute-gem-retrieves-a-memory)) + :in-theory (disable sum-and-update-norest sub-and-update-norest gen-eq-update gem-instruction-p + par1 par2 par3 par4 member-equal nth)))) + + + + + +(defthm executing-gem-instruction-preserves-correctness-wrt-arity + (implies + (and + (gem-statep st) + (correct-wrt-arity m (mem st))) + (correct-wrt-arity m (mem (execute-instruction st)))) + :hints (("Goal" :in-theory (disable correct-type gemvar-0 var-type gem-statep pcc nth execute-instruction type-0)) + ("Subgoal *1/3" :use (:instance execute-instruction-is-type-and-attribute-invariant-on-any-var (cell (gemvar-0 m)))))) + + + + + +(defthm executing-gem-instruction-keeps-vars-inclusion-right + (implies + (gem-statep st) + (iff (vars-inclusion m (mem st)) (vars-inclusion m (mem (execute-instruction st))))) + :hints (("Goal" :cases ( (null (nth (pcc st) (code st))) (gem-instruction-p (nth (pcc st) (code st)) (mem st)))) + ("Subgoal 3" :use an-instruction-of-gem-program-is-null-or-gem-instruction) + ("Subgoal 1" :in-theory (disable par1 par2 par3 par4 sum-and-update-norest opcode code pcc member-equal nth) + :cases ( (equal (opcode (nth (pcc st) (code st))) 'gem-equ) + (equal (opcode (nth (pcc st) (code st))) 'gem-add) + (equal (opcode (nth (pcc st) (code st))) 'gem-sub))) + ("Subgoal 1.3" :in-theory '((:rewrite car-cons) + (:definition make-state) + (:definition mem) + (:definition generic-eql) + (:definition execute-instruction) + (:definition gem-instruction-p)) + :use (:instance putting-an-existing-cell-does-not-change-var-inclusion-right + (mem (mem st)) + (v (par1 (nth (pcc st) (code st)))) + (anyvalue (gen-eq-update + (par1 (nth (pcc st) (code st))) + (par2 (nth (pcc st) (code st))) + (par3 (nth (pcc st) (code st))) + (mem st))))) + ("Subgoal 1.2" :in-theory '((:rewrite car-cons) + (:definition make-state) + (:definition mem) + (:definition gem-add) + (:definition execute-instruction) + (:definition gem-instruction-p)) + :use (:instance putting-an-existing-cell-does-not-change-var-inclusion-right + (mem (mem st)) + (v (par1 (nth (pcc st) (code st)))) + (anyvalue (sum-and-update-norest + (par1 (nth (pcc st) (code st))) + (par2 (nth (pcc st) (code st))) + (par3 (nth (pcc st) (code st))) + (mem st))))) + ("Subgoal 1.1" :in-theory '((:rewrite car-cons) + (:definition make-state) + (:definition mem) + (:definition gem-sub) + (:definition execute-instruction) + (:definition gem-instruction-p)) + :use (:instance putting-an-existing-cell-does-not-change-var-inclusion-right + (mem (mem st)) + (v (par1 (nth (pcc st) (code st)))) + (anyvalue (sub-and-update-norest + (par1 (nth (pcc st) (code st))) + (par2 (nth (pcc st) (code st))) + (par3 (nth (pcc st) (code st))) + (mem st))))))) + +(defthm executing-gem-instruction-keeps-vars-inclusion-left + (implies + (gem-statep st) + (iff (vars-inclusion (mem st) m) (vars-inclusion (mem (execute-instruction st)) m))) + :hints (("Goal" :cases ( (null (nth (pcc st) (code st))) (gem-instruction-p (nth (pcc st) (code st)) (mem st)))) + ("Subgoal 3" :use an-instruction-of-gem-program-is-null-or-gem-instruction) + ("Subgoal 1" :in-theory (disable par1 par2 par3 par4 sum-and-update-norest opcode code pcc member-equal nth) + :cases ( (equal (opcode (nth (pcc st) (code st))) 'gem-equ) + (equal (opcode (nth (pcc st) (code st))) 'gem-add) + (equal (opcode (nth (pcc st) (code st))) 'gem-sub))) + ("Subgoal 1.3" :in-theory '((:rewrite car-cons) + (:definition make-state) + (:definition mem) + (:definition generic-eql) + (:definition execute-instruction) + (:definition gem-instruction-p)) + :use (:instance putting-an-existing-cell-does-not-change-var-inclusion-left + (mem (mem st)) + (v (par1 (nth (pcc st) (code st)))) + (anyvalue (gen-eq-update + (par1 (nth (pcc st) (code st))) + (par2 (nth (pcc st) (code st))) + (par3 (nth (pcc st) (code st))) + (mem st))))) + ("Subgoal 1.2" :in-theory '((:rewrite car-cons) + (:definition make-state) + (:definition mem) + (:definition gem-add) + (:definition execute-instruction) + (:definition gem-instruction-p)) + :use (:instance putting-an-existing-cell-does-not-change-var-inclusion-left + (mem (mem st)) + (v (par1 (nth (pcc st) (code st)))) + (anyvalue (sum-and-update-norest + (par1 (nth (pcc st) (code st))) + (par2 (nth (pcc st) (code st))) + (par3 (nth (pcc st) (code st))) + (mem st))))) + ("Subgoal 1.1" :in-theory '((:rewrite car-cons) + (:definition make-state) + (:definition mem) + (:definition gem-sub) + (:definition execute-instruction) + (:definition gem-instruction-p)) + :use (:instance putting-an-existing-cell-does-not-change-var-inclusion-left + (mem (mem st)) + (v (par1 (nth (pcc st) (code st)))) + (anyvalue (sub-and-update-norest + (par1 (nth (pcc st) (code st))) + (par2 (nth (pcc st) (code st))) + (par3 (nth (pcc st) (code st))) + (mem st))))))) + + +;;(ld "Properties-of-Execute-n-Rtm-Instructions-New.lisp" :ld-error-action :error) + + + +(defthm any-mem-cell-is-conserved-after-execute-instruction-on-rtmstate + (implies (and + (rtm-statep st) + (is-mem-cell-p (get-cell anycell (mem st)))) + (is-mem-cell-p (get-cell anycell (mem (execute-instruction st))))) +:hints (("Goal" :cases ( (null (nth (pcc st) (code st))) (rtm-instruction-p (nth (pcc st) (code st)) (mem st)))) + ("Subgoal 3" :use an-instruction-of-rtm-program-is-null-or-rtm-instruction) + ("Subgoal 1" :use (execute-instruction + (:instance gen-eq-update-returns-a-mem-cell + (c1 (par1 (nth (pcc st) (code st)))) + (c2 (par2 (nth (pcc st) (code st)))) + (c3 (par3 (nth (pcc st) (code st)))) + (mem (mem st))) + (:instance and-update-returns-a-mem-cell + (c1 (par1 (nth (pcc st) (code st)))) + (c2 (par2 (nth (pcc st) (code st)))) + (c3 (par3 (nth (pcc st) (code st)))) + (mem (mem st))) + (:instance or-update-returns-a-mem-cell + (c1 (par1 (nth (pcc st) (code st)))) + (c2 (par2 (nth (pcc st) (code st)))) + (c3 (par3 (nth (pcc st) (code st)))) + (mem (mem st))) + (:instance sum-and-update-returns-a-mem-cell + (c1 (par1 (nth (pcc st) (code st)))) + (c2 (par2 (nth (pcc st) (code st)))) + (c3 (par3 (nth (pcc st) (code st)))) + (prime (par4 (nth (pcc st) (code st)))) + (mem (mem st))) + (:instance sub-and-update-returns-a-mem-cell + (c1 (par1 (nth (pcc st) (code st)))) + (c2 (par2 (nth (pcc st) (code st)))) + (c3 (par3 (nth (pcc st) (code st)))) + (prime (par4 (nth (pcc st) (code st)))) + (mem (mem st)))) + :in-theory (disable put-cell get-cell execute-instruction + sum-and-update sub-and-update and-update or-update gen-eq-update + par1 par2 par3 par4 member-equal nth gem-add gem-sub is-mem-cell-p)))) + + +(defthm any-rtm-instruction-is-conserved-by-execution + (implies + (and + (rtm-statep st) + (rtm-instruction-p instr (mem st))) + (rtm-instruction-p instr (mem (execute-instruction st)))) + :hints (("Goal" + :in-theory '((:definition rtm-instruction-p)) + :use + ( + (:instance any-mem-cell-is-conserved-after-execute-instruction-on-rtmstate + (anycell (par1 instr))) + (:instance any-mem-cell-is-conserved-after-execute-instruction-on-rtmstate + (anycell (par2 instr))) + (:instance any-mem-cell-is-conserved-after-execute-instruction-on-rtmstate + (anycell (par3 instr))) + (:instance any-mem-cell-is-conserved-after-execute-instruction-on-rtmstate + (anycell (par4 instr))) + (:instance execute-instruction-is-type-and-attribute-invariant-on-any-var + (cell (par1 instr))) + (:instance execute-instruction-is-type-and-attribute-invariant-on-any-var + (cell (par2 instr))) + (:instance execute-instruction-is-type-and-attribute-invariant-on-any-var + (cell (par3 instr))) + (:instance execute-instruction-is-type-and-attribute-invariant-on-any-var + (cell (par4 instr))))))) + + + +(defthm a-rtm-instruction-list-is-such-after-execute-instruction + (implies + (and + (rtm-statep st) + (rtm-instruction-list-p instrlist (mem st))) + (rtm-instruction-list-p instrlist (mem (execute-instruction st)))) + :hints (("Goal" + :induct (rtm-instruction-list-p instrlist (mem st)) + :in-theory (disable execute-instruction)) + ("Subgoal *1/3" :use (:instance rtm-instruction-list-p (instlist instrlist) (mem (mem st)))) + ("Subgoal *1/2" + :in-theory (union-theories (current-theory 'ground-zero) '((:definition rtm-instruction-list-p))) + :use (:instance any-rtm-instruction-is-conserved-by-execution (instr (car instrlist)))))) + + +(defthm execute-rtm-retrieves-a-memory + (implies + (and + (rtm-statep st) + (rtm-instruction-p (nth (pcc st) (code st)) (mem st))) + (is-typed-amem-p (mem (execute-instruction st)))) + :hints (("Goal" + :in-theory (disable is-mem-cell-p + and-update or-update gen-eq-update sum-and-update sub-and-update ) + :use ( + (:instance gen-eq-update-returns-a-mem-cell + (c1 (par1 (nth (pcc st) (code st)))) + (c2 (par2 (nth (pcc st) (code st)))) + (c3 (par3 (nth (pcc st) (code st)))) + (mem (mem st))) + (:instance or-update-returns-a-mem-cell + (c1 (par1 (nth (pcc st) (code st)))) + (c2 (par2 (nth (pcc st) (code st)))) + (c3 (par3 (nth (pcc st) (code st)))) + (mem (mem st))) + (:instance and-update-returns-a-mem-cell + (c1 (par1 (nth (pcc st) (code st)))) + (c2 (par2 (nth (pcc st) (code st)))) + (c3 (par3 (nth (pcc st) (code st)))) + (mem (mem st))) + (:instance sum-and-update-returns-a-mem-cell + (c1 (par1 (nth (pcc st) (code st)))) + (c2 (par2 (nth (pcc st) (code st)))) + (c3 (par3 (nth (pcc st) (code st)))) + (prime (par4 (nth (pcc st) (code st)))) + (mem (mem st))) + (:instance sub-and-update-returns-a-mem-cell + (c1 (par1 (nth (pcc st) (code st)))) + (c2 (par2 (nth (pcc st) (code st)))) + (c3 (par3 (nth (pcc st) (code st)))) + (prime (par4 (nth (pcc st) (code st)))) + (mem (mem st))))))) + + + +(defthm executing-rtm-instruction-retrieves-a-rtm-state-from-rtm-state + (implies + (rtm-statep st) + (rtm-statep (execute-instruction st))) + :hints (("Goal" :cases ( (null (nth (pcc st) (code st))) (rtm-instruction-p (nth (pcc st) (code st)) (mem st)))) + ("Subgoal 3" :use an-instruction-of-rtm-program-is-null-or-rtm-instruction) + ("Subgoal 1" + :use ( + (:instance a-rtm-instruction-list-is-such-after-execute-instruction (instrlist (code st))) + (:instance execute-rtm-retrieves-a-memory)) + :in-theory (disable sum-and-update sub-and-update and-update or-update gen-eq-update + rtm-instruction-p + par1 par2 par3 par4 member-equal nth)))) + + + + + +(defthm executing-rtm-instruction-is-attributes-invariant + (implies + (rtm-statep st) + (equal + (var-attributes vars (mem st)) + (var-attributes vars (mem (execute-instruction st))))) + :hints (("Goal" :in-theory (disable par1 par2 par3 par4 member-equal nth)) + ("Subgoal *1/2" :use (:instance execute-instruction-is-type-and-attribute-invariant-on-any-var + (cell (car vars)))))) + + + +(defthm executing-rtm-instruction-keeps-m-pointing-to-rtm-var-sets + (implies + (and + (rtm-statep st) + (m-entries-point-to-good-rtm-var-sets m (mem st))) + (m-entries-point-to-good-rtm-var-sets m (mem (execute-instruction st)))) + :hints (("Goal" :in-theory (disable par1 par2 par3 par4 member-equal nth)) + ("Subgoal *1/3" :use (:instance executing-rtm-instruction-is-attributes-invariant + (vars (rtmintvars-0 m)))))) + + + + + + + + + + + + + + + + + +(defun listpars1 (st n) + (if (zp n) + nil + (cons (par1 (nth (pcc st) (code st))) + (listpars1 (execute-instruction st) (1- n))))) + +(defun listpars2 (st n) + (if (zp n) + nil + (cons (par2 (nth (pcc st) (code st))) + (listpars2 (execute-instruction st) (1- n))))) + +(defun listpars3 (st n) + (if (zp n) + nil + (cons (par3 (nth (pcc st) (code st))) + (listpars3 (execute-instruction st) (1- n))))) + +(defun listpars4 (st n) + (if (zp n) + nil + (cons (par4 (nth (pcc st) (code st))) + (listpars4 (execute-instruction st) (1- n))))) + + + + +(defthm lemma12-lp1r + (equal (cdr (listpars1 st n)) (listpars1 (execute-instruction st) (1- n))) +:hints (("Goal" :in-theory (disable execute-instruction)))) + + +(defthm lemma12-lp2r + (equal (cdr (listpars2 st n)) (listpars2 (execute-instruction st) (1- n))) + :hints (("Goal" :in-theory (disable execute-instruction)))) + + +(defthm lemma12-lp3r + (equal (cdr (listpars3 st n)) (listpars3 (execute-instruction st) (1- n))) + :hints (("Goal" :in-theory (disable execute-instruction)))) + + +(defthm lemma12-lp4r + (equal (cdr (listpars4 st n)) (listpars4 (execute-instruction st) (1- n))) + :hints (("Goal" :in-theory (disable execute-instruction)))) + +(defthm length-of-listpars1-n-is-n + (implies + (and + (integerp n) + (>= n 0)) + (equal (len (listpars1 st n)) n)) + :hints (("Goal" :in-theory (disable execute-instruction nth par1 pcc code member-equal)))) + +(defthm length-of-listpars2-n-is-n + (implies + (and + (integerp n) + (>= n 0)) + (equal (len (listpars2 st n)) n)) + :hints (("Goal" :in-theory (disable execute-instruction nth par2 pcc code member-equal)))) + +(defthm length-of-listpars3-n-is-n + (implies + (and + (integerp n) + (>= n 0)) + (equal (len (listpars3 st n)) n)) + :hints (("Goal" :in-theory (disable execute-instruction)))) + +(defthm length-of-listpars4-n-is-n + (implies + (and + (integerp n) + (>= n 0)) + (equal (len (listpars4 st n)) n)) + :hints (("Goal" :in-theory (disable execute-instruction)))) + + + + + + + + + + + + + + +(defthm only-par1-is-involved + (implies + (and + (or + (null (nth (pcc gstate) (code gstate))) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-equ) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-add) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-sub)) + (not (equal var (par1 (nth (pcc gstate) (code gstate))))) ) + (equal (get-cell var (mem gstate)) (get-cell var (mem (execute-instruction gstate))))) + :hints (("Goal" :in-theory (disable sum-and-update sub-and-update gen-eq-update nth mod)))) + +(defthm only-par1-is-involved-rtm + (implies + (and + (or + (null (nth (pcc gstate) (code gstate))) + (equal (opcode (nth (pcc gstate) (code gstate))) 'rtm-and) + (equal (opcode (nth (pcc gstate) (code gstate))) 'rtm-or) + (equal (opcode (nth (pcc gstate) (code gstate))) 'rtm-equ) + (equal (opcode (nth (pcc gstate) (code gstate))) 'rtm-add) + (equal (opcode (nth (pcc gstate) (code gstate))) 'rtm-sub)) + (not (equal var (par1 (nth (pcc gstate) (code gstate))))) ) + (equal (get-cell var (mem gstate)) (get-cell var (mem (execute-instruction gstate))))) + :hints (("Goal" :in-theory (disable sum-and-update sub-and-update gen-eq-update nth mod)))) + + + + + + + + + + + + + + + + + + + + +(in-theory (enable build-values-by-rns)) + + +(in-theory (disable mod floor)) + + + + + +(defun rtmintvars-i (gvar m) (cdr (assoc-equal gvar m))) + +(DEFUN TYPE-I (gvar M) + (COND ((AND (TRUE-LISTP (RTMINTVARS-I gvar M)) + (EQUAL (LEN (RTMINTVARS-I gvar M)) 1)) + 'BOOL) + ((AND (TRUE-LISTP (RTMINTVARS-I gvar M)) + (EQUAL (LEN (RTMINTVARS-I gvar M)) + (LEN *RNS*))) + 'INT) + (T 'WRONG-TYPING))) + +(defthm type-i-is-vartyper + (implies + (and + (assoc-equal gvar1 m) + (true-listp m) + (correct-wrt-arity m mem)) + (equal (type-i gvar1 m) (var-type (get-cell gvar1 mem)))) + :hints (("Goal" :in-theory (enable + var-type gemvar-0 rtmintvars-0 var-type type-i type-0)))) + +(defthm type-i-is-type-expected + (implies + (and + (assoc-equal gvar m) + (true-listp m) + (correct-wrt-arity m mem)) + (equal + (type-i gvar m) + (type-expected (rtmintvars-i gvar m))))) + +(defun pos-equal-0 (el l) + (cond + ( (endp l) 0 ) + ( (equal el (caar l)) 0 ) + (t (1+ (pos-equal-0 el (cdr l)))))) + +(defthm assoc-means-pos-in-range + (implies (assoc-equal el l) (in-range (pos-equal-0 el l) l)) + :rule-classes :forward-chaining) + + + +(defun retrieve-gemvars (m) + (if + (endp m) + nil + (cons (gemvar-0 m) (retrieve-gemvars (cdr m))))) + + +(defthm retrieve-gemvars-same-len + (implies + (true-listp m) + (equal (len (retrieve-gemvars m)) (len m)))) + +(defthm equal-nth-of-retrieve-car-of-nth + (equal (nth idx (retrieve-gemvars m)) (car (nth idx m))) + :hints (("Goal" :in-theory (enable gemvar-0)))) + + +(defthm no-duplicates-whose-caar-is-nth-idx-means-idx-is-0 +(IMPLIES (AND (NOT (ENDP L)) + (EQUAL (CAR (NTH IDX L)) (CAAR L)) + (TRUE-LISTP L) + (in-range idx l) + (NO-DUPLICATES-P (RETRIEVE-GEMVARS L))) + (EQUAL idx 0)) +:hints (("Goal" + :in-theory (union-theories (current-theory 'ground-zero) + '((:definition in-range) + (:definition len) + (:rewrite equal-nth-of-retrieve-car-of-nth))) + :use + ( + (:instance retrieve-gemvars-same-len (m l)) + (:instance no-dup-3 (l (retrieve-gemvars l)) (idx2 0))))) +:rule-classes nil) + + +(defthm subgoal12 +(IMPLIES (AND (NOT (ENDP L)) + (EQUAL (CAR (NTH IDX L)) (CAAR L)) + (TRUE-LISTP L) + (< (POS-EQUAL-0 (CAR (NTH IDX L)) L) + (LEN L)) + (INTEGERP IDX) + (<= 0 IDX) + (< IDX (LEN L)) + (NO-DUPLICATES-P (RETRIEVE-GEMVARS L))) + (EQUAL (POS-EQUAL-0 (CAR (NTH IDX L)) L) + IDX)) +:hints (("Goal" + :use no-duplicates-whose-caar-is-nth-idx-means-idx-is-0))) + + +(defthm no-duplicates-has-pos-equal-right-in-that-place + (implies + (and + (true-listp l) + (in-range idx l) + (no-duplicates-p (retrieve-gemvars l))) + (equal (pos-equal-0 (car (nth idx l)) l) idx)) + :hints (("Goal" :in-theory (enable gemvar-0)) + ("Subgoal *1/2" :use subgoal12))) + + + + + +(defthm rtmintvars-i-is-cdr-of-nth-entry + (equal (rtmintvars-i gvar m) + (cdr (nth (pos-equal-0 gvar m) m)))) + + + +(defun type-i-idx (m idx) + (COND ((AND (TRUE-LISTP (cdr (nth idx m))) + (EQUAL (LEN (cdr (nth idx m))) 1)) + 'BOOL) + ((AND (TRUE-LISTP (cdr (nth idx m))) + (EQUAL (LEN (cdr (nth idx m))) + (LEN *RNS*))) + 'INT) + (T 'WRONG-TYPING))) + +(defun listinstr (st n) + (if (zp n) + nil + (cons (nth (pcc st) (code st)) + (listinstr (execute-instruction st) (1- n))))) + +(defthm inclusion-trans + (implies + (and + (vars-inclusion m1 m2) + (assoc-equal v m1)) + (assoc-equal v m2))) + +(defthm correct-wrt-arity-has-rtmintvars-i-tl + (implies + (correct-wrt-arity m mem) + (true-listp (rtmintvars-i gvar1 m))) + :hints (("Goal" :in-theory (enable correct-wrt-arity type-0 gemvar-0 rtmintvars-0 correct-type)))) + +(defun rtm-eq-and (v1 v2 tmp res) +(list + (list 'rtm-equ tmp v1 v2) + (list 'rtm-and res tmp res))) + +(defun rtm-eq-or (v1 v2 tmp res) +(list + (list 'rtm-equ tmp v1 v2) + (list 'rtm-or res tmp tmp))) + +(defun equality-trans2 (listvars1 listvars2 tmp res) + (if (endp listvars1) + nil + (append + (rtm-eq-and (car listvars1) (car listvars2) tmp res) + (equality-trans2 (cdr listvars1) (cdr listvars2) tmp res)))) + +(defun equality-trans3 (listvars1 listvars2 tmp res) + (append + (rtm-eq-or (car listvars1) (car listvars2) tmp res) + (equality-trans2 (cdr listvars1) (cdr listvars2) tmp res))) + +(defun all-rtm-adds-for-n-steps (st n) + (declare (xargs :measure (acl2-count n))) + (if (zp n) + t + (and + (equal (opcode (nth (pcc st) (code st))) 'rtm-add) + (all-rtm-adds-for-n-steps (execute-instruction st) (1- n))))) + +(defun all-rtm-subs-for-n-steps (st n) + (declare (xargs :measure (acl2-count n))) + (if (zp n) + t + (and + (equal (opcode (nth (pcc st) (code st))) 'rtm-sub) + (all-rtm-subs-for-n-steps (execute-instruction st) (1- n))))) + + +(defun good-translation-gem-rtm (gstate rstate m) + (declare (xargs :measure (acl2-count (- (len (code gstate)) (pcc gstate))))) + (if + (or (not (integerp (pcc gstate))) + (< (pcc gstate) 0) + (>= (pcc gstate) (len (code gstate)))) + (>= (pcc rstate) (len (code rstate))) + (case (opcode (nth (pcc gstate) (code gstate))) + (gem-equ + (and + (in-range (pcc rstate) (code rstate)) + (equal (listinstr rstate (* 2 (len *rns*)) ) + (equality-trans3 + (eventually-make-list (rtmintvars-i (par2 (nth (pcc gstate) (code gstate))) m) (len *rns*)) + (eventually-make-list (rtmintvars-i (par3 (nth (pcc gstate) (code gstate))) m) (len *rns*)) + 'tmp + (car (rtmintvars-i (par1 (nth (pcc gstate) (code gstate))) m)))) + (not (equal + (par1 (nth (pcc gstate) (code gstate))) + (par2 (nth (pcc gstate) (code gstate))))) + (not (equal + (par1 (nth (pcc gstate) (code gstate))) + (par3 (nth (pcc gstate) (code gstate))))) + (good-translation-gem-rtm + (execute-instruction gstate ) + (execute-n-instructions rstate (* 2 (len *rns*)) ) + m))) + (gem-add + (and + (in-range (pcc rstate) (code rstate)) + (all-rtm-adds-for-n-steps rstate (len *rns*) ) + (equal (listpars1 rstate (len *rns*) ) + (rtmintvars-i (par1 (nth (pcc gstate) (code gstate))) m)) + (equal (listpars2 rstate (len *rns*) ) + (eventually-make-list (rtmintvars-i (par2 (nth (pcc gstate) (code gstate))) m) (len *rns*))) ;new + (equal (listpars3 rstate (len *rns*) ) + (eventually-make-list (rtmintvars-i (par3 (nth (pcc gstate) (code gstate))) m) (len *rns*))) ;new + (equal (listpars4 rstate (len *rns*) ) *rns*) + (good-translation-gem-rtm + (execute-instruction gstate ) + (execute-n-instructions rstate (len *rns*) ) + m))) + (gem-sub ;;;gem-add + (and + (in-range (pcc rstate) (code rstate)) + (all-rtm-subs-for-n-steps rstate (len *rns*) ) + (equal (listpars1 rstate (len *rns*) ) + (rtmintvars-i (par1 (nth (pcc gstate) (code gstate))) m)) + (equal (listpars2 rstate (len *rns*) ) + (eventually-make-list (rtmintvars-i (par2 (nth (pcc gstate) (code gstate))) m) (len *rns*))) ;new + (equal (listpars3 rstate (len *rns*) ) + (eventually-make-list (rtmintvars-i (par3 (nth (pcc gstate) (code gstate))) m) (len *rns*))) ;new + (equal (listpars4 rstate (len *rns*) ) *rns*) + (good-translation-gem-rtm + (execute-instruction gstate ) + (execute-n-instructions rstate (len *rns*) ) + m))) + (otherwise nil)))) + + + + + +(defun equal-get-cells (lcell mem1 mem2) + (if (endp lcell) + (null lcell) + (and + (equal (get-cell (car lcell) mem1) (get-cell (car lcell) mem2)) + (equal-get-cells (cdr lcell) mem1 mem2)))) + +(defthm equal-get-cells-implies-equal-parts-of-cells + (implies + (equal-get-cells lcell mem1 mem2) + (and + (equal + (var-attributes lcell mem1) + (var-attributes lcell mem2)) + (equal + (var-values lcell mem1) + (var-values lcell mem2))))) + + +(defthm equal-get-cells-implies-equal-values-and-attributes-still-works + (implies + (equal-get-cells lcell mem1 mem2) + (iff + (equal-values-and-attributes gemcell lcell mem1 type) + (equal-values-and-attributes gemcell lcell mem2 type)))) + + +(defun idx-different-cell (l mem1 mem2) + (cond + ( (endp l) 0) + ( (not (equal (get-cell (car l) mem1) (get-cell (car l) mem2))) 0 ) + (t (1+ (idx-different-cell (cdr l) mem1 mem2))))) + + + +(defthm if-bad-index-in-range-then-cells-must-be-different + (implies + (in-range (idx-different-cell l mem1 mem2) l) + (not (equal + (get-cell (nth (idx-different-cell l mem1 mem2) l) mem1) + (get-cell (nth (idx-different-cell l mem1 mem2) l) mem2)))) + :rule-classes :forward-chaining) + + +(defthm if-bad-index-not-in-range-then-every-equal + (implies (and (true-listp l) + (not (in-range (idx-different-cell l mem1 mem2) l))) + (equal-get-cells l mem1 mem2))) + + + + + + +(in-theory (enable gemvar-0 rtmintvars-0)) + +(defthm m-correspondent-values-implies-equal-values-and-attribus + (implies + (and + (true-listp m) + (m-correspondent-values-p m memgstate memrstate) + (assoc-equal gvar1 m)) + (equal-values-and-attributes + (get-cell gvar1 memgstate) + (rtmintvars-i gvar1 m) + memrstate + (type-i gvar1 m))) +:hints (("Goal" :in-theory (disable equal-values-and-attributes)))) + +(in-theory (disable gemvar-0 rtmintvars-0)) + + +(defun retrieve-rtmvars (m) + (if (endp m) + nil + (cons (cdr (car m)) + (retrieve-rtmvars (cdr m))))) + + +(defthm rtmintvars-i-is-pos-equal-0-of-retrieve-vars + (equal (rtmintvars-i gvar m) + (nth (pos-equal-0 gvar m) (retrieve-rtmvars m)))) + + +(defthm lemma-help2 + (implies + (true-listp m) + (equal (len m) (len (retrieve-rtmvars m)))) + :rule-classes nil) + +(defthm lemma-help3 + (implies + (true-listp m) + (iff (in-range idx m) (in-range idx (retrieve-rtmvars m)))) + :hints (("Goal" :use lemma-help2)) + :rule-classes nil) + +(defthm lemma-help4 + (implies + (and + (assoc-equal gvar1 m) + (not (equal gvar1 gvar2))) + (not (equal (pos-equal-0 gvar1 m) (pos-equal-0 gvar2 m))))) + +(defthm lemma1-different-vars-do-not-belong + (implies + (and + (true-listp m) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (assoc-equal gvar1 m) + (assoc-equal gvar2 m) + (not (equal gvar1 gvar2)) + (in-range idx1 (rtmintvars-i gvar1 m))) + (not (member-equal-bool (nth idx1 (rtmintvars-i gvar1 m)) + (rtmintvars-i gvar2 m)))) + :hints (("Goal" + :in-theory '((:type-prescription retrieve-rtmvars) + (:definition in-range) + (:rewrite in-range-is-member-eq-bool)) + :use ( + lemma-help4 + (:instance lemma-help3 (idx (pos-equal-0 gvar1 m))) + (:instance lemma-help3 (idx (pos-equal-0 gvar2 m))) + (:instance generalized-disjunctivity-unordered-2 + (el1 (nth idx1 (nth (pos-equal-0 gvar1 m) (retrieve-rtmvars m)))) + (ll (retrieve-rtmvars m)) + (idx1 (pos-equal-0 gvar1 m)) + (idx2 (pos-equal-0 gvar2 m))) + (:instance assoc-means-pos-in-range (el gvar1) (l m)) + (:instance assoc-means-pos-in-range (el gvar2) (l m)) + (:instance rtmintvars-i-is-pos-equal-0-of-retrieve-vars (gvar gvar1)) + (:instance rtmintvars-i-is-pos-equal-0-of-retrieve-vars (gvar gvar2)))))) + + +(defthm teorema-main-con-pcc-in-range-su-variabile-non-interessata + (implies + (and + (gem-statep gstate) + (rtm-statep rstate) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (not (equal gvar1 (par1 (nth (pcc gstate) (code gstate)))))) + (equal + (get-cell gvar1 (mem (execute-instruction gstate))) + (get-cell gvar1 (mem gstate)))) + :hints (("Goal" :use (:instance only-par1-is-involved (var gvar1))))) + + +(defun bad-idx-eqv-va (m gem-mem rtm-mem) + (cond + ( (endp m) + 0 ) + ( (not (equal-values-and-attributes + (get-cell (gemvar-0 m) gem-mem) + (rtmintvars-0 m) + rtm-mem + (type-0 m))) + 0 ) + (t (1+ (bad-idx-eqv-va (cdr m) gem-mem rtm-mem))))) + +(defthm if-bad-index-in-range-thne-must-be-different-mc + (implies + (in-range (bad-idx-eqv-va m gem-mem rtm-mem) m) + (not (m-correspondent-values-p m gem-mem rtm-mem))) + :hints (("Goal" :in-theory (enable gemvar-0)))) + +(defthm if-bad-index-in-range-thne-must-be-different-vs + (implies + (in-range (bad-idx-eqv-va m gem-mem rtm-mem) m) + (not + (equal-values-and-attributes + (get-cell (car (nth (bad-idx-eqv-va m gem-mem rtm-mem) m)) gem-mem) + (cdr (nth (bad-idx-eqv-va m gem-mem rtm-mem) m)) + rtm-mem + (type-i-idx m (bad-idx-eqv-va m gem-mem rtm-mem))))) + :hints (("Goal" :in-theory (e/d (type-0 gemvar-0 rtmintvars-0) + (var-attribute var-attributes apply-direct-rns-to-value-according-to-type + var-values-of-1-variable-is-one-element-list-of-var-value + var-values equal-values + ))))) + + +(defthm if-bad-index-not-in-range-then-m-corr + (implies + (and + (true-listp m) + (not (in-range (bad-idx-eqv-va m gem-mem rtm-mem) m))) + (m-correspondent-values-p m gem-mem rtm-mem)) + :hints (("Goal" :in-theory (e/d (gemvar-0) + ((:type-prescription retrieve-rtmvars) + retrieve-rtmvars))))) + +(defthm execute-n-instructions-keeps-rtm-state-and-points-to-good + (implies + (and + (rtm-statep st) + (m-entries-point-to-good-rtm-var-sets m (mem st))) + (and + (rtm-statep (execute-n-instructions st n)) + (m-entries-point-to-good-rtm-var-sets m (mem (execute-n-instructions st n))))) + :hints (("Goal" :induct (execute-n-instructions st n) ) + ("Subgoal *1/2" + :in-theory '((:definition execute-n-instructions) + (:rewrite executing-rtm-instruction-keeps-m-pointing-to-rtm-var-sets) + (:rewrite executing-rtm-instruction-retrieves-a-rtm-state-from-rtm-state))))) + + +;;(ld "Proof-Of-Plus.lisp" :ld-error-action :error) + +(in-theory (enable + (:executable-counterpart build-values-by-rns) + (:type-prescription build-values-by-rns) + (:induction build-values-by-rns) + (:definition build-values-by-rns) + posp-all posp mod mod-+-exp mod-prod-makes-same-residues)) + +(in-theory (disable mod floor)) + +(defun sum-list (vl2 vl3 rns) + (if (endp vl2) + nil + (cons (mod (+ (car vl2) (car vl3)) (car rns)) + (sum-list (cdr vl2) (cdr vl3) (cdr rns))))) + +(defthm sum-correspondence-by-put-list + (implies + (and + (integerp gval1) + (integerp gval2) + (posp-all rns)) + (equal (build-values-by-rns (+ gval1 gval2) rns) + (sum-list + (build-values-by-rns gval1 rns) + (build-values-by-rns gval2 rns) + rns))) + :hints (("Goal" :induct t))) + + + + +(defthm sum-correspondence-by-put-list-2-fin + (implies + (and + (integerp gval1) + (integerp gval2) + (posp-all rns)) + (equal (build-values-by-rns (mod (+ gval1 gval2) (prod rns)) rns) + (sum-list + (build-values-by-rns gval1 rns) + (build-values-by-rns gval2 rns) + rns)))) + +(in-theory (disable mod-prod-makes-same-residues)) + + + +(in-theory (disable mod floor mod-+-exp mod-prod-makes-same-residues)) + + + + + + + +(defthm sum-correspondence-by-put-list-h + (implies + (and + (integerp gval1) + (integerp gval2) + (integer>1-listp rns)) + (equal (build-values-by-rns (mod (+ gval1 gval2) (prod rns)) rns) + (sum-list + (build-values-by-rns gval1 rns) + (build-values-by-rns gval2 rns) + rns))) + :hints (("Goal" :use (sum-correspondence-by-put-list-2-fin greater-one-means-greater-zero)))) + + + +(defthm a-boolean-has-same-rnss-than-list-of-itself + (implies + (and + (integerp val) + (or (equal val 0) (equal val 1)) + (integer>1-listp rns)) + (equal + (build-values-by-rns val rns) + (make-n-list val (len rns)))) + :hints (("Goal" :in-theory (enable mod-x-y-=-x-exp)))) + + + + +(defthm sum-correspondence-by-put-list-on-boolean + (implies + (and + (integerp gval1) + (integerp gval2) + (or (equal gval2 0) (equal gval2 1)) + (integer>1-listp rns)) + (equal (build-values-by-rns (mod (+ gval1 gval2) (prod rns)) rns) + (sum-list + (build-values-by-rns gval1 rns) + (make-n-list gval2 (len rns)) + rns))) + :hints (("Goal" :in-theory nil + :use (sum-correspondence-by-put-list-h + (:instance a-boolean-has-same-rnss-than-list-of-itself (val gval2)))))) + + + +(defun equal-sum-and-updates (reslist par1list par2list par3list primelist mem memafterputs) + (if (endp reslist) + (null reslist) + (and + (equal + (get-cell (car reslist) memafterputs) + (sum-and-update + (car par1list) + (car par2list) + (car par3list) + (car primelist) + mem)) + (equal-sum-and-updates + (cdr reslist) + (cdr par1list) + (cdr par2list) + (cdr par3list) + (cdr primelist) + mem + memafterputs)))) + + + + + +(defthm equal-sum-and-updates-have-same-attributes + (implies + (and + (true-listp rtmvars1) + (true-listp rtmvarsres) + (equal (len rtmvars1) (len rtmvarsres)) + (equal-sum-and-updates rtmvarsres rtmvars1 rtmvars2 rtmvars3 rns rtmmem rtmmemafter)) + (equal (var-attributes rtmvarsres rtmmemafter) (var-attributes rtmvars1 rtmmem)))) + +(in-theory (enable sum-list)) + +(defthm equal-sum-and-updates-have-values-that-are-sum-lists + (implies + (and + (equal (len rtmvars1) (len rtmvarsres)) + (equal (len rtmvars2) (len rtmvarsres)) + (equal (len rtmvars3) (len rtmvarsres)) + (equal-sum-and-updates rtmvarsres rtmvars1 rtmvars2 rtmvars3 rns rtmmem rtmmemafter)) + (equal (var-values rtmvarsres rtmmemafter) + (sum-list + (var-values rtmvars2 rtmmem) + (var-values rtmvars3 rtmmem) + rns))) + :hints ( ("Subgoal *1/2" :in-theory (enable var-value get-cell make-cell)))) + + + + + +(defthm behaviour-of-sum-and-update-norest + (and + (equal + (var-attribute (sum-and-update-norest c1 c2 c3 mem)) + (var-attribute (get-cell c1 mem))) + (equal + (var-value (sum-and-update-norest c1 c2 c3 mem)) + (mod + (+ + (var-value (get-cell c2 mem)) + (var-value (get-cell c3 mem))) + (prod *rns*))) + (equal + (var-type (sum-and-update-norest c1 c2 c3 mem)) + (var-type (get-cell c1 mem)))) + :hints (("Goal" :in-theory (enable var-type var-value var-attribute make-cell)))) + + + + +(defthm defexpansion + (implies + (not (null (var-value gcell))) + (equal + (equal-values-and-attributes gcell rtmvars rtmmem 'Int) + (and + (equal-values (var-values rtmvars rtmmem) + (build-values-by-rns (var-value gcell) *rns*)) + (equal-elements (var-attribute gcell) + (var-attributes rtmvars rtmmem))))) + :hints (("Goal" :in-theory '((:definition equal-values-and-attributes) + (:definition apply-direct-rns-to-value-according-to-type)) + :use (:instance build-values-by-rns-extended-behaves-standardly-on-non-nils + (gem-value (var-value gcell)) + (rns *rns*))))) + + +(defthm if-gem-is-sum-and-update-inf-every-rtm-var-is-sum-and-update-then-equal-values-is-kept + (implies + (and + (true-listp rtmvars1) + (true-listp rtmvarsres) + (equal (len rtmvars1) (len rtmvarsres)) + (equal (len rtmvars2) (len rtmvarsres)) + (equal (len rtmvars3) (len rtmvarsres)) + (not (null (var-value (get-cell gvar1 gemmem)))) + (integerp (var-value (get-cell gvar2 gemmem))) + (integerp (var-value (get-cell gvar3 gemmem))) + (equal-sum-and-updates rtmvarsres rtmvars1 rtmvars2 rtmvars3 *rns* rtmmem rtmmemafter) + (equal-values-and-attributes (get-cell gvar1 gemmem) rtmvars1 rtmmem 'Int) + (equal-values-and-attributes (get-cell gvar2 gemmem) rtmvars2 rtmmem 'Int) + (equal-values-and-attributes (get-cell gvar3 gemmem) rtmvars3 rtmmem 'Int)) + (equal-values-and-attributes + (sum-and-update-norest gvar1 gvar2 gvar3 gemmem) + rtmvarsres + rtmmemafter + 'Int)) + :hints (("Goal" + :in-theory (union-theories (current-theory 'ground-zero) + '( + (:definition integer>1-listp) + (:definition equal-values) + (:rewrite defexpansion))) + :use ( + (:instance greater-one-means-greater-zero (rns *rns*)) + (:instance equal-sum-and-updates-have-values-that-are-sum-lists (rns *rns*)) + (:instance equal-sum-and-updates-have-same-attributes (rns *rns*)) + (:instance sum-correspondence-by-put-list-h + (gval1 (var-value (get-cell gvar2 gemmem))) + (gval2 (var-value (get-cell gvar3 gemmem))) + (rns *rns*)) + (:instance behaviour-of-sum-and-update-norest + (c1 gvar1) + (c2 gvar2) + (c3 gvar3) + (mem gemmem))))) + ) + + + + + + + +(defthm if-a-var-value-is-same-then-var-values-are-list-of + (implies + (equal (var-value (get-cell (car rtmvars) rtmmem)) (var-value gcell)) + (equal-values (var-values (make-n-list (car rtmvars) (len rns)) rtmmem) + (make-n-list (var-value gcell) (len rns))))) + +(defthm if-a-var-attribute-is-same-then-var-attributes-are-list-of + (implies + (equal (var-attribute (get-cell (car rtmvars) rtmmem)) (var-attribute gcell)) + (equal-elements + (var-attribute gcell) + (var-attributes (make-n-list (car rtmvars) (len rns)) rtmmem)))) + + + +(defthm defexpansion-bool-values + (implies + (or (equal (var-value gcell) 0) + (equal (var-value gcell) 1)) + (implies + (equal-values-and-attributes gcell rtmvars rtmmem 'Bool) + (equal-values (var-values (make-n-list (car rtmvars) (len *rns*)) rtmmem) + (build-values-by-rns (var-value gcell) *rns*)))) + :hints (("Goal" :use ( (:instance if-a-var-value-is-same-then-var-values-are-list-of + (rns *rns*)))))) + + + + +(defthm equal-values-on-list-entails-equality-on-first-els + (implies + (and + (integerp n) + (> n 0) + (equal-values (var-values (make-n-list el n) mem) + (make-n-list val n))) + (equal-values (var-values (list el) mem) + (list val))) + :hints (("Subgoal *1/3'" :use ( (:instance make-n-list (el el) (n 1)) + (:instance make-n-list (el val) (n 1)) )))) + + +(defthm cell-types + (implies + (is-mem-cell-p gcell) + (or + (equal (var-type gcell) 'Bool) + (equal (var-type gcell) 'Int))) + :hints (("Goal" :in-theory (enable my-or-2))) + :rule-classes nil) + +(defthm bool-cell + (implies + (and + (is-mem-cell-p gcell) + (equal (var-type gcell) 'Bool)) + (and + (integerp (var-value gcell)) + (or (equal (var-value gcell) 0) + (equal (var-value gcell) 1)))) + :rule-classes nil) + +(defthm int-cell + (implies + (and + (is-mem-cell-p gcell) + (equal (var-type gcell) 'Int)) + (integerp (var-value gcell))) + :rule-classes nil) + + +(defthm defexpansion-bool-values-inv + (implies + (and + (is-mem-cell-p gcell) + (equal (var-type gcell) 'Bool) + (equal (type-expected rtmvars) (var-type gcell))) + (implies + (equal-values (var-values (eventually-make-list rtmvars (len *rns*)) rtmmem) + (build-values-by-rns (var-value gcell) *rns*)) + (equal-values + (var-values rtmvars rtmmem) + (apply-direct-rns-to-value-according-to-type gcell (var-type gcell))))) + :hints (("Goal" :use (bool-cell + (:instance equal-values-on-list-entails-equality-on-first-els + (mem rtmmem) + (n (len *rns*)) + (el (car rtmvars)) + (val (var-value gcell))) + (:instance a-boolean-has-same-rnss-than-list-of-itself + (val (var-value gcell)) (rns *rns*)))))) + + + + +(defthm defexpansion-bool-attrs-1 + (implies + (equal-values-and-attributes gcell rtmvars rtmmem 'Bool) + (equal (var-attribute (get-cell (car rtmvars) rtmmem)) (var-attribute gcell)))) + + +(defthm defexpansion-bool-attrs + (implies + (equal-values-and-attributes gcell rtmvars rtmmem 'Bool) + (equal-elements + (var-attribute gcell) + (var-attributes (make-n-list (car rtmvars) (len *rns*)) rtmmem))) + :hints (("Goal" :use ( defexpansion-bool-attrs-1 + (:instance if-a-var-attribute-is-same-then-var-attributes-are-list-of + (rns *rns*)))))) + + +(defthm defexpansion-bool-attrs-inv-1 + (implies + (equal (type-expected rtmvars) 'Bool) + (equal + (var-attributes rtmvars rtmmem) + (list (var-attribute (get-cell (car rtmvars) rtmmem))))) + :hints (("Subgoal 1'" :use (:theorem (implies + (and (true-listp rtmvars2) + (equal (+ 1 (len rtmvars2)) 1)) + (endp rtmvars2))))) + :otf-flg t) + +(defthm defexpansion-bool-attrs-inv-2 + (implies + (and + (equal (type-expected rtmvars) 'Bool) + (equal val (var-attribute (get-cell (car rtmvars) rtmmem)))) + (equal-elements val (var-attributes rtmvars rtmmem)))) + + +(defthm defexpansion-bool-attrs-inv-3 + (implies + (and + (integerp n) + (> n 0)) + (implies + (equal-elements + val + (var-attributes (make-n-list car-rtmvars n) rtmmem)) + (equal + val + (var-attribute (get-cell car-rtmvars rtmmem))))) + :hints (("Subgoal *1/3'" :use (:instance make-n-list (el car-rtmvars) (n 1)))) + :rule-classes nil) + + +(defthm defexpansion-bool-attrs-inv + (implies + (and + (equal (var-type gcell) 'Bool) + (equal (type-expected rtmvars) (var-type gcell))) + (implies + (equal-elements + (var-attribute gcell) + (var-attributes (make-n-list (car rtmvars) (len *rns*)) rtmmem)) + (equal-elements + (var-attribute gcell) + (var-attributes rtmvars rtmmem)))) + :hints (("Goal" :use + ( defexpansion-bool-attrs-inv-1 + defexpansion-bool-attrs-inv-2 + (:instance defexpansion-bool-attrs-inv-3 + (n (len *rns*)) + (car-rtmvars (car rtmvars)) + (val (var-attribute gcell))))))) + +(defthm defexpansion-bool + (implies + (and + (is-mem-cell-p gcell) + (equal (var-type gcell) 'Bool) + (equal (type-expected rtmvars) (var-type gcell))) + (equal + (equal-values-and-attributes gcell rtmvars rtmmem 'Bool) + (and + (equal-values (var-values (make-n-list (car rtmvars) (len *rns*)) rtmmem) + (build-values-by-rns (var-value gcell) *rns*)) + (equal-elements + (var-attribute gcell) + (var-attributes (make-n-list (car rtmvars) (len *rns*)) rtmmem))))) + :hints (("Goal" :use + ( bool-cell + defexpansion-bool-attrs + defexpansion-bool-values + defexpansion-bool-attrs-inv + defexpansion-bool-values-inv)))) + + + + + +(defthm defexpansion-generic-bool + (implies + (and + (is-mem-cell-p gcell) + (equal (var-type gcell) 'Bool) + (equal (type-expected rtmvars) (var-type gcell))) + (equal + (equal-values-and-attributes gcell rtmvars rtmmem (var-type gcell)) + (and + (equal-values (var-values (eventually-make-list rtmvars (len *rns*)) rtmmem) + (build-values-by-rns (var-value gcell) *rns*)) + (equal-elements (var-attribute gcell) + (var-attributes (eventually-make-list rtmvars (len *rns*)) rtmmem))))) + :hints (("Goal" :in-theory (union-theories (current-theory 'ground-zero) + '((:definition type-expected) + (:definition eventually-make-list))) + :use (defexpansion-bool bool-cell)))) + +(defthm defexpansion-generic-int + (implies + (and + (is-mem-cell-p gcell) + (equal (var-type gcell) 'Int) + (equal (type-expected rtmvars) (var-type gcell))) + (equal + (equal-values-and-attributes gcell rtmvars rtmmem (var-type gcell)) + (and + (equal-values (var-values (eventually-make-list rtmvars (len *rns*)) rtmmem) + (build-values-by-rns (var-value gcell) *rns*)) + (equal-elements (var-attribute gcell) + (var-attributes (eventually-make-list rtmvars (len *rns*)) rtmmem))))) + :hints (("Goal" :in-theory (union-theories (current-theory 'ground-zero) + '((:definition type-expected) + (:definition eventually-make-list))) + :use (defexpansion int-cell)))) + + + + +(defthm defexpansion-generic + (implies + (and + (is-mem-cell-p gcell) + (equal (type-expected rtmvars) (var-type gcell))) + (equal + (equal-values-and-attributes gcell rtmvars rtmmem (var-type gcell)) + (and + (equal-values (var-values (eventually-make-list rtmvars (len *rns*)) rtmmem) + (build-values-by-rns (var-value gcell) *rns*)) + (equal-elements (var-attribute gcell) + (var-attributes (eventually-make-list rtmvars (len *rns*)) rtmmem))))) + :hints (("Goal" + :cases ( (equal (var-type gcell) 'Bool) + (equal (var-type gcell) 'Int) )) + ("Subgoal 3" :use cell-types) + ("Subgoal 2" :use defexpansion-generic-bool) + ("Subgoal 1" :use defexpansion-generic-int))) + + + + + + +(defthm if-gem-is-sum-and-update-inf-every-rtm-var-is-sum-and-update-then-equal-values-is-kept-g + (implies + (and + (true-listp rtmvars1) + (true-listp rtmvarsres) + (equal (len rtmvars1) (len rtmvarsres)) + (equal (len (eventually-make-list rtmvars2 (len *rns*))) (len rtmvarsres)) + (equal (len (eventually-make-list rtmvars3 (len *rns*))) (len rtmvarsres)) + (equal (var-type (get-cell gvar2 gemmem)) (type-expected rtmvars2)) + (equal (var-type (get-cell gvar3 gemmem)) (type-expected rtmvars3)) + (is-mem-cell-p (get-cell gvar1 gemmem)) + (equal (var-type (get-cell gvar1 gemmem)) 'Int) + (is-mem-cell-p (get-cell gvar2 gemmem)) + (is-mem-cell-p (get-cell gvar3 gemmem)) + (equal-sum-and-updates + rtmvarsres + rtmvars1 + (eventually-make-list rtmvars2 (len *rns*)) + (eventually-make-list rtmvars3 (len *rns*)) + *rns* rtmmem rtmmemafter) + (equal-values-and-attributes (get-cell gvar1 gemmem) rtmvars1 rtmmem 'Int) + (equal-values-and-attributes (get-cell gvar2 gemmem) rtmvars2 rtmmem (var-type (get-cell gvar2 gemmem))) + (equal-values-and-attributes (get-cell gvar3 gemmem) rtmvars3 rtmmem (var-type (get-cell gvar3 gemmem)))) + (equal-values-and-attributes + (sum-and-update-norest gvar1 gvar2 gvar3 gemmem) + rtmvarsres + rtmmemafter + 'Int)) + :hints (("Goal" + :in-theory (union-theories (current-theory 'ground-zero) + '((:definition integer>1-listp) + (:definition equal-values) + (:definition is-mem-cell-p) + (:rewrite defexpansion))) + :use ( + (:instance defexpansion-generic + (gcell (get-cell gvar2 gemmem)) + (rtmvars rtmvars2)) + (:instance defexpansion-generic + (gcell (get-cell gvar3 gemmem)) + (rtmvars rtmvars3)) + (:instance equal-sum-and-updates-have-values-that-are-sum-lists + (rtmvars2 (eventually-make-list rtmvars2 (len *rns*))) + (rtmvars3 (eventually-make-list rtmvars3 (len *rns*))) + (rns *rns*)) + (:instance equal-sum-and-updates-have-same-attributes + (rtmvars2 (eventually-make-list rtmvars2 (len *rns*))) + (rtmvars3 (eventually-make-list rtmvars3 (len *rns*))) + (rns *rns*)) + (:instance sum-correspondence-by-put-list-h + (gval1 (var-value (get-cell gvar2 gemmem))) + (gval2 (var-value (get-cell gvar3 gemmem))) + (rns *rns*)) + (:instance behaviour-of-sum-and-update-norest + (c1 gvar1) + (c2 gvar2) + (c3 gvar3) + (mem gemmem)))))) + + + + + +(in-theory (disable sum-list sum-correspondence-by-put-list + equal-sum-and-updates-have-same-attributes + equal-sum-and-updates-have-values-that-are-sum-lists + behaviour-of-sum-and-update-norest + defexpansion + if-a-var-value-is-same-then-var-values-are-list-of + if-a-var-attribute-is-same-then-var-attributes-are-list-of + defexpansion-generic-bool + defexpansion-generic-int + defexpansion-generic + defexpansion-bool-values-inv + defexpansion-bool-values + defexpansion-bool-attrs-inv + defexpansion-bool-attrs-inv-1 + defexpansion-bool-attrs-inv-2 + defexpansion-bool-attrs + defexpansion-bool-attrs-1 + equal-values-on-list-entails-equality-on-first-els + )) + + + + + +(defun execute-n-rtm-adds (st n) + (if + (zp n) + st + (execute-n-rtm-adds + (rtm-add + (par1 (nth (pcc st) (code st))) + (par2 (nth (pcc st) (code st))) + (par3 (nth (pcc st) (code st))) + (par4 (nth (pcc st) (code st))) + st) + (1- n)))) + + +(defthm all-rtm-adds-means-only-adds-are-executed + (implies + (all-rtm-adds-for-n-steps st n) + (equal + (execute-n-rtm-adds st n) + (execute-n-instructions st n))) + :hints (("Goal" :in-theory (disable rtm-add member-equal nth par1 par2 par3)))) + + +(defun adds-list-n (l1 l2 l3 l4 mem n) + (if (zp n) + mem + (adds-list-n (cdr l1) (cdr l2) (cdr l3) (cdr l4) + (put-cell + (car l1) + (sum-and-update + (car l1) + (car l2) + (car l3) + (car l4) + mem) + mem) + (1- n)))) + + + + + + + +(in-theory (disable member-equal)) + + +(in-theory (enable make-cell)) + + + +(defthm execute-n-rtm-adds-tantamount-to-add-list-n + (implies + (and + (all-rtm-adds-for-n-steps st n) + (>= (pcc st) 0) + (rtm-statep st)) + (equal + (mem (execute-n-rtm-adds st n)) + (adds-list-n + (listpars1 st n) + (listpars2 st n) + (listpars3 st n) + (listpars4 st n) + (mem st) + n))) + :hints + (("Goal" :induct t ) + ("Subgoal *1/2.2" :in-theory '((:definition all-rtm-adds-for-n-steps) + (:definition execute-instruction) + (:definition rtm-add) + (:definition make-state) + (:definition mem)) + ) + ("Subgoal *1/2" + :use ( execute-n-rtm-adds + (:instance adds-list-n + (l1 (listpars1 st n)) + (l2 (listpars2 st n)) + (l3 (listpars3 st n)) + (l4 (listpars4 st n)) + (mem (mem st))) + lemma12-lp1r lemma12-lp2r lemma12-lp3r lemma12-lp4r + (:theorem + (IMPLIES (AND (ALL-RTM-ADDS-FOR-N-STEPS ST N) + (>= (pcc st) 0) + (not (zp n))) + (equal (mem (execute-instruction st)) + (PUT-CELL (CAR (LISTPARS1 ST N)) + (SUM-AND-UPDATE (CAR (LISTPARS1 ST N)) + (CAR (LISTPARS2 ST N)) + (CAR (LISTPARS3 ST N)) + (CAR (LISTPARS4 ST N)) + (MEM ST)) + (MEM ST))))) + executing-rtm-instruction-retrieves-a-rtm-state-from-rtm-state + instruction-incrementing-pvv)))) + + +(in-theory (disable lemma12-lp1r lemma12-lp2r lemma12-lp3r lemma12-lp4r )) + + + + + + + + + + +(defun adds-list-e (c1 c2 c3 c4 mem) + (if + (endp c1) + mem + (adds-list-e + (cdr c1) + (cdr c2) + (cdr c3) + (cdr c4) + (put-cell (car c1) (sum-and-update (car c1) (car c2) (car c3) (car c4) mem) mem)))) + + + +(defthm adds-list-e-is-adds-list-n + (equal (adds-list-e c1 c2 c3 c4 mem) (adds-list-n c1 c2 c3 c4 mem (len c1))) + :rule-classes nil) + + + +(defthm execute-n-instructions-tantamount-to-add-list-e + (implies + (and + (integerp n) + (>= n 0) + (all-rtm-adds-for-n-steps st n) + (>= (pcc st) 0) + (rtm-statep st)) + (equal + (mem (execute-n-instructions st n)) + (adds-list-e + (listpars1 st n) + (listpars2 st n) + (listpars3 st n) + (listpars4 st n) + (mem st)))) + :hints (("Goal" :in-theory nil + :use ((:instance adds-list-e-is-adds-list-n + (c1 (listpars1 st n)) + (c2 (listpars2 st n)) + (c3 (listpars3 st n)) + (c4 (listpars4 st n)) + (mem (mem st))) + execute-n-rtm-adds-tantamount-to-add-list-n + all-rtm-adds-means-only-adds-are-executed + length-of-listpars1-n-is-n)))) + + + + + + + + + + +(defthm not-in-list-untouched-by-adds-list-e + (implies + (not (member-equal-bool v l1)) + (equal (get-cell v (adds-list-e l1 l2 l3 l4 mem)) (get-cell v mem))) + :hints (("Goal" :in-theory (disable sum-and-update)))) + +(defthm not-in-list-untouched-by-adds-list-e-1 + (implies + (not (member-equal-bool (car l1) (cdr l1))) + (equal (get-cell (car l1) (adds-list-e (cdr l1) (cdr l2) (cdr l3) (cdr l4) mem)) + (get-cell (car l1) mem)))) + + +(defthm sum-and-update-independent-from-firstbn + (implies + (and + (not (member-equal-bool (nth idx l1) (firstn idx l1))) + (not (member-equal-bool (nth idx l2) (firstn idx l1))) + (not (member-equal-bool (nth idx l3) (firstn idx l1)))) + (equal (sum-and-update + (nth idx l1) + (nth idx l2) + (nth idx l3) + (nth idx l4) + (adds-list-e (firstn idx l1) (firstn idx l2) (firstn idx l3) (firstn idx l4) mem)) + (sum-and-update + (nth idx l1) + (nth idx l2) + (nth idx l3) + (nth idx l4) + mem)))) + + + +(defthm adds-list-decomp + (implies + (and + (in-range idx l1) + (in-range idx l2) + (in-range idx l3) + (in-range idx l4)) + (equal + (adds-list-e l1 l2 l3 l4 mem) + (adds-list-e (nthcdr idx l1) (nthcdr idx l2) (nthcdr idx l3) (nthcdr idx l4) + (adds-list-e (firstn idx l1) (firstn idx l2) (firstn idx l3) (firstn idx l4) mem)))) + :hints (("Goal" :in-theory (disable sum-and-update)))) + + +(defthm if-el-does-not-appear-after-its-position-then-adds-list-e-produces-its-sum + (implies + (and + (not (member-equal-bool (nth idx l1) (cdr (nthcdr idx l1)))) + (in-range idx l1) + (in-range idx l2) + (in-range idx l3) + (in-range idx l4)) + (equal + (get-cell (nth idx l1) (adds-list-e l1 l2 l3 l4 mem)) + (sum-and-update + (nth idx l1) + (nth idx l2) + (nth idx l3) + (nth idx l4) + (adds-list-e (firstn idx l1) (firstn idx l2) (firstn idx l3) (firstn idx l4) mem)))) + :hints (("Goal" :in-theory (disable sum-and-update)))) + + + + +(defthm rtm-variable-of-adds-list-e-is-sum-of-correspondent-variables + (implies + (and + (positive-list rns) + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (in-range gem1 ll) + (in-range gem2 ll) + (in-range gem3 ll) + (in-range idx (nth gem1 ll)) + (in-range idx (nth gem2 ll)) + (in-range idx (nth gem3 ll)) + (in-range idx rns)) + (equal + (get-cell (nth idx (nth gem1 ll)) (adds-list-e (nth gem1 ll) (nth gem2 ll) (nth gem3 ll) rns mem)) + (sum-and-update (nth idx (nth gem1 ll)) (nth idx (nth gem2 ll)) (nth idx (nth gem3 ll)) (nth idx rns) mem))) + :hints (("Goal" :in-theory (disable sum-and-update) + :use ( + (:instance no-duplicates-all-implies-no-duplicates-one (idx1 gem1)) + (:instance no-duplicates-means-an-element-does-not-appear-after-its-position (l (nth gem1 ll))) + if-el-does-not-appear-after-its-position-then-adds-list-e-produces-its-sum + (:instance adds-list-decomp + (l1 (nth gem1 ll)) (l2 (nth gem2 ll)) (l3 (nth gem3 ll))) + (:instance sum-and-update-independent-from-firstbn + (l1 (nth gem1 ll)) (l2 (nth gem2 ll)) (l3 (nth gem3 ll))))))) + + + +(defun index-different-sum-and-updates (rtmvarsres rtmvars1 rtmvars2 rtmvars3 rns mem mem-after-add) + (cond + ( (endp rtmvarsres) + 0 ) + ( (not (equal (get-cell (car rtmvarsres) mem-after-add) + (sum-and-update (car rtmvars1) (car rtmvars2) (car rtmvars3) (car rns) mem))) + 0 ) + ( t + (1+ (index-different-sum-and-updates + (cdr rtmvarsres) + (cdr rtmvars1) + (cdr rtmvars2) + (cdr rtmvars3) + (cdr rns) + mem + mem-after-add))))) + +(defthm if-bad-index-in-range-thne-must-be-nonsumandupdate + (let ((bad-idx (index-different-sum-and-updates rtmvarsres rtmvars1 rtmvars2 rtmvars3 rns mem mem-after-add))) + (implies + (in-range bad-idx rtmvarsres) + (not (equal + (get-cell (nth bad-idx rtmvarsres) mem-after-add) + (sum-and-update + (nth bad-idx rtmvars1) + (nth bad-idx rtmvars2) + (nth bad-idx rtmvars3) + (nth bad-idx rns) + mem))))) + :hints (("Goal" :in-theory (disable get-cell sum-and-update)))) + + +(defthm if-bad-index-not-in-range-then-every-equalsumandupdate + (let ((bad-idx (index-different-sum-and-updates rtmvarsres rtmvars1 rtmvars2 rtmvars3 rns mem mem-after-add))) + (implies (and (true-listp rtmvarsres) + (not (in-range bad-idx rtmvarsres))) + (equal-sum-and-updates rtmvarsres rtmvars1 rtmvars2 rtmvars3 rns mem mem-after-add)))) + + +(defthm rtm-variable-of-adds-list-e-is-sum-and-updates + (implies + (and + (positive-list rns) + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (equal (len (nth gem1 ll)) (len (nth gem2 ll))) + (equal (len (nth gem1 ll)) (len (nth gem3 ll))) + (equal (len (nth gem1 ll)) (len rns)) + (in-range gem1 ll) + (in-range gem2 ll) + (in-range gem3 ll) + (true-listp (nth gem1 ll))) + (equal-sum-and-updates (nth gem1 ll) (nth gem1 ll) (nth gem2 ll) (nth gem3 ll) rns mem + (adds-list-e (nth gem1 ll) (nth gem2 ll) (nth gem3 ll) rns mem))) + :hints (("Goal" :use (:instance rtm-variable-of-adds-list-e-is-sum-of-correspondent-variables + (idx (index-different-sum-and-updates + (nth gem1 ll) + (nth gem1 ll) + (nth gem2 ll) + (nth gem3 ll) + rns + mem + (adds-list-e (nth gem1 ll) (nth gem2 ll) (nth gem3 ll) rns mem))))) + ("Goal'" :cases ( (in-range (index-different-sum-and-updates + (nth gem1 ll) + (nth gem1 ll) + (nth gem2 ll) + (nth gem3 ll) + rns + mem + (adds-list-e (nth gem1 ll) (nth gem2 ll) (nth gem3 ll) rns mem)) + (nth gem1 ll)) ) ) + ("Subgoal 1" :in-theory '((:definition in-range) + (:rewrite if-bad-index-in-range-thne-must-be-nonsumandupdate))) + ("Subgoal 2" :in-theory '((:rewrite if-bad-index-not-in-range-then-every-equalsumandupdate))))) + + + + +(defthm any-element-of-make-list-does-not-appear-into-other-lists + (implies + (and + (integerp n) + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (in-range gem1 ll) + (in-range gem2 ll) + (not (equal gem1 gem2)) + (equal (len (nth gem1 ll)) 1) + (in-range idx (make-n-list (car (nth gem1 ll)) n))) + (not (member-equal-bool + (nth idx (make-n-list (car (nth gem1 ll)) n)) + (nth gem2 ll)))) + :hints (("Goal" :use + ( + (:instance + el-of-makelist-is-el + (el (car (nth gem1 ll)))) + (:instance generalized-disjunctivity-unordered-2 + (idx1 gem1) (idx2 gem2) (el1 (car (nth gem1 ll))))))) + :otf-flg t) + +(defthm firstns-do-not-cotain-el-of-make-n-list-if-diff + (implies + (and + (integerp n) + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (in-range gem1 ll) + (in-range gem2 ll) + (not (equal gem1 gem2)) + (equal (len (nth gem1 ll)) 1) + (in-range idx (make-n-list (car (nth gem1 ll)) n))) + (not (member-equal-bool + (nth idx (make-n-list (car (nth gem1 ll)) n)) + (firstn idx (nth gem2 ll))))) + :hints (("Goal" :use + ( + (:instance no-member-holds-on-firstn + (el (nth idx (make-n-list (car (nth gem1 ll)) n))) + (l (nth gem2 ll))) + any-element-of-make-list-does-not-appear-into-other-lists)))) + + + +(defthm rtm-variable-of-adds-list-e-is-sum-of-correspondent-variables-when-var-3-is-boolean + (implies + (and + (integerp n) + (positive-list rns) + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (in-range gem1 ll) + (in-range gem2 ll) + (in-range gem3 ll) + (not (equal gem1 gem3)) + (equal (len (nth gem3 ll)) 1) + (in-range idx (nth gem1 ll)) + (in-range idx (nth gem2 ll)) + (in-range idx (make-n-list (car (nth gem3 ll)) n)) + (in-range idx rns)) + (equal + (get-cell (nth idx (nth gem1 ll)) + (adds-list-e + (nth gem1 ll) + (nth gem2 ll) + (make-n-list (car (nth gem3 ll)) n) + rns mem)) + (sum-and-update + (nth idx (nth gem1 ll)) + (nth idx (nth gem2 ll)) + (nth idx (make-n-list (car (nth gem3 ll)) n)) + (nth idx rns) mem))) + :hints (("Goal" :in-theory (disable sum-and-update) + :use ( + (:instance firstns-do-not-cotain-el-of-make-n-list-if-diff (gem1 gem3) (gem2 gem1)) + (:instance no-duplicates-all-implies-no-duplicates-one (idx1 gem1)) + (:instance no-duplicates-means-an-element-does-not-appear-after-its-position (l (nth gem1 ll))) + (:instance adds-list-decomp + (l1 (nth gem1 ll)) + (l2 (nth gem2 ll)) + (l3 (make-n-list (car (nth gem3 ll)) n)) + (l4 rns)) + (:instance sum-and-update-independent-from-firstbn + (l1 (nth gem1 ll)) + (l2 (nth gem2 ll)) + (l3 (make-n-list (car (nth gem3 ll)) n)) + (l4 rns)))))) + +(defthm rtm-variable-of-adds-list-e-is-sum-of-correspondent-variables-when-var-2-is-boolean + (implies + (and + (integerp n) + (positive-list rns) + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (in-range gem1 ll) + (in-range gem2 ll) + (in-range gem3 ll) + (not (equal gem1 gem2)) + (equal (len (nth gem2 ll)) 1) + (in-range idx (nth gem1 ll)) + (in-range idx (nth gem3 ll)) + (in-range idx (make-n-list (car (nth gem2 ll)) n)) + (in-range idx rns)) + (equal + (get-cell (nth idx (nth gem1 ll)) + (adds-list-e + (nth gem1 ll) + (make-n-list (car (nth gem2 ll)) n) + (nth gem3 ll) + rns mem)) + (sum-and-update + (nth idx (nth gem1 ll)) + (nth idx (make-n-list (car (nth gem2 ll)) n)) + (nth idx (nth gem3 ll)) + (nth idx rns) mem))) + :hints (("Goal" :in-theory (disable sum-and-update) + :use ( + (:instance firstns-do-not-cotain-el-of-make-n-list-if-diff (gem1 gem2) (gem2 gem1)) + (:instance no-duplicates-all-implies-no-duplicates-one (idx1 gem1)) + (:instance no-duplicates-means-an-element-does-not-appear-after-its-position (l (nth gem1 ll))) + (:instance adds-list-decomp + (l1 (nth gem1 ll)) + (l2 (make-n-list (car (nth gem2 ll)) n)) + (l3 (nth gem3 ll)) + (l4 rns)) + (:instance sum-and-update-independent-from-firstbn + (l1 (nth gem1 ll)) + (l2 (make-n-list (car (nth gem2 ll)) n)) + (l3 (nth gem3 ll)) + (l4 rns)))))) + +(defthm rtm-variable-of-adds-list-e-is-sum-of-correspondent-variables-when-var-2and3-are-boolean + (implies + (and + (integerp n) + (positive-list rns) + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (in-range gem1 ll) + (in-range gem2 ll) + (in-range gem3 ll) + (not (equal gem1 gem2)) + (not (equal gem1 gem3)) + (equal (len (nth gem2 ll)) 1) + (equal (len (nth gem3 ll)) 1) + (in-range idx (nth gem1 ll)) + (in-range idx (make-n-list (car (nth gem2 ll)) n)) + (in-range idx (make-n-list (car (nth gem3 ll)) n)) + (in-range idx rns)) + (equal + (get-cell (nth idx (nth gem1 ll)) + (adds-list-e + (nth gem1 ll) + (make-n-list (car (nth gem2 ll)) n) + (make-n-list (car (nth gem3 ll)) n) + rns mem)) + (sum-and-update + (nth idx (nth gem1 ll)) + (nth idx (make-n-list (car (nth gem2 ll)) n)) + (nth idx (make-n-list (car (nth gem3 ll)) n)) + (nth idx rns) mem))) + :hints (("Goal" :in-theory (disable sum-and-update) + :use ( + (:instance firstns-do-not-cotain-el-of-make-n-list-if-diff (gem1 gem2) (gem2 gem1)) + (:instance firstns-do-not-cotain-el-of-make-n-list-if-diff (gem1 gem3) (gem2 gem1)) + (:instance no-duplicates-all-implies-no-duplicates-one (idx1 gem1)) + (:instance no-duplicates-means-an-element-does-not-appear-after-its-position (l (nth gem1 ll))) + (:instance adds-list-decomp + (l1 (nth gem1 ll)) + (l2 (make-n-list (car (nth gem2 ll)) n)) + (l3 (make-n-list (car (nth gem3 ll)) n)) + (l4 rns)) + (:instance sum-and-update-independent-from-firstbn + (l1 (nth gem1 ll)) + (l2 (make-n-list (car (nth gem2 ll)) n)) + (l3 (make-n-list (car (nth gem3 ll)) n)) + (l4 rns)))))) + + + + +(defthm rtm-variable-of-adds-list-e-is-sum-of-correspondent-variables-with-all-vars-types + (implies + (and + (integerp n) + (positive-list rns) + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (in-range gem1 ll) + (in-range gem2 ll) + (in-range gem3 ll) + (not (equal (len (nth gem1 ll)) 1)) + (in-range idx (nth gem1 ll)) + (in-range idx (eventually-make-list (nth gem2 ll) n)) + (in-range idx (eventually-make-list (nth gem3 ll) n)) + (in-range idx rns)) + (equal + (get-cell (nth idx (nth gem1 ll)) + (adds-list-e + (nth gem1 ll) + (eventually-make-list (nth gem2 ll) n) + (eventually-make-list (nth gem3 ll) n) + rns mem)) + (sum-and-update + (nth idx (nth gem1 ll)) + (nth idx (eventually-make-list (nth gem2 ll) n)) + (nth idx (eventually-make-list (nth gem3 ll) n)) + (nth idx rns) mem))) + :hints (("Goal" :in-theory (union-theories (current-theory 'ground-zero) + '((:definition eventually-make-list))) + :cases + ( (and (not (equal (len (nth gem3 ll)) 1)) (equal (len (nth gem2 ll)) 1)) + (and (equal (len (nth gem3 ll)) 1) (not (equal (len (nth gem2 ll)) 1))) + (and (not (equal (len (nth gem3 ll)) 1)) (not (equal (len (nth gem2 ll)) 1))) + (and (equal (len (nth gem3 ll)) 1) (equal (len (nth gem2 ll)) 1)))) + ("Subgoal 4" + :use rtm-variable-of-adds-list-e-is-sum-of-correspondent-variables-when-var-2-is-boolean) + ("Subgoal 3" + :use rtm-variable-of-adds-list-e-is-sum-of-correspondent-variables-when-var-3-is-boolean) + ("Subgoal 2" + :use rtm-variable-of-adds-list-e-is-sum-of-correspondent-variables) + ("Subgoal 1" + :use rtm-variable-of-adds-list-e-is-sum-of-correspondent-variables-when-var-2and3-are-boolean))) + + + +(defthm sum-and-updates-holding-for-every-variable-type + (implies + (and + (integerp n) + (not (equal (len (nth gem1 ll)) 1)) + (positive-list rns) + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (equal (len (nth gem1 ll)) (len (eventually-make-list (nth gem2 ll) n))) + (equal (len (nth gem1 ll)) (len (eventually-make-list (nth gem3 ll) n))) + (equal (len (nth gem1 ll)) (len rns)) + (in-range gem1 ll) + (in-range gem2 ll) + (in-range gem3 ll) + (true-listp (nth gem1 ll))) + (equal-sum-and-updates + (nth gem1 ll) + (nth gem1 ll) + (eventually-make-list (nth gem2 ll) n) + (eventually-make-list (nth gem3 ll) n) + rns mem + (adds-list-e + (nth gem1 ll) + (eventually-make-list (nth gem2 ll) n) + (eventually-make-list (nth gem3 ll) n) + rns mem))) + :hints (("Goal" :use (:instance rtm-variable-of-adds-list-e-is-sum-of-correspondent-variables-with-all-vars-types + (idx (index-different-sum-and-updates + (nth gem1 ll) + (nth gem1 ll) + (eventually-make-list (nth gem2 ll) n) + (eventually-make-list (nth gem3 ll) n) + rns + mem + (adds-list-e + (nth gem1 ll) + (eventually-make-list (nth gem2 ll) n) + (eventually-make-list (nth gem3 ll) n) + rns mem))))) + ("Goal'" :cases ( (in-range (index-different-sum-and-updates + (nth gem1 ll) + (nth gem1 ll) + (eventually-make-list (nth gem2 ll) n) + (eventually-make-list (nth gem3 ll) n) + rns + mem + (adds-list-e + (nth gem1 ll) + (eventually-make-list (nth gem2 ll) n) + (eventually-make-list (nth gem3 ll) n) + rns mem)) + (nth gem1 ll)) ) ) + ("Subgoal 1" :in-theory '((:definition in-range) + (:rewrite if-bad-index-in-range-thne-must-be-nonsumandupdate))) + ("Subgoal 2" :in-theory '((:rewrite if-bad-index-not-in-range-then-every-equalsumandupdate))))) + + + +(defthm lemma2-only-adds-in-rtm-add + (implies + (and + (gem-statep gstate) + (rtm-statep rstate) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-add) + (good-translation-gem-rtm gstate rstate m)) + (all-rtm-adds-for-n-steps rstate (len *rns*))) + :hints (("Goal" :expand + ( (good-translation-gem-rtm gstate rstate m) + (gem-statep gstate) + (rtm-statep rstate) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate))) + :in-theory nil)) + :rule-classes nil) + + +(defthm cells-untouched-by-execute-on-other-cell-add + (implies + (and + (integerp n) + (>= n 0) + (all-rtm-adds-for-n-steps st n) + (>= (pcc st) 0) + (rtm-statep st) + (not (member-equal-bool v (listpars1 st n)))) + (equal (get-cell v (mem st)) + (get-cell v (mem (execute-n-instructions st n))))) + :hints (("Goal" + :use (execute-n-instructions-tantamount-to-add-list-e + (:instance not-in-list-untouched-by-adds-list-e + (v v) + (l1 (listpars1 st n)) + (l2 (listpars2 st n)) + (l3 (listpars3 st n)) + (l4 (listpars4 st n)) + (mem (mem st))))))) + + +(defthm rtm-variable-of-other-cell-untouched-add + (implies + (and + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-add) + (>= (pcc rstate) 0) + (rtm-statep rstate) + (good-translation-gem-rtm gstate rstate m) + (in-range (pcc gstate) (code gstate)) + (assoc-equal (par1 (nth (pcc gstate) (code gstate))) m) + (true-listp m) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (assoc-equal gvar1 m) + (not (equal gvar1 (par1 (nth (pcc gstate) (code gstate))))) + (in-range idx1 (rtmintvars-i gvar1 m))) + (equal (get-cell (nth idx1 (rtmintvars-i gvar1 m)) (mem rstate)) + (get-cell (nth idx1 (rtmintvars-i gvar1 m)) (mem (execute-n-instructions rstate (len *rns*)))))) + :hints (("Goal" :in-theory (current-theory 'ground-zero) + :expand ( (in-range (pcc gstate) (code gstate)) + (good-translation-gem-rtm gstate rstate m) ) + :use ( + (:instance lemma1-different-vars-do-not-belong (gvar2 (par1 (nth (pcc gstate) (code gstate))))) + (:instance cells-untouched-by-execute-on-other-cell-add (st rstate) (n (len *rns*)) + (v (nth idx1 (rtmintvars-i gvar1 m)))))))) + +(defthm rtm-variables-of-other-cell-untouched-add + (implies + (and + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-add) + (>= (pcc rstate) 0) + (rtm-statep rstate) + (good-translation-gem-rtm gstate rstate m) + (in-range (pcc gstate) (code gstate)) + (assoc-equal (par1 (nth (pcc gstate) (code gstate))) m) + (true-listp m) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (assoc-equal gvar1 m) + (true-listp (rtmintvars-i gvar1 m)) + (not (equal gvar1 (par1 (nth (pcc gstate) (code gstate)))))) + (equal-get-cells + (rtmintvars-i gvar1 m) (mem rstate) (mem (execute-n-instructions rstate (len *rns*))))) + :hints (("Goal" :in-theory nil + :use ( (:instance rtm-variable-of-other-cell-untouched-add + (idx1 (idx-different-cell + (rtmintvars-i gvar1 m) + (mem rstate) + (mem (execute-n-instructions rstate (len *rns*)))))) )) + ("Goal'" :cases ( (in-range + (idx-different-cell + (rtmintvars-i gvar1 m) + (mem rstate) + (mem (execute-n-instructions rstate (len *rns*)))) + (rtmintvars-i gvar1 m)))) + ("Subgoal 2" :in-theory '((:rewrite if-bad-index-not-in-range-then-every-equal))) + ("Subgoal 1" :in-theory '((:forward-chaining if-bad-index-in-range-then-cells-must-be-different))))) + + + + +(defthm properies-of-type-and-existence-of-current-args-add + (implies + (and + (gem-statep gstate) + (in-range (pcc gstate) (code gstate)) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-add)) + (and + (equal (var-type (get-cell (par1 (nth (pcc gstate) (code gstate))) (mem gstate))) 'Int) + (assoc-equal (par1 (nth (pcc gstate) (code gstate))) (mem gstate)) + (assoc-equal (par2 (nth (pcc gstate) (code gstate))) (mem gstate)) + (assoc-equal (par3 (nth (pcc gstate) (code gstate))) (mem gstate)))) + :hints (("Goal" :in-theory (enable get-cell) + :use (:instance in-range-instruction-is-gem-instruction + (pcc (pcc gstate)) + (code (code gstate)) + (mem (mem gstate))))) + :rule-classes nil) + + +(defthm par1-of-current-instruction-is-into-mapping-add + (implies + (and + (vars-inclusion (mem gstate) m) + (gem-statep gstate) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-add) + (in-range (pcc gstate) (code gstate))) + (assoc-equal (par1 (nth (pcc gstate) (code gstate))) m)) + :hints (("Goal" :in-theory (enable get-cell) + :use (properies-of-type-and-existence-of-current-args-add + (:instance inclusion-trans + (v (par1 (nth (pcc gstate) (code gstate)))) + (m1 (mem gstate)) + (m2 m)) + (:instance in-range-instruction-is-gem-instruction + (pcc (pcc gstate)) + (code (code gstate)) + (mem (mem gstate))))))) + + + +(defthm teorema-main-con-pcc-in-range-su-variabile-non-interessata-final-add + (implies + (and + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-add) + (good-translation-gem-rtm gstate rstate m) + (vars-inclusion (mem gstate) m) + (true-listp m) + (assoc-equal gvar1 m) + (gem-statep gstate) + (rtm-statep rstate) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (not (equal gvar1 (par1 (nth (pcc gstate) (code gstate))))) + (m-correspondent-values-p m (mem gstate) (mem rstate)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (correct-wrt-arity m (mem gstate))) + (equal-values-and-attributes + (get-cell gvar1 (mem (execute-instruction gstate))) + (rtmintvars-i gvar1 m) + (mem (execute-n-instructions rstate (len *rns*))) + (type-i gvar1 m))) + :hints (("Goal" + :in-theory '((:definition good-translation-gem-rtm)) + :use ( + par1-of-current-instruction-is-into-mapping-add + (:instance correct-wrt-arity-has-rtmintvars-i-tl (mem (mem gstate))) + (:instance m-correspondent-values-implies-equal-values-and-attribus + (memgstate (mem gstate)) (memrstate (mem rstate))) + (:instance in-range (idx (pcc gstate)) (l (code gstate))) + (:instance in-range (idx (pcc rstate)) (l (code rstate))) + rtm-variables-of-other-cell-untouched-add + teorema-main-con-pcc-in-range-su-variabile-non-interessata + (:instance equal-get-cells-implies-equal-values-and-attributes-still-works + (gemcell (get-cell gvar1 (mem gstate))) + (lcell (rtmintvars-i gvar1 m)) + (mem1 (mem rstate)) + (mem2 (mem (execute-n-instructions rstate (len *rns*)))) + (type (type-i gvar1 m))))))) + + +(defthm teorema-main-con-pcc-in-range-su-variabile-interessata-add + (implies + (and + (gem-statep gstate) + (rtm-statep rstate) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-add) + (good-translation-gem-rtm gstate rstate m)) + (equal + (mem (execute-n-instructions rstate (len *rns*))) + (adds-list-e + (rtmintvars-i (par1 (nth (pcc gstate) (code gstate))) m) + (eventually-make-list (rtmintvars-i (par2 (nth (pcc gstate) (code gstate))) m) (len *rns*)) ;new + (eventually-make-list (rtmintvars-i (par3 (nth (pcc gstate) (code gstate))) m) (len *rns*)) ;new + *rns* + (mem rstate)))) + :hints (("Goal" + :in-theory (union-theories (current-theory 'ground-zero) '((:definition in-range))) + :use (good-translation-gem-rtm + lemma2-only-adds-in-rtm-add + (:instance execute-n-instructions-tantamount-to-add-list-e + (n (len *rns*)) + (st rstate))))) + :rule-classes nil) + + + + +(defthm posinrg-add + (implies + (and + (vars-inclusion (mem gstate) m) + (gem-statep gstate) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-add) + (in-range (pcc gstate) (code gstate))) + (and + (in-range (pos-equal-0 (par1 (nth (pcc gstate) (code gstate))) m) m) + (in-range (pos-equal-0 (par2 (nth (pcc gstate) (code gstate))) m) m) + (in-range (pos-equal-0 (par3 (nth (pcc gstate) (code gstate))) m) m))) + :hints (("Goal" + :use (properies-of-type-and-existence-of-current-args-add + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par1 (nth (pcc gstate) (code gstate))))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par2 (nth (pcc gstate) (code gstate))))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par3 (nth (pcc gstate) (code gstate))))) + (:instance assoc-means-pos-in-range + (el (par1 (nth (pcc gstate) (code gstate)))) + (l m)) + (:instance assoc-means-pos-in-range + (el (par2 (nth (pcc gstate) (code gstate)))) + (l m)) + (:instance assoc-means-pos-in-range + (el (par3 (nth (pcc gstate) (code gstate)))) + (l m))))) + :rule-classes nil) + +(defthm eqlenss-add + (implies + (and + (gem-statep gstate) + (rtm-statep rstate) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-add) + (good-translation-gem-rtm gstate rstate m)) + (and + (equal (len (rtmintvars-i (par1 (nth (pcc gstate) (code gstate))) m)) (len *rns*)) + (equal (len (eventually-make-list (rtmintvars-i (par2 (nth (pcc gstate) (code gstate))) m) (len *rns*))) (len *rns*)) + (equal (len (eventually-make-list (rtmintvars-i (par3 (nth (pcc gstate) (code gstate))) m) (len *rns*))) (len *rns*)))) + :hints (("Goal" + :in-theory (union-theories (current-theory 'ground-zero) '((:definition in-range))) + :use + ( + good-translation-gem-rtm + (:instance length-of-listpars1-n-is-n (st rstate) (n (len *rns*))) + (:instance length-of-listpars2-n-is-n (st rstate) (n (len *rns*))) + (:instance length-of-listpars3-n-is-n (st rstate) (n (len *rns*)))))) + :rule-classes nil) + + +(defthm equal-sum-and-updates-after-n-instr + (implies + (and + (true-listp m) + (correct-wrt-arity m (mem gstate)) + (gem-statep gstate) + (rtm-statep rstate) + (vars-inclusion (mem gstate) m) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-add) + (good-translation-gem-rtm gstate rstate m) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (assoc-equal gvar1 m) + (equal gvar1 (par1 (nth (pcc gstate) (code gstate))))) + (equal-sum-and-updates + (rtmintvars-i gvar1 m) + (rtmintvars-i (par1 (nth (pcc gstate) (code gstate))) m) + (eventually-make-list (rtmintvars-i (par2 (nth (pcc gstate) (code gstate))) m) (len *rns*)) ;new + (eventually-make-list (rtmintvars-i (par3 (nth (pcc gstate) (code gstate))) m) (len *rns*)) ;new + *rns* + (mem rstate) + (mem (execute-n-instructions rstate (len *rns*))))) + :hints (("Goal" + :in-theory (union-theories (current-theory 'ground-zero) + '((:type-prescription retrieve-rtmvars) + (:definition positive-list) + (:definition positivep) + (:definition in-range))) + :use + ( + (:instance correct-wrt-arity-has-rtmintvars-i-tl (mem (mem gstate))) + (:instance sum-and-updates-holding-for-every-variable-type + (n (len *rns*)) + (ll (retrieve-rtmvars m)) + (rns *rns*) + (gem1 (pos-equal-0 (par1 (nth (pcc gstate) (code gstate))) m)) + (gem2 (pos-equal-0 (par2 (nth (pcc gstate) (code gstate))) m)) + (gem3 (pos-equal-0 (par3 (nth (pcc gstate) (code gstate))) m)) + (mem (mem rstate))) + lemma-help2 + eqlenss-add + posinrg-add + teorema-main-con-pcc-in-range-su-variabile-interessata-add + (:instance rtmintvars-i-is-pos-equal-0-of-retrieve-vars + (gvar (par1 (nth (pcc gstate) (code gstate))))) + (:instance rtmintvars-i-is-pos-equal-0-of-retrieve-vars + (gvar (par2 (nth (pcc gstate) (code gstate))))) + (:instance rtmintvars-i-is-pos-equal-0-of-retrieve-vars + (gvar (par3 (nth (pcc gstate) (code gstate))))) + (:instance rtmintvars-i-is-pos-equal-0-of-retrieve-vars + (gvar (par4 (nth (pcc gstate) (code gstate))))))))) + + +(defthm equal-sum-and-update-norest-afetr-one-instr + (implies + (and + (gem-statep gstate) + (in-range (pcc gstate) (code gstate)) + (good-translation-gem-rtm gstate rstate m) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-add) + (equal gvar1 (par1 (nth (pcc gstate) (code gstate)))) + (equal gvar2 (par2 (nth (pcc gstate) (code gstate)))) + (equal gvar3 (par3 (nth (pcc gstate) (code gstate))))) + (equal (get-cell gvar1 (mem (execute-instruction gstate))) + (sum-and-update-norest gvar1 gvar2 gvar3 (mem gstate)))) + :hints (("Goal" :in-theory (e/d (put-cell get-cell) + (par1 par2 par3 par4 opcode pcc code nth gem-instruction-list-p + gen-eq-update sum-and-update sub-and-update sub-and-update-norest sum-and-update-norest)))) + :rule-classes nil) + + +(DEFTHM mem-cellity-of-current-gem-args-add + (IMPLIES + (AND (GEM-STATEP GSTATE) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-add) + (IN-RANGE (PCC GSTATE) (CODE GSTATE))) + (AND (is-mem-cell-p (get-cell (PAR1 (NTH (PCC GSTATE) (CODE GSTATE))) (mem gstate))) + (is-mem-cell-p (get-cell (PAR2 (NTH (PCC GSTATE) (CODE GSTATE))) (mem gstate))) + (is-mem-cell-p (get-cell (PAR3 (NTH (PCC GSTATE) (CODE GSTATE))) (mem gstate))))) + :HINTS + (("Goal" + :USE + (:INSTANCE IN-RANGE-INSTRUCTION-IS-GEM-INSTRUCTION + (PCC (PCC GSTATE)) + (CODE (CODE GSTATE)) + (MEM (MEM GSTATE)))))) + + + +(defthm type-is-for-pars-add + (implies + (and + (true-listp m) + (vars-inclusion (mem gstate) m) + (gem-statep gstate) + (correct-wrt-arity m (mem gstate)) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-add) + (equal gvar1 (par1 (nth (pcc gstate) (code gstate)))) + (equal gvar2 (par2 (nth (pcc gstate) (code gstate)))) + (equal gvar3 (par3 (nth (pcc gstate) (code gstate)))) + (in-range (pcc gstate) (code gstate))) + (equal (type-i gvar1 m) 'int)) + :hints (("Goal" + :in-theory (disable type-i-is-type-expected rtmintvars-i-is-pos-equal-0-of-retrieve-vars) + :use ( properies-of-type-and-existence-of-current-args-add + (:instance type-i-is-vartyper (gvar1 gvar1)) + (:instance type-i-is-vartyper (gvar1 gvar2)) + (:instance type-i-is-vartyper (gvar1 gvar3)) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par1 (nth (pcc gstate) (code gstate))))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par2 (nth (pcc gstate) (code gstate))))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par3 (nth (pcc gstate) (code gstate)))))))) + :rule-classes nil) + + +(defthm m-correspondence-kept-on-same-gvar-add + (implies + (and + (good-translation-gem-rtm gstate rstate m) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-add) + (equal gvar1 (par1 (nth (pcc gstate) (code gstate)))) + (true-listp m) + (correct-wrt-arity m (mem gstate)) + (gem-statep gstate) + (rtm-statep rstate) + (vars-inclusion (mem gstate) m) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (assoc-equal gvar1 m) + (m-correspondent-values-p m (mem gstate) (mem rstate))) + (equal-values-and-attributes + (get-cell gvar1 (mem (execute-instruction gstate))) + (rtmintvars-i gvar1 m) + (mem (execute-n-instructions rstate (len *rns*))) + (type-i gvar1 m))) + :hints (("Goal" :in-theory nil + :use ( + properies-of-type-and-existence-of-current-args-add + mem-cellity-of-current-gem-args-add + good-translation-gem-rtm + (:instance type-i-is-vartyper (gvar1 gvar1) (mem (mem gstate))) + (:instance type-i-is-vartyper (gvar1 (par2 (nth (pcc gstate) (code gstate)))) (mem (mem gstate))) + (:instance type-i-is-vartyper (gvar1 (par3 (nth (pcc gstate) (code gstate)))) (mem (mem gstate))) + (:instance type-i-is-type-expected (gvar gvar1) (mem (mem gstate))) + (:instance type-i-is-type-expected (gvar (par2 (nth (pcc gstate) (code gstate)))) (mem (mem gstate))) + (:instance type-i-is-type-expected (gvar (par3 (nth (pcc gstate) (code gstate)))) (mem (mem gstate))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par1 (nth (pcc gstate) (code gstate))))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par2 (nth (pcc gstate) (code gstate))))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par3 (nth (pcc gstate) (code gstate))))) + (:instance + equal-sum-and-update-norest-afetr-one-instr + (gvar2 (par2 (nth (pcc gstate) (code gstate)))) + (gvar3 (par3 (nth (pcc gstate) (code gstate)))) + ) + eqlenss-add + (:instance correct-wrt-arity-has-rtmintvars-i-tl (mem (mem gstate))) + (:instance type-is-for-pars-add + (gvar2 (par2 (nth (pcc gstate) (code gstate)))) + (gvar3 (par3 (nth (pcc gstate) (code gstate))))) + (:instance m-correspondent-values-implies-equal-values-and-attribus + (memgstate (mem gstate)) (memrstate (mem rstate)) + (gvar1 gvar1)) + (:instance m-correspondent-values-implies-equal-values-and-attribus + (memgstate (mem gstate)) (memrstate (mem rstate)) + (gvar1 (par2 (nth (pcc gstate) (code gstate))))) + (:instance m-correspondent-values-implies-equal-values-and-attribus + (memgstate (mem gstate)) (memrstate (mem rstate)) + (gvar1 (par3 (nth (pcc gstate) (code gstate))))) + equal-sum-and-updates-after-n-instr + (:instance + if-gem-is-sum-and-update-inf-every-rtm-var-is-sum-and-update-then-equal-values-is-kept-g + (gvar2 (par2 (nth (pcc gstate) (code gstate)))) + (gvar3 (par3 (nth (pcc gstate) (code gstate)))) + (rtmvars1 (rtmintvars-i gvar1 m)) + (rtmvars2 (rtmintvars-i (par2 (nth (pcc gstate) (code gstate))) m)) + (rtmvars3 (rtmintvars-i (par3 (nth (pcc gstate) (code gstate))) m)) + (rtmvarsres (rtmintvars-i gvar1 m)) + (gemmem (mem gstate)) + (rtmmem (mem rstate)) + (rtmmemafter (mem (execute-n-instructions rstate (len *rns*))))))))) + + +(defthm equal-values-correspondence-kept-by-any-execution-add + (implies + (and + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-add) + (good-translation-gem-rtm gstate rstate m) + (true-listp m) + (correct-wrt-arity m (mem gstate)) + (gem-statep gstate) + (rtm-statep rstate) + (vars-inclusion (mem gstate) m) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (assoc-equal gvar1 m) + (m-correspondent-values-p m (mem gstate) (mem rstate))) + (equal-values-and-attributes + (get-cell gvar1 (mem (execute-instruction gstate))) + (rtmintvars-i gvar1 m) + (mem (execute-n-instructions rstate (len *rns*))) + (type-i gvar1 m))) + :hints (("Goal" :use (m-correspondence-kept-on-same-gvar-add + teorema-main-con-pcc-in-range-su-variabile-non-interessata-final-add)))) + + + +(defthm equal-values-correspondence-kept-by-any-execution-idxed-add + (implies + (and + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-add) + (no-duplicates-p (retrieve-gemvars m)) + (good-translation-gem-rtm gstate rstate m) + (alistp m) + (correct-wrt-arity m (mem gstate)) + (gem-statep gstate) + (rtm-statep rstate) + (vars-inclusion (mem gstate) m) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (in-range idx m) + (m-correspondent-values-p m (mem gstate) (mem rstate))) + (equal-values-and-attributes + (get-cell (car (nth idx m)) (mem (execute-instruction gstate))) + (cdr (nth idx m)) + (mem (execute-n-instructions rstate (len *rns*))) + (type-i-idx m idx))) + :hints (("Goal" :in-theory (union-theories (current-theory 'ground-zero) '((:definition in-range))) + :use ( (:theorem + (implies + (and + (alistp m) + (in-range idx m)) + (and + (true-listp m) + (assoc-equal (car (nth idx m)) m)))) + type-i-idx + (:instance type-i (gvar (car (nth idx m)))) + (:instance rtmintvars-i-is-cdr-of-nth-entry (gvar (car (nth idx m)))) + (:instance equal-values-correspondence-kept-by-any-execution-add (gvar1 (car (nth idx m)))) + (:instance no-duplicates-has-pos-equal-right-in-that-place (l m))))) + :otf-flg t) + +(defthm m-correspondence-kept-by-any-execution-idxed-add + (implies + (and + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-add) + (no-duplicates-p (retrieve-gemvars m)) + (good-translation-gem-rtm gstate rstate m) + (alistp m) + (correct-wrt-arity m (mem gstate)) + (gem-statep gstate) + (rtm-statep rstate) + (vars-inclusion (mem gstate) m) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (m-correspondent-values-p m (mem gstate) (mem rstate))) + (m-correspondent-values-p + m + (mem (execute-instruction gstate)) + (mem (execute-n-instructions rstate (len *rns*))))) + :hints (("Goal" :use (:instance equal-values-correspondence-kept-by-any-execution-idxed-add + (idx (bad-idx-eqv-va m + (mem (execute-instruction gstate)) + (mem (execute-n-instructions rstate (len *rns*))))))) + ("Goal'" :cases ( (in-range (bad-idx-eqv-va m (mem (execute-instruction gstate)) + (mem (execute-n-instructions rstate (len *rns*)))) m))) + ("Subgoal 2" :in-theory '((:forward-chaining alistp-forward-to-true-listp) + (:rewrite if-bad-index-not-in-range-then-m-corr))) + ("Subgoal 1" :in-theory '((:rewrite if-bad-index-in-range-thne-must-be-different-vs))))) + + + + +(defthm m-correspondence-and-other-conditions-kept-by-any-execution-add + (implies + (and + (alistp m) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-add) + (no-duplicates-p (retrieve-gemvars m)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (good-translation-gem-rtm gstate rstate m) + (correct-wrt-arity m (mem gstate)) + (gem-statep gstate) + (rtm-statep rstate) + (vars-inclusion (mem gstate) m) + (vars-inclusion m (mem gstate)) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (m-entries-point-to-good-rtm-var-sets m (mem rstate)) + (m-correspondent-values-p m (mem gstate) (mem rstate))) + (and + (good-translation-gem-rtm (execute-instruction gstate) (execute-n-instructions rstate (len *rns*)) m) + (rtm-statep (execute-n-instructions rstate (len *rns*))) + (m-entries-point-to-good-rtm-var-sets m (mem (execute-n-instructions rstate (len *rns*)))) + (gem-statep (execute-instruction gstate)) + (correct-wrt-arity m (mem (execute-instruction gstate))) + (vars-inclusion (mem (execute-instruction gstate)) m) + (vars-inclusion m (mem (execute-instruction gstate))) + (m-correspondent-values-p + m + (mem (execute-instruction gstate)) + (mem (execute-n-instructions rstate (len *rns*)))))) +:hints (("Goal" + :in-theory (disable + rtm-statep gem-statep + pcc code opcode + execute-instruction rtmintvars-i par1 par2 par3 nth len member-equal) + :use + (m-correspondence-kept-by-any-execution-idxed-add + good-translation-gem-rtm + (:instance execute-n-instructions-keeps-rtm-state-and-points-to-good + (st rstate) (n (len *rns*))) + (:instance executing-gem-instruction-retrieves-a-gem-state-from-gem-state (st gstate)) + (:instance executing-gem-instruction-preserves-correctness-wrt-arity (st gstate)) + (:instance executing-gem-instruction-keeps-vars-inclusion-right (st gstate)) + (:instance executing-gem-instruction-keeps-vars-inclusion-left (st gstate)))))) + + + + + + + + + + + +;;(ld "Proof-Of-Minus.lisp" :ld-error-action :error) + + +(in-theory (enable + (:executable-counterpart build-values-by-rns) + (:type-prescription build-values-by-rns) + (:induction build-values-by-rns) + (:definition build-values-by-rns) + posp-all posp mod mod-- mod-prod-makes-same-residues)) + +(in-theory (disable mod floor)) + +(defun sub-list (vl2 vl3 rns) + (if (endp vl2) + nil + (cons (mod (- (car vl2) (car vl3)) (car rns)) + (sub-list (cdr vl2) (cdr vl3) (cdr rns))))) + + +(defthm sub-correspondence-by-put-list + (implies + (and + (integerp gval1) + (integerp gval2) + (posp-all rns)) + (equal (build-values-by-rns (- gval1 gval2) rns) + (sub-list + (build-values-by-rns gval1 rns) + (build-values-by-rns gval2 rns) + rns))) + :hints (("Goal" :induct t))) + + + + +(in-theory (disable mod floor)) + +(defthm sub-correspondence-by-put-list-2-fin + (implies + (and + (integerp gval1) + (integerp gval2) + (posp-all rns)) + (equal (build-values-by-rns (mod (- gval1 gval2) (prod rns)) rns) + (sub-list + (build-values-by-rns gval1 rns) + (build-values-by-rns gval2 rns) + rns))) + :hints (("Goal" :in-theory (disable sum-correspondence-by-put-list-2-fin sum-correspondence-by-put-list) + :use (sub-correspondence-by-put-list + (:instance mod-prod-makes-same-residues (x (- gval1 gval2))))))) + + + +(in-theory (disable mod floor mod-- mod-prod-makes-same-residues)) + + +(defthm sub-correspondence-by-put-list-h + (implies + (and + (integerp gval1) + (integerp gval2) + (integer>1-listp rns)) + (equal (build-values-by-rns (mod (- gval1 gval2) (prod rns)) rns) + (sub-list + (build-values-by-rns gval1 rns) + (build-values-by-rns gval2 rns) + rns))) + :hints (("Goal" :use (sub-correspondence-by-put-list-2-fin greater-one-means-greater-zero)))) + + + + +(defthm a-boolean-has-same-rnss-than-list-of-itself + (implies + (and + (integerp val) + (or (equal val 0) (equal val 1)) + (integer>1-listp rns)) + (equal + (build-values-by-rns val rns) + (make-n-list val (len rns))))) + + + +(defthm sub-correspondence-by-put-list-on-boolean + (implies + (and + (integerp gval1) + (integerp gval2) + (or (equal gval2 0) (equal gval2 1)) + (integer>1-listp rns)) + (equal (build-values-by-rns (mod (- gval1 gval2) (prod rns)) rns) + (sub-list + (build-values-by-rns gval1 rns) + (make-n-list gval2 (len rns)) + rns))) + :hints (("Goal" :in-theory nil + :use (sub-correspondence-by-put-list-h + (:instance a-boolean-has-same-rnss-than-list-of-itself (val gval2)))))) + +(in-theory (disable mod--)) + + +(defun equal-sub-and-updates (reslist par1list par2list par3list primelist mem memafterputs) + (if (endp reslist) + (null reslist) + (and + (equal + (get-cell (car reslist) memafterputs) + (sub-and-update + (car par1list) + (car par2list) + (car par3list) + (car primelist) + mem)) + (equal-sub-and-updates + (cdr reslist) + (cdr par1list) + (cdr par2list) + (cdr par3list) + (cdr primelist) + mem + memafterputs)))) + + + + + +(defthm equal-sub-and-updates-have-same-attributes + (implies + (and + (true-listp rtmvars1) + (true-listp rtmvarsres) + (equal (len rtmvars1) (len rtmvarsres)) + (equal-sub-and-updates rtmvarsres rtmvars1 rtmvars2 rtmvars3 rns rtmmem rtmmemafter)) + (equal (var-attributes rtmvarsres rtmmemafter) (var-attributes rtmvars1 rtmmem))) + :hints (("Goal" :in-theory (enable var-attribute make-cell)))) + +;(in-theory (enable sub-list)) + +(defthm equal-sub-and-updates-have-values-that-are-sub-lists + (implies + (and + (equal (len rtmvars1) (len rtmvarsres)) + (equal (len rtmvars2) (len rtmvarsres)) + (equal (len rtmvars3) (len rtmvarsres)) + (equal-sub-and-updates rtmvarsres rtmvars1 rtmvars2 rtmvars3 rns rtmmem rtmmemafter)) + (equal (var-values rtmvarsres rtmmemafter) + (sub-list + (var-values rtmvars2 rtmmem) + (var-values rtmvars3 rtmmem) + rns))) + :hints ( ("Subgoal *1/2" :in-theory (enable var-value get-cell make-cell)))) + + + + + +(defthm behaviour-of-sub-and-update-norest + (and + (equal + (var-attribute (sub-and-update-norest c1 c2 c3 mem)) + (var-attribute (get-cell c1 mem))) + (equal + (var-value (sub-and-update-norest c1 c2 c3 mem)) + (mod + (- + (var-value (get-cell c2 mem)) + (var-value (get-cell c3 mem))) + (prod *rns*))) + (equal + (var-type (sub-and-update-norest c1 c2 c3 mem)) + (var-type (get-cell c1 mem)))) + :hints (("Goal" :in-theory (enable var-type var-value var-attribute make-cell)))) + + + + +(defthm defexpansion-sub + (implies + (not (null (var-value gcell))) + (equal + (equal-values-and-attributes gcell rtmvars rtmmem 'Int) + (and + (equal-values (var-values rtmvars rtmmem) + (build-values-by-rns (var-value gcell) *rns*)) + (equal-elements (var-attribute gcell) + (var-attributes rtmvars rtmmem))))) + :hints (("Goal" :in-theory '((:definition equal-values-and-attributes) + (:definition apply-direct-rns-to-value-according-to-type)) + :use (:instance build-values-by-rns-extended-behaves-standardly-on-non-nils + (gem-value (var-value gcell)) + (rns *rns*))))) + + + + + +(defthm if-gem-is-sub-and-update-inf-every-rtm-var-is-sub-and-update-then-equal-values-is-kept + (implies + (and + (true-listp rtmvars1) + (true-listp rtmvarsres) + (equal (len rtmvars1) (len rtmvarsres)) + (equal (len rtmvars2) (len rtmvarsres)) + (equal (len rtmvars3) (len rtmvarsres)) + (not (null (var-value (get-cell gvar1 gemmem)))) + (integerp (var-value (get-cell gvar2 gemmem))) + (integerp (var-value (get-cell gvar3 gemmem))) + (equal-sub-and-updates rtmvarsres rtmvars1 rtmvars2 rtmvars3 *rns* rtmmem rtmmemafter) + (equal-values-and-attributes (get-cell gvar1 gemmem) rtmvars1 rtmmem 'Int) + (equal-values-and-attributes (get-cell gvar2 gemmem) rtmvars2 rtmmem 'Int) + (equal-values-and-attributes (get-cell gvar3 gemmem) rtmvars3 rtmmem 'Int)) + (equal-values-and-attributes + (sub-and-update-norest gvar1 gvar2 gvar3 gemmem) + rtmvarsres + rtmmemafter + 'Int)) + :hints (("Goal" + :in-theory (union-theories (current-theory 'ground-zero) + '( + (:definition integer>1-listp) + (:definition equal-values) + (:rewrite defexpansion-sub))) + :use ( + (:instance greater-one-means-greater-zero (rns *rns*)) + (:instance equal-sub-and-updates-have-values-that-are-sub-lists (rns *rns*)) + (:instance equal-sub-and-updates-have-same-attributes (rns *rns*)) + (:instance sub-correspondence-by-put-list-h + (gval1 (var-value (get-cell gvar2 gemmem))) + (gval2 (var-value (get-cell gvar3 gemmem))) + (rns *rns*)) + (:instance behaviour-of-sub-and-update-norest + (c1 gvar1) + (c2 gvar2) + (c3 gvar3) + (mem gemmem))))) + ) + + + + + + + + + + + + +(defthm if-gem-is-sub-and-update-inf-every-rtm-var-is-sub-and-update-then-equal-values-is-kept-g + (implies + (and + (true-listp rtmvars1) + (true-listp rtmvarsres) + (equal (len rtmvars1) (len rtmvarsres)) + (equal (len (eventually-make-list rtmvars2 (len *rns*))) (len rtmvarsres)) + (equal (len (eventually-make-list rtmvars3 (len *rns*))) (len rtmvarsres)) + (equal (var-type (get-cell gvar2 gemmem)) (type-expected rtmvars2)) + (equal (var-type (get-cell gvar3 gemmem)) (type-expected rtmvars3)) + (is-mem-cell-p (get-cell gvar1 gemmem)) + (equal (var-type (get-cell gvar1 gemmem)) 'Int) + (is-mem-cell-p (get-cell gvar2 gemmem)) + (is-mem-cell-p (get-cell gvar3 gemmem)) + (equal-sub-and-updates + rtmvarsres + rtmvars1 + (eventually-make-list rtmvars2 (len *rns*)) + (eventually-make-list rtmvars3 (len *rns*)) + *rns* rtmmem rtmmemafter) + (equal-values-and-attributes (get-cell gvar1 gemmem) rtmvars1 rtmmem 'Int) + (equal-values-and-attributes (get-cell gvar2 gemmem) rtmvars2 rtmmem (var-type (get-cell gvar2 gemmem))) + (equal-values-and-attributes (get-cell gvar3 gemmem) rtmvars3 rtmmem (var-type (get-cell gvar3 gemmem)))) + (equal-values-and-attributes + (sub-and-update-norest gvar1 gvar2 gvar3 gemmem) + rtmvarsres + rtmmemafter + 'Int)) + :hints (("Goal" + :in-theory (union-theories (current-theory 'ground-zero) + '((:definition integer>1-listp) + (:definition equal-values) + (:definition is-mem-cell-p) + (:rewrite defexpansion-sub))) + :use ( + (:instance defexpansion-generic + (gcell (get-cell gvar2 gemmem)) + (rtmvars rtmvars2)) + (:instance defexpansion-generic + (gcell (get-cell gvar3 gemmem)) + (rtmvars rtmvars3)) + (:instance equal-sub-and-updates-have-values-that-are-sub-lists + (rtmvars2 (eventually-make-list rtmvars2 (len *rns*))) + (rtmvars3 (eventually-make-list rtmvars3 (len *rns*))) + (rns *rns*)) + (:instance equal-sub-and-updates-have-same-attributes + (rtmvars2 (eventually-make-list rtmvars2 (len *rns*))) + (rtmvars3 (eventually-make-list rtmvars3 (len *rns*))) + (rns *rns*)) + (:instance sub-correspondence-by-put-list-h + (gval1 (var-value (get-cell gvar2 gemmem))) + (gval2 (var-value (get-cell gvar3 gemmem))) + (rns *rns*)) + (:instance behaviour-of-sub-and-update-norest + (c1 gvar1) + (c2 gvar2) + (c3 gvar3) + (mem gemmem)))))) + + + + + +(in-theory (disable sub-list sub-correspondence-by-put-list + sub-correspondence-by-put-list-h + sub-correspondence-by-put-list-2-fin + equal-sub-and-updates-have-same-attributes + equal-sub-and-updates-have-values-that-are-sub-lists + behaviour-of-sub-and-update-norest + defexpansion + if-a-var-value-is-same-then-var-values-are-list-of + if-a-var-attribute-is-same-then-var-attributes-are-list-of + defexpansion-generic-bool + defexpansion-generic-int + defexpansion-generic + defexpansion-bool-values-inv + defexpansion-bool-values + defexpansion-bool-attrs-inv + defexpansion-bool-attrs-inv-1 + defexpansion-bool-attrs-inv-2 + defexpansion-bool-attrs + defexpansion-bool-attrs-1 + equal-values-on-list-entails-equality-on-first-els + )) + + + + + +(defun execute-n-rtm-subs (st n) + (if + (zp n) + st + (execute-n-rtm-subs + (rtm-sub + (par1 (nth (pcc st) (code st))) + (par2 (nth (pcc st) (code st))) + (par3 (nth (pcc st) (code st))) + (par4 (nth (pcc st) (code st))) + st) + (1- n)))) + + +(defthm all-rtm-subs-means-only-subs-are-executed + (implies + (all-rtm-subs-for-n-steps st n) + (equal + (execute-n-rtm-subs st n) + (execute-n-instructions st n))) + :hints (("Goal" :in-theory (disable rtm-sub member-equal nth par1 par2 par3)))) + + +(defun subs-list-n (l1 l2 l3 l4 mem n) + (if (zp n) + mem + (subs-list-n (cdr l1) (cdr l2) (cdr l3) (cdr l4) + (put-cell + (car l1) + (sub-and-update + (car l1) + (car l2) + (car l3) + (car l4) + mem) + mem) + (1- n)))) + + + + + + + +(in-theory (disable member-equal)) + + +(in-theory (enable make-cell)) + + + +(defthm execute-n-rtm-subs-tantamount-to-sub-list-n + (implies + (and + (all-rtm-subs-for-n-steps st n) + (>= (pcc st) 0) + (rtm-statep st)) + (equal + (mem (execute-n-rtm-subs st n)) + (subs-list-n + (listpars1 st n) + (listpars2 st n) + (listpars3 st n) + (listpars4 st n) + (mem st) + n))) + :hints + (("Goal" :induct t ) + ("Subgoal *1/2.2" :in-theory '((:definition all-rtm-subs-for-n-steps) + (:definition execute-instruction) + (:definition rtm-sub) + (:definition make-state) + (:definition mem)) + ) + ("Subgoal *1/2" + :use ( execute-n-rtm-subs + (:instance subs-list-n + (l1 (listpars1 st n)) + (l2 (listpars2 st n)) + (l3 (listpars3 st n)) + (l4 (listpars4 st n)) + (mem (mem st))) + lemma12-lp1r lemma12-lp2r lemma12-lp3r lemma12-lp4r + (:theorem + (IMPLIES (AND (ALL-RTM-SUBS-FOR-N-STEPS ST N) + (>= (pcc st) 0) + (not (zp n))) + (equal (mem (execute-instruction st)) + (PUT-CELL (CAR (LISTPARS1 ST N)) + (SUB-AND-UPDATE (CAR (LISTPARS1 ST N)) + (CAR (LISTPARS2 ST N)) + (CAR (LISTPARS3 ST N)) + (CAR (LISTPARS4 ST N)) + (MEM ST)) + (MEM ST))))) + executing-rtm-instruction-retrieves-a-rtm-state-from-rtm-state + instruction-incrementing-pvv)))) + + +(in-theory (disable lemma12-lp1r lemma12-lp2r lemma12-lp3r lemma12-lp4r )) + + + + + + + + + + +(defun subs-list-e (c1 c2 c3 c4 mem) + (if + (endp c1) + mem + (subs-list-e + (cdr c1) + (cdr c2) + (cdr c3) + (cdr c4) + (put-cell (car c1) (sub-and-update (car c1) (car c2) (car c3) (car c4) mem) mem)))) + + + +(defthm subs-list-e-is-subs-list-n + (equal (subs-list-e c1 c2 c3 c4 mem) (subs-list-n c1 c2 c3 c4 mem (len c1))) + :rule-classes nil) + + + +(defthm execute-n-instructions-tantamount-to-sub-list-e + (implies + (and + (integerp n) + (>= n 0) + (all-rtm-subs-for-n-steps st n) + (>= (pcc st) 0) + (rtm-statep st)) + (equal + (mem (execute-n-instructions st n)) + (subs-list-e + (listpars1 st n) + (listpars2 st n) + (listpars3 st n) + (listpars4 st n) + (mem st)))) + :hints (("Goal" :in-theory nil + :use ((:instance subs-list-e-is-subs-list-n + (c1 (listpars1 st n)) + (c2 (listpars2 st n)) + (c3 (listpars3 st n)) + (c4 (listpars4 st n)) + (mem (mem st))) + execute-n-rtm-subs-tantamount-to-sub-list-n + all-rtm-subs-means-only-subs-are-executed + length-of-listpars1-n-is-n)))) + + + + + + + + + + +(defthm not-in-list-untouched-by-subs-list-e + (implies + (not (member-equal-bool v l1)) + (equal (get-cell v (subs-list-e l1 l2 l3 l4 mem)) (get-cell v mem))) + :hints (("Goal" :in-theory (disable sub-and-update)))) + +(defthm not-in-list-untouched-by-subs-list-e-1 + (implies + (not (member-equal-bool (car l1) (cdr l1))) + (equal (get-cell (car l1) (subs-list-e (cdr l1) (cdr l2) (cdr l3) (cdr l4) mem)) + (get-cell (car l1) mem)))) + + +(defthm sub-and-update-independent-from-firstbn + (implies + (and + (not (member-equal-bool (nth idx l1) (firstn idx l1))) + (not (member-equal-bool (nth idx l2) (firstn idx l1))) + (not (member-equal-bool (nth idx l3) (firstn idx l1)))) + (equal (sub-and-update + (nth idx l1) + (nth idx l2) + (nth idx l3) + (nth idx l4) + (subs-list-e (firstn idx l1) (firstn idx l2) (firstn idx l3) (firstn idx l4) mem)) + (sub-and-update + (nth idx l1) + (nth idx l2) + (nth idx l3) + (nth idx l4) + mem)))) + + + +(defthm subs-list-decomp + (implies + (and + (in-range idx l1) + (in-range idx l2) + (in-range idx l3) + (in-range idx l4)) + (equal + (subs-list-e l1 l2 l3 l4 mem) + (subs-list-e (nthcdr idx l1) (nthcdr idx l2) (nthcdr idx l3) (nthcdr idx l4) + (subs-list-e (firstn idx l1) (firstn idx l2) (firstn idx l3) (firstn idx l4) mem)))) + :hints (("Goal" :in-theory (disable sub-and-update)))) + + +(defthm if-el-does-not-appear-after-its-position-then-subs-list-e-produces-its-sub + (implies + (and + (not (member-equal-bool (nth idx l1) (cdr (nthcdr idx l1)))) + (in-range idx l1) + (in-range idx l2) + (in-range idx l3) + (in-range idx l4)) + (equal + (get-cell (nth idx l1) (subs-list-e l1 l2 l3 l4 mem)) + (sub-and-update + (nth idx l1) + (nth idx l2) + (nth idx l3) + (nth idx l4) + (subs-list-e (firstn idx l1) (firstn idx l2) (firstn idx l3) (firstn idx l4) mem)))) + :hints (("Goal" :in-theory (disable sub-and-update)))) + + + + +(defthm rtm-variable-of-subs-list-e-is-sub-of-correspondent-variables + (implies + (and + (positive-list rns) + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (in-range gem1 ll) + (in-range gem2 ll) + (in-range gem3 ll) + (in-range idx (nth gem1 ll)) + (in-range idx (nth gem2 ll)) + (in-range idx (nth gem3 ll)) + (in-range idx rns)) + (equal + (get-cell (nth idx (nth gem1 ll)) (subs-list-e (nth gem1 ll) (nth gem2 ll) (nth gem3 ll) rns mem)) + (sub-and-update (nth idx (nth gem1 ll)) (nth idx (nth gem2 ll)) (nth idx (nth gem3 ll)) (nth idx rns) mem))) + :hints (("Goal" :in-theory (disable sub-and-update) + :use ( + (:instance no-duplicates-all-implies-no-duplicates-one (idx1 gem1)) + (:instance no-duplicates-means-an-element-does-not-appear-after-its-position (l (nth gem1 ll))) + if-el-does-not-appear-after-its-position-then-subs-list-e-produces-its-sub + (:instance subs-list-decomp + (l1 (nth gem1 ll)) (l2 (nth gem2 ll)) (l3 (nth gem3 ll))) + (:instance sub-and-update-independent-from-firstbn + (l1 (nth gem1 ll)) (l2 (nth gem2 ll)) (l3 (nth gem3 ll))))))) + + + +(defun index-different-sub-and-updates (rtmvarsres rtmvars1 rtmvars2 rtmvars3 rns mem mem-after-sub) + (cond + ( (endp rtmvarsres) + 0 ) + ( (not (equal (get-cell (car rtmvarsres) mem-after-sub) + (sub-and-update (car rtmvars1) (car rtmvars2) (car rtmvars3) (car rns) mem))) + 0 ) + ( t + (1+ (index-different-sub-and-updates + (cdr rtmvarsres) + (cdr rtmvars1) + (cdr rtmvars2) + (cdr rtmvars3) + (cdr rns) + mem + mem-after-sub))))) + +(defthm if-bad-index-in-range-thne-must-be-nonsubandupdate + (let ((bad-idx (index-different-sub-and-updates rtmvarsres rtmvars1 rtmvars2 rtmvars3 rns mem mem-after-sub))) + (implies + (in-range bad-idx rtmvarsres) + (not (equal + (get-cell (nth bad-idx rtmvarsres) mem-after-sub) + (sub-and-update + (nth bad-idx rtmvars1) + (nth bad-idx rtmvars2) + (nth bad-idx rtmvars3) + (nth bad-idx rns) + mem))))) + :hints (("Goal" :in-theory (disable get-cell sub-and-update)))) + + +(defthm if-bad-index-not-in-range-then-every-equalsubandupdate + (let ((bad-idx (index-different-sub-and-updates rtmvarsres rtmvars1 rtmvars2 rtmvars3 rns mem mem-after-sub))) + (implies (and (true-listp rtmvarsres) + (not (in-range bad-idx rtmvarsres))) + (equal-sub-and-updates rtmvarsres rtmvars1 rtmvars2 rtmvars3 rns mem mem-after-sub)))) + + +(defthm rtm-variable-of-subs-list-e-is-sub-and-updates + (implies + (and + (positive-list rns) + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (equal (len (nth gem1 ll)) (len (nth gem2 ll))) + (equal (len (nth gem1 ll)) (len (nth gem3 ll))) + (equal (len (nth gem1 ll)) (len rns)) + (in-range gem1 ll) + (in-range gem2 ll) + (in-range gem3 ll) + (true-listp (nth gem1 ll))) + (equal-sub-and-updates (nth gem1 ll) (nth gem1 ll) (nth gem2 ll) (nth gem3 ll) rns mem + (subs-list-e (nth gem1 ll) (nth gem2 ll) (nth gem3 ll) rns mem))) + :hints (("Goal" :use (:instance rtm-variable-of-subs-list-e-is-sub-of-correspondent-variables + (idx (index-different-sub-and-updates + (nth gem1 ll) + (nth gem1 ll) + (nth gem2 ll) + (nth gem3 ll) + rns + mem + (subs-list-e (nth gem1 ll) (nth gem2 ll) (nth gem3 ll) rns mem))))) + ("Goal'" :cases ( (in-range (index-different-sub-and-updates + (nth gem1 ll) + (nth gem1 ll) + (nth gem2 ll) + (nth gem3 ll) + rns + mem + (subs-list-e (nth gem1 ll) (nth gem2 ll) (nth gem3 ll) rns mem)) + (nth gem1 ll)) ) ) + ("Subgoal 1" :in-theory '((:definition in-range) + (:rewrite if-bad-index-in-range-thne-must-be-nonsubandupdate))) + ("Subgoal 2" :in-theory '((:rewrite if-bad-index-not-in-range-then-every-equalsubandupdate))))) + + + + +(defthm any-element-of-make-list-does-not-appear-into-other-lists + (implies + (and + (integerp n) + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (in-range gem1 ll) + (in-range gem2 ll) + (not (equal gem1 gem2)) + (equal (len (nth gem1 ll)) 1) + (in-range idx (make-n-list (car (nth gem1 ll)) n))) + (not (member-equal-bool + (nth idx (make-n-list (car (nth gem1 ll)) n)) + (nth gem2 ll)))) + :hints (("Goal" :use + ( + (:instance + el-of-makelist-is-el + (el (car (nth gem1 ll)))) + (:instance generalized-disjunctivity-unordered-2 + (idx1 gem1) (idx2 gem2) (el1 (car (nth gem1 ll))))))) + :otf-flg t) + +(defthm firstns-do-not-cotain-el-of-make-n-list-if-diff + (implies + (and + (integerp n) + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (in-range gem1 ll) + (in-range gem2 ll) + (not (equal gem1 gem2)) + (equal (len (nth gem1 ll)) 1) + (in-range idx (make-n-list (car (nth gem1 ll)) n))) + (not (member-equal-bool + (nth idx (make-n-list (car (nth gem1 ll)) n)) + (firstn idx (nth gem2 ll))))) + :hints (("Goal" :use + ( + (:instance no-member-holds-on-firstn + (el (nth idx (make-n-list (car (nth gem1 ll)) n))) + (l (nth gem2 ll))) + any-element-of-make-list-does-not-appear-into-other-lists)))) + + + +(defthm rtm-variable-of-subs-list-e-is-sub-of-correspondent-variables-when-var-3-is-boolean + (implies + (and + (integerp n) + (positive-list rns) + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (in-range gem1 ll) + (in-range gem2 ll) + (in-range gem3 ll) + (not (equal gem1 gem3)) + (equal (len (nth gem3 ll)) 1) + (in-range idx (nth gem1 ll)) + (in-range idx (nth gem2 ll)) + (in-range idx (make-n-list (car (nth gem3 ll)) n)) + (in-range idx rns)) + (equal + (get-cell (nth idx (nth gem1 ll)) + (subs-list-e + (nth gem1 ll) + (nth gem2 ll) + (make-n-list (car (nth gem3 ll)) n) + rns mem)) + (sub-and-update + (nth idx (nth gem1 ll)) + (nth idx (nth gem2 ll)) + (nth idx (make-n-list (car (nth gem3 ll)) n)) + (nth idx rns) mem))) + :hints (("Goal" :in-theory (disable sub-and-update) + :use ( + (:instance firstns-do-not-cotain-el-of-make-n-list-if-diff (gem1 gem3) (gem2 gem1)) + (:instance no-duplicates-all-implies-no-duplicates-one (idx1 gem1)) + (:instance no-duplicates-means-an-element-does-not-appear-after-its-position (l (nth gem1 ll))) + (:instance subs-list-decomp + (l1 (nth gem1 ll)) + (l2 (nth gem2 ll)) + (l3 (make-n-list (car (nth gem3 ll)) n)) + (l4 rns)) + (:instance sub-and-update-independent-from-firstbn + (l1 (nth gem1 ll)) + (l2 (nth gem2 ll)) + (l3 (make-n-list (car (nth gem3 ll)) n)) + (l4 rns)))))) + +(defthm rtm-variable-of-subs-list-e-is-sub-of-correspondent-variables-when-var-2-is-boolean + (implies + (and + (integerp n) + (positive-list rns) + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (in-range gem1 ll) + (in-range gem2 ll) + (in-range gem3 ll) + (not (equal gem1 gem2)) + (equal (len (nth gem2 ll)) 1) + (in-range idx (nth gem1 ll)) + (in-range idx (nth gem3 ll)) + (in-range idx (make-n-list (car (nth gem2 ll)) n)) + (in-range idx rns)) + (equal + (get-cell (nth idx (nth gem1 ll)) + (subs-list-e + (nth gem1 ll) + (make-n-list (car (nth gem2 ll)) n) + (nth gem3 ll) + rns mem)) + (sub-and-update + (nth idx (nth gem1 ll)) + (nth idx (make-n-list (car (nth gem2 ll)) n)) + (nth idx (nth gem3 ll)) + (nth idx rns) mem))) + :hints (("Goal" :in-theory (disable sub-and-update) + :use ( + (:instance firstns-do-not-cotain-el-of-make-n-list-if-diff (gem1 gem2) (gem2 gem1)) + (:instance no-duplicates-all-implies-no-duplicates-one (idx1 gem1)) + (:instance no-duplicates-means-an-element-does-not-appear-after-its-position (l (nth gem1 ll))) + (:instance subs-list-decomp + (l1 (nth gem1 ll)) + (l2 (make-n-list (car (nth gem2 ll)) n)) + (l3 (nth gem3 ll)) + (l4 rns)) + (:instance sub-and-update-independent-from-firstbn + (l1 (nth gem1 ll)) + (l2 (make-n-list (car (nth gem2 ll)) n)) + (l3 (nth gem3 ll)) + (l4 rns)))))) + +(defthm rtm-variable-of-subs-list-e-is-sub-of-correspondent-variables-when-var-2and3-are-boolean + (implies + (and + (integerp n) + (positive-list rns) + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (in-range gem1 ll) + (in-range gem2 ll) + (in-range gem3 ll) + (not (equal gem1 gem2)) + (not (equal gem1 gem3)) + (equal (len (nth gem2 ll)) 1) + (equal (len (nth gem3 ll)) 1) + (in-range idx (nth gem1 ll)) + (in-range idx (make-n-list (car (nth gem2 ll)) n)) + (in-range idx (make-n-list (car (nth gem3 ll)) n)) + (in-range idx rns)) + (equal + (get-cell (nth idx (nth gem1 ll)) + (subs-list-e + (nth gem1 ll) + (make-n-list (car (nth gem2 ll)) n) + (make-n-list (car (nth gem3 ll)) n) + rns mem)) + (sub-and-update + (nth idx (nth gem1 ll)) + (nth idx (make-n-list (car (nth gem2 ll)) n)) + (nth idx (make-n-list (car (nth gem3 ll)) n)) + (nth idx rns) mem))) + :hints (("Goal" :in-theory (disable sub-and-update) + :use ( + (:instance firstns-do-not-cotain-el-of-make-n-list-if-diff (gem1 gem2) (gem2 gem1)) + (:instance firstns-do-not-cotain-el-of-make-n-list-if-diff (gem1 gem3) (gem2 gem1)) + (:instance no-duplicates-all-implies-no-duplicates-one (idx1 gem1)) + (:instance no-duplicates-means-an-element-does-not-appear-after-its-position (l (nth gem1 ll))) + (:instance subs-list-decomp + (l1 (nth gem1 ll)) + (l2 (make-n-list (car (nth gem2 ll)) n)) + (l3 (make-n-list (car (nth gem3 ll)) n)) + (l4 rns)) + (:instance sub-and-update-independent-from-firstbn + (l1 (nth gem1 ll)) + (l2 (make-n-list (car (nth gem2 ll)) n)) + (l3 (make-n-list (car (nth gem3 ll)) n)) + (l4 rns)))))) + + + + +(defthm rtm-variable-of-subs-list-e-is-sub-of-correspondent-variables-with-all-vars-types + (implies + (and + (integerp n) + (positive-list rns) + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (in-range gem1 ll) + (in-range gem2 ll) + (in-range gem3 ll) + (not (equal (len (nth gem1 ll)) 1)) + (in-range idx (nth gem1 ll)) + (in-range idx (eventually-make-list (nth gem2 ll) n)) + (in-range idx (eventually-make-list (nth gem3 ll) n)) + (in-range idx rns)) + (equal + (get-cell (nth idx (nth gem1 ll)) + (subs-list-e + (nth gem1 ll) + (eventually-make-list (nth gem2 ll) n) + (eventually-make-list (nth gem3 ll) n) + rns mem)) + (sub-and-update + (nth idx (nth gem1 ll)) + (nth idx (eventually-make-list (nth gem2 ll) n)) + (nth idx (eventually-make-list (nth gem3 ll) n)) + (nth idx rns) mem))) + :hints (("Goal" :in-theory (union-theories (current-theory 'ground-zero) + '((:definition eventually-make-list))) + :cases + ( (and (not (equal (len (nth gem3 ll)) 1)) (equal (len (nth gem2 ll)) 1)) + (and (equal (len (nth gem3 ll)) 1) (not (equal (len (nth gem2 ll)) 1))) + (and (not (equal (len (nth gem3 ll)) 1)) (not (equal (len (nth gem2 ll)) 1))) + (and (equal (len (nth gem3 ll)) 1) (equal (len (nth gem2 ll)) 1)))) + ("Subgoal 4" + :use rtm-variable-of-subs-list-e-is-sub-of-correspondent-variables-when-var-2-is-boolean) + ("Subgoal 3" + :use rtm-variable-of-subs-list-e-is-sub-of-correspondent-variables-when-var-3-is-boolean) + ("Subgoal 2" + :use rtm-variable-of-subs-list-e-is-sub-of-correspondent-variables) + ("Subgoal 1" + :use rtm-variable-of-subs-list-e-is-sub-of-correspondent-variables-when-var-2and3-are-boolean))) + + + +(defthm sub-and-updates-holding-for-every-variable-type + (implies + (and + (integerp n) + (not (equal (len (nth gem1 ll)) 1)) + (positive-list rns) + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (equal (len (nth gem1 ll)) (len (eventually-make-list (nth gem2 ll) n))) + (equal (len (nth gem1 ll)) (len (eventually-make-list (nth gem3 ll) n))) + (equal (len (nth gem1 ll)) (len rns)) + (in-range gem1 ll) + (in-range gem2 ll) + (in-range gem3 ll) + (true-listp (nth gem1 ll))) + (equal-sub-and-updates + (nth gem1 ll) + (nth gem1 ll) + (eventually-make-list (nth gem2 ll) n) + (eventually-make-list (nth gem3 ll) n) + rns mem + (subs-list-e + (nth gem1 ll) + (eventually-make-list (nth gem2 ll) n) + (eventually-make-list (nth gem3 ll) n) + rns mem))) + :hints (("Goal" :use (:instance rtm-variable-of-subs-list-e-is-sub-of-correspondent-variables-with-all-vars-types + (idx (index-different-sub-and-updates + (nth gem1 ll) + (nth gem1 ll) + (eventually-make-list (nth gem2 ll) n) + (eventually-make-list (nth gem3 ll) n) + rns + mem + (subs-list-e + (nth gem1 ll) + (eventually-make-list (nth gem2 ll) n) + (eventually-make-list (nth gem3 ll) n) + rns mem))))) + ("Goal'" :cases ( (in-range (index-different-sub-and-updates + (nth gem1 ll) + (nth gem1 ll) + (eventually-make-list (nth gem2 ll) n) + (eventually-make-list (nth gem3 ll) n) + rns + mem + (subs-list-e + (nth gem1 ll) + (eventually-make-list (nth gem2 ll) n) + (eventually-make-list (nth gem3 ll) n) + rns mem)) + (nth gem1 ll)) ) ) + ("Subgoal 1" :in-theory '((:definition in-range) + (:rewrite if-bad-index-in-range-thne-must-be-nonsubandupdate))) + ("Subgoal 2" :in-theory '((:rewrite if-bad-index-not-in-range-then-every-equalsubandupdate))))) + + + +(defthm lemma2-only-subs-in-rtm-sub + (implies + (and + (gem-statep gstate) + (rtm-statep rstate) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-sub) + (good-translation-gem-rtm gstate rstate m)) + (all-rtm-subs-for-n-steps rstate (len *rns*))) + :hints (("Goal" :expand + ( (good-translation-gem-rtm gstate rstate m) + (gem-statep gstate) + (rtm-statep rstate) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate))) + :in-theory nil)) + :rule-classes nil) + + +(defthm cells-untouched-by-execute-on-other-cell-sub + (implies + (and + (integerp n) + (>= n 0) + (all-rtm-subs-for-n-steps st n) + (>= (pcc st) 0) + (rtm-statep st) + (not (member-equal-bool v (listpars1 st n)))) + (equal (get-cell v (mem st)) + (get-cell v (mem (execute-n-instructions st n))))) + :hints (("Goal" + :use (execute-n-instructions-tantamount-to-sub-list-e + (:instance not-in-list-untouched-by-subs-list-e + (v v) + (l1 (listpars1 st n)) + (l2 (listpars2 st n)) + (l3 (listpars3 st n)) + (l4 (listpars4 st n)) + (mem (mem st))))))) + + +(defthm rtm-variable-of-other-cell-untouched-sub + (implies + (and + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-sub) + (>= (pcc rstate) 0) + (rtm-statep rstate) + (good-translation-gem-rtm gstate rstate m) + (in-range (pcc gstate) (code gstate)) + (assoc-equal (par1 (nth (pcc gstate) (code gstate))) m) + (true-listp m) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (assoc-equal gvar1 m) + (not (equal gvar1 (par1 (nth (pcc gstate) (code gstate))))) + (in-range idx1 (rtmintvars-i gvar1 m))) + (equal (get-cell (nth idx1 (rtmintvars-i gvar1 m)) (mem rstate)) + (get-cell (nth idx1 (rtmintvars-i gvar1 m)) (mem (execute-n-instructions rstate (len *rns*)))))) + :hints (("Goal" :in-theory (current-theory 'ground-zero) + :expand ( (in-range (pcc gstate) (code gstate)) + (good-translation-gem-rtm gstate rstate m) ) + :use ( + (:instance lemma1-different-vars-do-not-belong (gvar2 (par1 (nth (pcc gstate) (code gstate))))) + (:instance cells-untouched-by-execute-on-other-cell-sub (st rstate) (n (len *rns*)) + (v (nth idx1 (rtmintvars-i gvar1 m)))))))) + +(defthm rtm-variables-of-other-cell-untouched-sub + (implies + (and + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-sub) + (>= (pcc rstate) 0) + (rtm-statep rstate) + (good-translation-gem-rtm gstate rstate m) + (in-range (pcc gstate) (code gstate)) + (assoc-equal (par1 (nth (pcc gstate) (code gstate))) m) + (true-listp m) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (assoc-equal gvar1 m) + (true-listp (rtmintvars-i gvar1 m)) + (not (equal gvar1 (par1 (nth (pcc gstate) (code gstate)))))) + (equal-get-cells + (rtmintvars-i gvar1 m) (mem rstate) (mem (execute-n-instructions rstate (len *rns*))))) + :hints (("Goal" :in-theory nil + :use ( (:instance rtm-variable-of-other-cell-untouched-sub + (idx1 (idx-different-cell + (rtmintvars-i gvar1 m) + (mem rstate) + (mem (execute-n-instructions rstate (len *rns*)))))) )) + ("Goal'" :cases ( (in-range + (idx-different-cell + (rtmintvars-i gvar1 m) + (mem rstate) + (mem (execute-n-instructions rstate (len *rns*)))) + (rtmintvars-i gvar1 m)))) + ("Subgoal 2" :in-theory '((:rewrite if-bad-index-not-in-range-then-every-equal))) + ("Subgoal 1" :in-theory '((:forward-chaining if-bad-index-in-range-then-cells-must-be-different))))) + + + + +(defthm properies-of-type-and-existence-of-current-args-sub + (implies + (and + (gem-statep gstate) + (in-range (pcc gstate) (code gstate)) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-sub)) + (and + (equal (var-type (get-cell (par1 (nth (pcc gstate) (code gstate))) (mem gstate))) 'Int) + (assoc-equal (par1 (nth (pcc gstate) (code gstate))) (mem gstate)) + (assoc-equal (par2 (nth (pcc gstate) (code gstate))) (mem gstate)) + (assoc-equal (par3 (nth (pcc gstate) (code gstate))) (mem gstate)))) + :hints (("Goal" :in-theory (enable get-cell) + :use (:instance in-range-instruction-is-gem-instruction + (pcc (pcc gstate)) + (code (code gstate)) + (mem (mem gstate))))) + :rule-classes nil) + + +(defthm par1-of-current-instruction-is-into-mapping-sub + (implies + (and + (vars-inclusion (mem gstate) m) + (gem-statep gstate) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-sub) + (in-range (pcc gstate) (code gstate))) + (assoc-equal (par1 (nth (pcc gstate) (code gstate))) m)) + :hints (("Goal" :in-theory (enable get-cell) + :use (properies-of-type-and-existence-of-current-args-sub + (:instance inclusion-trans + (v (par1 (nth (pcc gstate) (code gstate)))) + (m1 (mem gstate)) + (m2 m)) + (:instance in-range-instruction-is-gem-instruction + (pcc (pcc gstate)) + (code (code gstate)) + (mem (mem gstate))))))) + + + +(defthm teorema-main-con-pcc-in-range-su-variabile-non-interessata-final-sub + (implies + (and + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-sub) + (good-translation-gem-rtm gstate rstate m) + (vars-inclusion (mem gstate) m) + (true-listp m) + (assoc-equal gvar1 m) + (gem-statep gstate) + (rtm-statep rstate) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (not (equal gvar1 (par1 (nth (pcc gstate) (code gstate))))) + (m-correspondent-values-p m (mem gstate) (mem rstate)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (correct-wrt-arity m (mem gstate))) + (equal-values-and-attributes + (get-cell gvar1 (mem (execute-instruction gstate))) + (rtmintvars-i gvar1 m) + (mem (execute-n-instructions rstate (len *rns*))) + (type-i gvar1 m))) + :hints (("Goal" + :in-theory '((:definition good-translation-gem-rtm)) + :use ( + par1-of-current-instruction-is-into-mapping-sub + (:instance correct-wrt-arity-has-rtmintvars-i-tl (mem (mem gstate))) + (:instance m-correspondent-values-implies-equal-values-and-attribus + (memgstate (mem gstate)) (memrstate (mem rstate))) + (:instance in-range (idx (pcc gstate)) (l (code gstate))) + (:instance in-range (idx (pcc rstate)) (l (code rstate))) + rtm-variables-of-other-cell-untouched-sub + teorema-main-con-pcc-in-range-su-variabile-non-interessata + (:instance equal-get-cells-implies-equal-values-and-attributes-still-works + (gemcell (get-cell gvar1 (mem gstate))) + (lcell (rtmintvars-i gvar1 m)) + (mem1 (mem rstate)) + (mem2 (mem (execute-n-instructions rstate (len *rns*)))) + (type (type-i gvar1 m))))))) + + +(defthm teorema-main-con-pcc-in-range-su-variabile-interessata-sub + (implies + (and + (gem-statep gstate) + (rtm-statep rstate) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-sub) + (good-translation-gem-rtm gstate rstate m)) + (equal + (mem (execute-n-instructions rstate (len *rns*))) + (subs-list-e + (rtmintvars-i (par1 (nth (pcc gstate) (code gstate))) m) + (eventually-make-list (rtmintvars-i (par2 (nth (pcc gstate) (code gstate))) m) (len *rns*)) ;new + (eventually-make-list (rtmintvars-i (par3 (nth (pcc gstate) (code gstate))) m) (len *rns*)) ;new + *rns* + (mem rstate)))) + :hints (("Goal" + :in-theory (union-theories (current-theory 'ground-zero) '((:definition in-range))) + :use (good-translation-gem-rtm + lemma2-only-subs-in-rtm-sub + (:instance execute-n-instructions-tantamount-to-sub-list-e + (n (len *rns*)) + (st rstate))))) + :rule-classes nil) + + + + +(defthm posinrg-sub + (implies + (and + (vars-inclusion (mem gstate) m) + (gem-statep gstate) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-sub) + (in-range (pcc gstate) (code gstate))) + (and + (in-range (pos-equal-0 (par1 (nth (pcc gstate) (code gstate))) m) m) + (in-range (pos-equal-0 (par2 (nth (pcc gstate) (code gstate))) m) m) + (in-range (pos-equal-0 (par3 (nth (pcc gstate) (code gstate))) m) m))) + :hints (("Goal" + :use (properies-of-type-and-existence-of-current-args-sub + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par1 (nth (pcc gstate) (code gstate))))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par2 (nth (pcc gstate) (code gstate))))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par3 (nth (pcc gstate) (code gstate))))) + (:instance assoc-means-pos-in-range + (el (par1 (nth (pcc gstate) (code gstate)))) + (l m)) + (:instance assoc-means-pos-in-range + (el (par2 (nth (pcc gstate) (code gstate)))) + (l m)) + (:instance assoc-means-pos-in-range + (el (par3 (nth (pcc gstate) (code gstate)))) + (l m))))) + :rule-classes nil) + +(defthm eqlenss-sub + (implies + (and + (gem-statep gstate) + (rtm-statep rstate) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-sub) + (good-translation-gem-rtm gstate rstate m)) + (and + (equal (len (rtmintvars-i (par1 (nth (pcc gstate) (code gstate))) m)) (len *rns*)) + (equal (len (eventually-make-list (rtmintvars-i (par2 (nth (pcc gstate) (code gstate))) m) (len *rns*))) (len *rns*)) + (equal (len (eventually-make-list (rtmintvars-i (par3 (nth (pcc gstate) (code gstate))) m) (len *rns*))) (len *rns*)))) + :hints (("Goal" + :in-theory (union-theories (current-theory 'ground-zero) '((:definition in-range))) + :use + ( + good-translation-gem-rtm + (:instance length-of-listpars1-n-is-n (st rstate) (n (len *rns*))) + (:instance length-of-listpars2-n-is-n (st rstate) (n (len *rns*))) + (:instance length-of-listpars3-n-is-n (st rstate) (n (len *rns*)))))) + :rule-classes nil) + + +(defthm equal-sub-and-updates-after-n-instr + (implies + (and + (true-listp m) + (correct-wrt-arity m (mem gstate)) + (gem-statep gstate) + (rtm-statep rstate) + (vars-inclusion (mem gstate) m) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-sub) + (good-translation-gem-rtm gstate rstate m) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (assoc-equal gvar1 m) + (equal gvar1 (par1 (nth (pcc gstate) (code gstate))))) + (equal-sub-and-updates + (rtmintvars-i gvar1 m) + (rtmintvars-i (par1 (nth (pcc gstate) (code gstate))) m) + (eventually-make-list (rtmintvars-i (par2 (nth (pcc gstate) (code gstate))) m) (len *rns*)) ;new + (eventually-make-list (rtmintvars-i (par3 (nth (pcc gstate) (code gstate))) m) (len *rns*)) ;new + *rns* + (mem rstate) + (mem (execute-n-instructions rstate (len *rns*))))) + :hints (("Goal" + :in-theory (union-theories (current-theory 'ground-zero) + '((:type-prescription retrieve-rtmvars) + (:definition positive-list) + (:definition positivep) + (:definition in-range))) + :use + ( + (:instance correct-wrt-arity-has-rtmintvars-i-tl (mem (mem gstate))) + (:instance sub-and-updates-holding-for-every-variable-type + (n (len *rns*)) + (ll (retrieve-rtmvars m)) + (rns *rns*) + (gem1 (pos-equal-0 (par1 (nth (pcc gstate) (code gstate))) m)) + (gem2 (pos-equal-0 (par2 (nth (pcc gstate) (code gstate))) m)) + (gem3 (pos-equal-0 (par3 (nth (pcc gstate) (code gstate))) m)) + (mem (mem rstate))) + lemma-help2 + eqlenss-sub + posinrg-sub + teorema-main-con-pcc-in-range-su-variabile-interessata-sub + (:instance rtmintvars-i-is-pos-equal-0-of-retrieve-vars + (gvar (par1 (nth (pcc gstate) (code gstate))))) + (:instance rtmintvars-i-is-pos-equal-0-of-retrieve-vars + (gvar (par2 (nth (pcc gstate) (code gstate))))) + (:instance rtmintvars-i-is-pos-equal-0-of-retrieve-vars + (gvar (par3 (nth (pcc gstate) (code gstate))))) + (:instance rtmintvars-i-is-pos-equal-0-of-retrieve-vars + (gvar (par4 (nth (pcc gstate) (code gstate))))))))) + + +(defthm equal-sub-and-update-norest-afetr-one-instr + (implies + (and + (gem-statep gstate) + (in-range (pcc gstate) (code gstate)) + (good-translation-gem-rtm gstate rstate m) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-sub) + (equal gvar1 (par1 (nth (pcc gstate) (code gstate)))) + (equal gvar2 (par2 (nth (pcc gstate) (code gstate)))) + (equal gvar3 (par3 (nth (pcc gstate) (code gstate))))) + (equal (get-cell gvar1 (mem (execute-instruction gstate))) + (sub-and-update-norest gvar1 gvar2 gvar3 (mem gstate)))) + :hints (("Goal" :in-theory (e/d (put-cell get-cell) + (par1 par2 par3 par4 opcode pcc code nth gem-instruction-list-p + gen-eq-update sub-and-update sub-and-update sub-and-update-norest sub-and-update-norest)))) + :rule-classes nil) + + +(DEFTHM mem-cellity-of-current-gem-args-sub + (IMPLIES + (AND (GEM-STATEP GSTATE) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-sub) + (IN-RANGE (PCC GSTATE) (CODE GSTATE))) + (AND (is-mem-cell-p (get-cell (PAR1 (NTH (PCC GSTATE) (CODE GSTATE))) (mem gstate))) + (is-mem-cell-p (get-cell (PAR2 (NTH (PCC GSTATE) (CODE GSTATE))) (mem gstate))) + (is-mem-cell-p (get-cell (PAR3 (NTH (PCC GSTATE) (CODE GSTATE))) (mem gstate))))) + :HINTS + (("Goal" + :USE + (:INSTANCE IN-RANGE-INSTRUCTION-IS-GEM-INSTRUCTION + (PCC (PCC GSTATE)) + (CODE (CODE GSTATE)) + (MEM (MEM GSTATE)))))) + + + +(defthm type-is-for-pars-sub + (implies + (and + (true-listp m) + (vars-inclusion (mem gstate) m) + (gem-statep gstate) + (correct-wrt-arity m (mem gstate)) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-sub) + (equal gvar1 (par1 (nth (pcc gstate) (code gstate)))) + (equal gvar2 (par2 (nth (pcc gstate) (code gstate)))) + (equal gvar3 (par3 (nth (pcc gstate) (code gstate)))) + (in-range (pcc gstate) (code gstate))) + (equal (type-i gvar1 m) 'int)) + :hints (("Goal" + :in-theory (disable type-i-is-type-expected rtmintvars-i-is-pos-equal-0-of-retrieve-vars) + :use ( properies-of-type-and-existence-of-current-args-sub + (:instance type-i-is-vartyper (gvar1 gvar1)) + (:instance type-i-is-vartyper (gvar1 gvar2)) + (:instance type-i-is-vartyper (gvar1 gvar3)) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par1 (nth (pcc gstate) (code gstate))))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par2 (nth (pcc gstate) (code gstate))))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par3 (nth (pcc gstate) (code gstate)))))))) + :rule-classes nil) + + +(defthm m-correspondence-kept-on-same-gvar-sub + (implies + (and + (good-translation-gem-rtm gstate rstate m) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-sub) + (equal gvar1 (par1 (nth (pcc gstate) (code gstate)))) + (true-listp m) + (correct-wrt-arity m (mem gstate)) + (gem-statep gstate) + (rtm-statep rstate) + (vars-inclusion (mem gstate) m) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (assoc-equal gvar1 m) + (m-correspondent-values-p m (mem gstate) (mem rstate))) + (equal-values-and-attributes + (get-cell gvar1 (mem (execute-instruction gstate))) + (rtmintvars-i gvar1 m) + (mem (execute-n-instructions rstate (len *rns*))) + (type-i gvar1 m))) + :hints (("Goal" :in-theory nil + :use ( + properies-of-type-and-existence-of-current-args-sub + mem-cellity-of-current-gem-args-sub + good-translation-gem-rtm + (:instance type-i-is-vartyper (gvar1 gvar1) (mem (mem gstate))) + (:instance type-i-is-vartyper (gvar1 (par2 (nth (pcc gstate) (code gstate)))) (mem (mem gstate))) + (:instance type-i-is-vartyper (gvar1 (par3 (nth (pcc gstate) (code gstate)))) (mem (mem gstate))) + (:instance type-i-is-type-expected (gvar gvar1) (mem (mem gstate))) + (:instance type-i-is-type-expected (gvar (par2 (nth (pcc gstate) (code gstate)))) (mem (mem gstate))) + (:instance type-i-is-type-expected (gvar (par3 (nth (pcc gstate) (code gstate)))) (mem (mem gstate))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par1 (nth (pcc gstate) (code gstate))))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par2 (nth (pcc gstate) (code gstate))))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par3 (nth (pcc gstate) (code gstate))))) + (:instance + equal-sub-and-update-norest-afetr-one-instr + (gvar2 (par2 (nth (pcc gstate) (code gstate)))) + (gvar3 (par3 (nth (pcc gstate) (code gstate)))) + ) + eqlenss-sub + (:instance correct-wrt-arity-has-rtmintvars-i-tl (mem (mem gstate))) + (:instance type-is-for-pars-sub + (gvar2 (par2 (nth (pcc gstate) (code gstate)))) + (gvar3 (par3 (nth (pcc gstate) (code gstate))))) + (:instance m-correspondent-values-implies-equal-values-and-attribus + (memgstate (mem gstate)) (memrstate (mem rstate)) + (gvar1 gvar1)) + (:instance m-correspondent-values-implies-equal-values-and-attribus + (memgstate (mem gstate)) (memrstate (mem rstate)) + (gvar1 (par2 (nth (pcc gstate) (code gstate))))) + (:instance m-correspondent-values-implies-equal-values-and-attribus + (memgstate (mem gstate)) (memrstate (mem rstate)) + (gvar1 (par3 (nth (pcc gstate) (code gstate))))) + equal-sub-and-updates-after-n-instr + (:instance + if-gem-is-sub-and-update-inf-every-rtm-var-is-sub-and-update-then-equal-values-is-kept-g + (gvar2 (par2 (nth (pcc gstate) (code gstate)))) + (gvar3 (par3 (nth (pcc gstate) (code gstate)))) + (rtmvars1 (rtmintvars-i gvar1 m)) + (rtmvars2 (rtmintvars-i (par2 (nth (pcc gstate) (code gstate))) m)) + (rtmvars3 (rtmintvars-i (par3 (nth (pcc gstate) (code gstate))) m)) + (rtmvarsres (rtmintvars-i gvar1 m)) + (gemmem (mem gstate)) + (rtmmem (mem rstate)) + (rtmmemafter (mem (execute-n-instructions rstate (len *rns*))))))))) + + +(defthm equal-values-correspondence-kept-by-any-execution-sub + (implies + (and + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-sub) + (good-translation-gem-rtm gstate rstate m) + (true-listp m) + (correct-wrt-arity m (mem gstate)) + (gem-statep gstate) + (rtm-statep rstate) + (vars-inclusion (mem gstate) m) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (assoc-equal gvar1 m) + (m-correspondent-values-p m (mem gstate) (mem rstate))) + (equal-values-and-attributes + (get-cell gvar1 (mem (execute-instruction gstate))) + (rtmintvars-i gvar1 m) + (mem (execute-n-instructions rstate (len *rns*))) + (type-i gvar1 m))) + :hints (("Goal" :use (m-correspondence-kept-on-same-gvar-sub + teorema-main-con-pcc-in-range-su-variabile-non-interessata-final-sub)))) + + + +(defthm equal-values-correspondence-kept-by-any-execution-idxed-sub + (implies + (and + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-sub) + (no-duplicates-p (retrieve-gemvars m)) + (good-translation-gem-rtm gstate rstate m) + (alistp m) + (correct-wrt-arity m (mem gstate)) + (gem-statep gstate) + (rtm-statep rstate) + (vars-inclusion (mem gstate) m) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (in-range idx m) + (m-correspondent-values-p m (mem gstate) (mem rstate))) + (equal-values-and-attributes + (get-cell (car (nth idx m)) (mem (execute-instruction gstate))) + (cdr (nth idx m)) + (mem (execute-n-instructions rstate (len *rns*))) + (type-i-idx m idx))) + :hints (("Goal" :in-theory (union-theories (current-theory 'ground-zero) '((:definition in-range))) + :use ( (:theorem + (implies + (and + (alistp m) + (in-range idx m)) + (and + (true-listp m) + (assoc-equal (car (nth idx m)) m)))) + type-i-idx + (:instance type-i (gvar (car (nth idx m)))) + (:instance rtmintvars-i-is-cdr-of-nth-entry (gvar (car (nth idx m)))) + (:instance equal-values-correspondence-kept-by-any-execution-sub (gvar1 (car (nth idx m)))) + (:instance no-duplicates-has-pos-equal-right-in-that-place (l m))))) + :otf-flg t) + +(defthm m-correspondence-kept-by-any-execution-idxed-sub + (implies + (and + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-sub) + (no-duplicates-p (retrieve-gemvars m)) + (good-translation-gem-rtm gstate rstate m) + (alistp m) + (correct-wrt-arity m (mem gstate)) + (gem-statep gstate) + (rtm-statep rstate) + (vars-inclusion (mem gstate) m) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (m-correspondent-values-p m (mem gstate) (mem rstate))) + (m-correspondent-values-p + m + (mem (execute-instruction gstate)) + (mem (execute-n-instructions rstate (len *rns*))))) + :hints (("Goal" :use (:instance equal-values-correspondence-kept-by-any-execution-idxed-sub + (idx (bad-idx-eqv-va m + (mem (execute-instruction gstate)) + (mem (execute-n-instructions rstate (len *rns*))))))) + ("Goal'" :cases ( (in-range (bad-idx-eqv-va m (mem (execute-instruction gstate)) + (mem (execute-n-instructions rstate (len *rns*)))) m))) + ("Subgoal 2" :in-theory '((:forward-chaining alistp-forward-to-true-listp) + (:rewrite if-bad-index-not-in-range-then-m-corr))) + ("Subgoal 1" :in-theory '((:rewrite if-bad-index-in-range-thne-must-be-different-vs))))) + + + + +(defthm m-correspondence-and-other-conditions-kept-by-any-execution-sub + (implies + (and + (alistp m) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-sub) + (no-duplicates-p (retrieve-gemvars m)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (good-translation-gem-rtm gstate rstate m) + (correct-wrt-arity m (mem gstate)) + (gem-statep gstate) + (rtm-statep rstate) + (vars-inclusion (mem gstate) m) + (vars-inclusion m (mem gstate)) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (m-entries-point-to-good-rtm-var-sets m (mem rstate)) + (m-correspondent-values-p m (mem gstate) (mem rstate))) + (and + (good-translation-gem-rtm (execute-instruction gstate) (execute-n-instructions rstate (len *rns*)) m) + (rtm-statep (execute-n-instructions rstate (len *rns*))) + (m-entries-point-to-good-rtm-var-sets m (mem (execute-n-instructions rstate (len *rns*)))) + (gem-statep (execute-instruction gstate)) + (correct-wrt-arity m (mem (execute-instruction gstate))) + (vars-inclusion (mem (execute-instruction gstate)) m) + (vars-inclusion m (mem (execute-instruction gstate))) + (m-correspondent-values-p + m + (mem (execute-instruction gstate)) + (mem (execute-n-instructions rstate (len *rns*)))))) +:hints (("Goal" + :in-theory (disable + rtm-statep gem-statep + pcc code opcode + execute-instruction rtmintvars-i par1 par2 par3 nth len member-equal) + :use + (m-correspondence-kept-by-any-execution-idxed-sub + good-translation-gem-rtm + (:instance execute-n-instructions-keeps-rtm-state-and-points-to-good + (st rstate) (n (len *rns*))) + (:instance executing-gem-instruction-retrieves-a-gem-state-from-gem-state (st gstate)) + (:instance executing-gem-instruction-preserves-correctness-wrt-arity (st gstate)) + (:instance executing-gem-instruction-keeps-vars-inclusion-right (st gstate)) + (:instance executing-gem-instruction-keeps-vars-inclusion-left (st gstate)))))) + + + + + + + +;;(ld "Proof-Of-Comparison.lisp" :ld-error-action :error) + + + +(defthm listinstr-of-2-unfolding-f + (equal + (listinstr st 2) + (list + (nth (pcc st) (code st)) + (nth (pcc (execute-instruction st)) (code (execute-instruction st))))) + :hints (("Goal" + :in-theory (current-theory 'ground-zero) + :use ( (:instance listinstr (n 2)) + (:instance listinstr (st (execute-instruction st)) (n 1)) + (:instance listinstr (st (execute-instruction (execute-instruction st))) (n 0)))))) + + + +(defthm listinstr-of-2-has-the-two-instructions + (implies + (equal (listinstr st 2) + (rtm-eq-and v1 v2 tmp res)) + (and + (equal (nth (pcc st) (code st)) + (list 'rtm-equ tmp v1 v2)) + (equal (nth (pcc (execute-instruction st)) (code (execute-instruction st))) + (list 'rtm-and res tmp res)))) + :hints (("Goal" :in-theory (current-theory 'ground-zero) + :use (rtm-eq-and + listinstr-of-2-unfolding-f )))) + +(defthm listinstr-of-2-has-the-two-opcodes + (implies + (equal (listinstr st 2) + (rtm-eq-and v1 v2 tmp res)) + (and + (equal (opcode (nth (pcc st) (code st))) 'rtm-equ) + (equal (par1 (nth (pcc st) (code st))) tmp) + (equal (par2 (nth (pcc st) (code st))) v1) + (equal (par3 (nth (pcc st) (code st))) v2) + (equal (opcode (nth (pcc (execute-instruction st)) (code (execute-instruction st)))) 'rtm-and) + (equal (par1 (nth (pcc (execute-instruction st)) (code (execute-instruction st)))) res) + (equal (par2 (nth (pcc (execute-instruction st)) (code (execute-instruction st)))) tmp) + (equal (par3 (nth (pcc (execute-instruction st)) (code (execute-instruction st)))) res))) + :hints (("Goal" :in-theory (union-theories (current-theory 'ground-zero) + '((:definition par1) + (:definition par2) + (:definition par3) + (:definition opcode))) + :use (listinstr-of-2-has-the-two-instructions + (:instance + (:theorem (and + (equal (nth 0 (list a b c d)) a) + (equal (nth 1 (list a b c d)) b) + (equal (nth 2 (list a b c d)) c) + (equal (nth 3 (list a b c d)) d))) + (a 'rtm-equ) + (b tmp) + (c v1) + (d v2)) + (:instance + (:theorem (and + (equal (nth 0 (list a b c d)) a) + (equal (nth 1 (list a b c d)) b) + (equal (nth 2 (list a b c d)) c) + (equal (nth 3 (list a b c d)) d))) + (a 'rtm-and) + (b res) + (c tmp) + (d res)))))) + + + +(defthm listinstr-of-2-or-the-two-instructions + (implies + (equal (listinstr st 2) + (rtm-eq-or v1 v2 tmp res)) + (and + (equal (nth (pcc st) (code st)) + (list 'rtm-equ tmp v1 v2)) + (equal (nth (pcc (execute-instruction st)) (code (execute-instruction st))) + (list 'rtm-or res tmp tmp)))) + :hints (("Goal" :in-theory (current-theory 'ground-zero) + :use (rtm-eq-or + listinstr-of-2-unfolding-f )))) + +(defthm listinstr-of-2-or-has-the-two-opcodes + (implies + (equal (listinstr st 2) + (rtm-eq-or v1 v2 tmp res)) + (and + (equal (opcode (nth (pcc st) (code st))) 'rtm-equ) + (equal (par1 (nth (pcc st) (code st))) tmp) + (equal (par2 (nth (pcc st) (code st))) v1) + (equal (par3 (nth (pcc st) (code st))) v2) + (equal (opcode (nth (pcc (execute-instruction st)) (code (execute-instruction st)))) 'rtm-or) + (equal (par1 (nth (pcc (execute-instruction st)) (code (execute-instruction st)))) res) + (equal (par2 (nth (pcc (execute-instruction st)) (code (execute-instruction st)))) tmp) + (equal (par3 (nth (pcc (execute-instruction st)) (code (execute-instruction st)))) tmp))) + :hints (("Goal" :in-theory (union-theories (current-theory 'ground-zero) + '((:definition par1) + (:definition par2) + (:definition par3) + (:definition opcode))) + :use (listinstr-of-2-or-the-two-instructions + (:instance + (:theorem (and + (equal (nth 0 (list a b c d)) a) + (equal (nth 1 (list a b c d)) b) + (equal (nth 2 (list a b c d)) c) + (equal (nth 3 (list a b c d)) d))) + (a 'rtm-equ) + (b tmp) + (c v1) + (d v2)) + (:instance + (:theorem (and + (equal (nth 0 (list a b c d)) a) + (equal (nth 1 (list a b c d)) b) + (equal (nth 2 (list a b c d)) c) + (equal (nth 3 (list a b c d)) d))) + (a 'rtm-or) + (b res) + (c tmp) + (d tmp)))))) + + + + + +(defthm one-steps-of-execution + (implies + (equal (listinstr st 2) + (rtm-eq-and v1 v2 tmp res)) + (equal (execute-instruction st) + (generic-eql tmp v1 v2 st))) + :hints (("Goal" + :in-theory '((:definition execute-instruction)) + :use (listinstr-of-2-has-the-two-opcodes)))) + +(defthm two-steps-of-execution + (implies + (equal (listinstr st 2) + (rtm-eq-and v1 v2 tmp res)) + (equal (execute-instruction (execute-instruction st)) + (rtm-and res tmp res (generic-eql tmp v1 v2 st)))) + :hints (("Goal" + :in-theory '((:definition execute-instruction)) + :use (listinstr-of-2-has-the-two-opcodes)))) + + +; Note: Below I have disabled a couple of names. This was not in the +; original script. In the conversion from Version 2.5 to 2.6, we +; added the case-split-limitations and choked it down from (nil nil) +; -- the old default -- to something smaller. The first proof to +; break was two-steps-inertia, below. In analyzing why it broke, I +; realized that two-steps-of-execution was being :USEd but not +; DISABLEd. So it could be rewritten away. Disabling it, however, +; had no good effect. Then I realized that it could be rewritten away +; by proving it again, which meant using the definition of +; execute-instruction. So I disabled that too. And voila, the proof +; happens very quickly, without significant case analysis -- certainly +; without approaching the case-split-limitations. You will see a +; similar pair of disables once more below. + +(defthm two-steps-inertia + (implies + (and + (equal (listinstr st 2) + (rtm-eq-and v1 v2 tmp res)) + (not (equal tmp vx1)) + (not (equal res vx1))) + (equal (get-cell vx1 (mem (execute-instruction (execute-instruction st)))) + (get-cell vx1 (mem st)))) + :hints (("Goal" :in-theory (disable execute-instruction ; (See note above.) + two-steps-of-execution ; (See note above.) + opcode one-steps-of-execution;par1 par2 par3 pcc code + gem-add gem-sub rtm-add rtm-sub and-update gen-eq-update) + :use (two-steps-of-execution)))) + + + +(defthm two-steps-inertia-on-sequence-of-vars + (implies + (and + (equal (listinstr st 2) (rtm-eq-and v1 v2 tmp res)) + (not (member-equal-bool tmp listvars1)) + (not (member-equal-bool res listvars1))) + (equal + (var-values listvars1 (mem st)) + (var-values listvars1 (mem (execute-instruction (execute-instruction st)))))) + :hints (("Goal" + :induct (var-values listvars1 (mem st)) + :in-theory (disable listinstr-of-2-unfolding-f + two-steps-of-execution execute-instruction one-steps-of-execution)) + ("Subgoal *1/2" :use (:instance two-steps-inertia (vx1 (car listvars1)))))) + + +(defthm two-steps-res + (implies + (and + (equal (listinstr st 2) + (rtm-eq-and v1 v2 tmp res)) + (not (equal tmp v1)) + (not (equal tmp v2)) + (not (equal res v1)) + (not (equal res v2)) + (not (equal tmp res))) + (equal (var-value (get-cell res (mem (rtm-and res tmp res (generic-eql tmp v1 v2 st))))) + (boolean-to-int + (and + (int-to-bool + (boolean-to-int (equal (var-value (get-cell v1 (mem st))) + (var-value (get-cell v2 (mem st)))))) + (int-to-bool (var-value (get-cell res (mem st)))))))) + :hints (("Goal" + :in-theory (e/d + (make-cell put-cell get-cell var-value) + (opcode one-steps-of-execution execute-instruction + int-to-bool boolean-to-int + gem-add gem-sub rtm-add rtm-sub ))))) + + +(defthm one-steps-of-execution-or + (implies + (equal (listinstr st 2) + (rtm-eq-or v1 v2 tmp res)) + (equal (execute-instruction st) + (generic-eql tmp v1 v2 st))) + :hints (("Goal" + :in-theory '((:definition execute-instruction)) + :use (listinstr-of-2-or-has-the-two-opcodes)))) + +(defthm two-steps-of-execution-or + (implies + (equal (listinstr st 2) + (rtm-eq-or v1 v2 tmp res)) + (equal (execute-instruction (execute-instruction st)) + (rtm-or res tmp tmp (generic-eql tmp v1 v2 st)))) + :hints (("Goal" + :in-theory '((:definition execute-instruction)) + :use (listinstr-of-2-or-has-the-two-opcodes)))) + + +(defthm two-steps-inertia-or + (implies + (and + (equal (listinstr st 2) + (rtm-eq-or v1 v2 tmp res)) + (not (equal tmp vx1)) + (not (equal res vx1))) + (equal (get-cell vx1 (mem (execute-instruction (execute-instruction st)))) + (get-cell vx1 (mem st)))) + :hints (("Goal" :in-theory (disable execute-instruction ; (See note above.) + two-steps-of-execution-or ; (See note above.) + opcode one-steps-of-execution-or ;par1 par2 par3 pcc code + gem-add gem-sub rtm-add rtm-sub and-update gen-eq-update or-update) + :use (two-steps-of-execution-or)))) + + + +(defthm two-steps-inertia-on-sequence-of-vars-or + (implies + (and + (equal (listinstr st 2) (rtm-eq-or v1 v2 tmp res)) + (not (member-equal-bool tmp listvars1)) + (not (member-equal-bool res listvars1))) + (equal + (var-values listvars1 (mem st)) + (var-values listvars1 (mem (execute-instruction (execute-instruction st)))))) + :hints (("Goal" + :induct (var-values listvars1 (mem st)) + :in-theory (disable listinstr-of-2-unfolding-f + two-steps-of-execution-or execute-instruction one-steps-of-execution-or)) + ("Subgoal *1/2" :use (:instance two-steps-inertia-or (vx1 (car listvars1)))))) + + +(defthm two-steps-res-or + (implies + (and + (equal (listinstr st 2) + (rtm-eq-or v1 v2 tmp res)) + (not (equal tmp v1)) + (not (equal tmp v2)) + (not (equal res v1)) + (not (equal res v2)) + (not (equal tmp res))) + (equal (var-value (get-cell res (mem (rtm-or res tmp tmp (generic-eql tmp v1 v2 st))))) + (boolean-to-int + (equal (var-value (get-cell v1 (mem st))) + (var-value (get-cell v2 (mem st))))))) + :hints (("Goal" + :use (:theorem + (equal + (or + (int-to-bool + (boolean-to-int (equal (var-value (get-cell v1 (mem st))) + (var-value (get-cell v2 (mem st)))))) + (int-to-bool + (boolean-to-int (equal (var-value (get-cell v1 (mem st))) + (var-value (get-cell v2 (mem st))))))) + (equal (var-value (get-cell v1 (mem st))) + (var-value (get-cell v2 (mem st)))))) + :in-theory (e/d + (make-cell put-cell get-cell var-value) + (opcode one-steps-of-execution-or execute-instruction + int-to-bool boolean-to-int + gem-add gem-sub rtm-add rtm-sub ))))) + + + +(defthm execute-instruction-2-unfolding + (equal + (execute-n-instructions st 2) + (execute-instruction (execute-instruction st))) + :hints (("Goal" + :in-theory (current-theory 'ground-zero) + :use + ((:instance execute-n-instructions (n 2)) + (:instance execute-n-instructions (st (execute-instruction st)) (n 1)) + (:instance execute-n-instructions (st (execute-instruction (execute-instruction st))) (n 0)))))) + + + +(defthm two-steps-res-2 + (implies + (and + (equal (listinstr st 2) + (rtm-eq-and v1 v2 tmp res)) + (not (equal tmp v1)) + (not (equal tmp v2)) + (not (equal res v1)) + (not (equal res v2)) + (not (equal tmp res))) + (equal (var-value (get-cell res (mem (execute-n-instructions st 2)))) + (boolean-to-int + (and + (equal (var-value (get-cell v1 (mem st))) + (var-value (get-cell v2 (mem st)))) + (int-to-bool (var-value (get-cell res (mem st)))))))) + :hints (("Goal" :in-theory '((:definition int-to-bool) + (:definition boolean-to-int)) + :use (two-steps-res two-steps-of-execution execute-instruction-2-unfolding)))) + + +(defthm two-steps-res-or-2 + (implies + (and + (equal (listinstr st 2) + (rtm-eq-or v1 v2 tmp res)) + (not (equal tmp v1)) + (not (equal tmp v2)) + (not (equal res v1)) + (not (equal res v2)) + (not (equal tmp res))) + (equal (var-value (get-cell res (mem (execute-n-instructions st 2)))) + (boolean-to-int + (equal (var-value (get-cell v1 (mem st))) + (var-value (get-cell v2 (mem st))))))) + :hints (("Goal" :in-theory '((:definition int-to-bool) + (:definition boolean-to-int)) + :use (two-steps-res-or two-steps-of-execution-or execute-instruction-2-unfolding)))) + + +(defthm int-bool-int-cancellation + (equal (int-to-bool (boolean-to-int (equal v1 v2))) (equal v1 v2))) + +(defthm bool-int-bool-cancellation + (implies + (or (equal res 0) (equal res 1)) + (equal (boolean-to-int (int-to-bool res)) res))) + +(defun eq-values (listvars1 listvars2 res mem n) + (if (zp n) + res + (eq-values + (cdr listvars1) + (cdr listvars2) + (boolean-to-int + (and + (equal (var-value (get-cell (car listvars1) mem)) + (var-value (get-cell (car listvars2) mem))) + (int-to-bool res))) + mem + (1- n)))) + + +(defun equal-lv (listvars1 listvars2 mem n) + (declare (xargs :measure (acl2-count n))) + (if (zp n) + t + (and + (equal + (var-value (get-cell (car listvars1) mem)) + (var-value (get-cell (car listvars2) mem))) + (equal-lv (cdr listvars1) (cdr listvars2) mem (1- n))))) + + +(defthm case-zero + (equal (eq-values listvars1 listvars2 0 mem n) 0)) + +(defthm case-one + (equal (eq-values listvars1 listvars2 1 mem n) (boolean-to-int (equal-lv listvars1 listvars2 mem n)))) + +(defthm eq-values-is-equal-lv + (implies + (and + (or (equal res 0) (equal res 1)) + (equal n (len listvars2)) + (equal n (len listvars1))) + (equal + (eq-values listvars1 listvars2 res mem n) + (boolean-to-int + (and + (equal-lv listvars1 listvars2 mem n) + (int-to-bool res))))) + :hints (("Goal" :in-theory (disable int-to-bool boolean-to-int)))) + + +(defthm equal-lv-is-equal-values + (implies + (and + (equal n (len listvars1)) + (equal n (len listvars2))) + (equal + (equal-lv listvars1 listvars2 mem n) + (equal-values + (var-values listvars1 mem) + (var-values listvars2 mem))))) + + +(defthm eq-values-is-equal-values + (implies + (and + (or (equal res 0) (equal res 1)) + (equal n (len listvars2)) + (equal n (len listvars1))) + (equal + (eq-values listvars1 listvars2 res mem n) + (boolean-to-int + (and + (equal-values + (var-values listvars1 mem) + (var-values listvars2 mem)) + (int-to-bool res)))))) + + +(defun induct-support (listvars1 listvars2 tmp res st) + (if + (endp listvars1) + nil + (cons (list (car listvars1) (car listvars2) tmp res (pcc st)) + (induct-support + (cdr listvars1) + (cdr listvars2) + tmp + res + (execute-n-instructions st 2))))) + +(defthm support-1 + (implies + (and + (not (endp listvars1)) + (not (member-equal-bool tmp listvars1)) + (not (member-equal-bool tmp listvars2)) + (not (member-equal-bool res listvars1)) + (not (member-equal-bool res listvars2))) + (and + (not (member-equal-bool tmp (cdr listvars1))) + (not (member-equal-bool tmp (cdr listvars2))) + (not (member-equal-bool res (cdr listvars1))) + (not (member-equal-bool res (cdr listvars2)))))) + +(defthm listinstr-is-decomposed + (implies + (and + (integerp n) + (>= n 0)) + (equal + (listinstr (execute-n-instructions st n) m) + (nthcdr n (listinstr st (+ n m))))) + :hints (("Goal" + :induct (execute-n-instructions st n) + :in-theory (disable execute-instruction)))) + +(defthm nthcdr-2-unfolding + (equal (nthcdr 2 l) (cddr l))) + +(defthm nthcdr2ofeqtrans2 + (implies + (not (endp listvars1)) + (equal + (equality-trans2 (cdr listvars1) (cdr listvars2) tmp res) + (nthcdr 2 (equality-trans2 listvars1 listvars2 tmp res)))) + :hints (("Goal" :use + ( (:instance nthcdr-2-unfolding + (l (equality-trans2 listvars1 listvars2 tmp res))) + equality-trans2) + :in-theory (union-theories (current-theory 'ground-zero) '((:definition rtm-eq-and)))))) + +(in-theory (disable nthcdr-2-unfolding nthcdr2ofeqtrans2 listinstr-is-decomposed)) + +(defthm support-2a + (implies + (not (endp listvars1)) + (equal (listinstr (execute-n-instructions st 2) (* 2 (len (cdr listvars1)))) + (nthcdr 2 (listinstr st (* 2 (len listvars1)))))) + :hints (("Goal" + :use ( + (:instance listinstr-is-decomposed + (n 2) + (m (* 2 (len (cdr listvars1)))))) + :in-theory (disable execute-instruction execute-instruction-2-unfolding is-mem-cell-p)))) + +(defthm support-2 + (implies + (and + (not (endp listvars1)) + (equal (listinstr st (* 2 (len listvars1))) + (equality-trans2 listvars1 listvars2 tmp res))) + (equal (listinstr (execute-n-instructions st 2) (* 2 (len (cdr listvars1)))) + (equality-trans2 (cdr listvars1) (cdr listvars2) tmp res))) + :hints (("Goal" + :in-theory nil + :use (nthcdr2ofeqtrans2 support-2a)))) + + + +(defthm listinstr-append + (implies + (and + (integerp n) + (integerp m) + (>= m 0) + (>= n 0)) + (equal + (listinstr st (+ m n)) + (append (listinstr st m) + (listinstr (execute-n-instructions st m) n)))) + :hints (("Goal" + :in-theory (disable execute-instruction)))) + +(defthm silly-00 + (implies + (and + (equal l (append l1 l2)) + (>= (len l1) 2)) + (and + (equal (car l1) (car l)) + (equal (cadr l1) (cadr l))))) + +(defthm length-of-listintr + (implies + (and + (integerp n) + (>= n 0)) + (equal (len (listinstr st n)) n))) + +(defthm first-2-instr-are-same-if-many + (implies + (and + (integerp le) + (>= le 2)) + (and + (equal (car (listinstr st 2)) (car (listinstr st le))) + (equal (cadr (listinstr st 2)) (cadr (listinstr st le))))) + :hints (("Goal" :in-theory (current-theory 'ground-zero) + :use + ( + (:theorem (implies (integerp le) (equal (+ 2 -2 le) le))) + (:instance silly-00 + (l1 (listinstr st 2)) + (l2 (listinstr (execute-n-instructions st 2) (- le 2))) + (l (listinstr st le))) + (:instance length-of-listintr (n 2)) + (:instance listinstr-append + (m 2) + (n (- le 2))))))) + + +(defthm first-2-instr-are-same-if-many-inst + (implies + (not (endp listvars1)) + (and + (equal (car (listinstr st 2)) (car (listinstr st (* 2 (len listvars1))))) + (equal (cadr (listinstr st 2)) (cadr (listinstr st (* 2 (len listvars1))))))) + :hints (("Goal" + :in-theory (current-theory 'ground-zero) + :use (:instance first-2-instr-are-same-if-many (le (* 2 (len listvars1)))))) + :otf-flg t) + + + +(defthm first-two-instructions-are-eq-and + (implies + (and + (not (endp listvars1)) + (equal (listinstr st (* 2 (len listvars1))) + (equality-trans2 listvars1 listvars2 tmp res))) + (equal (listinstr st 2) (rtm-eq-and (car listvars1) (car listvars2) tmp res))) + :hints (("Goal" + :in-theory (disable execute-instruction) + :use first-2-instr-are-same-if-many-inst))) + + + +(defthm support-3a + (implies + (and + (equal (listinstr st (* 2 (len listvars1))) + (equality-trans2 listvars1 listvars2 tmp res)) + (not (endp listvars1)) + (not (endp listvars2)) + (not (member-equal-bool tmp listvars1)) + (not (member-equal-bool tmp listvars2)) + (not (member-equal-bool res listvars1)) + (not (member-equal-bool res listvars2)) + (not (equal tmp res))) + (equal + (eq-values + listvars1 + listvars2 + (var-value (get-cell res (mem st))) + (mem st) + (len listvars1)) + (eq-values + (cdr listvars1) + (cdr listvars2) + (var-value (get-cell res (mem (execute-n-instructions st 2)))) + (mem st) + (len (cdr listvars1))))) + :hints (("Goal" + :in-theory (disable listinstr-append listinstr-of-2-unfolding-f + execute-instruction one-steps-of-execution execute-instruction-2-unfolding) + :use + (first-two-instructions-are-eq-and + (:instance two-steps-res-2 (v1 (car listvars1)) (v2 (car listvars2))))))) + + + + + +(defthm support-3 + (implies + (and + (equal (listinstr st (* 2 (len listvars1))) + (equality-trans2 listvars1 listvars2 tmp res)) + (not (endp listvars1)) + (not (endp listvars2)) + (equal (len listvars1) (len listvars2)) + (not (member-equal-bool tmp listvars1)) + (not (member-equal-bool tmp listvars2)) + (not (member-equal-bool res listvars1)) + (not (member-equal-bool res listvars2)) + (not (equal tmp res))) + (equal + (eq-values + listvars1 + listvars2 + (var-value (get-cell res (mem st))) + (mem st) + (len listvars1)) + (eq-values + (cdr listvars1) + (cdr listvars2) + (var-value (get-cell res (mem (execute-n-instructions st 2)))) + (mem (execute-instruction (execute-instruction st))) + (len (cdr listvars1))))) + :hints (("Goal" + :in-theory (disable listinstr-append listinstr-of-2-unfolding-f + execute-instruction one-steps-of-execution execute-instruction-2-unfolding) + :use + (first-two-instructions-are-eq-and + (:instance two-steps-inertia-on-sequence-of-vars + (v1 (car listvars1)) + (v2 (car listvars2)) + (listvars1 (cdr listvars1))) + (:instance two-steps-inertia-on-sequence-of-vars + (v1 (car listvars1)) + (v2 (car listvars2)) + (listvars1 (cdr listvars2))) + (:instance two-steps-res-2 (v1 (car listvars1)) (v2 (car listvars2))))))) + + + + + + + + +(defthm value-of-result-after-executing-2n-instr + (implies + (and + (not (member-equal-bool tmp listvars1)) + (not (member-equal-bool tmp listvars2)) + (not (member-equal-bool res listvars1)) + (not (member-equal-bool res listvars2)) + (equal (len listvars1) (len listvars2)) + (not (equal tmp res)) + (equal (listinstr st (* 2 (len listvars1))) + (equality-trans2 listvars1 listvars2 tmp res))) + (equal + (var-value + (get-cell + res + (mem (execute-n-instructions st (* 2 (len listvars1)))))) + (eq-values + listvars1 + listvars2 + (var-value (get-cell res (mem st))) + (mem st) + (len listvars1)))) + :hints (("Goal" + :in-theory (disable execute-instruction is-mem-cell-p) + :induct (induct-support listvars1 listvars2 tmp res st)) + ("Subgoal *1/2" :use (support-1 support-2 support-3)))) + + +(defthm value-of-result-after-executing-2n-instr-fin + (implies + (and + (not (member-equal-bool tmp listvars1)) + (not (member-equal-bool tmp listvars2)) + (not (member-equal-bool res listvars1)) + (not (member-equal-bool res listvars2)) + (equal (len listvars1) (len listvars2)) + (or + (equal (var-value (get-cell res (mem st))) 0) + (equal (var-value (get-cell res (mem st))) 1)) + (not (equal tmp res)) + (equal (listinstr st (* 2 (len listvars1))) + (equality-trans2 listvars1 listvars2 tmp res))) + (equal + (var-value + (get-cell + res + (mem (execute-n-instructions st (* 2 (len listvars1)))))) + (boolean-to-int + (and + (equal-values + (var-values listvars1 (mem st)) + (var-values listvars2 (mem st))) + (int-to-bool (var-value (get-cell res (mem st)))))))) + :hints (("Goal" + :in-theory (disable execute-instruction is-mem-cell-p) + :use (value-of-result-after-executing-2n-instr)))) +(defthm nthcdr2ofeqtrans3 + (equal + (equality-trans2 (cdr listvars1) (cdr listvars2) tmp res) + (nthcdr 2 (equality-trans3 listvars1 listvars2 tmp res))) + :hints (("Goal" :use + ( (:instance nthcdr-2-unfolding + (l (equality-trans3 listvars1 listvars2 tmp res))) + equality-trans3) + :in-theory (union-theories (current-theory 'ground-zero) '((:definition rtm-eq-or)))))) + +(in-theory (disable nthcdr-2-unfolding nthcdr2ofeqtrans3 listinstr-is-decomposed)) + + +(defthm support-2b + (implies + (and + (not (endp listvars1)) + (equal (listinstr st (* 2 (len listvars1))) + (equality-trans3 listvars1 listvars2 tmp res))) + (equal (listinstr (execute-n-instructions st 2) (* 2 (len (cdr listvars1)))) + (equality-trans2 (cdr listvars1) (cdr listvars2) tmp res))) + :hints (("Goal" + :in-theory nil + :use (nthcdr2ofeqtrans3 support-2a)))) + + + +(defthm first-two-instructions-are-eq-or + (implies + (and + (not (endp listvars1)) + (equal (listinstr st (* 2 (len listvars1))) + (equality-trans3 listvars1 listvars2 tmp res))) + (equal (listinstr st 2) (rtm-eq-or (car listvars1) (car listvars2) tmp res))) + :hints (("Goal" + :in-theory (disable nthcdr nthcdr2ofeqtrans3 execute-instruction + ;; v2-6 mod: + listinstr-append) + :use first-2-instr-are-same-if-many-inst))) + + + + +(defthm support4 + (implies + (not (endp listvars1)) + (EQUAL + (EXECUTE-N-INSTRUCTIONS (EXECUTE-N-INSTRUCTIONS ST 2) (* 2 (LEN (CDR LISTVARS1)))) + (EXECUTE-N-INSTRUCTIONS ST (* 2 (LEN LISTVARS1))))) + :hints (("Goal" + :in-theory (current-theory 'ground-zero) + :use + (:instance execute-n-instruction-decomposition + (n1 2) + (n2 (* 2 (1- (len listvars1)))))) + ("Subgoal 1" + :use ((:theorem (equal (+ -2 2 (* 2 (LEN (CDR LISTVARS1)))) + (* 2 (LEN (CDR LISTVARS1))))) + (:theorem (equal (+ 2 (* 2 (LEN (CDR LISTVARS1)))) + (+ 2 -2 2 (* 2 (LEN (CDR LISTVARS1)))))))))) + + +(defthm value-of-result-after-executing-2n-+2instr-fin + (implies + (and + (not (member-equal-bool tmp listvars1)) + (not (member-equal-bool tmp listvars2)) + (not (member-equal-bool res listvars1)) + (not (member-equal-bool res listvars2)) + (equal (len listvars1) (len listvars2)) + (not (endp listvars1)) + (not (equal tmp res)) + (equal (listinstr st (* 2 (len listvars1))) + (equality-trans3 listvars1 listvars2 tmp res))) + (equal + (var-value + (get-cell + res + (mem (execute-n-instructions st (* 2 (len listvars1)))))) + (boolean-to-int + (and + (equal-values + (var-values (cdr listvars1) (mem (execute-n-instructions st 2))) + (var-values (cdr listvars2) (mem (execute-n-instructions st 2)))) + (int-to-bool + (boolean-to-int + (equal (var-value (get-cell (car listvars1) (mem st))) + (var-value (get-cell (car listvars2) (mem st)))))))))) + :hints (("Goal" + :in-theory (union-theories (current-theory 'ground-zero) + '((:definition member-equal-bool) + (:definition boolean-to-int))) + :use + ( + support-2b + support4 + first-two-instructions-are-eq-or + (:instance value-of-result-after-executing-2n-instr-fin + (st (execute-n-instructions st 2)) + (listvars1 (cdr listvars1)) + (listvars2 (cdr listvars2))) + (:instance two-steps-res-or-2 + (v1 (car listvars1)) + (v2 (car listvars2))))))) + + +(defthm at-the-end-equality-on-all + (implies + (and + (not (endp listvars1)) + (equal (len listvars1) (len listvars2))) + (equal + (boolean-to-int + (equal-values + (var-values listvars1 (mem st )) + (var-values listvars2 (mem st )))) + (boolean-to-int + (and + (equal-values + (var-values (cdr listvars1) (mem st )) + (var-values (cdr listvars2) (mem st ))) + (int-to-bool + (boolean-to-int + (equal (var-value (get-cell (car listvars1) (mem st))) + (var-value (get-cell (car listvars2) (mem st))))))))))) + + + + + + + +(defthm value-of-result-after-executing-2n-+2instr-finale + (implies + (and + (not (member-equal-bool tmp listvars1)) + (not (member-equal-bool tmp listvars2)) + (not (member-equal-bool res listvars1)) + (not (member-equal-bool res listvars2)) + (equal (len listvars1) (len listvars2)) + (not (endp listvars1)) + (not (equal tmp res)) + (equal (listinstr st (* 2 (len listvars1))) + (equality-trans3 listvars1 listvars2 tmp res))) + (equal + (var-value + (get-cell + res + (mem (execute-n-instructions st (* 2 (len listvars1)))))) + (boolean-to-int + (equal-values + (var-values listvars1 (mem st )) + (var-values listvars2 (mem st )))))) + :hints (("Goal" + :in-theory + (union-theories (current-theory 'ground-zero) + '((:rewrite execute-instruction-2-unfolding) + (:definition member-equal-bool))) + :use ( + (:instance two-steps-inertia-on-sequence-of-vars-or + (v1 (car listvars1)) + (v2 (car listvars2)) + (listvars1 (cdr listvars1))) + (:instance two-steps-inertia-on-sequence-of-vars-or + (v1 (car listvars1)) + (v2 (car listvars2)) + (listvars1 (cdr listvars2))) + first-two-instructions-are-eq-or + value-of-result-after-executing-2n-+2instr-fin + at-the-end-equality-on-all)))) + + +(in-theory (disable +listinstr-of-2-unfolding-f listinstr-of-2-has-the-two-instructions listinstr-of-2-has-the-two-opcodes +listinstr-of-2-or-the-two-instructions listinstr-of-2-or-has-the-two-opcodes +one-steps-of-execution two-steps-of-execution two-steps-inertia +two-steps-inertia-on-sequence-of-vars two-steps-res +one-steps-of-execution-or two-steps-of-execution-or two-steps-inertia-or +two-steps-inertia-on-sequence-of-vars-or two-steps-res-or +execute-instruction-2-unfolding two-steps-res-2 two-steps-res-or-2 +int-bool-int-cancellation bool-int-bool-cancellation case-zero case-one +equal-lv-is-equal-values eq-values-is-equal-values +support-1 listinstr-is-decomposed nthcdr-2-unfolding support-2a support-2 +listinstr-append silly-00 length-of-listintr +first-2-instr-are-same-if-many first-2-instr-are-same-if-many-inst +first-two-instructions-are-eq-and support-3a support-3 +value-of-result-after-executing-2n-instr value-of-result-after-executing-2n-instr-fin +equality-trans3 nthcdr2ofeqtrans3 support-2b +first-two-instructions-are-eq-or support4 +value-of-result-after-executing-2n-+2instr-fin +at-the-end-equality-on-all value-of-result-after-executing-2n-+2instr-finale)) + +(defun pars1-instructions (listinstr) + (if (endp listinstr) + nil + (cons (par1 (car listinstr)) + (pars1-instructions (cdr listinstr))))) + +(defthm pars1-instruction-is-listpars1 + (equal + (pars1-instructions (listinstr st n)) + (listpars1 st n))) + + + +(defun eqtr2 (l1 tmp res) + (if + (endp l1) + nil + (append (list tmp res) (eqtr2 (cdr l1) tmp res)))) + +(defun eqtr3 (l1 tmp res) + (append (list tmp res) (eqtr2 (cdr l1) tmp res))) + +(defthm cgr1 (equal (pars1-instructions (equality-trans2 l1 l2 tmp res)) (eqtr2 l1 tmp res))) + +(defthm pars1iappend + (equal (pars1-instructions (append l1 l2)) + (append (pars1-instructions l1) (pars1-instructions l2)))) + +(defthm parsi-instructions-of-eq3-are-eqtr3 + (equal (pars1-instructions (equality-trans3 l1 l2 tmp res)) (eqtr3 l1 tmp res)) + :hints (("Subgoal 2" :in-theory nil) + ("Goal" :use (eqtr3 + (:instance pars1iappend + (l1 (rtm-eq-or (car l1) (car l2 ) tmp res)) + (l2 (equality-trans2 (cdr l1) (cdr l2) tmp res))) + (:instance cgr1 (l1 (cdr l1)) (l2 (cdr l2))) + (:theorem (equal (pars1-instructions (rtm-eq-or (car l1) (car l2) tmp res)) (list tmp res))) + (:instance equality-trans3 (listvars1 l1) (listvars2 l2)))))) + + +(defthm only-tmp-res-into-eqtr3 + (implies + (and + (not (equal v tmp)) + (not (equal v res))) + (not (member-equal-bool v (eqtr3 l1 tmp res)))) + :otf-flg t) + + + + + +(defthm equality-trans3-has-par1-made-of-tmp-res + (implies + (and + (not (equal v tmp)) + (not (equal v res)) + (equal + (listinstr st n) + (equality-trans3 l1 l2 tmp res))) + (not (member-equal-bool v (listpars1 st n)))) +:hints (("Goal" :in-theory nil + :use (pars1-instruction-is-listpars1 + parsi-instructions-of-eq3-are-eqtr3 + only-tmp-res-into-eqtr3)))) + + + + + + + + +(DEFUN LISTOPCODES (ST N) + (IF (ZP N) + NIL + (CONS (OPCODE (NTH (PCC ST) (CODE ST))) + (LISTOPCODES (EXECUTE-INSTRUCTION ST) + (1- N))))) +(defun all-par1ops (opcodes) + (if (endp opcodes) + t + (and + (or + (equal (car opcodes) 'rtm-and) + (equal (car opcodes) 'rtm-or) + (equal (car opcodes) 'rtm-equ) + (equal (car opcodes) 'rtm-add) + (equal (car opcodes) 'rtm-sub)) + (all-par1ops (cdr opcodes))))) + +(defun all-par1opso (st n) + (declare (xargs :measure (acl2-count n))) + (if (zp n) + t + (and + (or + (null (NTH (PCC ST) (CODE ST))) + (equal (OPCODE (NTH (PCC ST) (CODE ST))) 'rtm-and) + (equal (OPCODE (NTH (PCC ST) (CODE ST))) 'rtm-or) + (equal (OPCODE (NTH (PCC ST) (CODE ST))) 'rtm-equ) + (equal (OPCODE (NTH (PCC ST) (CODE ST))) 'rtm-add) + (equal (OPCODE (NTH (PCC ST) (CODE ST))) 'rtm-sub)) + (all-par1opso (execute-instruction st) (1- n))))) + + + +(defthm if-only-par1-involving-ops-are-there-then-other-vars-are-untouched + (implies + (and + (all-par1opso st n) + (not (member-equal-bool v (listpars1 st n)))) + (equal (get-cell v (mem st)) (get-cell v (mem (execute-n-instructions st n))))) + :hints (("Goal" :in-theory (disable execute-instruction)) + ("Subgoal *1/2" :use (:instance only-par1-is-involved-rtm + (gstate st) + (var v))))) + + + + +(defun pars1-opcodes (listinstr) + (if (endp listinstr) + nil + (cons (opcode (car listinstr)) + (pars1-opcodes (cdr listinstr))))) + +(defthm pars1-opcodes-is-listopcodes + (equal + (pars1-opcodes (listinstr st n)) + (listopcodes st n))) + +(defun eqtr2o (l1) + (if + (endp l1) + nil + (append (list 'rtm-equ 'rtm-and) (eqtr2o (cdr l1))))) + +(defun eqtr3o (l1) + (append (list 'rtm-equ 'rtm-or) (eqtr2o (cdr l1)))) + +(defthm cgr2 (equal (pars1-opcodes (equality-trans2 l1 l2 tmp res)) (eqtr2o l1))) + +(defthm pars1oappend + (equal (pars1-opcodes (append l1 l2)) + (append (pars1-opcodes l1) (pars1-opcodes l2)))) + +(defthm parsi-opcodes-of-eq3-are-eqtr3o + (equal (pars1-opcodes (equality-trans3 l1 l2 tmp res)) (eqtr3o l1)) + :hints (("Subgoal 2" :in-theory nil) + ("Goal" :use (eqtr3o + (:instance pars1oappend + (l1 (rtm-eq-or (car l1) (car l2 ) tmp res)) + (l2 (equality-trans2 (cdr l1) (cdr l2) tmp res))) + (:instance cgr2 (l1 (cdr l1)) (l2 (cdr l2))) + (:theorem (equal (pars1-opcodes (rtm-eq-or (car l1) (car l2) tmp res)) (list 'rtm-equ 'rtm-or))) + (:instance equality-trans3 (listvars1 l1) (listvars2 l2)))))) + + +(defthm eqtr3o-makes-par1-instrs + (all-par1ops (eqtr3o l)) + :otf-flg t) + + + +(defthm opcodes-on-par1-imply-instructions-on-par1 + (implies + (all-par1ops (pars1-opcodes (listinstr st n))) + (all-par1opso st n))) + +(defthm if-instructions-are-trans3-and-v-non-in-par1-v-untouched + (implies + (and + (equal (listinstr st n) + (equality-trans3 l1 l2 tmp res)) + (not (member-equal-bool v (listpars1 st n)))) + (equal + (get-cell v (mem st)) + (get-cell v (mem (execute-n-instructions st n))))) + :hints (("Goal" + :in-theory nil + :use + (opcodes-on-par1-imply-instructions-on-par1 + pars1-opcodes-is-listopcodes + parsi-opcodes-of-eq3-are-eqtr3o + (:instance eqtr3o-makes-par1-instrs (l l1)) + if-only-par1-involving-ops-are-there-then-other-vars-are-untouched)))) + + +(defthm equality-trans3-means-touching-just-tmp-res + (implies + (and + (not (equal v tmp)) + (not (equal v res)) + (equal + (listinstr st n) + (equality-trans3 l1 l2 tmp res))) + (equal + (get-cell v (mem st)) + (get-cell v (mem (execute-n-instructions st n))))) + :hints (("Goal" + :use + (if-instructions-are-trans3-and-v-non-in-par1-v-untouched + equality-trans3-has-par1-made-of-tmp-res)))) + + + + + +(in-theory (disable + pars1-instructions pars1-instruction-is-listpars1 + eqtr2 eqtr3 cgr1 pars1iappend parsi-instructions-of-eq3-are-eqtr3 + only-tmp-res-into-eqtr3 equality-trans3-has-par1-made-of-tmp-res + all-par1ops all-par1opso + if-only-par1-involving-ops-are-there-then-other-vars-are-untouched + pars1-opcodes pars1-opcodes-is-listopcodes + eqtr2o eqtr3o cgr2 pars1oappend parsi-opcodes-of-eq3-are-eqtr3o + eqtr3o-makes-par1-instrs opcodes-on-par1-imply-instructions-on-par1 + if-instructions-are-trans3-and-v-non-in-par1-v-untouched)) + + + +(defthm lemma2-only-adds-in-rtm-equ + (implies + (and + (gem-statep gstate) + (rtm-statep rstate) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-equ) + (good-translation-gem-rtm gstate rstate m)) + (and + (equal (listinstr rstate (* 2 (len *rns*)) ) + (equality-trans3 + (eventually-make-list (rtmintvars-i (par2 (nth (pcc gstate) (code gstate))) m) (len *rns*)) + (eventually-make-list (rtmintvars-i (par3 (nth (pcc gstate) (code gstate))) m) (len *rns*)) + 'tmp + (car (rtmintvars-i (par1 (nth (pcc gstate) (code gstate))) m)))) + (not (equal + (par1 (nth (pcc gstate) (code gstate))) + (par2 (nth (pcc gstate) (code gstate))))) + (not (equal + (par1 (nth (pcc gstate) (code gstate))) + (par3 (nth (pcc gstate) (code gstate))))))) + :hints (("Goal" :expand + ( (good-translation-gem-rtm gstate rstate m) + (gem-statep gstate) + (rtm-statep rstate) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate))) + :in-theory nil)) + :rule-classes nil) + + + +(defthm lemma1-different-vars-do-not-belong-ref + (implies + (and + (true-listp m) + (not (endp (rtmintvars-i gvar2 m))) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (assoc-equal gvar1 m) + (assoc-equal gvar2 m) + (not (equal gvar1 gvar2)) + (in-range idx1 (rtmintvars-i gvar1 m))) + (not (equal (nth idx1 (rtmintvars-i gvar1 m)) + (car (rtmintvars-i gvar2 m))))) + :hints (("Goal" :in-theory nil + :use (lemma1-different-vars-do-not-belong + (:instance member-equal-bool + (el (nth idx1 (rtmintvars-i gvar1 m))) + (l (rtmintvars-i gvar2 m))))))) + +(defun no-tmp-into-mapping (m) + (if (endp m) + t + (and + (not (member-equal-bool 'tmp (rtmintvars-0 m))) + (no-tmp-into-mapping (cdr m))))) + +(defthm a-variable-is-never-tmp + (implies + (and + (no-tmp-into-mapping m) + (assoc-equal gvar1 m) + (in-range idx1 (rtmintvars-i gvar1 m))) + (not (equal (nth idx1 (rtmintvars-i gvar1 m)) 'tmp))) + :hints (("Goal" :in-theory (enable rtmintvars-0)))) + + +(defthm an-m-entry-is-never-nil + (implies + (and + (true-listp m) + (m-entries-point-to-good-rtm-var-sets m rtm-mem) + (assoc-equal var m)) + (not (endp (rtmintvars-i var m)))) + :hints (("Goal" :in-theory (enable rtmintvars-0)))) + + +(defthm rtm-variable-of-other-cell-untouched-equ + (implies + (and + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-equ) + (>= (pcc rstate) 0) + (rtm-statep rstate) + (no-tmp-into-mapping m) + (m-entries-point-to-good-rtm-var-sets m (mem rstate)) + (good-translation-gem-rtm gstate rstate m) + (in-range (pcc gstate) (code gstate)) + (assoc-equal (par1 (nth (pcc gstate) (code gstate))) m) + (true-listp m) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (assoc-equal gvar1 m) + (not (equal gvar1 (par1 (nth (pcc gstate) (code gstate))))) + (in-range idx1 (rtmintvars-i gvar1 m))) + (equal (get-cell (nth idx1 (rtmintvars-i gvar1 m)) (mem rstate)) + (get-cell (nth idx1 (rtmintvars-i gvar1 m)) (mem (execute-n-instructions rstate (* 2 (len *rns*))))))) + :hints (("Goal" :in-theory (current-theory 'ground-zero) + :expand ( (in-range (pcc gstate) (code gstate)) + (good-translation-gem-rtm gstate rstate m) ) + :use ( + (:instance a-variable-is-never-tmp (gvar1 gvar1)) + (:instance an-m-entry-is-never-nil + (rtm-mem (mem rstate)) + (var (par1 (nth (pcc gstate) (code gstate))))) + (:instance equality-trans3-means-touching-just-tmp-res + (v (nth idx1 (rtmintvars-i gvar1 m))) + (l1 (eventually-make-list (rtmintvars-i (par2 (nth (pcc gstate) (code gstate))) m) (len *rns*))) + (l2 (eventually-make-list (rtmintvars-i (par3 (nth (pcc gstate) (code gstate))) m) (len *rns*))) + (st rstate) + (tmp 'tmp) + (res (car (rtmintvars-i (par1 (nth (pcc gstate) (code gstate))) m))) + (n (* 2 (len *rns*)))) + (:instance lemma1-different-vars-do-not-belong-ref (gvar2 (par1 (nth (pcc gstate) (code gstate))))))))) + + + +(defthm rtm-variables-of-other-cell-untouched-equ + (implies + (and + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-equ) + (no-tmp-into-mapping m) + (m-entries-point-to-good-rtm-var-sets m (mem rstate)) + (>= (pcc rstate) 0) + (rtm-statep rstate) + (good-translation-gem-rtm gstate rstate m) + (in-range (pcc gstate) (code gstate)) + (assoc-equal (par1 (nth (pcc gstate) (code gstate))) m) + (true-listp m) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (assoc-equal gvar1 m) + (true-listp (rtmintvars-i gvar1 m)) + (not (equal gvar1 (par1 (nth (pcc gstate) (code gstate)))))) + (equal-get-cells + (rtmintvars-i gvar1 m) (mem rstate) (mem (execute-n-instructions rstate (* 2 (len *rns*)))))) + :hints (("Goal" :in-theory nil + :use ( (:instance rtm-variable-of-other-cell-untouched-equ + (idx1 (idx-different-cell + (rtmintvars-i gvar1 m) + (mem rstate) + (mem (execute-n-instructions rstate (* 2 (len *rns*)))))) ))) + ("Goal'" :cases ( (in-range + (idx-different-cell + (rtmintvars-i gvar1 m) + (mem rstate) + (mem (execute-n-instructions rstate (* 2 (len *rns*))))) + (rtmintvars-i gvar1 m)))) + ("Subgoal 2" :in-theory '((:rewrite if-bad-index-not-in-range-then-every-equal))) + ("Subgoal 1" :in-theory '((:forward-chaining if-bad-index-in-range-then-cells-must-be-different))))) + + + +(defthm properies-of-type-and-existence-of-current-args-equ + (implies + (and + (gem-statep gstate) + (in-range (pcc gstate) (code gstate)) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-equ)) + (and + (equal (var-type (get-cell (par1 (nth (pcc gstate) (code gstate))) (mem gstate))) 'Bool) + (assoc-equal (par1 (nth (pcc gstate) (code gstate))) (mem gstate)) + (assoc-equal (par2 (nth (pcc gstate) (code gstate))) (mem gstate)) + (assoc-equal (par3 (nth (pcc gstate) (code gstate))) (mem gstate)))) + :hints (("Goal" :in-theory (enable get-cell) + :use (:instance in-range-instruction-is-gem-instruction + (pcc (pcc gstate)) + (code (code gstate)) + (mem (mem gstate))))) + :rule-classes nil) + + +(defthm par1-of-current-instruction-is-into-mapping-equ + (implies + (and + (vars-inclusion (mem gstate) m) + (gem-statep gstate) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-equ) + (in-range (pcc gstate) (code gstate))) + (assoc-equal (par1 (nth (pcc gstate) (code gstate))) m)) + :hints (("Goal" :in-theory (enable get-cell) + :use (properies-of-type-and-existence-of-current-args-equ + (:instance inclusion-trans + (v (par1 (nth (pcc gstate) (code gstate)))) + (m1 (mem gstate)) + (m2 m)) + (:instance in-range-instruction-is-gem-instruction + (pcc (pcc gstate)) + (code (code gstate)) + (mem (mem gstate))))))) + + + + +(defthm teorema-main-con-pcc-in-range-su-variabile-non-interessata-final-equ + (implies + (and + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-equ) + (no-tmp-into-mapping m) + (m-entries-point-to-good-rtm-var-sets m (mem rstate)) + (good-translation-gem-rtm gstate rstate m) + (vars-inclusion (mem gstate) m) + (true-listp m) + (assoc-equal gvar1 m) + (gem-statep gstate) + (rtm-statep rstate) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (not (equal gvar1 (par1 (nth (pcc gstate) (code gstate))))) + (m-correspondent-values-p m (mem gstate) (mem rstate)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (correct-wrt-arity m (mem gstate))) + (equal-values-and-attributes + (get-cell gvar1 (mem (execute-instruction gstate))) + (rtmintvars-i gvar1 m) + (mem (execute-n-instructions rstate (* 2 (len *rns*)))) + (type-i gvar1 m))) + :hints (("Goal" + :in-theory '((:definition good-translation-gem-rtm)) + :use ( + par1-of-current-instruction-is-into-mapping-equ + (:instance correct-wrt-arity-has-rtmintvars-i-tl (mem (mem gstate))) + (:instance m-correspondent-values-implies-equal-values-and-attribus + (memgstate (mem gstate)) (memrstate (mem rstate))) + (:instance in-range (idx (pcc gstate)) (l (code gstate))) + (:instance in-range (idx (pcc rstate)) (l (code rstate))) + rtm-variables-of-other-cell-untouched-equ + teorema-main-con-pcc-in-range-su-variabile-non-interessata + (:instance equal-get-cells-implies-equal-values-and-attributes-still-works + (gemcell (get-cell gvar1 (mem gstate))) + (lcell (rtmintvars-i gvar1 m)) + (mem1 (mem rstate)) + (mem2 (mem (execute-n-instructions rstate (* 2 (len *rns*))))) + (type (type-i gvar1 m))))))) + + +(defthm posinrg-equ + (implies + (and + (vars-inclusion (mem gstate) m) + (gem-statep gstate) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-equ) + (in-range (pcc gstate) (code gstate))) + (and + (in-range (pos-equal-0 (par1 (nth (pcc gstate) (code gstate))) m) m) + (in-range (pos-equal-0 (par2 (nth (pcc gstate) (code gstate))) m) m) + (in-range (pos-equal-0 (par3 (nth (pcc gstate) (code gstate))) m) m))) + :hints (("Goal" :use (properies-of-type-and-existence-of-current-args-equ + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par1 (nth (pcc gstate) (code gstate))))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par2 (nth (pcc gstate) (code gstate))))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par3 (nth (pcc gstate) (code gstate))))) + (:instance assoc-means-pos-in-range + (el (par1 (nth (pcc gstate) (code gstate)))) + (l m)) + (:instance assoc-means-pos-in-range + (el (par2 (nth (pcc gstate) (code gstate)))) + (l m)) + (:instance assoc-means-pos-in-range + (el (par3 (nth (pcc gstate) (code gstate)))) + (l m))))) + :rule-classes nil) + + +(defthm equal-eq-update-norest-afetr-one-instr + (implies + (and + (gem-statep gstate) + (in-range (pcc gstate) (code gstate)) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-equ) + (good-translation-gem-rtm gstate rstate m) + (equal gvar1 (par1 (nth (pcc gstate) (code gstate)))) + (equal gvar2 (par2 (nth (pcc gstate) (code gstate)))) + (equal gvar3 (par3 (nth (pcc gstate) (code gstate))))) + (equal (get-cell gvar1 (mem (execute-instruction gstate))) + (gen-eq-update gvar1 gvar2 gvar3 (mem gstate)))) + :hints (("Goal" :in-theory (e/d (put-cell get-cell) + (par1 par2 par3 par4 opcode pcc code nth gem-instruction-list-p + gen-eq-update sum-and-update sub-and-update sub-and-update-norest sum-and-update-norest)))) + :rule-classes nil) + +(DEFTHM mem-cellity-of-current-gem-args-equ + (IMPLIES + (AND (GEM-STATEP GSTATE) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-equ) + (IN-RANGE (PCC GSTATE) (CODE GSTATE))) + (AND (is-mem-cell-p (get-cell (PAR1 (NTH (PCC GSTATE) (CODE GSTATE))) (mem gstate))) + (is-mem-cell-p (get-cell (PAR2 (NTH (PCC GSTATE) (CODE GSTATE))) (mem gstate))) + (is-mem-cell-p (get-cell (PAR3 (NTH (PCC GSTATE) (CODE GSTATE))) (mem gstate))))) + :HINTS + (("Goal" + :USE + (:INSTANCE IN-RANGE-INSTRUCTION-IS-GEM-INSTRUCTION + (PCC (PCC GSTATE)) + (CODE (CODE GSTATE)) + (MEM (MEM GSTATE)))))) + + + + +(DEFTHM + VAR-ATTRIBUTES-OF-1-VARIABLE-IS-ONE-ELEMENT-LIST-OF-VAR-ATTRIBUTE + (IMPLIES (AND (TRUE-LISTP VARS) + (EQUAL (LEN VARS) 1)) + (EQUAL (VAR-ATTRIBUTES VARS MEM) + (LIST (VAR-ATTRIBUTE (GET-CELL (CAR VARS) MEM))))) + :HINTS + (("Subgoal *1/2.2" + :USE + (:THEOREM (IMPLIES (AND (TRUE-LISTP VARS) + (EQUAL (LEN VARS) 1)) + (AND (EQUAL (LEN (CDR VARS)) 0) + (TRUE-LISTP (CDR VARS)))))))) + + +(defthm equal-values-and-attributes-in-boolean-case + (implies + (equal (type-expected rtmvars) 'Bool) + (equal + (equal-values-and-attributes gcell rtmvars rtmmem 'Bool) + (and + (equal + (var-value (get-cell (car rtmvars) rtmmem)) + (var-value gcell)) + (equal + (var-attribute gcell) + (var-attribute (get-cell (car rtmvars) rtmmem))))))) + + + + + +(defthm type-is-for-pars-equ + (implies + (and + (true-listp m) + (vars-inclusion (mem gstate) m) + (gem-statep gstate) + (correct-wrt-arity m (mem gstate)) + (equal gvar1 (par1 (nth (pcc gstate) (code gstate)))) + (equal gvar2 (par2 (nth (pcc gstate) (code gstate)))) + (equal gvar3 (par3 (nth (pcc gstate) (code gstate)))) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-equ) + (in-range (pcc gstate) (code gstate))) + (equal (type-i gvar1 m) 'bool)) + :hints (("Goal" + :in-theory nil ;(current-theory 'ground-zero) + :use ( properies-of-type-and-existence-of-current-args-equ + (:instance type-i-is-vartyper (gvar1 gvar1) (mem (mem gstate))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par1 (nth (pcc gstate) (code gstate)))))))) +:rule-classes nil) + + + + + +(defthm goal15 +(IMPLIES + (INTEGERP VAR-VALUE-GCELL2) + (EQUAL (BUILD-VALUES-BY-RNS-EXTENDED-FOR-NIL VAR-VALUE-GCELL2 + '(11 13 15 17 19)) + (LIST (MOD VAR-VALUE-GCELL2 11) + (MOD VAR-VALUE-GCELL2 13) + (MOD VAR-VALUE-GCELL2 15) + (MOD VAR-VALUE-GCELL2 17) + (MOD VAR-VALUE-GCELL2 19)))) +:hints (("Goal" :use ( + (:instance build-values-by-rns-extended-for-nil + (gem-value VAR-VALUE-GCELL2) + (rns '(11 13 15 17 19))) + (:instance build-values-by-rns-extended-for-nil + (gem-value VAR-VALUE-GCELL2) + (rns '(13 15 17 19))) + (:instance build-values-by-rns-extended-for-nil + (gem-value VAR-VALUE-GCELL2) + (rns '(15 17 19))) + (:instance build-values-by-rns-extended-for-nil + (gem-value VAR-VALUE-GCELL2) + (rns '(17 19))) + (:instance build-values-by-rns-extended-for-nil + (gem-value VAR-VALUE-GCELL2) + (rns '(19))) + (:instance build-values-by-rns-extended-for-nil + (gem-value VAR-VALUE-GCELL2) + (rns nil))))) +:rule-classes nil) + +(defthm var-values-of-n-list + (equal + (var-values (make-n-list gvar n) mem) + (make-n-list (var-value (get-cell gvar mem)) n)) + :rule-classes nil) + +(defthm make-n-list-expansion-5 + (equal + (make-n-list el 5) + (list el el el el el)) + :hints (("Goal" :use + ( (:instance make-n-list (n 5)) + (:instance make-n-list (n 4)) + (:instance make-n-list (n 3)) + (:instance make-n-list (n 2)) + (:instance make-n-list (n 1)) + (:instance make-n-list (n 0)) ) )) + :rule-classes nil) + + + +(defthm subgoal41 +(IMPLIES + (EQUAL (VAR-VALUE (GET-CELL RTMINTVARS-I-GVAR3 RTMMEM)) + 1) + (EQUAL (VAR-VALUES (MAKE-N-LIST RTMINTVARS-I-GVAR3 5) + RTMMEM) + '(1 1 1 1 1))) +:hints (("Goal" :use ( (:instance make-n-list-expansion-5 (el (VAR-VALUE (GET-CELL RTMINTVARS-I-GVAR3 RTMMEM)))) + (:instance var-values-of-n-list + (gvar RTMINTVARS-I-GVAR3) + (n 5) + (mem rtmmem))))) +:rule-classes nil) + +(defthm subgoal21 +(IMPLIES + (EQUAL (VAR-VALUE (GET-CELL RTMINTVARS-I-GVAR3 RTMMEM)) + 0) + (EQUAL (VAR-VALUES (MAKE-N-LIST RTMINTVARS-I-GVAR3 5) + RTMMEM) + '(0 0 0 0 0))) +:hints (("Goal" :use ( (:instance make-n-list-expansion-5 (el (VAR-VALUE (GET-CELL RTMINTVARS-I-GVAR3 RTMMEM)))) + (:instance var-values-of-n-list + (gvar RTMINTVARS-I-GVAR3) + (n 5) + (mem rtmmem))))) +:rule-classes nil) + + + +(defthm var-values-of-evmakelist-is-rns-anyway + (implies + (and + (is-mem-cell-p gcell2) + (equal (type-expected rtmintvars-i-gvar2) (var-type gcell2)) + (equal-values-and-attributes gcell2 rtmintvars-i-gvar2 rtmmem (var-type gcell2))) + (equal + (var-values (eventually-make-list rtmintvars-i-gvar2 (len *rns*)) rtmmem) + (build-values-by-rns (var-value gcell2) *rns*))) + :hints (("Goal" :in-theory (enable my-or-2)) + ("Subgoal 5'''" :use (:instance goal15 (var-value-gcell2 (var-value gcell2)))) +; fcd/Satriani v3.7 Moore - used to Subgoal 4.1 + ("Subgoal 1.1" :use subgoal41) +; fcd/Satriani v3.7 Moore - used to Subgoal 2.1 + ("Subgoal 3.1" :use subgoal21))) + + + +(defthm ax-on-rns-values + (implies + (and + (natp gval1) + (< gval1 (prod *rns*)) + (natp gval2) + (< gval2 (prod *rns*)) + (not (equal gval1 gval2))) + (not (equal (build-values-by-rns gval1 *rns*) (build-values-by-rns gval2 *rns*)))) + :hints (("Goal" :use ( fact-bout-rns + (:instance crt-inversion (val gval1) (rns *rns*)) + (:instance crt-inversion (val gval2) (rns *rns*)))))) + +(defthm hlp1 + (implies + (and + (is-mem-cell-p cell) + (bounded-value cell)) + (and + (natp (var-value cell)) + (< (var-value cell) (prod *rns*)))) + :rule-classes nil) + +(defthm equal-equality-of-var-values-euqlity-of-evlists + (implies + (and + (is-mem-cell-p gcell2) + (is-mem-cell-p gcell3) + (bounded-value gcell2) + (bounded-value gcell3) + (equal (type-expected rtmintvars-i-gvar2) (var-type gcell2)) + (equal (type-expected rtmintvars-i-gvar3) (var-type gcell3)) + (equal-values-and-attributes gcell2 rtmintvars-i-gvar2 rtmmem (var-type gcell2)) + (equal-values-and-attributes gcell3 rtmintvars-i-gvar3 rtmmem (var-type gcell3))) + (equal + (equal + (var-value gcell2) + (var-value gcell3) ) + (equal + (var-values (eventually-make-list rtmintvars-i-gvar2 (len *rns*)) rtmmem) + (var-values (eventually-make-list rtmintvars-i-gvar3 (len *rns*)) rtmmem)))) + :hints (("Goal" + :in-theory nil + :use + ( (:instance hlp1 (cell gcell2)) + (:instance hlp1 (cell gcell3)) + (:instance ax-on-rns-values + (gval1 (var-value gcell2)) + (gval2 (var-value gcell3))) + (:instance var-values-of-evmakelist-is-rns-anyway + (gcell2 gcell2) + (rtmintvars-i-gvar2 rtmintvars-i-gvar2)) + (:instance var-values-of-evmakelist-is-rns-anyway + (gcell2 gcell3) + (rtmintvars-i-gvar2 rtmintvars-i-gvar3)))))) + +(in-theory (disable ax-on-rns-values)) + + + + + +(defthm length-of-makelist-n + (implies + (and + (integerp n) + (>= n 0)) + (equal (len (make-n-list l n)) n))) + +(defthm if-type-exepcted-is-ok-eventually-always-has-len-of-rns + (implies + (my-or-2 + (equal (type-expected l) 'Bool) + (equal (type-expected l) 'Int)) + (equal (len (eventually-make-list l (len *rns*))) (len *rns*)))) + +(defthm tmp-never-appears + (implies + (and + (no-tmp-into-mapping m) + (assoc-equal gvar1 m)) + (not (member-equal-bool 'tmp (eventually-make-list (rtmintvars-i gvar1 m) n)))) + :hints (("Goal" :in-theory (enable rtmintvars-0)))) + +(defthm tmp-never-appears-simple + (implies + (and + (no-tmp-into-mapping m) + (assoc-equal gvar1 m)) + (not (member-equal-bool 'tmp (rtmintvars-i gvar1 m) ))) + :hints (("Goal" :in-theory (enable rtmintvars-0)))) + +(defthm type-of-a-mem-cell + (implies + (is-mem-cell-p cell) + (my-or-2 + (equal (var-type cell) 'Bool) + (equal (var-type cell) 'Int))) + :hints (("Goal" :in-theory (enable my-or-2))) + :rule-classes nil) + + +(defthm sillllly + (equal (make-n-list l1 1) (list l1)) + :hints (("Goal" :use (:instance make-n-list (el l1) (n 1)))) + :rule-classes nil) + +; Added by Matt K. for v3-5. Heuristic changes to linear arithmetic were +; preventing the next lemma, not-member-equal-bool-holds-on-ev, from going +; through. But the original proof involved generalization and three levels of +; induction, so rather than investigate further, we'll just prove the following +; lemma. With it, the proof of not-member-equal-bool-holds-on-ev goes through +; without :hints. +(local + (defthm helper-from-matt-k + (implies (not (equal el l1)) + (not (member-equal-bool el (make-n-list l1 n)))))) + +(defthm not-member-equal-bool-holds-on-ev + (implies + (and + (integerp n) + (> n 0) + (not (member-equal-bool el l))) + (not (member-equal-bool el (eventually-make-list l n)))) + :hints (("Subgoal *1.1/4''" :use sillllly) ; Modified for v2-6 by Matt K. + ("Subgoal *1.1/4.1" :use sillllly)) + :rule-classes nil) + +(defthm not-memb-1 + (implies + (and + (true-listp m) + (equal (len (rtmintvars-i gvar1 m)) 1) + (assoc-equal gvar1 m) + (assoc-equal gvar2 m) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (not (equal gvar1 gvar2))) + (not (member-equal-bool + (car (rtmintvars-i gvar1 m)) + (rtmintvars-i gvar2 m)))) + :hints (("Goal" + :use ( (:instance lemma1-different-vars-do-not-belong (idx1 0))))) + :rule-classes nil) + +(defthm not-memb-2 + (implies + (and + (true-listp m) + (equal (len (rtmintvars-i gvar1 m)) 1) + (assoc-equal gvar1 m) + (assoc-equal gvar2 m) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (not (equal gvar1 gvar2))) + (not (member-equal-bool + (car (rtmintvars-i gvar1 m)) + (eventually-make-list (rtmintvars-i gvar2 m) (len *rns*))))) + :hints (("Goal" + :use ( not-memb-1 + (:instance not-member-equal-bool-holds-on-ev + (el (car (rtmintvars-i gvar1 m))) + (l (rtmintvars-i gvar2 m)) + (n (len *rns*)))))) + :rule-classes nil) + + +(defthm eq-and-update-behaviour + (and + (equal + (var-value (gen-eq-update c1 c2 c3 mem)) + (boolean-to-int (equal + (var-value (get-cell c2 mem)) + (var-value (get-cell c3 mem))))) + (equal + (var-attribute (gen-eq-update c1 c2 c3 mem)) + (var-attribute (get-cell c1 mem)))) + :hints (("Goal" :in-theory (enable var-value var-attribute)))) + + +(defthm var-attribute-of-a-var-is-same-after-n-steps + (implies + (rtm-statep st) + (equal (var-attribute (get-cell anyvar (mem st))) + (var-attribute (get-cell anyvar (mem (execute-n-instructions st n)))))) + :hints (("Goal" + :induct (execute-n-instructions st n) + :in-theory (disable rtm-statep execute-instruction)) + ("Subgoal *1/2" + :use + ( + (:instance execute-instruction-is-type-and-attribute-invariant-on-any-var (cell anyvar)) + executing-rtm-instruction-retrieves-a-rtm-state-from-rtm-state)))) + + +(defthm bool-to-int-strip + (iff + (equal (boolean-to-int (equal a b)) (boolean-to-int (equal-values c d))) + (equal (equal a b) (equal c d)))) + + +(defthm equal-equality-of-var-values-euqlity-of-evlists-2 + (implies + (and + (is-mem-cell-p gcell2) + (is-mem-cell-p gcell3) + (bounded-value gcell2) + (bounded-value gcell3) + (equal (type-expected rtmintvars-i-gvar2) (var-type gcell2)) + (equal (type-expected rtmintvars-i-gvar3) (var-type gcell3)) + (equal-values-and-attributes gcell2 rtmintvars-i-gvar2 rtmmem (var-type gcell2)) + (equal-values-and-attributes gcell3 rtmintvars-i-gvar3 rtmmem (var-type gcell3))) + (equal + (boolean-to-int + (equal + (var-value gcell2) + (var-value gcell3) )) + (boolean-to-int + (equal-values + (var-values (eventually-make-list rtmintvars-i-gvar2 (len *rns*)) rtmmem) + (var-values (eventually-make-list rtmintvars-i-gvar3 (len *rns*)) rtmmem))))) + :hints (("Goal" + :in-theory nil + :use + ((:instance bool-to-int-strip + (a (var-value gcell2)) + (b (var-value gcell3)) + (c (var-values (eventually-make-list rtmintvars-i-gvar2 (len *rns*)) rtmmem)) + (d (var-values (eventually-make-list rtmintvars-i-gvar3 (len *rns*)) rtmmem))) + equal-equality-of-var-values-euqlity-of-evlists)))) + + + +(defthm sil-support-2 + (implies + (and + (integerp n) + (> n 0) + (or + (equal (type-expected l) 'Bool) + (equal (type-expected l) 'Int))) + (not (endp (eventually-make-list l n)))) + :hints (("Subgoal *1.1/3'" :use sillllly)) + :otf-flg t) + +(defthm sil-support-3 + (implies + (my-or-2 + (equal (type-expected l) 'Bool) + (equal (type-expected l) 'Int)) + (not (endp (eventually-make-list l (len *rns*))))) + :hints (("Goal" :use (:instance sil-support-2 (n (len *rns*)))))) + + +(defthm not-in-car-if-no-memb + (implies + (and + (equal (len l) 1) + (not (member-equal-bool 'tmp l))) + (not (equal 'tmp (car l))))) + +(defthm sil-support-1 + (implies + (equal (type-i gvar1 m) 'bool) + (equal (LEN (RTMINTVARS-I gvar1 m)) 1))) + + +(defthm bounded-are-bounded + (implies + (and + (bounded-amem-p mem) + (assoc-equal cell mem)) + (bounded-value (get-cell cell mem))) + :hints (("Goal" :in-theory (enable get-cell))) + :rule-classes nil) + + + + +(defthm m-correspondence-kept-on-same-gvar-equ + (implies + (and + (NOT (ENDP (EVENTUALLY-MAKE-LIST + (RTMINTVARS-I (PAR2 (NTH (PCC GSTATE) (CODE GSTATE))) + M) + (LEN '(11 13 15 17 19))))) + (NOT (EQUAL 'TMP + (CAR (RTMINTVARS-I (PAR1 (NTH (PCC GSTATE) (CODE GSTATE))) + M)))) + (EQUAL (LEN (RTMINTVARS-I (PAR1 (NTH (PCC GSTATE) (CODE GSTATE))) M)) 1) + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-equ) + (no-tmp-into-mapping m) + (good-translation-gem-rtm gstate rstate m) + (vars-inclusion (mem gstate) m) + (true-listp m) + (assoc-equal gvar1 m) + (gem-statep gstate) + (rtm-statep rstate) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (equal gvar1 (par1 (nth (pcc gstate) (code gstate)))) + (m-correspondent-values-p m (mem gstate) (mem rstate)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (correct-wrt-arity m (mem gstate))) + (equal-values-and-attributes + (get-cell gvar1 (mem (execute-instruction gstate))) + (rtmintvars-i gvar1 m) + (mem (execute-n-instructions rstate (* 2 (len *rns*)))) + (type-i gvar1 m))) + :hints (("Goal" :in-theory nil + :use ( + (:instance gem-statep (x gstate)) + (:instance bounded-are-bounded (cell (par2 (nth (pcc gstate) (code gstate)))) (mem (mem gstate))) + (:instance bounded-are-bounded (cell (par3 (nth (pcc gstate) (code gstate)))) (mem (mem gstate))) + (:instance eq-and-update-behaviour + (c1 gvar1) + (c2 (par2 (nth (pcc gstate) (code gstate)))) + (c3 (par3 (nth (pcc gstate) (code gstate)))) + (mem (mem gstate))) + (:instance var-attribute-of-a-var-is-same-after-n-steps + (st rstate) + (anyvar (car (rtmintvars-i (par1 (nth (pcc gstate) (code gstate))) m))) + (n (* 2 (len *rns*)))) + (:instance in-range (idx (pcc gstate)) (l (code gstate))) + (:instance not-memb-2 + (gvar1 (par1 (nth (pcc gstate) (code gstate)))) + (gvar2 (par2 (nth (pcc gstate) (code gstate))))) + (:instance not-memb-2 + (gvar1 (par1 (nth (pcc gstate) (code gstate)))) + (gvar2 (par3 (nth (pcc gstate) (code gstate))))) + (:instance type-of-a-mem-cell (cell (get-cell (par2 (nth (pcc gstate) (code gstate))) (mem gstate)))) + (:instance type-of-a-mem-cell (cell (get-cell (par3 (nth (pcc gstate) (code gstate))) (mem gstate)))) + properies-of-type-and-existence-of-current-args-equ + mem-cellity-of-current-gem-args-equ + good-translation-gem-rtm + (:instance tmp-never-appears (n (len *rns*)) (gvar1 (par2 (nth (pcc gstate) (code gstate))))) + (:instance tmp-never-appears (n (len *rns*)) (gvar1 (par3 (nth (pcc gstate) (code gstate))))) + (:instance if-type-exepcted-is-ok-eventually-always-has-len-of-rns + (l (rtmintvars-i (par2 (nth (pcc gstate) (code gstate))) m))) + (:instance if-type-exepcted-is-ok-eventually-always-has-len-of-rns + (l (rtmintvars-i (par3 (nth (pcc gstate) (code gstate))) m))) + (:instance type-i-is-vartyper (gvar1 gvar1) (mem (mem gstate))) + (:instance type-i-is-vartyper (gvar1 (par2 (nth (pcc gstate) (code gstate)))) (mem (mem gstate))) + (:instance type-i-is-vartyper (gvar1 (par3 (nth (pcc gstate) (code gstate)))) (mem (mem gstate))) + (:instance type-i-is-type-expected (gvar gvar1) (mem (mem gstate))) + (:instance type-i-is-type-expected (gvar (par2 (nth (pcc gstate) (code gstate)))) (mem (mem gstate))) + (:instance type-i-is-type-expected (gvar (par3 (nth (pcc gstate) (code gstate)))) (mem (mem gstate))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par1 (nth (pcc gstate) (code gstate))))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par2 (nth (pcc gstate) (code gstate))))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par3 (nth (pcc gstate) (code gstate))))) + (:instance + equal-eq-update-norest-afetr-one-instr + (gvar2 (par2 (nth (pcc gstate) (code gstate)))) + (gvar3 (par3 (nth (pcc gstate) (code gstate)))) + ) + (:instance type-is-for-pars-equ + (gvar2 (par2 (nth (pcc gstate) (code gstate)))) + (gvar3 (par3 (nth (pcc gstate) (code gstate))))) + (:instance equal-values-and-attributes-in-boolean-case + (rtmvars (rtmintvars-i gvar1 m)) + (gcell (get-cell gvar1 (mem gstate))) + (rtmmem (mem rstate))) + (:instance equal-values-and-attributes-in-boolean-case + (rtmvars (rtmintvars-i gvar1 m)) + (gcell (get-cell gvar1 (mem (execute-instruction gstate)))) + (rtmmem (mem (execute-n-instructions rstate (* 2 (len *rns*)))))) + (:instance m-correspondent-values-implies-equal-values-and-attribus + (memgstate (mem gstate)) (memrstate (mem rstate)) + (gvar1 (par1 (nth (pcc gstate) (code gstate))))) + (:instance m-correspondent-values-implies-equal-values-and-attribus + (memgstate (mem gstate)) (memrstate (mem rstate)) + (gvar1 (par2 (nth (pcc gstate) (code gstate))))) + (:instance m-correspondent-values-implies-equal-values-and-attribus + (memgstate (mem gstate)) (memrstate (mem rstate)) + (gvar1 (par3 (nth (pcc gstate) (code gstate))))) + (:instance value-of-result-after-executing-2n-+2instr-finale + (tmp 'tmp) + (res (car (rtmintvars-i (par1 (nth (pcc gstate) (code gstate))) m))) + (listvars1 (eventually-make-list (rtmintvars-i (par2 (nth (pcc gstate) (code gstate))) m) (len *rns*))) + (listvars2 (eventually-make-list (rtmintvars-i (par3 (nth (pcc gstate) (code gstate))) m) (len *rns*))) + (st rstate)) + (:instance equal-equality-of-var-values-euqlity-of-evlists-2 + (gcell2 (get-cell (par2 (nth (pcc gstate) (code gstate))) (mem gstate))) + (gcell3 (get-cell (par3 (nth (pcc gstate) (code gstate))) (mem gstate))) + (rtmintvars-i-gvar2 (rtmintvars-i (par2 (nth (pcc gstate) (code gstate))) m)) + (rtmintvars-i-gvar3 (rtmintvars-i (par3 (nth (pcc gstate) (code gstate))) m)) + (rtmmem (mem rstate))))))) + + +(defthm m-correspondence-kept-on-same-gvar-equ-supp + (implies + (and + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-equ) + (no-tmp-into-mapping m) + (equal gvar1 (par1 (nth (pcc gstate) (code gstate)))) + (assoc-equal gvar1 m) + (vars-inclusion (mem gstate) m) + (true-listp m) + (gem-statep gstate) + (rtm-statep rstate) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (correct-wrt-arity m (mem gstate))) + (and + (NOT (ENDP (EVENTUALLY-MAKE-LIST + (RTMINTVARS-I (PAR2 (NTH (PCC GSTATE) (CODE GSTATE))) + M) + (LEN '(11 13 15 17 19))))) + (NOT (EQUAL 'TMP + (CAR (RTMINTVARS-I (PAR1 (NTH (PCC GSTATE) (CODE GSTATE))) + M)))) + (EQUAL (LEN (RTMINTVARS-I (PAR1 (NTH (PCC GSTATE) (CODE GSTATE))) M)) 1))) + :hints (("Goal" :in-theory nil + :use ( + (:instance sil-support-3 (l (RTMINTVARS-I (PAR2 (NTH (PCC GSTATE) (CODE GSTATE))) M) )) + (:instance not-in-car-if-no-memb (l (RTMINTVARS-I (PAR1 (NTH (PCC GSTATE) (CODE GSTATE))) m))) + (:instance sil-support-1 (gvar1 (PAR1 (NTH (PCC GSTATE) (CODE GSTATE))))) + (:instance in-range (idx (pcc gstate)) (l (code gstate))) + (:instance type-of-a-mem-cell (cell (get-cell (par2 (nth (pcc gstate) (code gstate))) (mem gstate)))) + (:instance type-of-a-mem-cell (cell (get-cell (par3 (nth (pcc gstate) (code gstate))) (mem gstate)))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par1 (nth (pcc gstate) (code gstate))))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par2 (nth (pcc gstate) (code gstate))))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par3 (nth (pcc gstate) (code gstate))))) + properies-of-type-and-existence-of-current-args-equ + mem-cellity-of-current-gem-args-equ + (:instance tmp-never-appears-simple (gvar1 (par1 (nth (pcc gstate) (code gstate))))) + (:instance type-i-is-vartyper (gvar1 gvar1) (mem (mem gstate))) + (:instance type-i-is-vartyper (gvar1 (par2 (nth (pcc gstate) (code gstate)))) (mem (mem gstate))) + (:instance type-i-is-vartyper (gvar1 (par3 (nth (pcc gstate) (code gstate)))) (mem (mem gstate))) + (:instance type-i-is-type-expected (gvar gvar1) (mem (mem gstate))) + (:instance type-i-is-type-expected (gvar (par2 (nth (pcc gstate) (code gstate)))) (mem (mem gstate))) + (:instance type-i-is-type-expected (gvar (par3 (nth (pcc gstate) (code gstate)))) (mem (mem gstate))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par1 (nth (pcc gstate) (code gstate))))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par2 (nth (pcc gstate) (code gstate))))) + (:instance inclusion-trans (m1 (mem gstate)) (m2 m) + (v (par3 (nth (pcc gstate) (code gstate))))) + (:instance type-is-for-pars-equ + (gvar2 (par2 (nth (pcc gstate) (code gstate)))) + (gvar3 (par3 (nth (pcc gstate) (code gstate))))))))) + + + +(defthm equal-values-correspondence-kept-by-any-execution-equ + (implies + (and + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-equ) + (no-tmp-into-mapping m) + (good-translation-gem-rtm gstate rstate m) + (vars-inclusion (mem gstate) m) + (true-listp m) + (assoc-equal gvar1 m) + (gem-statep gstate) + (rtm-statep rstate) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (m-correspondent-values-p m (mem gstate) (mem rstate)) + (M-ENTRIES-POINT-TO-GOOD-RTM-VAR-SETS M (MEM RSTATE)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (correct-wrt-arity m (mem gstate))) + (equal-values-and-attributes + (get-cell gvar1 (mem (execute-instruction gstate))) + (rtmintvars-i gvar1 m) + (mem (execute-n-instructions rstate (* 2 (len *rns*)))) + (type-i gvar1 m))) + :hints (("Goal" :in-theory nil + :use (m-correspondence-kept-on-same-gvar-equ + m-correspondence-kept-on-same-gvar-equ-supp + teorema-main-con-pcc-in-range-su-variabile-non-interessata-final-equ)))) + + +(defthm rtmintvars-i-iscdrnth + (implies + (and + (true-listp m) + (in-range idx m) + (no-duplicates-p (retrieve-gemvars m))) + (equal (rtmintvars-i (car (nth idx m)) m) + (cdr (nth idx m)))) + :hints (("Goal" + :in-theory nil + :use ( + (:instance no-duplicates-has-pos-equal-right-in-that-place (l m)) + (:instance rtmintvars-i-is-cdr-of-nth-entry (gvar (car (nth idx m)))))))) + +(defthm type-i-is-typeidx + (implies + (and + (true-listp m) + (in-range idx m) + (no-duplicates-p (retrieve-gemvars m))) + (equal (type-i (car (nth idx m)) m) + (type-i-idx m idx)))) + + + +(defthm equal-values-correspondence-kept-by-any-execution-idxed-equ + (implies + (and + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-equ) + (no-tmp-into-mapping m) + (good-translation-gem-rtm gstate rstate m) + (vars-inclusion (mem gstate) m) + (alistp m) + (in-range idx m) + (gem-statep gstate) + (rtm-statep rstate) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (m-correspondent-values-p m (mem gstate) (mem rstate)) + (M-ENTRIES-POINT-TO-GOOD-RTM-VAR-SETS M (MEM RSTATE)) + (no-duplicates-p (retrieve-gemvars m)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (correct-wrt-arity m (mem gstate))) + (equal-values-and-attributes + (get-cell (car (nth idx m)) (mem (execute-instruction gstate))) + (cdr (nth idx m)) + (mem (execute-n-instructions rstate (* 2 (len *rns*)))) + (type-i-idx m idx))) + :hints (("Subgoal 2" :in-theory nil) + ("Goal" :in-theory (union-theories (current-theory 'ground-zero) + '((:definition in-range))) + :use ( (:theorem + (implies + (and + (alistp m) + (in-range idx m)) + (and + (true-listp m) + (assoc-equal (car (nth idx m)) m)))) + + rtmintvars-i-iscdrnth + type-i-is-typeidx + (:instance equal-values-correspondence-kept-by-any-execution-equ (gvar1 (car (nth idx m))))))) + :otf-flg t) + + + + +(defthm m-correspondence-kept-by-any-execution-idxed-equ + (implies + (and + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-equ) + (no-tmp-into-mapping m) + (good-translation-gem-rtm gstate rstate m) + (vars-inclusion (mem gstate) m) + (alistp m) + (gem-statep gstate) + (rtm-statep rstate) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (m-correspondent-values-p m (mem gstate) (mem rstate)) + (M-ENTRIES-POINT-TO-GOOD-RTM-VAR-SETS M (MEM RSTATE)) + (no-duplicates-p (retrieve-gemvars m)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (correct-wrt-arity m (mem gstate))) + (m-correspondent-values-p + m + (mem (execute-instruction gstate)) + (mem (execute-n-instructions rstate (* 2 (len *rns*)))))) + :hints (("Goal" :use (:instance equal-values-correspondence-kept-by-any-execution-idxed-equ + (idx (bad-idx-eqv-va m + (mem (execute-instruction gstate)) + (mem (execute-n-instructions rstate (* 2 (len *rns*)))))))) + ("Goal'" :cases ( (in-range (bad-idx-eqv-va m (mem (execute-instruction gstate)) + (mem (execute-n-instructions rstate (* 2 (len *rns*))))) m))) + ("Subgoal 2" :in-theory '((:forward-chaining alistp-forward-to-true-listp) + (:rewrite if-bad-index-not-in-range-then-m-corr))) + ("Subgoal 1" :in-theory '((:rewrite if-bad-index-in-range-thne-must-be-different-vs))))) + + + +(defthm m-correspondence-and-other-conditions-kept-by-any-execution-idxed-equ + (implies + (and + (equal (opcode (nth (pcc gstate) (code gstate))) 'gem-equ) + (no-tmp-into-mapping m) + (good-translation-gem-rtm gstate rstate m) + (vars-inclusion (mem gstate) m) + (vars-inclusion m (mem gstate)) + (alistp m) + (gem-statep gstate) + (rtm-statep rstate) + (in-range (pcc gstate) (code gstate)) + (in-range (pcc rstate) (code rstate)) + (m-correspondent-values-p m (mem gstate) (mem rstate)) + (M-ENTRIES-POINT-TO-GOOD-RTM-VAR-SETS M (MEM RSTATE)) + (no-duplicates-p (retrieve-gemvars m)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (correct-wrt-arity m (mem gstate))) + (and + (good-translation-gem-rtm (execute-instruction gstate) (execute-n-instructions rstate (* 2 (len *rns*))) m) + (rtm-statep (execute-n-instructions rstate (* 2 (len *rns*)))) + (m-entries-point-to-good-rtm-var-sets m (mem (execute-n-instructions rstate (* 2 (len *rns*))))) + (gem-statep (execute-instruction gstate)) + (correct-wrt-arity m (mem (execute-instruction gstate))) + (vars-inclusion (mem (execute-instruction gstate)) m) + (vars-inclusion m (mem (execute-instruction gstate))) + (m-correspondent-values-p + m + (mem (execute-instruction gstate)) + (mem (execute-n-instructions rstate (* 2 (len *rns*))))))) + :hints (("Goal" + :in-theory ;nil + (disable + rtm-statep gem-statep + pcc code opcode + execute-instruction rtmintvars-i par1 par2 par3 nth len member-equal) + :use + (m-correspondence-kept-by-any-execution-idxed-equ + good-translation-gem-rtm + (:instance execute-n-instructions-keeps-rtm-state-and-points-to-good + (st rstate) (n (* 2 (len *rns*)))) + (:instance executing-gem-instruction-retrieves-a-gem-state-from-gem-state (st gstate)) + (:instance executing-gem-instruction-preserves-correctness-wrt-arity (st gstate)) + (:instance executing-gem-instruction-keeps-vars-inclusion-right (st gstate)) + (:instance executing-gem-instruction-keeps-vars-inclusion-left (st gstate)))))) + + + +(encapsulate + () +;;; Modified 12/24/2014 to avoid the nu-rewriter, which is being eliminated. +; (set-nu-rewriter-mode nil) ; to avoid skip-proofs below + (defthm after-n-instructions-out-of-range-rtmstate-untouched + (implies + (and + (rtm-statep rstate) + (>= (pcc rstate) (len (code rstate)))) + (equal (execute-n-instructions rstate n) rstate)) + :hints (("Goal" :in-theory (enable execute-not-in-range-instruction-retrieves-same-state))))) + + + +(defun correspondent-steps-to-current-gem-instruction (gstate) + (case (opcode (nth (pcc gstate) (code gstate))) + (gem-add (len *rns*)) + (gem-sub (len *rns*)) + (gem-equ (* 2 (len *rns*))) + (otherwise 0))) + + + +(defun correspondent-steps (n gstate) + (if (zp n) + 0 + (+ (correspondent-steps-to-current-gem-instruction gstate) + (correspondent-steps (1- n) (execute-instruction gstate))))) + + + + + +(defthm m-correspondence-and-other-conditions-kept-by-out-of-range-execution-2 + (implies + (and + (alistp m) + (no-duplicates-p (retrieve-gemvars m)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (good-translation-gem-rtm gstate rstate m) + (correct-wrt-arity m (mem gstate)) + (gem-statep gstate) + (rtm-statep rstate) + (vars-inclusion (mem gstate) m) + (vars-inclusion m (mem gstate)) + (not (in-range (pcc gstate) (code gstate))) + (>= (pcc gstate) 0) + (>= (pcc rstate) (len (code rstate))) + (m-entries-point-to-good-rtm-var-sets m (mem rstate)) + (m-correspondent-values-p m (mem gstate) (mem rstate))) + (and + (good-translation-gem-rtm + (execute-instruction gstate) + (execute-n-instructions rstate + (correspondent-steps-to-current-gem-instruction gstate)) m) + (rtm-statep (execute-n-instructions rstate (correspondent-steps-to-current-gem-instruction gstate))) + (m-entries-point-to-good-rtm-var-sets + m + (mem (execute-n-instructions rstate (correspondent-steps-to-current-gem-instruction gstate)))) + (gem-statep (execute-instruction gstate)) + (correct-wrt-arity m (mem (execute-instruction gstate))) + (vars-inclusion (mem (execute-instruction gstate)) m) + (vars-inclusion m (mem (execute-instruction gstate))) + (m-correspondent-values-p + m + (mem (execute-instruction gstate)) + (mem (execute-n-instructions rstate (correspondent-steps-to-current-gem-instruction gstate)))))) + :hints (("Goal" + :in-theory '((in-range)) + :use + ( + (:instance after-n-instructions-out-of-range-rtmstate-untouched + (n (correspondent-steps-to-current-gem-instruction gstate))) + (:instance execute-not-in-range-instruction-retrieves-same-state (st gstate)))))) + + + + + +(defthm m-correspondence-and-other-conditions-kept-execution-2 + (implies + (and + (alistp m) + (no-tmp-into-mapping m) + (no-duplicates-p (retrieve-gemvars m)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (good-translation-gem-rtm gstate rstate m) + (correct-wrt-arity m (mem gstate)) + (gem-statep gstate) + (rtm-statep rstate) + (vars-inclusion (mem gstate) m) + (vars-inclusion m (mem gstate)) + (>= (pcc gstate) 0) + (m-entries-point-to-good-rtm-var-sets m (mem rstate)) + (m-correspondent-values-p m (mem gstate) (mem rstate))) + (and + (>= (pcc (execute-instruction gstate)) 0) + (good-translation-gem-rtm + (execute-instruction gstate) + (execute-n-instructions rstate (correspondent-steps-to-current-gem-instruction gstate)) m) + (rtm-statep (execute-n-instructions rstate (correspondent-steps-to-current-gem-instruction gstate))) + (m-entries-point-to-good-rtm-var-sets + m + (mem (execute-n-instructions rstate (correspondent-steps-to-current-gem-instruction gstate)))) + (gem-statep (execute-instruction gstate)) + (correct-wrt-arity m (mem (execute-instruction gstate))) + (vars-inclusion (mem (execute-instruction gstate)) m) + (vars-inclusion m (mem (execute-instruction gstate))) + (m-correspondent-values-p + m + (mem (execute-instruction gstate)) + (mem (execute-n-instructions rstate (correspondent-steps-to-current-gem-instruction gstate)))))) + :hints (("Goal" :in-theory '((:definition in-range)) + :use ((:instance instruction-incrementing-pvv (st gstate)) + correspondent-steps-to-current-gem-instruction + good-translation-gem-rtm + m-correspondence-and-other-conditions-kept-by-out-of-range-execution-2 + m-correspondence-and-other-conditions-kept-by-any-execution-add + m-correspondence-and-other-conditions-kept-by-any-execution-sub + m-correspondence-and-other-conditions-kept-by-any-execution-idxed-equ)))) + + + + + + + + + + + + + + +(defun parallel-exec (gstate rstate n) + (if (zp n) + (list gstate rstate) + (parallel-exec + (execute-instruction gstate) + (execute-n-instructions rstate (correspondent-steps-to-current-gem-instruction gstate)) + (1- n)))) + + + + + + + + + + + + +(defthm m-correspondence-and-other-conditions-kept-execution-on-n + (implies + (and + (integerp n) + (>= n 0) + (alistp m) + (no-duplicates-p (retrieve-gemvars m)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (no-tmp-into-mapping m) + (good-translation-gem-rtm gstate rstate m) + (correct-wrt-arity m (mem gstate)) + (gem-statep gstate) + (rtm-statep rstate) + (vars-inclusion (mem gstate) m) + (vars-inclusion m (mem gstate)) + (>= (pcc gstate) 0) + (m-entries-point-to-good-rtm-var-sets m (mem rstate)) + (m-correspondent-values-p m (mem gstate) (mem rstate))) + (and + (>= (pcc (execute-n-instructions gstate n)) 0) + (good-translation-gem-rtm + (execute-n-instructions gstate n) + (execute-n-instructions rstate (correspondent-steps n gstate)) m) + (rtm-statep (execute-n-instructions rstate (correspondent-steps n gstate))) + (m-entries-point-to-good-rtm-var-sets + m + (mem (execute-n-instructions rstate (correspondent-steps n gstate)))) + (gem-statep (execute-n-instructions gstate n)) + (correct-wrt-arity m (mem (execute-n-instructions gstate n))) + (vars-inclusion (mem (execute-n-instructions gstate n)) m) + (vars-inclusion m (mem (execute-n-instructions gstate n))) + (m-correspondent-values-p + m + (mem (execute-n-instructions gstate n)) + (mem (execute-n-instructions rstate (correspondent-steps n gstate)))))) + :hints (("Goal" :in-theory + ;(current-theory 'ground-zero) + (disable executing-gem-instruction-preserves-correctness-wrt-arity + execute-instruction-is-type-and-attribute-invariant-on-any-var + ;executing-gem-instruction-is-type-attribute-invariant + executing-gem-instruction-keeps-vars-inclusion-left + executing-gem-instruction-keeps-vars-inclusion-right + execute-n-instructions-keeps-rtm-state-and-points-to-good + correspondent-steps-to-current-gem-instruction + execute-n-instructions-tantamount-to-add-list-e + m-correspondence-and-other-conditions-kept-by-any-execution-add + m-correspondence-and-other-conditions-kept-by-any-execution-sub + m-correspondence-and-other-conditions-kept-by-any-execution-idxed-equ + m-correspondence-and-other-conditions-kept-by-out-of-range-execution-2 + executing-gem-instruction-retrieves-a-gem-state-from-gem-state + executing-rtm-instruction-retrieves-a-rtm-state-from-rtm-state + instruction-incrementing-pvv + good-translation-gem-rtm + all-rtm-adds-for-n-steps + null-opcode-implies-execution-does-not-touch-state + bad-idx-eqv-va + mem pcc code opcode retrieve-rtmvars gem-statep rtm-statep execute-instruction) + :induct (parallel-exec gstate rstate n)) + ("Subgoal *1/2" :use + ( + (:instance execute-n-instruction-decomposition + (n1 (correspondent-steps (1- n) gstate)) + (n2 (correspondent-steps-to-current-gem-instruction gstate)) + (st rstate)) + (:instance m-correspondence-and-other-conditions-kept-execution-2 + (gstate (execute-instruction gstate)) + (rstate (execute-n-instructions rstate (correspondent-steps-to-current-gem-instruction gstate)))))))) + + + + +(defthm simple-fact-about-initial-gemstate + (implies + (gem-program-p gemprog) + (and + (>= (pcc (initial-state gemprog)) 0) + (gem-statep (initial-state gemprog))))) + +(defthm simple-fact-about-initial-rtmstate + (implies + (rtm-program-p rtmprog) + (and + (>= (pcc (initial-state rtmprog)) 0) + (rtm-statep (initial-state rtmprog))))) + + +(defun good-mapping (m) + (and + (alistp m) + (no-tmp-into-mapping m) + (no-duplicates-p (retrieve-gemvars m)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))))) + +(defun good-mapping-wrt-memories (m mem-gstate mem-rstate) + (and + (correct-wrt-arity m mem-gstate) + (vars-inclusion mem-gstate m) + (vars-inclusion m mem-gstate) + (m-entries-point-to-good-rtm-var-sets m mem-rstate) + (m-correspondent-values-p m mem-gstate mem-rstate))) + + + + +(defun correct-translation (gemprog rtmprog m) + (good-translation-gem-rtm (initial-state gemprog) (initial-state rtmprog) m)) + + +(defthm execution-of-correctly-translated-gem-and-rtm-yields-same-output + (let + ((gstate (initial-state gemprog)) + (rstate (initial-state rtmprog)) + (n (len (code gstate)))) + (implies + (and + (gem-program-p gemprog) + (rtm-program-p rtmprog) + (good-mapping m) + (good-mapping-wrt-memories m (mem gstate) (mem rstate)) + (correct-translation gemprog rtmprog m)) + (equal-memories + (decode m (projectio (mem (execute-n-instructions rstate (correspondent-steps n gstate))) attr)) + (projectio (mem (execute-n-instructions gstate n)) attr)))) + :hints (("Goal" + :in-theory (union-theories (current-theory 'ground-zero) + '((:rewrite equalities-on-io) + (:definition correct-translation) + (:definition good-mapping-wrt-memories) + (:definition gem-statep) + (:definition rtm-statep) + (:definition good-mapping))) + :use + ( + fact-bout-rns + simple-fact-about-initial-rtmstate + simple-fact-about-initial-gemstate + (:instance m-correspondence-and-other-conditions-kept-execution-on-n + (gstate (initial-state gemprog)) + (rstate (initial-state rtmprog)) + (n (len (code gstate)))))))) + + diff --git a/books/workshops/1999/embedded/Proof-Of-Contribution/Proof-Of-Correctness.lisp b/books/workshops/1999/embedded/Proof-Of-Contribution/Proof-Of-Correctness.lisp new file mode 100644 index 0000000..99271ba --- /dev/null +++ b/books/workshops/1999/embedded/Proof-Of-Contribution/Proof-Of-Correctness.lisp @@ -0,0 +1,2408 @@ +;(ld "Proof-Of-Correctness.lisp") + +(in-package "ACL2") + +(include-book "Proof-Of-Correctness-OneCycle") + +(defun updated-cell (var value mem) + (make-cell + value + (var-attribute (get-cell var mem)) + (var-type (get-cell var mem)))) + +(defun equal-put-vals (varlist vals mem memafterputs) + (if (endp varlist) + (null varlist) + (and + (equal + (get-cell (car varlist) memafterputs) + (updated-cell (car varlist) (car vals) mem)) + (equal-put-vals + (cdr varlist) + (cdr vals) + mem + memafterputs)))) + + +(defthm equal-put-vals-have-same-attributes + (implies + (and + (true-listp varlist) + (equal-put-vals varlist vals mem memafter)) + (equal (var-attributes varlist memafter) (var-attributes varlist mem))) + :hints (("Goal" :in-theory (enable var-attribute)))) + +(defthm equal-put-vals-have-values-that-are-vals + (implies + (and + (true-listp vals) + (true-listp varlist) + (equal (len varlist) (len vals)) + (equal-put-vals varlist vals mem memafter)) + (equal (var-values varlist memafter) + vals )) + :hints ( ("Goal" :in-theory (enable var-value get-cell make-cell)))) + +(defthm props-of-updated-cell + (and (equal (var-attribute (updated-cell gvar newv mem)) (var-attribute (get-cell gvar mem))) + (equal (var-type (updated-cell gvar newv mem)) (var-type (get-cell gvar mem))) + (equal (var-value (updated-cell gvar newv mem)) newv)) + :hints (("Goal" :in-theory (enable var-value var-type var-attribute))) + :rule-classes nil) + + +(defthm if-values-are-rns-then-equal-values-is-kept + (implies + (and + (true-listp varlist) + (true-listp vals) + (equal (len varlist) (len vals)) + (equal-put-vals varlist vals mem memafter) + (equal + vals + (apply-direct-rns-to-value-according-to-type + (updated-cell gvar newv gmem) + type)) + (equal-values-and-attributes + (get-cell gvar gmem) + varlist + mem + type)) + (equal-values-and-attributes + (updated-cell gvar newv gmem) + varlist + memafter + type)) + :hints (("Goal" + :use ( (:instance props-of-updated-cell (mem gmem)) + (:instance equal-put-vals-have-values-that-are-vals)) + :in-theory (disable apply-direct-rns-to-value-according-to-type)))) + + +(defun input-var (var val mem) + (put-cell var (updated-cell var val mem) mem)) + +(defun input-vars-e (varlist vals mem) + (if (endp varlist) + mem + (input-vars-e + (cdr varlist) + (cdr vals) + (input-var (car varlist) (car vals) mem)))) + + + +(defun index-different-input-vars-e (varlist vals mem memafter) + (cond + ( (endp varlist) + 0 ) + ( (not (equal (get-cell (car varlist) memafter) + (updated-cell (car varlist) (car vals) mem))) + 0 ) + ( t + (1+ (index-different-input-vars-e + (cdr varlist) + (cdr vals) + mem + memafter))))) + +(defthm if-bad-index-in-range-ten-must-be-noninput + (let ((bad-idx (index-different-input-vars-e varlist vals mem memafter))) + (implies + (in-range bad-idx varlist) + (not (equal + (get-cell (nth bad-idx varlist) memafter) + (updated-cell + (nth bad-idx varlist) + (nth bad-idx vals) + mem))))) + :hints (("Goal" :in-theory (disable get-cell updated-cell)))) + + +(defthm if-bad-index-not-in-range-then-every-update + (let ((bad-idx (index-different-input-vars-e varlist vals mem memafter))) + (implies (and (true-listp varlist) + (not (in-range bad-idx varlist))) + (equal-put-vals varlist vals mem memafter)))) + + +(defthm input-list-decomp + (implies + (and + (in-range idx l1) + (in-range idx l2)) + (equal + (input-vars-e l1 l2 mem) + (input-vars-e (nthcdr idx l1) (nthcdr idx l2) + (input-vars-e (firstn idx l1) (firstn idx l2) mem)))) + :hints (("Goal" :in-theory (disable updated-cell)))) + +(defthm not-in-list-untouched-by-input-vars-e + (implies (not (member-equal-bool v l1)) + (equal (get-cell v (input-vars-e l1 l2 mem)) (get-cell v mem)))) + +(defthm update-independent-from-firstbn + (implies + (not (member-equal-bool (nth idx l1) (firstn idx l1))) + (equal (updated-cell + (nth idx l1) + (nth idx l2) + (input-vars-e (firstn idx l1) (firstn idx l2) mem)) + (updated-cell + (nth idx l1) + (nth idx l2) + mem)))) + +(defthm if-el-does-not-appear-after-its-position-then-input-vars-e-produces-v + (implies + (and + (not (member-equal-bool (nth idx l1) (cdr (nthcdr idx l1)))) + (in-range idx l1) + (in-range idx l2)) + (equal + (get-cell (nth idx l1) (input-vars-e l1 l2 mem)) + (updated-cell + (nth idx l1) + (nth idx l2) + (input-vars-e (firstn idx l1) (firstn idx l2) mem)))) + :hints (("Goal" :in-theory (disable updated-cell)))) + + +(defthm rtm-variable-of-input-vars-e-is-correspondent-value + (implies + (and + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (in-range gem1 ll) + (in-range idx vals) + (in-range idx (nth gem1 ll))) + (equal + (get-cell (nth idx (nth gem1 ll)) (input-vars-e (nth gem1 ll) vals mem)) + (updated-cell (nth idx (nth gem1 ll)) (nth idx vals) mem))) +:hints (("Goal" :in-theory (disable updated-cell) + :use ( + (:instance no-duplicates-all-implies-no-duplicates-one (idx1 gem1)) + (:instance + no-duplicates-means-an-element-does-not-appear-after-its-position + (l (nth gem1 ll))) + if-el-does-not-appear-after-its-position-then-input-vars-e-produces-v + (:instance input-list-decomp + (l1 (nth gem1 ll)) (l2 (nth vals ll))) + (:instance update-independent-from-firstbn + (l1 (nth gem1 ll)) (l2 (nth vals ll))))))) + + + +(defthm rtm-variable-of-input-vars-e-is-put-vals + (implies + (and + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (equal (len (nth gem1 ll)) (len vals)) + (in-range gem1 ll) + (true-listp (nth gem1 ll))) + (equal-put-vals (nth gem1 ll) vals mem + (input-vars-e (nth gem1 ll) vals mem))) + :hints (("Goal" :use (:instance rtm-variable-of-input-vars-e-is-correspondent-value + (idx (index-different-input-vars-e + (nth gem1 ll) + vals + mem + (input-vars-e (nth gem1 ll) vals mem))))) + ("Goal'" :cases ( (in-range (index-different-input-vars-e + (nth gem1 ll) + vals + mem + (input-vars-e (nth gem1 ll) vals mem)) + (nth gem1 ll)) ) ) + ("Subgoal 1" :in-theory '((:definition in-range) + (:rewrite if-bad-index-in-range-ten-must-be-noninput))) + ("Subgoal 2" :in-theory '((:rewrite if-bad-index-not-in-range-then-every-update))))) + + + +(defthm input-vars-e-preserves-equal-values-attributes + (implies + (and + (true-listp ll) + (no-duplicates-p (append-lists ll)) + (equal (len (nth gem1 ll)) (len vals)) + (in-range gem1 ll) + (true-listp vals) + (true-listp (nth gem1 ll)) + (equal + vals + (apply-direct-rns-to-value-according-to-type (updated-cell gvar newv gmem) type)) + (equal-values-and-attributes (get-cell gvar gmem) (nth gem1 ll) mem type)) + (equal-values-and-attributes (updated-cell gvar newv gmem) + (nth gem1 ll) + (input-vars-e (nth gem1 ll) vals mem) type)) + :hints (("Goal" + :use + ((:instance rtm-variable-of-input-vars-e-is-put-vals) + (:instance if-values-are-rns-then-equal-values-is-kept + (varlist (nth gem1 ll)) + (memafter (input-vars-e (nth gem1 ll) vals mem))))))) + + + +(defthm variable-of-other-cell-untouched-input + (implies + (and + (true-listp m) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (assoc-equal gvar1 m) + (assoc-equal gvar2 m) + (in-range idx2 (rtmintvars-i gvar2 m)) + (not (equal gvar1 gvar2))) + (equal + (get-cell (nth idx2 (rtmintvars-i gvar2 m)) rm) + (get-cell (nth idx2 (rtmintvars-i gvar2 m)) (input-vars-e (rtmintvars-i gvar1 m) vals rm)))) + :hints (("Goal" :use (:instance lemma1-different-vars-do-not-belong + (idx1 idx2) + (gvar1 gvar2) + (gvar2 gvar1))))) + + + +(defthm variables-of-other-cells-untouched-input + (implies + (and + (true-listp m) + (true-listp (rtmintvars-i gvar2 m)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (m-correspondent-values-p m gm rm) + (assoc-equal gvar1 m) + (assoc-equal gvar2 m) + (not (equal gvar1 gvar2))) + (equal-get-cells (rtmintvars-i gvar2 m) rm (input-vars-e (rtmintvars-i gvar1 m) vals rm))) + :hints (("Goal" :in-theory nil + :use ( (:instance variable-of-other-cell-untouched-input + (idx2 (idx-different-cell + (rtmintvars-i gvar2 m) + rm + (input-vars-e (rtmintvars-i gvar1 m) vals rm)))))) + ("Goal'" :cases ( (in-range + (idx-different-cell + (rtmintvars-i gvar2 m) + rm + (input-vars-e (rtmintvars-i gvar1 m) vals rm)) + (rtmintvars-i gvar2 m)) )) + ("Subgoal 2" :in-theory '((:rewrite if-bad-index-not-in-range-then-every-equal))) + ("Subgoal 1" :in-theory '((:forward-chaining if-bad-index-in-range-then-cells-must-be-different))))) + + + + + +(defthm result-of-input-one-var + (equal + (get-cell var0 (input-var var val mem)) + (if (equal var var0) + (updated-cell var val mem) + (get-cell var0 mem)))) + +(defthm other-variables-equal-values-attributes-input + (implies + (and + (true-listp m) + (true-listp (rtmintvars-i gvar1 m)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (m-correspondent-values-p m gm rm) + (assoc-equal gvar1 m) + (assoc-equal gvar2 m) + (not (equal gvar1 gvar2))) + (equal-values-and-attributes + (get-cell gvar1 (input-var gvar2 gval2 gm)) + (rtmintvars-i gvar1 m) + (input-vars-e (rtmintvars-i gvar2 m) vals rm) + (type-i gvar1 m))) + :hints (("Goal" :use ( (:instance result-of-input-one-var + (var0 gvar1) (var gvar2) (val gval2)) + (:instance m-correspondent-values-implies-equal-values-and-attribus + (memgstate gm) + (memrstate rm)) + (:instance variables-of-other-cells-untouched-input + (gvar1 gvar2) (gvar2 gvar1)))))) + + +(defthm equal-values-kept-by-appropriate-input-vars + (implies + (and + (true-listp m) + (true-listp (retrieve-rtmvars m)) + (true-listp (rtmintvars-i gvar1 m)) + (true-listp vals) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (equal (len (rtmintvars-i gvar1 m)) (len vals)) + (m-correspondent-values-p m gm rm) + (equal + vals + (apply-direct-rns-to-value-according-to-type + (updated-cell gvar1 gval1 gm) + (type-i gvar1 m))) + (assoc-equal gvar1 m)) + (equal-values-and-attributes + (get-cell gvar1 (input-var gvar1 gval1 gm)) + (rtmintvars-i gvar1 m) + (input-vars-e (rtmintvars-i gvar1 m) vals rm) + (type-i gvar1 m))) + :hints (("Goal" + :in-theory nil + :use ((:instance result-of-input-one-var + (var0 gvar1) (var gvar1) (val gval1) (mem gm)) + (:instance lemma-help3 + (idx (pos-equal-0 gvar1 m))) + (:instance + rtmintvars-i-is-pos-equal-0-of-retrieve-vars + (gvar gvar1)) + (:instance assoc-means-pos-in-range + (el gvar1) + (l m)) + (:instance + m-correspondent-values-implies-equal-values-and-attribus + (memgstate gm) + (memrstate rm)) + (:instance input-vars-e-preserves-equal-values-attributes + (ll (retrieve-rtmvars m)) + (gem1 (pos-equal-0 gvar1 m)) + (type (type-i gvar1 m)) + (mem rm) + (gmem gm) + (gvar gvar1) + (newv gval1) + ))))) + + + + +(defthm equal-all-values-kept-by-appropriate-input-vars + (implies + (and + (true-listp m) + (true-listp (retrieve-rtmvars m)) + (true-listp (rtmintvars-i gvar1 m)) + (true-listp vals) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (equal (len (rtmintvars-i gvar2 m)) (len vals)) + (m-correspondent-values-p m gm rm) + (equal + vals + (apply-direct-rns-to-value-according-to-type + (updated-cell gvar2 gval2 gm) + (type-i gvar2 m))) + (assoc-equal gvar1 m) + (assoc-equal gvar2 m)) + (equal-values-and-attributes + (get-cell gvar1 (input-var gvar2 gval2 gm)) + (rtmintvars-i gvar1 m) + (input-vars-e (rtmintvars-i gvar2 m) vals rm) + (type-i gvar1 m))) + :hints (("Goal" :cases ( (equal gvar1 gvar2) )) + ("Subgoal 2" :use (:instance other-variables-equal-values-attributes-input )) + ("Subgoal 1" :use (:instance equal-values-kept-by-appropriate-input-vars (gvar1 gvar2) (gval1 gval2))))) + + + + +(defthm hlemma1 + (implies + (and + (alistp m) + (in-range idx m)) + (and + (true-listp m) + (assoc-equal (car (nth idx m)) m))) + :rule-classes nil + :otf-flg t) + +(defun correct-wrt-anyarity (m) + (if (endp m) + (null m) + (and + (correct-type (type-0 m)) + (correct-wrt-anyarity (cdr m))))) + + +(defthm hlemma2 + (implies + (and + (correct-wrt-anyarity m) + (in-range idx m)) + (true-listp (nth idx m))) + :hints (("Goal" :in-theory (enable rtmintvars-0))) + :rule-classes nil) + + +(defthm equal-all-values-kept-by-appropriate-input-vars-idxed + (implies + (and + (alistp m) + (correct-wrt-anyarity m) + (true-listp (retrieve-rtmvars m)) + (true-listp vals) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (no-duplicates-p (retrieve-gemvars m)) + (equal (len (cdr (nth idx2 m))) (len vals)) + (m-correspondent-values-p m gm rm) + (equal + vals + (apply-direct-rns-to-value-according-to-type + (updated-cell (car (nth idx2 m)) gval2 gm) + (type-i-idx m idx2))) + (in-range idx m) + (in-range idx2 m)) + (equal-values-and-attributes + (get-cell (car (nth idx m)) (input-var (car (nth idx2 m)) gval2 gm)) + (cdr (nth idx m)) + (input-vars-e (cdr (nth idx2 m)) vals rm) + (type-i-idx m idx))) + :hints (("Goal" :in-theory (union-theories (current-theory 'ground-zero) '((:definition in-range))) + :use ( hlemma2 + (:instance hlemma1 (idx idx)) + (:instance hlemma1 (idx idx2)) + (:instance type-i-is-typeidx (idx idx)) + (:instance type-i-is-typeidx (idx idx2)) + (:instance rtmintvars-i-is-cdr-of-nth-entry (gvar (car (nth idx m)))) + (:instance rtmintvars-i-is-cdr-of-nth-entry (gvar (car (nth idx2 m)))) + (:instance equal-all-values-kept-by-appropriate-input-vars + (gvar1 (car (nth idx m))) + (gvar2 (car (nth idx2 m)))) + (:instance no-duplicates-has-pos-equal-right-in-that-place (l m) (idx idx)) + (:instance no-duplicates-has-pos-equal-right-in-that-place (l m) (idx idx2))))) + :otf-flg t) + + + +(defthm type-invariance-after-input + (equal + (var-type (get-cell v (input-var v2 val2 gm))) + (var-type (get-cell v gm)) ) + :hints (("Goal" :in-theory (enable put-cell get-cell var-type)))) + + + + + +(defthm m-correspondence-kept-by-appropriate-input-vars-idxed + (implies + (and + (alistp m) + (correct-wrt-anyarity m) + (true-listp (retrieve-rtmvars m)) + (true-listp vals) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (no-duplicates-p (retrieve-gemvars m)) + (equal (len (cdr (nth idx2 m))) (len vals)) + (m-correspondent-values-p m gm rm) + (equal + vals + (apply-direct-rns-to-value-according-to-type + (updated-cell (car (nth idx2 m)) gval2 gm) + (type-i-idx m idx2))) + (in-range idx2 m)) + (m-correspondent-values-p + m + (input-var (car (nth idx2 m)) gval2 gm) + (input-vars-e (cdr (nth idx2 m)) vals rm))) + :hints (("Goal" + :in-theory nil + :use ( (:instance equal-all-values-kept-by-appropriate-input-vars-idxed + (idx (bad-idx-eqv-va m + (input-var (car (nth idx2 m)) gval2 gm) + (input-vars-e (cdr (nth idx2 m)) vals rm)))) + (:instance hlemma2 (idx idx2)))) + ("Goal'" :cases ( (in-range (bad-idx-eqv-va m + (input-var (car (nth idx2 m)) gval2 gm) + (input-vars-e (cdr (nth idx2 m)) vals rm)) m) )) + ("Subgoal 2" + :in-theory '((:forward-chaining alistp-forward-to-true-listp) + (:rewrite if-bad-index-not-in-range-then-m-corr))) + ("Subgoal 1" + :in-theory '((:rewrite if-bad-index-in-range-thne-must-be-different-vs))))) + + +(defun input-var-seq (vars vals m mem) + (if (endp vars) + mem + (input-var + (car (nth (car vars) m)) + (car vals) + (input-var-seq + (cdr vars) + (cdr vals) + m + mem)))) + + + + + +(defun input-vars-seq (varsseqs valsseqs mem) + (if (endp varsseqs) + mem + (input-vars-e + (car varsseqs) + (car valsseqs) + (input-vars-seq + (cdr varsseqs) + (cdr valsseqs) + mem)))) + +(defthm invariant1-s + (implies + (equal (var-value cell1) (var-value cell2)) + (equal + (apply-direct-rns-to-value-according-to-type cell1 ty) + (apply-direct-rns-to-value-according-to-type cell2 ty))) + :rule-classes nil) + + +(defthm invariant2-s + (equal (var-value (updated-cell var val mem1)) + (var-value (updated-cell var val mem2))) + :hints (("Goal" :in-theory (enable var-value make-cell))) + :rule-classes nil) + +(defthm invariant3-s + (equal + (apply-direct-rns-to-value-according-to-type + (updated-cell + (car (nth (car vars) m)) + (car vals) + (input-var-seq (cdr vars) (cdr vals) m gm)) + (type-i-idx m (car vars))) + (apply-direct-rns-to-value-according-to-type + (updated-cell + (car (nth (car vars) m)) + (car vals) + gm) + (type-i-idx m (car vars)))) + :hints (("Goal" :use ((:instance invariant1-s + (cell1 (updated-cell + (car (nth (car vars) m)) + (car vals) + (input-var-seq (cdr vars) (cdr vals) m gm))) + (cell2 (updated-cell + (car (nth (car vars) m)) + (car vals) + gm)) + ( ty (type-i-idx m (car vars)))) + (:instance invariant2-s + (var (car (nth (car vars) m))) + (val (car vals)) + (mem1 (input-var-seq (cdr vars) (cdr vals) m gm)) + (mem2 gm))))) + :rule-classes nil) + + + +(defun correct-encoding (vars vals varsseqs valsseqs m gm) + (if (endp vars) + (endp varsseqs) + (and + (consp (car varsseqs)) + (true-listp (car varsseqs)) + (in-range (car vars) m) + (equal (car varsseqs) (cdr (nth (car vars) m))) + (true-listp (car valsseqs)) + (equal (len (car varsseqs)) (len (car valsseqs))) + (equal + (car valsseqs) + (apply-direct-rns-to-value-according-to-type + (updated-cell + (car (nth (car vars) m)) + (car vals) + gm) + (type-i-idx m (car vars)))) + (correct-encoding + (cdr vars) + (cdr vals) + (cdr varsseqs) + (cdr valsseqs) + m + gm)))) + + +(defun ind-scheme (vars vals varsseqs valsseqs) + (if (endp vars) + (append vars vals varsseqs valsseqs) + (ind-scheme + (cdr vars) + (cdr vals) + (cdr varsseqs) + (cdr valsseqs)))) + + + + + +(defthm m-correspondence-kept-by-appropriate-inputs + (implies + (and + (alistp m) + (correct-wrt-anyarity m) + (true-listp (retrieve-rtmvars m)) + (no-duplicates-p (append-lists (retrieve-rtmvars m))) + (no-duplicates-p (retrieve-gemvars m)) + (m-correspondent-values-p m gm rm) + (correct-encoding vars vals varsseqs valsseqs m gm)) + (m-correspondent-values-p + m + (input-var-seq vars vals m gm) + (input-vars-seq varsseqs valsseqs rm))) + :hints (("Goal" + :induct (ind-scheme vars vals varsseqs valsseqs)) + ("Subgoal *1/2" + :in-theory (current-theory 'ground-zero) + :use + ( correct-encoding + invariant3-s + (:instance input-var-seq (mem gm)) + (:instance input-vars-seq (mem rm)) + (:instance m-correspondence-kept-by-appropriate-input-vars-idxed + (gm (input-var-seq (cdr vars) (cdr vals) m gm)) + (rm (input-vars-seq (cdr varsseqs) (cdr valsseqs) rm)) + (idx2 (car vars)) + (vals (car valsseqs)) + (gval2 (car vals))))))) + + + + +(defthm input-var-preserves-correct-wrt-arity + (implies + (correct-wrt-arity m gm) + (correct-wrt-arity m (input-var v2 val2 gm))) + :hints (("Goal" :induct (len m) + :in-theory (disable result-of-input-one-var correct-type type-0 var-type input-var)))) + +(defthm input-var-seq-preserves-correct-wrt-arity + (implies + (correct-wrt-arity m gm) + (correct-wrt-arity m (input-var-seq vs2 vals2 m gm))) + :hints (("Goal" :induct (input-var-seq vs2 vals2 m gm)) + ("Subgoal *1/2" :in-theory nil + :use ((:instance input-var-seq (vars vs2) (vals vals2) (mem gm)) + (:instance input-var-preserves-correct-wrt-arity + (v2 (car (nth (car vs2) m))) + (val2 (car vals2)) + (gm (input-var-seq (cdr vs2) (cdr vals2) m gm))))))) + + + + +(defthm input-var-doesnot-decrement-vars + (implies + (vars-inclusion m gm) + (vars-inclusion m (input-var anyvar anyval gm))) + :hints (("Goal" :in-theory (enable put-cell get-cell)))) + +(defthm input-var-seq-doesnot-decrement-vars + (implies + (vars-inclusion m gm) + (vars-inclusion m (input-var-seq vars vals m gm))) + :hints (("Goal" :induct (input-var-seq vars vals m gm)) + ("Subgoal *1/2" :use (:instance input-var-doesnot-decrement-vars + (anyvar (car (nth (car vars) m))) + (anyval (car vals)) + (gm (input-var-seq (cdr vars) (cdr vals) m gm)))))) + + +(defthm a-var-in-m-appears-in-mem + (implies + (and + (in-range var m) + (vars-inclusion m mem)) + (assoc-equal (car (nth var m)) mem)) + :rule-classes nil) + + +(defthm input-existing-var-does-not-increment-vars0 + (implies + (and + (vars-inclusion m mem) + (assoc-equal var mem) + (vars-inclusion mem m)) + (vars-inclusion + (input-var var val mem) + m)) + :hints (("Goal" :in-theory (enable put-cell get-cell))) + :rule-classes nil) + +(defthm input-existing-var-does-not-increment-vars + (implies + (and + (in-range var m) + (vars-inclusion m mem) + (vars-inclusion mem m)) + (vars-inclusion + (input-var (car (nth var m)) val mem) + m)) + :hints (("Goal" :use ((:instance a-var-in-m-appears-in-mem) + (:instance input-existing-var-does-not-increment-vars0 + (var (car (nth var m)))))))) + + +(defun in-ranges (vars m) + (if (endp vars) + t + (and (in-range (car vars) m) + (in-ranges (cdr vars) m)))) + +(defthm input-exisitng-varseq-doesnot-increment-vars + (implies + (and + (in-ranges vars m) + (vars-inclusion m gm) + (vars-inclusion gm m)) + (vars-inclusion (input-var-seq vars vals m gm) m)) + :hints (("Goal" :induct (input-var-seq vars vals m gm)) + ("Subgoal *1/2" :use (:instance input-existing-var-does-not-increment-vars + (var (car vars)) + (val (car vals)) + (mem (input-var-seq (cdr vars) (cdr vals) m gm)))))) + +(defthm input-var-invariant-wrt-var-attributes + (equal (var-attributes vars mem) + (var-attributes vars (input-var var val mem))) + :hints (("Goal" :in-theory (enable put-cell get-cell var-attribute make-cell))) + :rule-classes nil) + +(defthm input-varseq-invariant-wrt-var-attributes + (equal (var-attributes otvars mem) + (var-attributes otvars (input-var-seq vars vals m mem))) + :hints (("Goal" :induct (input-var-seq vars vals m mem)) + ("Subgoal *1/2" :use ( (:instance input-var-seq) + (:instance input-var-invariant-wrt-var-attributes + (var (car (nth (car vars) m))) + (val (car vals)) + (vars otvars) + (mem (input-var-seq (cdr vars) (cdr vals) m mem)))))) + :rule-classes nil) + +(defthm put-update-invariant-wrt-var-attributes + (equal + (var-attributes otvars mem) + (var-attributes otvars (put-cell var (updated-cell var val mem) mem))) + :hints (("Goal" + :in-theory (enable put-cell get-cell var-attribute make-cell))) + :rule-classes nil) + + +(defthm input-vars-e-invariant-wrt-var-attributes + (equal (var-attributes otvars mem) + (var-attributes otvars (input-vars-e vars vals mem))) + :hints (("Goal" :induct (input-vars-e vars vals mem)) + ("Subgoal *1/2" :use (:instance put-update-invariant-wrt-var-attributes + (var (car vars)) + (val (car vals))))) + :rule-classes nil) + +(defthm input-vars-seqs-invariant-wrt-var-attributes + (equal (var-attributes otvars mem) + (var-attributes otvars (input-vars-seq varsseqs valsseqs mem))) + :hints (("Goal" :induct (input-vars-seq varsseqs valsseqs mem)) + ("Subgoal *1/2" :use (:instance input-vars-e-invariant-wrt-var-attributes + (vars (car varsseqs)) + (vals (car valsseqs)) + (mem (input-vars-seq (cdr varsseqs) (cdr valsseqs) mem))))) + :rule-classes nil) + +(defthm input-vars-seqs-preserves-point-to-good-rtm-var-sets + (implies + (m-entries-point-to-good-rtm-var-sets m rm) + (m-entries-point-to-good-rtm-var-sets m (input-vars-seq varsseqs valsseqs rm))) + :hints (("Goal" :induct (len m)) + ("Subgoal *1/1" :use (:instance input-vars-seqs-invariant-wrt-var-attributes + (otvars (rtmintvars-0 m)) + (mem rm))))) + + +(defthm correct-arity-implies-correct-anyarity + (implies + (correct-wrt-arity m gm) + (correct-wrt-anyarity m)) + :rule-classes nil) + + +(defthm correct-encoding-implies-in-ranges + (implies + (correct-encoding vars vals varsseqs valsseqs m gm) + (in-ranges vars m)) + :rule-classes nil) + + +(defthm input-preserves-good-mapping-wrt-memories + (implies + (and + (good-mapping m) + (correct-encoding vars vals varsseqs valsseqs m gm) + (good-mapping-wrt-memories m gm rm)) + (good-mapping-wrt-memories m (input-var-seq vars vals m gm) (input-vars-seq varsseqs valsseqs rm))) + :hints (("Goal" + :use ( correct-arity-implies-correct-anyarity + correct-encoding-implies-in-ranges + input-vars-seqs-preserves-point-to-good-rtm-var-sets + input-exisitng-varseq-doesnot-increment-vars + input-var-seq-doesnot-decrement-vars + (:instance input-var-seq-preserves-correct-wrt-arity (vs2 vars) (vals2 vals)) + m-correspondence-kept-by-appropriate-inputs)))) + + +(defthm a-cell-remains-typed-after-good-put + (implies + (and + (is-mem-cell-p (get-cell anyvar mem)) + (is-mem-cell-p (get-cell var mem)) + (if (equal (var-type (get-cell var mem)) 'bool) + (my-or-2 (equal val 0) (equal val 1)) + (integerp val))) + (is-mem-cell-p (get-cell anyvar (input-var var val mem)))) + :hints (("Goal" :in-theory (enable get-cell put-cell my-or-2 var-type var-attribute var-value)))) + + +(defthm updated-cell-is-typed-if-ok + (implies + (and + (is-mem-cell-p (get-cell var mem)) + (if (equal (var-type (get-cell var mem)) 'bool) + (my-or-2 (equal val 0) (equal val 1)) + (integerp val))) + (is-mem-cell-p (updated-cell var val mem))) + :hints (("Goal" :in-theory (enable get-cell put-cell my-or-2 var-type var-attribute var-value)))) + +(defthm input-okvar-keeps-typed-amem + (implies + (and + (is-typed-amem-p mem) + (is-mem-cell-p (get-cell var mem)) + (if (equal (var-type (get-cell var mem)) 'bool) + (my-or-2 (equal val 0) (equal val 1)) + (integerp val))) + (is-typed-amem-p (input-var var val mem))) + :hints (("Goal" + :use + ( (:instance putting-a-new-cell-preserves-typed-amem + (new-cell (updated-cell var val mem)) + (c var)) + (:instance updated-cell-is-typed-if-ok))))) + +(defun ok-vars (vars vals m mem) + (if (endp vars) + t + (and + (is-mem-cell-p + (get-cell (car (nth (car vars) m)) + (input-var-seq (cdr vars) (cdr vals) m mem))) + (if (equal (var-type (get-cell (car (nth (car vars) m)) + (input-var-seq (cdr vars) (cdr vals) m mem))) 'bool) + (my-or-2 (equal (car vals) 0) (equal (car vals) 1)) + (integerp (car vals))) + (ok-vars (cdr vars) (cdr vals) m mem)))) + +(defthm input-okvar-seq-keeps-typed-amem + (implies + (and + (is-typed-amem-p mem) + (ok-vars vars vals m mem)) + (is-typed-amem-p (input-var-seq vars vals m mem))) + :hints (("Goal" :induct (input-var-seq vars vals m mem)) + ("Subgoal *1/2" :use + ( (:instance ok-vars) + (:instance input-var-seq) + (:instance input-okvar-keeps-typed-amem + (var (car (nth (car vars) m))) + (val (car vals)) + (mem (input-var-seq (cdr vars) (cdr vals) m mem))))))) + +(defun bounded-values (vals) + (if (endp vals) + t + (and (natp (car vals)) + (< (car vals) (prod *rns*)) + (bounded-values (cdr vals))))) + +(defthm bounded-input-preserves-boundedness + (implies + (and + (bounded-amem-p mem) + (bounded-values vals) + (true-listp vars) + (true-listp vals) + (equal (len vars) (len vals))) + (bounded-amem-p (input-var-seq vars vals m mem))) + :hints (("Goal" :in-theory (enable var-value get-cell put-cell)))) + +(defthm input-okvar-preserves-a-mem-cell + (implies + (and + (is-mem-cell-p (get-cell v mem)) + (is-typed-amem-p mem) + (is-mem-cell-p (get-cell var mem)) + (if (equal (var-type (get-cell var mem)) 'bool) + (my-or-2 (equal val 0) (equal val 1)) + (integerp val))) + (is-mem-cell-p (get-cell v (input-var var val mem)))) + :hints (("Goal" :in-theory (enable get-cell put-cell my-or-2 var-value var-attribute var-type)))) + + + +(defthm input-var-preserves-gem-instruction + (implies + (and + (gem-instruction-p instr mem) + (is-typed-amem-p mem) + (is-mem-cell-p (get-cell var mem)) + (if (equal (var-type (get-cell var mem)) 'bool) + (my-or-2 (equal val 0) (equal val 1)) + (integerp val))) + (gem-instruction-p instr (input-var var val mem))) + :hints (("Goal" :in-theory '((:definition gem-instruction-p)) + :use ( (:instance input-okvar-preserves-a-mem-cell (v (par1 instr))) + (:instance input-okvar-preserves-a-mem-cell (v (par2 instr))) + (:instance input-okvar-preserves-a-mem-cell (v (par3 instr))) + (:instance type-invariance-after-input (v (par1 instr)) (v2 var) (val2 val) (gm mem)) + (:instance type-invariance-after-input (v (par2 instr)) (v2 var) (val2 val) (gm mem)) + (:instance type-invariance-after-input (v (par3 instr)) (v2 var) (val2 val) (gm mem)))))) + +(defthm input-var-preserves-gem-instruction-list + (implies + (and + (gem-instruction-list-p instrlist mem) + (is-typed-amem-p mem) + (is-mem-cell-p (get-cell var mem)) + (if (equal (var-type (get-cell var mem)) 'bool) + (my-or-2 (equal val 0) (equal val 1)) + (integerp val))) + (gem-instruction-list-p instrlist (input-var var val mem))) + :hints (("Goal" :induct (gem-instruction-list-p instrlist mem)) + ("Subgoal *1/3" :in-theory '((:definition gem-instruction-list-p))) + ("Subgoal *1/2" :in-theory '((:definition gem-instruction-list-p)) + :use (:instance input-var-preserves-gem-instruction + (instr (car instrlist)))))) + + +(defthm input-var-seq-preserves-gem-instruction-list + (implies + (and + (gem-instruction-list-p instrlist mem) + (is-typed-amem-p mem) + (ok-vars vars vals m mem)) + (gem-instruction-list-p instrlist (input-var-seq vars vals m mem))) + :hints (("Goal" :induct (input-var-seq vars vals m mem)) + ("Subgoal *1/2" + :in-theory (disable input-var is-mem-cell-p) + :use + ( (:instance ok-vars) + (:instance input-var-seq) + (:instance input-var-preserves-gem-instruction-list + (var (car (nth (car vars) m))) + (val (car vals)) + (mem (input-var-seq (cdr vars) (cdr vals) m mem))))))) + + + + +(defthm skkk0 (equal (mem (make-state m p c)) m) ) +(defthm skkk1 (equal (pcc (make-state m p c)) p) ) +(defthm skkk2 (equal (code (make-state m p c)) c) ) +(defthm skkk3 (implies (gem-statep s1) (equal (cdr (make-state m (pcc s1) (code s1))) (cdr s1)))) +(defthm skkk4 (implies (gem-statep s1) (consp (cdr (make-state m (pcc s1) (code s1)))))) +(defthm skkk5 (implies (gem-statep s1) (integerp (pcc (make-state m (pcc s1) (code s1)))))) + + +(defthm prs01 + (implies + (and + (gem-statep gstate) + (bounded-values vals) + (true-listp vars) + (true-listp vals) + (equal (len vars) (len vals)) + (ok-vars vars vals m (mem gstate))) + (and + (consp (make-state (input-var-seq vars vals m (mem gstate)) (pcc gstate) (code gstate))) + (consp (cdr (make-state (input-var-seq vars vals m (mem gstate)) (pcc gstate) (code gstate)))) + (integerp (pcc (make-state (input-var-seq vars vals m (mem gstate)) (pcc gstate) (code gstate)))))) + :hints (("Goal" + :do-not-induct t + :in-theory '((:definition make-state) + (:rewrite skkk0) (:rewrite skkk1) (:rewrite skkk2) (:rewrite skkk3)) + :use ((:instance skkk4 (s1 gstate) (m (input-var-seq vars vals m (mem gstate)))) + (:instance skkk5 (s1 gstate) (m (input-var-seq vars vals m (mem gstate)))) + (:instance gem-statep (x gstate)) + (:instance gem-statep (x (make-state (input-var-seq vars vals m (mem gstate)) (pcc gstate) (code gstate))))))) + :rule-classes nil) + + + + +(defthm prs02 + (implies + (and + (gem-statep gstate) + (bounded-values vals) + (true-listp vars) + (true-listp vals) + (equal (len vars) (len vals)) + (ok-vars vars vals m (mem gstate))) + (and + (gem-instruction-list-p (code (make-state (input-var-seq vars vals m (mem gstate)) (pcc gstate) (code gstate))) + (mem (make-state (input-var-seq vars vals m (mem gstate)) (pcc gstate) (code gstate)))) + (bounded-amem-p (mem (make-state (input-var-seq vars vals m (mem gstate)) (pcc gstate) (code gstate)))) + (is-typed-amem-p (mem (make-state (input-var-seq vars vals m (mem gstate)) (pcc gstate) (code gstate)))))) + :hints (("Goal" + :do-not-induct t + :in-theory '( (:rewrite skkk0) (:rewrite skkk1) (:rewrite skkk2) (:rewrite skkk3)) + :use ( + (:instance gem-statep (x gstate)) + (:instance gem-statep (x (make-state (input-var-seq vars vals m (mem gstate)) (pcc gstate) (code gstate)))) + (:instance input-var-seq-preserves-gem-instruction-list + (instrlist (code gstate)) (mem (mem gstate))) + (:instance bounded-input-preserves-boundedness (mem (mem gstate))) + (:instance input-okvar-seq-keeps-typed-amem (mem (mem gstate)))))) + :rule-classes nil) + + +(defun ok-gem-vars-vals (vars vals m mem) + (and + (bounded-values vals) + (true-listp vars) + (true-listp vals) + (equal (len vars) (len vals)) + (ok-vars vars vals m mem))) + + +(defthm ok-vars-preserve-gem-statep + (implies + (and + (gem-statep gstate) + (ok-gem-vars-vals vars vals m (mem gstate))) + (gem-statep (make-state (input-var-seq vars vals m (mem gstate)) (pcc gstate) (code gstate)))) + :hints (("Goal" + :do-not-induct t + :in-theory '((:definition ok-gem-vars-vals) (:definition gem-statep)) + :use (prs01 prs02)))) + + + +(defun ok-rtm-vars (vars vals mem) + (if (endp vars) + t + (and + (is-mem-cell-p + (get-cell (car vars) mem)) + (if (equal (var-type (get-cell (car vars) + mem)) 'bool) + (my-or-2 (equal (car vals) 0) (equal (car vals) 1)) + (integerp (car vals))) + (ok-rtm-vars (cdr vars) (cdr vals) (put-cell (car vars) (updated-cell (car vars) (car vals) mem) mem))))) + + + + +(defthm ok-rtm-vars-means-input-vars-preserves-typed-mem + (implies + (and + (is-typed-amem-p mem) + (ok-rtm-vars vars vals mem)) + (is-typed-amem-p (input-vars-e vars vals mem))) + :hints (("Subgoal *1/2" :use + ((:instance putting-a-new-cell-preserves-typed-amem + (c (car vars)) + (new-cell (updated-cell (car vars) (car vals) mem))) + (:instance updated-cell-is-typed-if-ok + (var (car vars)) + (val (car vals))))))) + + +(defun ok-rtmvarsseq (varsseqs valsseqs mem) + (if (endp varsseqs) + t + (and + (ok-rtm-vars (car varsseqs) (car valsseqs) + (input-vars-seq (cdr varsseqs) (cdr valsseqs) mem)) + (ok-rtmvarsseq (cdr varsseqs) (cdr valsseqs) mem)))) + +(defthm ok-rtmvarsseqs-kjeeps-typed-amem + (implies + (and + (is-typed-amem-p mem) + (ok-rtmvarsseq varsseqs valsseqs mem)) + (is-typed-amem-p (input-vars-seq varsseqs valsseqs mem)))) + + + +(defthm input-var-preserves-rtm-instruction + (implies + (and + (rtm-instruction-p instr mem) + (is-typed-amem-p mem) + (is-mem-cell-p (get-cell var mem)) + (if (equal (var-type (get-cell var mem)) 'bool) + (my-or-2 (equal val 0) (equal val 1)) + (integerp val))) + (rtm-instruction-p instr (input-var var val mem))) + :hints (("Goal" :in-theory '((:definition rtm-instruction-p)) + :use ( (:instance input-okvar-preserves-a-mem-cell (v (par1 instr))) + (:instance input-okvar-preserves-a-mem-cell (v (par2 instr))) + (:instance input-okvar-preserves-a-mem-cell (v (par3 instr))) + (:instance type-invariance-after-input (v (par1 instr)) (v2 var) (val2 val) (gm mem)) + (:instance type-invariance-after-input (v (par2 instr)) (v2 var) (val2 val) (gm mem)) + (:instance type-invariance-after-input (v (par3 instr)) (v2 var) (val2 val) (gm mem)))))) + + + +(defthm input-vars-preserves-rtm-instruction + (implies + (and + (rtm-instruction-p instr mem) + (ok-rtm-vars vars vals mem) + (is-typed-amem-p mem)) + (rtm-instruction-p instr (input-vars-e vars vals mem))) + :hints (("Goal" :induct (input-vars-e vars vals mem)) + ("Subgoal *1/2" + :in-theory '((:definition input-var) (:definition input-vars-e)) + :use (ok-rtm-vars + (:instance input-var-preserves-rtm-instruction + (var (car vars)) + (val (car vals)) + (mem mem)) + (:instance input-okvar-keeps-typed-amem + (var (car vars)) + (val (car vals)) + (mem mem)))))) + + + +(defthm input-vars-e-preserves-rtm-instruction-list + (implies + (and + (rtm-instruction-list-p instrlist mem) + (ok-rtm-vars vars vals mem) + (is-typed-amem-p mem)) + (rtm-instruction-list-p instrlist (input-vars-e vars vals mem))) + :hints (("Goal" :induct (rtm-instruction-list-p instrlist mem)) + ("Subgoal *1/3" :in-theory '((:definition rtm-instruction-list-p))) + ("Subgoal *1/2" :in-theory '((:definition rtm-instruction-list-p)) + :use (:instance input-vars-preserves-rtm-instruction + (instr (car instrlist)))))) + + +(defthm input-vars-seq-preserves-rtm-instruction-list + (implies + (and + (rtm-instruction-list-p instrlist mem) + (ok-rtmvarsseq varsseqs valsseqs mem) + (is-typed-amem-p mem)) + (rtm-instruction-list-p instrlist (input-vars-seq varsseqs valsseqs mem)))) + + + +(defthm skkk3r (implies (rtm-statep s1) (equal (cdr (make-state m (pcc s1) (code s1))) (cdr s1)))) +(defthm skkk4r (implies (rtm-statep s1) (consp (cdr (make-state m (pcc s1) (code s1)))))) +(defthm skkk5r (implies (rtm-statep s1) (integerp (pcc (make-state m (pcc s1) (code s1)))))) + +(defthm prs03 + (implies + (rtm-statep rstate) + (and + (consp (make-state (input-vars-seq varsseqs valsseqs (mem rstate)) (pcc rstate) (code rstate))) + (consp (cdr (make-state (input-vars-seq varsseqs valsseqs (mem rstate)) (pcc rstate) (code rstate)))) + (integerp (pcc (make-state (input-vars-seq varsseqs valsseqs (mem rstate)) (pcc rstate) (code rstate)))))) + :hints (("Goal" + :do-not-induct t + :in-theory '((:definition make-state) + (:rewrite skkk0) (:rewrite skkk1) (:rewrite skkk2) (:rewrite skkk3r)) + :use ((:instance skkk4r (s1 rstate) (m (input-vars-seq varsseqs valsseqs (mem rstate)))) + (:instance skkk5r (s1 rstate) (m (input-vars-seq varsseqs valsseqs (mem rstate)))) + (:instance rtm-statep (x rstate)) + (:instance rtm-statep (x (make-state (input-var-seq vars vals m (mem rstate)) (pcc rstate) (code rstate))))))) + :rule-classes nil) + + + +(defthm prs04 + (implies + (and + (rtm-statep rstate) + (ok-rtmvarsseq varsseqs valsseqs (mem rstate))) + (and + (rtm-instruction-list-p (code (make-state (input-vars-seq varsseqs valsseqs (mem rstate)) (pcc rstate) (code rstate))) + (mem (make-state (input-vars-seq varsseqs valsseqs (mem rstate)) (pcc rstate) (code rstate)))) + (is-typed-amem-p (mem (make-state (input-vars-seq varsseqs valsseqs (mem rstate)) (pcc rstate) (code rstate)))))) + :hints (("Goal" + :do-not-induct t + :in-theory '( (:rewrite skkk0) (:rewrite skkk1) (:rewrite skkk2) (:rewrite skkk3r)) + :use ( + (:instance rtm-statep (x rstate)) + (:instance rtm-statep (x (make-state (input-vars-seq varsseqs valsseqs (mem rstate)) (pcc rstate) (code rstate)))) + (:instance input-vars-seq-preserves-rtm-instruction-list + (instrlist (code rstate)) (mem (mem rstate))) + (:instance ok-rtmvarsseqs-kjeeps-typed-amem (mem (mem rstate)))))) + :rule-classes nil) + + +(defthm ok-rtmvarsseqs-preserve-rtmstatehood + (implies + (and + (rtm-statep rstate) + (ok-rtmvarsseq varsseqs valsseqs (mem rstate))) + (rtm-statep (make-state (input-vars-seq varsseqs valsseqs (mem rstate)) (pcc rstate) (code rstate)))) + :hints (("Goal" :in-theory '((:definition rtm-statep)) + :use (prs03 prs04)))) + + + + + + + +(defthm same-pcc-after-execution-regardelss-of-mem + (implies + (and + (equal (code st) (code st2)) + (equal (pcc st) (pcc st2))) + (equal + (pcc (execute-instruction st)) + (pcc (execute-instruction st2))))) + + + +(defun indsc (st1 st2 n) + (if (zp n) + nil + (append st1 st2 + (indsc + (execute-instruction st1) (execute-instruction st2) (1- n))))) + + + +(defthm listinstr-is-independent-from-mem + (implies (and + (equal (pcc st) (pcc st2)) + (equal (code st) (code st2))) + (equal (listinstr st n) (listinstr st2 n))) + :hints (("Goal" :induct (indsc st st2 n)) + ("Subgoal *1/2" + :in-theory nil + :use ( listinstr + (:instance listinstr (st st2)) + (:instance same-pcc-after-execution-regardelss-of-mem) + (:instance execute-instruction-does-not-touch-code) + (:instance execute-instruction-does-not-touch-code (st st2))))) + :rule-classes nil) + + +(defthm listpars1-independent-from-mem + (implies + (and + (equal (pcc st) (pcc st2)) + (equal (code st) (code st2))) + (equal (listpars1 st n) (listpars1 st2 n))) + :hints (("Goal" :in-theory nil + :use ( listinstr-is-independent-from-mem + (:instance pars1-instruction-is-listpars1 (st st)) + (:instance pars1-instruction-is-listpars1 (st st2)))))) + + + +(defun pars2-instructions (listinstr) + (if (endp listinstr) + nil + (cons (par2 (car listinstr)) + (pars2-instructions (cdr listinstr))))) + +(defthm pars2-instruction-is-listpars2 + (equal + (pars2-instructions (listinstr st n)) + (listpars2 st n))) + + +(defthm listpars2-independent-from-mem + (implies + (and + (equal (pcc st) (pcc st2)) + (equal (code st) (code st2))) + (equal (listpars2 st n) (listpars2 st2 n))) + :hints (("Goal" :in-theory nil + :use ( listinstr-is-independent-from-mem + (:instance pars2-instruction-is-listpars2 (st st)) + (:instance pars2-instruction-is-listpars2 (st st2)))))) + + +(defun pars3-instructions (listinstr) + (if (endp listinstr) + nil + (cons (par3 (car listinstr)) + (pars3-instructions (cdr listinstr))))) + +(defthm pars3-instruction-is-listpars3 + (equal + (pars3-instructions (listinstr st n)) + (listpars3 st n))) + + +(defthm listpars3-independent-from-mem + (implies + (and + (equal (pcc st) (pcc st2)) + (equal (code st) (code st2))) + (equal (listpars3 st n) (listpars3 st2 n))) + :hints (("Goal" :in-theory nil + :use ( listinstr-is-independent-from-mem + (:instance pars3-instruction-is-listpars3 (st st)) + (:instance pars3-instruction-is-listpars3 (st st2)))))) + + +(defun pars4-instructions (listinstr) + (if (endp listinstr) + nil + (cons (par4 (car listinstr)) + (pars4-instructions (cdr listinstr))))) + +(defthm pars4-instruction-is-listpars4 + (equal + (pars4-instructions (listinstr st n)) + (listpars4 st n))) + + +(defthm listpars4-independent-from-mem + (implies + (and + (equal (pcc st) (pcc st2)) + (equal (code st) (code st2))) + (equal (listpars4 st n) (listpars4 st2 n))) + :hints (("Goal" :in-theory nil + :use ( listinstr-is-independent-from-mem + (:instance pars4-instruction-is-listpars4 (st st)) + (:instance pars4-instruction-is-listpars4 (st st2)))))) + + +(defthm all-rtm-adds-independent-from-mem + (implies + (and + (equal (pcc st) (pcc st2)) + (equal (code st) (code st2))) + (equal (all-rtm-adds-for-n-steps st n) (all-rtm-adds-for-n-steps st2 n)))) + +(defthm all-rtm-subs-independent-from-mem + (implies + (and + (equal (pcc st) (pcc st2)) + (equal (code st) (code st2))) + (equal (all-rtm-subs-for-n-steps st n) (all-rtm-subs-for-n-steps st2 n)))) + +(defthm listinstr-independent-from-mem + (implies + (and + (equal (pcc st) (pcc st2)) + (equal (code st) (code st2))) + (equal (listinstr st n) (listinstr st2 n)))) + + + + + +(defthm same-pcc-after-execution-n-regardelss-of-mem + (implies + (and + (equal (code st) (code st2)) + (equal (pcc st) (pcc st2))) + (equal + (pcc (execute-n-instructions st n)) + (pcc (execute-n-instructions st2 n)))) + :hints (("Goal" :induct (indsc st st2 n)) + ("Subgoal *1/2" + :in-theory '((:definition execute-n-instructions)) + :use + ( + (:instance same-pcc-after-execution-regardelss-of-mem (st st)) + (:instance execute-instruction-does-not-touch-code (st st)) + (:instance execute-instruction-does-not-touch-code (st st2)))))) + + +(defun good-translation-induct (gstate rstate gstate2 rstate2) + (declare (xargs :measure (acl2-count (- (len (code gstate)) (pcc gstate))))) + (if + (or (not (integerp (pcc gstate))) + (< (pcc gstate) 0) + (>= (pcc gstate) (len (code gstate)))) + (append gstate rstate gstate2 rstate2) + (case (opcode (nth (pcc gstate) (code gstate))) + (gem-equ + (good-translation-induct + (execute-instruction gstate ) + (execute-n-instructions rstate (* 2 (len *rns*)) ) + (execute-instruction gstate2 ) + (execute-n-instructions rstate2 (* 2 (len *rns*)) ) + )) + (gem-add + (good-translation-induct + (execute-instruction gstate ) + (execute-n-instructions rstate (len *rns*) ) + (execute-instruction gstate2 ) + (execute-n-instructions rstate2 (len *rns*) ) + )) + (gem-sub + (good-translation-induct + (execute-instruction gstate ) + (execute-n-instructions rstate (len *rns*) ) + (execute-instruction gstate2 ) + (execute-n-instructions rstate2 (len *rns*) ) + )) + (otherwise nil)))) + +(defthm good-translation-is-independent-from-mem + (implies + (and + (equal (code gstate) (code gstate2)) + (equal (pcc gstate) (pcc gstate2)) + (equal (code rstate) (code rstate2)) + (equal (pcc rstate) (pcc rstate2)) + (good-translation-gem-rtm gstate rstate m)) + (good-translation-gem-rtm gstate2 rstate2 m)) + :hints (("Goal" :induct (good-translation-induct gstate rstate gstate2 rstate2 )) + ("Subgoal *1/5" :in-theory '((:definition good-translation-gem-rtm))) + ("Subgoal *1/4" :in-theory '((:definition good-translation-gem-rtm)) + :use ( (:instance execute-n-instruction-does-not-touch-code (st rstate) (n (len *rns*))) + (:instance execute-n-instruction-does-not-touch-code (st rstate2) (n (len *rns*))) + (:instance execute-instruction-does-not-touch-code (st gstate)) + (:instance execute-instruction-does-not-touch-code (st gstate2)) + (:instance same-pcc-after-execution-n-regardelss-of-mem (st rstate) (st2 rstate2) (n (len *rns*))) + (:instance same-pcc-after-execution-regardelss-of-mem (st gstate) (st2 gstate2)) + (:instance all-rtm-subs-independent-from-mem (st rstate) (st2 rstate2) (n (len *rns*))) + (:instance listpars1-independent-from-mem (st rstate) (st2 rstate2) (n (len *rns*))) + (:instance listpars2-independent-from-mem (st rstate) (st2 rstate2) (n (len *rns*))) + (:instance listpars3-independent-from-mem (st rstate) (st2 rstate2) (n (len *rns*))) + (:instance listpars4-independent-from-mem (st rstate) (st2 rstate2) (n (len *rns*))))) + ("Subgoal *1/3" :in-theory '((:definition good-translation-gem-rtm)) + :use ( (:instance execute-n-instruction-does-not-touch-code (st rstate) (n (len *rns*))) + (:instance execute-n-instruction-does-not-touch-code (st rstate2) (n (len *rns*))) + (:instance execute-instruction-does-not-touch-code (st gstate)) + (:instance execute-instruction-does-not-touch-code (st gstate2)) + (:instance same-pcc-after-execution-n-regardelss-of-mem (st rstate) (st2 rstate2) (n (len *rns*))) + (:instance same-pcc-after-execution-regardelss-of-mem (st gstate) (st2 gstate2)) + (:instance all-rtm-adds-independent-from-mem (st rstate) (st2 rstate2) (n (len *rns*))) + (:instance listpars1-independent-from-mem (st rstate) (st2 rstate2) (n (len *rns*))) + (:instance listpars2-independent-from-mem (st rstate) (st2 rstate2) (n (len *rns*))) + (:instance listpars3-independent-from-mem (st rstate) (st2 rstate2) (n (len *rns*))) + (:instance listpars4-independent-from-mem (st rstate) (st2 rstate2) (n (len *rns*))))) + ("Subgoal *1/2" :in-theory '((:definition good-translation-gem-rtm)) + :use ( (:instance execute-n-instruction-does-not-touch-code (st rstate) (n (* 2 (len *rns*)))) + (:instance execute-n-instruction-does-not-touch-code (st rstate2) (n (* 2 (len *rns*)))) + (:instance execute-instruction-does-not-touch-code (st gstate)) + (:instance execute-instruction-does-not-touch-code (st gstate2)) + (:instance same-pcc-after-execution-n-regardelss-of-mem (st rstate) (st2 rstate2) (n (* 2 (len *rns*)))) + (:instance same-pcc-after-execution-regardelss-of-mem (st gstate) (st2 gstate2)) + (:instance listinstr-independent-from-mem (st rstate) (st2 rstate2) (n (* 2 (len *rns*)))))) + ("Subgoal *1/1" :in-theory '((:definition good-translation-gem-rtm))))) + + + +(defun correct-input (vars vals varsseqs valsseqs m gstate rstate) + (and + (ok-rtmvarsseq varsseqs valsseqs (mem rstate)) + (ok-gem-vars-vals vars vals m (mem gstate)) + (correct-encoding vars vals varsseqs valsseqs m (mem gstate)))) + + +(defthm all-properties-hold-after-correct-input0 + (implies + (and + (correct-input vars vals varsseqs valsseqs m gstate rstate) + (good-mapping m) + (good-mapping-wrt-memories m (mem gstate) (mem rstate)) + (good-translation-gem-rtm gstate rstate m) + (gem-statep gstate) + (rtm-statep rstate) + (>= (pcc gstate) 0) + (m-correspondent-values-p m (mem gstate) (mem rstate))) + (and + (good-mapping-wrt-memories + m + (mem (make-state (input-var-seq vars vals m (mem gstate)) (pcc gstate) (code gstate))) + (mem (make-state (input-vars-seq varsseqs valsseqs (mem rstate)) (pcc rstate) (code rstate)))) + (good-translation-gem-rtm + (make-state (input-var-seq vars vals m (mem gstate)) (pcc gstate) (code gstate)) + (make-state (input-vars-seq varsseqs valsseqs (mem rstate)) (pcc rstate) (code rstate)) + m) + (gem-statep (make-state (input-var-seq vars vals m (mem gstate)) (pcc gstate) (code gstate))) + (rtm-statep (make-state (input-vars-seq varsseqs valsseqs (mem rstate)) (pcc rstate) (code rstate))) + (>= (pcc (make-state (input-var-seq vars vals m (mem gstate)) (pcc gstate) (code gstate))) 0) + (m-correspondent-values-p + m + (mem (make-state (input-var-seq vars vals m (mem gstate)) (pcc gstate) (code gstate))) + (mem (make-state (input-vars-seq varsseqs valsseqs (mem rstate)) (pcc rstate) (code rstate)))) +)) + :hints (("Goal" + :in-theory '((:definition correct-input) + (:type-prescription retrieve-rtmvars) + (:definition good-mapping-wrt-memories) + (:definition good-mapping) + (:rewrite skkk0) + (:rewrite skkk1) + (:rewrite skkk2)) + :use ( + ok-rtmvarsseqs-preserve-rtmstatehood + ok-vars-preserve-gem-statep + (:instance input-preserves-good-mapping-wrt-memories (gm (mem gstate)) (rm (mem rstate))) + (:instance correct-arity-implies-correct-anyarity (gm (mem gstate))) + (:instance m-correspondence-kept-by-appropriate-inputs (gm (mem gstate)) (rm (mem rstate))) + (:instance good-translation-is-independent-from-mem + (gstate2 (make-state (input-var-seq vars vals m (mem gstate)) (pcc gstate) (code gstate))) + (rstate2 (make-state (input-vars-seq varsseqs valsseqs (mem rstate)) (pcc rstate) (code rstate)))))))) + + +(defun input-gem (vars vals m gstate) + (make-state (input-var-seq vars vals m (mem gstate)) (pcc gstate) (code gstate))) + +(defun input-rtm (varsseqs valsseqs rstate) + (make-state (input-vars-seq varsseqs valsseqs (mem rstate)) (pcc rstate) (code rstate))) + + + +(defthm all-properties-hold-after-correct-input1 + (implies + (and + (correct-input vars vals varsseqs valsseqs m gstate rstate) + (good-mapping m) + (good-mapping-wrt-memories m (mem gstate) (mem rstate)) + (good-translation-gem-rtm gstate rstate m) + (gem-statep gstate) + (rtm-statep rstate) + (>= (pcc gstate) 0) + (m-correspondent-values-p m (mem gstate) (mem rstate))) + (and + (good-mapping-wrt-memories + m + (mem (input-gem vars vals m gstate)) + (mem (input-rtm varsseqs valsseqs rstate))) + (good-translation-gem-rtm + (input-gem vars vals m gstate) + (input-rtm varsseqs valsseqs rstate) + m) + (gem-statep (input-gem vars vals m gstate)) + (rtm-statep (input-rtm varsseqs valsseqs rstate)) + (>= (pcc (input-gem vars vals m gstate)) 0) + (m-correspondent-values-p + m + (mem (input-gem vars vals m gstate)) + (mem (input-rtm varsseqs valsseqs rstate))))) + :hints (("Goal" + :in-theory nil + :use (input-gem + input-rtm + all-properties-hold-after-correct-input0)))) + +(defthm all-properties-hold-after-input-and-execution + (implies + (and + (integerp n) + (>= n 0) + (correct-input vars vals varsseqs valsseqs m gstate rstate) + (good-mapping m) + (good-mapping-wrt-memories m (mem gstate) (mem rstate)) + (good-translation-gem-rtm gstate rstate m) + (gem-statep gstate) + (rtm-statep rstate) + (>= (pcc gstate) 0) + (m-correspondent-values-p m (mem gstate) (mem rstate))) + (and + (good-mapping-wrt-memories + m + (mem (execute-n-instructions (input-gem vars vals m gstate) n)) + (mem (execute-n-instructions + (input-rtm varsseqs valsseqs rstate) + (correspondent-steps n (input-gem vars vals m gstate))))) + (good-translation-gem-rtm + (execute-n-instructions (input-gem vars vals m gstate) n) + (execute-n-instructions + (input-rtm varsseqs valsseqs rstate) + (correspondent-steps n (input-gem vars vals m gstate))) + m) + (gem-statep (execute-n-instructions (input-gem vars vals m gstate) n)) + (rtm-statep (execute-n-instructions + (input-rtm varsseqs valsseqs rstate) + (correspondent-steps n (input-gem vars vals m gstate)))) + (>= (pcc (execute-n-instructions (input-gem vars vals m gstate) n)) 0) + (m-correspondent-values-p + m + (mem (execute-n-instructions (input-gem vars vals m gstate) n)) + (mem (execute-n-instructions + (input-rtm varsseqs valsseqs rstate) + (correspondent-steps n (input-gem vars vals m gstate))))))) + :hints (("Goal" :in-theory '((:definition good-mapping) + (:definition good-mapping-wrt-memories)) + :use ( all-properties-hold-after-correct-input1 + (:instance m-correspondence-and-other-conditions-kept-execution-on-n + (gstate (input-gem vars vals m gstate)) + (rstate (input-rtm varsseqs valsseqs rstate))))))) + +(defun restart-program (gstate) + (make-state (mem gstate) 0 (code gstate))) + +(defthm hh1 + (implies (gem-statep s) (gem-statep (restart-program s))) + :rule-classes nil) + +(defthm hh2 + (implies (rtm-statep s) (rtm-statep (restart-program s))) + :rule-classes nil) + + +(defthm hh3 + (implies + (and + (good-mapping-wrt-memories m (mem gstate) (mem rstate)) + (good-translation-gem-rtm gstate rstate m) + (correct-translation gem-program rtm-program m) + (gem-statep gstate) + (rtm-statep rstate) + (m-correspondent-values-p m (mem gstate) (mem rstate))) + (and + (>= 0 (pcc (restart-program gstate))) + (good-mapping-wrt-memories + m + (mem (restart-program gstate)) + (mem (restart-program rstate))) + (m-correspondent-values-p + m + (mem (restart-program gstate)) + (mem (restart-program rstate))))) + :hints (("Goal" :in-theory '( + (:definition restart-program) + (:rewrite skkk0) + (:rewrite skkk1) + (:rewrite skkk2)))) + :rule-classes nil) + +(defthm hh5 + (and + (equal (code (restart-program s)) (code s)) + (equal (pcc (restart-program s)) (pcc (initial-state p))))) + +(defthm hh6 + (implies + (and + (gem-statep gstate) + (rtm-statep rstate) + (equal (code gstate) (code (initial-state gem-program))) + (equal (code rstate) (code (initial-state rtm-program))) + (correct-translation gem-program rtm-program m)) + (good-translation-gem-rtm + (restart-program gstate ) + (restart-program rstate ) + m)) + :hints (("Goal" :in-theory '((:definition make-state) + (:definition mem) + (:definition pcc) + (:definition code) + (:definition gem-statep) + (:definition rtm-statep) + (:definition correct-translation) + (:definition restart-program) + (:definition initial-state) + (:rewrite hh5) + (:rewrite skkk0) + (:rewrite skkk1) + (:rewrite skkk2)) + :use + ((:instance hh5 (s gstate) (p gem-program)) + (:instance hh5 (s rstate) (p rtm-program)) + (:instance correct-translation (gemprog gem-program) (rtmprog rtm-program)) + (:instance good-translation-is-independent-from-mem + (gstate (initial-state gem-program)) + (rstate (initial-state rtm-program)) + (gstate2 (restart-program gstate )) + (rstate2 (restart-program rstate )))))) + :rule-classes nil) + + + + +(defthm all-properties-hold-after-restarting-program + (implies + (and + (equal (code gstate) (code (initial-state gem-program))) + (equal (code rstate) (code (initial-state rtm-program))) + (correct-translation gem-program rtm-program m) + (good-mapping-wrt-memories m (mem gstate) (mem rstate)) + (good-translation-gem-rtm gstate rstate m) + (correct-translation gem-program rtm-program m) + (gem-statep gstate) + (rtm-statep rstate) + (m-correspondent-values-p m (mem gstate) (mem rstate))) + (and + (>= 0 (pcc (restart-program gstate))) + (good-mapping-wrt-memories + m + (mem (restart-program gstate)) + (mem (restart-program rstate))) + (good-translation-gem-rtm + (restart-program gstate) + (restart-program rstate) + m) + (gem-statep (restart-program gstate)) + (rtm-statep (restart-program rstate)) + (m-correspondent-values-p + m + (mem (restart-program gstate)) + (mem (restart-program rstate))))) + :hints (("Goal" :in-theory nil + :use ( + (:instance hh1 (s gstate)) + (:instance hh2 (s rstate)) + hh3 + hh6)))) + + +(defthm execution-after-input-gem-does-not-touch-code + (equal + (code (execute-n-instructions (input-gem vars vals m gstate) n)) + (code gstate)) + :hints (("Goal" + :in-theory (disable execute-n-instructions) + :use (:instance execute-n-instruction-does-not-touch-code + (st (input-gem vars vals m gstate)))))) + + +(defthm execution-after-input-rtm-does-not-touch-code + (equal + (code (execute-n-instructions (input-rtm varsseqs valsseqs rstate) n)) + (code rstate)) + :hints (("Goal" + :in-theory (disable execute-n-instructions) + :use (:instance execute-n-instruction-does-not-touch-code + (st (input-rtm varsseqs valsseqs rstate)))))) + + + + + + +(defthm m-correspondence-and-other-conditions-kept-execution-on-n-clean + (implies + (and + (integerp n) + (>= n 0) + (good-mapping m) + (good-mapping-wrt-memories m (mem gstate) (mem rstate)) + (good-translation-gem-rtm gstate rstate m) + (gem-statep gstate) + (rtm-statep rstate) + (>= (pcc gstate) 0) + (m-correspondent-values-p m (mem gstate) (mem rstate))) + (and + (good-mapping-wrt-memories m + (mem (execute-n-instructions gstate n)) + (mem (execute-n-instructions rstate (correspondent-steps n gstate)))) + (>= (pcc (execute-n-instructions gstate n)) 0) + (good-translation-gem-rtm + (execute-n-instructions gstate n) + (execute-n-instructions rstate (correspondent-steps n gstate)) m) + (rtm-statep (execute-n-instructions rstate (correspondent-steps n gstate))) + (gem-statep (execute-n-instructions gstate n)) + (m-correspondent-values-p + m + (mem (execute-n-instructions gstate n)) + (mem (execute-n-instructions rstate (correspondent-steps n gstate)))))) + :hints (("Goal" :in-theory '((:definition good-mapping) (:definition good-mapping-wrt-memories)) + :use m-correspondence-and-other-conditions-kept-execution-on-n))) + + + +(defthm trivialities-on-restart + (and + (>= (pcc (restart-program st)) 0) + (equal (code (restart-program st)) (code st)))) + + +(defthm equalities-on-io-clean + (implies + (and + (good-mapping m) + (good-mapping-wrt-memories m gem-typed-mem rtm-typed-mem) + (is-typed-amem-p gem-typed-mem) + (bounded-amem-p gem-typed-mem)) + (equal-memories (decode m (projectio rtm-typed-mem attr)) (projectio gem-typed-mem attr))) + :hints (("Goal" :use (equalities-on-io fact-bout-rns)))) + +(defthm sil00 + (implies (gem-statep gstate) + (and + (is-typed-amem-p (mem gstate)) + (bounded-amem-p (mem gstate)))) + :rule-classes nil) + +(defthm coherent-output-and-properties-hold + (implies + (and + (integerp n) + (>= n 0) + + (equal (code gstate) (code (initial-state gem-program))) + (equal (code rstate) (code (initial-state rtm-program))) + (correct-translation gem-program rtm-program m) + + (correct-input vars vals varsseqs valsseqs m gstate rstate) + (good-mapping m) + (good-mapping-wrt-memories m (mem gstate) (mem rstate)) + (good-translation-gem-rtm gstate rstate m) + (gem-statep gstate) + (rtm-statep rstate) + (>= (pcc gstate) 0) ) + (and + (equal-memories (decode m (projectio (mem rstate) attr)) (projectio (mem gstate) attr)) + (equal (code (restart-program (execute-n-instructions (input-gem vars vals m gstate) n))) + (code (initial-state gem-program))) + (equal (code (restart-program + (execute-n-instructions + (input-rtm varsseqs valsseqs rstate) + (correspondent-steps n (input-gem vars vals m gstate))))) + (code (initial-state rtm-program))) + (good-mapping-wrt-memories + m + (mem (restart-program (execute-n-instructions (input-gem vars vals m gstate) n))) + (mem (restart-program + (execute-n-instructions + (input-rtm varsseqs valsseqs rstate) + (correspondent-steps n (input-gem vars vals m gstate)))))) + (good-translation-gem-rtm + (restart-program (execute-n-instructions (input-gem vars vals m gstate) n)) + (restart-program + (execute-n-instructions + (input-rtm varsseqs valsseqs rstate) + (correspondent-steps n (input-gem vars vals m gstate)))) + m) + (gem-statep (restart-program (execute-n-instructions (input-gem vars vals m gstate) n))) + (rtm-statep + (restart-program + (execute-n-instructions + (input-rtm varsseqs valsseqs rstate) + (correspondent-steps n (input-gem vars vals m gstate))))) + (>= (pcc (restart-program (execute-n-instructions (input-gem vars vals m gstate) n))) 0) + (m-correspondent-values-p + m + (mem (restart-program (execute-n-instructions (input-gem vars vals m gstate) n))) + (mem (restart-program + (execute-n-instructions + (input-rtm varsseqs valsseqs rstate) + (correspondent-steps n (input-gem vars vals m gstate)))))))) + :hints (("Goal" :in-theory '((:definition good-mapping-wrt-memories)) + :use ( (:instance equalities-on-io-clean + (gem-typed-mem (mem gstate)) + (rtm-typed-mem (mem rstate))) + sil00 + all-properties-hold-after-correct-input1 + (:instance trivialities-on-restart (st (execute-n-instructions (input-gem vars vals m gstate) n))) + (:instance trivialities-on-restart + (st (execute-n-instructions + (input-rtm varsseqs valsseqs rstate) + (correspondent-steps n (input-gem vars vals m gstate))))) + (:instance m-correspondence-and-other-conditions-kept-execution-on-n-clean + (gstate (input-gem vars vals m gstate)) + (rstate (input-rtm varsseqs valsseqs rstate))) + (:instance all-properties-hold-after-restarting-program + (gstate (execute-n-instructions (input-gem vars vals m gstate) n)) + (rstate (execute-n-instructions + (input-rtm varsseqs valsseqs rstate) + (correspondent-steps n (input-gem vars vals m gstate))))) + execution-after-input-gem-does-not-touch-code + (:instance execution-after-input-rtm-does-not-touch-code + (n (correspondent-steps n (input-gem vars vals m gstate)))))))) + + + + +(defun equal-output-sequences (rmems gmems) + (if (or + (endp rmems) + (endp gmems)) + t + (and + (equal-memories (car rmems) (car gmems)) + (equal-output-sequences (cdr rmems) (cdr gmems))))) + + +(defun valid-input-sequences (gemseq-seq gemval-seq rtmseq-seq rtmval-seq m gstate rstate n) + (if (or + (endp gemseq-seq) + (endp rtmseq-seq)) + t + (and + (correct-input + (car gemseq-seq) + (car gemval-seq) + (car rtmseq-seq) + (car rtmval-seq) + m gstate rstate) + (valid-input-sequences + (cdr gemseq-seq) + (cdr gemval-seq) + (cdr rtmseq-seq) + (cdr rtmval-seq) + m + (restart-program (execute-n-instructions (input-gem (car gemseq-seq) (car gemval-seq) m gstate) n)) + (restart-program (execute-n-instructions + (input-rtm (car rtmseq-seq) (car rtmval-seq) rstate) + (correspondent-steps n (input-gem (car gemseq-seq) (car gemval-seq) m gstate)))) + n)))) + + +(defun build-gem-output (gemseq-seq gemval-seq m gstate n attr) + (if (endp gemseq-seq) + nil + (cons (projectio (mem gstate) attr) + (build-gem-output + (cdr gemseq-seq) + (cdr gemval-seq) + m + (restart-program (execute-n-instructions (input-gem (car gemseq-seq) (car gemval-seq) m gstate) n)) + n + attr)))) + +(defun build-rtm-output (rtmseq-seq rtmval-seq m gstate rstate n attr gemseq-seq gemval-seq) + (if + (endp rtmseq-seq) + nil + (cons (decode m (projectio (mem rstate) attr)) + (build-rtm-output + (cdr rtmseq-seq) + (cdr rtmval-seq) + m + (restart-program (execute-n-instructions (input-gem (car gemseq-seq) (car gemval-seq) m gstate) n)) + (restart-program + (execute-n-instructions + (input-rtm (car rtmseq-seq) (car rtmval-seq) rstate) + (correspondent-steps n (input-gem (car gemseq-seq) (car gemval-seq) m gstate)))) + n + attr + (cdr gemseq-seq) + (cdr gemval-seq))))) + +(defthm many-cycle-semantic-eqv0 + (implies + (and + (integerp n) + (>= n 0) + (equal (code gstate) (code (initial-state gem-program))) + (equal (code rstate) (code (initial-state rtm-program))) + (correct-translation gem-program rtm-program m) + (good-mapping m) + (good-mapping-wrt-memories m (mem gstate) (mem rstate)) + (good-translation-gem-rtm gstate rstate m) + (gem-statep gstate) + (rtm-statep rstate) + (>= (pcc gstate) 0) + (valid-input-sequences gemseq-seq gemval-seq rtmseq-seq rtmval-seq m gstate rstate n)) + (equal-output-sequences + (build-rtm-output rtmseq-seq rtmval-seq m gstate rstate n attr gemseq-seq gemval-seq) + (build-gem-output gemseq-seq gemval-seq m gstate n attr))) + :hints (("Goal" :induct (valid-input-sequences gemseq-seq gemval-seq rtmseq-seq rtmval-seq m gstate rstate n)) + ("Subgoal *1/3" :in-theory '((:definition valid-input-sequences))) + ("Subgoal *1/2" + :in-theory + (union-theories (current-theory 'ground-zero) + '((:definition valid-input-sequences) + (:definition equal-output-sequences) + (:definition build-gem-output) + (:definition build-rtm-output))) + :use (:instance coherent-output-and-properties-hold + (vars (car gemseq-seq)) + (vals (car gemval-seq)) + (varsseqs (car rtmseq-seq)) + (valsseqs (car rtmval-seq)))) + ("Subgoal *1/1" :in-theory (union-theories (current-theory 'ground-zero) + '((:definition build-rtm-output) + (:definition equal-output-sequences) + (:definition build-gem-output)))))) + + + + + + + + + + + + + + + + + + + + + + + + +(defthm semantic-eqv + (let* + ((gstate (initial-state gem-program)) + (rstate (initial-state rtm-program)) + (n (len (code gstate)))) + (implies + + (and + (gem-program-p gem-program) + (rtm-program-p rtm-program) + (correct-translation gem-program rtm-program m) + (good-mapping m) + (good-mapping-wrt-memories m (mem gstate) (mem rstate)) + (valid-input-sequences + gemseq-seq gemval-seq rtmseq-seq rtmval-seq m gstate rstate n)) + (equal-output-sequences + (build-rtm-output + rtmseq-seq rtmval-seq m gstate rstate n attr gemseq-seq gemval-seq) + (build-gem-output + gemseq-seq gemval-seq m gstate n attr)))) + :hints (("Goal" + :in-theory (current-theory 'ground-zero) + :use + ((:instance correct-translation + (gemprog gem-program) + (rtmprog rtm-program)) + (:instance many-cycle-semantic-eqv0 + (n (len (code (initial-state gem-program)))) + ;(n (len (code gstate))) + (gstate (initial-state gem-program)) + (rstate (initial-state rtm-program))) + (:instance simple-fact-about-initial-gemstate (gemprog gem-program)) + (:instance simple-fact-about-initial-rtmstate (rtmprog rtm-program)))))) +; +;(defun is-variable-mapping (m gm rm) +; (and +; (good-mapping m) +; (good-mapping-wrt-memories m gm rm))) + +(defun correct-input-sequences (gemseq-seq rtmseq-seq m gem-program rtm-program) + (valid-input-sequences (car gemseq-seq) + (cdr gemseq-seq) + (car rtmseq-seq) + (cdr rtmseq-seq) + m + (initial-state gem-program) + (initial-state rtm-program) + (len (code (initial-state gem-program))))) + + + +(defun declarations (prog) + (car prog)) + +(defun instructs (prog) + (cdr prog)) + +(defthm mem-and-code-of-initial-state + (and + (equal (mem (initial-state prog)) (declarations prog)) + (equal (code (initial-state prog)) (instructs prog)))) + +(defun gem-output-sequence (gemseq-seq m gem-program) + (build-gem-output (car gemseq-seq) (cdr gemseq-seq) m + (initial-state gem-program) + (len (code (initial-state gem-program))) + 'Output)) + +(defthm correspondent-steps-independent-from-mem + (implies + (and (equal (pcc st1) (pcc st2)) + (equal (code st1) (code st2))) + (equal (correspondent-steps n st1) (correspondent-steps n st2)))) + +(defthm correspondent-steps-no-matter-input + (equal + (correspondent-steps n (input-gem gemvars gemvals m gstate)) + (correspondent-steps n gstate)) + :hints (("Goal" :use (:instance correspondent-steps-independent-from-mem + (st1 (input-gem gemvars gemvals m gstate)) + (st2 gstate))))) + + +(defun build-rtm-output-clean (rtmseq-seq rtmval-seq m gstate rstate n attr) + (if + (endp rtmseq-seq) + nil + (cons (decode m (projectio (mem rstate) attr)) + (build-rtm-output-clean + (cdr rtmseq-seq) + (cdr rtmval-seq) + m + gstate + (restart-program + (execute-n-instructions + (input-rtm (car rtmseq-seq) (car rtmval-seq) rstate) + (correspondent-steps n gstate))) + n + attr)))) + +(defthm after-restarting-same-code + (equal + (code (restart-program (execute-n-instructions (input-gem gemvars gemvals m gstate) n))) + (code gstate)) + :hints (("Goal" + :in-theory '((:definition input-gem) + (:rewrite skkk2)) + :use ( (:instance execute-n-instruction-does-not-touch-code + (st (input-gem gemvars gemvals m gstate))) + (:instance trivialities-on-restart + (st (execute-n-instructions (input-gem gemvars gemvals m gstate) n))))))) + + +(defthm another-trivail-restart + (equal (pcc (restart-program st)) 0)) + + + +(defun build-rtm-output-induct (rtmseq-seq rtmval-seq m gstate gstate2 rstate n attr gemseq-seq gemval-seq) + (if + (endp rtmseq-seq) + nil + (cons (append rtmseq-seq rtmval-seq m gstate gstate2 rstate n attr gemseq-seq gemval-seq) + (build-rtm-output-induct + (cdr rtmseq-seq) + (cdr rtmval-seq) + m + (restart-program (execute-n-instructions (input-gem (car gemseq-seq) (car gemval-seq) m gstate) n)) + (restart-program (execute-n-instructions (input-gem (car gemseq-seq) (car gemval-seq) m gstate2) n)) + (restart-program + (execute-n-instructions + (input-rtm (car rtmseq-seq) (car rtmval-seq) rstate) + (correspondent-steps n (input-gem (car gemseq-seq) (car gemval-seq) m gstate)))) + n + attr + (cdr gemseq-seq) + (cdr gemval-seq))))) + + + +(defthm build-rtm-output-independent-from-gem-memory + (implies + (and (equal (pcc st1) (pcc st2)) + (equal (code st1) (code st2))) + (equal + (build-rtm-output rtmseq-seq rtmval-seq m st1 rstate n attr gemseq-seq gemval-seq) + (build-rtm-output rtmseq-seq rtmval-seq m st2 rstate n attr gemseq-seq gemval-seq))) + :hints + (("Goal" + :induct + (build-rtm-output-induct rtmseq-seq rtmval-seq m st1 st2 rstate n attr gemseq-seq gemval-seq)) + ("Subgoal *1/2" + :in-theory '((:definition build-rtm-output) + (:rewrite correspondent-steps-no-matter-input) + (:rewrite after-restarting-same-code) + (:rewrite another-trivail-restart)) + :use (correspondent-steps-independent-from-mem)))) + + + +(defun build-rtm-output-induct2 + (rtmseq-seq rtmval-seq m gstate gstate2 rstate n attr gemseq-seq gemval-seq gemseq-seq2 gemval-seq2) + (if + (endp rtmseq-seq) + nil + (cons (append rtmseq-seq rtmval-seq m gstate gstate2 rstate n attr gemseq-seq gemval-seq gemseq-seq2 gemval-seq2) + (build-rtm-output-induct2 + (cdr rtmseq-seq) + (cdr rtmval-seq) + m + (restart-program (execute-n-instructions (input-gem (car gemseq-seq) (car gemval-seq) m gstate) n)) + (restart-program (execute-n-instructions (input-gem (car gemseq-seq2) (car gemval-seq2) m gstate2) n)) + (restart-program + (execute-n-instructions + (input-rtm (car rtmseq-seq) (car rtmval-seq) rstate) + (correspondent-steps n (input-gem (car gemseq-seq) (car gemval-seq) m gstate)))) + n + attr + (cdr gemseq-seq) + (cdr gemval-seq) + (cdr gemseq-seq2) + (cdr gemval-seq2))))) + + + +(defthm build-rtm-output-independent-from-gem-input + (equal + (build-rtm-output rtmseq-seq rtmval-seq m gstate rstate n attr gemseq-seq gemval-seq) + (build-rtm-output rtmseq-seq rtmval-seq m gstate rstate n attr gemseq-seq2 gemval-seq2)) + :hints (("Goal" + :induct (build-rtm-output-induct2 rtmseq-seq rtmval-seq m gstate gstate rstate n attr + gemseq-seq gemval-seq gemseq-seq2 gemval-seq2)) + ("Subgoal *1/2" + :in-theory '((:definition build-rtm-output) + (:rewrite correspondent-steps-no-matter-input) + (:rewrite another-trivail-restart) + ;(:rewrite build-rtm-output-independent-from-gem-memory) + (:rewrite after-restarting-same-code)) + :use (:instance build-rtm-output-independent-from-gem-memory + (rtmseq-seq (cdr rtmseq-seq)) + (rtmval-seq (cdr rtmval-seq)) + (st1 (RESTART-PROGRAM + (EXECUTE-N-INSTRUCTIONS (INPUT-GEM (CAR GEMSEQ-SEQ) + (CAR GEMVAL-SEQ) + M GSTATE) N))) + (st2 (RESTART-PROGRAM + (EXECUTE-N-INSTRUCTIONS (INPUT-GEM (CAR GEMSEQ-SEQ2) + (CAR GEMVAL-SEQ2) + M GSTATE) N))) + (rstate + (RESTART-PROGRAM + (EXECUTE-N-INSTRUCTIONS (INPUT-RTM (CAR RTMSEQ-SEQ) + (CAR RTMVAL-SEQ) + RSTATE) + (CORRESPONDENT-STEPS N + (INPUT-GEM (CAR GEMSEQ-SEQ) + (CAR GEMVAL-SEQ) + M GSTATE))))) + (gemseq-seq (cdr gemseq-seq2)) + (gemval-seq (cdr gemval-seq2)))))) + + + + +(defun rtm-output-sequence (rtmseq-seq m gem-program rtm-program) + (build-rtm-output (car rtmseq-seq) + (cdr rtmseq-seq) + m + (initial-state gem-program) + (initial-state rtm-program) + (len (code (initial-state gem-program))) + 'Output + nil + nil)) + + + + +(defthm semantic-eqv2 + (implies + (and + (gem-program-p gem-program) + (rtm-program-p rtm-program) + (correct-translation gem-program rtm-program m) + (is-variable-mapping + m + (declarations gem-program) + (declarations rtm-program)) + (correct-input-sequences + gemseq-seq rtmseq-seq m gem-program rtm-program)) + (equal-output-sequences + (rtm-output-sequence rtmseq-seq m gem-program rtm-program) + (gem-output-sequence gemseq-seq m gem-program))) + + :hints (("Goal" + :in-theory (union-theories (current-theory 'ground-zero) + '((:rewrite mem-and-code-of-initial-state) + (:definition rtm-output-sequence) + (:definition gem-output-sequence) + (:definition correct-input-sequences) + (:definition gem-variables) + (:definition rtm-variables) + (:definition same-vars) + (:definition good-mapping) + (:definition good-mapping-wrt-memories) + (:definition is-variable-mapping))) + :use ((:instance build-rtm-output-independent-from-gem-input + (rtmseq-seq (car rtmseq-seq)) + (rtmval-seq (cdr rtmseq-seq)) + (gstate (initial-state gem-program)) + (rstate (initial-state rtm-program)) + (n (LEN (CODE (INITIAL-STATE GEM-PROGRAM)))) + (attr 'Output) + (gemseq-seq (car gemseq-seq)) + (gemval-seq (cdr gemseq-seq)) + (gemseq-seq2 nil) + (gemval-seq2 nil)) + (:instance redefinition-of-m-corr + (rtm-vars (declarations rtm-program)) + (gem-vars (declarations gem-program))) + (:instance semantic-eqv (attr 'Output) + (gemseq-seq (car gemseq-seq)) + (gemval-seq (cdr gemseq-seq)) + (rtmseq-seq (car rtmseq-seq)) + (rtmval-seq (cdr rtmseq-seq))))))) + + + + + + + +(defun semantically-equivalent + (gem-program rtm-program m gemseq-seq rtmseq-seq) + (implies + (correct-input-sequences + gemseq-seq rtmseq-seq m gem-program rtm-program) + (equal-output-sequences + (rtm-output-sequence rtmseq-seq m gem-program rtm-program) + (gem-output-sequence gemseq-seq m gem-program)))) + +(defun syntactically-equivalent (gem-program rtm-program m) + (and + (gem-program-p gem-program) + (rtm-program-p rtm-program) + (is-variable-mapping + m + (declarations gem-program) + (declarations rtm-program)) + (correct-translation gem-program rtm-program m))) + + + +(defthm syntactic-eqv-implies-m-eqv + (let + ((gstate (initial-state gem-program)) + (rstate (initial-state rtm-program))) + (implies + (and + (natp n) + (syntactically-equivalent gem-program rtm-program m)) + (is-variable-mapping + m + (mem (execute-n-instructions gstate n)) + (mem (execute-n-instructions rstate (correspondent-steps n gstate)))))) + :hints (("Goal" :use + ( (:instance simple-fact-about-initial-rtmstate (rtmprog rtm-program)) + (:instance simple-fact-about-initial-gemstate (gemprog gem-program)) + (:instance redefinition-of-m-corr + (rtm-vars (declarations rtm-program)) + (gem-vars (declarations gem-program))) + (:instance redefinition-of-m-corr + (rtm-vars (mem (execute-n-instructions + (initial-state rtm-program) + (correspondent-steps n (initial-state gem-program))))) + (gem-vars (mem (execute-n-instructions (initial-state gem-program) n)))) + (:instance m-correspondence-and-other-conditions-kept-execution-on-n + (gstate (initial-state gem-program)) + (rstate (initial-state rtm-program)))) + :in-theory + '( (:definition natp) + (:definition syntactically-equivalent) + (:definition same-vars) + (:definition correct-translation) + (:definition gem-variables) + (:definition rtm-variables) + (:definition is-variable-mapping) + (:rewrite mem-and-code-of-initial-state))))) + + + +(in-theory (union-theories (current-theory 'ground-zero) + '((:definition semantically-equivalent) + (:definition syntactically-equivalent) + (:rewrite semantic-eqv2)))) + +(defthm syntactic-eqv-implies-semantic-eqv + (implies + (syntactically-equivalent gem-program rtm-program m) + (semantically-equivalent + gem-program rtm-program m gemseq-seq rtmseq-seq))) + + + diff --git a/books/workshops/1999/embedded/Proof-Of-Contribution/Proof-Of-Equiv-From-M-Corr.lisp b/books/workshops/1999/embedded/Proof-Of-Contribution/Proof-Of-Equiv-From-M-Corr.lisp new file mode 100644 index 0000000..bb06f01 --- /dev/null +++ b/books/workshops/1999/embedded/Proof-Of-Contribution/Proof-Of-Equiv-From-M-Corr.lisp @@ -0,0 +1,1320 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Section 4: Definition of m-correspondence +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; +;;; Definition of mapping-induced correspondence: +;;; +;;; In order for a Gem memory and and Rtm memory to be m-correspondent via m, +;;; the following conditions must hold: +;;; +;;; - Correctness w.r.t. the types of the variables appearing into the memories: +;;; I.e., m must map boolean Gem variables into single Rtm variables, and integer Gem +;;; variables into tuples of |*rns*| Rtm variables; +;;; +;;; - Correctness w.r.t. the values and attributes of the variables appearing into the memories: +;;; for each entry of the mapping, +;;; the values obtained by direct application of rns to the gem variable of the entry must +;;; match those of the rtm variables, and +;;; the attributes of the rtm variables must match that of the rtm variable. +;;; +;;; - A mapping must have every Gem variable within the range of the Gem memory it references +;;; +;;; - A mapping must contain every variable of the Gem memory it references +;;; +;;; +;;; Similar properties to the least two will be needed for the Rtm memories (e.g., every Rtm +;;; variable should be in the range of the Rtm memory), when proving properties about +;;; programs. We will insert them then. +;;; + + + +(in-package "ACL2") + +(include-book "CRTcorollaries") + +(in-theory (current-theory 'ground-zero)) + +(include-book "Mapping") + + +;;; +;;; Subsection 4.1: +;;; +;;; Memories must be correspondent via m in terms of types +;;; + + + +(defun correct-wrt-arity (m gem-typed-mem) + (if (endp m) + (null m) + (and + (correct-type (type-0 m)) + (equal + (type-0 m) + (var-type (get-cell (gemvar-0 m) gem-typed-mem))) + (correct-wrt-arity (cdr m) gem-typed-mem)))) + +(defthm correct-arity-all-i-need + (implies + (and + (not (endp m)) + (correct-wrt-arity m gem-typed-mem)) + (and + (correct-type (type-0 m)) + (equal + (type-0 m) + (var-type (get-cell (gemvar-0 m) gem-typed-mem))) + (not (null (var-attributes (rtmintvars-0 m) rtm-typed-mem))) + (correct-wrt-arity (cdr m) gem-typed-mem)))) + + + +;; +;; Section 4.5: +;; +;; Every entry of the mapping must point to a coherent set of rtm variables, i.e. to a set of of rtm +;; variables which share the same attribute. +;; + +(defun get-common-value (l) + (if (equal-elements (car l) (cdr l)) + (car l) + 'error-value)) + +(defthm if-every-element-matches-val-then-get-common-value-amounts-to-val + (implies + (and + (true-listp l) + (not (null l)) + (equal-elements v l)) + (equal (get-common-value l) v))) + +(in-theory (disable if-every-element-matches-val-then-get-common-value-amounts-to-val)) + + +(defun m-entries-point-to-good-rtm-var-sets (m rtm-typed-mem) + (if (endp m) + (null m) + (and + (not (endp (rtmintvars-0 m))) + (true-listp (rtmintvars-0 m)) + (not (equal 'error-value (get-common-value (var-attributes (rtmintvars-0 m) rtm-typed-mem)))) + (m-entries-point-to-good-rtm-var-sets (cdr m) rtm-typed-mem)))) + +(in-theory (disable m-entries-point-to-good-rtm-var-sets)) + + + +;;; +;;; Subsection 4.6: +;;; +;;; Values and attributes must be correspondent via the mapping. +;;; +;;; In order to allow this definition, we first provide +;;; definitions of transformations of gem values into tuples of rtm values (by *rns*) and +;;; viceversa (by inverse application of *rns*). +;;; +;;; Notice that these transformations are actually just ``stubs'', since we provide a +;;; simplified form of axiomatization of the chinese remainder inversion theorem. +;;; Additional hypothesis (e.g., boundedness of Gem and Rtm integers, and relations between such +;;; bounds) shall (and will) be added and taken into account when proving properties of programs. +;;; In the cureent state of the proof, however, we can limit ourselves to consider 'generic' +;;; transformations of Gem vars into tuples of Rtm vars, and their corresponding generic inverse. +;;; +;;; However, since memories could contain nil cells, we have to lift our transformations, and +;;; the 'simplified axiomatization of CRT', to deal with nils. +;;; +;;; We extend transformations so that nils transform into sequences of nils and viceversa. +;;; We lift the simplified CRT axiomatization to such extended version. +;;; +;;; + + + + +(defun make-null-list (l) + (if (endp l) + nil + (cons nil (make-null-list (cdr l))))) + +(defthm make-null-list-is-invariant-on-value-slicing (equal (make-null-list rtmvars) (make-null-list (var-values rtmvars rm)))) + +(in-theory (disable make-null-list-is-invariant-on-value-slicing)) + +(defun equal-values (val-list-1 val-list-2) + (equal val-list-1 val-list-2)) + +(defun build-values-by-rns (gem-value rns) + (if (endp rns) + nil + (cons (mod gem-value (car rns)) + (build-values-by-rns gem-value (cdr rns))))) + +(in-theory (enable build-values-by-rns)) + +(defun mod-extended-for-nil (val1 val2) + (if (null val1) + nil + (mod val1 val2))) + +(defun build-values-by-rns-extended-for-nil (gem-value rns) + (if (endp rns) + nil + (cons (mod-extended-for-nil gem-value (car rns)) + (build-values-by-rns-extended-for-nil gem-value (cdr rns))))) + +(defthm build-values-by-rns-extended-behaves-standardly-on-non-nils + (implies + (not (null gem-value)) + (equal + (build-values-by-rns-extended-for-nil gem-value rns) + (build-values-by-rns gem-value rns)))) + +(defthm build-values-by-rns-extended-for-nils-provides-integers-from-integer + (implies + (and + (integerp val) + (not (null rns)) + (integer-listp rns)) + (and + (not (null (build-values-by-rns-extended-for-nil val rns))) + (integer-listp (build-values-by-rns-extended-for-nil val rns))))) + + + + +(defun build-value-by-inverse-rns (rtm-values rns) + (crtmod rtm-values rns)) + + +(defun build-value-by-inverse-rns-extended-for-nil (rtm-values rns) + (if + (integer-listp rtm-values) + (crtmod rtm-values rns) + nil)) + + +(defthm build-value-by-inverse-rns-extended-for-nils-behaves-standardly-on-integer-lists + (implies + (integer-listp rtm-values) + (equal + (build-value-by-inverse-rns-extended-for-nil rtm-values rns) + (build-value-by-inverse-rns rtm-values rns)))) + + + + +(defthm crt-inversion-inst + (implies + (and + (rel-prime-moduli rns) + (natp gem-value) + (< gem-value (prod rns))) + (equal + (build-value-by-inverse-rns (build-values-by-rns gem-value rns) rns) + gem-value)) + :hints (("Goal" :in-theory (enable crt-inversion)))) + + +(in-theory (enable natp)) + + +(defthm crt-inversion-extended-to-nils-in-integer-case + (implies + (and + (rel-prime-moduli rns) + (< gem-value (prod rns)) + (not (null rns)) + (integer-listp rns) + (natp gem-value)) + (equal + (build-value-by-inverse-rns-extended-for-nil (build-values-by-rns-extended-for-nil gem-value rns) rns) + gem-value)) + :hints (("goal" + :use ( + crt-inversion-inst + build-values-by-rns-extended-behaves-standardly-on-non-nils + (:instance build-value-by-inverse-rns-extended-for-nils-behaves-standardly-on-integer-lists + (rtm-values (build-values-by-rns gem-value rns))) + (:instance build-values-by-rns-extended-for-nils-provides-integers-from-integer + (val gem-value)))))) + +(defthm crt-inversion-extended-to-nils-in-nil-case + (implies + (and + (rel-prime-moduli rns) + (not (null rns)) + (integer-listp rns) + (null gem-value)) + (equal + (build-value-by-inverse-rns-extended-for-nil (build-values-by-rns-extended-for-nil gem-value rns) rns) + gem-value))) + +(defthm crt-inversion-extended-to-nils + (implies + (and + (rel-prime-moduli rns) + (integer-listp rns) + (not (null rns)) + (or + (null gem-value) + (and + (natp gem-value) + (< gem-value (prod rns))))) + (equal + (build-value-by-inverse-rns-extended-for-nil (build-values-by-rns-extended-for-nil gem-value rns) rns) + gem-value)) + :hints (("goal" + :cases ( + (and (not (null gem-value)) (not (and (natp gem-value) (< gem-value (prod rns))))) + (null gem-value) + (and (natp gem-value) (< gem-value (prod rns))))) + ("Subgoal 2" :use crt-inversion-extended-to-nils-in-nil-case) + ("subgoal 1" :use (:instance crt-inversion-extended-to-nils-in-integer-case)))) + + +(in-theory (disable build-values-by-rns-extended-for-nil + build-values-by-rns + build-value-by-inverse-rns-extended-for-nil + build-value-by-inverse-rns + build-values-by-rns-extended-behaves-standardly-on-non-nils + build-values-by-rns-extended-for-nils-provides-integers-from-integer + build-value-by-inverse-rns-extended-for-nils-behaves-standardly-on-integer-lists + crt-inversion-extended-to-nils-in-integer-case + crt-inversion-extended-to-nils-in-nil-case)) + + + + + + + +;; +;; m-correspondence definition w.r.t. values and attributes of memories +;; + + + + +(defun apply-direct-rns-to-value-according-to-type (gem-cell type) + (cond + ( (equal type 'bool) + (list (var-value gem-cell))) + ( (equal type 'int) + (build-values-by-rns-extended-for-nil (var-value gem-cell) *rns*)) + ( t nil))) + + + +(defun apply-invers-rns-to-values-according-to-type (vals type) + (cond + ( (equal type 'bool) + (car vals) ) + ( (equal type 'int) + (build-value-by-inverse-rns-extended-for-nil vals *rns*)) + ( t nil ))) + + + + +(defun invert-cell (rtmvars rtm-typed-mem type) + (if + (equal-values + (var-values rtmvars rtm-typed-mem) + (make-null-list rtmvars)) + (apply-invers-rns-to-values-according-to-type + (var-values rtmvars rtm-typed-mem) + type) + (make-cell + (apply-invers-rns-to-values-according-to-type + (var-values rtmvars rtm-typed-mem) + type) + (get-common-value (var-attributes rtmvars rtm-typed-mem)) + type))) + +(defun equal-values-and-attributes (gem-cell rtmvars rtm-typed-mem type) +(and + (equal-values + (var-values rtmvars rtm-typed-mem) + (apply-direct-rns-to-value-according-to-type gem-cell type)) + (equal-elements + (var-attribute gem-cell) + (var-attributes rtmvars rtm-typed-mem)))) + + + +(defthm apply-direct-rns-unfolding-for-integer-case + (implies + (equal type 'int) + (equal + (apply-direct-rns-to-value-according-to-type gem-cell type) + (build-values-by-rns-extended-for-nil (var-value gem-cell) *rns*)))) + +(defthm apply-direct-rns-unfolding-for-boolean-case + (implies + (equal type 'bool) + (equal + (apply-direct-rns-to-value-according-to-type gem-cell type) + (list (var-value gem-cell))))) + + + +(defthm apply-inverse-rns-unfolding-for-integer-case + (implies + (equal type 'int) + (equal (apply-invers-rns-to-values-according-to-type values type) + (build-value-by-inverse-rns-extended-for-nil values *rns*)))) + + +(defthm apply-inverse-direct-retrieves-same-value-for-typed-cells + (implies + (and + (rel-prime-moduli *rns*) + (integer-listp *rns*) + (not (null *rns*)) + (or + (equal type 'int) + (equal type 'bool)) + (or + (and + (natp (var-value gem-cell)) + (< (var-value gem-cell) (prod *rns*))) + (null (var-value gem-cell)))) + (equal + (apply-invers-rns-to-values-according-to-type + (apply-direct-rns-to-value-according-to-type gem-cell type) type) + (var-value gem-cell))) + :hints (("goal" :cases ( (equal type 'bool) + (equal type 'int))) + ("subgoal 1" + :in-theory (disable null + apply-inverse-rns-unfolding-for-integer-case + crt-inversion-extended-to-nils + apply-direct-rns-unfolding-for-integer-case + apply-direct-rns-to-value-according-to-type + var-value + apply-invers-rns-to-values-according-to-type + build-value-by-inverse-rns-extended-for-nil + build-values-by-rns-extended-for-nil) + :use ((:instance apply-direct-rns-unfolding-for-integer-case) + (:instance apply-inverse-rns-unfolding-for-integer-case (values (build-values-by-rns-extended-for-nil (var-value gem-cell) *rns*))) + (:instance crt-inversion-extended-to-nils (rns *rns*) (gem-value (var-value gem-cell))))))) + + + + +(defthm inversion-for-empty-cell + (implies + (and + (null cell) + (equal-values (var-values rtmvars rm) (apply-direct-rns-to-value-according-to-type cell type)) + (correct-type type)) + (and + (equal-values (var-values rtmvars rm) (make-null-list rtmvars)) + (equal (apply-invers-rns-to-values-according-to-type (var-values rtmvars rm) type) cell))) + :hints (("goal" + :in-theory (enable make-null-list-is-invariant-on-value-slicing) + :cases ( (equal type 'bool) (equal type 'int))))) + + +(in-theory (disable make-cell)) + + +(defthm ad-hoc-2-for-inversion-of-one-nonempty-cell-by-decode + (implies + (and (not (null bui)) (integer-listp bui)) + (not (equal (make-null-list l) bui)))) + + +(defthm ad-hoc-3-for-inversion-of-one-nonempty-cell-by-decode + (implies + (integerp (var-value cell)) + (not (equal (make-null-list l) (build-values-by-rns-extended-for-nil (var-value cell) *rns*)))) + :hints (("goal" :use ((:instance build-values-by-rns-extended-for-nils-provides-integers-from-integer + (val (var-value cell)) (rns *rns*)) + (:instance ad-hoc-2-for-inversion-of-one-nonempty-cell-by-decode + (l l) + (bui (build-values-by-rns-extended-for-nil (var-value cell) *rns*))))))) + +(defthm nonempty-cell-is-not-mapped-into-nils-by-rns + (implies + (and + (true-listp (var-attributes rtmvars rm)) + (not (null (var-attributes rtmvars rm))) + (is-mem-cell-p cell) + (not (null cell)) + (equal-values (var-values rtmvars rm) (apply-direct-rns-to-value-according-to-type cell type)) + (equal-elements (var-attribute cell) (var-attributes rtmvars rm)) + (equal type (var-type cell))) + (not (equal-values (var-values rtmvars rm) (make-null-list rtmvars)))) + :hints (("goal" :cases ( (equal type 'bool) (equal type 'int))))) + + + +(in-theory (disable my-or-2 my-or-3)) + +(defthm silly00 + (IMPLIES (AND (TRUE-LISTP CELL6) + (EQUAL (+ 3 (LEN CELL6)) 3)) + (NOT CELL6)) + :rule-classes nil) + +(defthm reconstruction-of-cell + (implies + (is-mem-cell-p cell) + (equal + (make-cell + (var-value cell) + (var-attribute cell) + (var-type cell)) + cell)) + :hints (("Subgoal 1.1" :use silly00) + ("Subgoal 2.1" :use silly00) + ("goal" + :in-theory + (union-theories (current-theory 'ground-zero) + '((:definition is-mem-cell-p) + (:definition make-cell) + (:definition var-type) + (:definition var-value) + (:definition var-attribute))))) + :rule-classes nil) + + + +(defthm nonempty-rtm-vars-which-correspond-to-gem-var-by-values-and-atributes-map-back-to-gem-var + (implies + (and + (rel-prime-moduli *rns*) + (integer-listp *rns*) + (not (null *rns*)) + (true-listp (var-attributes rtmvars rm)) + (not (null (var-attributes rtmvars rm))) + (is-mem-cell-p cell) + (not (null cell)) + (natp (var-value cell)) + (< (var-value cell) (prod *rns*)) + (equal-values (var-values rtmvars rm) (apply-direct-rns-to-value-according-to-type cell type)) + (equal-elements (var-attribute cell) (var-attributes rtmvars rm)) + (equal type (var-type cell))) + (equal + (make-cell + (apply-invers-rns-to-values-according-to-type (var-values rtmvars rm) type) + (get-common-value (var-attributes rtmvars rm)) + type) + cell)) + :hints (("goal" :in-theory '((:definition my-or-2) + (:definition is-mem-cell-p) + (:definition natp) + (:definition equal-values) + (:definition is-mem-cell-p)) + :use (reconstruction-of-cell + (:instance if-every-element-matches-val-then-get-common-value-amounts-to-val + (l (var-attributes rtmvars rm)) (v (var-attribute cell))) + (:instance apply-inverse-direct-retrieves-same-value-for-typed-cells + (type type) (gem-cell cell)))))) + + + + + + + + + + +(defthm decode-inversion-for-nonempty-gem-cell + (implies + (and + (rel-prime-moduli *rns*) + (integer-listp *rns*) + (not (null *rns*)) + (true-listp (var-attributes rtmvars rm)) + (not (null (var-attributes rtmvars rm))) + (is-mem-cell-p cell) + (not (null cell)) + (natp (var-value cell)) + (< (var-value cell) (prod *rns*)) + (equal-values (var-values rtmvars rm) (apply-direct-rns-to-value-according-to-type cell type)) + (equal-elements (var-attribute cell) (var-attributes rtmvars rm)) + (equal type (var-type cell))) + (and + (not (equal-values (var-values rtmvars rm) (make-null-list rtmvars))) + (equal + (make-cell + (apply-invers-rns-to-values-according-to-type (var-values rtmvars rm) type) + (get-common-value (var-attributes rtmvars rm)) + type) + cell))) + :hints (("goal" :use (nonempty-cell-is-not-mapped-into-nils-by-rns + nonempty-rtm-vars-which-correspond-to-gem-var-by-values-and-atributes-map-back-to-gem-var)))) + + + + + + +(defthm var-attributes-always-true-listp + (true-listp (var-attributes rtmvars rtm-typed-mem))) + +(defun bounded-value (cell) + (if (null cell) + t + (and (natp (var-value cell)) (< (var-value cell) (prod *rns*))))) + +(defthm invert-cell-inverts-for-m-correspondents + (implies + (and + (rel-prime-moduli *rns*) + (integer-listp *rns*) + (not (null *rns*)) + (not (null (var-attributes rtmvars rtm-typed-mem))) + (equal type (var-type gem-cell)) + (correct-type type) + (or (null gem-cell) (is-mem-cell-p gem-cell)) + (bounded-value gem-cell) + (equal-values-and-attributes gem-cell rtmvars rtm-typed-mem type)) + (equal + (invert-cell rtmvars rtm-typed-mem type) + gem-cell)) + :hints (("Goal" + :in-theory (disable equal-values) + :use ( var-attributes-always-true-listp + (:instance decode-inversion-for-nonempty-gem-cell + (cell gem-cell) + (rm rtm-typed-mem)) + (:instance inversion-for-empty-cell + (cell gem-cell) + (rm rtm-typed-mem)))))) + + +(defun is-typed-amem-p (mem) + (if (endp mem) + (null mem) + (and + (consp (car mem)) + (is-mem-cell-p (cdr (car mem))) + (is-typed-amem-p (cdr mem))))) + +(in-theory (enable get-cell)) + +(defthm any-cell-of-a-typed-mem-is-nil-or-a-typed-cell + (implies + (is-typed-amem-p gem-typed-mem) + (or + (and + (null (assoc-equal v gem-typed-mem)) + (null (get-cell v gem-typed-mem))) + (is-mem-cell-p (get-cell v gem-typed-mem)))) + :rule-classes nil) + + + + + + + + +(defun m-correspondent-values-p (m gem-typed-mem rtm-typed-mem) + (cond + ( (endp m) + (null m) ) + ( t + (and + (equal-values-and-attributes + (get-cell (gemvar-0 m) gem-typed-mem) + (rtmintvars-0 m) + rtm-typed-mem (type-0 m)) + (m-correspondent-values-p (cdr m) gem-typed-mem rtm-typed-mem))))) + +(defun decode (m rtm-typed-mem) + (if + (endp m) + nil + (put-cell + (gemvar-0 m) + (invert-cell (rtmintvars-0 m) rtm-typed-mem (type-0 m)) + (decode (cdr m) rtm-typed-mem)))) + + +(defthm silly1 + (equal (caar m) (gemvar-0 m))) + +(in-theory (disable silly1)) + +(defthm silly2 + (implies + (correct-wrt-arity m gem-typed-mem) + (correct-wrt-arity (cdr m) gem-typed-mem))) + +(in-theory (disable silly1 silly2)) + +(defun bounded-amem-p (mem) + (if + (endp mem) + (null mem) + (and (bounded-value (cdr (car mem))) + (bounded-amem-p (cdr mem))))) + +(defthm any-cell-of-bounded-mem-is-bounded + (implies + (bounded-amem-p gem-typed-mem) + (bounded-value (get-cell v gem-typed-mem))) + :rule-classes nil) + +(defthm decode-equals-retrieve-vars + (implies + (and + (rel-prime-moduli *rns*) + (integer-listp *rns*) + (not (null *rns*)) + (m-correspondent-values-p m gem-typed-mem rtm-typed-mem) + (is-typed-amem-p gem-typed-mem) + (bounded-amem-p gem-typed-mem) + (correct-wrt-arity m gem-typed-mem)) + (equal + (decode m rtm-typed-mem) + (retrieve-vars m gem-typed-mem))) + :hints (("Goal" :induct (len m)) + ("Subgoal *1/1" + :in-theory nil + :use (silly1 + silly2 + decode + (:instance retrieve-vars (vars m) (mem gem-typed-mem)) + m-correspondent-values-p + (:instance any-cell-of-a-typed-mem-is-nil-or-a-typed-cell (v (gemvar-0 m))) + (:instance any-cell-of-bounded-mem-is-bounded (v (gemvar-0 m))) + correct-arity-all-i-need + (:instance invert-cell-inverts-for-m-correspondents + (rtmvars (rtmintvars-0 m)) + (gem-cell (get-cell (gemvar-0 m) gem-typed-mem)) + (type (type-0 m))))))) + + +(defthm decode-retrieves-gem-memory + (implies + (and + (rel-prime-moduli *rns*) + (integer-listp *rns*) + (not (null *rns*)) + (vars-inclusion gem-typed-mem m) + (vars-inclusion m gem-typed-mem) + (m-correspondent-values-p m gem-typed-mem rtm-typed-mem) + (is-typed-amem-p gem-typed-mem) + (bounded-amem-p gem-typed-mem) + (correct-wrt-arity m gem-typed-mem)) + (equal-memories (decode m rtm-typed-mem) gem-typed-mem)) + :hints (("Goal" :in-theory (enable retrieving-keeps-equality)))) + + +(defun projectiocell (cell attr) + (if (null cell) + cell + (if (equal (var-attribute cell) attr) + cell + nil ))) + +(defun projectio (mem attr) + (if (endp mem) + nil + (put-cell (caar mem) + (projectiocell (cdr (car mem)) attr) + (projectio (cdr mem) attr)))) + + + +(defthm cell-of-projected-mem-is-projected-cell + (equal + (get-cell cell (projectio mem attr)) + (projectiocell (get-cell cell mem) attr))) + + + + +(defthm projection-of-null-list-is-null-list + (implies + (equal-values (var-values l rtm-typed-mem) (make-null-list l)) + (equal-values (var-values l (projectio rtm-typed-mem attr)) (make-null-list l)))) + + +(defthm null-cell-corresponds-to-null-lists-of-values + (implies + (and + (null gem-cell) + (equal-values-and-attributes gem-cell rtmvars rtm-typed-mem type)) + (equal-values (var-values rtmvars rtm-typed-mem) (make-null-list rtmvars))) + :hints (("Goal" :in-theory (disable get-cell var-value var-attribute )))) + + + +(defthm project-invert-commute-for-empty-cell + (implies + (and + (null gem-cell) + (equal-values-and-attributes gem-cell rtmvars rtm-typed-mem type)) + (equal (projectiocell (invert-cell rtmvars rtm-typed-mem type) attr) + (invert-cell rtmvars (projectio rtm-typed-mem attr) type))) + :hints (("Goal" :use (null-cell-corresponds-to-null-lists-of-values + (:instance projection-of-null-list-is-null-list (l rtmvars)))))) + + + +(defthm rtmvars-correspondent-to-nonemptycell-is-not-emptylist + (implies + (and + (not (null (var-attributes rtmvars rtm-typed-mem))) + (equal type (var-type gem-cell)) + (correct-type type) + (not (null gem-cell)) + (equal (var-attribute gem-cell) attr) + (is-mem-cell-p gem-cell) + (equal-values-and-attributes gem-cell rtmvars rtm-typed-mem type)) + (not + (equal-values + (var-values rtmvars rtm-typed-mem) + (make-null-list rtmvars))))) + + + + +(defthm values-remain-the-same-if-correspondent-attrs + (implies + (and + (not (null (var-attributes rtmvars rtm-typed-mem))) + (equal type (var-type gem-cell)) + (correct-type type) + (not (null gem-cell)) + (equal (var-attribute gem-cell) attr) + (is-mem-cell-p gem-cell) + (equal-values-and-attributes gem-cell rtmvars rtm-typed-mem type)) + (equal + (var-values rtmvars (projectio rtm-typed-mem attr)) + (var-values rtmvars rtm-typed-mem))) + :hints (("Goal" :do-not '(generalize)))) + + + +(defthm attributes-same-1 + (implies + (equal-elements attr (var-attributes rtmvars rtm-typed-mem)) + (equal + (var-attributes rtmvars (projectio rtm-typed-mem attr)) + (var-attributes rtmvars rtm-typed-mem)))) + + + + +(defthm inversion-2-for-nonempty-projected-on-same-attr + (implies + (and + (not (null (var-attributes rtmvars rtm-typed-mem))) + (equal type (var-type gem-cell)) + (correct-type type) + (not (null gem-cell)) + (equal (var-attribute gem-cell) attr) + (is-mem-cell-p gem-cell) + (equal-values-and-attributes gem-cell rtmvars rtm-typed-mem type)) + (equal (invert-cell rtmvars (projectio rtm-typed-mem attr) type) + (invert-cell rtmvars rtm-typed-mem type))) + :hints (("Goal" :in-theory nil + ;; modified for Version 2.7 fertilization + :use ( + (:instance invert-cell (rtm-typed-mem (projectio rtm-typed-mem attr))) + invert-cell + equal-values-and-attributes + (:instance attributes-same-1 (attr (var-attribute gem-cell))) + rtmvars-correspondent-to-nonemptycell-is-not-emptylist + values-remain-the-same-if-correspondent-attrs) + :expand ((:free (x) (hide x)))))) + + +(defthm inversion-1-for-nonempty-projected-on-different-attr + (implies + (and + (not (null (var-attributes rtmvars rtm-typed-mem))) + (equal type (var-type gem-cell)) + (correct-type type) + (not (null gem-cell)) + (not (equal (var-attribute gem-cell) attr)) + (is-mem-cell-p gem-cell) + (equal-values-and-attributes gem-cell rtmvars rtm-typed-mem type)) + (equal (projectiocell (invert-cell rtmvars rtm-typed-mem type) attr) + nil))) + + +(defthm projecting-on-different-attr-gets-nils + (implies + (and + (not (equal (var-attribute gem-cell) attr)) + (equal-values-and-attributes gem-cell rtmvars rtm-typed-mem type)) + (equal-values + (var-values rtmvars (projectio rtm-typed-mem attr)) + (make-null-list rtmvars)))) + + + +(defthm decode-one-entry-of-null-list-is-nil +(implies + (and + (true-listp l) + (not (endp l)) + (equal-values (var-values l rtm-typed-mem) (make-null-list l))) + (equal (apply-invers-rns-to-values-according-to-type (var-values l rtm-typed-mem) ty) nil)) + :hints(("goal" :in-theory (enable build-value-by-inverse-rns-extended-for-nil)))) + + +(defthm inversion-2-for-nonempty-projected-on-different-attr + (implies + (and + (true-listp rtmvars) + (not (null rtmvars)) + (not (equal (var-attribute gem-cell) attr)) + (equal-values-and-attributes gem-cell rtmvars rtm-typed-mem type)) + (equal (invert-cell rtmvars (projectio rtm-typed-mem attr) type) + nil)) + :hints (("Goal" :use + ((:instance decode-one-entry-of-null-list-is-nil + (l rtmvars) + (rtm-typed-mem (projectio rtm-typed-mem attr)) + (ty type)) + (:instance invert-cell (rtm-typed-mem (projectio rtm-typed-mem attr))) + projecting-on-different-attr-gets-nils)))) + + + + +(defthm inversion-for-nonempty-projected-on-different-attr + (implies + (and + (true-listp rtmvars) + (not (null rtmvars)) + (not (null (var-attributes rtmvars rtm-typed-mem))) + (equal type (var-type gem-cell)) + (correct-type type) + (not (null gem-cell)) + (not (equal (var-attribute gem-cell) attr)) + (is-mem-cell-p gem-cell) + (equal-values-and-attributes gem-cell rtmvars rtm-typed-mem type)) + (equal (projectiocell (invert-cell rtmvars rtm-typed-mem type) attr) + (invert-cell rtmvars (projectio rtm-typed-mem attr) type))) + :hints (("Goal" + :in-theory nil + :use + (inversion-1-for-nonempty-projected-on-different-attr + inversion-2-for-nonempty-projected-on-different-attr)))) + + + + + +(defthm project-invert-commuting + (implies + (and + (true-listp rtmvars) + (not (null rtmvars)) + (not (null (var-attributes rtmvars rtm-typed-mem))) + (or + (null gem-cell) + (equal type (var-type gem-cell))) + (correct-type type) + (or (null gem-cell) (is-mem-cell-p gem-cell)) + (equal-values-and-attributes gem-cell rtmvars rtm-typed-mem type)) + (equal (projectiocell (invert-cell rtmvars rtm-typed-mem type) attr) + (invert-cell rtmvars (projectio rtm-typed-mem attr) type))) + :hints (("Goal" :cases + ( (and (not (null gem-cell)) (not (equal (var-attribute gem-cell) attr))) + (and (not (null gem-cell)) (equal (var-attribute gem-cell) attr)))) + ("Subgoal 3" :use project-invert-commute-for-empty-cell) + ("Subgoal 2" :use inversion-for-nonempty-projected-on-different-attr))) + +(defthm letssimplify + (implies + (and + (true-listp rtmvars) + (not (null rtmvars))) + (not (null (var-attributes rtmvars rtm-typed-mem))))) + + +(defthm project-invert-commuting-better + (implies + (and + (true-listp rtmvars) + (not (null rtmvars)) + (or + (null gem-cell) + (equal type (var-type gem-cell))) + (correct-type type) + (or (null gem-cell) (is-mem-cell-p gem-cell)) + (equal-values-and-attributes gem-cell rtmvars rtm-typed-mem type)) + (equal (projectiocell (invert-cell rtmvars rtm-typed-mem type) attr) + (invert-cell rtmvars (projectio rtm-typed-mem attr) type))) + :hints (("Goal" :use (letssimplify project-invert-commuting)))) + + + +(in-theory (enable + m-entries-point-to-good-rtm-var-sets + m-correspondent-values-p)) + +(in-theory (disable gemvar-0 rtmintvars-0)) + +(defthm lil-helper + (implies + (and + (not (endp m)) + (is-typed-amem-p gem-typed-mem) + (correct-wrt-arity m gem-typed-mem) + (m-entries-point-to-good-rtm-var-sets m rtm-typed-mem) + (m-correspondent-values-p m gem-typed-mem rtm-typed-mem)) + (and + (or + (null (get-cell (gemvar-0 m) gem-typed-mem)) + (is-mem-cell-p (get-cell (gemvar-0 m) gem-typed-mem))) + (true-listp (rtmintvars-0 m)) + (not (null (rtmintvars-0 m))) + (correct-type (type-0 m)) + (or + (null (get-cell (gemvar-0 m) gem-typed-mem)) + (equal (type-0 m) (var-type (get-cell (gemvar-0 m) gem-typed-mem)))) + (equal-values-and-attributes + (get-cell (gemvar-0 m) gem-typed-mem) + (rtmintvars-0 m) + rtm-typed-mem + (type-0 m)) + (correct-wrt-arity (cdr m) gem-typed-mem) + (m-entries-point-to-good-rtm-var-sets (cdr m) rtm-typed-mem) + (m-correspondent-values-p (cdr m) gem-typed-mem rtm-typed-mem))) + :hints (("Goal" :use (:instance any-cell-of-a-typed-mem-is-nil-or-a-typed-cell + (v (gemvar-0 m))))) + :rule-classes nil) + + + +(defun decode-projection (m rtm-typed-mem attr) + (if (endp m) + nil + (put-cell (gemvar-0 m) + (projectiocell + (invert-cell + (rtmintvars-0 m) + rtm-typed-mem + (type-0 m)) + attr) + (decode-projection (cdr m) rtm-typed-mem attr)))) + + +(in-theory (enable m-entries-point-to-good-rtm-var-sets)) + +(defthm project-of-decode-is-decode-projection + (equal + (projectio (decode m rtm-typed-mem) attr) + (decode-projection m rtm-typed-mem attr))) + + +(defthm decode-projection-is-decode-of-projection + (implies + (and + (is-typed-amem-p gem-typed-mem) + (correct-wrt-arity m gem-typed-mem) + (m-entries-point-to-good-rtm-var-sets m rtm-typed-mem) + (m-correspondent-values-p m gem-typed-mem rtm-typed-mem)) + (equal + (decode-projection m rtm-typed-mem attr) + (decode m (projectio rtm-typed-mem attr)))) + :hints (("Goal" :induct (len m)) + ("Subgoal *1/1" :in-theory nil + :use (lil-helper + (:instance decode (rtm-typed-mem (projectio rtm-typed-mem attr))) + decode-projection + (:instance project-invert-commuting-better + (type (type-0 m)) + (gem-cell (get-cell (gemvar-0 m) gem-typed-mem)) + (rtmvars (rtmintvars-0 m))))))) + + + +(defthm decode-project-commuting + (implies + (and + (is-typed-amem-p gem-typed-mem) + (correct-wrt-arity m gem-typed-mem) + (m-entries-point-to-good-rtm-var-sets m rtm-typed-mem) + (m-correspondent-values-p m gem-typed-mem rtm-typed-mem)) + (equal + (projectio (decode m rtm-typed-mem) attr) + (decode m (projectio rtm-typed-mem attr))))) + + + +(in-theory (disable get-cell put-cell)) + +(defthm equalwrt-holds-on-project + (implies + (equal-wrt-vars m0 m1 m2) + (equal-wrt-vars m0 (projectio m1 attr) (projectio m2 attr)))) + +(defthm projectio-keeps-caars + (same-caars-p m0 (projectio m0 attr)) + :hints (("Goal" :in-theory (enable put-cell)))) + + +(defthm equalwrt-holds-on-project-all + (implies + (equal-wrt-vars m0 m1 m2) + (equal-wrt-vars (projectio m0 attr) m1 m2)) + :hints (("Goal" :use (:instance if-same-caars-same-equality-wrt-vars + (vars1 m0) + (vars2 (projectio m0 attr)) + (mem1 m1) + (mem2 m2))))) + +(defthm equalwrt-holds-on-project-all-all + (implies + (equal-wrt-vars m0 m1 m2) + (equal-wrt-vars (projectio m0 attr) (projectio m1 attr) (projectio m2 attr))) + :hints (("Goal" :use (:instance if-same-caars-same-equality-wrt-vars + (vars1 m0) + (vars2 (projectio m0 attr)) + (mem1 m1) + (mem2 m2))))) + +(defthm equal-memories-holds-by-projection + (implies + (equal-memories m1 m2) + (equal-memories (projectio m1 attr) (projectio m2 attr)))) + + + + +(defthm equalities-on-io + (implies + (and + (rel-prime-moduli *rns*) + (integer-listp *rns*) + (not (null *rns*)) + (m-entries-point-to-good-rtm-var-sets m rtm-typed-mem) + (vars-inclusion gem-typed-mem m) + (vars-inclusion m gem-typed-mem) + (m-correspondent-values-p m gem-typed-mem rtm-typed-mem) + (is-typed-amem-p gem-typed-mem) + (bounded-amem-p gem-typed-mem) + (correct-wrt-arity m gem-typed-mem)) + (equal-memories (decode m (projectio rtm-typed-mem attr)) (projectio gem-typed-mem attr))) + :hints (("Goal" + :in-theory (enable + equal-memories-commutative + retrieving-keeps-equality + decode-equals-retrieve-vars + equal-wrt-vars-reflexive + equal-wrt-vars-transitive + equalwrt-holds-on-project-all) + :use ( (:instance equal-memories-holds-by-projection + (m1 (decode m rtm-typed-mem)) + (m2 gem-typed-mem)))))) + + +(defthm fact-bout-rns-v0 + (and + (integer-listp *rns*) + (rel-prime-moduli *rns*) + (posp-all *rns*) + (not (null *rns*)) + (natp (prod *rns*)) + (> (prod *rns*) 1)) + :hints (("Goal" :in-theory (enable prod posp rel-prime-moduli rel-prime-all rel-prime g-c-d + posp-all + (:executable-counterpart nonneg-int-gcd)))) + :rule-classes nil) + +(defun append-lists (list-of-lists) + (if (endp list-of-lists) + nil + (append (car list-of-lists) + (append-lists (cdr list-of-lists))))) + +(defun retrieve-gemvars (m) + (if + (endp m) + nil + (cons (gemvar-0 m) (retrieve-gemvars (cdr m))))) + +(defun retrieve-rtmvars (m) + (if (endp m) + nil + (cons (cdr (car m)) + (retrieve-rtmvars (cdr m))))) + +(defun gem-variables (m) (retrieve-gemvars m)) +(defun rtm-variables (m) (append-lists (retrieve-rtmvars m))) + +(defun same-vars (m1 m2) + (and + (vars-inclusion m1 m2) + (vars-inclusion m2 m1))) + +(defun member-equal-bool (el l) + (declare (xargs :guard (true-listp l))) + (cond ((endp l) nil) + ((equal el (car l)) t) + (t (member-equal-bool el (cdr l))))) + +(defun no-tmp-into-mapping (m) + (if (endp m) + t + (and + (not (member-equal-bool 'tmp (rtmintvars-0 m))) + (no-tmp-into-mapping (cdr m))))) + +(defun no-duplicates-p (l) + (if (endp l) + t + (and (not (member-equal-bool (car l) (cdr l))) + (no-duplicates-p (cdr l))))) + + +(defun apply-direct-rns-to-value-depending-on-type (gemvalue type) + (cond ( (equal type 'bool) (list gemvalue) ) + ( (equal type 'int) (build-values-by-rns-extended-for-nil gemvalue *rns*) ) + ( t nil ))) + +(defun represent-same-values-p (gemvalue rtmvalues type) + (equal-values + rtmvalues + (apply-direct-rns-to-value-depending-on-type gemvalue type))) + + +(defun m-correspondent-vals-p (m gem-typed-mem rtm-typed-mem) + (cond + ( (endp m) + (null m) ) + ( t + (and + (represent-same-values-p + (var-value (get-cell (gemvar-0 m) gem-typed-mem)) + (var-values (rtmintvars-0 m) rtm-typed-mem) + (type-0 m)) + (m-correspondent-vals-p (cdr m) gem-typed-mem rtm-typed-mem))))) + + +(defun attributes-correspondence (m gem-typed-mem rtm-typed-mem) + (if (endp m) + (null m) + (and + (not (endp (rtmintvars-0 m))) + (true-listp (rtmintvars-0 m)) + (not (equal 'error-value (get-common-value (var-attributes (rtmintvars-0 m) rtm-typed-mem)))) + (equal-elements + (var-attribute (get-cell (gemvar-0 m) gem-typed-mem)) + (var-attributes (rtmintvars-0 m) rtm-typed-mem)) + (attributes-correspondence (cdr m) gem-typed-mem rtm-typed-mem)))) + + +(defthm redefinition-of-m-corr + (equal + (and + (m-entries-point-to-good-rtm-var-sets m rtm-vars) + (m-correspondent-values-p m gem-vars rtm-vars)) + (and + (attributes-correspondence m gem-vars rtm-vars) + (m-correspondent-vals-p m gem-vars rtm-vars))) + :rule-classes nil) + + + +(defun is-variable-mapping (m gem-vars rtm-vars) + (and + (alistp m) + (no-tmp-into-mapping m) + (no-duplicates-p (gem-variables m)) + (no-duplicates-p (rtm-variables m)) + (correct-wrt-arity m gem-vars) + (same-vars gem-vars m) + (attributes-correspondence m gem-vars rtm-vars) + (m-correspondent-vals-p m gem-vars rtm-vars))) + +(defun output (mem) (projectio mem 'Output)) + +(defun is-gem-mem-p (mem) + (and (is-typed-amem-p mem) + (bounded-amem-p mem))) + +(defthm mapping-correspondence-implies-same-outputs + (implies + (and + (is-variable-mapping m gem-mem rtm-mem) + (is-gem-mem-p gem-mem)) + (equal-memories + (output gem-mem) + (decode m (output rtm-mem)))) + :hints (("Goal" :use + (fact-bout-rns-v0 + (:instance redefinition-of-m-corr + (gem-vars gem-mem) + (rtm-vars rtm-mem)) + (:instance equalities-on-io + (gem-typed-mem gem-mem) + (rtm-typed-mem rtm-mem)) + (:instance equal-memories-commutative + (mem1 (output gem-mem)) + (mem2 (decode m (output rtm-mem))))))) + :rule-classes nil) + + + +(in-theory (disable correct-arity-all-i-need + if-every-element-matches-val-then-get-common-value-amounts-to-val + make-null-list-is-invariant-on-value-slicing + build-values-by-rns-extended-for-nils-provides-integers-from-integer + build-value-by-inverse-rns-extended-for-nils-behaves-standardly-on-integer-lists + crt-inversion-extended-to-nils-in-integer-case + apply-direct-rns-unfolding-for-integer-case + apply-direct-rns-unfolding-for-boolean-case + apply-inverse-direct-retrieves-same-value-for-typed-cells + inversion-for-empty-cell + ad-hoc-2-for-inversion-of-one-nonempty-cell-by-decode + ad-hoc-3-for-inversion-of-one-nonempty-cell-by-decode + nonempty-cell-is-not-mapped-into-nils-by-rns + nonempty-rtm-vars-which-correspond-to-gem-var-by-values-and-atributes-map-back-to-gem-var + decode-inversion-for-nonempty-gem-cell + invert-cell-inverts-for-m-correspondents + ;any-cell-of-a-typed-mem-is-nil-or-a-typed-cell + silly1 + silly2 + decode-equals-retrieve-vars + decode-retrieves-gem-memory + cell-of-projected-mem-is-projected-cell + projection-of-null-list-is-null-list + null-cell-corresponds-to-null-lists-of-values + project-invert-commute-for-empty-cell + rtmvars-correspondent-to-nonemptycell-is-not-emptylist + values-remain-the-same-if-correspondent-attrs + attributes-same-1 + inversion-2-for-nonempty-projected-on-different-attr + inversion-1-for-nonempty-projected-on-different-attr + projecting-on-different-attr-gets-nils + decode-one-entry-of-null-list-is-nil + inversion-2-for-nonempty-projected-on-different-attr + inversion-for-nonempty-projected-on-different-attr + project-invert-commuting + letssimplify + project-invert-commuting-better + decode-projection-is-decode-of-projection + decode-project-commuting + equalwrt-holds-on-project-all + equalwrt-holds-on-project-all-all + equal-memories-holds-by-projection + equalities-on-io)) + + + + + + + + diff --git a/books/workshops/1999/embedded/Proof-Of-Contribution/README b/books/workshops/1999/embedded/Proof-Of-Contribution/README new file mode 100644 index 0000000..835b967 --- /dev/null +++ b/books/workshops/1999/embedded/Proof-Of-Contribution/README @@ -0,0 +1,77 @@ + + + CONTENTS: +--------------------------------------------------------------------------------------------------- + +CRT.lisp Proof script for the Chinese Remainder Theorem, + as supplied by David Russinoff. + +CRTcorollaries.lisp Some corollaries to the Chinese Remainder + Theorem; namely, a theorem for uniqueness of inversion. + +Disjoint-lists.lisp Some lemmas about disjunct lists, + used to prove the inversion properties for mappings. + +Generic.lisp Some generic lemmas about arithmetics. + +Memory-Assoc.lisp Formalization of memories and operations upon + them, using association lists. + +Mapping.lisp Formalization of the notion of mapping. + +Minimal-Mod-Lemmas.lisp A book to export some necessary lemmas about mod. + A certified version is also present. + +private-qr-lemmas.lisp A slightly modified version of the quotient-remainder + book, that also exports some previously local lemma. + A certified version is also present. + + +Proof-Of-Equiv-From-M-Corr.lisp Proof of statement (1.8) in the paper. + +Proof-Of-Correctness-OneCycle.lisp Proof of statement (1.5) in the paper. It includes: + - Proof of the correct translation of the + comparison operation (between integers, and + between integer and boolean) + + - Proof of the correct translation of the + subtraction operation (between integers, and + between integer and boolean) + + - Proof of the correct translation of the + sum operation (between integers, and + between integer and boolean) + +Proof-Of-Correctness.lisp Proof of statement (1.4) in the paper. + + + +HOW TO RUN THE PROOFS +------------------------------------------------------------------------------- + +To run the ACL2 script of the proof described in ``Design verification +of a safety-critical embedded verifier'', you can simply run make in +this directory. Alternatively, follow steps 1-11: + + + 1 - Run ACL2 and (certify-book "private-qr-lemmas"). Exit ACL2. + + 2 - Run ACL2 and (certify-book "Minimal-Mod-Lemmas"). Exit ACL2. + + 3 - Run ACL2 and (certify-book "CRT"). Exit ACL2. + + 4 - Run ACL2 and (certify-book "CRTcorollaries"). Exit ACL2. + + 5 - Run ACL2 and (certify-book "Generic"). Exit ACL2. + + 6 - Run ACL2 and (certify-book "Memory-Assoc"). Exit ACL2. + + 7 - Run ACL2 and (certify-book "Mapping"). Exit ACL2. + + 8 - Run ACL2 and (certify-book "Proof-Of-Equiv-From-M-Corr"). Exit ACL2. + + 9 - Run ACL2 and (certify-book "Disjoint-lists"). Exit ACL2. + +10 - Run ACL2 and (certify-book "Proof-Of-Correctness-OneCycle"). Exit ACL2. + +11 - Run ACL2 and (certify-book "Proof-Of-Correctness"). Exit ACL2. diff --git a/books/workshops/1999/embedded/Proof-Of-Contribution/private-qr-lemmas.lisp b/books/workshops/1999/embedded/Proof-Of-Contribution/private-qr-lemmas.lisp new file mode 100644 index 0000000..d1879d2 --- /dev/null +++ b/books/workshops/1999/embedded/Proof-Of-Contribution/private-qr-lemmas.lisp @@ -0,0 +1,3211 @@ +; quotient-remainder-lemmas.lisp -- facts about FLOOR, MOD, TRUNCATE and REM +; Copyright (C) 1997 Computational Logic, Inc. +; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2. + +;;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +;;; +;;; quotient-remainder-lemmas.lisp +;;; +;;; This book includes facts about the functions FLOOR, MOD, TRUNCATE and +;;; REM, and integer ratios. +;;; +;;; Bishop Brock +;;; Computational Logic, Inc. +;;; 1717 West 6th Street, Suite 290 +;;; Austin, Texas 78703 +;;; (512) 322-9951 +;;; brock@cli.com +;;; +;;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +(in-package "ACL2") + +(deflabel quotient-remainder-lemmas + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section quotient-remainder-lemmas +; +; A book of facts about FLOOR, MOD, TRUNCATE and REM, and integer ratios. +; Also enough of a theory of the Acl2 function NONNEGATIVE-INTEGER-QUOTIENT +; to prove the rules. +; ~/ + +; Since NONNEGATIVE-INTEGER-QUOTIENT is the only one of these functions that +; is recursive, the others must be DISABLEd for this library to be of any +; use. This can easily be done by DISABLEing the QUOTIENT-REMAINDER-FUNCTIONS +; theory (defined by this book): + +; (IN-THEORY (DISABLE QUOTIENT-REMAINDER-FUNCTIONS)) + +; ~/ +; INTRODUCTION + +; Common Lisp defines the quotient/remainder functions FLOOR/MOD and +; TRUNCATE/REM, which operate on any rational numbers (as long as the divisor +; is non-zero). Both (TRUNCATE x y) and (FLOOR x y) are integers, and +; specify the `integer part' of the rational number x/y; they differ in the +; direction of rounding. + +; TRUNCATE is the `FORTRAN-style' quotient operation, rounding towards 0, +; i.e., (TRUNCATE x y) = (TRUNCATE (ABS x) (ABS y)). This book provides a +; selected theory of TRUNCATE and REM. + +; (FLOOR x y) is identical to TRUNCATE if x/y > 0 or x/y is an integer, +; otherwise for negative non-integer ratios x/y, +; (FLOOR x y) = (TRUNCATE x y) - 1. (FLOOR i (EXPT 2 j)) is the +; specification of an `arithmetic shift' of the integer i by -j bits. Since +; FLOOR and MOD are the foundations for integer descriptions of hardware, +; this book contains a very extensive theory of FLOOR and MOD. + +; The formal definitions of the Common Lisp functions are made in terms of +; the Acl2 function NONNEGATIVE-INTEGER-QUOTIENT, which is simple recursive +; specification of division of nonnegative integers by repeated subtraction. +; We provide only enough of a theory of NONNEGATIVE-INTEGER-QUOTIENT to prove +; the desired properties of the Common Lisp functions. + +; DOCUMENTATION + +; The documentation for this library is divided into a number of sections. +; There is a section for the rules that apply to each function. Some of the +; rules will appear in more than 1 section. If a rule is exported DISABLEd, +; then you will see `(D)' after the rule class in the `one-liner' for the +; rule. Note that we often abbreviate NONNEGATIVE-INTEGER-QUOTIENT as NIQ. + +; APPROACH + +; We have tried to capture the properties of the quotient/remainder functions +; with the smallest number of the most general rules possible. This approach +; takes advantage of Acl2 type reasoning, and the assumed existence of a +; basic mathematics simplification library. Several lemmas contain the +; hypothesis (INTEGERP (/ x y)), which we consider to be the simplest +; statement of the fact that (<quotient> x y) = x/y, e.g. + +; (INTEGERP (/ x y)) ==> (FLOOR x y) = (/ x y), +; (INTEGERP (/ x y)) ==> (MOD x y) = 0. + +; Thus, the first fact above obviates the need for a specials lemmas like +; (FLOOR i 1) = i for integers i, since (/ i 1) = i by simplification. + +; In general, at most 2 of the many possible commutative forms of the rules are +; exported from this library. If they aren't the ones you need, simply prove +; the appropriate corollary, or :USE an :INSTANCE of the library rule. +; Also, lemmas are generally exported DISABLEd if they seemed to interfere +; with the proofs of other lemmas, or could easily lead to infinite looping. +; Be careful when ENABLEing these lemmas. + +; Questions, comments, and sugestions are welcome. Contact brock@cli.com.~/" + ) + +(deflabel niq-lemmas + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section quotient-remainder-lemmas +; Lemmas about nonnegative-integer-QUOTIENT (abbreviated NIQ). +; ~/~/~/" + ) + +(deflabel floor-lemmas + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section quotient-remainder-lemmas +; Lemmas about FLOOR. +; ~/~/~/" + ) + +(deflabel truncate-lemmas + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section quotient-remainder-lemmas +; Lemmas about TRUNCATE. +; ~/~/~/" + ) + +(deflabel mod-lemmas + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section quotient-remainder-lemmas +; Lemmas about MOD. +; ~/~/~/" + ) + +(deflabel rem-lemmas + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section quotient-remainder-lemmas +; Lemmas about REM. +; ~/~/~/" + ) + +(deflabel integer-ratio-lemmas + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section quotient-remainder-lemmas +; Lemmas about ratios x/y that are known to be INTEGERP. +; ~/~/~/" + ) + + +;;;**************************************************************************** +;;; +;;; ENVIRONMENT -- Load books and initialize the theory. +;;; +;;;**************************************************************************** + +;;; Global rules. + +(include-book "../../../../ihs/ihs-init") +(include-book "../../../../ihs/ihs-theories") +(local (include-book "../../../../ihs/math-lemmas")) +(local (in-theory nil)) + +(local (in-theory (enable basic-boot-strap ; From ihs-theories + ;; From math-lemmas + ihs-math + rationalp-algebra + ifix nfix))) + + +;;;**************************************************************************** +;;; +;;; DEFINITIONS and GUARD MACROS +;;; +;;;**************************************************************************** + +(deflabel qr-guard-macros + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section quotient-remainder-lemmas +; Macro forms of the guards for the quotient/remainder functions. +; ~/ +; Without these macros, fully 25% of the text of the +; \"quotient-remainder-lemmas\" book is given over simply to expressing +; the guards!~/~/" + + ) + +(defmacro niq-guard (i j) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; ":doc-section qr-guard-macros +; Macro form of the guard for NONNEGATIVE-INTEGER-QUOTIENT (forced). +; ~/~/~" + + (mlambda (i j) + (and (force (integerp i)) + (force (>= i 0)) + (force (integerp j)) + (force (> j 0))))) + +(defmacro qr-guard (x y) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; ":doc-section qr-guard-macros +; Quotient/Remainder GUARD: Macro form of the guards for FLOOR, MOD, TRUNCATE, +; and REM., or any ratio x/y of rationals (forced). +; ~/~/~" + + (mlambda (x y) + (and (force (rationalp x)) + (force (rationalp y)) + (force (not (equal 0 y)))))) + + +;;;**************************************************************************** +;;; +;;; LOCAL LEMMAS -- A few special rules derived from the more general +;;; rules included above. +;;; +;;;**************************************************************************** + +(local + (defthm cancel-<-+-3 + (equal (< (+ x y z) y) + (< (+ x z) 0)) + :hints (("Goal" :in-theory (enable rewrite-linear-equalities-to-iff))))) + +(local + (defthm cancel-equal-+-3 + (implies (acl2-numberp y) + (equal (equal (+ x y z) y) + (equal (fix x) (- z)))))) + +(local + (defthm cancel-equal-+-right + (equal (equal (+ y x) (+ z x)) + (equal (fix y) (fix z))))) + +; This theory is useful for proving certain types of bounds properties, but +; will cause thrashing in linear arithmetic unless the hypotheses e.g. +; x <= y can be relieved. + +(local + (defthm ratio-theory-of-1 + (and + (implies + (and (qr-guard x y) (<= 0 x) (< 0 y) (< x y)) + (< (/ x y) 1)) + (implies + (and (qr-guard x y) (<= 0 x) (< 0 y) (<= y x)) + (<= 1 (/ x y))) + (implies + (and (qr-guard x y) (<= 0 x) (< y 0) (< x (- y))) + (< -1 (/ x y))) + (implies + (and (qr-guard x y) (<= 0 x) (< y 0) (<= (- y) x)) + (<= (/ x y) -1)) + (implies + (and (qr-guard x y) (<= 0 x) (< y 0) (<= x (- y))) + (<= -1 (/ x y))) + (implies + (and (qr-guard x y) (<= x 0) (< 0 y) (< (- x) y)) + (< -1 (/ x y))) + (implies + (and (qr-guard x y) (<= x 0) (< 0 y) (<= y (- x))) + (<= (/ x y) -1)) + (implies + (and (qr-guard x y) (<= x 0) (< 0 y) (<= (- x) y)) + (<= -1 (/ x y))) + (implies + (and (qr-guard x y) (<= x 0) (< y 0) (< (- x) (- y))) + (< (/ x y) 1)) + (implies + (and (qr-guard x y) (<= x 0) (< y 0) (<= (- y) (- x))) + (<= 1 (/ x y)))) + :rule-classes :linear + :hints + (("Goal" + :in-theory (enable prefer-*-to-/ + rewrite-linear-equalities-to-iff))))) + + +;;;**************************************************************************** +;;; +;;; LEMMAS -- Begin proving lemmas. +;;; +;;;**************************************************************************** + +(deflabel begin-quotient-remainder-lemmas) + +;;;**************************************************************************** +;;; +;;; NONNEGATIVE-INTEGER-QUOTIENT +;;; +;;;**************************************************************************** + +(local (defthm niq-bounds-help-1 + (implies (and (rationalp i) + (< 0 j) + (rationalp j) + (rationalp x)) + (equal (< (+ -1 (* i (/ j))) x) + (< i (+ j (* j x))))) + :hints (("Goal" :in-theory + (set-difference-theories + (enable rewrite-linear-equalities-to-iff) + '(<-*-left-cancel)) + :use (:instance <-*-left-cancel + (z j) (y x) (x (/ (+ i (- j)) j))))) + :rule-classes nil)) + +(defthm niq-bounds + (implies + (niq-guard i j) + (and (<= (nonnegative-integer-quotient i j) (/ i j)) + (< (- (/ i j) 1) (nonnegative-integer-quotient i j)))) + :rule-classes + ((:linear :trigger-terms ((nonnegative-integer-quotient i j)))) + :hints + (("Goal" :in-theory (enable ifix nfix nonnegative-integer-quotient + ratio-theory-of-1)) + ("Subgoal *1/2.2" :use + (:instance niq-bounds-help-1 + (i i) (j j) + (x (nonnegative-integer-quotient (+ i (- j)) + j))))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section niq-lemmas +; Linear (D): i/j - 1 < (NIQ i j) <= i/j. +; ~/ + +; This lemma serves as a :LINEAR definition of NONNEGATIVE-INTEGER-QUOTIENT, +; and allows us to derive interesting properties of FLOOR and TRUNCATE by +; linear arithmetic. This lemma is stored as a :LINEAR rule under NIQ +; since we think of this as a property of NIQ, and not as a general property +; of (/ I J).~/~/" + ) + +;< Although the following follows naturally from NIQ-BOUNDS, it can't be +;proved by linear alone, probably because (/ i j) is `too heavy'. + +(defthm niq-type + (implies + (niq-guard i j) + (and + (equal (equal (nonnegative-integer-quotient i j) 0) + (< i j)) + (equal (< 0 (nonnegative-integer-quotient i j)) + (>= i j)) + (equal (equal (nonnegative-integer-quotient i j) (/ i j)) + (integerp (/ i j))))) + :rule-classes + ((:rewrite) + (:linear + :corollary + (implies + (and (>= i j) + (niq-guard i j)) + (< 0 (nonnegative-integer-quotient i j)))) + (:rewrite + :corollary + (implies + (and (< i j) + (niq-guard i j)) + (equal (nonnegative-integer-quotient i j) + 0))) + (:rewrite + :corollary + (implies + (and (equal r (/ i j)) + (integerp r) + (niq-guard i j)) + (equal (nonnegative-integer-quotient i j) r)))) + :hints + (("Goal" + :in-theory (disable niq-bounds <-*-/-left) + :use (niq-bounds))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section niq-lemmas +; Various : Decide (NIQ i j) = 0, (NIQ i j) > 0, and +; (NIQ i j) = i/j based on the inequalities of i and j, and the INTEGERP-ness +; of i/j. +; ~/~/~/" + ) + + +;;;**************************************************************************** +;;; +;;; TRUNCATE and REM +;;; +;;; We begin with TRUNCATE and REM since we will sometimes prove properties of +;;; FLOOR from a definition of FLOOR in terms of TRUNCATE. Since TRUNCATE +;;; doesn't figure into our hardware specification, however, it's theory is +;;; somewhat TRUNCATEd! +;;; +;;;**************************************************************************** + +(defthm truncate-rem-elim + (implies + (qr-guard x y) + (equal (+ (rem x y) (* y (truncate x y))) + x)) + :rule-classes (:rewrite :elim) + :hints + (("Goal" + :in-theory (enable rem))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section truncate-lemmas +; Rewrite: (+ (REM x y) (* y (TRUNCATE x y))) = x. +; ~/ +; NB: This rule is also stored as an :ELIM rule.~/~/ +; :cited-by rem-lemmas" + ) + +(defthm truncate-=-x/y + (implies + (qr-guard x y) + (equal (equal (truncate x y) (/ x y)) + (integerp (/ x y)))) + :hints + (("Goal" :in-theory + (set-difference-theories (enable truncate equal-*-x-y-x) + '(commutativity-of-*)))) + :rule-classes + ((:rewrite) + (:generalize) + (:rewrite + :corollary + (implies + (and (equal r (/ x y)) + (integerp r) + (qr-guard x y)) + (equal (truncate x y) r)))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section truncate-lemmas +; Rewrite: (TRUNCATE x y) = x/y, when x/y is an integer. +; ~/ +; This rule is a corollary of a more general equality, which is also stored +; as a :REWRITE and :GENERALIZE rule.~/~/ +; :cited-by integer-ratio-lemmas" + ) + +;< This is a fast and beautiful proof, using the :LINEAR rule NIQ-BOUNDS. + +(defthm truncate-bounds + (and + (implies + (and (>= x 0) (> y 0) (qr-guard x y)) + (and (< (- (/ x y) 1) (truncate x y)) + (<= (truncate x y) (/ x y)))) + (implies + (and (<= x 0) (< y 0) (qr-guard x y)) + (and (< (- (/ x y) 1) (truncate x y)) + (<= (truncate x y) (/ x y)))) + (implies + (and (>= x 0) (< y 0) (qr-guard x y)) + (and (<= (/ x y) (truncate x y)) + (< (truncate x y) (+ (/ x y) 1)))) + (implies + (and (<= x 0) (> y 0) (qr-guard x y)) + (and (<= (/ x y) (truncate x y)) + (< (truncate x y) (+ (/ x y) 1))))) + :rule-classes + ((:linear :trigger-terms ((truncate x y)))) + + :hints + (("Goal" :in-theory (set-difference-theories (enable truncate + rational-implies2) + '(<-*-/-left <-*-/-right)))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section truncate-lemmas +; Linear (D) : x/y - 1 < (TRUNCATE x y) <= x/y, when x/y >= 0; +; x/y <= (TRUNCATE x y) < x/y + 1, when x/y =< 0. +; ~/ +; This lemma `defines' TRUNCATE as a set of inequalties. Many of the +; properties of TRUNCATE will be derived from this theorem. Unfortunately, +; this lemma is implicated in thrashing in the linear arithmetic procedure +; unless the inequalties of X and Y can be decided, so it may need to be +; DISABLEd at times. This lemma is stored as a :LINEAR rule for TRUNCATE +; exclusively since we consider it to be a property of TRUNCATE, and not a +; general property of (/ x y). + +; The statement of the hypotheses of this lemma is critical for its +; proper application. It is necessary for each inequality of x and y to +; stand alone in order to be relieveable by linear arithemetic. ~/~/" + ) + +;< Without the :CASES hint, the inequality conditions simplify to a form +;that doesn't allow us to decide the sign of X, and the proof fails. With +;the :CASES hint, we can decide the sign of X and the proof is obvious from +;TRUNCATE-BOUNDS. + +(defthm truncate-type + (implies + (qr-guard x y) + (and + (equal (< (truncate x y) 0) + (or (and (<= x 0) (> y 0) (<= y (- x))) + (and (>= x 0) (< y 0) (<= (- y) x)))) + (equal (> (truncate x y) 0) + (or (and (>= x 0) (> y 0) (<= y x)) + (and (<= x 0) (< y 0) (>= y x)))) + (equal (equal (truncate x y) 0) + (< (abs x) (abs y))))) + :rule-classes + ((:rewrite) + (:generalize) + (:linear + :corollary + (implies + (and (<= x 0) (> y 0) (<= y (- x)) (qr-guard x y)) + (< (truncate x y) 0))) + (:linear + :corollary + (implies + (and (>= x 0) (< y 0) (<= (- y) x) (qr-guard x y)) + (< (truncate x y) 0))) + (:linear + :corollary + (implies + (and (>= x 0) (> y 0) (<= y x) (qr-guard x y)) + (> (truncate x y) 0))) + (:linear + :corollary + (implies + (and (<= x 0) (< y 0) (>= y x) (qr-guard x y)) + (> (truncate x y) 0))) + (:rewrite + :corollary + (implies + (and (< (abs x) (abs y)) (qr-guard x y)) + (equal (truncate x y) 0))) + (:type-prescription + :corollary + (implies + (and (<= x 0) (> y 0) (qr-guard x y)) + (<= (truncate x y) 0))) + (:type-prescription + :corollary + (implies + (and (>= x 0) (< y 0) (qr-guard x y)) + (<= (truncate x y) 0))) + (:type-prescription + :corollary + (implies + (and (>= x 0) (> y 0) (qr-guard x y)) + (>= (truncate x y) 0))) + (:type-prescription + :corollary + (implies + (and (<= x 0) (< y 0) (qr-guard x y)) + (>= (truncate x y) 0)))) + :hints + (("Goal" + :cases ((< x 0) (> x 0)))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section truncate-lemmas +; Various : Decide (TRUNCATE x y) < 0, (TRUNCATE x y) > 0, and +; (TRUNCATE x y) = 0 based on inequalities of x and y. +; ~/ +; This rule is available in various forms: :REWRITE, :LINEAR, +; :TYPE-PRESCRIPTION, and :GENERALIZE as appropriate. Note that unless we +; can decide the inequalities of X and Y the :LINEAR forms may thrash.~/~/" + ) + +;< These follow immediately from the definition of TRUNCATE. If we enter +;these lemmas in a theory that includes the :LINEAR rules for TRUNCATE we will +;observe severe thrashing in linear arithmetic, since these rules are +;independent of the signs of x and y. So, we'll just prove them in the theory +;that prevails at the beginning of this book. + +(encapsulate () + + (local (in-theory (current-theory 'begin-quotient-remainder-lemmas))) + (local (in-theory (enable truncate))) + + (local (defthm foo (equal (rationalp (- x)) + (or (rationalp x) + (not (acl2-numberp x)))))) + + (defthm truncate-minus + (and (equal (truncate (- x) y) + (- (truncate x y))) + (equal (truncate x (- y)) + (- (truncate x y)))) + :hints (("Goal" :in-theory (enable denominator-unary-minus) + :expand + (nonnegative-integer-quotient 0 + (denominator (- (* x (/ y))))))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section truncate-lemmas +; Rewrite: (TRUNCATE (- x) y) = (- (TRUNCATE x y)); +; (TRUNCATE x (- y)) = (- (TRUNCATE x y)). +; ~/~/~/" + ) + + (defthm rewrite-truncate-x*y-z-left + (equal (truncate (* x y) z) + (truncate y (/ z x))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section truncate-lemmas +; Rewrite (D): (TRUNCATE (* x y) z) = (TRUNCATE y (/ z x)), when x /= 0. +; ~/ +; Since we don't presume any rewriting strategy for / vis-a-vis *, this +; often useful rule is exported DISABLEd.~/~/" + ) + + (in-theory (disable rewrite-truncate-x*y-z-left)) + + (defthm rewrite-truncate-x*y-z-right + (equal (truncate (* x y) z) + (truncate x (/ z y))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section truncate-lemmas +; Rewrite (D): (TRUNCATE (* x y) z) = (TRUNCATE x (/ z y)), when y /= 0. +; ~/ +; Since we don't presume any rewriting strategy for / vis-a-vis *, this +; often useful rule is exported DISABLEd.~/~/" + ) + + (in-theory (disable rewrite-truncate-x*y-z-right)) + + (defthm truncate-cancel-* + (implies + (qr-guard x y) + (and (equal (truncate (* x y) y) + (truncate x 1)) + (equal (truncate (* y x) y) + (truncate x 1)))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section truncate-lemmas +; Rewrite: (TRUNCATE (* x y) y) = (TRUNCATE x 1). +; ~/ +; NB: You get the commutted form as well.~/~/" + )) + +;< The linear rules refuse to fire on their own. From TRUNCATE-BOUNDS and +;NIQ-BOUNDS it is obvious that these are the same integers. + +(defthm integer-truncate-as-niq + (implies + (and (integerp i) + (integerp j) + (force (not (equal j 0)))) + (equal (truncate i j) + (* (signum i) (signum j) + (nonnegative-integer-quotient (abs i) (abs j))))) + :hints + (("Goal" + :in-theory (disable truncate-bounds niq-bounds <-*-/-right <-*-/-left) + :use ((:instance truncate-bounds (x i) (y j)) + (:instance niq-bounds (i (abs i)) (j (abs j)))))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section truncate-lemmas +; Rewrite (D) : (TRUNCATE i j) = +; (SIGNUM i) * (SIGNUM j) * (NIQ i j), for integers i,j. +; ~/ +; This rule shows that TRUNCATE is the \"usual\" (i.e., FORTRAN-style) +; integer quotient for both positive and negative integers.~/~/" + ) + +(in-theory (disable integer-truncate-as-niq)) + +#| + +(defthm truncate-truncate-integer + (implies + (and (integerp i) + (integerp j) + (integerp k) + (force (not (equal j 0))) + (force (not (equal k 0)))) + (equal (truncate (truncate i j) k) + (truncate i (* j k)))) + :hints + (("Goal" + :in-theory (enable truncate)))) + :hints + (("Goal" + :in-theory (e/d (integer-truncate-as-niq niq-type niq-i/j-<-k + prefer-*-to-/) + (x-<-y*z)) + :use ((:instance x-<-y*z (x (abs i)) (y (abs j)) (z (abs k)))))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section truncate-lemmas +; Rewrite: (TRUNCATE (TRUNCATE i j) k) = (TRUNCATE i (* j k)) +; for integers i,j,k.~/~/~/" +) +|# + + +;;;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +;;; +;;; REM +;;; +;;;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +(defthm linearize-rem + (implies + (and (qr-guard x y) + (force (rationalp z))) + (and + (equal (< (rem x y) z) + (if (> y 0) + (< (- (/ x y) (truncate x y)) (/ z y)) + (> (- (/ x y) (truncate x y)) (/ z y)))) + (equal (> (rem x y) z) + (if (> y 0) + (> (- (/ x y) (truncate x y)) (/ z y)) + (< (- (/ x y) (truncate x y)) (/ z y)))) + (equal (equal (rem x y) z) + (equal (- (/ x y) (truncate x y)) (/ z y))))) + :hints + (("Goal" + :in-theory (enable rem prefer-*-to-/))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section rem-lemmas +; Rewrite (D): Transform (REM x y) < z, (REM x y) > z, and (REM x y) = z +; into an equivalent TRUNCATE expression suitable for reasoning about with +; TRUNCATE-BOUNDS and other theorems about TRUNCATE. +; ~/ +; Since this lemma can be considered a `definition' of REM, it is exported +; DISABLED.~/~/" + ) + +(in-theory (disable linearize-rem)) + +(defthm rem-=-0 + (implies + (qr-guard x y) + (equal (equal (rem x y) 0) + (integerp (/ x y)))) + :rule-classes + ((:rewrite) + (:generalize) + (:rewrite + :corollary + (implies + (and (integerp (/ x y)) + (qr-guard x y)) + (equal (rem x y) 0)))) + :hints + (("Goal" + :in-theory (enable linearize-rem))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section rem-lemmas +; Rewrite: (REM x y) = 0, when x/y is an integer; +; ~/ +; NB: This rule is a corollary of a more general equality. +; The equality is also stored as a :REWRITE and :GENERALIZE rule.~/~/ +; :cited-by integer-ratio-lemmas" + ) + +(defthm rem-x-y-=-x + (implies + (qr-guard x y) + (equal (equal (rem x y) x) + (< (abs x) (abs y)))) + :rule-classes + ((:rewrite) + (:generalize) + (:rewrite + :corollary + (implies + (and (< (abs x) (abs y)) + (qr-guard x y)) + (equal (rem x y) x)))) + :hints + (("Goal" + :in-theory (enable linearize-rem))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section rem-lemmas +; Rewrite: (REM x y) = x, when |x| < |y|. +; ~/ +; This rule is a corollary of a more general equality which is also stored as +; a :REWRITE and :GENERALIZE rule.~/~/" + ) + +(defthm integerp-rem + (implies + (and (integerp i) + (integerp j) + (force (not (equal j 0)))) + (integerp (rem i j))) + :rule-classes :type-prescription + :hints + (("Goal" + :in-theory (enable rem))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section rem-lemmas +; Type-Prescription: (REM i j) is an integer, when i and j are integers. +; ~/~/~/" + ) + +;< Again, this rule is an easy consequence of TRUNCATE-BOUNDS, but (/ x y) +;is too `heavy' to let it fire naturally, so we have to :USE it. + +(defthm rem-bounds + (and + (implies + (and (>= x 0) + (qr-guard x y)) + (< (rem x y) (abs y))) + (implies + (and (<= x 0) + (qr-guard x y)) + (> (rem x y) (- (abs y))))) + :rule-classes + ((:linear :trigger-terms ((rem x y))) + (:generalize)) + :hints + (("Goal" + :in-theory (e/d (linearize-rem) (truncate-bounds)) + :use truncate-bounds)) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section rem-lemmas +; Linear: Useful forms of the fact that |(REM x y)| < |y|. +; ~/ +; This lemma is also stored as a :GENERALIZE rules.~/~/" + ) + +(defthm rem-type + (implies + (qr-guard x y) + (and + (equal (< (rem x y) 0) + (and (< x 0) + (not (integerp (/ x y))))) + (equal (> (rem x y) 0) + (and (> x 0) + (not (integerp (/ x y))))))) + :rule-classes + ((:rewrite) + (:generalize) + (:linear + :corollary + (implies + (and (< x 0) (not (integerp (/ x y))) (qr-guard x y)) + (< (rem x y) 0))) + (:linear + :corollary + (implies + (and (> x 0) (not (integerp (/ x y))) (qr-guard x y)) + (> (rem x y) 0))) + (:linear + :corollary + (implies + (and (<= x 0) (qr-guard x y)) + (<= (rem x y) 0))) + (:linear + :corollary + (implies + (and (>= x 0) (qr-guard x y)) + (>= (rem x y) 0))) + (:type-prescription + :corollary + (implies + (and (< x 0) (not (integerp (/ x y))) (qr-guard x y)) + (< (rem x y) 0))) + (:type-prescription + :corollary + (implies + (and (> x 0) (not (integerp (/ x y))) (qr-guard x y)) + (> (rem x y) 0))) + (:type-prescription + :corollary + (implies + (and (<= x 0) (qr-guard x y)) + (<= (rem x y) 0))) + (:type-prescription + :corollary + (implies + (and (>= x 0) (qr-guard x y)) + (>= (rem x y) 0)))) + :hints + (("Goal" + :in-theory (set-difference-theories + (enable linearize-rem) + '(<-*-/-right <-*-/-left)))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section rem-lemmas +; Various : Decide (REM x y) < 0 and (REM x y) > 0 based on the sign of +; x and the INTEGERP-ness of x/y. +; ~/ +; This rule is stored as appropriate :REWRITE, :LINEAR, :GENERALIZE, and +; :TYPE-PRESCRIPTION rules.~/~/" + ) + +(defthm rem-minus + (implies + (qr-guard x y) + (and + (equal (rem (- x) y) + (- (rem x y))) + (equal (rem x (- y)) + (* (signum y) (signum y) (rem x y))))) + + :hints + (("Goal" + :in-theory (enable linearize-rem) + :expand (rem x y))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section rem-lemmas +; Rewrite: (REM (- x) y) = (- (REM x y)); +; (REM x (- y)) = (SIGNUM x) * (SIGNUM y) * (REM x y)). +; ~/~/~/" + ) + + + +;;;**************************************************************************** +;;; +;;; FLOOR and MOD +;;; +;;;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +; We'll sometimes use this lemma which allows us to prove properties of +; FLOOR from properties of TRUNCATE. + +(defthm floor-as-truncate + (implies + (qr-guard x y) + (equal (floor x y) + (if (or (integerp (/ x y)) + (> (/ x y) 0)) + (truncate x y) + (- (truncate x y) 1)))) + :hints + (("Goal" :in-theory (enable floor truncate))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section floor-lemmas +; Rewrite: Rewrite (FLOOR x y) to a function of (TRUNCATE x y). +; ~/~/~/" + ) + +(in-theory (disable floor-as-truncate)) + +(defthm floor-mod-elim + (implies (force (acl2-numberp x)) + (equal (+ (mod x y) (* y (floor x y))) x)) + :rule-classes (:rewrite :elim) + :hints (("Goal" :in-theory (enable mod))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section floor-lemmas +; Rewrite: (+ (MOD x y) (* y (FLOOR x y))) = x. +; ~/ +; NB: This rule is also stored as an :ELIM rule.~/~/ +; :cited-by mod-lemmas" + ) + +(defthm floor-=-x/y + (implies + (qr-guard x y) + (equal (equal (floor x y) (/ x y)) + (integerp (/ x y)))) + :rule-classes + ((:rewrite) + (:generalize) + (:rewrite + :corollary + (implies + (and (equal r (/ x y)) + (integerp r) + (qr-guard x y)) + (equal (floor x y) r))) ) + :hints (("Goal" :in-theory + (set-difference-theories (enable floor equal-*-x-y-x) + '(commutativity-of-*)))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section floor-lemmas +; Rewrite: (FLOOR x y) = x/y, when x/y is an integer. +; ~/ +; This rule is a corollary of a more general equality which is also stored as +; a :REWRITE and :GENERALIZE rule.~/~/" + ) + +;< Another beautiful proof from NIQ-BOUNDS. + +(defthm floor-bounds + (implies + (qr-guard x y) + (and (< (- (/ x y) 1) (floor x y)) + (<= (floor x y) (/ x y)))) + :rule-classes + ((:linear :trigger-terms ((floor x y))) + (:generalize)) + :hints (("Goal" :in-theory + (set-difference-theories (enable floor rational-implies2) + '(<-*-/-left <-*-/-right)))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section floor-lemmas +; Linear (D) : x/y - 1 < (FLOOR x y) <= x/y. +; ~/ +; This lemma `defines' FLOOR as a set of inequalties. Many of the properties +; of FLOOR will be derived from this theorem. Unfortunately, this lemma is +; implicated in thrashing in the linear arithmetic procedure and must be +; DISABLEd at times. This lemmas is stored as a :LINEAR rule for FLOOR +; exclusively since we consider it to be a property of FLOOR, and not a +; general property of (/ x y).~/~/" + ) + +;< We need to consider the :CASES to get FLOOR-BOUNDS to do its job. This +;proof does 2 eliminations (considering (FLOOR x y) = -1) but it goes +;through. If we simply :USE FLOOR-BOUNDS with the same :CASES it also works +;and takes about the same amount of time. I'll bet that it could get the +;(FLOOR x y) = -1 cases with FLOOR-BOUNDS if we let FLOOR-BOUNDS trigger on +;(/ x y). + +;; The lemma FLOOR-TYPE had too many cases, so I split it in to 4 lemmas: +;; FLOOR-TYPE-1, FLOOR-TYPE-2, FLOOR-TYPE-3 and FLOOR-TYPE-4. +;; A. Flatau 17-Nov-1994 + +(defthm floor-type-1 + (implies (qr-guard x y) + (iff (< (floor x y) 0) + (or (and (< x 0) (> y 0)) + (and (> x 0) (< y 0))))) + :hints (("Goal" :cases ((< (/ x y) 0) (> (/ x y) 0)) + :in-theory (enable normalize-<-/-to-*-3))) + :rule-classes ((:rewrite + :corollary + (implies (qr-guard x y) + (equal (< (floor x y) 0) + (or (and (< x 0) (> y 0)) + (and (> x 0) (< y 0)))))) + (:generalize + :corollary + (implies (qr-guard x y) + (equal (< (floor x y) 0) + (or (and (< x 0) (> y 0)) + (and (> x 0) (< y 0)))))) + (:linear + :corollary + (implies + (and (< x 0) (> y 0) (qr-guard x y)) + (< (floor x y) 0))) + (:linear :corollary + (implies (and (> x 0) (< y 0) (qr-guard x y)) + (< (floor x y) 0))) + (:type-prescription :corollary + (implies (and (< x 0) + (> y 0) + (qr-guard x y)) + (< (floor x y) 0))) + (:type-prescription :corollary + (implies (and (> x 0) + (< y 0) + (qr-guard x y)) + (< (floor x y) 0)))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section floor-lemmas +; Decide (FLOOR x y) < 0 based on inequalities of x and y.~/ +; This rule is available in various forms: :REWRITE, :LINEAR, +; :TYPE-PRESCRIPTION, and :GENERALIZE as appropriate. Note that unless we +; can decide the inequalities of x and y the :LINEAR forms may thrash.~/~/" + ) + + +(defthm floor-type-2 + (implies (qr-guard x y) + (equal (> (floor x y) 0) + (or (and (>= x 0) (> y 0) (<= y x)) + (and (<= x 0) (< y 0) (>= y x))))) + :hints (("Subgoal 6" :cases ((<= x 0) (<= 0 x))) + ("Subgoal 2" :cases ((<= x 0) (<= 0 x)))) + :rule-classes ((:rewrite) + (:generalize) + (:linear :corollary + (implies (and (>= x 0) (> y 0) (<= y x) + (qr-guard x y)) + (> (floor x y) 0))) + (:linear :corollary + (implies (and (<= x 0) (< y 0) (>= y x) + (qr-guard x y)) + (> (floor x y) 0)))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section floor-lemmas +; Decide (FLOOR x y) > 0 based on inequalities of x and y. ~/ +; This rule is available in various forms: :REWRITE, :LINEAR, +; :TYPE-PRESCRIPTION, and :GENERALIZE as appropriate. Note that unless we +; can decide the inequalities of x and y the :LINEAR forms may thrash.~/~/" + ) + +(defthm floor-type-3 + (implies (qr-guard x y) + (equal (equal (floor x y) 0) + (or (and (>= x 0) (> y 0) (< x y)) + (and (<= x 0) (< y 0) (> x y))))) + + :hints (("Goal" :cases ((< (/ x y) 0) (> (/ x y) 0)))) + :rule-classes ((:rewrite) + (:generalize) + (:rewrite :corollary + (implies (and (>= x 0) (> y 0) (< x y) + (qr-guard x y)) + (equal (floor x y) 0))) + (:rewrite :corollary + (implies (and (<= x 0) (< y 0) (> x y) + (qr-guard x y)) + (equal (floor x y) 0))) + (:type-prescription :corollary + (implies (and (>= x 0) (> y 0) + (qr-guard x y)) + (>= (floor x y) 0))) + (:type-prescription :corollary + (implies (and (<= x 0) (< y 0) + (qr-guard x y)) + (>= (floor x y) 0)))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section floor-lemmas +; Decide (FLOOR x y) > 0 based on inequalities of x and y. ~/ +; This rule is available in various forms: :REWRITE, :LINEAR, +; :TYPE-PRESCRIPTION, and :GENERALIZE as appropriate. Note that unless we +; can decide the inequalities of x and y the :LINEAR forms may thrash.~/~/" + ) + +(defthm floor-type-4 + (implies (qr-guard x y) + (equal (equal (floor x y) -1) + (or (and (< x 0) (> y 0) (<= (- x) y)) + (and (> x 0) (< y 0) (<= x (- y)))))) + :rule-classes ((:rewrite) + (:generalize) + (:rewrite :corollary + (implies (and (> x 0) (< y 0) (<= x (- y)) + (qr-guard x y)) + (equal (floor x y) -1))) + (:rewrite :corollary + (implies (and (< x 0) (> y 0) (<= (- x) y) + (qr-guard x y)) + (equal (floor x y) -1)))) + :hints (("Goal" :cases ((< (/ x y) 0) (> (/ x y) 0))) + ("Subgoal 2" + :in-theory (set-difference-theories (enable <-+-negative-0-1 + <-+-negative-0-2 + normalize-<-/-to-*-3) + '(floor-bounds)) + :use (:instance floor-bounds (x x) (y y)))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section floor-lemmas +; Decide (FLOOR x y) = -1 based on inequalities of x and y.~/ +; This rule is available in various forms: :REWRITE, :LINEAR, +; :TYPE-PRESCRIPTION, and :GENERALIZE as appropriate. Note that unless we +; can decide the inequalities of x and y the :LINEAR forms may thrash.~/~/" + ) + +(deftheory floor-type-linear + '((:linear floor-type-1 . 1) + (:linear floor-type-1 . 2) + (:linear floor-type-2 . 1) + (:linear floor-type-2 . 2)) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section floor-lemmas +; A theory of the :LINEAR rules created by the lemmas FLOOR-TYPE-1 and +; FLOOR-TYPE-2.~/ +; These rules are implicated in thrashing linear arithmetic, so we provide +; this theory which can be DISABLED if it becomes a problem.~/~/" + ) + +;< These follow immediately from the definition of FLOOR. If we enter +;these lemmas in a theory that includes the :LINEAR rules for FLOOR we will +;observe severe thrashing in linear arithmetic, since these rules are +;independent of the signs of x and y. So, we'll just prove them in the theory +;that prevails at the beginning of this book. + +(encapsulate () + + (local (in-theory (current-theory 'begin-quotient-remainder-lemmas))) + (local (in-theory (enable floor))) + + (defthm floor-minus + (and + (implies + (qr-guard x y) + (equal (floor (- x) y) + (if (integerp (* x (/ y))) + (- (floor x y)) + (- (- (floor x y)) 1)))) + (implies + (qr-guard x y) + (equal (floor x (- y)) + (if (integerp (* x (/ y))) + (- (floor x y)) + (- (- (floor x y)) 1))))) + :hints (("Goal" :in-theory (enable DENOMINATOR-UNARY-MINUS))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section floor-lemmas +; Rewrite: (FLOOR (- x) y) = +; (IF (INTEGERP (* x (/ y))) +; (- (FLOOR x y)) +; (- (- (FLOOR x y)) 1))); +; Rhs identical for -y. +; ~/~/~/" + ) + + (defthm rewrite-floor-x*y-z-left + (implies + (and (rationalp x) + (not (equal x 0)) + (rationalp y) + (force (rationalp z)) + (force (not (equal z 0)))) + (equal (floor (* x y) z) + (floor y (/ z x)))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section floor-lemmas +; Rewrite (D): (FLOOR (* x y) z) = (FLOOR y (/ z x)), when x /= 0. +; ~/ +; Since we don't presume any rewriting strategy for / vis-a-vis *, this +; often useful rule is exported DISABLEd.~/~/" + ) + + (in-theory (disable rewrite-floor-x*y-z-left)) + + (defthm rewrite-floor-x*y-z-right + (implies + (and (rationalp x) + (rationalp y) + (not (equal y 0)) + (force (rationalp z)) + (force (not (equal z 0)))) + (equal (floor (* x y) z) + (floor x (/ z y)))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section floor-lemmas +; Rewrite: (FLOOR (* x y) z) = (FLOOR x (/ z y)), when y /= 0. +; ~/ +; Since we don't presume any rewriting strategy for / vis-a-vis *, this +; often useful rule is exported DISABLEd.~/~/" + ) + + (in-theory (disable rewrite-floor-x*y-z-right)) + + (defthm floor-cancel-* + (implies + (qr-guard x y) + (and (equal (floor (* x y) y) + (floor x 1)) + (equal (floor (* y x) y) + (floor x 1)))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section floor-lemmas +; Rewrite: (FLOOR (* x y) y) = (FLOOR x 1). +; ~/ +; NB: You get the commuted form as well.~/~/" + ) + + (defthm floor-cancel-*-2 + (implies + (and (rationalp x) + (not (equal x 0)) + (rationalp y) + (rationalp z) + (not (equal z 0))) + (equal (floor (* x y) (* x z)) + (floor y z))) + :hints + (("Goal" + :in-theory (enable rewrite-floor-x*y-z-left))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section floor-lemmas +; Rewrite: (FLOOR (* x y) (* x z)) = (FLOOR y z). +; ~/~/~/" + )) + +; This proof is only this complicated because I wanted to prove the most +; general thing possible. + +(encapsulate () + + (local + (defthm crock0 + (implies + (and (< 1 y) + (< 0 x) + (qr-guard x y)) + (< (/ x y) x)) + :rule-classes :linear)) + + (local + (defthm crock1 + (implies + (and (<= (+ 1 1) y) + (< x 0) + (qr-guard x y)) + (<= (* x y) (+ x x))) + :rule-classes :linear + :hints (("Goal" :in-theory (disable <-*-left-cancel (binary-+)) + :use (:instance <-*-left-cancel (z x) (x 2) (y y)))))) + + (local + (defthm crock2 + (implies + (and (<= 2 y) + (< x 0) + (< y (- x)) + (qr-guard x y)) + (< x (- (/ x y) 1))) + :rule-classes :linear + :hints + (("Goal" + :in-theory (e/d (prefer-*-to-/) (<-*-left-cancel)) + :use (:instance <-*-left-cancel (z y) (x x) (y (- (/ x y) 1))))))) + + (defthm justify-floor-recursion + (implies + (qr-guard x y) + (and + (implies + (and (< 0 x) + (< 1 y)) + (< (floor x y) x)) + (implies + (and (< x -1) + (<= 2 y)) + (< x (floor x y))))) + :hints + (("Goal" + :use ((:instance floor-bounds (x x) (y y)))) + ("Goal'" + :cases ((< 0 x) (< y (- x))))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section floor-lemmas +; Rewrite: (FLOOR x y) < x, when x > 0 and y > 1; +; x < (FLOOR x y), when x < -1 and y >= 2. +; ~/ +; This theorem justifies recursion by FLOOR using the measure ACL2-COUNT, +; which for integers i is simply (ABS i). Thus, this theorem won't justify +; a simple recursion by a negative y, since (FLOOR 1 y) = -1 for negative y, +; and (ABS -1) = (ABS 1). For the most general case that includes negative +; y one would need to define a different measure that could handle this +; condition.~/~/" + )) + + +;;;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +;;; +;;; MOD +;;; +;;;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +(defthm linearize-mod + (implies + (and (qr-guard x y) + (force (rationalp z))) + (and + (equal (< (mod x y) z) + (if (> y 0) + (< (- (/ x y) (floor x y)) (/ z y)) + (> (- (/ x y) (floor x y)) (/ z y)))) + (equal (> (mod x y) z) + (if (> y 0) + (> (- (/ x y) (floor x y)) (/ z y)) + (< (- (/ x y) (floor x y)) (/ z y)))) + (equal (equal (mod x y) z) + (equal (- (/ x y) (floor x y)) (/ z y))))) + :hints + (("Goal" + :in-theory (enable mod prefer-*-to-/))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section mod-lemmas +; Rewrite (D): Transform (MOD x y) < z, (MOD x y) > z, and (MOD x y) = z +; into an equivalent FLOOR expression suitable for reasoning about with +; FLOOR-BOUNDS and other theorems about FLOOR. +; ~/ +; Since this lemma can be considered a `definition' of MOD, it is exported +; DISABLED.~/~/" + ) + +(in-theory (disable linearize-mod)) + +(defthm mod-=-0 + (implies + (qr-guard x y) + (equal (equal (mod x y) 0) + (integerp (/ x y)))) + :rule-classes + ((:rewrite) + (:generalize) + (:rewrite + :corollary + (implies + (and (integerp (/ x y)) + (qr-guard x y)) + (equal (mod x y) 0)))) + :hints (("Goal" :in-theory (enable linearize-mod))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section mod-lemmas +; Rewrite: (MOD x y) = 0, when x/y is an integer; +; ~/ +; This rule is a corollary of a more general equality. +; The equality is also stored as a :REWRITE and :GENERALIZE rule.~/~/ +; :cited-by integer-ratio-lemmas" + ) + +(defthm mod-x-y-=-x + (implies + (qr-guard x y) + (equal (equal (mod x y) x) + (or (and (>= x 0) (> y 0) (< x y)) + (and (<= x 0) (< y 0) (> x y))))) + :rule-classes + ((:rewrite) + (:generalize) + (:rewrite + :corollary + (implies + (and (>= x 0) (> y 0) (< x y) (qr-guard x y)) + (equal (mod x y) x))) + (:rewrite + :corollary + (implies + (and (<= x 0) (< y 0) (> x y) (qr-guard x y)) + (equal (mod x y) x)))) + :hints (("Goal" :in-theory (enable linearize-mod))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section mod-lemmas +; Rewrite: (MOD x y) = x, when |x| <= |y| and x and y have the same sign. +; ~/ +; This rule is a corollary of a more general equality which is also stored as +; :REWRITE and :GENERALIZE rules.~/~/" + ) + +;< Again, we need to :USE FLOOR-BOUNDS to make this proof quick. + +(encapsulate nil + + (local (defthm another-crock + (equal (equal (- x) 1) (equal x -1)))) + + (defthm mod-x-y-=-x+y + (implies + (qr-guard x y) + (equal (equal (mod x y) (+ x y)) + (or (and (> x 0) (< y 0) (<= x (- y))) + (and (< x 0) (> y 0) (<= (- x) y))))) + :rule-classes + ((:rewrite) + (:generalize) + (:rewrite + :corollary + (implies + (and (> x 0) (< y 0) (<= x y) (qr-guard x y)) + (equal (mod x y) (+ x y)))) + (:rewrite + :corollary + (implies + (and (< x 0) (> y 0) (<= (- x) y) (qr-guard x y)) + (equal (mod x y) (+ x y))))) + :hints + (("Goal" + :in-theory (e/d (linearize-mod) (floor-bounds)) + :use floor-bounds)) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section mod-lemmas +; Rewrite: (MOD x y) = x + y, when |x| <= |y| and x and y have different +; signs and x /= 0. +; ~/ +; This rule is a corollary of a more general equality which is also stored as +; :REWRITE and :GENERALIZE rules.~/~/" + )) + +;; Added the :rule-classes :rewrite as this seems necessary at times. +;; A. Flatau 1-Dec-1994 +(defthm integerp-mod + (implies + (and (integerp i) + (integerp j)) + (integerp (mod i j))) + :rule-classes (:type-prescription :rewrite) + :hints + (("Goal" + :in-theory (enable mod))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section mod-lemmas +; Type-Prescription: (MOD i j) is an integer, when i and j are integers. +; ~/~/~/" + ) + +(defthm mod-bounds + (and + (implies + (and (> y 0) + (qr-guard x y)) + (< (mod x y) y)) + (implies + (and (< y 0) + (qr-guard x y)) + (> (mod x y) y))) + :rule-classes + ((:linear :trigger-terms ((mod x y))) + (:generalize)) + :hints + (("Goal" + :in-theory (e/d (linearize-mod) (floor-bounds)) + :use floor-bounds)) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section mod-lemmas +; Linear: Useful forms of the fact that |(MOD x y)| < |y|. +; ~/ +; This lemma is also stored as a :GENERALIZE rule.~/~/" + ) + +(defthm mod-type + (implies + (qr-guard x y) + (and + (equal (< (mod x y) 0) + (and (< y 0) + (not (integerp (/ x y))))) + (equal (> (mod x y) 0) + (and (> y 0) + (not (integerp (/ x y))))))) + :rule-classes + ((:rewrite) + (:generalize) + (:linear + :corollary + (implies + (and (< y 0) (not (integerp (/ x y))) (qr-guard x y)) + (< (mod x y) 0))) + (:linear + :corollary + (implies + (and (> y 0) (not (integerp (/ x y))) (qr-guard x y)) + (> (mod x y) 0))) + (:linear + :corollary + (implies + (and (<= y 0) (qr-guard x y)) + (<= (mod x y) 0))) + (:linear + :corollary + (implies + (and (>= y 0) (qr-guard x y)) + (>= (mod x y) 0))) + (:type-prescription + :corollary + (implies + (and (< y 0) (not (integerp (/ x y))) (qr-guard x y)) + (< (mod x y) 0))) + (:type-prescription + :corollary + (implies + (and (> y 0) (not (integerp (/ x y))) (qr-guard x y)) + (> (mod x y) 0))) + (:type-prescription + :corollary + (implies + (and (<= y 0) (qr-guard x y)) + (<= (mod x y) 0))) + (:type-prescription + :corollary + (implies + (and (>= y 0) (qr-guard x y)) + (>= (mod x y) 0)))) + :hints + (("Goal" + :in-theory (enable linearize-mod) + :use floor-bounds)) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section mod-lemmas +; Various: Decide (MOD x y) < 0 and (MOD x y) > 0 based on the sign of +; y and the INTEGERP-ness of x/y. +; ~/ +; This rule is also stored as appropriate :REWRITE, :LINEAR, :GENERALIZE, +; and :TYPE-PRESCRIPTION rules.~/~/" + ) + +(deftheory mod-type-linear + '((:linear mod-type . 1) + (:linear mod-type . 2) + (:linear mod-type . 3) + (:linear mod-type . 4)) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section mod-lemmas +; A theory of the :LINEAR rules created by the lemma MOD-TYPE. +; ~/ +; These rules are implicated in thrashing linear arithmetic, so we provide +; this theory which can be DISABLED if it becomes a problem.~/~/" + ) + +(defthm mod-minus + (implies + (qr-guard x y) + (and (equal (mod (- x) y) + (if (integerp (/ x y)) + 0 + (- y (mod x y)))) + (equal (mod x (- y)) + (if (integerp (/ x y)) + 0 + (- (mod x y) y))))) + :hints + (("Goal" + :in-theory (enable linearize-mod) + :expand (mod x y))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section mod-lemmas +; Rewrite: (MOD (- x) y) = +; (IF (INTEGERP (/ x y)) +; 0 +; (- y (MOD x y))); +; (MOD x (- y)) = +; (IF (INTEGERP (/ x y)) +; 0 +; (- (MOD x y) y)). +; ~/~/~/ +; :cited-by integer-ratio-lemmas" + ) + +(encapsulate () + + (local (in-theory (current-theory 'begin-quotient-remainder-lemmas))) + + (defthm simplify-mod-* + (implies + (and (integerp x) + (not (equal x 0)) + (integerp y) + (integerp z) + (not (equal z 0))) + (equal (mod (* x y) (* x z)) + (* x (mod y z)))) + :hints + (("Goal" + :in-theory (enable mod floor-cancel-*-2))))) + + +;;;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +;;; +;;; Addition Cancellation theory for FLOOR and MOD +;;; +;;;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +;< This next section of lemmas has nothing to do with the :LINEAR theory of +;FLOOR and MOD, so we DISABLE the key :LINEAR lemmas to avoid thrashing. + +(local (in-theory (disable floor-bounds floor-type-1 floor-type-2 + floor-type-3 floor-type-4 mod-bounds mod-type))) + +; These LOCAL theorems will be superceded by CANCEL-FLOOR-+, +; CANCEL-FLOOR-+-3, CANCEL-MOD-+, and CANCEL-MOD-+-3. + +(local + (defthm floor-x+i*y-y + (implies + (and (integerp i) + (qr-guard x y)) + (and + (equal (floor (+ x (* i y)) y) + (+ i (floor x y))) + (equal (floor (+ x (* y i)) y) + (+ i (floor x y))) + (equal (floor (- x (* i y)) y) + (- (floor x y) i)) + (equal (floor (- x (* y i)) y) + (- (floor x y) i)))) + :hints + (("Goal" + :use ((:instance floor-bounds (x (+ x (* i y))) (y y)) + (:instance floor-bounds (x (- x (* i y))) (y y)) + (:instance floor-bounds (x x) (y y))))))) + +(local + (defthm floor-x+y+i*z-z + (implies + (and (integerp i) + (force (rationalp x)) + (qr-guard y z)) + (and + (equal (floor (+ x y (* i z)) z) + (+ i (floor (+ x y) z))) + (equal (floor (+ x y (* z i)) z) + (+ i (floor (+ x y) z))) + (equal (floor (+ x y (- (* z i))) z) + (- (floor (+ x y) z) i)) + (equal (floor (+ x y (- (* i z))) z) + (- (floor (+ x y) z) i)))) + :hints + (("Goal" + :in-theory (disable floor-x+i*y-y) + :use ((:instance floor-x+i*y-y (x (+ x y)) (y z))))))) + +;;;(local modified by PG to export thm + + (defthm mod-x+i*y-y + (implies + (and (integerp i) + (qr-guard x y)) + (and + (equal (mod (+ x (* i y)) y) + (mod x y)) + (equal (mod (+ x (* y i)) y) + (mod x y)) + (equal (mod (+ x (- (* i y))) y) + (mod x y)) + (equal (mod (+ x (- (* y i))) y) + (mod x y)))) + :hints + (("Goal" + :in-theory (enable mod)))) + +;;; ) + +(local + (defthm mod-x+y+i*z-z + (implies + (and (integerp i) + (force (rationalp x)) + (qr-guard y z)) + (and + (equal (mod (+ x y (* i z)) z) + (mod (+ x y) z)) + (equal (mod (+ x y (* z i)) z) + (mod (+ x y) z)) + (equal (mod (+ x y (- (* i z))) z) + (mod (+ x y) z)) + (equal (mod (+ x y (- (* z i))) z) + (mod (+ x y) z)))) + :hints + (("Goal" + :in-theory (disable mod-x+i*y-y) + :use ((:instance mod-x+i*y-y (x (+ x y)) (y z))))))) + +(encapsulate () + + (local + (defthm floor-+-crock + (implies + (and (rationalp x) + (rationalp y) + (rationalp z) + (syntaxp (and (eq x 'x) (eq y 'y) (eq z 'z)))) + (equal (floor (+ x y) z) + (floor (+ (+ (mod x z) (mod y z)) + (* (+ (floor x z) (floor y z)) z)) z))))) + + (defthm floor-+ + (implies + (and (force (rationalp x)) + (force (rationalp y)) + (force (rationalp z)) + (force (not (equal z 0)))) + (equal (floor (+ x y) z) + (+ (floor (+ (mod x z) (mod y z)) z) + (+ (floor x z) (floor y z))))) + :hints (("Goal" :in-theory (union-theories (disable associativity-of-+ + commutativity-2-of-+ + associativity-of-* + commutativity-2-of-* + distributivity) + '(rationalp-+ mod)))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section floor-lemmas +; Rewrite (D): (FLOOR (+ x y) z) = +; (FLOOR x z) + (FLOOR y z) + (FLOOR (+ (MOD x z) (MOD y z)) z). +; ~/ + +; As this rule could easily loop it is exported DISABLEd. Don't ENABLE this +; lemma unless you are sure that the FLOOR/MOD term will simplify, or else +; put SYNTAXP guards on the variables x, y, and/or z.~/~/" + ) + + (in-theory (disable floor-+))) + +(encapsulate () + + (local + (defthm mod-+-crock + (implies + (and (rationalp x) + (rationalp y) + (rationalp z) + (not (equal z 0)) + (syntaxp (and (eq x 'x) (eq y 'y) (eq z 'z)))) + (equal (mod (+ x y) z) + (mod (+ (+ (mod x z) (mod y z)) + (* (+ (floor x z) (floor y z)) z)) z))))) + + (defthm mod-+ + (implies + (and (force (rationalp x)) + (force (rationalp y)) + (force (rationalp z)) + (force (not (equal z 0)))) + (equal (mod (+ x y) z) + (mod (+ (mod x z) (mod y z)) z))) + :hints (("Goal" :in-theory (union-theories (disable associativity-of-+ + commutativity-2-of-+ + associativity-of-* + commutativity-2-of-* + distributivity) + '(rationalp-+ mod)))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section mod-+ +; Rewrite (D): (MOD (+ x y) z) = (MOD (+ (MOD x z) (MOD y z)) z). +; ~/ + +; As this rule could easily loop it is exported DISABLEd. Don't ENABLE this +; lemma unless you are sure that the MOD/MOD term will simplify, or else +; put SYNTAXP guards on the variables x, y, and/or z.~/~/" + ) + + (in-theory (disable mod-+))) + +(encapsulate () + + (local + (defthm crock0 + (implies + (and (integerp i) + (integerp (* x y))) + (integerp (* x y i))))) + + (defthm rewrite-floor-mod + (implies + (and (equal i (/ y z)) + (integerp i) + (qr-guard x y) + (qr-guard x z)) + (equal (floor (mod x y) z) + (- (floor x z) (* i (floor x y))))) + :hints + (("Goal" + :in-theory (enable mod) + :use ((:instance floor-+ (x x) (y (- (* y (floor x y)))) (z z))))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section floor-lemmas +; Rewrite: (FLOOR (MOD x y) z) = (FLOOR x z) - i*(FLOOR x y), when i = y/z +; is an integer. +; ~/~/~/ +; :cited-by integer-ratio-lemmas" + ) + + (defthm rewrite-mod-mod + (implies + (and (equal i (/ y z)) + (integerp i) + (qr-guard x y) + (qr-guard y z)) + (equal (mod (mod x y) z) + (mod x z))) + :hints + (("Goal" + :expand ((mod x y) (mod x z)) + :use ((:instance mod-+ (x x) (y (- (* y (floor x y)))) (z z))))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section mod-lemmas +; Rewrite: (MOD (MOD x y) z) = (MOD x z), when y/z is an integer. +; ~/~/~/ +; :cited-by integer-ratio-lemmas" + )) + +(defthm cancel-floor-+ + (implies + (and (equal i (/ x z)) + (integerp i) + (force (rationalp x)) + (force (rationalp y)) + (force (rationalp z)) + (force (not (equal z 0)))) + (and + (equal (floor (+ x y) z) + (+ i (floor y z))) + (equal (floor (+ y x) z) + (+ i (floor y z))))) + :hints + (("Goal" + :in-theory (enable floor-+))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section floor-lemmas +; Rewrite: (FLOOR (+ x y) z) = x/z + (FLOOR y z), when x/z is an integer; +; also the commutative form. +; ~/~/~/ +; :cited-by integer-ratio-lemmas" + ) + +(defthm cancel-floor-+-3 + (implies + (and (equal i (/ y z)) + (integerp i) + (force (rationalp w)) + (force (rationalp x)) + (force (rationalp y)) + (force (rationalp z)) + (force (not (equal z 0)))) + (equal (floor (+ w x y) z) + (+ i (floor (+ w x) z)))) + :hints + (("Goal" + :in-theory (disable cancel-floor-+) + :use ((:instance cancel-floor-+ (x y) (y (+ w x)) (z z))))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section floor-lemmas +; Rewrite: (FLOOR (+ w x y) z) = y/z + (FLOOR (+ w x) z), when y/z is an +; integer. +; ~/~/~/ +; :cited-by integer-ratio-lemmas" + ) + +(defthm cancel-mod-+ + (implies + (and (equal i (/ x z)) + (integerp i) + (force (rationalp x)) + (force (rationalp y)) + (force (rationalp z)) + (force (not (equal z 0)))) + (and + (equal (mod (+ x y) z) + (mod y z)) + (equal (mod (+ y x) z) + (mod y z)))) + :hints + (("Goal" + :in-theory (enable mod-+))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section mod-lemmas +; Rewrite: (MOD (+ x y) z) = (MOD y z), when x/z is an integer; +; also the commutative form. +; ~/~/~/ +; :cited-by integer-ratio-lemmas" + ) + +(defthm cancel-mod-+-3 + (implies + (and (equal i (/ y z)) + (integerp i) + (force (rationalp w)) + (force (rationalp x)) + (force (rationalp y)) + (force (rationalp z)) + (force (not (equal z 0)))) + (equal (mod (+ w x y) z) + (mod (+ w x) z))) + :hints + (("Goal" + :in-theory (disable cancel-mod-+) + :use ((:instance cancel-mod-+ (x y) (y (+ w x)) (z z))))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section mod-lemmas +; Rewrite: (MOD (+ w x y) z) = (MOD (+ w x) z), when y/z is an integer. +; ~/~/~/ +; :cited-by integer-ratio-lemmas" + ) + +(defthm not-rationalp-rationalp-plus + (implies (and (acl2-numberp x) + (rationalp y) + (not (rationalp x))) + (not (rationalp (+ x y)))) + :hints (("Goal" :use ((:instance rationalp-+ (x (+ x y)) (y (- y))))))) + +(defthm not-rationalp-rationalp-unary---plus + (implies (and (acl2-numberp x) + (rationalp y) + (not (rationalp (- x)))) + (not (rationalp (+ x y)))) + :hints (("Goal" :use ((:instance rationalp-+ (x (+ x y)) (y (- y)))) + :in-theory (enable rationalp-unary--)))) + +(encapsulate nil + + (local (defthm simplify-mod-+-mod-crock + (equal (equal (- (* i y)) y) + (and (acl2-numberp y) + (or (equal y 0) + (equal i -1)))) + :hints (("Goal" :in-theory (disable left-cancellation-for-*) + :use (:instance left-cancellation-for-* + (z y) (x -1) (y i)))))) + + (local (defthm simplify-mod-+-mod-crock-2 + (equal (equal (* a b) (+ y z)) + (equal (fix z) (- (* a b) y))))) + +(defthm simplify-mod-+-mod + (implies (and (equal i (/ y z)) + (integerp i) + (qr-guard x y) + (qr-guard w z)) + (and (equal (mod (+ w (mod x y)) z) + (mod (+ w x) z)) + (equal (mod (+ (mod x y) w) z) + (mod (+ w x) z)) + (equal (mod (- w (mod x y)) z) + (mod (- w x) z)) + (equal (mod (- (mod x y) w) z) + (mod (- x w) z)))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section mod-lemmas +; Rewrite: (MOD (+ w (MOD x y)) z) = (MOD (+ w x) z); +; (MOD (+ (MOD x y) w) z) = (MOD (+ w x) z)); +; (MOD (- w (MOD x y)) z) = (MOD (- w x) z)); +; (MOD (- (MOD x y) w) z) = (MOD (- x w) z)), +; Provided that for each case y/z is an integer. +; ~/~/~/" + )) + +(defthm mod-+-cancel-0 + (implies + (and (qr-guard x z) + (qr-guard y z)) + (equal (equal (mod (+ x y) z) x) + (and (equal (mod y z) 0) + (equal (mod x z) x)))) + :hints (("Goal" :in-theory (disable left-cancellation-for-* equal-*-/-2) + :use ((:instance left-cancellation-for-* + (z (/ z)) (x y) (y (* z (floor (+ x y) z))))) + :expand ((mod (+ x y) z))))) + +(local (in-theory (enable floor-type-1 floor-type-2 floor-type-3 floor-type-4 + floor-bounds mod-type mod-bounds))) + + +;;;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +;;; +;;; Positive integer theory for FLOOR and MOD +;;; +;;;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +;;; +;;; The following is a proof of the theorem +;;; +;;; (implies +;;; (and (integerp i) +;;; (integerp j) +;;; (< 0 i) +;;; (< 0 j) +;;; (rationalp x)) +;;; (equal (floor (floor x i) j) +;;; (floor x (* i j))))). +;;; +;;; I believe that this is the most general, or at least the most +;;; generally useful form of this result. E.g., it's not true for negative +;;; J and K. This theorem is used to justify a recursive definition of +;;; "shifting" integers, i.e., +;;; +;;; (equal (floor i (expt 2 j)) (floor (floor i 2) (expt 2 (- j 1)))) +;;; +;;; for J > 0. + +(defthm rationalp-mod + (implies (and (rationalp x) + (rationalp y)) + (rationalp (mod x y))) + :hints (("Goal" :in-theory (enable mod rationalp-+)))) + +(encapsulate () + + ;; This proof of FLOOR-FLOOR-INTEGER is an elaborate rewriting trick, + ;; which is spoiled by these 2 lemmas! + + (local (in-theory (disable rewrite-floor-mod rewrite-mod-mod))) + + ;;< These first 2 lemmas have nothing to do with the :LINEAR theory of + ;;FLOOR and MOD, so we DISABLE the key :LINEAR lemmas to avoid thrashing. + + (local (in-theory (disable floor-type-1 floor-type-2 floor-type-3 + floor-type-4 floor-bounds mod-type mod-bounds))) + + ;; First, write x as a quotient and remainder of i*j. + + (local + (defthm floor-floor-integer-crock0 + (implies + (and (rationalp x) + (integerp i) + (not (equal i 0)) + (integerp j) + (not (equal j 0)) + (syntaxp (and (eq x 'x) (eq i 'i) (eq j 'j)))) + (equal (floor (floor x i) j) + (floor (floor (+ (mod x (* i j)) + (* (* i j) (floor x (* i j)))) i) + j))) + :hints (("Goal" :in-theory (disable commutativity-2-of-+ + commutativity-2-of-* + associativity-of-*))))) + + ;; Next, divide out i and j through the sums. + + (local + (defthm floor-floor-integer-crock1 + (implies + (and (rationalp x) + (integerp i) + (not (equal i 0)) + (integerp j) + (not (equal j 0)) + (syntaxp (and (eq x 'x) (eq i 'i) (eq j 'j)))) + (equal (floor (floor x i) j) + (+ (floor x (* i j)) (floor (floor (mod x (* i j)) i) j)))) + :hints + (("Goal" + :in-theory (disable floor-mod-elim))))) + + ;;< This proof takes 20 sec. with no splitting. We need to re-ENABLE the + ;;type lemmas to make it work. It could probably be speeded up by + ;;DISABLEing selected parts of the :LINEAR theory of FLOOR and MOD. + + (local + (defthm floor-floor-integer-crock2 + (implies + (and (rationalp x) + (integerp i) + (< 0 i) + (integerp j) + (< 0 j)) + (equal (floor (floor (mod x (* i j)) i) j) + 0)) + :hints (("Goal" :in-theory + (set-difference-theories (enable floor-type-1 + floor-type-2 + floor-type-3 + mod-type) + '(floor-bounds mod-bounds + <-*-left-cancel + <-*-/-left-commuted)) + :use ((:instance floor-bounds (x (mod x (* i j))) (y i)) + (:instance mod-bounds (x x) (y (* i j))) + (:instance <-*-left-cancel + (z (/ i)) (x (mod x (* i j))) (y (* i j)))))))) + + ;; Voila! + + (defthm floor-floor-integer + (implies + (and (integerp i) + (integerp j) + (< 0 i) + (< 0 j) + (rationalp x)) + (equal (floor (floor x i) j) + (floor x (* i j)))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section floor-lemmas +; Rewrite: (FLOOR (FLOOR x i) j) = (FLOOR x (* i j)) for integers i,j > 0. +; ~/~/~/" + )) + +(defthm floor-x+i*k-i*j + (implies + (and (force (rationalp x)) + (force (integerp i)) + (force (integerp j)) + (force (integerp k)) + (< 0 i) + (< 0 j) + (<= 0 x) + (< x i)) + (equal (floor (+ x (* i k)) (* i j)) + (floor k j))) + :hints + (("Goal" + :in-theory (disable floor-floor-integer floor-+) + :use ((:instance floor-floor-integer (x (+ x (* i k))) (i i) (j j)) + (:instance floor-+ (x x) (y (* i k)) (z i))))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section floor-lemmas +; Rewrite: (FLOOR (+ x (* i k)) (* i j)) = (FLOOR k j), when +; i,j > 0 and 0 <= x < i. +; ~/ +; This is a crucial lemma for certain kinds of reasoning about hardware +; specifications, and is used to prove MOD-x+i*j-i*k.~/~/" + ) + +(defthm mod-x+i*k-i*j + (implies + (and (force (rationalp x)) + (force (integerp i)) + (force (integerp j)) + (force (integerp k)) + (< 0 i) + (< 0 j) + (<= 0 x) + (< x i)) + (equal (mod (+ x (* i k)) (* i j)) + (+ x (* i (mod k j))))) + :hints + (("Goal" + :in-theory (enable mod))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section mod-lemmas +; Rewrite: (MOD (+ x (* i k)) (* i j)) = (+ x (* i (MOD k j))), when +; i,j > 0 and 0 <= x < i. +; ~/ +; This is a crucial lemma for certain kinds of reasoning about hardware +; specifications, for example, we can use this to prove that +; (MOD i (EXPT 2 n)) = (MOD i 2) + (MOD (FLOOR i 2) (EXPT 2 (1- n))), for +; n > 0, which justifies a recursive specification of hardware +; operations.~/~/" + ) + +(encapsulate () + + (local (in-theory (disable floor-type-1 floor-type-2 floor-type-3 + floor-type-4 floor-bounds))) + + (local + (defthm mod-x-i*j-crock + (implies + (and (> i 0) + (> j 0) + (force (integerp i)) + (force (integerp j)) + (force (rationalp x))) + (equal (mod (+ (mod x i) (* i (floor x i))) (* i j)) + (+ (mod x i) (* i (mod (floor x i) j))))) + :rule-classes nil + :hints + (("Goal" + :in-theory (disable floor-mod-elim))))) + + (defthm mod-x-i*j + (implies + (and (> i 0) + (> j 0) + (force (integerp i)) + (force (integerp j)) + (force (rationalp x))) + (equal (mod x (* i j)) + (+ (mod x i) (* i (mod (floor x i) j))))) + :hints + (("Goal" + :use mod-x-i*j-crock)))) + + +;;;**************************************************************************** +;;; +;;; Misc. +;;; +;;;**************************************************************************** + +;; This is a nice "quotient" theorem -- If J is an integer and I/J is an +;; integer, then I is also an integer, namely J*(FLOOR I J). It was proved +;; as part of en earlier pass at this book, and although it's not used +;; anymore, I like it so I'm leaving it in. + +(encapsulate () + + (local + (defthm crock0 + (implies + (and (integerp (/ i j)) + (rationalp i) + (integerp j) + (not (equal 0 j))) + (integerp (+ (* j (floor i j)) (mod i j)))) + :rule-classes nil + :hints + (("Goal" + :in-theory (disable floor-=-x/y))))) + + (defthm integerp-i/j-integerp-forward + (implies + (and (integerp (/ i j)) + (rationalp i) + (integerp j) + (not (zerop j))) + (integerp i)) + :hints + (("Goal" + :use ((:instance crock0)) + :in-theory (disable mod-=-0 floor-=-x/y))) + :rule-classes + ((:forward-chaining + :corollary + (implies + (and (integerp (/ i j)) + (force (rationalp i)) + (integerp j) + (force (not (equal 0 j)))) + (integerp i))) + (:forward-chaining + :corollary + (implies + (and (integerp (* (/ j) i)) + (force (rationalp i)) + (integerp j) + (force (not (equal 0 j)))) + (integerp i)))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section integer-ratio-lemmas +; Forward: If i/j is an integer and j is an integer, then i is an integer. +; ~/ +; NB: The trigger-term is (INTEGERP (/ i j)).~/~/" + )) + + +;;;**************************************************************************** +;;; +;;; THEORIES -- A couple of exported theories. +;;; +;;;**************************************************************************** + +(deflabel quotient-remainder-theories + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section quotient-remainder-lemmas +; Logical theories supplied by the QUOTIENT-REMAINDER book.~/~/ + +; The QUOTIENT-REMAINDER book exports 2 theories: +; QUOTIENT-REMAINDER-FUNCTIONS and QUOTIENT-REMAINDER-RULES. The former is +; simply a theory of the functions characterized by the book. Since +; these functions are all ENABLEd by default, and most are non-recursive, one +; should immediately: + +; (IN-THEORY (DISABLE QUOTIENT-REMAINDER-FUNCTIONS)) + +; upon loading this book, or the lemmas may never be applied. + +; QUOTIENT-REMAINDER-RULES is a theory of all of the lemmas exported by this +; book which are ENABLEd by default. You can \"turn off\" this book +; after it is loaded by + +; (IN-THEORY (DISABLE QUOTIENT-REMAINDER-RULES)).~/" + ) + +(deftheory quotient-remainder-functions + '(nonnegative-integer-quotient floor mod truncate rem) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section quotient-remainder-theories +; A theory of the function symbols characterized by +; \"quotient-remainder-lemmas\". +; ~/ +; You should DISASBLE this theory immediately after loading this book.~/~/" + ) + +(deftheory quotient-remainder-rules + (union-theories + (defun-type/exec-theory + '(NONNEGATIVE-INTEGER-QUOTIENT FLOOR MOD TRUNCATE REM)) + (set-difference-theories (current-theory :here) + (current-theory 'begin-quotient-remainder-lemmas))) + +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. + +; :doc +; ":doc-section quotient-remainder-theories +; A theory of all rules exported ENABLEd by the \"quotient-remainder-lemmas\" +; book.~/~/~/" + ) + +; Documentation, auto-generated from legacy doc strings commented out above: + +(include-book "xdoc/top" :dir :system) + +(defxdoc cancel-floor-+ + :parents (floor-lemmas integer-ratio-lemmas) + :short "Rewrite: (FLOOR (+ x y) z) = x/z + (FLOOR y z), when x/z is an integer; +also the commutative form." + :long "") + +(defxdoc cancel-floor-+-3 + :parents (floor-lemmas integer-ratio-lemmas) + :short "Rewrite: (FLOOR (+ w x y) z) = y/z + (FLOOR (+ w x) z), when y/z is an +integer." + :long "") + +(defxdoc cancel-mod-+ + :parents (mod-lemmas integer-ratio-lemmas) + :short "Rewrite: (MOD (+ x y) z) = (MOD y z), when x/z is an integer; +also the commutative form." + :long "") + +(defxdoc cancel-mod-+-3 + :parents (mod-lemmas integer-ratio-lemmas) + :short "Rewrite: (MOD (+ w x y) z) = (MOD (+ w x) z), when y/z is an integer." + :long "") + +(defxdoc floor-+ + :parents (floor-lemmas) + :short "Rewrite (D): (FLOOR (+ x y) z) = +(FLOOR x z) + (FLOOR y z) + (FLOOR (+ (MOD x z) (MOD y z)) z)." + :long "<p>As this rule could easily loop it is exported DISABLEd. Don't + ENABLE this lemma unless you are sure that the FLOOR/MOD term will simplify, + or else put SYNTAXP guards on the variables x, y, and/or z.</p> + + ") + +(defxdoc floor-=-x/y + :parents (floor-lemmas) + :short "Rewrite: (FLOOR x y) = x/y, when x/y is an integer." + :long "<p>This rule is a corollary of a more general equality which is also + stored as a :REWRITE and :GENERALIZE rule.</p> + + ") + +(defxdoc floor-as-truncate + :parents (floor-lemmas) + :short "Rewrite: Rewrite (FLOOR x y) to a function of (TRUNCATE x y)." + :long "") + +(defxdoc floor-bounds + :parents (floor-lemmas) + :short "Linear (D) : x/y - 1 < (FLOOR x y) <= x/y." + :long "<p>This lemma `defines' FLOOR as a set of inequalties. Many of the + properties of FLOOR will be derived from this theorem. Unfortunately, this + lemma is implicated in thrashing in the linear arithmetic procedure and must + be DISABLEd at times. This lemmas is stored as a :LINEAR rule for FLOOR + exclusively since we consider it to be a property of FLOOR, and not a general + property of (/ x y).</p> + + ") + +(defxdoc floor-cancel-* + :parents (floor-lemmas) + :short "Rewrite: (FLOOR (* x y) y) = (FLOOR x 1)." + :long "<p>NB: You get the commuted form as well.</p> + + ") + +(defxdoc floor-cancel-*-2 + :parents (floor-lemmas) + :short "Rewrite: (FLOOR (* x y) (* x z)) = (FLOOR y z)." + :long "") + +(defxdoc floor-floor-integer + :parents (floor-lemmas) + :short "Rewrite: (FLOOR (FLOOR x i) j) = (FLOOR x (* i j)) for integers i,j > 0." + :long "") + +(defxdoc floor-lemmas + :parents (quotient-remainder-lemmas) + :short "Lemmas about FLOOR." + :long "") + +(defxdoc floor-minus + :parents (floor-lemmas) + :short "Rewrite: (FLOOR (- x) y) = + (IF (INTEGERP (* x (/ y))) + (- (FLOOR x y)) + (- (- (FLOOR x y)) 1))); + Rhs identical for -y." + :long "") + +(defxdoc floor-mod-elim + :parents (floor-lemmas mod-lemmas) + :short "Rewrite: (+ (MOD x y) (* y (FLOOR x y))) = x." + :long "<p>NB: This rule is also stored as an :ELIM rule.</p> + + ") + +(defxdoc floor-type-1 + :parents (floor-lemmas) + :short "Decide (FLOOR x y) < 0 based on inequalities of x and y." + :long "<p>This rule is available in various forms: :REWRITE, :LINEAR, + :TYPE-PRESCRIPTION, and :GENERALIZE as appropriate. Note that unless we can + decide the inequalities of x and y the :LINEAR forms may thrash.</p> + + ") + +(defxdoc floor-type-2 + :parents (floor-lemmas) + :short "Decide (FLOOR x y) > 0 based on inequalities of x and y." + :long "<p>This rule is available in various forms: :REWRITE, :LINEAR, + :TYPE-PRESCRIPTION, and :GENERALIZE as appropriate. Note that unless we can + decide the inequalities of x and y the :LINEAR forms may thrash.</p> + + ") + +(defxdoc floor-type-3 + :parents (floor-lemmas) + :short "Decide (FLOOR x y) > 0 based on inequalities of x and y." + :long "<p>This rule is available in various forms: :REWRITE, :LINEAR, + :TYPE-PRESCRIPTION, and :GENERALIZE as appropriate. Note that unless we can + decide the inequalities of x and y the :LINEAR forms may thrash.</p> + + ") + +(defxdoc floor-type-4 + :parents (floor-lemmas) + :short "Decide (FLOOR x y) = -1 based on inequalities of x and y." + :long "<p>This rule is available in various forms: :REWRITE, :LINEAR, + :TYPE-PRESCRIPTION, and :GENERALIZE as appropriate. Note that unless we can + decide the inequalities of x and y the :LINEAR forms may thrash.</p> + + ") + +(defxdoc floor-type-linear + :parents (floor-lemmas) + :short "A theory of the :LINEAR rules created by the lemmas FLOOR-TYPE-1 and +FLOOR-TYPE-2." + :long "<p>These rules are implicated in thrashing linear arithmetic, so we + provide this theory which can be DISABLED if it becomes a problem.</p> + + ") + +(defxdoc floor-x+i*k-i*j + :parents (floor-lemmas) + :short "Rewrite: (FLOOR (+ x (* i k)) (* i j)) = (FLOOR k j), when +i,j > 0 and 0 <= x < i." + :long "<p>This is a crucial lemma for certain kinds of reasoning about + hardware specifications, and is used to prove MOD-x+i*j-i*k.</p> + + ") + +(defxdoc integer-ratio-lemmas + :parents (quotient-remainder-lemmas) + :short "Lemmas about ratios x/y that are known to be INTEGERP." + :long "") + +(defxdoc integer-truncate-as-niq + :parents (truncate-lemmas) + :short "Rewrite (D) : (TRUNCATE i j) = + (SIGNUM i) * (SIGNUM j) * (NIQ i j), for integers i,j." + :long "<p>This rule shows that TRUNCATE is the \"usual\" (i.e., + FORTRAN-style) integer quotient for both positive and negative integers.</p> + + ") + +(defxdoc integerp-i/j-integerp-forward + :parents (integer-ratio-lemmas) + :short "Forward: If i/j is an integer and j is an integer, then i is an integer." + :long "<p>NB: The trigger-term is (INTEGERP (/ i j)).</p> + + ") + +(defxdoc integerp-mod + :parents (mod-lemmas) + :short "Type-Prescription: (MOD i j) is an integer, when i and j are integers." + :long "") + +(defxdoc integerp-rem + :parents (rem-lemmas) + :short "Type-Prescription: (REM i j) is an integer, when i and j are integers." + :long "") + +(defxdoc justify-floor-recursion + :parents (floor-lemmas) + :short "Rewrite: (FLOOR x y) < x, when x > 0 and y > 1; + x < (FLOOR x y), when x < -1 and y >= 2." + :long "<p>This theorem justifies recursion by FLOOR using the measure + ACL2-COUNT, which for integers i is simply (ABS i). Thus, this theorem won't + justify a simple recursion by a negative y, since (FLOOR 1 y) = -1 for + negative y, and (ABS -1) = (ABS 1). For the most general case that includes + negative y one would need to define a different measure that could handle this + condition.</p> + + ") + +(defxdoc linearize-mod + :parents (mod-lemmas) + :short "Rewrite (D): Transform (MOD x y) < z, (MOD x y) > z, and (MOD x y) = z +into an equivalent FLOOR expression suitable for reasoning about with +FLOOR-BOUNDS and other theorems about FLOOR." + :long "<p>Since this lemma can be considered a `definition' of MOD, it is + exported DISABLED.</p> + + ") + +(defxdoc linearize-rem + :parents (rem-lemmas) + :short "Rewrite (D): Transform (REM x y) < z, (REM x y) > z, and (REM x y) = z +into an equivalent TRUNCATE expression suitable for reasoning about with +TRUNCATE-BOUNDS and other theorems about TRUNCATE." + :long "<p>Since this lemma can be considered a `definition' of REM, it is + exported DISABLED.</p> + + ") + +(defxdoc mod-+ + :parents (mod-+) + :short "Rewrite (D): (MOD (+ x y) z) = (MOD (+ (MOD x z) (MOD y z)) z)." + :long "<p>As this rule could easily loop it is exported DISABLEd. Don't + ENABLE this lemma unless you are sure that the MOD/MOD term will simplify, or + else put SYNTAXP guards on the variables x, y, and/or z.</p> + + ") + +(defxdoc mod-=-0 + :parents (mod-lemmas integer-ratio-lemmas) + :short "Rewrite: (MOD x y) = 0, when x/y is an integer;" + :long "<p>This rule is a corollary of a more general equality. The equality + is also stored as a :REWRITE and :GENERALIZE rule.</p> + + ") + +(defxdoc mod-bounds + :parents (mod-lemmas) + :short "Linear: Useful forms of the fact that |(MOD x y)| < |y|." + :long "<p>This lemma is also stored as a :GENERALIZE rule.</p> + + ") + +(defxdoc mod-lemmas + :parents (quotient-remainder-lemmas) + :short "Lemmas about MOD." + :long "") + +(defxdoc mod-minus + :parents (mod-lemmas integer-ratio-lemmas) + :short "Rewrite: (MOD (- x) y) = + (IF (INTEGERP (/ x y)) + 0 + (- y (MOD x y))); + (MOD x (- y)) = + (IF (INTEGERP (/ x y)) + 0 + (- (MOD x y) y))." + :long "") + +(defxdoc mod-type + :parents (mod-lemmas) + :short "Various: Decide (MOD x y) < 0 and (MOD x y) > 0 based on the sign of +y and the INTEGERP-ness of x/y." + :long "<p>This rule is also stored as + appropriate :REWRITE, :LINEAR, :GENERALIZE, and :TYPE-PRESCRIPTION rules.</p> + + ") + +(defxdoc mod-type-linear + :parents (mod-lemmas) + :short "A theory of the :LINEAR rules created by the lemma MOD-TYPE." + :long "<p>These rules are implicated in thrashing linear arithmetic, so we + provide this theory which can be DISABLED if it becomes a problem.</p> + + ") + +(defxdoc mod-x+i*k-i*j + :parents (mod-lemmas) + :short "Rewrite: (MOD (+ x (* i k)) (* i j)) = (+ x (* i (MOD k j))), when +i,j > 0 and 0 <= x < i." + :long "<p>This is a crucial lemma for certain kinds of reasoning about + hardware specifications, for example, we can use this to prove that + (MOD i (EXPT 2 n)) = (MOD i 2) + (MOD (FLOOR i 2) (EXPT 2 (1- n))), for n > + 0, which justifies a recursive specification of hardware operations.</p> + + ") + +(defxdoc mod-x-y-=-x + :parents (mod-lemmas) + :short "Rewrite: (MOD x y) = x, when |x| <= |y| and x and y have the same sign." + :long "<p>This rule is a corollary of a more general equality which is also + stored as + :REWRITE and :GENERALIZE rules.</p> + + ") + +(defxdoc mod-x-y-=-x+y + :parents (mod-lemmas) + :short "Rewrite: (MOD x y) = x + y, when |x| <= |y| and x and y have different +signs and x /= 0." + :long "<p>This rule is a corollary of a more general equality which is also + stored as + :REWRITE and :GENERALIZE rules.</p> + + ") + +(defxdoc niq-bounds + :parents (niq-lemmas) + :short "Linear (D): i/j - 1 < (NIQ i j) <= i/j." + :long "<p>This lemma serves as a :LINEAR definition of + NONNEGATIVE-INTEGER-QUOTIENT, and allows us to derive interesting properties + of FLOOR and TRUNCATE by linear arithmetic. This lemma is stored as a :LINEAR + rule under NIQ since we think of this as a property of NIQ, and not as a + general property of (/ I J).</p> + + ") + +(defxdoc niq-guard + :parents (qr-guard-macros) + :short "Macro form of the guard for NONNEGATIVE-INTEGER-QUOTIENT (forced)." + :long "<p>~</p>") + +(defxdoc niq-lemmas + :parents (quotient-remainder-lemmas) + :short "Lemmas about nonnegative-integer-QUOTIENT (abbreviated NIQ)." + :long "") + +(defxdoc niq-type + :parents (niq-lemmas) + :short "Various : Decide (NIQ i j) = 0, (NIQ i j) > 0, and +(NIQ i j) = i/j based on the inequalities of i and j, and the INTEGERP-ness +of i/j." + :long "") + +(defxdoc qr-guard + :parents (qr-guard-macros) + :short "Quotient/Remainder GUARD: Macro form of the guards for FLOOR, MOD, TRUNCATE, +and REM., or any ratio x/y of rationals (forced)." + :long "<p>~</p>") + +(defxdoc qr-guard-macros + :parents (quotient-remainder-lemmas) + :short "Macro forms of the guards for the quotient/remainder functions." + :long "<p>Without these macros, fully 25% of the text of the + \"quotient-remainder-lemmas\" book is given over simply to expressing the + guards!</p> + + ") + +(defxdoc quotient-remainder-functions + :parents (quotient-remainder-theories) + :short "A theory of the function symbols characterized by +\"quotient-remainder-lemmas\"." + :long "<p>You should DISASBLE this theory immediately after loading this + book.</p> + + ") + +(defxdoc quotient-remainder-lemmas + :parents (quotient-remainder-lemmas) + :short "A book of facts about FLOOR, MOD, TRUNCATE and REM, and integer ratios. +Also enough of a theory of the Acl2 function NONNEGATIVE-INTEGER-QUOTIENT +to prove the rules." + :long "<p>Since NONNEGATIVE-INTEGER-QUOTIENT is the only one of these + functions that is recursive, the others must be DISABLEd for this library to + be of any use. This can easily be done by DISABLEing the + QUOTIENT-REMAINDER-FUNCTIONS theory (defined by this book):</p> + + <p>(IN-THEORY (DISABLE QUOTIENT-REMAINDER-FUNCTIONS))</p> + + <p>INTRODUCTION</p> + + <p>Common Lisp defines the quotient/remainder functions FLOOR/MOD and + TRUNCATE/REM, which operate on any rational numbers (as long as the divisor is + non-zero). Both (TRUNCATE x y) and (FLOOR x y) are integers, and specify the + `integer part' of the rational number x/y; they differ in the direction of + rounding.</p> + + <p>TRUNCATE is the `FORTRAN-style' quotient operation, rounding towards 0, + i.e., (TRUNCATE x y) = (TRUNCATE (ABS x) (ABS y)). This book provides a + selected theory of TRUNCATE and REM.</p> + + <p>(FLOOR x y) is identical to TRUNCATE if x/y > 0 or x/y is an integer, + otherwise for negative non-integer ratios x/y, (FLOOR x y) = (TRUNCATE x y) - + 1. (FLOOR i (EXPT 2 j)) is the specification of an `arithmetic shift' of the + integer i by -j bits. Since FLOOR and MOD are the foundations for integer + descriptions of hardware, this book contains a very extensive theory of FLOOR + and MOD.</p> + + <p>The formal definitions of the Common Lisp functions are made in terms of + the Acl2 function NONNEGATIVE-INTEGER-QUOTIENT, which is simple recursive + specification of division of nonnegative integers by repeated subtraction. We + provide only enough of a theory of NONNEGATIVE-INTEGER-QUOTIENT to prove the + desired properties of the Common Lisp functions.</p> + + <p>DOCUMENTATION</p> + + <p>The documentation for this library is divided into a number of sections. + There is a section for the rules that apply to each function. Some of the + rules will appear in more than 1 section. If a rule is exported DISABLEd, + then you will see `(D)' after the rule class in the `one-liner' for the rule. + Note that we often abbreviate NONNEGATIVE-INTEGER-QUOTIENT as NIQ.</p> + + <p>APPROACH</p> + + <p>We have tried to capture the properties of the quotient/remainder functions + with the smallest number of the most general rules possible. This approach + takes advantage of Acl2 type reasoning, and the assumed existence of a basic + mathematics simplification library. Several lemmas contain the hypothesis + (INTEGERP (/ x y)), which we consider to be the simplest statement of the fact + that (<quotient> x y) = x/y, e.g.</p> + + <p>(INTEGERP (/ x y)) ==> (FLOOR x y) = (/ x y), (INTEGERP (/ x y)) ==> + (MOD x y) = 0.</p> + + <p>Thus, the first fact above obviates the need for a specials lemmas like + (FLOOR i 1) = i for integers i, since (/ i 1) = i by simplification.</p> + + <p>In general, at most 2 of the many possible commutative forms of the rules + are exported from this library. If they aren't the ones you need, simply + prove the appropriate corollary, or :USE an :INSTANCE of the library rule. + Also, lemmas are generally exported DISABLEd if they seemed to interfere with + the proofs of other lemmas, or could easily lead to infinite looping. Be + careful when ENABLEing these lemmas.</p> + + <p>Questions, comments, and sugestions are welcome. Contact + brock@@cli.com.</p>") + +(defxdoc quotient-remainder-rules + :parents (quotient-remainder-theories) + :short "A theory of all rules exported ENABLEd by the \"quotient-remainder-lemmas\" +book." + :long "") + +(defxdoc quotient-remainder-theories + :parents (quotient-remainder-lemmas) + :short "Logical theories supplied by the QUOTIENT-REMAINDER book." + :long "<p>The QUOTIENT-REMAINDER book exports 2 theories: + QUOTIENT-REMAINDER-FUNCTIONS and QUOTIENT-REMAINDER-RULES. The former is + simply a theory of the functions characterized by the book. Since these + functions are all ENABLEd by default, and most are non-recursive, one should + immediately:</p> + + <p>(IN-THEORY (DISABLE QUOTIENT-REMAINDER-FUNCTIONS))</p> + + <p>upon loading this book, or the lemmas may never be applied.</p> + + <p>QUOTIENT-REMAINDER-RULES is a theory of all of the lemmas exported by this + book which are ENABLEd by default. You can \"turn off\" this book after it is + loaded by</p> + + <p>(IN-THEORY (DISABLE QUOTIENT-REMAINDER-RULES)).</p>") + +(defxdoc rem-=-0 + :parents (rem-lemmas integer-ratio-lemmas) + :short "Rewrite: (REM x y) = 0, when x/y is an integer;" + :long "<p>NB: This rule is a corollary of a more general equality. The + equality is also stored as a :REWRITE and :GENERALIZE rule.</p> + + ") + +(defxdoc rem-bounds + :parents (rem-lemmas) + :short "Linear: Useful forms of the fact that |(REM x y)| < |y|." + :long "<p>This lemma is also stored as a :GENERALIZE rules.</p> + + ") + +(defxdoc rem-lemmas + :parents (quotient-remainder-lemmas) + :short "Lemmas about REM." + :long "") + +(defxdoc rem-minus + :parents (rem-lemmas) + :short "Rewrite: (REM (- x) y) = (- (REM x y)); + (REM x (- y)) = (SIGNUM x) * (SIGNUM y) * (REM x y))." + :long "") + +(defxdoc rem-type + :parents (rem-lemmas) + :short "Various : Decide (REM x y) < 0 and (REM x y) > 0 based on the sign of +x and the INTEGERP-ness of x/y." + :long "<p>This rule is stored as appropriate :REWRITE, :LINEAR, :GENERALIZE, + and + :TYPE-PRESCRIPTION rules.</p> + + ") + +(defxdoc rem-x-y-=-x + :parents (rem-lemmas) + :short "Rewrite: (REM x y) = x, when |x| < |y|." + :long "<p>This rule is a corollary of a more general equality which is also + stored as a :REWRITE and :GENERALIZE rule.</p> + + ") + +(defxdoc rewrite-floor-mod + :parents (floor-lemmas integer-ratio-lemmas) + :short "Rewrite: (FLOOR (MOD x y) z) = (FLOOR x z) - i*(FLOOR x y), when i = y/z +is an integer." + :long "") + +(defxdoc rewrite-floor-x*y-z-left + :parents (floor-lemmas) + :short "Rewrite (D): (FLOOR (* x y) z) = (FLOOR y (/ z x)), when x /= 0." + :long "<p>Since we don't presume any rewriting strategy for / vis-a-vis *, + this often useful rule is exported DISABLEd.</p> + + ") + +(defxdoc rewrite-floor-x*y-z-right + :parents (floor-lemmas) + :short "Rewrite: (FLOOR (* x y) z) = (FLOOR x (/ z y)), when y /= 0." + :long "<p>Since we don't presume any rewriting strategy for / vis-a-vis *, + this often useful rule is exported DISABLEd.</p> + + ") + +(defxdoc rewrite-mod-mod + :parents (mod-lemmas integer-ratio-lemmas) + :short "Rewrite: (MOD (MOD x y) z) = (MOD x z), when y/z is an integer." + :long "") + +(defxdoc rewrite-truncate-x*y-z-left + :parents (truncate-lemmas) + :short "Rewrite (D): (TRUNCATE (* x y) z) = (TRUNCATE y (/ z x)), when x /= 0." + :long "<p>Since we don't presume any rewriting strategy for / vis-a-vis *, + this often useful rule is exported DISABLEd.</p> + + ") + +(defxdoc rewrite-truncate-x*y-z-right + :parents (truncate-lemmas) + :short "Rewrite (D): (TRUNCATE (* x y) z) = (TRUNCATE x (/ z y)), when y /= 0." + :long "<p>Since we don't presume any rewriting strategy for / vis-a-vis *, + this often useful rule is exported DISABLEd.</p> + + ") + +(defxdoc simplify-mod-+-mod + :parents (mod-lemmas) + :short "Rewrite: (MOD (+ w (MOD x y)) z) = (MOD (+ w x) z); + (MOD (+ (MOD x y) w) z) = (MOD (+ w x) z)); + (MOD (- w (MOD x y)) z) = (MOD (- w x) z)); + (MOD (- (MOD x y) w) z) = (MOD (- x w) z)), +Provided that for each case y/z is an integer." + :long "") + +(defxdoc truncate-=-x/y + :parents (truncate-lemmas integer-ratio-lemmas) + :short "Rewrite: (TRUNCATE x y) = x/y, when x/y is an integer." + :long "<p>This rule is a corollary of a more general equality, which is also + stored as a :REWRITE and :GENERALIZE rule.</p> + + ") + +(defxdoc truncate-bounds + :parents (truncate-lemmas) + :short "Linear (D) : x/y - 1 < (TRUNCATE x y) <= x/y, when x/y >= 0; + x/y <= (TRUNCATE x y) < x/y + 1, when x/y =< 0." + :long "<p>This lemma `defines' TRUNCATE as a set of inequalties. Many of the + properties of TRUNCATE will be derived from this theorem. Unfortunately, this + lemma is implicated in thrashing in the linear arithmetic procedure unless the + inequalties of X and Y can be decided, so it may need to be DISABLEd at times. + This lemma is stored as a :LINEAR rule for TRUNCATE exclusively since we + consider it to be a property of TRUNCATE, and not a general property of (/ x + y).</p> + + <p>The statement of the hypotheses of this lemma is critical for its proper + application. It is necessary for each inequality of x and y to stand alone in + order to be relieveable by linear arithemetic.</p> + + ") + +(defxdoc truncate-cancel-* + :parents (truncate-lemmas) + :short "Rewrite: (TRUNCATE (* x y) y) = (TRUNCATE x 1)." + :long "<p>NB: You get the commutted form as well.</p> + + ") + +(defxdoc truncate-lemmas + :parents (quotient-remainder-lemmas) + :short "Lemmas about TRUNCATE." + :long "") + +(defxdoc truncate-minus + :parents (truncate-lemmas) + :short "Rewrite: (TRUNCATE (- x) y) = (- (TRUNCATE x y)); + (TRUNCATE x (- y)) = (- (TRUNCATE x y))." + :long "") + +(defxdoc truncate-rem-elim + :parents (truncate-lemmas rem-lemmas) + :short "Rewrite: (+ (REM x y) (* y (TRUNCATE x y))) = x." + :long "<p>NB: This rule is also stored as an :ELIM rule.</p> + + ") + +(defxdoc truncate-type + :parents (truncate-lemmas) + :short "Various : Decide (TRUNCATE x y) < 0, (TRUNCATE x y) > 0, and +(TRUNCATE x y) = 0 based on inequalities of x and y." + :long "<p>This rule is available in various forms: :REWRITE, :LINEAR, + :TYPE-PRESCRIPTION, and :GENERALIZE as appropriate. Note that unless we can + decide the inequalities of X and Y the :LINEAR forms may thrash.</p> + + ") |