SICP/ex-5_20-22.scm

188 lines
5.3 KiB
Scheme
Raw Normal View History

2021-04-02 01:51:12 +02:00
(load "util.scm")
(load "misc/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)))
2021-04-02 18:11:38 +02:00
(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
2021-04-02 01:51:12 +02:00
(make-machine
'(tree val continue)
(list (list 'cons cons) (list 'car car) (list 'cdr cdr)
2021-04-02 18:11:38 +02:00
(list 'not-pair? not-pair?) (list 'null? null?)
(list '+ +))
2021-04-02 01:51:12 +02:00
'(controller
(assign val (const 0))
(assign continue (label count-done))
count-leaves
(test (op null?) (reg tree))
(branch (label null-case))
2021-04-02 18:11:38 +02:00
(test (op not-pair?) (reg tree))
2021-04-02 01:51:12 +02:00
(branch (label not-pair-case))
2021-04-02 18:11:38 +02:00
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))
2021-04-02 01:51:12 +02:00
null-case
2021-04-02 18:11:38 +02:00
(goto (reg continue))
2021-04-02 01:51:12 +02:00
not-pair-case
2021-04-02 18:11:38 +02:00
(assign val (op +) (reg val) (const 1))
2021-04-02 01:51:12 +02:00
(goto (reg continue))
count-done)))
2021-04-02 18:11:38 +02:00
(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))
2021-04-02 01:51:12 +02:00