git.gag.com Git - fw/altos/blob - src/scheme/ao_scheme_vector.scheme

   1 ;
   2 ; Copyright © 2018 Keith Packard <keithp@keithp.com>
   3 ;
   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.
   8 ;
   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.
  13 ;
  14 ; vector functions placed in ROM
  15
  16
  17 (define vector->string
  18   (lambda (v . args)
  19     (let ((l 0)
  20           (h (vector-length v)))
  21       (if (not (null? args))
  22           (begin
  23             (set! l (car args))
  24             (if (not (null? (cdr args)))
  25                 (set! h (cadr args)))
  26             )
  27           )
  28       (do ((s (make-string (- h l)))
  29            (p l (+ p 1))
  30            )
  31           ((= p h) s)
  32         (string-set! s (- p l) (vector-ref v p))
  33         )
  34       )
  35     )
  36   )
  37
  38 (_??_ (vector->string #(#\a #\b #\c) 0 2) "ab")
  39
  40 (define string->vector
  41   (lambda (s . args)
  42     (let ((l 0)
  43           (h (string-length s)))
  44       (if (not (null? args))
  45           (begin
  46             (set! l (car args))
  47             (if (not (null? (cdr args)))
  48                 (set! h (cadr args)))
  49             )
  50           )
  51       (do ((v (make-vector (- h l)))
  52            (p l (+ p 1))
  53            )
  54           ((= p h) v)
  55         (vector-set! v (- p l) (string-ref s p))
  56         )
  57       )
  58     )
  59   )
  60
  61 (_??_ (string->vector "hello" 0 2) #(#\h #\e))
  62
  63 (define vector-copy!
  64   (lambda (t a f . args)
  65     (let ((l 0)
  66           (h (vector-length f))
  67           (o a)
  68           (d 1))
  69                                         ; handle optional start/end args
  70
  71       (if (not (null? args))
  72           (begin
  73             (set! l (car args))
  74             (if (not (null? (cdr args)))
  75                 (set! h (cadr args)))
  76             (set! o (- a l))
  77             )
  78           )
  79                                         ; flip copy order if dst is
  80                                         ; after src
  81       (if (< l a)
  82           (begin
  83             (set! d h)
  84             (set! h (- l 1))
  85             (set! l (- d 1))
  86             (set! d -1)
  87             )
  88           )
  89                                         ; loop copying one at a time
  90       (do ((p l (+ p d))
  91            )
  92           ((= p h) t)
  93         (vector-set! t (+ p o) (vector-ref f p))
  94         )
  95       )
  96     )
  97   )
  98
  99                                         ; simple vector-copy test
 100
 101 (_??_ (vector-copy! (make-vector 10 "t") 0 (make-vector 5 "f") 0 5) #("f" "f" "f" "f" "f" "t" "t" "t" "t" "t"))
 102
 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)
 106   )
 107
 108 (define vector-copy
 109   (lambda (v . args)
 110     (let ((l 0)
 111           (h (vector-length v)))
 112       (if (not (null? args))
 113           (begin
 114             (set! l (car args))
 115             (if (not (null? (cdr args)))
 116                 (set! h (cadr args)))
 117             )
 118           )
 119       (vector-copy! (make-vector (- h l)) 0 v)
 120       )
 121     )
 122   )
 123
 124 (_??_ (vector-copy #(1 2 3) 0 3) #(1 2 3))
 125
 126 (define vector-append
 127   (lambda a
 128     (define (_f v a p)
 129       (if (null? a)
 130           v
 131           (begin
 132             (vector-copy! v p (car a))
 133             (_f v (cdr a) (+ p (vector-length (car a))))
 134             )
 135           )
 136       )
 137     (_f (make-vector (apply + (map vector-length a))) a 0)
 138     )
 139   )
 140
 141 (_??_ (vector-append #(1 2 3) #(4 5 6) #(7 8 9)) #(1 2 3 4 5 6 7 8 9))
 142
 143 (define vector-fill!
 144   (lambda (v a . args)
 145     (let ((l 0)
 146           (h (vector-length v)))
 147       (cond ((not (null? args))
 148              (set! l (car args))
 149              (cond ((not (null? (cdr args)))
 150                     (set! h (cadr args)))
 151                    )
 152              )
 153             )
 154       (define (_f b)
 155         (cond ((< b h)
 156                (vector-set! v b a)
 157                (_f (+ b 1))
 158                )
 159               (else v)
 160               )
 161         )
 162       (_f l)
 163       )
 164     )
 165   )
 166
 167 (_??_ (vector-fill! (make-vector 3) #t 1 2) #(#f #t #f))
 168
 169                                         ; like 'map', but for vectors
 170
 171 (define vector-map
 172   (lambda (proc . vectors)
 173                                         ; result length is min of arg lengths
 174     (let* ((l (apply min (map vector-length vectors)))
 175                                         ; create the result
 176            (v (make-vector l)))
 177                                         ; walk the vectors, doing evaluation
 178       (define (_m p)
 179         (if (equal? p l)
 180             v
 181             (begin
 182               (vector-set! v p (apply proc (map (lambda (v) (vector-ref v p)) vectors)))
 183               (_m (+ p 1))
 184               )
 185             )
 186         )
 187       (_m 0)
 188       )
 189     )
 190   )
 191
 192 (_??_ (vector-map + #(1 2 3) #(4 5 6)) #(5 7 9))