source: project/release/4/tuples/trunk/tuples.scm @ 26086

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

single-state and single-state! renamed to single-ref and single-set!

File size: 10.5 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: Mar 07, 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 'contracts)
54
55(module tuples ;*
56  (tuples tuple tuple? tuple-of? 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!
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        contracts
64        (only chicken unless condition-case case-lambda define-inline
65          open-output-string get-output-string)
66        (only data-structures list-of?))
67
68;;; implementation and helpers
69;;; must appear before interface, because some routines are inlined
70
71(define-inline (cardinal? n)
72  (and (integer? n) (exact? n) (not (negative? n))))
73
74(define-inline (true? x) #t)
75
76(define-inline (project n)
77  (lambda args
78    (list-ref args n)))
79
80(define-inline (%tuple-length tup)
81  (tup (project 1)))
82
83(define-inline (%tuple-ref tup n)
84  (tup (project (+ n 2))))
85
86(define-inline (%tuple-left tup)
87  (tup (project 2)))
88
89(define-inline (%tuple-right tup)
90  (tup (project (+ (%tuple-length tup) 1))))
91
92(define-inline (%tuple-state sg)
93  (sg (project 1)))
94
95(define-inline (%tuple-state! sg arg)
96  ((sg (project 2)) arg))
97
98(define (%tuple? xpr)
99  (and (procedure? xpr)
100       (condition-case (eq? 'tuple (xpr (project 0)))
101         ((exn) #f))))
102
103(define (%tuple-of? ok?)
104  (lambda (x)
105    (and (%tuple? x)
106         (let helper ((n (%tuple-length x)))
107           (if (zero? n)
108             #t
109             (and (ok? (%tuple-ref x (- n 1))) (helper (- n 1))))))))
110
111(define (%tuple . args)
112  (lambda (sel)
113    (apply sel (cons 'tuple (cons (length args) args)))))
114
115(define (%tuple-map fn tup)
116  (let loop ((n (%tuple-length tup)) (acc '()))
117    (if (zero? n)
118      (apply %tuple acc)
119      (loop (- n 1) (cons (fn (%tuple-ref tup (- n 1))) acc)))))
120
121(define (%tuple-append . tups)
122  (lambda (sel)
123    (apply sel (cons 'tuple
124                     (cons (apply + (map %tuple-length tups))
125                           (apply append (map %tuple->list tups)))))))
126
127(define (%tuple->list tup)
128  (let loop ((n (%tuple-length tup)) (acc '()))
129    (if (zero? n)
130      acc
131      (loop (- n 1) (cons (%tuple-ref tup (- n 1)) acc)))))
132
133(define (%tuple-copy tup . intervall)
134  (let (
135    (from (if (null? intervall)
136            0
137            (car intervall)))
138    (upto (if (< (length intervall) 2)
139            (%tuple-length tup)
140            (cadr intervall)))
141    )
142    (let loop ((n upto) (acc '()))
143      (if (= from n)
144        (apply %tuple acc)
145        (loop (- n 1) (cons (%tuple-ref tup (- n 1)) acc))))))
146
147(define (%tuple-find tup item compare?)
148  (let ((len (%tuple-length tup)))
149    (if (zero? len)
150      #f
151      (let loop ((result 0))
152        (cond
153          ((= result len) #f)
154          ((compare? item (%tuple-ref tup result)) result)
155          (else (loop (+ result 1))))))))
156
157(define (%tuple-for-each proc tup)
158  (let ((len (%tuple-length tup)))
159    (let loop ((n 0))
160      (unless (= n len)
161        (proc (%tuple-ref tup n))
162        (loop (+ n 1))))))
163
164(define (%single? xpr)
165  (and (procedure? xpr)
166       (condition-case (eq? 'single (xpr (project 0)))
167         ((exn) #f))))
168
169(define (%single xpr)
170  (lambda (sel)
171    (sel 'single xpr (lambda (new) (set! xpr new)))))
172
173;; initialize documentation
174(doclist '())
175
176;;; iterface
177
178;;; general n-tuples
179
180;;; predicates
181(define-with-contract (tuple? xpr)
182  "checks if xpr evaluates to a tuple"
183  (%tuple? xpr))
184
185(define-with-contract (tuple-of? ok?)
186  "checks, if each tuple item satisfies predicate ok?"
187  (domain (procedure? ok?)
188           "ok? is a one parameter predicate")
189  (range (procedure? result)
190          "result is a one parameter predicate")
191  (%tuple-of? ok?))
192
193;;; constructors
194(define-with-contract (tuple . args)
195  "tuple constructor"
196  (domain (true? args))
197  (range (%tuple? result))
198  (apply %tuple args))
199
200(define-with-contract (list->tuple lst)
201  "transforms a list into a tuple"
202  (domain (list? lst))
203  (range (%tuple? result))
204  (apply %tuple lst))
205
206(define-with-contract (tuple-map fn tup)
207  "constructs a new tuple by mapping each item of tup with function fn"
208  (domain (%tuple? tup)
209           (procedure? fn)
210           "a one parameter function")
211  (range (%tuple? result))
212  (%tuple-map fn tup))
213
214(define-with-contract (tuple-append . tups)
215  "constructs a new tuple by concatenating several others"
216  (domain ((list-of? tuple?) tups))
217  (range (%tuple? result))
218  (apply %tuple-append tups))
219
220(define-with-contract (tuple-copy tup . interval)
221  "constructing a subtuple with tup data from interval"
222  (domain (%tuple? tup)
223           (<= (length interval) 2)
224           ((list-of? cardinal?) interval)
225           (apply <= (append interval (list (%tuple-length tup)))))
226  (range (%tuple? result))
227  (apply %tuple-copy tup interval))
228
229;;; accessors
230(define-with-contract (tuple-length tup)
231  "returns the number of tuple items"
232  (domain (%tuple? tup))
233  (range (cardinal? result))
234  (%tuple-length tup))
235
236(define-with-contract (tuple-ref tup n)
237  "returns the n'th item of tup, counting from zero"
238  (domain (%tuple? tup) (cardinal? n) (< n (%tuple-length tup)))
239  (%tuple-ref tup n))
240
241(define-with-contract (tuple-left tup)
242  "returns the leftmost item of tup"
243  (domain (%tuple? tup) (positive? (%tuple-length tup)))
244  (%tuple-left tup))
245
246(define-with-contract (tuple-right tup)
247  "returns the rightmost item of tup"
248  (domain (%tuple? tup) (>= (%tuple-length tup) 2))
249  (%tuple-right tup))
250
251(define-with-contract (tuple-find tup item compare?)
252  "checks by comparing with compare? if item is contained in tup"
253  (domain (%tuple? tup)
254           (procedure? compare?)
255           "a two parameter predicate")
256  (range (or (not result)
257              (and (cardinal? result) (< result (%tuple-length tup)))))
258  (%tuple-find tup item compare?))
259
260(define-with-contract (tuple->list tup)
261  "transforms a tuple into a list"
262  (domain (%tuple? tup))
263  (range (list? result))
264  (%tuple->list tup))
265
266(define-with-contract (tuple-for-each proc tup)
267  "apply a one parameter procedure to each item of tup"
268  (domain (%tuple? tup)
269           (procedure? proc)
270           "a one parameter procedure")
271  (%tuple-for-each proc tup))
272
273;;; empty is the tuple which stores nothing
274(define-with-contract (empty? x)
275  "tests for an empty tuple"
276  (and (%tuple? x) (= (%tuple-length x) 0)))
277
278(define-with-contract (empty)
279  "constructor for an empty tuple"
280  (%tuple))
281
282;;; singles are tuples which store exactly one item. But without being
283;;; able to modify this item, singles were useless. So we give an
284;;; independent definition of its constructor.
285(define-with-contract (single? xpr)
286  "check, if xpr evaluates to a single"
287  (%single? xpr))
288
289(define-with-contract (single xpr)
290  "package xpr into a box so that it can be modified"
291  (domain (true? xpr))
292  (range (%single? result))
293  (%single xpr))
294
295;;; query
296(define-with-contract (single-ref sg)
297  "returns the state of the single object sg"
298  (domain (%single? sg))
299  (%tuple-state sg))
300
301;;; command
302(define-with-contract (single-set! sg arg)
303  "replaces state of sg with arg"
304  (domain (%single? sg) (true? arg))
305  (effect (state (%tuple-state sg) arg))
306  (%tuple-state! sg arg))
307
308;;; couples are tuples which store two items
309(define-with-contract (couple? x)
310  "tests for a tuple storing two items"
311  (and (%tuple? x) (= (%tuple-length x) 2)))
312
313(define-with-contract (couple x y)
314  "constructor for a tuple storing two items"
315  (%tuple 1 2))
316
317(define-with-contract (couple-left tup)
318  "returns the left item of a couple"
319  (%tuple-ref tup 0))
320
321(define-with-contract (couple-right tup)
322  "returns the right item of a couple"
323  (%tuple-ref tup 1))
324
325;;; couples are tuples which store three items
326(define-with-contract (triple? x)
327  "tests for a tuple storing two items"
328  (and (%tuple? x) (= (%tuple-length x) 3)))
329
330(define-with-contract (triple x y z)
331  "constructor for a tuple storing two items"
332  (%tuple x y z))
333
334(define-with-contract (triple-left tup)
335  "returns the left item of a triple"
336  (%tuple-ref tup 0))
337
338(define-with-contract (triple-middle tup)
339  "returns the middle item of a triple"
340  (%tuple-ref tup 1))
341
342(define-with-contract (triple-right tup)
343  "returns the right item of a triple"
344  (%tuple-ref tup 2))
345
346;;; documentation
347(define tuples (doclist->dispatcher (doclist)))
348
349) ; module tuples
350
Note: See TracBrowser for help on using the repository browser.