SICP/ex-5_20-22.scm

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

(display "\nex-5.20 - box-and-pointer\n")

(define x (cons 1 2))
(define y (list x x))

; | Index | 0 | 1 | 2 | 3 | 4 | 5 | 6 |
; |-------|---|---|---|---|---|---|---|
; |the-car|   | n1| p1| p1|   |   |   |
; |the-cdr|   | n2| p3| e0|   |   |   |

(display "[done]\n")

(display "\nex-5.21 - count-leaves\n")

(define (count-leaves tree)
  (cond ((null? tree) 0)
        ((not (pair? tree)) 1)
        (else (+ (count-leaves (car tree))
                 (count-leaves (cdr tree))))))

(define (not-pair? x) (not (pair? x)))

(define count-leaves-machine-rec
  (make-machine
    '(tree val n continue)
    (list (list 'cons cons) (list 'car car) (list 'cdr cdr)
          (list 'not-pair? not-pair?) (list 'null? null?)
          (list '+ +))
    '(controller
        (assign continue (label count-done))
      count-leaves
        (test (op null?) (reg tree))
        (branch (label null-case))
        (test (op not-pair?) (reg tree))
        (branch (label not-pair-case))
      left-sub
        (save continue)
        (save tree)
        (assign tree (op car) (reg tree))
        (assign continue (label right-sub))
        (goto (label count-leaves))
      right-sub               ; val contains count of left-tree
        (restore tree)
        (save val)
        (assign tree (op cdr) (reg tree))
        (assign continue (label after-count))
        (goto (label count-leaves))
      after-count             ; val contains count of right-tree
        (assign n (reg val))  ; n contains count of right-tree
        (restore val)         ; val now cointans count of left-tree
        (assign val (op +) (reg n) (reg val)) ; val contains count
        (restore continue)
        (goto (reg continue))
      null-case
        (assign val (const 0))
        (goto (reg continue))
      not-pair-case
        (assign val (const 1))
        (goto (reg continue))
      count-done)))

(define t '(1 (2 3 (4 5))))
(set-register-contents! count-leaves-machine-rec 'tree t)
(start count-leaves-machine-rec)
(assert (get-register-contents count-leaves-machine-rec 'val)
        (count-leaves t))

(define (count-leaves tree)
  (define (count-iter tree n)
    (cond ((null? tree) n)
          ((not (pair? tree)) (+ n 1))
          (else (count-iter (cdr tree)
                            (count-iter (car tree) n)))))
  (count-iter tree 0))

(define count-leaves-machine-iter
  (make-machine
    '(tree val continue)
    (list (list 'cons cons) (list 'car car) (list 'cdr cdr)
          (list 'not-pair? not-pair?) (list 'null? null?)
          (list '+ +))
    '(controller
        (assign val (const 0))
        (assign continue (label count-done))
      count-leaves
        (test (op null?) (reg tree))
        (branch (label null-case))
        (test (op not-pair?) (reg tree))
        (branch (label not-pair-case))
      count-left
        (save continue)
        (save tree)
        (assign tree (op car) (reg tree))
        (assign continue (label count-right))
        (goto (label count-leaves))
      count-right
        (restore tree)
        (restore continue)
        (assign tree (op cdr) (reg tree))
        (goto (label count-leaves))
      null-case
        (goto (reg continue))
      not-pair-case
        (assign val (op +) (reg val) (const 1))
        (goto (reg continue))
      count-done)))

(define t '(1 (2 3 (4 5))))
(set-register-contents! count-leaves-machine-iter 'tree t)
(start count-leaves-machine-iter)
(assert (get-register-contents count-leaves-machine-iter 'val)
        (count-leaves t))

(display "\nex-5.22 - append\n")

(define (append x y)
  (if (null? x)
      y
      (cons (car x) (append (cdr x) y))))

(define append-machine
  (make-machine
    '(x y z continue)
    (list (list 'cons cons) (list 'car car)
          (list 'cdr cdr) (list 'null? null?))
    '(controller
       (assign continue (label append-done))
      append-loop
       (test (op null?) (reg x))
       (branch (label base-case))
      append-rest
       (save continue)
       (save x)
       (assign x (op cdr) (reg x))
       (assign continue (label after-append))
       (goto (label append-loop))
      after-append
       (restore x)
       (restore continue)
       (assign x (op car) (reg x))
       (assign z (op cons) (reg x) (reg z))
       (goto (reg continue))
      base-case
       (assign z (reg y))
       (goto (reg continue))
      append-done)))

(set-register-contents! append-machine 'x '(1 2))
(set-register-contents! append-machine 'y '(3 4))
(start append-machine)
(assert (get-register-contents append-machine 'z) '(1 2 3 4))

(define append-bang-machine
  (make-machine
    '(x x-cdr y)
    (list (list 'set-cdr! set-cdr!) (list 'cdr cdr) (list 'null? null?))
    '(controller
       (save x)
       (assign x-cdr (op cdr) (reg x))
      last-pair-loop
       (test (op null?) (reg x-cdr))
       (branch (label last-pair))
       (assign x (op cdr) (reg x))
       (assign x-cdr (op cdr) (reg x))
       (goto (label last-pair-loop))
      last-pair
       (perform (op set-cdr!) (reg x) (reg y))
       (restore x)
      append-done)))

(define (append! x y)
  (set-cdr! (last-pair x) y)
  x)

(define (last-pair x)
  (if (null? (cdr x))
      x
      (last-pair (cdr x))))

(set-register-contents! append-bang-machine 'x '(1 2))
(set-register-contents! append-bang-machine 'y '(3 4))
(start append-bang-machine)
(assert (get-register-contents append-bang-machine 'x) '(1 2 3 4))