summaryrefslogtreecommitdiff
path: root/src/scheme/ao_scheme_vector.scheme
diff options
context:
space:
mode:
authorKeith Packard <keithp@keithp.com>2018-01-10 23:11:40 -0800
committerKeith Packard <keithp@keithp.com>2018-01-10 23:11:40 -0800
commitf26cc1a677f577da533425a15485fcaa24626b23 (patch)
tree2f1e96addf6af39a9013acc76409f9df74a5e561 /src/scheme/ao_scheme_vector.scheme
parent4b52fc6eea9a478cb3dd42dcd32c92838df39734 (diff)
altos/scheme: Move ao-scheme to a separate repository
This way it can be incorporated into multiple operating systems more easily. Signed-off-by: Keith Packard <keithp@keithp.com>
Diffstat (limited to 'src/scheme/ao_scheme_vector.scheme')
-rw-r--r--src/scheme/ao_scheme_vector.scheme192
1 files changed, 0 insertions, 192 deletions
diff --git a/src/scheme/ao_scheme_vector.scheme b/src/scheme/ao_scheme_vector.scheme
deleted file mode 100644
index 6c25aae5..00000000
--- a/src/scheme/ao_scheme_vector.scheme
+++ /dev/null
@@ -1,192 +0,0 @@
-;
-; Copyright © 2018 Keith Packard <keithp@keithp.com>
-;
-; This program is free software; you can redistribute it and/or modify
-; it under the terms of the GNU General Public License as published by
-; the Free Software Foundation, either version 2 of the License, or
-; (at your option) any later version.
-;
-; This program is distributed in the hope that it will be useful, but
-; WITHOUT ANY WARRANTY; without even the implied warranty of
-; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-; General Public License for more details.
-;
-; vector functions placed in ROM
-
-
-(define vector->string
- (lambda (v . args)
- (let ((l 0)
- (h (vector-length v)))
- (if (not (null? args))
- (begin
- (set! l (car args))
- (if (not (null? (cdr args)))
- (set! h (cadr args)))
- )
- )
- (do ((s (make-string (- h l)))
- (p l (+ p 1))
- )
- ((= p h) s)
- (string-set! s (- p l) (vector-ref v p))
- )
- )
- )
- )
-
-(vector->string #(#\a #\b #\c) 0 2)
-
-(define string->vector
- (lambda (s . args)
- (let ((l 0)
- (h (string-length s)))
- (if (not (null? args))
- (begin
- (set! l (car args))
- (if (not (null? (cdr args)))
- (set! h (cadr args)))
- )
- )
- (do ((v (make-vector (- h l)))
- (p l (+ p 1))
- )
- ((= p h) v)
- (vector-set! v (- p l) (string-ref s p))
- )
- )
- )
- )
-
-(string->vector "hello" 0 2)
-
-(define vector-copy!
- (lambda (t a f . args)
- (let ((l 0)
- (h (vector-length f))
- (o a)
- (d 1))
- ; handle optional start/end args
-
- (if (not (null? args))
- (begin
- (set! l (car args))
- (if (not (null? (cdr args)))
- (set! h (cadr args)))
- (set! o (- a l))
- )
- )
- ; flip copy order if dst is
- ; after src
- (if (< l a)
- (begin
- (set! d h)
- (set! h (- l 1))
- (set! l (- d 1))
- (set! d -1)
- )
- )
- ; loop copying one at a time
- (do ((p l (+ p d))
- )
- ((= p h) t)
- (vector-set! t (+ p o) (vector-ref f p))
- )
- )
- )
- )
-
- ; simple vector-copy test
-
-(vector-copy! (make-vector 10 "t") 0 (make-vector 5 "f") 0 5)
-
-(let ((v (vector 1 2 3 4 5 6 7 8 9 0)))
- (vector-copy! v 1 v 0 2)
- (display "v ") (write v) (newline)
- )
-
-(define vector-copy
- (lambda (v . args)
- (let ((l 0)
- (h (vector-length v)))
- (if (not (null? args))
- (begin
- (set! l (car args))
- (if (not (null? (cdr args)))
- (set! h (cadr args)))
- )
- )
- (vector-copy! (make-vector (- h l)) 0 v)
- )
- )
- )
-
-(vector-copy #(1 2 3) 0 3)
-
-(define vector-append
- (lambda a
- (define (_f v a p)
- (if (null? a)
- v
- (begin
- (vector-copy! v p (car a))
- (_f v (cdr a) (+ p (vector-length (car a))))
- )
- )
- )
- (_f (make-vector (apply + (map vector-length a))) a 0)
- )
- )
-
-(vector-append #(1 2 3) #(4 5 6) #(7 8 9))
-
-(define vector-fill!
- (lambda (v a . args)
- (let ((l 0)
- (h (vector-length v)))
- (cond ((not (null? args))
- (set! l (car args))
- (cond ((not (null? (cdr args)))
- (set! h (cadr args)))
- )
- )
- )
- (define (_f b)
- (cond ((< b h)
- (vector-set! v b a)
- (_f (+ b 1))
- )
- (else v)
- )
- )
- (_f l)
- )
- )
- )
-
-(vector-fill! (make-vector 3) #t 1 2)
-
- ; like 'map', but for vectors
-
-(define vector-map
- (lambda (proc . vectors)
- ; result length is min of arg lengths
- (let* ((l (apply min (map vector-length vectors)))
- ; create the result
- (v (make-vector l)))
- ; walk the vectors, doing evaluation
- (define (_m p)
- (if (equal? p l)
- v
- (begin
- (vector-set! v p (apply proc (map (lambda (v) (vector-ref v p)) vectors)))
- (_m (+ p 1))
- )
- )
- )
- (_m 0)
- )
- )
- )
-
-(vector-map + #(1 2 3) #(4 5 6))