1 | ; Copyright (c) 2012, Juergen Lorenz |
---|
2 | ; All rights reserved. |
---|
3 | ; |
---|
4 | ; Redistribution and use in source and binary forms, with or without |
---|
5 | ; modification, are permitted provided that the following conditions are |
---|
6 | ; met: |
---|
7 | ; |
---|
8 | ; Redistributions of source code must retain the above copyright |
---|
9 | ; notice, this list of conditions and the following disclaimer. |
---|
10 | ; |
---|
11 | ; Redistributions in binary form must reproduce the above copyright |
---|
12 | ; notice, this list of conditions and the following disclaimer in the |
---|
13 | ; documentation and/or other materials provided with the distribution. |
---|
14 | ; |
---|
15 | ; Neither the name of the author nor the names of its contributors may be |
---|
16 | ; used to endorse or promote products derived from this software without |
---|
17 | ; specific prior written permission. |
---|
18 | ; |
---|
19 | ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS |
---|
20 | ; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED |
---|
21 | ; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A |
---|
22 | ; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT |
---|
23 | ; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, |
---|
24 | ; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED |
---|
25 | ; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR |
---|
26 | ; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF |
---|
27 | ; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING |
---|
28 | ; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS |
---|
29 | ; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |
---|
30 | ; |
---|
31 | |
---|
32 | ; Author: Juergen Lorenz |
---|
33 | ; ju (at) jugilo (dot) de |
---|
34 | ; |
---|
35 | ; Last update: Aug 02, 2012 |
---|
36 | ; |
---|
37 | ;In this module, we'll implement tuples, a container structure like |
---|
38 | ;vectors, but with one important difference: The data in a tuple are |
---|
39 | ;encapsulated. That means, there are no state-changing routines like |
---|
40 | ;vector-set! so that the encapsulated data can not be changed, unless |
---|
41 | ;they are stored in a single (or a box). |
---|
42 | |
---|
43 | ;A single is a tuple storing one item only, but this item can be changed |
---|
44 | ;without changing the single itself. This way state-changing is |
---|
45 | ;resticted to the absolute necessity. |
---|
46 | |
---|
47 | ;There are three other special tuples, empty, couples and triples, which |
---|
48 | ;store what their names suggest. Note that with couples and empty you |
---|
49 | ;can do the same things as with lists (but without state changing, of |
---|
50 | ;course), albeit the access routines are named differently: couple-left |
---|
51 | ;and couple-right. |
---|
52 | |
---|
53 | (require-library contracts) |
---|
54 | |
---|
55 | (module %tuples |
---|
56 | (tuple tuple? tuple-length tuple-ref tuple-find |
---|
57 | tuple-map tuple-append list->tuple tuple->list tuple-for-each |
---|
58 | empty empty? single single? single-ref single-set! tuple-of? |
---|
59 | couple couple? couple-left couple-right triple triple? triple-left |
---|
60 | triple-middle triple-right tuple-left tuple-right tuple-copy) |
---|
61 | |
---|
62 | (import scheme |
---|
63 | (only chicken unless condition-case case-lambda define-inline |
---|
64 | open-output-string get-output-string) |
---|
65 | (only data-structures list-of?)) |
---|
66 | |
---|
67 | ;;; implementation and helpers |
---|
68 | ;;; must appear before interface, because some routines are inlined |
---|
69 | |
---|
70 | (define-inline (project n) |
---|
71 | (lambda args |
---|
72 | (list-ref args n))) |
---|
73 | |
---|
74 | (define (tuple-length tup) |
---|
75 | (tup (project 1))) |
---|
76 | |
---|
77 | (define (tuple-ref tup n) |
---|
78 | (tup (project (+ n 2)))) |
---|
79 | |
---|
80 | (define (tuple-left tup) |
---|
81 | (tup (project 2))) |
---|
82 | |
---|
83 | (define (tuple-right tup) |
---|
84 | (tup (project (+ (tuple-length tup) 1)))) |
---|
85 | |
---|
86 | (define (tuple? xpr) |
---|
87 | (and (procedure? xpr) |
---|
88 | (condition-case (eq? 'tuple (xpr (project 0))) |
---|
89 | ((exn) #f)))) |
---|
90 | |
---|
91 | (define (tuple-of? ok?) |
---|
92 | (lambda (x) |
---|
93 | (and (tuple? x) |
---|
94 | (let helper ((n (tuple-length x))) |
---|
95 | (if (zero? n) |
---|
96 | #t |
---|
97 | (and (ok? (tuple-ref x (- n 1))) (helper (- n 1)))))))) |
---|
98 | |
---|
99 | (define (tuple . args) |
---|
100 | (lambda (sel) |
---|
101 | (apply sel (cons 'tuple (cons (length args) args))))) |
---|
102 | |
---|
103 | (define (tuple-map fn tup) |
---|
104 | (let loop ((n (tuple-length tup)) (acc '())) |
---|
105 | (if (zero? n) |
---|
106 | (apply tuple acc) |
---|
107 | (loop (- n 1) (cons (fn (tuple-ref tup (- n 1))) acc))))) |
---|
108 | |
---|
109 | (define (tuple-append . tups) |
---|
110 | (lambda (sel) |
---|
111 | (apply sel (cons 'tuple |
---|
112 | (cons (apply + (map tuple-length tups)) |
---|
113 | (apply append (map tuple->list tups))))))) |
---|
114 | |
---|
115 | (define (tuple->list tup) |
---|
116 | (let loop ((n (tuple-length tup)) (acc '())) |
---|
117 | (if (zero? n) |
---|
118 | acc |
---|
119 | (loop (- n 1) (cons (tuple-ref tup (- n 1)) acc))))) |
---|
120 | |
---|
121 | (define (tuple-copy tup . intervall) |
---|
122 | (let ( |
---|
123 | (from (if (null? intervall) |
---|
124 | 0 |
---|
125 | (car intervall))) |
---|
126 | (upto (if (< (length intervall) 2) |
---|
127 | (tuple-length tup) |
---|
128 | (cadr intervall))) |
---|
129 | ) |
---|
130 | (let loop ((n upto) (acc '())) |
---|
131 | (if (= from n) |
---|
132 | (apply tuple acc) |
---|
133 | (loop (- n 1) (cons (tuple-ref tup (- n 1)) acc)))))) |
---|
134 | |
---|
135 | (define (tuple-find tup item compare?) |
---|
136 | (let ((len (tuple-length tup))) |
---|
137 | (if (zero? len) |
---|
138 | #f |
---|
139 | (let loop ((result 0)) |
---|
140 | (cond |
---|
141 | ((= result len) #f) |
---|
142 | ((compare? item (tuple-ref tup result)) result) |
---|
143 | (else (loop (+ result 1)))))))) |
---|
144 | |
---|
145 | (define (tuple-for-each proc tup) |
---|
146 | (let ((len (tuple-length tup))) |
---|
147 | (let loop ((n 0)) |
---|
148 | (unless (= n len) |
---|
149 | (proc (tuple-ref tup n)) |
---|
150 | (loop (+ n 1)))))) |
---|
151 | |
---|
152 | (define (list->tuple lst) |
---|
153 | (apply tuple lst)) |
---|
154 | |
---|
155 | ;;; empties are 0-tuples |
---|
156 | (define (empty) |
---|
157 | (tuple)) |
---|
158 | |
---|
159 | (define (empty? x) |
---|
160 | (and (tuple? x) (= (tuple-length x) 0))) |
---|
161 | |
---|
162 | ;;; singles as mutable 1-tuples |
---|
163 | (define (single? xpr) |
---|
164 | (and (procedure? xpr) |
---|
165 | (condition-case (eq? 'single (xpr (project 0))) |
---|
166 | ((exn) #f)))) |
---|
167 | |
---|
168 | (define (single xpr) |
---|
169 | (lambda (sel) |
---|
170 | (sel 'single xpr (lambda (new) (set! xpr new))))) |
---|
171 | |
---|
172 | ;;; query |
---|
173 | (define (single-ref sg) |
---|
174 | (sg (project 1))) |
---|
175 | |
---|
176 | ;;; command |
---|
177 | (define (single-set! sg arg) |
---|
178 | ((sg (project 2)) arg)) |
---|
179 | |
---|
180 | ;;; couples are tuples which store two items |
---|
181 | (define (couple? x) |
---|
182 | (and (tuple? x) (= (tuple-length x) 2))) |
---|
183 | |
---|
184 | (define (couple x y) |
---|
185 | (tuple 1 2)) |
---|
186 | |
---|
187 | (define (couple-left tup) |
---|
188 | (tuple-ref tup 0)) |
---|
189 | |
---|
190 | (define (couple-right tup) |
---|
191 | (tuple-ref tup 1)) |
---|
192 | |
---|
193 | ;;; triples are tuples which store three items |
---|
194 | (define (triple? x) |
---|
195 | (and (tuple? x) (= (tuple-length x) 3))) |
---|
196 | |
---|
197 | (define (triple x y z) |
---|
198 | (tuple x y z)) |
---|
199 | |
---|
200 | (define (triple-left tup) |
---|
201 | (tuple-ref tup 0)) |
---|
202 | |
---|
203 | (define (triple-middle tup) |
---|
204 | (tuple-ref tup 1)) |
---|
205 | |
---|
206 | (define (triple-right tup) |
---|
207 | (tuple-ref tup 2)) |
---|
208 | |
---|
209 | ) ; module %tuples |
---|
210 | |
---|
211 | (module tuples |
---|
212 | (tuples tuple tuple? tuple-of? tuple-length tuple-ref tuple-find |
---|
213 | tuple-map tuple-append list->tuple tuple->list tuple-for-each |
---|
214 | empty empty? single single? single-ref single-set! |
---|
215 | couple couple? couple-left couple-right triple triple? triple-left |
---|
216 | triple-middle triple-right tuple-left tuple-right tuple-copy) |
---|
217 | |
---|
218 | (import scheme |
---|
219 | contracts |
---|
220 | (prefix %tuples %) |
---|
221 | (only chicken unless condition-case case-lambda define-inline |
---|
222 | open-output-string get-output-string) |
---|
223 | (only data-structures list-of?)) |
---|
224 | |
---|
225 | ;;; implementation and helpers |
---|
226 | ;;; must appear before interface, because some routines are inlined |
---|
227 | |
---|
228 | (define-inline (cardinal? n) |
---|
229 | (and (integer? n) (exact? n) (not (negative? n)))) |
---|
230 | |
---|
231 | (define-inline (true? x) #t) |
---|
232 | |
---|
233 | ;;; predicates |
---|
234 | (define-with-contract (tuple? xpr) |
---|
235 | "checks if xpr evaluates to a tuple" |
---|
236 | (%tuple? xpr)) |
---|
237 | |
---|
238 | (define-with-contract (tuple-of? ok?) |
---|
239 | "checks, if each tuple item satisfies predicate ok?" |
---|
240 | (domain (procedure? ok?) |
---|
241 | "ok? is a one parameter predicate") |
---|
242 | (range (procedure? result) |
---|
243 | "result is a one parameter predicate") |
---|
244 | (%tuple-of? ok?)) |
---|
245 | |
---|
246 | ;;; constructors |
---|
247 | (define-with-contract (tuple . args) |
---|
248 | "tuple constructor" |
---|
249 | (domain (true? args)) |
---|
250 | (range (%tuple? result)) |
---|
251 | (apply %tuple args)) |
---|
252 | |
---|
253 | (define-with-contract (list->tuple lst) |
---|
254 | "transforms a list into a tuple" |
---|
255 | (domain (list? lst)) |
---|
256 | (range (%tuple? result)) |
---|
257 | (apply %tuple lst)) |
---|
258 | |
---|
259 | (define-with-contract (tuple-map fn tup) |
---|
260 | "constructs a new tuple by mapping each item of tup with function fn" |
---|
261 | (domain (%tuple? tup) |
---|
262 | (procedure? fn) |
---|
263 | "a one parameter function") |
---|
264 | (range (%tuple? result)) |
---|
265 | (%tuple-map fn tup)) |
---|
266 | |
---|
267 | (define-with-contract (tuple-append . tups) |
---|
268 | "constructs a new tuple by concatenating several others" |
---|
269 | (domain ((list-of? tuple?) tups)) |
---|
270 | (range (%tuple? result)) |
---|
271 | (apply %tuple-append tups)) |
---|
272 | |
---|
273 | (define-with-contract (tuple-copy tup . interval) |
---|
274 | "constructing a subtuple with tup data from interval" |
---|
275 | (domain (%tuple? tup) |
---|
276 | (<= (length interval) 2) |
---|
277 | ((list-of? cardinal?) interval) |
---|
278 | (apply <= (append interval (list (%tuple-length tup))))) |
---|
279 | (range (%tuple? result)) |
---|
280 | (apply %tuple-copy tup interval)) |
---|
281 | |
---|
282 | ;;; accessors |
---|
283 | (define-with-contract (tuple-length tup) |
---|
284 | "returns the number of tuple items" |
---|
285 | (domain (%tuple? tup)) |
---|
286 | (range (cardinal? result)) |
---|
287 | (%tuple-length tup)) |
---|
288 | |
---|
289 | (define-with-contract (tuple-ref tup n) |
---|
290 | "returns the n'th item of tup, counting from zero" |
---|
291 | (domain (%tuple? tup) (cardinal? n) (< n (%tuple-length tup))) |
---|
292 | (%tuple-ref tup n)) |
---|
293 | |
---|
294 | (define-with-contract (tuple-left tup) |
---|
295 | "returns the leftmost item of tup" |
---|
296 | (domain (%tuple? tup) (positive? (%tuple-length tup))) |
---|
297 | (%tuple-left tup)) |
---|
298 | |
---|
299 | (define-with-contract (tuple-right tup) |
---|
300 | "returns the rightmost item of tup" |
---|
301 | (domain (%tuple? tup) (>= (%tuple-length tup) 2)) |
---|
302 | (%tuple-right tup)) |
---|
303 | |
---|
304 | (define-with-contract (tuple-find tup item compare?) |
---|
305 | "checks by comparing with compare? if item is contained in tup" |
---|
306 | (domain (%tuple? tup) |
---|
307 | (procedure? compare?) |
---|
308 | "a two parameter predicate") |
---|
309 | (range (or (not result) |
---|
310 | (and (cardinal? result) (< result (%tuple-length tup))))) |
---|
311 | (%tuple-find tup item compare?)) |
---|
312 | |
---|
313 | (define-with-contract (tuple->list tup) |
---|
314 | "transforms a tuple into a list" |
---|
315 | (domain (%tuple? tup)) |
---|
316 | (range (list? result)) |
---|
317 | (%tuple->list tup)) |
---|
318 | |
---|
319 | (define-with-contract (tuple-for-each proc tup) |
---|
320 | "apply a one parameter procedure to each item of tup" |
---|
321 | (domain (%tuple? tup) |
---|
322 | (procedure? proc) |
---|
323 | "a one parameter procedure") |
---|
324 | (%tuple-for-each proc tup)) |
---|
325 | |
---|
326 | ;;; empty is the tuple which stores nothing |
---|
327 | (define-with-contract (empty? x) |
---|
328 | "tests for an empty tuple" |
---|
329 | (and (%tuple? x) (= (%tuple-length x) 0))) |
---|
330 | |
---|
331 | (define-with-contract (empty) |
---|
332 | "constructor for an empty tuple" |
---|
333 | (%tuple)) |
---|
334 | |
---|
335 | ;;; singles are tuples which store exactly one item. But without being |
---|
336 | ;;; able to modify this item, singles were useless. So we give an |
---|
337 | ;;; independent definition of its constructor. |
---|
338 | (define-with-contract (single? xpr) |
---|
339 | "check, if xpr evaluates to a single" |
---|
340 | (%single? xpr)) |
---|
341 | |
---|
342 | (define-with-contract (single xpr) |
---|
343 | "package xpr into a box so that it can be modified" |
---|
344 | (domain (true? xpr)) |
---|
345 | (range (%single? result)) |
---|
346 | (%single xpr)) |
---|
347 | |
---|
348 | ;;; query |
---|
349 | (define-with-contract (single-ref sg) |
---|
350 | "returns the state of the single object sg" |
---|
351 | (domain (%single? sg)) |
---|
352 | (%single-ref sg)) |
---|
353 | |
---|
354 | ;;; command |
---|
355 | (define-with-contract (single-set! sg arg) |
---|
356 | "replaces state of sg with arg" |
---|
357 | (domain (%single? sg) (true? arg)) |
---|
358 | (effect (state (%single-ref sg) arg)) |
---|
359 | (%single-set! sg arg)) |
---|
360 | |
---|
361 | ;;; couples are tuples which store two items |
---|
362 | (define-with-contract (couple? x) |
---|
363 | "tests for a tuple storing two items" |
---|
364 | (and (%tuple? x) (= (%tuple-length x) 2))) |
---|
365 | |
---|
366 | (define-with-contract (couple x y) |
---|
367 | "constructor for a tuple storing two items" |
---|
368 | (%tuple 1 2)) |
---|
369 | |
---|
370 | (define-with-contract (couple-left tup) |
---|
371 | "returns the left item of a couple" |
---|
372 | (%tuple-ref tup 0)) |
---|
373 | |
---|
374 | (define-with-contract (couple-right tup) |
---|
375 | "returns the right item of a couple" |
---|
376 | (%tuple-ref tup 1)) |
---|
377 | |
---|
378 | ;;; couples are tuples which store three items |
---|
379 | (define-with-contract (triple? x) |
---|
380 | "tests for a tuple storing two items" |
---|
381 | (and (%tuple? x) (= (%tuple-length x) 3))) |
---|
382 | |
---|
383 | (define-with-contract (triple x y z) |
---|
384 | "constructor for a tuple storing two items" |
---|
385 | (%tuple x y z)) |
---|
386 | |
---|
387 | (define-with-contract (triple-left tup) |
---|
388 | "returns the left item of a triple" |
---|
389 | (%tuple-ref tup 0)) |
---|
390 | |
---|
391 | (define-with-contract (triple-middle tup) |
---|
392 | "returns the middle item of a triple" |
---|
393 | (%tuple-ref tup 1)) |
---|
394 | |
---|
395 | (define-with-contract (triple-right tup) |
---|
396 | "returns the right item of a triple" |
---|
397 | (%tuple-ref tup 2)) |
---|
398 | |
---|
399 | ;;; documentation |
---|
400 | (define tuples (doclist->dispatcher (doclist))) |
---|
401 | |
---|
402 | ) ; module tuples |
---|
403 | |
---|