]> git.rkrishnan.org Git - sicp.git/blob - src/sicp/ex3_23.rkt
rewrite `quote->cons' using `match'.
[sicp.git] / src / sicp / ex3_23.rkt
1 #lang r5rs
2
3 (define error display)
4
5 (define (front-ptr deque) (car deque))
6 (define (rear-ptr deque) (cdr deque))
7 (define (set-front-ptr! deque item) (set-car! deque item))
8 (define (set-rear-ptr! deque item) (set-cdr! deque item))
9
10 (define (empty-deque? deque) (null? (front-ptr deque)))
11
12 (define (make-deque) (cons '() '()))
13
14 (define (front-deque deque)
15   (if (empty-deque? deque)
16       (error "FRONT called with an empty deque" deque)
17       (car (front-ptr deque))))
18
19 (define (rear-deque deque)
20   (if (empty-deque? deque)
21       (error "REAR called with an empty deque" deque)
22       (car (rear-ptr deque))))
23
24 (define (make-cell item)
25   (cons item (cons '() '())))
26
27 (define (value cell)
28   (car cell))
29
30 (define (next-cell cell)
31   (car (cdr cell)))
32
33 (define (prev-cell cell)
34   (cdr (cdr cell)))
35
36 (define (set-next! cell pair)
37   (set-car! (cdr cell) pair))
38
39 (define (set-prev! cell pair)
40   (set-cdr! (cdr cell) pair))
41
42 (define (front-insert-deque! deque item)
43   (let ((new-pair (make-cell item)))
44     (cond 
45       ((empty-deque? deque)
46        (set-front-ptr! deque new-pair)
47        (set-rear-ptr! deque new-pair)
48        deque)
49       (else
50        (set-next! new-pair (front-ptr deque))
51        ;(set-cdr! (cdr (front-ptr deque)) new-pair)
52        (set-prev! (front-ptr deque) new-pair)
53        (set-front-ptr! deque new-pair)
54        deque))))
55
56 (define (rear-insert-deque! deque item)
57   (let ((new-pair (make-cell item)))
58     (cond
59       ((empty-deque? deque)
60        (set-front-ptr! deque new-pair)
61        (set-rear-ptr! deque new-pair)
62        deque)
63       (else
64        (set-prev! new-pair (rear-ptr deque))
65        ;(set-car! (cdr (rear-ptr deque)) new-pair)
66        (set-next! (rear-ptr deque) new-pair)
67        (set-rear-ptr! deque new-pair)
68        deque))))
69
70 (define (front-delete-deque! deque)
71   (cond
72     ((empty-deque? deque)
73      (error "DELETE! called with an empty deque"))
74     (else
75      (set-front-ptr! deque (car (cdr (front-ptr deque))))
76      deque)))
77      
78 (define (rear-delete-deque! deque)
79   (cond
80     ((empty-deque? deque)
81      (error "DELETE! called with an empty deque"))
82     (else
83      (set-rear-ptr! deque (prev-cell (rear-ptr deque)))
84      (set-next! (rear-ptr deque) '())
85      deque)))
86      
87
88 (define (print-deque queue)
89   (define (copy-queue q1)
90     (let ((q2 (make-deque)))
91       (set-front-ptr! q2 (front-ptr q1))
92       (set-rear-ptr! q2 (rear-ptr q1))
93       q2))
94   (let ((q (copy-queue queue)))
95     (if (not (empty-deque? q))
96         (begin
97           (display (front-deque q))
98           (display " ")
99           (print-deque (front-delete-deque! q))))))
100
101 #|
102 > (define q (make-deque))
103 > (front-insert-deque! q 'a)
104 (mcons (mcons 'a (mcons '() '())) (mcons 'a (mcons '() '())))
105 > (front-insert-deque! q 'b)
106 (mcons #0=(mcons 'b (mcons #1=(mcons 'a (mcons '() #0#)) '())) #1#)
107 > (front-insert-deque! q 'c)
108 (mcons
109  #0=(mcons 'c (mcons #1=(mcons 'b (mcons #2=(mcons 'a (mcons '() #1#)) #0#)) '()))
110  #2#)
111 > (print-deque q)
112 c b a 
113 > q
114 (mcons
115  #0=(mcons 'c (mcons #1=(mcons 'b (mcons #2=(mcons 'a (mcons '() #1#)) #0#)) '()))
116  #2#)
117 > (rear-delete-deque! q)
118 (mcons #0=(mcons 'c (mcons #1=(mcons 'b (mcons '() #0#)) '())) #1#)
119 > (print-deque q)
120 c b 
121 > (rear-insert-deque! q 'd)
122 (mcons
123  #0=(mcons 'c (mcons #1=(mcons 'b (mcons #2=(mcons 'd (mcons '() #1#)) #0#)) '()))
124  #2#)
125 > (print-deque q)
126 c b d 
127 > (front-insert-deque! q 'e)
128 (mcons
129  #0=(mcons
130      'e
131      (mcons
132       #1=(mcons
133           'c
134           (mcons #2=(mcons 'b (mcons #3=(mcons 'd (mcons '() #2#)) #1#)) #0#))
135       '()))
136  #3#)
137 > (print-deque q)
138 e c b d 
139 > (front-delete-deque! q)
140 (mcons
141  #0=(mcons
142      'c
143      (mcons
144       #1=(mcons 'b (mcons #2=(mcons 'd (mcons '() #1#)) #0#))
145       (mcons 'e (mcons #0# '()))))
146  #2#)
147 > (print-deque q)
148 c b d 
149
150 |#