source: project/release/4/srfi-27/trunk/srfi-27-vector-support.scm @ 35477

Last change on this file since 35477 was 35477, checked in by kon, 5 months ago

fix distribution generator type

File size: 4.0 KB
Line 
1;;;; srfi-27-vector-support.scm
2;;;; Kon Lovett, Feb '10
3
4;; Issues
5;;
6;; - More could be coded in C, there is a lot of overhead
7
8; Chicken Generic Arithmetic!
9
10(module srfi-27-vector-support
11
12(;export
13  vector-filled! u8vector-filled! f32vector-filled! f64vector-filled!
14  f32vector-mapi!/1 f32vector-foldi/1
15  f64vector-mapi!/1 f64vector-foldi/1
16  ;
17  check-vector%
18  vector%-length
19  vector%-mapi!/1
20  vector%-foldi/1
21  vector%-filled!
22  vector%-scale!
23  vector%-sum-squares)
24
25(import scheme chicken)
26
27(use
28  (only srfi-4
29    u8vector-length u8vector-ref u8vector-set!
30    f32vector? f32vector-length f32vector-ref f32vector-set!
31    f64vector? f64vector-length f64vector-ref f64vector-set!)
32  (only vector-lib vector-map! vector-fold)
33  (only type-errors error-vector))
34
35;;;
36
37;;
38
39(define (make-filled! veclenf vecsetf)
40  (letrec (
41    (self
42      (case-lambda
43        ((vec gen)
44          (self vec gen 0) )
45        ((vec gen start)
46          (self vec gen start (veclenf vec)) )
47        ((vec gen start end)
48          (do ((idx start (fx+ idx 1)))
49              ((fx= end idx) vec)
50            (vecsetf vec idx (gen)) ) ) ) ) )
51    self ) )
52
53#;
54(define (make-filled! veclenf vecsetf)
55  (lambda (vec gen #!optional (start 0) (end (veclenf vec)))
56    (do ((idx start (fx+ idx 1)))
57        ((fx= end idx) vec)
58      (vecsetf vec idx (gen)) ) ) )
59
60(define (make-mapi!/1 veclenf vecref vecsetf)
61  (lambda (proc vec)
62    (let ((len (veclenf vec)))
63      (do ((i 0 (fx+ i 1)))
64          ((fx= i len) vec)
65        (vecsetf vec i (proc i (vecref vec i))) ) ) ) )
66
67(define (make-foldi/1 veclenf vecref)
68  (lambda (proc init vec)
69    (let ((len (veclenf vec)))
70      (do ((i 0 (fx+ i 1) )
71           (acc init (proc i acc (vecref vec i)) ) )
72          ((fx= i len) acc) ) ) ) )
73
74;;
75
76(define u8vector-filled!
77  (make-filled! u8vector-length u8vector-set!) )
78
79(define f64vector-filled!
80  (make-filled! f64vector-length f64vector-set!) )
81
82(define f32vector-filled!
83  (make-filled! f32vector-length f32vector-set!) )
84
85(define vector-filled!
86  (make-filled! vector-length vector-set!) )
87
88(define f32vector-mapi!/1
89  (make-mapi!/1 f32vector-length f32vector-ref f32vector-set!) )
90
91(define f64vector-mapi!/1
92  (make-mapi!/1 f64vector-length f64vector-ref f64vector-set!) )
93
94(define f32vector-foldi/1
95  (make-foldi/1 f32vector-length f32vector-ref) )
96
97(define f64vector-foldi/1
98  (make-foldi/1 f64vector-length f64vector-ref) )
99
100;;; Vector% Support
101
102(define (vector-fold/1 vec proc seed)
103  (vector-fold proc seed vec) )
104
105(define (vector-map!/1 vec proc)
106  (vector-map! proc vec) )
107
108#; ;NOT YET
109(define (array-rank/1? obj)
110  (and (array? obj) (fx= 1 (array-rank obj))))
111
112(define (acceptable-vector? obj)
113  (or
114    (vector? obj)
115    (f32vector? obj)
116    (f64vector? obj)
117    #; ;NOT YET
118    (array-rank/1? obj) ) )
119
120(define (check-vector% loc obj #!optional argnam)
121  (unless (acceptable-vector? obj)
122    (error-vector loc obj argnam) )
123  obj )
124
125(define (make-oper vec-oper f32vec-oper f64vec-oper)
126  (lambda (vec . args)
127    (cond
128      ((vector? vec)
129        (apply vec-oper vec args) )
130      ((f32vector? vec)
131        (apply f32vec-oper vec args) )
132      ((f64vector? vec)
133        (apply f64vec-oper vec args) )
134      #; ;NOT YET
135      ((array-rank/1? vec)
136        ;arr-rnk-1-oper
137        (apply arr-rnk-1 vec args) )
138      (else
139        (error-vector #f vec)) ) ) )
140
141;;
142
143(define vector%-length
144  (make-oper vector-length f32vector-length f64vector-length) )
145
146(define vector%-mapi!/1
147  ;(lambda (vec proc) (array-map! vec (cut proc #f <>)))
148  (make-oper vector-map!/1 f32vector-mapi!/1 f64vector-mapi!/1) )
149
150(define vector%-foldi/1
151  ;(lambda (vec proc seed) (array-fold (cut proc #f <> <>) seed vec))
152  (make-oper vector-fold/1 f32vector-foldi/1 f64vector-foldi/1) )
153
154(define vector%-filled!
155  ;(lambda (vec func) (array-fold (lambda (x y) (func)) #f vec))
156  (make-oper vector-filled! f32vector-filled! f64vector-filled!) )
157
158(define (vector%-scale! vec factor)
159  (vector%-mapi!/1 vec (lambda (i elt) (* elt factor))) )
160
161(define (vector%-sum-squares vec)
162  (vector%-foldi/1 vec (lambda (i sum elt) (+ sum (* elt elt))) 0) )
163
164) ;module srfi-27-vector-support
Note: See TracBrowser for help on using the repository browser.