SICP/ex-5_01-06.scm

(load "util.scm")
(load "misc/sicp-regsim.scm")

(display "\nex-5.1 draw-factorial\n")

; See misc directory for drawing.

(display "[answered]\n")

(display "\nex-5.2 design-factorial\n")

(define factorial-machine
  (make-machine
    '(counter product n)
    (list (list '> >) (list '* *) (list '+ +))
    '(controller
       (assign product (const 1))
       (assign counter (const 1))
       test-counter
         (test (op >) (reg counter) (reg n))
         (branch (label factorial-done))
         (assign product (op *) (reg product) (reg counter))
         (assign counter (op +) (reg counter) (const 1))
         (goto (label test-counter))
      factorial-done)))

(set-register-contents! factorial-machine 'n 6)
(start factorial-machine)
(assert (get-register-contents factorial-machine 'product) 720)

(display "\nex-5.3 - sqrt-newton\n")

(define (good-enough? guess n)
  (< (abs (- (* guess guess) n)) 0.01))

(define (improve guess n)
  (average guess (/ n guess)))

(define (average a b)
  (/ (+ a b) 2))

(define (sqrt-newton n)
  (define (iter guess)
    (if (good-enough? guess n)
      guess
      (iter (improve guess n))))
  (iter 1.))

(define sqrt-machine
  (make-machine
    '(guess n)
    (list (list 'good-enough? good-enough?)
          (list 'improve improve))
    '(controller
       (assign guess (const 1.))
       iter
         (test (op good-enough?) (reg guess) (reg n))
         (branch (label sqrt-done))
         (assign guess (op improve) (reg guess) (reg n))
         (goto (label iter))
       sqrt-done)))

(set-register-contents! sqrt-machine 'n 2)
(start sqrt-machine)
(assert (get-register-contents sqrt-machine 'guess) (sqrt-newton 2))

(define sqrt-machine
  (make-machine
    '(guess n div_n_guess guess_error)
    (list (list '>= >=)
          (list '< <)
          (list 'abs abs)
          (list '- -)
          (list '* *)
          (list '/ /)
          (list '+ +))
    '(controller
       (assign guess (const 1.))
       iter
         ; good-enough?
         (assign guess_error (op *) (reg guess) (reg guess))
         (assign guess_error (op -) (reg guess_error) (reg n))
         (test (op >=) (reg guess_error) (const 0))
         (branch (label guess_error_positive))
         (assign guess_error (op *) (reg guess_error) (const -1))
         guess_error_positive
         (test (op <) (reg guess_error) (const 0.01))
         (branch (label sqrt-done))
         ; improve
         (assign div_n_guess (op /) (reg n) (reg guess))
         (assign guess (op +) (reg guess) (reg div_n_guess))
         (assign guess (op /) (reg guess) (const 2))
         (goto (label iter))
       sqrt-done)))

(set-register-contents! sqrt-machine 'n 2)
(start sqrt-machine)
(assert (get-register-contents sqrt-machine 'guess) (sqrt-newton 2))

(display "\nex-5.4 - expt\n")

(define (expt-rec b n)
  (if (= n 0)
      1
      (* b (expt b (- n 1)))))

(define expt-rec-machine
  (make-machine
    '(b n val continue)
    (list (list '* *) (list '- -) (list '= =))
    '(controller
      (assign continue (label expt-done))
      expt-loop
        (test (op =) (reg n) (const 0))
        (branch (label base-case))
        (save continue)
        (assign n (op -) (reg n) (const 1))
        (assign continue (label after-expt))
        (goto (label expt-loop))
      after-expt
        (restore continue)
        (assign val (op *) (reg b) (reg val))
        (goto (reg continue))
      base-case
        (assign val (const 1))
        (goto (reg continue))
      expt-done)))

(set-register-contents! expt-rec-machine 'b 3)
(set-register-contents! expt-rec-machine 'n 4)
(start expt-rec-machine)
(assert (get-register-contents expt-rec-machine 'val)
        (expt-rec 3 4))

(define (expt-iter b n)
  (define (expt-iter counter product)
    (if (= counter 0)
        product
        (expt-iter (- counter 1) (* b product))))
  (expt-iter n 1))

(define expt-iter-machine
  (make-machine
    '(b n counter product continue)
    (list (list '* *) (list '- -) (list '= =))
    '(controller
       (assign counter (reg n))
       (assign product (const 1))
      expt-loop
        (test (op =) (reg counter) (const 0))
        (branch (label expt-done))
        (assign counter (op -) (reg counter) (const 1))
        (assign product (op *) (reg b) (reg product))
        (goto (label expt-loop))
      expt-done)))

(set-register-contents! expt-iter-machine 'b 3)
(set-register-contents! expt-iter-machine 'n 4)
(start expt-iter-machine)
(assert (get-register-contents expt-iter-machine 'product)
        (expt-iter 3 4))

(display "\nex-5.5 - hand-simulate-fib\n")
(display "[answered]\n")

; begin
; n = 2 ; val = ? ; continue = fib-done
; stack = []

; fib-loop
; n = 1 ; val = ? ; continue = afterfib-n-1
; stack = [2, fib-done]

; fib-loop
; immediate-answer
; n = 1 ; val = 1 ; continue = afterfib-n-1
; stack = [2, fib-done]

; afterfib-n-1
; n = 0 ; val = 1 ; continue = afterfib-n-2
; stack = [1, fib-done]

; fib-loop
; n = 0 ; val = 0 ; continue = afterfib-n-2
; stack = [1, fib-done]

; afterfib-n-2
; n = 0 ; val = 1 ; continue = fib-done
; stack = []

; fib-done
; val = 1

(display "\nex-5.6 - slightly-improved-fib\n")

(define fib-machine
  (make-machine
    '(n val continue)
    (list (list '< <) (list '- -) (list '= +) (list '+ +))
    '(controller
        (assign continue (label fib-done))
      fib-loop
        (test (op <) (reg n) (const 2))
        (branch (label immediate-answer))
        ;; set up to compute Fib(n - 1)
        (save continue)
        (assign continue (label afterfib-n-1))
        (save n)                           ; save old value of n
        (assign n (op -) (reg n) (const 1)); clobber n to n - 1
        (goto (label fib-loop))            ; perform recursive call
      afterfib-n-1                         ; upon return, val contains Fib(n - 1)
        (restore n)
        ;(restore continue)                ; uneeded restore
        ;; set up to compute Fib(n - 2)
        (assign n (op -) (reg n) (const 2))
        ;(save continue)                   ; uneeded continue
        (assign continue (label afterfib-n-2))
        (save val)                         ; save Fib(n - 1)
        (goto (label fib-loop))
      afterfib-n-2                         ; upon return, val contains Fib(n - 2)
        (assign n (reg val))               ; n now contains Fib(n - 2)
        (restore val)                      ; val now contains Fib(n - 1)
        (assign val                        ;  Fib(n - 1) +  Fib(n - 2)
                (op +) (reg val) (reg n))
        (restore continue)
        (goto (reg continue))              ; return to caller, answer is in val
      immediate-answer
        (assign val (reg n))               ; base case:  Fib(n) = n
        (goto (reg continue))
      fib-done)))

(set-register-contents! fib-machine 'n 8)
(start fib-machine)
(assert (get-register-contents fib-machine 'val) 21)

; restore and save of continue in afterfib-n-1 is not needed
(display "[answered]\n")