1
;;;;;; SRFI 43: Vector library -*- Scheme -*-
3
;;; Taylor Campbell wrote this code; he places it in the public domain.
8
;; 2007-08-28 yamaken - Imported from
9
;; http://srfi.schemers.org/srfi-43/vector-lib.scm
10
;; and adapted to SigScheme
11
;; 2007-09-08 yamaken - Fix an incorrect error message in check-indices
14
;;; --------------------
15
;;; Exported procedure index
18
;;; make-vector vector
19
;;; vector-unfold vector-unfold-right
20
;;; vector-copy vector-reverse-copy
21
;;; vector-append vector-concatenate
33
;;; vector-fold vector-fold-right
34
;;; vector-map vector-map!
39
;;; vector-index vector-skip
40
;;; vector-index-right vector-skip-right
41
;;; vector-binary-search
42
;;; vector-any vector-every
49
;;; vector-copy! vector-reverse-copy!
53
;;; vector->list reverse-vector->list
54
;;; list->vector reverse-list->vector
58
;;; --------------------
59
;;; Commentary on efficiency of the code
61
;;; This code is somewhat tuned for efficiency. There are several
62
;;; internal routines that can be optimized greatly to greatly improve
63
;;; the performance of much of the library. These internal procedures
64
;;; are already carefully tuned for performance, and lambda-lifted by
65
;;; hand. Some other routines are lambda-lifted by hand, but only the
66
;;; loops are lambda-lifted, and only if some routine has two possible
67
;;; loops -- a fast path and an n-ary case --, whereas _all_ of the
68
;;; internal routines' loops are lambda-lifted so as to never cons a
69
;;; closure in their body (VECTOR-PARSE-START+END doesn't have a loop),
70
;;; even in Scheme systems that perform no loop optimization (which is
71
;;; most of them, unfortunately).
73
;;; Fast paths are provided for common cases in most of the loops in
76
;;; All calls to primitive vector operations are protected by a prior
77
;;; type check; they can be safely converted to use unsafe equivalents
78
;;; of the operations, if available. Ideally, the compiler should be
79
;;; able to determine this, but the state of Scheme compilers today is
82
;;; Efficiency of the actual algorithms is a rather mundane point to
83
;;; mention; vector operations are rarely beyond being straightforward.
87
;;; --------------------
90
;;; SigScheme: Use native SRFI-8
91
;;;;; SRFI 8, too trivial to put in the dependencies list.
92
;;(define-syntax receive
94
;; ((receive ?formals ?producer ?body1 ?body2 ...)
95
;; (call-with-values (lambda () ?producer)
96
;; (lambda ?formals ?body1 ?body2 ...)))))
98
;;; SigScheme: Define let*-optionals as an alias to let-optionals*
99
;;;;; Not the best LET*-OPTIONALS, but not the worst, either. Use Olin's
100
;;;;; if it's available to you.
101
;;(define-syntax let*-optionals
103
;; ((let*-optionals (?x ...) ((?var ?default) ...) ?body1 ?body2 ...)
104
;; (let ((args (?x ...)))
105
;; (let*-optionals args ((?var ?default) ...) ?body1 ?body2 ...)))
106
;; ((let*-optionals ?args ((?var ?default) ...) ?body1 ?body2 ...)
107
;; (let*-optionals:aux ?args ?args ((?var ?default) ...)
108
;; ?body1 ?body2 ...))))
110
;;(define-syntax let*-optionals:aux
112
;; ((aux ?orig-args-var ?args-var () ?body1 ?body2 ...)
113
;; (if (null? ?args-var)
114
;; (let () ?body1 ?body2 ...)
115
;; (error "too many arguments" (length ?orig-args-var)
117
;; ((aux ?orig-args-var ?args-var
118
;; ((?var ?default) ?more ...)
119
;; ?body1 ?body2 ...)
120
;; (if (null? ?args-var)
121
;; (let* ((?var ?default) ?more ...) ?body1 ?body2 ...)
122
;; (let ((?var (car ?args-var))
123
;; (new-args (cdr ?args-var)))
124
;; (let*-optionals:aux ?orig-args-var new-args
126
;; ?body1 ?body2 ...))))))
128
(define (nonneg-int? x)
130
(not (negative? x))))
132
(define (between? x y z)
136
(define (unspecified-value) (if #f #f))
138
;++ This should be implemented more efficiently. It shouldn't cons a
139
;++ closure, and the cons cells used in the loops when using this could
141
(define (vectors-ref vectors i)
142
(map (lambda (v) (vector-ref v i)) vectors))
146
;;; --------------------
149
;;; Error signalling (not checking) is done in a way that tries to be
150
;;; as helpful to the person who gets the debugging prompt as possible.
151
;;; That said, error _checking_ tries to be as unredundant as possible.
153
;;; I don't use any sort of general condition mechanism; I use simply
154
;;; SRFI 23's ERROR, even in cases where it might be better to use such
155
;;; a general condition mechanism. Fix that when porting this to a
156
;;; Scheme implementation that has its own condition system.
158
;;; In argument checks, upon receiving an invalid argument, the checker
159
;;; procedure recursively calls itself, but in one of the arguments to
160
;;; itself is a call to ERROR; this mechanism is used in the hopes that
161
;;; the user may be thrown into a debugger prompt, proceed with another
162
;;; value, and let it be checked again.
164
;;; Type checking is pretty basic, but easily factored out and replaced
165
;;; with whatever your implementation's preferred type checking method
166
;;; is. I doubt there will be many other methods of index checking,
167
;;; though the index checkers might be better implemented natively.
169
;;; (CHECK-TYPE <type-predicate?> <value> <callee>) -> value
170
;;; Ensure that VALUE satisfies TYPE-PREDICATE?; if not, signal an
171
;;; error stating that VALUE did not satisfy TYPE-PREDICATE?, showing
172
;;; that this happened while calling CALLEE. Return VALUE if no
173
;;; error was signalled.
174
(define (check-type pred? value callee)
177
;; Recur: when (or if) the user gets a debugger prompt, he can
178
;; proceed where the call to ERROR was with the correct value.
180
(error "erroneous value"
182
`(while calling ,callee))
185
;;; (CHECK-INDEX <vector> <index> <callee>) -> index
186
;;; Ensure that INDEX is a valid index into VECTOR; if not, signal an
187
;;; error stating that it is not and that this happened in a call to
188
;;; CALLEE. Return INDEX when it is valid. (Note that this does NOT
189
;;; check that VECTOR is indeed a vector.)
190
(define (check-index vec index callee)
191
(let ((index (check-type integer? index callee)))
194
(error "vector index too low"
197
`(while calling ,callee))
199
((>= index (vector-length vec))
201
(error "vector index too high"
204
`(while calling ,callee))
208
;;; (CHECK-INDICES <vector>
209
;;; <start> <start-name>
211
;;; <caller>) -> [start end]
212
;;; Ensure that START and END are valid bounds of a range within
213
;;; VECTOR; if not, signal an error stating that they are not, with
214
;;; the message being informative about what the argument names were
215
;;; called -- by using START-NAME & END-NAME --, and that it occurred
216
;;; while calling CALLEE. Also ensure that VEC is in fact a vector.
217
;;; Returns no useful value.
218
(define (check-indices vec start start-name end end-name callee)
219
(let ((lose (lambda things
220
(apply error "vector range out of bounds"
223
`(,start-name was ,start)
224
`(,end-name was ,end)
225
`(while calling ,callee)))))
226
(start (check-type integer? start callee))
227
(end (check-type integer? end callee)))
229
;; I'm not sure how well this will work. The intent is that
230
;; the programmer tells the debugger to proceed with both a
231
;; new START & a new END by returning multiple values
233
(receive (new-start new-end)
234
(lose `(,end-name < ,start-name))
241
(lose `(,start-name < 0))
245
((>= start (vector-length vec))
247
(lose `(,start-name >= len)
248
`(len was ,(vector-length vec)))
252
((> end (vector-length vec))
255
(lose `(,end-name > len)
256
`(len was ,(vector-length vec)))
260
(values start end)))))
264
;;; --------------------
265
;;; Internal routines
267
;;; These should all be integrated, native, or otherwise optimized --
268
;;; they're used a _lot_ --. All of the loops and LETs inside loops
269
;;; are lambda-lifted by hand, just so as not to cons closures in the
270
;;; loops. (If your compiler can do better than that if they're not
271
;;; lambda-lifted, then lambda-drop (?) them.)
273
;;; (VECTOR-PARSE-START+END <vector> <arguments>
274
;;; <start-name> <end-name>
277
;;; Return two values, composing a valid range within VECTOR, as
278
;;; extracted from ARGUMENTS or defaulted from VECTOR -- 0 for START
279
;;; and the length of VECTOR for END --; START-NAME and END-NAME are
280
;;; purely for error checking.
281
(define (vector-parse-start+end vec args start-name end-name callee)
282
(let ((len (vector-length vec)))
287
(car args) start-name
292
(car args) start-name
296
(error "too many arguments"
297
`(extra args were ,(cddr args))
298
`(while calling ,callee))))))
300
;;; SigScheme: Defined in module-srfi43.c
301
;;(define-syntax let-vector-start+end
303
;; ((let-vector-start+end ?callee ?vec ?args (?start ?end)
304
;; ?body1 ?body2 ...)
305
;; (let ((?vec (check-type vector? ?vec ?callee)))
306
;; (receive (?start ?end)
307
;; (vector-parse-start+end ?vec ?args '?start '?end
309
;; ?body1 ?body2 ...)))))
311
;;; (%SMALLEST-LENGTH <vector-list> <default-length> <callee>)
312
;;; -> exact, nonnegative integer
313
;;; Compute the smallest length of VECTOR-LIST. DEFAULT-LENGTH is
314
;;; the length that is returned if VECTOR-LIST is empty. Common use
315
;;; of this is in n-ary vector routines:
316
;;; (define (f vec . vectors)
317
;;; (let ((vec (check-type vector? vec f)))
318
;;; ...(%smallest-length vectors (vector-length vec) f)...))
319
;;; %SMALLEST-LENGTH takes care of the type checking -- which is what
320
;;; the CALLEE argument is for --; thus, the design is tuned for
321
;;; avoiding redundant type checks.
322
(define %smallest-length
323
(letrec ((loop (lambda (vector-list length callee)
324
(if (null? vector-list)
326
(loop (cdr vector-list)
335
;;; (%VECTOR-COPY! <target> <tstart> <source> <sstart> <send>)
336
;;; Copy elements at locations SSTART to SEND from SOURCE to TARGET,
337
;;; starting at TSTART in TARGET.
339
;;; Optimize this! Probably with some combination of:
340
;;; - Force it to be integrated.
341
;;; - Let it use unsafe vector element dereferencing routines: bounds
342
;;; checking already happens outside of it. (Or use a compiler
343
;;; that figures this out, but Olin Shivers' PhD thesis seems to
344
;;; have been largely ignored in actual implementations...)
345
;;; - Implement it natively as a VM primitive: the VM can undoubtedly
346
;;; perform much faster than it can make Scheme perform, even with
348
;;; - Implement it in assembly: you _want_ the fine control that
349
;;; assembly can give you for this.
350
;;; I already lambda-lift it by hand, but you should be able to make it
351
;;; even better than that.
352
(define %vector-copy!
353
(letrec ((loop/l->r (lambda (target source send i j)
355
(vector-set! target j
356
(vector-ref source i))
357
(loop/l->r target source send
359
(loop/r->l (lambda (target source sstart i j)
361
(vector-set! target j
362
(vector-ref source i))
363
(loop/r->l target source sstart
364
(- i 1) (- j 1)))))))
365
(lambda (target tstart source sstart send)
366
(if (> sstart tstart) ; Make sure we don't copy over
368
(loop/l->r target source send sstart tstart)
369
(loop/r->l target source sstart (- send 1)
370
(+ -1 tstart send (- sstart)))))))
372
;;; (%VECTOR-REVERSE-COPY! <target> <tstart> <source> <sstart> <send>)
373
;;; Copy elements from SSTART to SEND from SOURCE to TARGET, in the
375
(define %vector-reverse-copy!
376
(letrec ((loop (lambda (target source sstart i j)
378
(vector-set! target j (vector-ref source i))
379
(loop target source sstart
382
(lambda (target tstart source sstart send)
383
(loop target source sstart
387
;;; (%VECTOR-REVERSE! <vector>)
388
(define %vector-reverse!
389
(letrec ((loop (lambda (vec i j)
391
(let ((v (vector-ref vec i)))
392
(vector-set! vec i (vector-ref vec j))
393
(vector-set! vec j v)
394
(loop vec (+ i 1) (- j 1))))))))
395
(lambda (vec start end)
396
(loop vec start (- end 1)))))
398
;;; (%VECTOR-FOLD1 <kons> <knil> <vector>) -> knil'
399
;;; (KONS <index> <knil> <elt>) -> knil'
400
(define %vector-fold1
401
(letrec ((loop (lambda (kons knil len vec i)
405
(kons i knil (vector-ref vec i))
407
(lambda (kons knil len vec)
408
(loop kons knil len vec 0))))
410
;;; (%VECTOR-FOLD2+ <kons> <knil> <vector> ...) -> knil'
411
;;; (KONS <index> <knil> <elt> ...) -> knil'
412
(define %vector-fold2+
413
(letrec ((loop (lambda (kons knil len vectors i)
418
(vectors-ref vectors i))
419
len vectors (+ i 1))))))
420
(lambda (kons knil len vectors)
421
(loop kons knil len vectors 0))))
423
;;; (%VECTOR-MAP! <f> <target> <length> <vector>) -> target
424
;;; (F <index> <elt>) -> elt'
425
(define %vector-map1!
426
(letrec ((loop (lambda (f target vec i)
430
(vector-set! target j
431
(f j (vector-ref vec j)))
432
(loop f target vec j))))))
433
(lambda (f target vec len)
434
(loop f target vec len))))
436
;;; (%VECTOR-MAP2+! <f> <target> <vectors> <len>) -> target
437
;;; (F <index> <elt> ...) -> elt'
438
(define %vector-map2+!
439
(letrec ((loop (lambda (f target vectors i)
443
(vector-set! target j
444
(apply f j (vectors-ref vectors j)))
445
(loop f target vectors j))))))
446
(lambda (f target vectors len)
447
(loop f target vectors len))))
451
;;;;;;;;;;;;;;;;;;;;;;;; ***** vector-lib ***** ;;;;;;;;;;;;;;;;;;;;;;;
453
;;; --------------------
456
;;; (MAKE-VECTOR <size> [<fill>]) -> vector
457
;;; [R5RS] Create a vector of length LENGTH. If FILL is present,
458
;;; initialize each slot in the vector with it; if not, the vector's
459
;;; initial contents are unspecified.
460
(define make-vector make-vector)
462
;;; (VECTOR <elt> ...) -> vector
463
;;; [R5RS] Create a vector containing ELEMENT ..., in order.
464
(define vector vector)
466
;;; This ought to be able to be implemented much more efficiently -- if
467
;;; we have the number of arguments available to us, we can create the
468
;;; vector without using LENGTH to determine the number of elements it
470
;(define (vector . elements) (list->vector elements))
472
;;; (VECTOR-UNFOLD <f> <length> <initial-seed> ...) -> vector
473
;;; (F <index> <seed> ...) -> [elt seed' ...]
474
;;; The fundamental vector constructor. Creates a vector whose
475
;;; length is LENGTH and iterates across each index K between 0 and
476
;;; LENGTH, applying F at each iteration to the current index and the
477
;;; current seeds to receive N+1 values: first, the element to put in
478
;;; the Kth slot and then N new seeds for the next iteration.
479
(define vector-unfold
480
(letrec ((tabulate! ; Special zero-seed case.
481
(lambda (f vec i len)
483
(vector-set! vec i (f i))
484
(tabulate! f vec (+ i 1) len)))))
485
(unfold1! ; Fast path for one seed.
486
(lambda (f vec i len seed)
488
(receive (elt new-seed)
490
(vector-set! vec i elt)
491
(unfold1! f vec (+ i 1) len new-seed)))))
492
(unfold2+! ; Slower variant for N seeds.
493
(lambda (f vec i len seeds)
495
(receive (elt . new-seeds)
497
(vector-set! vec i elt)
498
(unfold2+! f vec (+ i 1) len new-seeds))))))
499
(lambda (f len . initial-seeds)
500
(let ((f (check-type procedure? f vector-unfold))
501
(len (check-type nonneg-int? len vector-unfold)))
502
(let ((vec (make-vector len)))
503
(cond ((null? initial-seeds)
504
(tabulate! f vec 0 len))
505
((null? (cdr initial-seeds))
506
(unfold1! f vec 0 len (car initial-seeds)))
508
(unfold2+! f vec 0 len initial-seeds)))
511
;;; (VECTOR-UNFOLD-RIGHT <f> <length> <initial-seed> ...) -> vector
512
;;; (F <seed> ...) -> [seed' ...]
513
;;; Like VECTOR-UNFOLD, but it generates elements from LENGTH to 0
514
;;; (still exclusive with LENGTH and inclusive with 0), not 0 to
515
;;; LENGTH as with VECTOR-UNFOLD.
516
(define vector-unfold-right
520
(vector-set! vec i (f i))
521
(tabulate! f vec (- i 1))))))
523
(lambda (f vec i seed)
525
(receive (elt new-seed)
527
(vector-set! vec i elt)
528
(unfold1! f vec (- i 1) new-seed)))))
530
(lambda (f vec i seeds)
532
(receive (elt . new-seeds)
534
(vector-set! vec i elt)
535
(unfold2+! f vec (- i 1) new-seeds))))))
536
(lambda (f len . initial-seeds)
537
(let ((f (check-type procedure? f vector-unfold-right))
538
(len (check-type nonneg-int? len vector-unfold-right)))
539
(let ((vec (make-vector len))
541
(cond ((null? initial-seeds)
543
((null? (cdr initial-seeds))
544
(unfold1! f vec i (car initial-seeds)))
546
(unfold2+! f vec i initial-seeds)))
549
;;; (VECTOR-COPY <vector> [<start> <end> <fill>]) -> vector
550
;;; Create a newly allocated vector containing the elements from the
551
;;; range [START,END) in VECTOR. START defaults to 0; END defaults
552
;;; to the length of VECTOR. END may be greater than the length of
553
;;; VECTOR, in which case the vector is enlarged; if FILL is passed,
554
;;; the new locations from which there is no respective element in
555
;;; VECTOR are filled with FILL.
556
(define (vector-copy vec . args)
557
(let ((vec (check-type vector? vec vector-copy)))
558
;; We can't use LET-VECTOR-START+END, because we have one more
559
;; argument, and we want finer control, too.
561
;; Olin's implementation of LET*-OPTIONALS would prove useful here:
562
;; the built-in argument-checks-as-you-go-along produces almost
563
;; _exactly_ the same code as VECTOR-COPY:PARSE-ARGS.
564
(receive (start end fill)
565
(vector-copy:parse-args vec args)
566
(let ((new-vector (make-vector (- end start) fill)))
567
(%vector-copy! new-vector 0
569
(if (> end (vector-length vec))
574
;;; Auxiliary for VECTOR-COPY.
575
(define (vector-copy:parse-args vec args)
577
(values 0 (vector-length vec) (unspecified-value))
578
(let ((start (check-index vec (car args) vector-copy)))
579
(if (null? (cdr args))
580
(values start (vector-length vec) (unspecified-value))
581
(let ((end (check-type nonneg-int? (cadr args)
583
(cond ((>= start (vector-length vec))
584
(error "start bound out of bounds"
588
`(while calling ,vector-copy)))
590
(error "can't invert a vector copy!"
594
`(while calling ,vector-copy)))
596
(values start end (unspecified-value)))
598
(let ((fill (caddr args)))
599
(if (null? (cdddr args))
600
(values start end fill)
601
(error "too many arguments"
603
(cdddr args)))))))))))
605
;;; (VECTOR-REVERSE-COPY <vector> [<start> <end>]) -> vector
606
;;; Create a newly allocated vector whose elements are the reversed
607
;;; sequence of elements between START and END in VECTOR. START's
608
;;; default is 0; END's default is the length of VECTOR.
609
(define (vector-reverse-copy vec . maybe-start+end)
610
(let-vector-start+end vector-reverse-copy vec maybe-start+end
612
(let ((new (make-vector (- end start))))
613
(%vector-reverse-copy! new 0 vec start end)
616
;;; (VECTOR-APPEND <vector> ...) -> vector
617
;;; Append VECTOR ... into a newly allocated vector and return that
619
(define (vector-append . vectors)
620
(vector-concatenate:aux vectors vector-append))
622
;;; (VECTOR-CONCATENATE <vector-list>) -> vector
623
;;; Concatenate the vectors in VECTOR-LIST. This is equivalent to
624
;;; (apply vector-append VECTOR-LIST)
625
;;; but VECTOR-APPEND tends to be implemented in terms of
626
;;; VECTOR-CONCATENATE, and some Schemes bork when the list to apply
627
;;; a function to is too long.
629
;;; Actually, they're both implemented in terms of an internal routine.
630
(define (vector-concatenate vector-list)
631
(vector-concatenate:aux vector-list vector-concatenate))
633
;;; Auxiliary for VECTOR-APPEND and VECTOR-CONCATENATE
634
(define vector-concatenate:aux
635
(letrec ((compute-length
636
(lambda (vectors len callee)
639
(let ((vec (check-type vector? (car vectors)
641
(compute-length (cdr vectors)
642
(+ (vector-length vec) len)
645
(lambda (vectors target to)
648
(let* ((vec1 (car vectors))
649
(len (vector-length vec1)))
650
(%vector-copy! target to vec1 0 len)
651
(concatenate! (cdr vectors) target
653
(lambda (vectors callee)
654
(cond ((null? vectors) ;+++
656
((null? (cdr vectors)) ;+++
657
;; Blech, we still have to allocate a new one.
658
(let* ((vec (check-type vector? (car vectors) callee))
659
(len (vector-length vec))
660
(new (make-vector len)))
661
(%vector-copy! new 0 vec 0 len)
665
(make-vector (compute-length vectors 0 callee))))
666
(concatenate! vectors new-vector 0)
671
;;; --------------------
674
;;; (VECTOR? <value>) -> boolean
675
;;; [R5RS] Return #T if VALUE is a vector and #F if not.
676
(define vector? vector?)
678
;;; (VECTOR-EMPTY? <vector>) -> boolean
679
;;; Return #T if VECTOR has zero elements in it, i.e. VECTOR's length
680
;;; is 0, and #F if not.
681
(define (vector-empty? vec)
682
(let ((vec (check-type vector? vec vector-empty?)))
683
(zero? (vector-length vec))))
685
;;; (VECTOR= <elt=?> <vector> ...) -> boolean
686
;;; (ELT=? <value> <value>) -> boolean
687
;;; Determine vector equality generalized across element comparators.
688
;;; Vectors A and B are equal iff their lengths are the same and for
689
;;; each respective elements E_a and E_b (element=? E_a E_b) returns
690
;;; a true value. ELT=? is always applied to two arguments. Element
691
;;; comparison must be consistent wtih EQ?; that is, if (eq? E_a E_b)
692
;;; results in a true value, then (ELEMENT=? E_a E_b) must result in a
693
;;; true value. This may be exploited to avoid multiple unnecessary
694
;;; element comparisons. (This implementation does, but does not deal
695
;;; with the situation that ELEMENT=? is EQ? to avoid more unnecessary
696
;;; comparisons, but I believe this optimization is probably fairly
699
;;; If the number of vector arguments is zero or one, then #T is
700
;;; automatically returned. If there are N vector arguments,
701
;;; VECTOR_1 VECTOR_2 ... VECTOR_N, then VECTOR_1 & VECTOR_2 are
702
;;; compared; if they are equal, the vectors VECTOR_2 ... VECTOR_N
703
;;; are compared. The precise order in which ELT=? is applied is not
705
(define (vector= elt=? . vectors)
706
(let ((elt=? (check-type procedure? elt=? vector=)))
707
(cond ((null? vectors)
709
((null? (cdr vectors))
710
(check-type vector? (car vectors) vector=)
713
(let loop ((vecs vectors))
714
(let ((vec1 (check-type vector? (car vecs) vector=))
717
(and (binary-vector= elt=? vec1 (car vec2+))
719
(define (binary-vector= elt=? vector-a vector-b)
720
(or (eq? vector-a vector-b) ;+++
721
(let ((length-a (vector-length vector-a))
722
(length-b (vector-length vector-b)))
723
(letrec ((loop (lambda (i)
726
(test (vector-ref vector-a i)
727
(vector-ref vector-b i)
729
(test (lambda (elt-a elt-b i)
730
(and (or (eq? elt-a elt-b) ;+++
733
(and (= length-a length-b)
738
;;; --------------------
741
;;; (VECTOR-REF <vector> <index>) -> value
742
;;; [R5RS] Return the value that the location in VECTOR at INDEX is
743
;;; mapped to in the store.
744
(define vector-ref vector-ref)
746
;;; (VECTOR-LENGTH <vector>) -> exact, nonnegative integer
747
;;; [R5RS] Return the length of VECTOR.
748
(define vector-length vector-length)
752
;;; --------------------
755
;;; (VECTOR-FOLD <kons> <initial-knil> <vector> ...) -> knil
756
;;; (KONS <knil> <elt> ...) -> knil' ; N vectors -> N+1 args
757
;;; The fundamental vector iterator. KONS is iterated over each
758
;;; index in all of the vectors in parallel, stopping at the end of
759
;;; the shortest; KONS is applied to an argument list of (list I
760
;;; STATE (vector-ref VEC I) ...), where STATE is the current state
761
;;; value -- the state value begins with KNIL and becomes whatever
762
;;; KONS returned at the respective iteration --, and I is the
763
;;; current index in the iteration. The iteration is strictly left-
765
;;; (vector-fold KONS KNIL (vector E_1 E_2 ... E_N))
767
;;; (KONS (... (KONS (KONS KNIL E_1) E_2) ... E_N-1) E_N)
768
(define (vector-fold kons knil vec . vectors)
769
(let ((kons (check-type procedure? kons vector-fold))
770
(vec (check-type vector? vec vector-fold)))
772
(%vector-fold1 kons knil (vector-length vec) vec)
773
(%vector-fold2+ kons knil
774
(%smallest-length vectors
777
(cons vec vectors)))))
779
;;; (VECTOR-FOLD-RIGHT <kons> <initial-knil> <vector> ...) -> knil
780
;;; (KONS <knil> <elt> ...) -> knil' ; N vectors => N+1 args
781
;;; The fundamental vector recursor. Iterates in parallel across
782
;;; VECTOR ... right to left, applying KONS to the elements and the
783
;;; current state value; the state value becomes what KONS returns
784
;;; at each next iteration. KNIL is the initial state value.
785
;;; (vector-fold-right KONS KNIL (vector E_1 E_2 ... E_N))
787
;;; (KONS (... (KONS (KONS KNIL E_N) E_N-1) ... E_2) E_1)
789
;;; Not implemented in terms of a more primitive operations that might
790
;;; called %VECTOR-FOLD-RIGHT due to the fact that it wouldn't be very
791
;;; useful elsewhere.
792
(define vector-fold-right
793
(letrec ((loop1 (lambda (kons knil vec i)
796
(loop1 kons (kons i knil (vector-ref vec i))
799
(loop2+ (lambda (kons knil vectors i)
804
(vectors-ref vectors i))
807
(lambda (kons knil vec . vectors)
808
(let ((kons (check-type procedure? kons vector-fold-right))
809
(vec (check-type vector? vec vector-fold-right)))
811
(loop1 kons knil vec (- (vector-length vec) 1))
812
(loop2+ kons knil (cons vec vectors)
813
(- (%smallest-length vectors
818
;;; (VECTOR-MAP <f> <vector> ...) -> vector
819
;;; (F <elt> ...) -> value ; N vectors -> N args
820
;;; Constructs a new vector of the shortest length of the vector
821
;;; arguments. Each element at index I of the new vector is mapped
822
;;; from the old vectors by (F I (vector-ref VECTOR I) ...). The
823
;;; dynamic order of application of F is unspecified.
824
(define (vector-map f vec . vectors)
825
(let ((f (check-type procedure? f vector-map))
826
(vec (check-type vector? vec vector-map)))
828
(let ((len (vector-length vec)))
829
(%vector-map1! f (make-vector len) vec len))
830
(let ((len (%smallest-length vectors
833
(%vector-map2+! f (make-vector len) (cons vec vectors)
836
;;; (VECTOR-MAP! <f> <vector> ...) -> unspecified
837
;;; (F <elt> ...) -> element' ; N vectors -> N args
838
;;; Similar to VECTOR-MAP, but rather than mapping the new elements
839
;;; into a new vector, the new mapped elements are destructively
840
;;; inserted into the first vector. Again, the dynamic order of
841
;;; application of F is unspecified, so it is dangerous for F to
842
;;; manipulate the first VECTOR.
843
(define (vector-map! f vec . vectors)
844
(let ((f (check-type procedure? f vector-map!))
845
(vec (check-type vector? vec vector-map!)))
847
(%vector-map1! f vec vec (vector-length vec))
848
(%vector-map2+! f vec (cons vec vectors)
849
(%smallest-length vectors
852
(unspecified-value)))
854
;;; (VECTOR-FOR-EACH <f> <vector> ...) -> unspecified
855
;;; (F <elt> ...) ; N vectors -> N args
856
;;; Simple vector iterator: applies F to each index in the range [0,
857
;;; LENGTH), where LENGTH is the length of the smallest vector
858
;;; argument passed, and the respective element at that index. In
859
;;; contrast with VECTOR-MAP, F is reliably applied to each
860
;;; subsequent elements, starting at index 0 from left to right, in
862
(define vector-for-each
864
(lambda (f vec i len)
866
(f i (vector-ref vec i))
867
(for-each1 f vec (+ i 1) len)))))
869
(lambda (f vecs i len)
871
(apply f i (vectors-ref vecs i))
872
(for-each2+ f vecs (+ i 1) len))))))
873
(lambda (f vec . vectors)
874
(let ((f (check-type procedure? f vector-for-each))
875
(vec (check-type vector? vec vector-for-each)))
877
(for-each1 f vec 0 (vector-length vec))
878
(for-each2+ f (cons vec vectors) 0
879
(%smallest-length vectors
881
vector-for-each)))))))
883
;;; (VECTOR-COUNT <predicate?> <vector> ...)
884
;;; -> exact, nonnegative integer
885
;;; (PREDICATE? <index> <value> ...) ; N vectors -> N+1 args
886
;;; PREDICATE? is applied element-wise to the elements of VECTOR ...,
887
;;; and a count is tallied of the number of elements for which a
888
;;; true value is produced by PREDICATE?. This count is returned.
889
(define (vector-count pred? vec . vectors)
890
(let ((pred? (check-type procedure? pred? vector-count))
891
(vec (check-type vector? vec vector-count)))
893
(%vector-fold1 (lambda (index count elt)
894
(if (pred? index elt)
900
(%vector-fold2+ (lambda (index count . elts)
901
(if (apply pred? index elts)
905
(%smallest-length vectors
908
(cons vec vectors)))))
912
;;; --------------------
915
;;; (VECTOR-INDEX <predicate?> <vector> ...)
916
;;; -> exact, nonnegative integer or #F
917
;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
918
;;; Search left-to-right across VECTOR ... in parallel, returning the
919
;;; index of the first set of values VALUE ... such that (PREDICATE?
920
;;; VALUE ...) returns a true value; if no such set of elements is
921
;;; reached, return #F.
922
(define (vector-index pred? vec . vectors)
923
(vector-index/skip pred? vec vectors vector-index))
925
;;; (VECTOR-SKIP <predicate?> <vector> ...)
926
;;; -> exact, nonnegative integer or #F
927
;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
928
;;; (vector-index (lambda elts (not (apply PREDICATE? elts)))
930
;;; Like VECTOR-INDEX, but find the index of the first set of values
931
;;; that do _not_ satisfy PREDICATE?.
932
(define (vector-skip pred? vec . vectors)
933
(vector-index/skip (lambda elts (not (apply pred? elts)))
937
;;; Auxiliary for VECTOR-INDEX & VECTOR-SKIP
938
(define vector-index/skip
939
(letrec ((loop1 (lambda (pred? vec len i)
941
((pred? (vector-ref vec i)) i)
942
(else (loop1 pred? vec len (+ i 1))))))
943
(loop2+ (lambda (pred? vectors len i)
945
((apply pred? (vectors-ref vectors i)) i)
946
(else (loop2+ pred? vectors len
948
(lambda (pred? vec vectors callee)
949
(let ((pred? (check-type procedure? pred? callee))
950
(vec (check-type vector? vec callee)))
952
(loop1 pred? vec (vector-length vec) 0)
953
(loop2+ pred? (cons vec vectors)
954
(%smallest-length vectors
959
;;; (VECTOR-INDEX-RIGHT <predicate?> <vector> ...)
960
;;; -> exact, nonnegative integer or #F
961
;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
962
;;; Right-to-left variant of VECTOR-INDEX.
963
(define (vector-index-right pred? vec . vectors)
964
(vector-index/skip-right pred? vec vectors vector-index-right))
966
;;; (VECTOR-SKIP-RIGHT <predicate?> <vector> ...)
967
;;; -> exact, nonnegative integer or #F
968
;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
969
;;; Right-to-left variant of VECTOR-SKIP.
970
(define (vector-skip-right pred? vec . vectors)
971
(vector-index/skip-right (lambda elts (not (apply pred? elts)))
975
(define vector-index/skip-right
976
(letrec ((loop1 (lambda (pred? vec i)
977
(cond ((negative? i) #f)
978
((pred? (vector-ref vec i)) i)
979
(else (loop1 pred? vec (- i 1))))))
980
(loop2+ (lambda (pred? vectors i)
981
(cond ((negative? i) #f)
982
((apply pred? (vectors-ref vectors i)) i)
983
(else (loop2+ pred? vectors (- i 1)))))))
984
(lambda (pred? vec vectors callee)
985
(let ((pred? (check-type procedure? pred? callee))
986
(vec (check-type vector? vec callee)))
988
(loop1 pred? vec (- (vector-length vec) 1))
989
(loop2+ pred? (cons vec vectors)
990
(- (%smallest-length vectors
995
;;; (VECTOR-BINARY-SEARCH <vector> <value> <cmp> [<start> <end>])
996
;;; -> exact, nonnegative integer or #F
997
;;; (CMP <value1> <value2>) -> integer
998
;;; positive -> VALUE1 > VALUE2
999
;;; zero -> VALUE1 = VALUE2
1000
;;; negative -> VALUE1 < VALUE2
1001
;;; Perform a binary search through VECTOR for VALUE, comparing each
1002
;;; element to VALUE with CMP.
1003
(define (vector-binary-search vec value cmp . maybe-start+end)
1004
(let ((cmp (check-type procedure? cmp vector-binary-search)))
1005
(let-vector-start+end vector-binary-search vec maybe-start+end
1007
(let loop ((start start) (end end) (j #f))
1008
(let ((i (quotient (+ start end) 2)))
1009
(if (or (= start end) (and j (= i j)))
1012
(check-type integer?
1013
(cmp (vector-ref vec i) value)
1014
`(,cmp for ,vector-binary-search))))
1015
(cond ((zero? comparison) i)
1016
((positive? comparison) (loop start i i))
1017
(else (loop i end i))))))))))
1019
;;; (VECTOR-ANY <pred?> <vector> ...) -> value
1020
;;; Apply PRED? to each parallel element in each VECTOR ...; if PRED?
1021
;;; should ever return a true value, immediately stop and return that
1022
;;; value; otherwise, when the shortest vector runs out, return #F.
1023
;;; The iteration and order of application of PRED? across elements
1024
;;; is of the vectors is strictly left-to-right.
1026
(letrec ((loop1 (lambda (pred? vec i len len-1)
1027
(and (not (= i len))
1029
(pred? (vector-ref vec i))
1030
(or (pred? (vector-ref vec i))
1031
(loop1 pred? vec (+ i 1)
1033
(loop2+ (lambda (pred? vectors i len len-1)
1034
(and (not (= i len))
1036
(apply pred? (vectors-ref vectors i))
1037
(or (apply pred? (vectors-ref vectors i))
1038
(loop2+ pred? vectors (+ i 1)
1040
(lambda (pred? vec . vectors)
1041
(let ((pred? (check-type procedure? pred? vector-any))
1042
(vec (check-type vector? vec vector-any)))
1044
(let ((len (vector-length vec)))
1045
(loop1 pred? vec 0 len (- len 1)))
1046
(let ((len (%smallest-length vectors
1049
(loop2+ pred? (cons vec vectors) 0 len (- len 1))))))))
1051
;;; (VECTOR-EVERY <pred?> <vector> ...) -> value
1052
;;; Apply PRED? to each parallel value in each VECTOR ...; if PRED?
1053
;;; should ever return #F, immediately stop and return #F; otherwise,
1054
;;; if PRED? should return a true value for each element, stopping at
1055
;;; the end of the shortest vector, return the last value that PRED?
1056
;;; returned. In the case that there is an empty vector, return #T.
1057
;;; The iteration and order of application of PRED? across elements
1058
;;; is of the vectors is strictly left-to-right.
1059
(define vector-every
1060
(letrec ((loop1 (lambda (pred? vec i len len-1)
1063
(pred? (vector-ref vec i))
1064
(and (pred? (vector-ref vec i))
1065
(loop1 pred? vec (+ i 1)
1067
(loop2+ (lambda (pred? vectors i len len-1)
1070
(apply pred? (vectors-ref vectors i))
1071
(and (apply pred? (vectors-ref vectors i))
1072
(loop2+ pred? vectors (+ i 1)
1074
(lambda (pred? vec . vectors)
1075
(let ((pred? (check-type procedure? pred? vector-every))
1076
(vec (check-type vector? vec vector-every)))
1078
(let ((len (vector-length vec)))
1079
(loop1 pred? vec 0 len (- len 1)))
1080
(let ((len (%smallest-length vectors
1083
(loop2+ pred? (cons vec vectors) 0 len (- len 1))))))))
1087
;;; --------------------
1090
;;; (VECTOR-SET! <vector> <index> <value>) -> unspecified
1091
;;; [R5RS] Assign the location at INDEX in VECTOR to VALUE.
1092
(define vector-set! vector-set!)
1094
;;; (VECTOR-SWAP! <vector> <index1> <index2>) -> unspecified
1095
;;; Swap the values in the locations at INDEX1 and INDEX2.
1096
(define (vector-swap! vec i j)
1097
(let ((vec (check-type vector? vec vector-swap!)))
1098
(let ((i (check-index vec i vector-swap!))
1099
(j (check-index vec j vector-swap!)))
1100
(let ((x (vector-ref vec i)))
1101
(vector-set! vec i (vector-ref vec j))
1102
(vector-set! vec j x)))))
1104
;;; (VECTOR-FILL! <vector> <value> [<start> <end>]) -> unspecified
1105
;;; [R5RS+] Fill the locations in VECTOR between START, whose default
1106
;;; is 0, and END, whose default is the length of VECTOR, with VALUE.
1108
;;; This one can probably be made really fast natively.
1109
(define vector-fill!
1110
(let ((%vector-fill! vector-fill!)) ; Take the native one, under
1111
; the assumption that it's
1112
; faster, so we can use it if
1113
; there are no optional
1115
(lambda (vec value . maybe-start+end)
1116
(if (null? maybe-start+end)
1117
(%vector-fill! vec value) ;+++
1118
(let-vector-start+end vector-fill! vec maybe-start+end
1120
(do ((i start (+ i 1)))
1122
(vector-set! vec i value)))))))
1124
;;; (VECTOR-COPY! <target> <tstart> <source> [<sstart> <send>])
1126
;;; Copy the values in the locations in [SSTART,SEND) from SOURCE to
1127
;;; to TARGET, starting at TSTART in TARGET.
1128
(define (vector-copy! target tstart source . maybe-sstart+send)
1129
(let* ((target (check-type vector? target vector-copy!))
1130
(tstart (check-index target tstart vector-copy!)))
1131
(let-vector-start+end vector-copy! source maybe-sstart+send
1133
(let* ((source-length (vector-length source))
1134
(lose (lambda (argument)
1135
(error "vector range out of bounds"
1137
`(while calling ,vector-copy!)
1138
`(target was ,target)
1139
`(target-length was ,(vector-length target))
1140
`(tstart was ,tstart)
1141
`(source was ,source)
1142
`(source-length was ,source-length)
1143
`(sstart was ,sstart)
1144
`(send was ,send)))))
1146
(lose '(sstart < 0)))
1150
(lose '(sstart > send)))
1151
((>= sstart source-length)
1152
(lose '(sstart >= source-length)))
1153
((> send source-length)
1154
(lose '(send > source-length)))
1156
(%vector-copy! target tstart
1157
source sstart send)))))))
1159
;;; (VECTOR-REVERSE-COPY! <target> <tstart> <source> [<sstart> <send>])
1160
(define (vector-reverse-copy! target tstart source . maybe-sstart+send)
1161
(let* ((target (check-type vector? target vector-reverse-copy!))
1162
(tstart (check-index target tstart vector-reverse-copy!)))
1163
(let-vector-start+end vector-reverse-copy source maybe-sstart+send
1165
(let* ((source-length (vector-length source))
1166
(lose (lambda (argument)
1167
(error "vector range out of bounds"
1169
`(while calling ,vector-reverse-copy!)
1170
`(target was ,target)
1171
`(target-length was ,(vector-length target))
1172
`(tstart was ,tstart)
1173
`(source was ,source)
1174
`(source-length was ,source-length)
1175
`(sstart was ,sstart)
1176
`(send was ,send)))))
1178
(lose '(sstart < 0)))
1182
(lose '(sstart > send)))
1183
((>= sstart source-length)
1184
(lose '(sstart >= source-length)))
1185
((> send source-length)
1186
(lose '(send > source-length)))
1187
((and (eq? target source)
1189
(%vector-reverse! target tstart send))
1190
((and (eq? target source)
1191
(or (between? sstart tstart send)
1192
(between? tstart sstart
1193
(+ tstart (- send sstart)))))
1194
(error "vector range for self-copying overlaps"
1195
vector-reverse-copy!
1196
`(vector was ,target)
1197
`(tstart was ,tstart)
1198
`(sstart was ,sstart)
1201
(%vector-reverse-copy! target tstart
1202
source sstart send)))))))
1204
;;; (VECTOR-REVERSE! <vector> [<start> <end>]) -> unspecified
1205
;;; Destructively reverse the contents of the sequence of locations
1206
;;; in VECTOR between START, whose default is 0, and END, whose
1207
;;; default is the length of VECTOR.
1208
(define (vector-reverse! vec . start+end)
1209
(let-vector-start+end vector-reverse! vec start+end
1211
(%vector-reverse! vec start end)))
1215
;;; --------------------
1218
;;; (VECTOR->LIST <vector> [<start> <end>]) -> list
1219
;;; [R5RS+] Produce a list containing the elements in the locations
1220
;;; between START, whose default is 0, and END, whose default is the
1221
;;; length of VECTOR, from VECTOR.
1222
(define vector->list
1223
(let ((%vector->list vector->list))
1224
(lambda (vec . maybe-start+end)
1225
(if (null? maybe-start+end) ; Oughta use CASE-LAMBDA.
1226
(%vector->list vec) ;+++
1227
(let-vector-start+end vector->list vec maybe-start+end
1229
;(unfold (lambda (i) ; No SRFI 1.
1231
; (lambda (i) (vector-ref vec i))
1232
; (lambda (i) (- i 1))
1234
(do ((i (- end 1) (- i 1))
1235
(result '() (cons (vector-ref vec i) result)))
1236
((< i start) result)))))))
1238
;;; (REVERSE-VECTOR->LIST <vector> [<start> <end>]) -> list
1239
;;; Produce a list containing the elements in the locations between
1240
;;; START, whose default is 0, and END, whose default is the length
1241
;;; of VECTOR, from VECTOR, in reverse order.
1242
(define (reverse-vector->list vec . maybe-start+end)
1243
(let-vector-start+end reverse-vector->list vec maybe-start+end
1245
;(unfold (lambda (i) (= i end)) ; No SRFI 1.
1246
; (lambda (i) (vector-ref vec i))
1247
; (lambda (i) (+ i 1))
1249
(do ((i start (+ i 1))
1250
(result '() (cons (vector-ref vec i) result)))
1251
((= i end) result))))
1253
;;; (LIST->VECTOR <list> [<start> <end>]) -> vector
1254
;;; [R5RS+] Produce a vector containing the elements in LIST, which
1255
;;; must be a proper list, between START, whose default is 0, & END,
1256
;;; whose default is the length of LIST. It is suggested that if the
1257
;;; length of LIST is known in advance, the START and END arguments
1258
;;; be passed, so that LIST->VECTOR need not call LENGTH to determine
1261
;;; This implementation diverges on circular lists, unless LENGTH fails
1262
;;; and causes - to fail as well. Given a LENGTH* that computes the
1263
;;; length of a list's cycle, this wouldn't diverge, and would work
1264
;;; great for circular lists.
1265
(define list->vector
1266
(let ((%list->vector list->vector))
1267
(lambda (lst . maybe-start+end)
1268
;; Checking the type of a proper list is expensive, so we do it
1269
;; amortizedly, or let %LIST->VECTOR or LIST-TAIL do it.
1270
(if (null? maybe-start+end) ; Oughta use CASE-LAMBDA.
1271
(%list->vector lst) ;+++
1272
;; We can't use LET-VECTOR-START+END, because we're using the
1273
;; bounds of a _list_, not a vector.
1274
(let*-optionals maybe-start+end
1276
(end (length lst))) ; Ugh -- LENGTH
1277
(let ((start (check-type nonneg-int? start list->vector))
1278
(end (check-type nonneg-int? end list->vector)))
1280
(vector-unfold f (- end start) (list-tail lst start)))
1283
(error "list was too short"
1285
`(attempted end was ,end)
1286
`(while calling ,list->vector)))
1288
(values (car l) (cdr l)))
1290
;; Make this look as much like what CHECK-TYPE
1291
;; would report as possible.
1292
(error "erroneous value"
1293
;; We want SRFI 1's PROPER-LIST?, but it
1294
;; would be a waste to link all of SRFI
1295
;; 1 to this module for only the single
1296
;; function PROPER-LIST?.
1299
,list->vector))))))))))))
1301
;;; (REVERSE-LIST->VECTOR <list> [<start> <end>]) -> vector
1302
;;; Produce a vector containing the elements in LIST, which must be a
1303
;;; proper list, between START, whose default is 0, and END, whose
1304
;;; default is the length of LIST, in reverse order. It is suggested
1305
;;; that if the length of LIST is known in advance, the START and END
1306
;;; arguments be passed, so that REVERSE-LIST->VECTOR need not call
1307
;;; LENGTH to determine the the length.
1309
;;; This also diverges on circular lists unless, again, LENGTH returns
1310
;;; something that makes - bork.
1311
(define (reverse-list->vector lst . maybe-start+end)
1312
(let*-optionals maybe-start+end
1314
(end (length lst))) ; Ugh -- LENGTH
1315
(let ((start (check-type nonneg-int? start reverse-list->vector))
1316
(end (check-type nonneg-int? end reverse-list->vector)))
1318
(vector-unfold-right f (- end start) (list-tail lst start)))
1321
(error "list too short"
1323
`(attempted end was ,end)
1324
`(while calling ,reverse-list->vector)))
1326
(values (car l) (cdr l)))
1328
(error "erroneous value"
1330
`(while calling ,reverse-list->vector)))))))))
added
removed
sigscheme/lib/srfi-43.scm
