Implement till 3.22

ex-3_12-20.scm

@@ -0,0 +1,204 @@
+(load "util.scm")
+
+(display "\nex-3.12 - append!\n")
+
+(define (append x y)
+  (if (null? x)
+      y
+      (cons (car x) (append (cdr x) y))))
+
+(define (append! x y)
+  (set-cdr! (last-pair x) y)
+  x)
+
+(define (last-pair x)
+  (if (null? (cdr x))
+      x
+      (last-pair (cdr x))))
+
+(define x (list 'a 'b))
+(define y (list 'c 'd))
+(define z (append x y))
+
+(assert z '(a b c d))
+(assert (cdr x) '(b))
+(define w (append! x y))
+(assert w '(a b c d))
+(assert (cdr x) '(b c d))
+
+(display "\nex-3.13 - make cycle\n")
+
+(define (make-cycle x)
+  (set-cdr! (last-pair x) x)
+  x)
+
+(define z (make-cycle (list 'a 'b 'c)))
+
+(display "[see comment]\n")
+; infinite loop
+; (last-pair z)
+
+(display "\nex-3.14 - mystery\n")
+
+; reverse
+(define (mystery x)
+  (define (loop x y)
+    (if (null? x)
+        y
+        (let ((temp (cdr x)))
+          (set-cdr! x y)
+          (loop temp x))))
+  (loop x '()))
+
+(define v (list 'a 'b 'c 'd))
+(define w (mystery v))
+
+(display v) (newline)
+(display w) (newline)
+
+(display "\nex-3.15\n")
+
+(define x (list 'a 'b))
+(define z1 (cons x x))
+(define z2 (cons (list 'a 'b) (list 'a 'b)))
+
+(define (set-to-wow! x)
+  (set-car! (car x) 'wow)
+  x)
+
+(assert z1 '((a b) a b))
+(set-to-wow! z1)
+(assert z1 '((wow b) wow b))
+(set-to-wow! z2)
+(assert z2 '((wow b) a b))
+
+
+(display "\nex-3.16 - count pairs\n")
+
+(define (count-pairs x)
+  (if (not (pair? x))
+      0
+      (+ (count-pairs (car x))
+         (count-pairs (cdr x))
+         1)))
+
+(define l3 '(1 2 3))
+(assert (count-pairs l3) 3)
+
+(define l4 '(1 2 3))
+(set-car! l4 (last-pair l4))
+(assert (count-pairs l4) 4)
+
+(define l7p3 (cons 3 '()))
+(define l7p2 (cons l7p3 l7p3))
+(define l7p1 (cons l7p2 l7p2))
+(define l7 l7p1)
+(assert (count-pairs l7) 7)
+
+(define ln '(1 2 3))
+(set-car! (last-pair ln) ln)
+;(count-pairs ln)
+(display "[endless-loop]\n")
+
+
+(display "\nex-3.17 - count pairs improved\n")
+
+(define (count-pairs x)
+  (define visited '())
+  (define (count-pairs-iter x)
+    (if (or (not (pair? x))
+            (contains x visited))
+        0
+        (begin
+          (set! visited (cons x visited))
+          (+ (count-pairs-iter (car x))
+             (count-pairs-iter (cdr x))
+             1))))
+  (count-pairs-iter x))
+
+(assert (count-pairs l3) 3)
+(assert (count-pairs l4) 3)
+(assert (count-pairs l7) 3)
+(assert (count-pairs ln) 3)
+
+(display "\nex-3.18 - has cycle\n")
+
+(define x (list 'a 'b 'c))
+(define z (make-cycle (list 'a 'b 'c)))
+
+(define (has-cycle? x)
+  (define (iter x visited)
+    (cond
+      ((null? x) #f)
+      ((contains x visited) #t)
+      (else
+        (iter (cdr x) (cons x visited)))))
+  (iter x '()))
+
+(assert (has-cycle? x) #f)
+(assert (has-cycle? l3) #f)
+(assert (has-cycle? l4) #f)
+(assert (has-cycle? l7) #f)
+(assert (has-cycle? z) #t)
+
+; ln contains a cycle in the sense that it lead to an endless-loop for
+; count-pairs. However, this question tells us that the criterion for a cycle
+; is whether cdr leads to an endless-loop. Consequently, I would say it is
+; legit that we get #f here.
+(assert (has-cycle? ln) #f)
+
+(display "\nex-3.19 - has cycle with constant space\n")
+
+(define x (list 'a 'b 'c))
+
+(define (has-cycle? original-xs)
+  (define (find x xs)
+    (define (find-iter xs index)
+      (cond
+        ((null? xs) 'notfound)
+        ((eq? x (car xs)) index)
+        (else (find-iter (cdr xs) (inc index)))))
+    (find-iter xs 0))
+
+  (define (cycle-iter xs index)
+    (if (null? xs)
+      #f
+      (let ((find-index (find (car xs) original-xs)))
+        (if (or (eq? find-index 'notfound)
+                (= find-index index))
+          (cycle-iter (cdr xs) (inc index))
+          #t))))
+  (cycle-iter original-xs 0))
+
+(assert (has-cycle? l7) #f)
+(assert (has-cycle? z) #t)
+
+(display "\nex-3.20\n")
+
+(define (cons x y)
+  (define (set-x! v) (set! x v))
+  (define (set-y! v) (set! y v))
+  (define (dispatch m)
+    (cond ((eq? m 'car) x)
+          ((eq? m 'cdr) y)
+          ((eq? m 'set-car!) set-x!)
+          ((eq? m 'set-cdr!) set-y!)
+          (else (error "Undefined operation -- CONS" m))))
+  dispatch)
+
+(define (car z) (z 'car))
+(define (cdr z) (z 'cdr))
+
+(define (set-car! z new-value)
+  ((z 'set-car!) new-value)
+  z)
+
+(define (set-cdr! z new-value)
+  ((z 'set-cdr!) new-value)
+  z)
+
+(define x (cons 1 2))
+(define z (cons x x))
+(set-car! (cdr z) 17)
+(assert (car x) 17)
+