; This is the script I used in the lecture on Thu, Jan 26, 2007.

; (include-book "problem-set-1-answers")

; In the lecture I loaded the ACL2 book above, which contains my answers to
; Problem Set 1.  But since Problem Set 1 is not due yet, I've changed this
; posting of the script to include just the definitions from that problem set
; that are needed below, namely:

(defpkg "M1"
  '(defun declare ignore xargs defthm mutual-recursion
    include-book in-theory disable defconst
    defmacro &rest
    intern-in-package-of-symbol
    coerce symbol-name
    string
    otherwise
    concatenate progn strip-cars syntaxp quotep assoc pairlis$ pairlis-x2 e/d

    o-p o< acl2-count
    let let*
    cond case
    and or not implies t nil quote
    cons consp car cdr endp
    list list*
    atom symbolp natp
    if equal
    zp + - * / mod expt < <= > >=))

(in-package "M1")

; and the definitions of the functions:
; push, top, pop,
; nth,
; update-nth,
; make-state, pc, locals, stack, program, and
; opcode, arg1, arg2

(defun push (x y) (cons x y))
(defun top (stack) (car stack))
(defun pop (stack) (cdr stack))
(defun nth (n list)
  (if (zp n)
      (car list)
    (nth (- n 1) (cdr list))))
(defun update-nth (n v list)
  (if (zp n)
      (cons v (cdr list))
    (cons (car list)
          (update-nth (- n 1) v (cdr list)))))
(defun make-state (pc locals stack program)
     (cons pc
           (cons locals
                 (cons stack
                       (cons program
                             nil)))))
(defun pc (s) (nth 0 s))
(defun locals (s) (nth 1 s))
(defun stack (s) (nth 2 s))
(defun program (s) (nth 3 s))
(defun op-code (inst) (car inst))
(defun arg1 (inst) (nth 1 inst))
(defun arg2 (inst) (nth 2 inst))

; That completes the preliminaries, all of which were in
; Problem Set 1.  So now I define the M1 machine:

(defun next-inst (s)
  (nth (pc s) (program s)))

; Now we define the semantics of each instruction.  These
; functions are called ``semantic functions.''

(defun execute-ILOAD (inst s)
  (make-state (+ 1 (pc s))
              (locals s)
              (push (nth (arg1 inst)
                         (locals s))
                    (stack s))
              (program s)))

(defun execute-ICONST (inst s)
  (make-state (+ 1 (pc s))
              (locals s)
              (push (arg1 inst) (stack s))
              (program s)))

(defun execute-IADD (inst s)
  (declare (ignore inst))
  (make-state (+ 1 (pc s))
              (locals s)
              (push (+ (top (pop (stack s)))
                       (top (stack s)))
                    (pop (pop (stack s))))
              (program s)))

(defun execute-ISTORE (inst s)
  (make-state (+ 1 (pc s))
              (update-nth (arg1 inst) (top (stack s)) (locals s))
              (pop (stack s))
              (program s)))

(defun execute-ISUB (inst s)
  (declare (ignore inst))
  (make-state (+ 1 (pc s))
              (locals s)
              (push (- (top (pop (stack s)))
                       (top (stack s)))
                    (pop (pop (stack s))))
              (program s)))

(defun execute-IMUL (inst s)
  (declare (ignore inst))
  (make-state (+ 1 (pc s))
              (locals s)
              (push (* (top (pop (stack s)))
                       (top (stack s)))
                    (pop (pop (stack s))))
              (program s)))

(defun execute-GOTO (inst s)
  (make-state (+ (arg1 inst) (pc s))
              (locals s)
              (stack s)
              (program s)))

(defun execute-IFLE (inst s)
  (make-state (if (<= (top (stack s)) 0)
                  (+ (arg1 inst) (pc s))
                (+ 1 (pc s)))
              (locals s)
              (pop (stack s))
              (program s)))

