source: project/release/5/arrays/trunk/arrays.scm @ 37416

Last change on this file since 37416 was 37416, checked in by juergen, 21 months ago

arrays ported from chicken-4

File size: 50.1 KB
Line 
1#|[
2Author: Juergen Lorenz
3ju (at) jugilo (dot) de
4
5Copyright (c) 2014-2019, Juergen Lorenz
6All rights reserved.
7
8Redistribution and use in source and binary forms, with or without
9modification, are permitted provided that the following conditions are
10met:
11
12Redistributions of source code must retain the above copyright
13notice, this list of conditions and the following disclaimer.
14
15Redistributions in binary form must reproduce the above copyright
16notice, this list of conditions and the following disclaimer in the
17documentation and/or other materials provided with the distribution.
18
19Neither the name of the author nor the names of its contributors may be
20used to endorse or promote products derived from this software without
21specific prior written permission.
22
23THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
24IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
25TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
26PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
27HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
28SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
29TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
30PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
31LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
32NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
33SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
34]|#
35
36;;; Functional arrays are like vectors, insofar as they are mutable and
37;;; allow fast access to items stored at a particular position. Fast
38;;; here means O(log n).
39;;; Contrary to vectors functional arrays are unbounded, they can expand
40;;; and shrink as needed. Adding and removing at the end, i.e. pruning,
41;;; is cheap.  Moreover, arrays can be typed: adding and updating items
42;;; works only, if the item passes an item? predicate supplied with the
43;;; constructor.
44
45;;; In this implementation, a functional array is internally represented
46;;; by a procedure closed over a completely balanced tree which acts via
47;;; message passing.  To arrive at an index position simply devide the
48;;; position argument recursively by 2 until it reaches 1 and inspect
49;;; quotient and remainder: If the latter is zero, follow the left,
50;;; otherwise the right subtree.
51
52;;; Besides the operations like item, update! and add!, which operate
53;;; on individual indexes we need operations, which operate on the array
54;;; as a whole, like searching, copying or mapping. Of course, one could
55;;; use the individual operations looping along the range of indexes.
56;;; But this is slow, because if we had to go from index 365, say, to
57;;; 366, we had to repeat the whole path in the local search tree except
58;;; the last step.  To avoid this we maintain a local cursor which
59;;; allows to process the array by stepping successively along each tree
60;;; level in the correct order.
61
62;;; Since access, adding and removing is fast, arrays can ideally be
63;;; used to implement sets. For example, to remove an item, simply swap!
64;;; it to the end and prune! it. This doesn't work for arrays, since
65;;; they are ordered by its indices, but it doesn't harm sets, which are
66;;; unorderd.
67;;;
68;;; We'll separate the library into three modules. The first contains the
69;;; actual closure, named array-handler, which does all the dirty work.
70
71;;; The second is a record, which contains the array-handler as a field
72;;; as well as two index positions, from (included) and upto (excluded)
73;;; which allow fast subarray operations by simply sharing structure
74;;; as in the pointer arithmetic of C-arrays. But note, that updating a
75;;; subarray updates the original array as well. The same happens with
76;;; the standard list procedure list-tail (but not with subvectors,
77;;; which are freshly constructed).
78;;;
79;;; The third is the set implementation, a record as well, containing
80;;; the handler and an equality-predicate, from which an item-predicate
81;;; can be deduced. There is no point to consider ranges, since sets are
82;;; unordered.
83;;;
84
85(define-interface ARRAYS
86  (arrays array? array-null? make-array array list->array vector->array array-repeat
87   array-iterate array-iterate-while array-iterate-until array-copy
88   array->list array->vector array-cursor-start!  array-cursor-next!
89   array-cursor-item array-cursor-index array-cursor-finished?
90   array-cursor-goto! array-member array-at
91   array-memp array-memq  array-memv  array-first array-rest
92   array-last array-butlast array-add!  array-update!  array-prune!
93   array-apply array-reverse array-reverse! array-swap! array-length
94   array-range array-item array-split-at array-split-with
95   array-drop array-drop-while array-take array-take-while
96   array-append array-append!  array-map array-mappend array-handler
97   array-for-each array-filter array-equ?  array-equal?  array-eqv?
98   array-eq?  array-remp array-remove array-remq array-remv
99   array-remove-dups array-fold-left array-fold-right array-sorted?
100   array-sort!  array-zip array-zip array-unzip array-interpose
101   array-every?  array-some? 
102   array-in?  array-bind))
103
104(define-interface SETS
105   (array-sets set? set-handler set-equ? set-item? set list->set vector->set 
106    make-set set-iterate set-iterate-while set-iterate-until set-map
107    set->list set->vector set-in  set-count set-filter set-null?
108    set-for-each set-copy set-difference set-add! set-remove! set=
109    set>= set<= set-union set-intersection set-every? set-some? set-apply))
110
111(module array-handlers
112  (array-handlers array-handler? make-array-handler array-handler-repeat
113   array-handler-iterate array-handler-iterate-while
114   array-handler-iterate-until nary nary? assert*)
115
116  (import scheme
117          (only (chicken base)
118                define-inline case-lambda receive
119                define-values error gensym)
120          (only (chicken condition)
121                condition-case)
122          (only (chicken fixnum)
123                fx+ fx- fx< fx= fx>= fxshr fxshl fxmod))
124
125(define-syntax dispatch
126  (syntax-rules ()
127    ((_ proc0 proc1 ...)
128     (lambda (msg)
129       (case msg
130         ((proc0) proc0)
131         ((proc1) proc1)
132         ...)))))
133
134(define (any? xpr) #t)
135
136(define-syntax assert*
137  (syntax-rules ()
138    ((_ sym xpr)
139     (let ((tmp xpr))
140       (if tmp
141         tmp
142         (error sym "assertion failed" 'xpr))))
143    ((_ sym xpr . xprs)
144     (begin
145       (assert* sym xpr)
146       (assert* sym . xprs)))))
147
148;;; tree interface
149(define-inline (make-tree) (vector))
150(define-inline (make-leaf x) (vector x (vector) (vector)))
151(define-inline (top tree) (vector-ref tree 0))
152(define-inline (left tree) (vector-ref tree 1))
153(define-inline (right tree) (vector-ref tree 2))
154(define-inline (top! val tree) (vector-set! tree 0 val))
155(define-inline (left! val tree) (vector-set! tree 1 val))
156(define-inline (right! val tree) (vector-set! tree 2 val))
157
158(define-values (make-array-handler array-handler?)
159  (let ((type (gensym 'array))
160        (start (gensym 'start)))
161    (values
162      ;; constructor
163      (case-lambda
164        ((item?)
165         (let (
166           (item? item?)
167           (count 0) ; number of all items
168           (tree (make-tree)) ; actual data
169           ;; to be populated and accessed by cursor-next
170           (subtrees (vector))
171           ;; to access subtrees
172           (tree-index -1)
173           (cursor-index -1)
174           (cursor-item start)
175           (move
176             (lambda (k tr)
177               (let loop ((k (fxshr k 1))
178                          (rem (fxmod k 2))
179                          (tr tr))
180                 (if (fx= k 1)
181                   (values tr rem)
182                   (loop (fxshr k 1)
183                         (fxmod k 2)
184                         (if (fx= rem 0)
185                           ;; choose left subtree
186                           (left tr)
187                           ;; choose right subtree
188                           (right tr)))))))
189           )
190           (letrec (
191             (item
192               (lambda (k)
193                 (cond
194                   ((fx< k 0)
195                    (error 'array-item "out of range" k))
196                   ((fx>= k count)
197                    (error 'array-item "out of range" k count))
198                   ((fx= k 0) (top tree))
199                   (else
200                     (receive (tr rem) (move (fx+ k 1) tree)
201                       (if (fx= rem 0)
202                         ;; choose item of left subtree
203                         (top (left tr))
204                         ;; choose item of right subtree
205                         (top (right tr))))))))
206             (add!
207               (lambda (new)
208                 (let ((leaf (if (item? new)
209                               (make-leaf new)
210                               (error 'array-add! "wrong item type" new))))
211                   (set! count (fx+ count 1))
212                   (if (fx= count 1)
213                     (set! tree leaf)
214                     (receive (tr rem) (move count tree)
215                       (if (fx= rem 0)
216                         ;; insert left
217                         (left! leaf tr)
218                         ;; insert right
219                         (right! leaf tr)))))))
220             (prune!
221               (lambda ()
222                 (cond
223                   ((fx= count 0)
224                    (error 'array-prune! "can't prune empty array"))
225                   ((fx= count 1)
226                    ;; set state to null state
227                    (set! count 0)
228                    (set! tree (make-tree))
229                    (set! subtrees (vector))
230                    (set! tree-index -1)
231                    (set! cursor-index -1)
232                    (set! cursor-item start))
233                   (else
234                     (let ((last (fx- count 1)))
235                       (receive (tr rem) (move count tree)
236                         (if (fx= rem 0)
237                           ;; remove left leaf
238                           (left! (make-tree) tr)
239                           ;; remove right leaf
240                           (right! (make-tree) tr)))
241                       (set! count last))))))
242             (update!
243               (lambda (k new)
244                 (cond
245                   ;((fx< k 0)
246                   ; (error 'array-update! "out-of-range" k))
247                   ;((fx>= k count)
248                   ; (error 'array-update! "out-of-range" k))
249                   ; range check done outside handler
250                   ((item? new)
251                    (if (fx= k 0)
252                      (top! new tree)
253                      (receive (tr rem) (move (fx+ k 1) tree)
254                        (if (fx= rem 0)
255                          ;; update left item
256                          (top! new (left tr))
257                          ;; update right item
258                          (top! new (right tr))))))
259                   (else
260                     (error 'array-update! "wrong item type" new)))))
261             (cursor-finished?
262               (lambda ()
263                 (fx< cursor-index 0)))
264             (cursor-start!
265               (lambda ()
266                 (set! cursor-index -1)
267                 (set! cursor-item start)))
268             (cursor-next!
269               (lambda ()
270                 (cond
271                   ((fx= cursor-index -1)
272                    (set! subtrees (vector tree))
273                    (set! tree-index 0)
274                    (set! cursor-index 0)
275                    (set! cursor-item (top tree)))
276                   (else
277                     (set! tree-index (fx+ tree-index 1))
278                     (let ((vlen (vector-length subtrees)))
279                       (if (fx= tree-index vlen)
280                         (let ((trees (make-vector (fxshl vlen 1) start)))
281                         ;(let ((trees (make-vector (fxshl vlen 1) finish)))
282                           ;; populate new vector with left ...
283                           (do ((k 0 (fx+ k 1)))
284                             ((fx= k vlen))
285                             (vector-set! trees
286                                          k
287                                          (left (vector-ref subtrees k))))
288                           ;; ... and with right subtrees of old vector
289                           (do ((k 0 (fx+ k 1)))
290                             ((fx= k vlen))
291                             (vector-set! trees
292                                          (fx+ vlen k)
293                                          (right (vector-ref subtrees k))))
294                           ;; update trees and index
295                           (set! subtrees trees)
296                           (set! tree-index 0)))
297                       (cond
298                         ((fx= cursor-index (fx- count 1))
299                          (cursor-start!))
300                         (else
301                           (set! cursor-index (fx+ cursor-index 1))
302                           (set! cursor-item
303                                 (top (vector-ref subtrees
304                                                  tree-index)))))
305                       )))))
306                 )
307                 (dispatch
308                   type
309                   item?
310                   count
311                   item
312                   add!
313                   update!
314                   prune!
315                   cursor-item
316                   cursor-index
317                   cursor-start!
318                   cursor-next!
319                   cursor-finished?
320                   ))))
321        (() (make-array-handler any?)))
322      ;; predicate
323      (lambda (xpr)
324        (and (procedure? xpr)
325             (condition-case (eq? (xpr 'type) type)
326               ((exn) #f)))))))
327
328;;; other constructors
329(define array-handler-repeat
330  (case-lambda
331    ((item? cnt item)
332     (let ((result (make-array-handler item?)))
333       (do ((k 0 (fx+ k 1)))
334         ((fx= k cnt) result)
335         ((result 'add!) item))))
336    ((cnt item)
337     (array-handler-repeat any? cnt item))))
338
339(define array-handler-iterate
340  (case-lambda
341    ((item? cnt fn start)
342     (let ((result (make-array-handler item?)))
343       (do ((k 0 (fx+ k 1)) (item start (fn item)))
344         ((fx= k cnt) result)
345         ((result 'add!) item))))
346    ((cnt fn start)
347     (array-handler-iterate any? cnt fn start))))
348
349(define array-handler-iterate-while
350  (case-lambda
351    ((item? ok? fn start)
352     (let ((result (make-array-handler item?)))
353       (do ((k 0 (fx+ k 1)) (item start (fn item)))
354         ((not (ok? item)) result)
355         ((result 'add!) item))))
356    ((ok? fn start)
357     (array-handler-iterate-while any? ok? fn start))))
358
359(define array-handler-iterate-until
360  (case-lambda
361    ((item? ok? fn start)
362     (let ((result (make-array-handler item?)))
363       (do ((k 0 (fx+ k 1)) (item start (fn item)))
364         ((ok? item) result)
365         ((result 'add!) item))))
366    ((ok? fn start)
367     (array-handler-iterate-until any? ok? fn start))))
368
369(define (array-handler-messages)
370  '(type item?  count item add! update! prune! cursor-item cursor-index cursor-start! cursor-next! cursor-finished?))
371
372;;; making binary comparisons nary
373(define (nary? bincmp?)
374  (lambda args
375    (let loop ((args args))
376      (cond
377        ((null? args) #t)
378        ((null? (cdr args)) #t)
379        (else
380          (and (bincmp? (car args) (cadr args))
381               (loop (cdr args))))))))
382
383;;; making binary operators nary
384(define (nary binop)
385  (lambda (arg . args)
386      (if (null? args)
387        arg
388        (apply (nary binop) (binop arg (car args)) (cdr args)))))
389
390;;; documentation
391(define array-handlers
392  (let (
393    (signatures '(
394      (array-handler? xpr)
395      (make-array-handler [item?])
396      (array-handler-repeat [item?] cnt item)
397      (array-handler-iterate [item?] cnt fn start)
398      (array-handler-iterate-while [item?] ok? fn start)
399      (array-handler-iterate-until [item?] ok? fn start)
400      (array-handler-messages)
401      (nary binop)
402      (nary? bincmp?)
403      (assert* loc . xprs)
404      ))
405    )
406    (case-lambda
407      (() (map car signatures))
408      ((sym) (assq sym signatures)))))
409) ; module array-handlers
410
411(module arrays ARRAYS
412  (import scheme
413          array-handlers
414          (only (chicken base)
415                o list-of? case-lambda receive
416                define-record-type define-record-printer
417                when unless cut error void)
418          (only (chicken condition)
419                condition-case)
420          (only (chicken fixnum)
421                fxeven? fx+ fx- fx< fx= fx>= fx<= fxshr))
422  (import-for-syntax (only (chicken base) receive))
423
424(define (any? xpr) #t)
425
426(define-record-type array
427  (array-maker handler from upto) ; internal
428  array?
429  (handler array-handler)
430  (from array-from array-from-set!) ; internal
431  (upto array-upto array-upto-set!)) ; internal
432
433(define-record-printer (array arr out)
434  (display "@" out)
435  (display (array->list arr) out)
436  (newline out))
437
438(define make-array ; exported
439  (case-lambda
440    ((item?)
441     (let ((handler (make-array-handler item?)))
442       (array-maker handler 0 (handler 'count))))
443    (()
444     (make-array any?))))
445
446(define (array-item? arr)
447  ((array-handler arr) 'item?))
448
449(define (array-count arr)
450  ((array-handler arr) 'count))
451
452(define (array-length arr)
453  (fx- (array-upto arr) (array-from arr)))
454
455(define (array-null? arr)
456  (fx= (array-length arr) 0))
457
458(define (array-add! item arr)
459  (assert* 'array-add!
460           (fx= (array-count arr)
461                (array-upto arr)))
462  (((array-handler arr) 'add!) item)
463  (array-upto-set! arr (fx+ (array-upto arr) 1)))
464 
465(define (array-prune! arr)
466  (assert* 'array-prune!
467           (fx= (array-count arr)
468                (array-upto arr)))
469  (((array-handler arr) 'prune!))
470  (array-upto-set! arr (fx- (array-upto arr) 1)))
471
472(define (array-item k arr)
473  (assert* 'array-item
474           (fx<= 0 k) (fx< k (array-length arr)))
475    (((array-handler arr) 'item) (fx+ k (array-from arr))))
476
477(define (array-at k arr) (array-item k arr))
478
479(define (array-update! k item arr)
480  (assert* 'array-update!
481           (fx<= 0 k) (fx< k (array-length arr)))
482    (((array-handler arr) 'update!) (fx+ k (array-from arr)) item))
483
484;;; cursor routines
485(define (array-cursor-item arr)
486  ((array-handler arr) 'cursor-item))
487
488(define (array-cursor-index arr)
489  ((array-handler arr) 'cursor-index))
490
491(define (array-cursor-finished? arr)
492  (fx< (array-cursor-index arr) (array-from arr)))
493
494(define (array-cursor-start! arr)
495  (let ((from (array-from arr)))
496    (((array-handler arr) 'cursor-start!))
497    (do ((k 0 (fx+ k 1)))
498      ((fx= k from))
499      (((array-handler arr) 'cursor-next!)))))
500
501(define (array-cursor-next! arr)
502  (if (fx= (array-cursor-index arr)
503           (fx- (array-upto arr) 1))
504    (array-cursor-start! arr)
505    (((array-handler arr) 'cursor-next!))))
506
507(define (array-cursor-goto! ok? arr)
508  (array-cursor-next! arr)
509  (do ()
510    ((or (fx< (array-cursor-index arr)
511              (array-from arr))
512         (ok? (array-cursor-item arr))))
513    (array-cursor-next! arr)))
514
515(define (array-memp ok? arr)
516  (array-cursor-start! arr)
517  (array-cursor-goto! ok? arr)
518  (if (array-cursor-finished? arr)
519    #f
520    (array-drop (array-cursor-index arr) arr)))
521
522(define (array-memq x arr)
523  (array-memp (cut eq? <> x) arr))
524
525(define (array-memv x arr)
526  (array-memp (cut eqv? <> x) arr))
527
528(define (array-member x arr)
529  (array-memp (cut equal? <> x) arr))
530
531;;; constructors
532(define array-repeat
533  (case-lambda
534    ((item? cnt item)
535     (array-maker (array-handler-repeat item? cnt item) 0 cnt))
536    ((cnt item)
537     (array-repeat any? cnt item))))
538
539(define array-iterate
540  (case-lambda
541    ((item? cnt fn start)
542     (array-maker (array-handler-iterate item? cnt fn start) 0 cnt))
543    ((cnt fn start)
544     (array-iterate any? cnt fn start))))
545
546(define array-iterate-while
547  (case-lambda
548    ((item? ok? fn start)
549     (let ((handler (array-handler-iterate-while item? ok? fn start)))
550       (array-maker handler 0 (handler 'count))))
551    ((ok? fn start)
552     (array-iterate-while any? ok? fn start))))
553
554(define array-iterate-until
555  (case-lambda
556    ((item? ok? fn start)
557     (let ((handler (array-handler-iterate-until item? ok? fn start)))
558       (array-maker handler 0 (handler 'count))))
559    ((ok? fn start)
560     (array-iterate-until any? ok? fn start))))
561
562(define (array-range from upto arr)
563  (assert* 'array-range
564           ((nary? fx<=) 0 from upto (array-length arr)))
565  (let ((old-from (array-from arr))
566        (old-upto (array-upto arr)))
567    (let* ((new-from (fx+ old-from from))
568           (new-upto (fx+ new-from (fx- upto from))))
569      (if ((nary? fx<=) 0 new-from new-upto (array-count arr))
570        (array-maker (array-handler arr) new-from new-upto)
571        (error 'array-range "out of range" new-from new-upto)))))
572
573(define (array-first arr)
574  (array-item 0 arr))
575
576(define (array-rest arr)
577  (array-range 1 (array-length arr) arr))
578
579(define (array-last arr)
580  (array-item (fx- (array-length arr) 1) arr))
581
582(define (array-butlast arr)
583  (array-range 0 (fx- (array-length arr) 1) arr))
584
585(define list->array
586  (case-lambda
587    ((item? lst)
588     (let ((result (make-array item?)))
589       (do ((lst lst (cdr lst)))
590         ((null? lst) result)
591         (array-add! (car lst) result))))
592    ((lst)
593     (list->array any? lst))))
594
595(define vector->array
596  (case-lambda
597    ((item? vec)
598     (let ((result (make-array item?)))
599       (do ((k 0 (fx+ k 1)))
600         ((fx= k (vector-length vec)) result)
601         (array-add! (vector-ref vec k) result))))
602    ((vec)
603     (vector->array any? vec))))
604
605(define (array arg/item? . args)
606  (assert* 'array (if (procedure? arg/item?)
607                    (not (null? args))
608                    #t))
609    (if (and (procedure? arg/item?)
610             (condition-case (arg/item? (car args))
611               ((exn) #f)))
612      (list->array arg/item? args)
613      (list->array any? (cons arg/item? args))))
614
615(define (array->list arr)
616  (array-cursor-start! arr)
617  (let loop ((lst '()))
618    (array-cursor-next! arr)
619    (if (array-cursor-finished? arr)
620      (reverse lst)
621      (loop (cons (array-cursor-item arr) lst)))))
622
623(define (array->vector arr)
624  (let ((from (array-from arr))
625        (result (make-vector (array-length arr) #f)))
626    (array-cursor-start! arr)
627    (let loop ()
628      (array-cursor-next! arr)
629      (cond
630        ((array-cursor-finished? arr)
631         result)
632        (else
633          (vector-set! result
634                       (fx- (array-cursor-index arr) from)
635                       (array-cursor-item arr))
636          (loop))))))
637
638(define (array-copy arr)
639  (let ((result (make-array (array-item? arr))))
640    (array-cursor-start! arr)
641    (let loop ()
642      (array-cursor-next! arr)
643      (cond
644        ((array-cursor-finished? arr)
645         result)
646        (else
647          (array-add! (array-cursor-item arr) result)
648          (loop))))))
649
650(define (array-for-each proc . arrs)
651  (assert* 'array-for-each
652           ((list-of? array?) arrs) (procedure? proc))
653  (for-each array-cursor-start! arrs)
654  (let loop ()
655    (for-each array-cursor-next! arrs)
656    (unless (memq #t (map array-cursor-finished? arrs))
657      (apply proc (map array-cursor-item arrs))
658      (loop))))
659
660(define (array-map fn/item? arr/fn . arrs)
661  (assert* 'array-map (procedure? fn/item?)
662           (or (procedure? arr/fn) (array? arr/fn))
663           ((list-of? array?) arrs))
664  (let ((acheck? (array? arr/fn)))
665    (let ((item? (if acheck? any? fn/item?))
666          (fn (if acheck? fn/item? arr/fn))
667          (arrs (if acheck? (cons arr/fn arrs) arrs)))
668      (let ((result (make-array item?)))
669        (for-each array-cursor-start! arrs)
670        (let loop ()
671          (for-each array-cursor-next! arrs)
672          (cond
673            ((memq #t (map array-cursor-finished? arrs))
674             result)
675            (else
676              (array-add! (apply fn (map array-cursor-item arrs))
677                          result)
678              (loop))))))))
679
680(define (array-mappend fn . arrs)
681  (array-apply array-append
682               (apply array-map fn arrs)))
683
684(define (array-append . arrs)
685  (assert* 'array-append
686           ((list-of? array?) arrs)
687           (apply (nary? eq?) (map array-item? arrs))
688           (not (null? arrs)))
689  (cond
690    ((null? (cdr arrs))
691     (car arrs))
692    ((null? (cddr arrs))
693     (let ((arr0 (car arrs)) (arr1 (cadr arrs)))
694       (let ((result (array-copy arr0)))
695         (array-cursor-start! arr1)
696         (let loop ()
697           (array-cursor-next! arr1)
698           (cond
699             ((array-cursor-finished? arr1)
700              result)
701             (else
702               (array-add! (array-cursor-item arr1) result)
703               (loop)))))))
704    (else
705      (array-append (car arrs)
706                    (apply array-append (cdr arrs))))))
707
708(define (array-append! . arrs)
709  (assert* 'array-append!
710           ((list-of? array?) arrs)
711           (apply (nary? eq?) (map array-item? arrs)))
712  (cond
713    ((null? arrs)
714     (void))
715    ((null? (cdr arrs))
716     (void))
717    ((null? (cddr arrs))
718     (let ((arr0 (car arrs)) (arr1 (cadr arrs)))
719       (array-cursor-start! arr1)
720       (let loop ()
721         (array-cursor-next! arr1)
722         (unless (array-cursor-finished? arr1)
723           (array-add! (array-cursor-item arr1) arr0)
724           (loop)))))
725    (else
726      (for-each (lambda (arr) (array-append! (car arrs) arr))
727                (cdr arrs)))))
728
729(define (array-swap! k l arr)
730  (let ((len (array-length arr)))
731    (cond
732      ((fx< k 0)
733       (error 'array-swap! "out of range" k))
734      ((fx>= k len)
735       (error 'array-swap! "out of range" k))
736      ((fx< l 0)
737       (error 'array-swap! "out of range" l))
738      ((fx>= l len)
739       (error 'array-swap! "out of range" l))
740      (else
741        (let ((x (array-item k arr)))
742          (array-update! k (array-item l arr) arr)
743          (array-update! l x arr))))))
744
745(define (array-reverse! arr)
746  (let ((len (array-length arr)))
747    (do ((m 0 (fx+ m 1)) (n (fx- len 1) (fx- n 1)))
748      ((fx= m (fxshr len 1)))
749      (array-swap! m n arr))))
750
751(define (array-reverse arr)
752  (let ((result (make-array (array-item? arr))))
753    (do ((arr arr (array-butlast arr)))
754      ((array-null? arr) result)
755      (array-add! (array-last arr) result))))
756
757(define (array-split-at k arr)
758  (assert* 'array-split-at
759           (array? arr)
760           (fx<= 0 k) (fx<= k (array-length arr)))
761  (values (array-range 0 k arr)
762          (array-range k (array-length arr) arr)))
763
764(define (array-take k arr)
765  (array-range 0 k arr))
766
767(define (array-drop k arr)
768  (array-range k (array-length arr) arr))
769
770(define (array-split-with ok? arr)
771  (array-cursor-start! arr)
772  (array-cursor-goto! (o not ok?) arr)
773  (array-split-at (array-cursor-index arr) arr))
774;
775(define (array-take-while ok? arr)
776  (call-with-values
777    (lambda () (array-split-with ok? arr))
778    (lambda (head tail) head)))
779
780(define (array-drop-while ok? arr)
781  (call-with-values
782    (lambda () (array-split-with ok? arr))
783    (lambda (head tail) tail)))
784
785;(define (array-fold-left op base . arrs) ; ok
786;  (let loop ((result base))
787;    (cond
788;      ;; all null
789;      ((apply (nary? eq?) #t (map array-null? arrs))
790;       result)
791;      ;; all not null
792;      ((apply (nary? eq?) #f (map array-null? arrs))
793;       (loop (map array-rest arrs)
794;             (apply op result (map array-first arrs))))
795;       (else
796;         (error 'array-fold-right "not of equal length" arrs)))))
797(define (array-fold-left op base . arrs)
798  (for-each array-cursor-start! arrs)
799  (let loop ((result base))
800    (for-each array-cursor-next! arrs)
801    (cond
802      ;; all null
803      ((apply (nary? eq?) #t (map array-cursor-finished? arrs))
804       result)
805      ;; all not null
806      ((apply (nary? eq?) #f (map array-cursor-finished? arrs))
807       (loop (apply op result (map array-cursor-item arrs))))
808      (else
809        (error 'array-fold-left "not of equal length" arrs)))))
810
811;(define (array-fold-right op base . arrs) ; ok
812;  (let loop ((result base))
813;    (cond
814;      ;; all null
815;      ((apply (nary? eq?) #t (map array-null? arrs))
816;       result)
817;      ;; all not null
818;      ((apply (nary? eq?) #f (map array-null? arrs))
819;       (loop (map array-butlast arrs)
820;             (apply op (append (map array-last arrs) (list result)))))
821;      (else
822;        (error 'array-fold-right "not of equal length" arrs)))))
823(define (array-fold-right op base . arrs)
824  (for-each array-cursor-start! arrs)
825  (let loop ()
826    (for-each array-cursor-next! arrs)
827    (cond
828      ;; all null
829      ((apply (nary? eq?) #t (map array-cursor-finished? arrs))
830       base)
831      ;; all not null
832      ((apply (nary? eq?) #f (map array-cursor-finished? arrs))
833       (apply op
834              (append (map array-cursor-item arrs)
835                      (list (loop)))))
836      (else
837        (error 'array-fold-right "not of equal length" arrs)))))
838
839(define (array-sorted? <? arr)
840  (array-cursor-start! arr)
841  (let loop ()
842    (array-cursor-next! arr)
843    (array-cursor-next! arr)
844    (if (array-cursor-finished? arr)
845      #t
846      (let ((item0 (array-cursor-item arr))
847            (item1 (begin (array-cursor-next! arr)
848                          (array-cursor-item arr))))
849        (if (<? item0 item1)
850          (loop)
851          #f)))))
852
853;;; a combination of quick sort and insertion sort
854(define (array-sort! <? arr)
855  (let recur ((l 0) (r (array-length arr)))
856    (cond
857      ((fx< (fx- r l) 2)
858       ;; nothing to do
859       (void))
860      ((fx< (fx- r l) 10)
861       ;; insertion sort
862       (do ((m (fx+ l 1) (fx+ m 1)))
863         ((fx= m r))
864          (let ((item (array-item m arr)))
865            (do ((k (fx- m 1) (fx- k 1)))
866              ((or (fx< k l) (<? (array-item k arr) item))
867               (array-update! (fx+ k 1) item arr))
868              (array-update! (fx+ k 1) (array-item k arr) arr)))))
869      (else
870        ;; quick sort with median-of-three pivot
871        (let ((m (fxshr r 1)) (r- (fx- r 1)))
872          (if (<? (array-item m arr) (array-item l arr))
873            (array-swap! l m arr))
874          (if (<? (array-item r- arr) (array-item l arr))
875            (array-swap! l r- arr))
876          (if (<? (array-item r- arr) (array-item m arr))
877            (array-swap! m r- arr))
878          ;; now the median of the tree resides in position m
879          ;; swap it to the left and use it as pivot
880          (array-swap! l m arr)
881          ;; partition
882          (let ((rh r-)
883                (lh (fx+ l 1))
884                (boundary l)
885                (pivot (array-item l arr)))
886            (let loop ((n rh) (m lh))
887              (unless (fx= m n)
888                (set! rh (do ((k n (fx- k 1)))
889                           ((or (fx= k lh)
890                                (<? (array-item k arr) pivot))
891                            k)))
892                (set! lh (do ((k m (fx+ k 1)))
893                           ((or (fx= k rh)
894                                (<? pivot (array-item k arr)))
895                            k)))
896                (array-swap! lh rh arr)
897                (loop rh lh)))
898            (if (<? (array-item lh arr) pivot)
899              (set! boundary lh))
900            ;; pivot to correct position
901            (array-swap! l boundary arr)
902            (recur l boundary)
903            (recur (fx+ boundary 1) r)
904            ))))))
905
906(define (array-apply fn . args)
907  (let ((args (reverse args)))
908    (assert* 'array-apply
909             (not (null? args))
910             (array? (car args)))
911    (let ((head (reverse (array->list (car args))))
912          (tail (cdr args)))
913      (apply fn (reverse (append head tail))))))
914
915(define (array-equ? equ? . arrs)
916  (cond
917    ((not (apply (nary? fx=) (map array-length arrs)))
918     #f)
919    ((not (apply (nary? eq?) (map array-item? arrs)))
920     #f)
921    (else
922      (for-each array-cursor-start! arrs)
923      (let loop ()
924        (for-each array-cursor-next! arrs)
925        (cond
926          ((apply (nary? eq?)
927                  (cons #t (map array-cursor-finished? arrs)))
928           #t)
929          ((apply (nary? equ?) (map array-cursor-item arrs))
930           (loop))
931          (else #f))))))
932
933(define (array-eq? . arrs)
934  (apply array-equ? eq? arrs))
935     
936(define (array-eqv? . arrs)
937  (apply array-equ? eqv? arrs))
938     
939(define (array-equal? . arrs)
940  (apply array-equ? equal? arrs))
941     
942(define (array-filter ok? arr)
943  (let ((yes (make-array (array-item? arr)))
944        (no  (make-array (array-item? arr))))
945    (array-cursor-start! arr)
946    (let loop ()
947      (array-cursor-next! arr)
948      (cond
949        ((array-cursor-finished? arr)
950         (values yes no))
951        ((ok? (array-cursor-item arr))
952         (array-add! (array-cursor-item arr) yes)
953         (loop))
954        (else
955          (array-add! (array-cursor-item arr) no)
956          (loop))))))
957;
958(define (array-remp ok? arr)
959  (call-with-values (lambda () (array-filter ok? arr))
960                    (lambda (a b) b)))
961;
962(define (array-remove item arr)
963  (array-remp (cut equal? <> item) arr))
964
965(define (array-remq item arr)
966  (array-remp (cut eq? <> item) arr))
967
968(define (array-remv item arr)
969  (array-remp (cut eqv? <> item) arr))
970
971(define (array-remove-dups equ? arr)
972  (let ((result (make-array (array-item? arr))))
973    (array-cursor-start! arr)
974    (let loop ()
975      (array-cursor-next! arr)
976      (cond
977        ((array-cursor-finished? arr)
978         result)
979        (else
980          (array-cursor-start! result)
981          (array-cursor-goto! (cut equ? <> (array-cursor-item arr)) result)
982          (if (array-cursor-finished? result) ; not found
983            (array-add! (array-cursor-item arr) result))
984          (loop))))))
985
986(define (array-unzip arr)
987  (let ((arr0 (make-array (array-item? arr)))
988        (arr1 (make-array (array-item? arr))))
989    (array-cursor-start! arr)
990    (let loop ((k 0))
991      (array-cursor-next! arr)
992      (cond
993        ((array-cursor-finished? arr)
994         (values arr0 arr1))
995        (else
996          (if (fxeven? k)
997            (array-add! (array-cursor-item arr) arr0)
998            (array-add! (array-cursor-item arr) arr1))
999          (loop (fx+ k 1)))))))
1000
1001(define (array-zip arr0 arr1)
1002  (assert* 'array-zip
1003           (array? arr0)
1004           (array? arr1)
1005           (eq? (array-item? arr0) (array-item? arr1)))
1006  (let ((result (make-array (array-item? arr0))))
1007    (array-cursor-start! arr0)
1008    (array-cursor-start! arr1)
1009    (array-cursor-next! arr0)
1010    (array-cursor-next! arr1)
1011    (do ()
1012      ((and (array-cursor-finished? arr0)
1013            (array-cursor-finished? arr1)))
1014      (cond
1015        ((array-cursor-finished? arr0)
1016         (array-add! (array-cursor-item arr1) result)
1017         (array-cursor-next! arr1))
1018        ((array-cursor-finished? arr1)
1019         (array-add! (array-cursor-item arr0) result)
1020         (array-cursor-next! arr0))
1021        (else
1022          (array-add! (array-cursor-item arr0) result)
1023          (array-cursor-next! arr0)
1024          (array-add! (array-cursor-item arr1) result)
1025          (array-cursor-next! arr1))))
1026    result))
1027
1028(define (array-interpose sep arr)
1029  (assert* 'array-interpose
1030           (array? arr)
1031           ((array-item? arr) sep))
1032  (let ((result (make-array (array-item? arr))))
1033    (array-cursor-start! arr)
1034    ;; add first item
1035    (unless (array-null? arr)
1036      (array-cursor-next! arr)
1037      (array-add! (array-cursor-item arr) result))
1038    (let loop ()
1039      (array-cursor-next! arr)
1040      (cond
1041        ((array-cursor-finished? arr)
1042         result)
1043        (else
1044          (array-add! sep result)
1045          (array-add! (array-cursor-item arr) result)
1046          (loop))))))
1047
1048(define (array-every? ok? arr)
1049  (array-cursor-start! arr)
1050  (array-cursor-goto! (o not ok?) arr)
1051  (array-cursor-finished? arr))
1052
1053(define (array-some? ok? arr)
1054  (array-cursor-start! arr)
1055  (array-cursor-goto! ok? arr)
1056  (not (array-cursor-finished? arr)))
1057
1058(define (array-in? =? arr0 arr1)
1059  (cond
1060    ((array-null? arr0)
1061     #t)
1062    ((array-null? arr1)
1063     (array-null? arr0))
1064    (else
1065      (array-cursor-start! arr0)
1066      (array-cursor-start! arr1)
1067      (let loop ()
1068        (array-cursor-next! arr0)
1069        (array-cursor-goto! (cut =? <> (array-cursor-item arr0)) arr1)
1070        (cond
1071          ((fx< (array-cursor-index arr0) (array-from arr0))
1072           #t)
1073          ((fx= (array-cursor-item arr0) (array-cursor-item arr1))
1074           (loop))
1075          (else #f))))))
1076     
1077(define-syntax array-bind
1078  (ir-macro-transformer
1079    (lambda (form inject compare?)
1080      (let ((pat (cadr form))
1081            (arr (caddr form))
1082            (xpr (caddr form))
1083            (xprs (cdddr form)))
1084        (if (list? pat)
1085          `(if (= ,(length pat) (array-length ,arr))
1086             (array-apply (lambda ,pat ,xpr ,@xprs) ,arr)
1087             (error 'array-bind "match error" ',pat ,arr))
1088          ;; pseudolist: separate list part
1089          (receive (head tail)
1090            (let loop ((pat pat) (lst '()))
1091              (if (pair? pat)
1092                (loop (cdr pat) (cons (car pat) lst))
1093                (values (reverse lst) pat)))
1094            `(if (<= ,(length head) (array-length ,arr))
1095               (receive (hd tl) (array-split-at ,(length head) ,arr)
1096                 (let ((,tail tl))
1097                   (array-apply (lambda ,head ,xpr ,@xprs) hd)))
1098               (error 'array-bind "match error" ',pat ,arr))))))))
1099
1100;;; documentation
1101(define arrays
1102  (let (
1103    (signatures '(
1104      (array? xpr)
1105      (array-null? xpr)
1106      (make-array [item?])
1107      (array [item?] . args)
1108      (list->array [item?] lst)
1109      (vector->array [item?] vec)
1110      (array-repeat [item?] cnt item)
1111      (array-iterate [item?] cnt fn start)
1112      (array-iterate-while [item?] ok? fn start)
1113      (array-iterate-until [item?] ok? fn start)
1114      (array-copy arr)
1115      (array->list arr)
1116      (array->vector arr)
1117      (array-cursor-start! arr)
1118      (array-cursor-next! arr)
1119      (array-cursor-item arr)
1120      (array-cursor-index arr)
1121      (array-cursor-finished? arr)
1122      (array-cursor-goto! ok? arr)
1123      (array-memp ok? arr)
1124      (array-member item arr)
1125      (array-memq item arr)
1126      (array-memv item arr)
1127      (array-handler arr)
1128      (array-first arr)
1129      (array-rest arr)
1130      (array-last arr)
1131      (array-butlast arr)
1132      (array-add! item arr)
1133      (array-update! index item arr)
1134      (array-prune! arr)
1135      (array-apply fn . args)
1136      (array-reverse arr)
1137      (array-reverse! arr)
1138      (array-swap! k l arr)
1139      (array-length arr)
1140      (array-count arr)
1141      (array-range from upto arr) ; subarray
1142      (array-item k arr) ; ref
1143      (array-at k arr) ; ref
1144      (array-split-at k arr)
1145      (array-split-with ok? arr)
1146      (array-drop k arr)
1147      (array-drop-while ok? arr)
1148      (array-take k arr)
1149      (array-take-while ok? arr)
1150      (array-append . arrs)
1151      (array-append! . arrs)
1152      (array-map [item?] fn . arrs)
1153      (array-mappend fn . arrs)
1154      (array-for-each fn . arrs)
1155      (array-filter ok? arr)
1156      (array-equ? equ? . arrs)
1157      (array-equal? . arrs)
1158      (array-eqv? . arrs)
1159      (array-eq? . arrs)
1160      (array-remp ok? arr)
1161      (array-remove item arr)
1162      (array-remq item arr)
1163      (array-remv item arr)
1164      (array-remove-dups equ? arr)
1165      (array-fold-left op base . arrs)
1166      (array-fold-right op base . arrs)
1167      (array-sorted? <? arr)
1168      (array-sort! <? arr)
1169      (array-zip arr0 arr1)
1170      (array-unzip arr)
1171      (array-interpose sep arr)
1172      (array-every? ok? arr)
1173      (array-some? ok? arr)
1174      (array-in? =? arr0 arr1)
1175      (array-bind (x ... . xs) arr xpr . xprs)
1176      ))
1177    )
1178    (case-lambda
1179      (() (map car signatures))
1180      ((sym) (assq sym signatures)))))
1181
1182) ; module arrays
1183
1184(module array-sets SETS
1185  (import scheme
1186          array-handlers
1187          (only (chicken base)
1188                list-of? case-lambda define-record-type
1189                define-record-printer unless error)
1190          (only (chicken fixnum) fx- fx= fx+)
1191          (only (chicken condition) condition-case)
1192          (only (chicken string) ->string))
1193
1194(define-record-type set
1195  (set-maker handler equ?) ; internal
1196  set?
1197  (handler set-handler)
1198  (equ? set-equ?))
1199
1200(define-record-printer (set st out)
1201  (let ((str (->string (set->list st))))
1202    (string-set! str 0 #\{)
1203    (string-set! str (fx- (string-length str) 1) #\})
1204    (display str out)
1205    (newline out)))
1206
1207(define (cmp->type equ?) ; internal
1208  (lambda (x)
1209    (condition-case (equ? x x)
1210      ((exn type) #f))))
1211
1212(define make-set ; exported
1213  (case-lambda
1214    ((equ?)
1215     (set-maker (make-array-handler (cmp->type equ?)) equ?))
1216    (()
1217     (make-set eqv?))))
1218
1219(define set-iterate
1220  (case-lambda
1221    ((equ? cnt fn start)
1222     (set-maker (array-handler-iterate (cmp->type equ?) cnt fn start) equ?))
1223    ((cnt fn start)
1224     (set-iterate eqv? cnt fn start))))
1225
1226(define set-iterate-while
1227  (case-lambda
1228    ((equ? ok? fn start)
1229     (set-maker (array-handler-iterate-while (cmp->type equ?) ok? fn
1230                                             start)
1231                equ?))
1232    ((ok? fn start)
1233     (set-iterate-while eqv? ok? fn start))))
1234
1235(define set-iterate-until
1236  (case-lambda
1237    ((equ? ok? fn start)
1238     (set-maker (array-handler-iterate-until (cmp->type equ?) ok? fn start)
1239                equ?))
1240    ((ok? fn start)
1241     (set-iterate-until eqv? ok? fn start))))
1242
1243(define (set arg/equ? . args)
1244  (assert* 'array (if (procedure? arg/equ?)
1245                    (not (null? args))
1246                    #t))
1247    (if (and (procedure? arg/equ?)
1248             (condition-case (arg/equ? (car args) (car args))
1249               ((exn) #f)))
1250      (list->set arg/equ? args)
1251      (list->set eqv? (cons arg/equ? args))))
1252
1253(define list->set
1254  (case-lambda
1255    ((equ? lst)
1256     (let ((result (make-set equ?)))
1257       (do ((lst lst (cdr lst)))
1258         ((null? lst) result)
1259         (set-add! (car lst) result))))
1260    ((lst)
1261     (list->set eqv? lst))))
1262
1263(define vector->set
1264  (case-lambda
1265    ((equ? vec)
1266     (let ((result (make-set equ?)))
1267       (do ((k 0 (fx+ k 1)))
1268         ((fx= k (vector-length vec)) result)
1269         (set-add! (vector-ref vec k) result))))
1270    ((vec)
1271     (vector->set eqv? vec))))
1272
1273(define (set-item? st)
1274  ((set-handler st) 'item?))
1275
1276(define (set-count st)
1277  ((set-handler st) 'count))
1278
1279(define (set-null? xpr)
1280  (and (set? xpr)
1281       (zero? ((set-handler xpr) 'count))))
1282
1283(define (set-in item st)
1284  (if (set-null? st)
1285    #f
1286    (let ((handler (set-handler st))
1287          (equ? (set-equ? st)))
1288      ((handler 'cursor-start!))
1289      (let loop ()
1290        ((handler 'cursor-next!))
1291        (cond
1292          (((handler 'cursor-finished?))
1293           #f)
1294          ((equ? item (handler 'cursor-item))
1295           (handler 'cursor-index))
1296          (else
1297            (loop)))))))
1298
1299(define (set<= set0 set1)
1300  (cond
1301    ((set-null? set0) #t)
1302    ((eq? (set-equ? set0) (set-equ? set1))
1303     (let ((handler (set-handler set0)))
1304       ((handler 'cursor-start!))
1305       (let loop ()
1306         ((handler 'cursor-next!))
1307         (cond
1308           (((handler 'cursor-finished?))
1309            #t)
1310           ((set-in (handler 'cursor-item) set1)
1311            (loop))
1312           (else #f)))))
1313    (else #f)))
1314
1315(define (set>= set0 set1)
1316  (set<= set1 set0))
1317
1318(define (set= set0 set1)
1319  (and (set<= set0 set1) (set>= set0 set1)))
1320
1321(define (set-add! item st)
1322  (assert* 'set-add!
1323           ((set-item? st) item))
1324  (unless (set-in item st)
1325    (((set-handler st) 'add!) item)))
1326
1327(define (set-remove! item st)
1328  (assert* 'set-remove!
1329           (not (set-null? st))
1330           ((set-item? st) item))
1331  (let ((handler (set-handler st)))
1332    (let ((ind (set-in item st))
1333          (last (fx- (handler 'count) 1)))
1334      (if ind
1335        (let ((x ((handler 'item) ind)))
1336          ((handler 'update!) ind
1337                              ((handler 'item) last))
1338          ((handler 'update!) last x)
1339          ((handler 'prune!)))))))
1340
1341(define (set->list st)
1342  (if (set-null? st)
1343    '()
1344    (let ((handler (set-handler st)))
1345      ((handler 'cursor-start!))
1346      (let loop ((lst '()))
1347        ((handler 'cursor-next!))
1348        (cond
1349          (((handler 'cursor-finished?))
1350           (reverse lst))
1351          (else
1352            (loop (cons (handler 'cursor-item) lst))))))))
1353
1354(define (set->vector st)
1355  (if (set-null? st)
1356    '#()
1357    (let ((handler (set-handler st))
1358          (result (make-vector (set-count st) #f)))
1359      ((handler 'cursor-start!))
1360      (let loop ()
1361        ((handler 'cursor-next!))
1362        (cond
1363          (((handler 'cursor-finished?))
1364           result)
1365          (else
1366            (vector-set! result
1367                         (handler 'cursor-index)
1368                         (handler 'cursor-item))
1369            (loop)))))))
1370
1371(define (set-filter ok? st)
1372  (let ((yes (make-set (set-equ? st)))
1373        (no  (make-set (set-equ? st))))
1374    (if (set-null? st)
1375      (values yes no)
1376      (let ((handler (set-handler st)))
1377        ((handler 'cursor-start!))
1378        (let loop ()
1379          ((handler 'cursor-next!))
1380          (cond
1381            (((handler 'cursor-finished?))
1382             (values yes no))
1383            ((ok? (handler 'cursor-item))
1384             (set-add! (handler 'cursor-item) yes)
1385             (loop))
1386            (else
1387              (set-add! (handler 'cursor-item) no)
1388              (loop))))))))
1389
1390(define (set-map fn/equ? set/fn . sets)
1391  (assert* 'set-map (procedure? fn/equ?)
1392           (or (procedure? set/fn) (set? set/fn))
1393           ((list-of? set?) sets))
1394  (let ((check? (set? set/fn)))
1395    (let ((equ? (if check? eqv? fn/equ?))
1396          (fn (if check? fn/equ? set/fn))
1397          (sets (if check? (cons set/fn sets) sets)))
1398      (let ((result (make-set equ?)))
1399        (if (memq #t (map set-null? sets))
1400          result
1401          (let ((handlers (map set-handler sets)))
1402            (for-each (lambda (hd) ((hd 'cursor-start!))) handlers)
1403            (let loop ()
1404              (for-each (lambda (hd) ((hd 'cursor-next!))) handlers)
1405              (cond
1406                ((memq #t (map (lambda (hd) ((hd 'cursor-finished?)))
1407                               handlers))
1408                 result)
1409                (else
1410                  (set-add! (apply fn (map (lambda (hd) (hd 'cursor-item))
1411                                           handlers))
1412                            result)
1413                  (loop))))))))))
1414
1415(define (set-for-each proc . sets)
1416  (assert* 'set-for-each
1417           ((list-of? set?) sets) (procedure? proc))
1418  (unless (memq #t (map set-null? sets))
1419    (let ((handlers (map set-handler sets)))
1420      (for-each (lambda (hd) ((hd 'cursor-start!))) handlers)
1421      (let loop ()
1422        (for-each (lambda (hd) ((hd 'cursor-next!))) handlers)
1423        (unless (memq #t (map (lambda (hd) ((hd 'cursor-finished?)))
1424                              handlers))
1425          (apply proc (map (lambda (hd) (hd 'cursor-item)) handlers))
1426          (loop))))))
1427
1428(define (set-copy st)
1429  (let ((result (make-set (set-equ? st))))
1430    (if (set-null? st)
1431      result
1432      (let ((handler (set-handler st)))
1433        ((handler 'cursor-start!))
1434        (let loop ()
1435          ((handler 'cursor-next!))
1436          (cond
1437            (((handler 'cursor-finished?)) result)
1438            (else
1439              (set-add! (handler 'cursor-item) result)
1440              (loop))))))))
1441
1442(define (set-difference set0 set1)
1443  (assert* 'set-difference (eq? (set-equ? set0) (set-equ? set1)))
1444  (let ((result (set-copy set0)))
1445    (if (set-null? set1)
1446      result
1447      (let ((handler (set-handler set1)))
1448        ((handler 'cursor-start!))
1449        (let loop ()
1450          ((handler 'cursor-next!))
1451          (cond
1452            (((handler 'cursor-finished?))
1453             result)
1454            ((set-in (handler 'cursor-item) set0)
1455             (set-remove! (handler 'cursor-item) result)
1456             (loop))
1457            (else
1458              (loop))))))))
1459
1460(define (set-union . sets)
1461  (assert* 'set-union
1462           (not (null? sets))
1463           ((list-of? set?) sets)
1464           (apply (nary? eq?) (map set-equ? sets)))
1465  (cond
1466    ((null? (cdr sets))
1467     (car sets))
1468    ((null? (cddr sets))
1469     (let ((result (set-copy (car sets))))
1470       (if (set-null? (cadr sets))
1471         result
1472         (let ((handler (set-handler (cadr sets))))
1473           ((handler 'cursor-start!))
1474           (let loop ()
1475             ((handler 'cursor-next!))
1476             (cond
1477               (((handler 'cursor-finished?))
1478                result)
1479               (else
1480                 (set-add! (handler 'cursor-item) result)
1481                 (loop))))))))
1482    (else
1483      (set-union (car sets) (apply set-union (cdr sets))))))
1484
1485(define (set-intersection . sets)
1486  (assert* 'set-intersection
1487           (not (null? sets))
1488           ((list-of? set?) sets)
1489           (apply (nary? eq?) (map set-equ? sets)))
1490  (cond
1491    ((null? (cdr sets))
1492     (car sets))
1493    ((null? (cddr sets))
1494     (let ((result (make-set (set-equ? (car sets)))))
1495       (if (set-null? (cadr sets))
1496         result
1497         (let ((handler (set-handler (cadr sets))))
1498           ((handler 'cursor-start!))
1499           (let loop ()
1500             ((handler 'cursor-next!))
1501             (if ((handler 'cursor-finished?))
1502               result
1503               (let ((ind (set-in (handler 'cursor-item) (car sets))))
1504                 (if ind
1505                   (set-add! (handler 'cursor-item) result))
1506                 (loop))))))))
1507    (else
1508      (set-intersection (car sets) (apply set-intersection (cdr sets))))))
1509
1510(define (set-every? ok? st)
1511  (if (set-null? st)
1512    #t
1513    (let ((handler (set-handler st)))
1514      ((handler 'cursor-start!))
1515      (let loop ()
1516        ((handler 'cursor-next!))
1517        (cond
1518          (((handler 'cursor-finished?)) #t)
1519          ((ok? (handler 'cursor-item)) (loop))
1520          (else #f))))))
1521
1522(define (set-some? ok? st)
1523  (if (set-null? st)
1524    #f
1525    (let ((handler (set-handler st)))
1526      ((handler 'cursor-start!))
1527      (let loop ()
1528        ((handler 'cursor-next!))
1529        (cond
1530          (((handler 'cursor-finished?)) #f)
1531          ((ok? (handler 'cursor-item)) #t)
1532          (else (loop)))))))
1533
1534(define (set-apply fn . args)
1535  (let ((args (reverse args)))
1536    (assert* 'set-apply
1537             (not (null? args))
1538             (set? (car args)))
1539    (let ((head (reverse (set->list (car args))))
1540          (tail (cdr args)))
1541      (apply fn (reverse (append head tail))))))
1542
1543;; documentation procedure
1544(define array-sets
1545  (let (
1546    (signatures '(
1547      (set? xpr)
1548      (make-set [equ?])
1549      (set-iterate [equ?] n fn start)
1550      (set-iterate-while [equ?] ok? fn start)
1551      (set-iterate-until [equ?] ok? fn start)
1552      (list->set [equ?] lst)
1553      (vector->set [equ?] vec)
1554      (set [equ?] . args)
1555      (set->list st)
1556      (set->vector st)
1557      (set-in item st)
1558      (set<= set0 set1)
1559      (set= set0 set1)
1560      (set>= set0 set1)
1561      (set-filter ok? st)
1562      (set-map [equ?] fn . sets)
1563      (set-for-each proc . sets)
1564      (set-null? xpr)
1565      (set-add! item st)
1566      (set-remove! item st)
1567      (set-count st)
1568      (set-copy st)
1569      (set-difference set0 set1)
1570      (set-union . sets)
1571      (set-intersection . sets)
1572      (set-every? ok? st)
1573      (set-some? ok? st)
1574      (set-apply fn . args)
1575      (set-handler st)
1576      (set-equ? st)
1577      (set-item? st)
1578      ))
1579    )
1580    (case-lambda
1581      (() (map car signatures))
1582      ((sym) (assq sym signatures)))))
1583
1584) ; module array-sets
1585
Note: See TracBrowser for help on using the repository browser.