From c421911b3a84d8bf13696845e7ca681b3ed0cb2a Mon Sep 17 00:00:00 2001
From: Felix Martin <mail@felixm.de>
Date: Fri, 2 Apr 2021 12:11:38 -0400
Subject: [PATCH] Implement till 5.22

---
 ex-5_20-22.scm | 153 ++++++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 146 insertions(+), 7 deletions(-)

diff --git a/ex-5_20-22.scm b/ex-5_20-22.scm
index 7df114f..1a62545 100644
--- a/ex-5_20-22.scm
+++ b/ex-5_20-22.scm
@@ -23,26 +23,165 @@
 
 (define (not-pair? x) (not (pair? x)))
 
-(define count-leaves-machine
+(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 '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?))
+        (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)))
 
-(set-register-contents! count-leaves-machine 'tree '())
-(start count-leaves-machine)
-(assert (get-register-contents count-leaves-machine 'val) 0)
+(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))
 
-(display "\nex-5.22\n")