205 lines
4.2 KiB
Scheme
205 lines
4.2 KiB
Scheme
(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)
|
|
|