; Problem set 6 answers

(include-book "m1-lemmas")

(begin-book t :ttags :all)

(in-package "M1")

; Problem 6-1:

#|
(compile
 '(x y)
 '((a = 1)
   (if (y = 0)
       ((return 1))
       ((if (x = 0)
          ((return 0))
          ((while (y > 0)
            (y = (y - 1))
            (a = (a * x)))
           (return a)))))))
|#

; The bytecode program generated by the compiler:

(defconst *expt-program*
  '((ICONST 1)   ;;;  0
    (ISTORE 2)   ;;;  1  (a = 1)
    (ILOAD 1)    ;;;  2  (if (y
    (ICONST 0)   ;;;  3         != 0)     jmp to pc + 4
    (ISUB)       ;;;  4
    (IFNE 4)     ;;;  5
    (ICONST 1)   ;;;  6  (if (y = 0)
    (HALT)       ;;;  7      (return 1)
    (GOTO 21)    ;;;  8
    (ILOAD 0)    ;;;  9  (if (x      
    (ICONST 0)   ;;;  10        != 0)     jmp to pc + 4
    (ISUB)       ;;;  11
    (IFNE 4)     ;;;  12
    (ICONST 0)   ;;;  13 (if (x = 0)
    (HALT)       ;;;  14     (return 0)
    (GOTO 14)    ;;;  15
    (ILOAD 1)    ;;;  16 (while       ; loop pc = 16
    (IFLE 10)    ;;;  17       (y > 0)
    (ILOAD 1)    ;;;  18
    (ICONST 1)   ;;;  19
    (ISUB)       ;;;  20
    (ISTORE 1)   ;;;  21 (y = (y - 1))
    (ILOAD 2)    ;;;  22
    (ILOAD 0)    ;;;  23
    (IMUL)       ;;;  24
    (ISTORE 2)   ;;;  25 (a = (a * x))
    (GOTO -10)   ;;;  26
    (ILOAD 2)    ;;;  27
    (HALT)))     ;;;  28

; Problem 6-2:

; [1] Specify the concepts

; (a) What we want:
; We call the function exp because expt is already defined in M1.

(defun exp (x y)
  (if (zp y)
      1
    (* x (exp x (- y 1)))))

; (b) How we'll do it:  We'll compute (iexpt x y 1), where

(defun iexpt (x y a)
  (if (zp y)
      a
    (iexpt x (- y 1) (* x a))))

; [2] Write the program.

; See Problem 6-1.

; [3] Specify how long it takes to execute the program (starting with the loop). Define a
;     scheduler function that will run this program to completion.

; To schedule the iexpt program on x and y starting at the loop pc = 16: If y
; <= 0, schedule 4 steps, namely the instructions at pcs 16, 17, 27, and 28,
; ending at the HALT. Otherwise, if y > 0, schedule the 11 instructions at pcs
; 16 through 26, ending back at pc = 16, and then schedule iexpt for y-1.

(defun sched-iexpt-loop (y)
  (if (zp y)
      (repeat 0 4)
    (app (repeat 0 11)
            (sched-iexpt-loop (- y 1)))))

; Schedule a complete iexpt computation, starting at pc = 0.

(defun sched-iexpt (x y)
  (if (zp y)
      (repeat 0 8)
      (if (zp x)
        (repeat 0 12)
        (app (repeat 0 10)
                (sched-iexpt-loop y)))))

; [4] Test the program and your scheduler.

; We define a little "test harness" to let us compute iexpt on any two
; naturals, using the iexpt program.

(defun test-iexpt (x y)
  (top
   (stack
    (run (sched-iexpt x y)
         (make-state 0
                     (cons x (cons y (cons 1 nil)))      ; x = x, y = y, a = 1
                     nil
                     *expt-program*)))))

(defthm test-iexpt-examples
  (and (equal (test-iexpt 0 1) (exp 0 1))
       (equal (test-iexpt 1 0) (exp 1 0))
       (equal (test-iexpt 0 0) (exp 0 0))
       (equal (test-iexpt 1 1) (exp 1 1))
       (equal (test-iexpt 2 4) (exp 2 4))
       (equal (test-iexpt 3 3) (exp 3 3)))
  :rule-classes nil)

; [5] Prove your program does what it does, starting with the loop.

(defthm iexpt-loop-lemma
  (implies (and (natp x)
                (natp y)
                (natp a))
           (equal (run (sched-iexpt-loop y)
                       (make-state 16
                                   (cons x (cons y (cons a nil)))
                                   stack
                                   *expt-program*))
                  (make-state 28
                              (cons x (cons 0 (cons (iexpt x y a) nil)))
                              (push (iexpt x y a) stack)
                              *expt-program*))))

(defthm iexpt-lemma
  (implies (and (natp x)
                (natp y)
                (natp a))
           (equal (run (sched-iexpt x y)
                       (make-state 0
                                   (cons x (cons y (cons a nil)))
                                   stack
                                   *expt-program*))
                  (if (zp y)
                      (make-state 7
                                  (cons x (cons 0 (cons 1 nil)))
                                  (push 1 stack)
                                  *expt-program*)
                    (if (zp x)
                        (make-state 14
                                    (cons 0 (cons y (cons 1 nil)))
                                    (push 0 stack)
                                    *expt-program*)
                      (make-state 28
                                  (cons x (cons 0 (cons (iexpt x y 1) nil)))
                                  (push (iexpt x y 1) stack)
                                  *expt-program*))))))

 ; We can now disable sched-isumn so that we never run the bytecode again in
 ; proofs.

(in-theory (disable sched-iexpt))

; [6] Prove what we do is what we want.

(defthm iexpt-is-exp
  (implies (and (natp x)
                (natp y)
                (natp a))
           (equal (iexpt x y a)
                  (* a (exp x y)))))

; [7]  Put it all together.

(defthm iexpt-correct
  (implies (and (natp x)
                (natp y)
                (natp a))
           (equal (run (sched-iexpt x y)
                       (make-state 0
                                   (cons x (cons y (cons a nil)))
                                   stack
                                   *expt-program*))
                  (if (zp y)
                      (make-state 7
                                  (cons x (cons 0 (cons 1 nil)))
                                  (push 1 stack)
                                  *expt-program*)
                    (if (zp x)
                        (make-state 14
                                    (cons 0 (cons y (cons 1 nil)))
                                    (push 0 stack)
                                    *expt-program*)
                      (make-state 28
                                  (cons x (cons 0 (cons (exp x y) nil)))
                                  (push (exp x y) stack)
                                  *expt-program*))))))

(defthm iexpt-correct-corollary-1
  (implies (and (natp x)
                (natp y)
                (natp a))
           (equal (top
                   (stack
                    (run (sched-iexpt x y)
                       (make-state 0
                                   (cons x (cons y (cons a nil)))
                                   stack
                                   *expt-program*))))
                  (exp x y))))

(defthm iexpt-correct-corollary-2
  (implies (and (natp x)
                (natp y)
                (natp a))
           (equal (top
                   (stack
                    (run (sched-iexpt x y)
                         (make-state 0
                                     (cons x (cons y (cons a nil)))
                                     stack
                                     (compile
                                      '(x y)
                                      '((a = 1)
                                        (if (y = 0)
                                          ((return 1))
                                          ((if (x = 0)
                                             ((return 0))
                                             ((while (y > 0)
                                                     (y = (y - 1))
                                                     (a = (a * x)))
                                              (return a)))))))))))
                  (exp x y))))