2 ; Copyright © 2018 Keith Packard <keithp@keithp.com>
4 ; This program is free software; you can redistribute it and/or modify
5 ; it under the terms of the GNU General Public License as published by
6 ; the Free Software Foundation, either version 2 of the License, or
7 ; (at your option) any later version.
9 ; This program is distributed in the hope that it will be useful, but
10 ; WITHOUT ANY WARRANTY; without even the implied warranty of
11 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 ; General Public License for more details.
14 ; vector functions placed in ROM
17 (define vector->string
20 (h (vector-length v)))
21 (if (not (null? args))
24 (if (not (null? (cdr args)))
28 (do ((s (make-string (- h l)))
32 (string-set! s (- p l) (vector-ref v p))
38 (_??_ (vector->string #(#\a #\b #\c) 0 2) "ab")
40 (define string->vector
43 (h (string-length s)))
44 (if (not (null? args))
47 (if (not (null? (cdr args)))
51 (do ((v (make-vector (- h l)))
55 (vector-set! v (- p l) (string-ref s p))
61 (_??_ (string->vector "hello" 0 2) #(#\h #\e))
64 (lambda (t a f . args)
69 ; handle optional start/end args
71 (if (not (null? args))
74 (if (not (null? (cdr args)))
79 ; flip copy order if dst is
89 ; loop copying one at a time
93 (vector-set! t (+ p o) (vector-ref f p))
99 ; simple vector-copy test
101 (_??_ (vector-copy! (make-vector 10 "t") 0 (make-vector 5 "f") 0 5) #("f" "f" "f" "f" "f" "t" "t" "t" "t" "t"))
103 (let ((v (vector 1 2 3 4 5 6 7 8 9 0)))
104 (vector-copy! v 1 v 0 2)
105 (display "v ") (write v) (newline)
111 (h (vector-length v)))
112 (if (not (null? args))
115 (if (not (null? (cdr args)))
116 (set! h (cadr args)))
119 (vector-copy! (make-vector (- h l)) 0 v)
124 (_??_ (vector-copy #(1 2 3) 0 3) #(1 2 3))
126 (define vector-append
132 (vector-copy! v p (car a))
133 (_f v (cdr a) (+ p (vector-length (car a))))
137 (_f (make-vector (apply + (map vector-length a))) a 0)
141 (_??_ (vector-append #(1 2 3) #(4 5 6) #(7 8 9)) #(1 2 3 4 5 6 7 8 9))
146 (h (vector-length v)))
147 (cond ((not (null? args))
149 (cond ((not (null? (cdr args)))
150 (set! h (cadr args)))
167 (_??_ (vector-fill! (make-vector 3) #t 1 2) #(#f #t #f))
169 ; like 'map', but for vectors
172 (lambda (proc . vectors)
173 ; result length is min of arg lengths
174 (let* ((l (apply min (map vector-length vectors)))
177 ; walk the vectors, doing evaluation
182 (vector-set! v p (apply proc (map (lambda (v) (vector-ref v p)) vectors)))
192 (_??_ (vector-map + #(1 2 3) #(4 5 6)) #(5 7 9))