(defun do-inst (inst s)
  (if (equal (op-code inst) 'ICONST)
      (execute-ICONST  inst s)
    (if (equal (op-code inst) 'ILOAD)
        (execute-ILOAD  inst s)
      (if (equal (op-code inst) 'ISTORE)
          (execute-ISTORE  inst s)
        (if (equal (op-code inst) 'IADD)
            (execute-IADD   inst s)
          (if (equal (op-code inst) 'ISUB)
              (execute-ISUB   inst s)
            (if (equal (op-code inst) 'IMUL)
                (execute-IMUL   inst s)
              (if (equal (op-code inst) 'GOTO)
                  (execute-GOTO   inst s)
                (if (equal (op-code inst) 'IFLE)
                    (execute-IFLE   inst s)
                  s)))))))))

(defun step (s)
     (do-inst (next-inst s) s))

(defun run (sched s)
     (if (endp sched)
         s
       (run (cdr sched) (step s))))

; ===========================================================================
; Now I present an example of an M1 program and its execution.

(defconst *ifact-program*
  ; Imagine compiling:
  ;  a = 1;
  ;  while (n > 0)
  ;    { a = n * a;
  ;      n = n-1;};
  ;  return a;

  '((ICONST 1)     ;;;  0
    (ISTORE 1)     ;;;  1 a = 1;
    (ILOAD 0)      ;;;  2 while         ; loop: pc=2
    (IFLE 10)      ;;;  3   (n > 0)
    (ILOAD 0)      ;;;  4   {
    (ILOAD 1)      ;;;  5
    (IMUL)         ;;;  6
    (ISTORE 1)     ;;;  7   a = n * a;
    (ILOAD 0)      ;;;  8
    (ICONST 1)     ;;;  9
    (ISUB)         ;;; 10
    (ISTORE 0)     ;;; 11   n = n-1;
    (GOTO -10)     ;;; 12   }            ; jump to loop
    (ILOAD 1)      ;;; 13
    (HALT)         ;;; 14  return a;
    ))

; You can just evaluate this test and get the answer shown.

(run
 '(0 0 0 0 0 0 0 0 0 0 ; 100 clock ticks
   0 0 0 0 0 0 0 0 0 0
   0 0 0 0 0 0 0 0 0 0
   0 0 0 0 0 0 0 0 0 0
   0 0 0 0 0 0 0 0 0 0
   0 0 0 0 0 0 0 0 0 0
   0 0 0 0 0 0 0 0 0 0
   0 0 0 0 0 0 0 0 0 0
   0 0 0 0 0 0 0 0 0 0
   0 0 0 0 0 0 0 0 0 0)
 (make-state
  0                    ; pc
  '(5 0)               ; locals: n=5, a=0
  nil                  ; stack
  *ifact-program*      ; our program, above
  ))

; ===========================================================================
; Now I make it easier to write schedules and write a schedule for ifact.

; Recall from Problem Set 1:

(defun app (x y)
  (if (endp x)
      y
    (cons (car x)
          (app (cdr x) y))))

(defun repeat (th n)
     (if (zp n)
         nil
       (cons th (repeat th (- n 1)))))

; So here is a function that returns a schedule suitable for executing ifact
; from the top of its loop at PC=2 through the HALT statement, assuming that
; the value of local variable 0 at the top of the loop is n:

(defun ifact-loop-sched (n)
  (if (zp n)
      (repeat 0 4)
    (app (repeat 0 11)
         (ifact-loop-sched (- n 1)))))

; This can be explained: to schedule the ifact program on n starting
; at the loop pc = 2: If n is 0, schedule 4 steps, namely the
; instructions at pcs 2, 3, 13, and 14, ending at the HALT.
; Otherwise, if n is not 0, schedule the 11 instructions at pcs 2
; through 12, ending back at pc = 2, and then schedule ifact for n-1.

; We then use this to say how to schedule a complete ifact computation,
; starting at pc = 0.

(defun ifact-sched (n)
  (app (repeat 0 2)
       (ifact-loop-sched n)))

; ===========================================================================
; Here is the ACL2 function for computing factorial directly:

(defun ! (n)
  (if (zp n)
      1
    (* n (! (- n 1)))))

; And here is a function that computes factorial by running M1:

(defun test-ifact (n)
   (top
    (stack
     (run (ifact-sched n)
          (make-state 0
                      (list n 0)
                      nil
                      *ifact-program*)))))

(test-ifact 5)

(test-ifact 7)

(test-ifact 100)

; This suggests a specification for ifact:

(equal (test-ifact 100) (! 100))