/[cl-gsl]/cl-gsl/vector.lisp
ViewVC logotype

Contents of /cl-gsl/vector.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Tue Mar 15 03:17:29 2005 UTC (9 years, 1 month ago) by edenny
Branch: MAIN
Changes since 1.3: +46 -13 lines
Can now actually set and get values from complex vectors. Bindings are
still leaky though.
1 ;;;; -*- Mode: Lisp; Synatx: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;;
3 ;;;; Copyright (C) 2005 Edgar Denny <edgardenny@comcast.net>
4 ;;;; This file is part of CL-GSL.
5 ;;;;
6 ;;;; This program is free software; you can redistribute it and/or modify
7 ;;;; it under the terms of the GNU General Public License as published by
8 ;;;; the Free Software Foundation; either version 2 of the License, or
9 ;;;; (at your option) any later version.
10 ;;;;
11 ;;;; This program is distributed in the hope that it will be useful,
12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;;; GNU General Public License for more details.
15 ;;;;
16 ;;;; You should have received a copy of the GNU General Public License
17 ;;;; along with this program; if not, write to the Free Software
18 ;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
19
20 (in-package #:cl-gsl-vector)
21
22 (defmacro def-vector-type-funcs% (typ)
23 (let ((type-ptr)
24 (type-val)
25 (type-val-ptr)
26 (type-string))
27 (cond
28 ((eq typ 'double-float)
29 (setq type-ptr 'gsl-vector-ptr)
30 (setq type-val :double)
31 (setq type-val-ptr '(* :double))
32 (setq type-string "vector"))
33 ((eq typ 'single-float)
34 (setq type-ptr 'gsl-vector-float-ptr)
35 (setq type-val :float)
36 (setq type-val-ptr '(* :float))
37 (setq type-string "vector_float"))
38 ((eq typ 'integer)
39 (setq type-ptr 'gsl-vector-int-ptr)
40 (setq type-val :int)
41 (setq type-val-ptr '(* :int))
42 (setq type-string "vector_int"))
43 ((equal typ '(complex (double-float)))
44 (setq type-ptr 'gsl-vector-complex-ptr)
45 (setq type-val 'gsl-complex)
46 (setq type-val-ptr '(* gsl-complex))
47 (setq type-string "vector_complex"))
48 ((equal typ '(complex (single-float)))
49 (setq type-ptr 'gsl-vector-complex-float-ptr)
50 (setq type-val 'gsl-complex-float)
51 (setq type-val-ptr '(* gsl-complex-float))
52 (setq type-string "vector_complex_float"))
53 (t
54 (error "no matching type.")))
55
56 `(progn
57 (defun-foreign ,(concatenate 'string "gsl_" type-string "_alloc")
58 ((size size-t))
59 ,type-ptr)
60
61 (defun-foreign ,(concatenate 'string "gsl_" type-string "_free")
62 ((v ,type-ptr))
63 :void)
64
65 (defun-foreign ,(concatenate 'string "gsl_" type-string "_get")
66 ((v ,type-ptr)
67 (i size-t))
68 ,type-val)
69
70 (defun-foreign ,(concatenate 'string "gsl_" type-string "_set")
71 ((v ,type-ptr)
72 (i size-t)
73 (x ,type-val))
74 :void)
75
76 (defun-foreign ,(concatenate 'string "gsl_" type-string "_set_all")
77 ((v ,type-ptr)
78 (x ,type-val))
79 :void)
80
81 (defun-foreign ,(concatenate 'string "gsl_" type-string "_set_zero")
82 ((v ,type-ptr))
83 :void)
84
85 (defun-foreign ,(concatenate 'string "gsl_" type-string "_set_basis")
86 ((v ,type-ptr)
87 (i size-t))
88 :void)
89
90 (defun-foreign ,(concatenate 'string "gsl_" type-string "_memcpy")
91 ((v1 ,type-ptr)
92 (v2 ,type-ptr))
93 :int)
94
95 (defun-foreign ,(concatenate 'string "gsl_" type-string "_swap")
96 ((v1 ,type-ptr)
97 (v2 ,type-ptr))
98 :int)
99
100 (defun-foreign ,(concatenate 'string "gsl_" type-string "_swap_elements")
101 ((v1 ,type-ptr)
102 (i size-t)
103 (j size-t))
104 :int)
105
106 (defun-foreign ,(concatenate 'string "gsl_" type-string "_reverse")
107 ((v1 ,type-ptr))
108 :int)
109
110 ,(unless (or (equal typ '(complex (double-float)))
111 (equal typ '(complex (single-float))))
112 `(defun-foreign ,(concatenate 'string "gsl_" type-string "_add")
113 ((va ,type-ptr)
114 (vb ,type-ptr))
115 :int))
116
117 ,(unless (or (equal typ '(complex (double-float)))
118 (equal typ '(complex (single-float))))
119 `(defun-foreign ,(concatenate 'string "gsl_" type-string "_sub")
120 ((va ,type-ptr)
121 (vb ,type-ptr))
122 :int))
123
124 ,(unless (or (equal typ '(complex (double-float)))
125 (equal typ '(complex (single-float))))
126 `(defun-foreign ,(concatenate 'string "gsl_" type-string "_mul")
127 ((va ,type-ptr)
128 (vb ,type-ptr))
129 :int))
130
131 ,(unless (or (equal typ '(complex (double-float)))
132 (equal typ '(complex (single-float))))
133 `(defun-foreign ,(concatenate 'string "gsl_" type-string "_div")
134 ((va ,type-ptr)
135 (vb ,type-ptr))
136 :int))
137
138 ,(unless (or (equal typ '(complex (double-float)))
139 (equal typ '(complex (single-float))))
140 `(defun-foreign ,(concatenate 'string "gsl_" type-string "_scale")
141 ((vec ,type-ptr)
142 (x ,type-val))
143 :int))
144
145 ,(unless (or (equal typ '(complex (double-float)))
146 (equal typ '(complex (single-float))))
147 `(defun-foreign ,(concatenate 'string
148 "gsl_" type-string "_add_constant")
149 ((vec ,type-ptr)
150 (x ,type-val))
151 :int))
152
153 ,(unless (or (equal typ '(complex (double-float)))
154 (equal typ '(complex (single-float))))
155 `(defun-foreign ,(concatenate 'string "gsl_" type-string "_max")
156 ((vec ,type-ptr))
157 ,type-val))
158
159 ,(unless (or (equal typ '(complex (double-float)))
160 (equal typ '(complex (single-float))))
161 `(defun-foreign ,(concatenate 'string "gsl_" type-string "_min")
162 ((vec ,type-ptr))
163 ,type-val))
164
165 ,(unless (or (equal typ '(complex (double-float)))
166 (equal typ '(complex (single-float))))
167 `(defun-foreign ,(concatenate 'string "gsl_" type-string "_minmax")
168 ((vec ,type-ptr)
169 (min ,type-val-ptr)
170 (max ,type-val-ptr))
171 :void))
172
173 ,(unless (or (equal typ '(complex (double-float)))
174 (equal typ '(complex (single-float))))
175 `(defun-foreign ,(concatenate 'string "gsl_" type-string "_max_index")
176 ((vec ,type-ptr))
177 size-t))
178
179 ,(unless (or (equal typ '(complex (double-float)))
180 (equal typ '(complex (single-float))))
181 `(defun-foreign ,(concatenate 'string "gsl_" type-string "_min_index")
182 ((vec ,type-ptr))
183 size-t))
184
185 ,(unless (or (equal typ '(complex (double-float)))
186 (equal typ '(complex (single-float))))
187 `(defun-foreign ,(concatenate 'string
188 "gsl_" type-string "_minmax_index")
189 ((vec ,type-ptr)
190 (min size-t-ptr)
191 (max size-t-ptr))
192 :void))
193
194 (defun-foreign ,(concatenate 'string "gsl_" type-string "_isnull")
195 ((vec ,type-ptr))
196 :int)
197
198 (defun-foreign ,(concatenate 'string "wrap_gsl_" type-string "_fwrite")
199 ((fn :cstring)
200 (v ,type-ptr))
201 :int)
202
203 (defun-foreign ,(concatenate 'string "wrap_gsl_" type-string "_fread")
204 ((fn :cstring)
205 (v ,type-ptr))
206 :int)
207
208 (defun-foreign ,(concatenate 'string "wrap_gsl_" type-string "_fprintf")
209 ((fn :cstring)
210 (v ,type-ptr))
211 :int)
212
213 (defun-foreign ,(concatenate 'string "wrap_gsl_" type-string "_fscanf")
214 ((fn :cstring)
215 (v ,type-ptr))
216 :int)
217
218 (defun-foreign ,(concatenate 'string "wrap_gsl_" type-string
219 "_subvector")
220 ((v gsl-vector-ptr)
221 (offset size-t)
222 (n size-t))
223 ,type-ptr)
224
225 (defun-foreign ,(concatenate 'string "wrap_gsl_" type-string
226 "_subvector_with_stride")
227 ((v gsl-vector-ptr)
228 (offset size-t)
229 (stride size-t)
230 (n size-t))
231 ,type-ptr))))
232
233
234 (defun-foreign "gsl_vector_complex_float_ptr"
235 ((v gsl-vector-complex-float-ptr)
236 (i size-t))
237 (* gsl-complex-float))
238
239 (defun-foreign "gsl_vector_complex_ptr"
240 ((v gsl-vector-complex-ptr)
241 (i size-t))
242 (* gsl-complex))
243
244 (defun-foreign "wrap_gsl_vector_complex_float_set"
245 ((v gsl-vector-complex-float-ptr)
246 (i size-t)
247 (z (* gsl-complex-float)))
248 :void)
249
250 (defun-foreign "wrap_gsl_vector_complex_set"
251 ((v gsl-vector-complex-ptr)
252 (i size-t)
253 (z (* gsl-complex)))
254 :void)
255
256 (defun-foreign "wrap_gsl_vector_complex_float_set_all"
257 ((v gsl-vector-complex-float-ptr)
258 (z (* gsl-complex-float)))
259 :void)
260
261 (defun-foreign "wrap_gsl_vector_complex_set_all"
262 ((v gsl-vector-complex-ptr)
263 (z (* gsl-complex)))
264 :void)
265
266 (def-vector-type-funcs% double-float)
267 (def-vector-type-funcs% single-float)
268 (def-vector-type-funcs% integer)
269 (def-vector-type-funcs% (complex (double-float)))
270 (def-vector-type-funcs% (complex (single-float)))
271
272 (defstruct gsl-vec
273 ;; TODO: print-function ?
274 ptr
275 size
276 element-type)
277
278 (defun alloc (v)
279 (assert (eq 'gsl-vec (type-of v)))
280 (cond
281 ((eq (gsl-vec-element-type v) 'integer)
282 (setf (gsl-vec-ptr v) (gsl-vector-int-alloc (gsl-vec-size v))))
283 ((eq (gsl-vec-element-type v) 'single-float)
284 (setf (gsl-vec-ptr v) (gsl-vector-float-alloc (gsl-vec-size v))))
285 ((eq (gsl-vec-element-type v) 'double-float)
286 (setf (gsl-vec-ptr v) (gsl-vector-alloc (gsl-vec-size v))))
287 ((equal (gsl-vec-element-type v) '(complex (single-float)))
288 (setf (gsl-vec-ptr v) (gsl-vector-complex-float-alloc (gsl-vec-size v))))
289 ((equal (gsl-vec-element-type v) '(complex (double-float)))
290 (setf (gsl-vec-ptr v) (gsl-vector-complex-alloc (gsl-vec-size v))))
291 (t
292 (error "No matching type"))))
293
294
295 (defun free (v)
296 (assert (eq 'gsl-vec (type-of v)))
297 (cond
298 ((eq (gsl-vec-element-type v) 'integer)
299 (gsl-vector-int-free (gsl-vec-ptr v)))
300 ((eq (gsl-vec-element-type v) 'single-float)
301 (gsl-vector-float-free (gsl-vec-ptr v)))
302 ((eq (gsl-vec-element-type v) 'double-float)
303 (gsl-vector-free (gsl-vec-ptr v)))
304 ((equal (gsl-vec-element-type v) '(complex (single-float)))
305 (gsl-vector-complex-float-free (gsl-vec-ptr v)))
306 ((equal (gsl-vec-element-type v) '(complex (double-float)))
307 (gsl-vector-complex-free (gsl-vec-ptr v)))
308 (t
309 (error "No matching type")))
310 (setf (gsl-vec-ptr v) nil)
311 (setf (gsl-vec-size v) nil)
312 (setf (gsl-vec-element-type v) nil))
313
314
315 (defun get-element (v i)
316 (assert (eq 'gsl-vec (type-of v)))
317 (assert (typep i 'integer))
318 (assert (< i (gsl-vec-size v)))
319 (cond
320 ((eq (gsl-vec-element-type v) 'integer)
321 (gsl-vector-int-get (gsl-vec-ptr v) i))
322 ((eq (gsl-vec-element-type v) 'single-float)
323 (gsl-vector-float-get (gsl-vec-ptr v) i))
324 ((eq (gsl-vec-element-type v) 'double-float)
325 (gsl-vector-get (gsl-vec-ptr v) i))
326 ((equal (gsl-vec-element-type v) '(complex (single-float)))
327 (gsl-complex-float->complex
328 (gsl-vector-complex-float-ptr (gsl-vec-ptr v) i)))
329 ((equal (gsl-vec-element-type v) '(complex (double-float)))
330 (gsl-complex->complex (gsl-vector-complex-ptr (gsl-vec-ptr v) i)))
331 (t
332 (error "No matching type"))))
333
334
335 (defun set-element (v i x)
336 (assert (eq 'gsl-vec (type-of v)))
337 (assert (typep x (gsl-vec-element-type v)))
338 (assert (typep i 'integer))
339 (assert (< i (gsl-vec-size v)))
340 (cond
341 ((eq (gsl-vec-element-type v) 'integer)
342 (gsl-vector-int-set (gsl-vec-ptr v) i x))
343 ((eq (gsl-vec-element-type v) 'single-float)
344 (gsl-vector-float-set (gsl-vec-ptr v) i x))
345 ((eq (gsl-vec-element-type v) 'double-float)
346 (gsl-vector-set (gsl-vec-ptr v) i x))
347 ((equal (gsl-vec-element-type v) '(complex (single-float)))
348 (wrap-gsl-vector-complex-float-set (gsl-vec-ptr v) i
349 (complex->gsl-complex-float-ptr x)))
350 ((equal (gsl-vec-element-type v) '(complex (double-float)))
351 (wrap-gsl-vector-complex-set (gsl-vec-ptr v) i
352 (complex->gsl-complex-ptr x)))
353 (t
354 (error "No matching type"))))
355
356
357 (defun set-all (v x)
358 (assert (eq 'gsl-vec (type-of v)))
359 (assert (typep x (gsl-vec-element-type v)))
360 (cond
361 ((eq (gsl-vec-element-type v) 'integer)
362 (gsl-vector-int-set-all (gsl-vec-ptr v) x))
363 ((eq (gsl-vec-element-type v) 'single-float)
364 (gsl-vector-float-set-all (gsl-vec-ptr v) x))
365 ((eq (gsl-vec-element-type v) 'double-float)
366 (gsl-vector-set-all (gsl-vec-ptr v) x))
367 ((equal (gsl-vec-element-type v) '(complex (single-float)))
368 (wrap-gsl-vector-complex-float-set-all (gsl-vec-ptr v)
369 (complex->gsl-complex-float-ptr x)))
370 ((equal (gsl-vec-element-type v) '(complex (double-float)))
371 (wrap-gsl-vector-complex-set-all (gsl-vec-ptr v)
372 (complex->gsl-complex-ptr x)))
373 (t
374 (error "No matching type"))))
375
376
377 (defun set-zero (v)
378 (assert (eq 'gsl-vec (type-of v)))
379 (cond
380 ((eq (gsl-vec-element-type v) 'integer)
381 (gsl-vector-int-set-zero (gsl-vec-ptr v)))
382 ((eq (gsl-vec-element-type v) 'single-float)
383 (gsl-vector-float-set-zero (gsl-vec-ptr v)))
384 ((eq (gsl-vec-element-type v) 'double-float)
385 (gsl-vector-set-zero (gsl-vec-ptr v)))
386 ((equal (gsl-vec-element-type v) '(complex (single-float)))
387 (gsl-vector-complex-float-set-zero (gsl-vec-ptr v)))
388 ((equal (gsl-vec-element-type v) '(complex (double-float)))
389 (gsl-vector-complex-set-zero (gsl-vec-ptr v)))
390 (t
391 (error "No matching type"))))
392
393
394 (defun set-basis (v i)
395 (assert (eq 'gsl-vec (type-of v)))
396 (assert (typep i 'integer))
397 (assert (< i (gsl-vec-size v)))
398 (cond
399 ((eq (gsl-vec-element-type v) 'integer)
400 (gsl-vector-int-set-basis (gsl-vec-ptr v) i))
401 ((eq (gsl-vec-element-type v) 'single-float)
402 (gsl-vector-float-set-basis (gsl-vec-ptr v) i))
403 ((eq (gsl-vec-element-type v) 'double-float)
404 (gsl-vector-set-basis (gsl-vec-ptr v) i))
405 ((equal (gsl-vec-element-type v) '(complex (single-float)))
406 (gsl-vector-complex-float-set-basis (gsl-vec-ptr v) i))
407 ((equal (gsl-vec-element-type v) '(complex (double-float)))
408 (gsl-vector-complex-set-basis (gsl-vec-ptr v) i))
409 (t
410 (error "No matching type"))))
411
412
413 (defun make-vector (size &key (element-type 'double-float) initial-element
414 initial-contents)
415 (assert (typep size 'integer))
416 (assert (find element-type '(integer single-float double-float
417 (complex (single-float))
418 (complex (double-float))) :test #'equal))
419 (let ((v (make-gsl-vec :size size :element-type element-type)))
420 (setf (gsl-vec-ptr v) (alloc v))
421 (cond
422 ((and initial-element initial-contents)
423 (error "cannot define both initial-element and initial-contents keys"))
424 (initial-element
425 (gsl-vector:set-all v initial-element))
426 (initial-contents
427 (cond
428 ((listp initial-contents)
429 (do ((x initial-contents (cdr x))
430 (i 0 (1+ i)))
431 ((= i size))
432 (gsl-vector:set-element v i (car x))))
433 ((vectorp initial-contents)
434 (do ((i 0 (1+ i)))
435 ((= i size))
436 (gsl-vector:set-element v i (aref initial-contents i))))
437 (t
438 (error "initial-contents must be either a list or a vector.")))))
439 v))
440
441
442 (defun write-to-binary-file (file-name v)
443 (assert (eq 'gsl-vec (type-of v)))
444 (let ((status))
445 ;; TODO: check if uffi:with-string returns a result, docs unclear.
446 (uffi:with-cstring (c-file-name file-name)
447 (setq status
448 (cond
449 ((eq (gsl-vec-element-type v) 'integer)
450 (wrap-gsl-vector-int-fwrite c-file-name (gsl-vec-ptr v)))
451 ((eq (gsl-vec-element-type v) 'single-float)
452 (wrap-gsl-vector-float-fwrite c-file-name (gsl-vec-ptr v)))
453 ((eq (gsl-vec-element-type v) 'double-float)
454 (wrap-gsl-vector-fwrite c-file-name (gsl-vec-ptr v)))
455 ((equal (gsl-vec-element-type v) '(complex (single-float)))
456 (wrap-gsl-vector-complex-float-fwrite c-file-name
457 (gsl-vec-ptr v)))
458 ((equal (gsl-vec-element-type v) '(complex (double-float)))
459 (wrap-gsl-vector-complex-fwrite c-file-name (gsl-vec-ptr v)))
460 (t
461 (error "No matching type")))))
462 status))
463
464
465 (defun write-to-file (file-name v)
466 (assert (eq 'gsl-vec (type-of v)))
467 (let ((status))
468 (uffi:with-cstring (c-file-name file-name)
469 (setq status
470 (cond
471 ((eq (gsl-vec-element-type v) 'integer)
472 (wrap-gsl-vector-int-fprintf c-file-name (gsl-vec-ptr v)))
473 ((eq (gsl-vec-element-type v) 'single-float)
474 (wrap-gsl-vector-float-fprintf c-file-name (gsl-vec-ptr v)))
475 ((eq (gsl-vec-element-type v) 'double-float)
476 (wrap-gsl-vector-fprintf c-file-name (gsl-vec-ptr v)))
477 ((equal (gsl-vec-element-type v) '(complex (single-float)))
478 (wrap-gsl-vector-complex-float-fprintf c-file-name
479 (gsl-vec-ptr v)))
480 ((equal (gsl-vec-element-type v) '(complex (double-float)))
481 (wrap-gsl-vector-complex-fprintf c-file-name (gsl-vec-ptr v)))
482 (t
483 (error "No matching type")))))
484 status))
485
486
487 (defun read-from-binary-file (file-name size element-type)
488 (let ((v (make-vector size :element-type element-type))
489 (status))
490 (uffi:with-cstring (c-file-name file-name)
491 (setq status
492 (cond
493 ((eq (gsl-vec-element-type v) 'integer)
494 (wrap-gsl-vector-int-fread c-file-name (gsl-vec-ptr v)))
495 ((eq (gsl-vec-element-type v) 'single-float)
496 (wrap-gsl-vector-float-fread c-file-name (gsl-vec-ptr v)))
497 ((eq (gsl-vec-element-type v) 'double-float)
498 (wrap-gsl-vector-fread c-file-name (gsl-vec-ptr v)))
499 ((equal (gsl-vec-element-type v) '(complex (single-float)))
500 (wrap-gsl-vector-complex-float-fread c-file-name (gsl-vec-ptr v)))
501 ((equal (gsl-vec-element-type v) '(complex (double-float)))
502 (wrap-gsl-vector-complex-fread c-file-name (gsl-vec-ptr v)))
503 (t
504 (error "No matching type")))))
505 (values v status)))
506
507
508 (defun read-from-file (file-name size element-type)
509 (let ((v (make-vector size :element-type element-type))
510 (status))
511 (uffi:with-cstring (c-file-name file-name)
512 (setq status
513 (cond
514 ((eq (gsl-vec-element-type v) 'integer)
515 (wrap-gsl-vector-int-fscanf c-file-name (gsl-vec-ptr v)))
516 ((eq (gsl-vec-element-type v) 'single-float)
517 (wrap-gsl-vector-float-fscanf c-file-name (gsl-vec-ptr v)))
518 ((eq (gsl-vec-element-type v) 'double-float)
519 (wrap-gsl-vector-fscanf c-file-name (gsl-vec-ptr v)))
520 ((equal (gsl-vec-element-type v) '(complex (single-float)))
521 (wrap-gsl-vector-complex-float-fscanf c-file-name
522 (gsl-vec-ptr v)))
523 ((equal (gsl-vec-element-type v) '(complex (double-float)))
524 (wrap-gsl-vector-complex-fscanf c-file-name (gsl-vec-ptr v)))
525 (t
526 (error "No matching type")))))
527 (values v status)))
528
529
530 (defun subvector (v offset n)
531 (assert (eq 'gsl-vec (type-of v)))
532 (assert (typep offset 'integer))
533 (assert (typep n 'integer))
534 (assert (< (+ offset n) (gsl-vec-size v)))
535 ;; use make-gsl-vec here rather than make-vector - we do not want to
536 ;; allocate any foreign memory for the subvector.
537 (let ((v-sub (make-gsl-vec :size n :element-type (gsl-vec-element-type v))))
538 (setf (gsl-vec-ptr v-sub)
539 (cond
540 ((eq (gsl-vec-element-type v) 'integer)
541 (wrap-gsl-vector-int-subvector (gsl-vec-ptr v) offset n))
542 ((eq (gsl-vec-element-type v) 'single-float)
543 (wrap-gsl-vector-float-subvector (gsl-vec-ptr v) offset n))
544 ((eq (gsl-vec-element-type v) 'double-float)
545 (wrap-gsl-vector-subvector (gsl-vec-ptr v) offset n))
546 ((equal (gsl-vec-element-type v) '(complex (single-float)))
547 (wrap-gsl-vector-complex-float-subvector (gsl-vec-ptr v) offset n))
548 ((equal (gsl-vec-element-type v) '(complex (double-float)))
549 (wrap-gsl-vector-complex-subvector (gsl-vec-ptr v) offset n))
550 (t
551 (error "No matching type"))))
552 v-sub))
553
554
555 (defun subvector-with-stride (v offset stride n)
556 (assert (eq 'gsl-vec (type-of v)))
557 (assert (typep offset 'integer))
558 (assert (typep stride 'integer))
559 (assert (typep n 'integer))
560 (assert (< (* (+ offset n) stride) (gsl-vec-size v)))
561 ;; use make-gsl-vec here rather than make-vector - we do not want to
562 ;; allocate any foreign memory for the subvector.
563 (let ((v-sub (make-gsl-vec :size n :element-type (gsl-vec-element-type v))))
564 (setf (gsl-vec-ptr v-sub)
565 (cond
566 ((eq (gsl-vec-element-type v) 'integer)
567 (wrap-gsl-vector-int-subvector-with-stride (gsl-vec-ptr v)
568 offset stride n))
569 ((eq (gsl-vec-element-type v) 'single-float)
570 (wrap-gsl-vector-float-subvector-with-stride (gsl-vec-ptr v)
571 offset stride n))
572 ((eq (gsl-vec-element-type v) 'double-float)
573 (wrap-gsl-vector-subvector-with-stride (gsl-vec-ptr v)
574 offset stride n))
575 ((equal (gsl-vec-element-type v) '(complex (single-float)))
576 (wrap-gsl-vector-complex-float-subvector-with-stride
577 (gsl-vec-ptr v) offset stride n))
578 ((equal (gsl-vec-element-type v) '(complex (double-float)))
579 (wrap-gsl-vector-complex-subvector-with-stride (gsl-vec-ptr v)
580 offset stride n))
581 (t
582 (error "No matching type"))))
583 v-sub))
584
585
586 (defun copy (v-src)
587 (assert (eq 'gsl-vec (type-of v-src)))
588 (let* ((v-dest (make-vector (gsl-vec-size v-src)
589 :element-type (gsl-vec-element-type v-src)))
590 (status (cond
591 ((eq (gsl-vec-element-type v-src) 'integer)
592 (gsl-vector-int-memcpy (gsl-vec-ptr v-dest)
593 (gsl-vec-ptr v-src)))
594 ((eq (gsl-vec-element-type v-src) 'single-float)
595 (gsl-vector-float-memcpy (gsl-vec-ptr v-dest)
596 (gsl-vec-ptr v-src)))
597 ((eq (gsl-vec-element-type v-src) 'double-float)
598 (gsl-vector-memcpy (gsl-vec-ptr v-dest)
599 (gsl-vec-ptr v-src)))
600 ((equal (gsl-vec-element-type v-src)
601 '(complex (single-float)))
602 (gsl-vector-complex-float-memcpy (gsl-vec-ptr v-dest)
603 (gsl-vec-ptr v-src)))
604 ((equal (gsl-vec-element-type v-src)
605 '(complex (double-float)))
606 (gsl-vector-complex-memcpy (gsl-vec-ptr v-dest)
607 (gsl-vec-ptr v-src)))
608 (t
609 (error "No matching type")))))
610 (values v-dest status)))
611
612
613 (defun swap (va vb)
614 (assert (eq 'gsl-vec (type-of va)))
615 (assert (eq 'gsl-vec (type-of vb)))
616 (assert (eq (gsl-vec-element-type va) (gsl-vec-element-type vb)))
617 (assert (= (gsl-vec-size va) (gsl-vec-size vb)))
618 (let ((status
619 (cond
620 ((eq (gsl-vec-element-type va) 'integer)
621 (gsl-vector-int-swap (gsl-vec-ptr va) (gsl-vec-ptr vb)))
622 ((eq (gsl-vec-element-type va) 'single-float)
623 (gsl-vector-float-swap (gsl-vec-ptr va) (gsl-vec-ptr vb)))
624 ((eq (gsl-vec-element-type va) 'double-float)
625 (gsl-vector-swap (gsl-vec-ptr va) (gsl-vec-ptr vb)))
626 ((equal (gsl-vec-element-type va) '(complex (single-float)))
627 (gsl-vector-complex-float-swap (gsl-vec-ptr va) (gsl-vec-ptr vb)))
628 ((equal (gsl-vec-element-type va) '(complex (double-float)))
629 (gsl-vector-complex-swap (gsl-vec-ptr va) (gsl-vec-ptr vb)))
630 (t
631 (error "No matching type")))))
632 (values va status)))
633
634
635 (defun swap-elements (v i j)
636 (assert (eq 'gsl-vec (type-of v)))
637 (assert (typep i 'integer))
638 (assert (typep j 'integer))
639 (assert (< i (gsl-vec-size v)))
640 (assert (< j (gsl-vec-size v)))
641 (let ((status
642 (cond
643 ((eq (gsl-vec-element-type v) 'integer)
644 (gsl-vector-int-swap-elements (gsl-vec-ptr v) i j))
645 ((eq (gsl-vec-element-type v) 'single-float)
646 (gsl-vector-float-swap-elements (gsl-vec-ptr v) i j))
647 ((eq (gsl-vec-element-type v) 'double-float)
648 (gsl-vector-swap-elements (gsl-vec-ptr v) i j))
649 ((equal (gsl-vec-element-type v) '(complex (single-float)))
650 (gsl-vector-complex-float-swap-elements (gsl-vec-ptr v) i j))
651 ((equal (gsl-vec-element-type v) '(complex (double-float)))
652 (gsl-vector-complex-swap-elements (gsl-vec-ptr v) i j))
653 (t
654 (error "No matching type")))))
655 (values v status)))
656
657
658 (defun reverse-vector (v)
659 (assert (eq 'gsl-vec (type-of v)))
660 (let ((status
661 (cond
662 ((eq (gsl-vec-element-type v) 'integer)
663 (gsl-vector-int-reverse (gsl-vec-ptr v)))
664 ((eq (gsl-vec-element-type v) 'single-float)
665 (gsl-vector-float-reverse (gsl-vec-ptr v)))
666 ((eq (gsl-vec-element-type v) 'double-float)
667 (gsl-vector-reverse (gsl-vec-ptr v)))
668 ((equal (gsl-vec-element-type v) '(complex (single-float)))
669 (gsl-vector-complex-float-reverse (gsl-vec-ptr v)))
670 ((equal (gsl-vec-element-type v) '(complex (double-float)))
671 (gsl-vector-complex-reverse (gsl-vec-ptr v)))
672 (t
673 (error "No matching type")))))
674 (values v status)))
675
676
677 (defun add (va vb)
678 (assert (eq 'gsl-vec (type-of va)))
679 (assert (eq 'gsl-vec (type-of vb)))
680 (assert (eq (gsl-vec-element-type va) (gsl-vec-element-type vb)))
681 (assert (= (gsl-vec-size va) (gsl-vec-size vb)))
682 (let ((status
683 (cond
684 ((eq (gsl-vec-element-type va) 'integer)
685 (gsl-vector-int-add (gsl-vec-ptr va) (gsl-vec-ptr vb)))
686 ((eq (gsl-vec-element-type va) 'single-float)
687 (gsl-vector-float-add (gsl-vec-ptr va) (gsl-vec-ptr vb)))
688 ((eq (gsl-vec-element-type va) 'double-float)
689 (gsl-vector-add (gsl-vec-ptr va) (gsl-vec-ptr vb)))
690 (t
691 (error "No matching type")))))
692 (values va status)))
693
694
695 (defun sub (va vb)
696 (assert (eq 'gsl-vec (type-of va)))
697 (assert (eq 'gsl-vec (type-of vb)))
698 (assert (eq (gsl-vec-element-type va) (gsl-vec-element-type vb)))
699 (assert (= (gsl-vec-size va) (gsl-vec-size vb)))
700 (let ((status
701 (cond
702 ((eq (gsl-vec-element-type va) 'integer)
703 (gsl-vector-int-sub (gsl-vec-ptr va) (gsl-vec-ptr vb)))
704 ((eq (gsl-vec-element-type va) 'single-float)
705 (gsl-vector-float-sub (gsl-vec-ptr va) (gsl-vec-ptr vb)))
706 ((eq (gsl-vec-element-type va) 'double-float)
707 (gsl-vector-sub (gsl-vec-ptr va) (gsl-vec-ptr vb)))
708 (t
709 (error "No matching type")))))
710 (values va status)))
711
712
713 (defun mul (va vb)
714 (assert (eq 'gsl-vec (type-of va)))
715 (assert (eq 'gsl-vec (type-of vb)))
716 (assert (eq (gsl-vec-element-type va) (gsl-vec-element-type vb)))
717 (assert (= (gsl-vec-size va) (gsl-vec-size vb)))
718 (let ((status
719 (cond
720 ((eq (gsl-vec-element-type va) 'integer)
721 (gsl-vector-int-mul (gsl-vec-ptr va) (gsl-vec-ptr vb)))
722 ((eq (gsl-vec-element-type va) 'single-float)
723 (gsl-vector-float-mul (gsl-vec-ptr va) (gsl-vec-ptr vb)))
724 ((eq (gsl-vec-element-type va) 'double-float)
725 (gsl-vector-mul (gsl-vec-ptr va) (gsl-vec-ptr vb)))
726 (t
727 (error "No matching type")))))
728 (values va status)))
729
730
731 (defun div (va vb)
732 (assert (eq 'gsl-vec (type-of va)))
733 (assert (eq 'gsl-vec (type-of vb)))
734 (assert (eq (gsl-vec-element-type va) (gsl-vec-element-type vb)))
735 (assert (= (gsl-vec-size va) (gsl-vec-size vb)))
736 (let ((status
737 (cond
738 ((eq (gsl-vec-element-type va) 'integer)
739 (gsl-vector-int-div (gsl-vec-ptr va) (gsl-vec-ptr vb)))
740 ((eq (gsl-vec-element-type va) 'single-float)
741 (gsl-vector-float-div (gsl-vec-ptr va) (gsl-vec-ptr vb)))
742 ((eq (gsl-vec-element-type va) 'double-float)
743 (gsl-vector-div (gsl-vec-ptr va) (gsl-vec-ptr vb)))
744 (t
745 (error "No matching type")))))
746 (values va status)))
747
748
749 (defun scale (v x)
750 (assert (eq 'gsl-vec (type-of v)))
751 (assert (typep x (gsl-vec-element-type v)))
752 (let ((status
753 (cond
754 ((eq (gsl-vec-element-type v) 'integer)
755 (gsl-vector-int-scale (gsl-vec-ptr v) x))
756 ((eq (gsl-vec-element-type v) 'single-float)
757 (gsl-vector-float-scale (gsl-vec-ptr v) x))
758 ((eq (gsl-vec-element-type v) 'double-float)
759 (gsl-vector-scale (gsl-vec-ptr v) x))
760 (t
761 (error "No matching type")))))
762 (values v status)))
763
764
765 (defun add-constant (v x)
766 (assert (eq 'gsl-vec (type-of v)))
767 (assert (typep x (gsl-vec-element-type v)))
768 (let ((status
769 (cond
770 ((eq (gsl-vec-element-type v) 'integer)
771 (gsl-vector-int-add-constant (gsl-vec-ptr v) x))
772 ((eq (gsl-vec-element-type v) 'single-float)
773 (gsl-vector-float-add-constant (gsl-vec-ptr v) x))
774 ((eq (gsl-vec-element-type v) 'double-float)
775 (gsl-vector-add-constant (gsl-vec-ptr v) x))
776 (t
777 (error "No matching type")))))
778 (values v status)))
779
780
781 (defun max-value (v)
782 (assert (eq 'gsl-vec (type-of v)))
783 (cond
784 ((eq (gsl-vec-element-type v) 'integer)
785 (gsl-vector-int-max (gsl-vec-ptr v)))
786 ((eq (gsl-vec-element-type v) 'single-float)
787 (gsl-vector-float-max (gsl-vec-ptr v)))
788 ((eq (gsl-vec-element-type v) 'double-float)
789 (gsl-vector-max (gsl-vec-ptr v)))
790 (t
791 (error "No matching type"))))
792
793
794 (defun min-value (v)
795 (assert (eq 'gsl-vec (type-of v)))
796 (cond
797 ((eq (gsl-vec-element-type v) 'integer)
798 (gsl-vector-int-min (gsl-vec-ptr v)))
799 ((eq (gsl-vec-element-type v) 'single-float)
800 (gsl-vector-float-min (gsl-vec-ptr v)))
801 ((eq (gsl-vec-element-type v) 'double-float)
802 (gsl-vector-min (gsl-vec-ptr v)))
803 (t
804 (error "No matching type"))))
805
806
807 (defun max-index (v)
808 (assert (eq 'gsl-vec (type-of v)))
809 (cond
810 ((eq (gsl-vec-element-type v) 'integer)
811 (gsl-vector-int-max-index (gsl-vec-ptr v)))
812 ((eq (gsl-vec-element-type v) 'single-float)
813 (gsl-vector-float-max-index (gsl-vec-ptr v)))
814 ((eq (gsl-vec-element-type v) 'double-float)
815 (gsl-vector-max-index (gsl-vec-ptr v)))
816 (t
817 (error "No matching type"))))
818
819
820 (defun min-index (v)
821 (assert (eq 'gsl-vec (type-of v)))
822 (cond
823 ((eq (gsl-vec-element-type v) 'integer)
824 (gsl-vector-int-min-index (gsl-vec-ptr v)))
825 ((eq (gsl-vec-element-type v) 'single-float)
826 (gsl-vector-float-min-index (gsl-vec-ptr v)))
827 ((eq (gsl-vec-element-type v) 'double-float)
828 (gsl-vector-min-index (gsl-vec-ptr v)))
829 (t
830 (error "No matching type"))))
831
832
833 (defun min-max-indicies (v)
834 (assert (eq 'gsl-vec (type-of v)))
835 (let ((min-ptr (uffi:allocate-foreign-object 'size-t))
836 (max-ptr (uffi:allocate-foreign-object 'size-t)))
837 (cond
838 ((eq (gsl-vec-element-type v) 'integer)
839 (gsl-vector-int-minmax-index (gsl-vec-ptr v) min-ptr max-ptr))
840 ((eq (gsl-vec-element-type v) 'single-float)
841 (gsl-vector-float-minmax-index (gsl-vec-ptr v) min-ptr max-ptr))
842 ((eq (gsl-vec-element-type v) 'double-float)
843 (gsl-vector-minmax-index (gsl-vec-ptr v) min-ptr max-ptr))
844 (t
845 (error "No matching type")))
846 (prog1
847 (list (uffi:deref-pointer min-ptr 'size-t)
848 (uffi:deref-pointer max-ptr 'size-t))
849 (uffi:free-foreign-object min-ptr)
850 (uffi:free-foreign-object max-ptr))))
851
852
853 (defun min-max-values (v)
854 (assert (eq 'gsl-vec (type-of v)))
855 (destructuring-bind (min-index max-index)
856 (min-max-indicies v)
857 (list (get-element v min-index)
858 (get-element v max-index))))
859
860
861 (defun isnull (v)
862 (assert (eq 'gsl-vec (type-of v)))
863 (1/0->t/nil (cond
864 ((eq (gsl-vec-element-type v) 'integer)
865 (gsl-vector-int-isnull (gsl-vec-ptr v)))
866 ((eq (gsl-vec-element-type v) 'single-float)
867 (gsl-vector-float-isnull (gsl-vec-ptr v)))
868 ((eq (gsl-vec-element-type v) 'double-float)
869 (gsl-vector-isnull (gsl-vec-ptr v)))
870 ((equal (gsl-vec-element-type v) '(complex (single-float)))
871 (gsl-vector-complex-float-isnull (gsl-vec-ptr v)))
872 ((equal (gsl-vec-element-type v) '(complex (double-float)))
873 (gsl-vector-complex-isnull (gsl-vec-ptr v)))
874 (t
875 (error "No matching type")))))
876
877 ;; Function: gsl_vector_view gsl_vector_complex_real (gsl_vector_complex *v)
878 ;; Function: gsl_vector_view gsl_vector_complex_imag (gsl_vector_complex *v)
879
880 ;; ----------------------------------------------------------------------
881 ;; Functions that I don't think need binding.
882 ;;
883
884 ;; Function: gsl_vector * gsl_vector_calloc (size_t n)
885
886 ;; Function: double * gsl_vector_ptr (gsl_vector * v, size_t i)
887 ;; Function: const double * gsl_vector_const_ptr (const gsl_vector * v, size_t i)
888
889 ;; Function: gsl_vector_const_view gsl_vector_const_subvector (const gsl_vector * v, size_t offset, size_t n)
890
891 ;; Function: gsl_vector_const_view gsl_vector_const_subvector_with_stride (const gsl_vector * v, size_t offset, size_t stride, size_t n)
892
893 ;; Function: gsl_vector_const_view gsl_vector_complex_const_real (const gsl_vector_complex *v)
894
895 ;; Function: gsl_vector_const_view gsl_vector_complex_const_imag (const gsl_vector_complex *v)
896
897 ;; Function: gsl_vector_view gsl_vector_view_array_with_stride (double * base, size_t stride, size_t n)
898 ;; Function: gsl_vector_const_view gsl_vector_const_view_array_with_stride (const double * base, size_t stride, size_t n)
899

  ViewVC Help
Powered by ViewVC 1.1.5