source: project/release/5/callable-sequences/trunk/callable-sequences.scm @ 38851

Last change on this file since 38851 was 38851, checked in by juergen, 3 months ago

callable-sequences-1.0.0 version

File size: 10.0 KB
Line 
1(module callable-sequences (
2  callable-sequences
3  make-sas-callable
4  make-ras-callable
5  make-callable
6  callable-sas?
7  callable-ras?
8  callable?
9  callable-length
10  callable-null?
11  callable-data
12  callable-reverse
13  )
14
15  (import scheme
16          (only (chicken base) atom? receive gensym print error case-lambda)
17          (only (chicken format) format)
18          (only (chicken condition) condition-case)
19          )
20
21;;; a variant of Mario's callable-lists
22;;; to be returned instead of lists in dotted-lambdas
23
24(define make-sas-callable 'make-sas-callable)
25(define callable-sas? 'callable-sas?)
26(define make-ras-callable 'make-ras-callable)
27(define callable-ras? 'callable-ras?)
28
29(let ((in (gensym 'in)) (sas (gensym 'sas)) (ras (gensym 'ras)))
30  (set! make-sas-callable
31    (lambda (seq seq-cons seq-car seq-cdr seq-null?)
32      (let maker ((seq seq))
33        (receive (nil len)
34          (let loop ((seq seq) (k 0))
35            (if (seq-null? seq)
36              (values seq k)
37              (loop (seq-cdr seq) (+ k 1))))
38          (case-lambda
39            (() (values seq len))
40            ((k)
41             (cond
42               ((and (integer? k) (>= k 0) (< k len))
43                (let loop ((seq seq) (n 0))
44                  (if (= n k)
45                    (seq-car seq)
46                    (loop (seq-cdr seq) (+ n 1)))))
47               ((and (symbol? k) (eq? k in))
48                sas)
49               (else
50                 (error 'make-sas-callable
51                        (format #f
52                                "k=~A is out of range for length=~A~%"
53                                k len)))))
54            ((k l)
55             (let ((revers (let loop ((seq seq) (revers nil))
56                             (if (seq-null? seq)
57                               revers
58                               (loop (seq-cdr seq)
59                                     (seq-cons (seq-car seq)
60                                               revers))))))
61               (cond
62                 ((and (integer? k) (integer? l)
63                       (>= k 0) (<= k l) (<= l len))
64                  (maker
65                    (let recur ((seq seq) (n 0))
66                      (cond
67                        ((= n l) nil)
68                        ((and (>= n k) (< n l))
69                         (seq-cons (seq-car seq) (recur (seq-cdr seq) (+ n 1))))
70                        (else
71                          (recur (seq-cdr seq) (+ n 1)))))
72                    ))
73                 ((and (integer? k) (not l) (>= k 0))
74                  ((maker seq) k len))
75                 ((and (integer? k) (integer? l)
76                       (>= l -1) (< l k) (< k len))
77                  ((maker revers) (- len k 1) (- len l 1)))
78                 ((and (not k) (integer? l) (>= l -1))
79                  ((maker revers) 0 (- len l 1)))
80                 (else
81                   (error 'make-sas-callable
82                          (format #f
83                                  "at least k=~A or l=~A is out of range for length=~A~%"
84                                  k l len)))))
85            ))))))
86  (set! callable-sas?
87    (lambda (xpr)
88      (and (procedure? xpr)
89           (eqv? (condition-case (xpr in)
90                   ((exn) #f))
91                 sas))))
92  (set! make-ras-callable
93    (lambda (seq make-seq seq-ref seq-set! seq-length)
94      (let maker ((seq seq))
95        (let ((len (seq-length seq)))
96          (case-lambda
97            (() (values seq len))
98            ((k)
99             (cond
100               ((and (integer? k) (>= k 0) (< k len))
101                (seq-ref seq k))
102               ((and (symbol? k) (eq? k in))
103                ras)
104               (else
105                 (error 'make-ras-callable
106                        (format #f
107                                "k=~A is out of range for length=~A~%"
108                                k len)))))
109            ((k l)
110             (cond
111               ((and (integer? k) (integer? l)
112                     (>= k 0) (<= k l) (<= l len))
113                (let ((result (make-seq (- l k))))
114                  (do ((n k (+ n 1)))
115                    ((= n l) (maker result))
116                    (seq-set! result (- n k) (seq-ref seq n))))) 
117               ((and (integer? k) (not l) (>= k 0))
118                ((maker seq) k len))
119               ((and (integer? k) (integer? l)
120                     (>= l -1) (< l k) (< k len))
121                (let ((result (make-seq (- k l))))
122                  (do ((n k (- n 1)))
123                    ((= n l) (maker result))
124                    (seq-set! result (- k n) (seq-ref seq n))))) 
125               ((and (not k) (integer? l) (>= l -1))
126                (let ((result (make-seq (- len l 1))))
127                  (do ((n (- len 1) (- n 1)))
128                    ((= n l) (maker result))
129                    (seq-set! result (- len n 1) (seq-ref seq n)))))
130               (else
131                 (error 'make-ras-callable
132                        (format #f
133                                "at least k=~A or l=~A is out of range for length=~A~%"
134                                k l len)))))
135            )))))
136  (set! callable-ras?
137    (lambda (xpr)
138      (and (procedure? xpr)
139           (eqv? (condition-case (xpr in)
140                   ((exn) #f))
141                 ras))))
142  )
143
144(define (any? xpr) #t)
145
146(define make-callable
147  (let* (
148    (standard-db
149      (list
150        (cons list?
151              (lambda (seq) (make-sas-callable seq
152                                               cons
153                                               car
154                                               cdr
155                                               null?)))
156        (cons vector?
157              (lambda (seq) (make-ras-callable seq
158                                               make-vector
159                                               vector-ref
160                                               vector-set!
161                                               vector-length)))
162        (cons string?
163              (lambda (seq) (make-ras-callable seq
164                                               make-string
165                                               string-ref
166                                               string-set!
167                                               string-length)))
168        (cons any?
169              (lambda (seq) (make-sas-callable seq
170                                               cons
171                                               car
172                                               cdr
173                                               atom?)))
174        ))
175    (db standard-db)
176    )
177    (case-lambda
178      (() ; reset database
179       (set! db standard-db)
180       db)
181      ((seq)
182       (let loop ((db db))
183         (if ((caar db) seq)
184           ((cdar db) seq)
185           (loop (cdr db)))))
186      ((seq? seq-maker?)
187       ;; add new sequence type before trailing catch all pair
188       (set! db
189         (let recur ((db db))
190           (if (null? (cdr db))
191             (list (cons seq? seq-maker?) (car db))
192             (cons (car db) (recur (cdr db))))))
193       db)
194      )))
195
196
197(define (callable? xpr)
198  (or (callable-sas? xpr)
199      (callable-ras? xpr)))
200
201(define (callable-length seq)
202  (call-with-values seq (lambda (a b) b)))
203
204(define (callable-data seq)
205  (call-with-values seq (lambda (a b) a)))
206
207(define (callable-null? xpr)
208  (and (callable? xpr) (zero? (callable-length xpr))))
209
210(define (callable-reverse seq)
211  ;(seq (- (callable-length seq) 1) -1))
212  (seq #f -1))
213
214;;; (callable-sequences sym ..)
215;;; -----------------------
216;;; documentation procedure
217(define callable-sequences
218  (let ((syms '(callables make-callable callable? callable-length)))
219    (case-lambda
220      (() syms)
221      ((sym)
222       (if (memq sym syms)
223         (case sym
224           ((make-sas-callable)
225            (print "  procedure:")
226            (print "  (make-sas-callable seq seq-cons seq-car seq-cdr seq-null?)")
227            (print "  returns a procedure with access to its")
228            (print "  sequential-access sequence argument, including slices"))
229           ((make-ras-callable)
230            (print "  procedure:")
231            (print "  (make-ras-callable seq make-seq seq-ref seq-set! seq-length)")
232            (print "  returns a procedure with access to its")
233            (print "  random-access sequence argument, including slices"))
234           ((make-callable)
235            (print "  generic procedure:")
236            (print "  (make-callable)")
237            (print "  (make-callable seq)")
238            (print "  (make-callable seq? seq-maker)")
239            (print "  the first resets the local database,")
240            (print "  the second returns a procedure with access")
241            (print "  to its sequence argument, including slices")
242            (print "  and the third inserts a new item to the local")
243            (print "  database in next to last position"))
244           ((callable-sas?)
245            (print "  procedure:")
246            (print "  type predicate for callable sequential-acces sequences"))
247           ((callable-ras?)
248            (print "  procedure:")
249            (print "  type predicate for callable random-acces sequences"))
250           ((callable?)
251            (print "  procedure:")
252            (print "  type predicate: either callable-sas? or callable-ras?"))
253           ((callable-null? xpr)
254            (print "  procedure:")
255            (print "  xpr is callable? and its data are empty"))
256           ((callable-length)
257            (print "  procedure:")
258            (print "  length of callable sequence"))
259           ((callable-data)
260            (print "  procedure:")
261            (print "  encapsulated data of callable sequence"))
262           ((callable-reverse)
263            (print "  procedure:")
264            (print "  reverse of callable sequence"))
265           ((callables sym ..)
266            (print "  procedure:")
267            (print "  documentation procedure"))
268           )
269         (print "not in list " sym ", chose one of " syms)))
270         )))
271) ; module
272
273;(import callable-sequences simple-tests)
274;(define vec (make-callable #(0 1 2 3 4 5)))
275;(define str (make-callable "012345"))
276;(define lst (make-callable '(0 1 2 3 4 5)))
277;(define pair (make-callable '(0 1 2 3 4 5 . 6)))
278;(make-callable boolean? identity)
Note: See TracBrowser for help on using the repository browser.