source: project/release/4/tuples/tags/0.8/tuples.scm @ 27174

Last change on this file since 27174 was 27174, checked in by juergen, 9 years ago

version 0.8 with code split in two modules checked in

File size: 11.7 KB
Line 
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
Note: See TracBrowser for help on using the repository browser.