; Script for ACL2 Code Proofs -- Lecture 2
; J Strother Moore
; November 15, 2013
; You should first certify the book m1-with-stobj.lisp before executing the
; following include-book form. However, if you are using an ACL2 Version after
; 6.3, or an svn copy of the acl2-books trunk updated after 11/16/2013, then
; you can replace the following include-book form with:
; (include-book "models/jvm/m1/m1-with-stobj" :dir :system)
(include-book "m1-with-stobj")
(in-package "M1")
(set-verify-guards-eagerness 0)
(set-guard-checking :nowarn)
(pe 'execute-ILOAD)
(pe '!pc)
(pe 'wr)
(pe 'wr-wr-diff)
(pe 'execute-ISTORE)
(pe 'execute-IADD)
(defconst *pi*
'((ICONST 0) ; 0
(ISTORE 2) ; 1 a $=$ 0;
(ILOAD 0) ; 2 [loop:]
(IFEQ 10) ; 3 if x$=$0 then go to end;
(ILOAD 0) ; 4
(ICONST 1) ; 5
(ISUB) ; 6
(ISTORE 0) ; 7 x $=$ x-1;
(ILOAD 1) ; 8
(ILOAD 2) ; 9
(IADD) ;10
(ISTORE 2) ;11 a $=$ y+a;
(GOTO -10) ;12 go to loop
(ILOAD 2) ;13 [end:]
(HALT) ;14 ``return'' a
))
(defun g (x y a)
(if (zp x)
a
(g (- x 1) y (+ y a))))
(defun loop-clk (x)
(if (zp x)
3
(clk+ 11
(loop-clk (- x 1)))))
(defun clk (x)
(clk+ 2
(loop-clk x)))
(defun test-program (x y s)
(declare (xargs :stobjs (s)))
(let* ((s (!pc 0 s))
(s (!loi 0 x s))
(s (!loi 1 y s))
(s (!stack nil s))
(s (update-ugly-program *pi* s))
(k (clk x))
(s (m1 s k)))
(mv `((:clk ,k)
(:haltedp ,(haltedp s))
(:tos ,(top (stack s))))
s)))
(test-program 5 7 s)
(test-program 7 5 s)
(test-program 700 500 s)
(quote (back to talk))
(defun natp-listp (x)
(if (endp x)
(equal x nil)
(and (natp (car x))
(natp-listp (cdr x)))))
(defun good-statep (s)
(declare (xargs :stobjs (s)))
(and (sp s)
(natp (rd :pc s))
(natp-listp (rd :locals s))
(<= 3 (len (rd :locals s)))
(natp-listp (rd :stack s))
(equal (rd :program s) *pi*)))
(thm (implies (good-statep s)
(good-statep (m1 s 11))))
(thm (implies (and (good-statep s)
(equal (pc s) 2))
(good-statep (m1 s 11))))
(defthm natp-listp-nth
(implies (and (natp-listp x)
(natp i)
(< i (len x)))
(natp (nth i x)))
:rule-classes (:rewrite :type-prescription))
(defthm natp-listp-update-nth
(implies (and (natp i)
(< i (len x))
(natp (nth i x)))
(equal (natp-listp (update-nth i v x))
(and (natp v)
(natp-listp x)))))
(defthm natp-listp-push
(implies (natp-listp stk)
(equal (natp-listp (push i stk))
(natp i)))
:hints (("Goal" :in-theory (enable push))))
(in-theory (disable natp-listp len nth update-nth))
(thm (implies (and (good-statep s)
(equal (pc s) 2))
(good-statep (m1 s 11))))
(defun hint (s)
(declare (xargs :stobjs (s)
:measure (acl2-count (loi 0 s))))
(if (and (good-statep s)
(equal (pc s) 2))
(if (zp (loi 0 s))
s
(let ((s (m1 s 11)))
(hint s)))
s))
(defthm loop-correct
(implies
(and (good-statep s)
(equal (rd :pc s) 2))
(equal
(m1 s (loop-clk (loi 0 s)))
(!pc 14
(!loi 0 0
(!loi 2 (g (loi 0 s) (loi 1 s) (loi 2 s))
(!stack (push (g (loi 0 s)
(loi 1 s)
(loi 2 s))
(stack s))
s))))))
:hints (("Goal" :induct (hint s))))
(in-theory (disable loop-clk))
(defthm entry-correct
(implies
(and (good-statep s)
(equal (pc s) 0))
(equal
(m1 s (clk (loi 0 s)))
(!pc 14
(!loi 0 0
(!loi 2 (g (loi 0 s) (loi 1 s) 0)
(!stack (push (g (loi 0 s)
(loi 1 s)
0)
(stack s))
s)))))))
(quote (back to talk))
(ubt! 'loop-correct)
(defthm loop-correct
(implies
(and (good-statep s)
(equal (rd :pc s) 2))
(equal
(m1 s (loop-clk (loi 0 s)))
(!pc 14
(!loi 0 0
(!loi 2 (g (loi 0 s) (loi 1 s) (loi 2 s))
(!stack (push (g (loi 0 s)
(loi 1 s)
(loi 2 s))
(stack s))
s))))))
:hints (("Goal" :induct (hint s)))
:rule-classes
((:rewrite
:corollary
(implies
(and (good-statep s)
(equal (rd :pc s) 2)
(equal x (loi 0 s)))
(equal
(m1 s (loop-clk x))
(!pc 14
(!loi 0 0
(!loi 2 (g (loi 0 s) (loi 1 s) (loi 2 s))
(!stack (push (g (loi 0 s)
(loi 1 s)
(loi 2 s))
(stack s))
s)))))))))
(in-theory (disable loop-clk))
(defthm entry-correct
(implies
(and (good-statep s)
(equal (pc s) 0))
(equal
(m1 s (clk (loi 0 s)))
(!pc 14
(!loi 0 0
(!loi 2 (g (loi 0 s) (loi 1 s) 0)
(!stack (push (g (loi 0 s) (loi 1 s) 0)
(stack s))
s))))))
:rule-classes
((:rewrite
:corollary
(implies
(and (good-statep s)
(equal (pc s) 0)
(equal x (loi 0 s)))
(equal
(m1 s (clk x))
(!pc 14
(!loi 0 0
(!loi 2 (g (loi 0 s) (loi 1 s) 0)
(!stack (push (g (loi 0 s) (loi 1 s) 0)
(stack s))
s)))))))))
(in-theory (disable clk))
(defthm lemma
(implies (and (natp x) (natp y) (natp a))
(equal (g x y a)
(+ a (* x y)))))
(defthm algorithm-implements-spec
(implies (and (natp x) (natp y))
(equal (g x y 0)
(* x y))))
(defthm main-goal
(implies (and (good-statep s)
(equal (pc s) 0)
(equal sf (m1 s (clk (loi 0 s)))))
(and (haltedp sf)
(equal (top (stack sf))
(* (loi 0 s)
(loi 1 s)))))
:rule-classes nil)
(quote (back to talk))
(ubt! 'hint)
(defun hint (s)
(declare (xargs :stobjs (s)
:measure (acl2-count (loi 0 s))))
(if (zp (loi 0 s))
s
(let* ((s (!loi 0 (- (loi 0 s) 1) s))
(s (!loi 2 (+ (loi 1 s) (loi 2 s)) s)))
(hint s))))
(defthm loop-correct
(implies
(and (good-statep s)
(equal (pc s) 2))
(equal
(m1 s (loop-clk (loi 0 s)))
(!pc 14
(!loi 0 0
(!loi 2 (g (loi 0 s) (loi 1 s) (loi 2 s))
(!stack (push (g (loi 0 s) (loi 1 s) (loi 2 s))
(stack s))
s))))))
:hints (("Goal" :induct (hint s)))
; :rule-classes ((:rewrite :corollary ...))
)
(ubt! 'hint)
(quote (back to talk))
(encapsulate
(((pre *) => *)
((post *) => *)
((test *) => *) ; recog base case
((k *) => *) ; steps to termination
((n *) => *) ; steps around loop
((m *) => *)) ; measure
(local (defun pre (si) (declare (ignore si)) t))
(local (defun post (sf) (declare (ignore sf)) t))
(local (defun test (s) (declare (ignore s)) t))
(local (defun k (s) (declare (ignore s)) 0))
(local (defun n (s) (declare (ignore s)) 0))
(local (defun m (s) (declare (ignore s)) 0))
(defthm natp-k
(natp (k s))
:rule-classes :type-prescription)
(defthm natp-n
(natp (n s))
:rule-classes :type-prescription)
(defthm o-p-m
(implies (pre s)
(o-p (m s)))
:rule-classes :rewrite)
(defthm m-dec
(implies (and (pre s)
(not (test s)))
(o< (m (m1 s (n s)))
(m s)))
:rule-classes :rewrite)
(defthm pre-invariant
(implies (and (pre s)
(not (test s)))
(pre (m1 s (n s))))
:rule-classes :rewrite)
(defthm pre-implies-post
(implies (and (pre s)
(test s))
(post (m1 s (k s)))))
)
(encapsulate
nil
(defun-nx iclk (s)
(declare (xargs :measure (if (pre s) (m s) 0)
:hints (("Goal" :in-theory (disable o-p o<)))))
(if (pre s)
(if (test s)
(k s)
(clk+ (n s) (iclk (m1 s (n s)))))
0))
(local
(defun-nx iclk1 (s)
(declare (xargs :measure (if (pre s) (m s) 0)
:hints (("Goal" :in-theory (disable o-p o<)))))
(if (pre s)
(if (test s)
0
(clk+ (n s) (iclk1 (m1 s (n s)))))
0)))
(local
(defthm iclk-is-iclk1+k
(implies (pre s)
(equal (iclk s) (clk+ (iclk1 s) (k (m1 s (iclk1 s))))))
:hints (("Subgoal *1/1'" :in-theory (enable binary-clk+)))
:rule-classes :rewrite))
(local
(defthm irule1
(implies (pre s)
(pre (m1 s (iclk1 s))))))
(local
(defthm irule2
(implies (pre s)
(test (m1 s (iclk1 s))))))
(defthm irule ; This is the special-purpose induction rule!
(implies (pre s)
(post (m1 s (iclk s))))))
(defthm loop-correct
(implies
(and (good-statep s)
(equal (rd :pc s) 2))
(equal
(m1 s (loop-clk (loi 0 s)))
(!pc 14
(!loi 0 0
(!loi 2 (g (loi 0 s) (loi 1 s) (loi 2 s))
(!stack (push (g (loi 0 s)
(loi 1 s)
(loi 2 s))
(stack s))
s))))))
:hints
(("Goal"
:use
(:functional-instance irule
(pre (lambda (s)
(and (good-statep s)
(equal (rd :pc s) 2))))
(post (lambda (sf)
(equal sf
(!pc 14
(!loi 0 0
(!loi 2 (g (loi 0 s)
(loi 1 s)
(loi 2 s))
(!stack (push (g (loi 0 s)
(loi 1 s)
(loi 2 s))
(stack s))
s)))))))
(m (lambda (s) (acl2-count (loi 0 s))))
(k (lambda (s) 3))
(n (lambda (s) 11))
(iclk (lambda (s)
(if (and (good-statep s)
(equal (rd :pc s) 2))
(loop-clk (loi 0 s))
0)))
(test (lambda (s) (zp (loi 0 s))))))))
(ubt! 'loop-correct)
(quote (back to talk))
(set-gag-mode :goals)
(thm
(implies (and (good-statep s)
(equal (pc s) 2)
(> (loi 0 s) 40))
(equal (pc (m1 s 440)) 2)))
(thm
(implies (and (good-statep s)
(equal (pc s) 2)
(> (loi 0 s) 80))
(equal (pc (m1 s 880)) 2)))
(in-theory (disable (:executable-counterpart binary-clk+)))
(thm
(implies (and (good-statep s)
(equal (pc s) 2)
(> (loi 0 s) 80))
(equal (pc (m1 s (clk+ 400 400 80))) 2)))
(quote (back to talk))
; At this point, the demo loaded and demonstrated tools that are not
; ready for release yet. The session log of Lecture 2 shows the
; commands and their output, but since the source code is not yet
; available, I'm not including the commands here.