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

Contents of /cl-gsl/vector.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (show annotations)
Sat Apr 30 22:37:00 2005 UTC (8 years, 11 months ago) by edenny
Branch: MAIN
CVS Tags: HEAD
Changes since 1.9: +1 -0 lines
Added a TODO note.
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-array)
21
22
23 (defclass gsl-vector ()
24 ((ptr :accessor ptr :initarg :ptr)
25 (size :accessor size :initarg :size)
26 (element-type :accessor element-type :initarg :element-type)))
27
28 ;; TODO: have a (defmethod initialize-instance : after) that calls alloc?
29
30 (defclass gsl-vector-double-float (gsl-vector) ())
31 (defclass gsl-vector-single-float (gsl-vector) ())
32 (defclass gsl-vector-integer (gsl-vector) ())
33 (defclass gsl-vector-complex-double-float (gsl-vector) ())
34 (defclass gsl-vector-complex-single-float (gsl-vector) ())
35
36
37 (defmacro def-vector-type-funcs% (typ)
38 (let ((type-ptr)
39 (type-val)
40 (type-val-ptr)
41 (type-string)
42 (is-real (or (eq typ 'double-float)
43 (eq typ 'single-float)
44 (eq typ 'integer))))
45 (cond
46 ((eq typ 'double-float)
47 (setq type-ptr 'gsl-vector-ptr)
48 (setq type-val :double)
49 (setq type-val-ptr '(* :double))
50 (setq type-string "vector"))
51 ((eq typ 'single-float)
52 (setq type-ptr 'gsl-vector-float-ptr)
53 (setq type-val :float)
54 (setq type-val-ptr '(* :float))
55 (setq type-string "vector_float"))
56 ((eq typ 'integer)
57 (setq type-ptr 'gsl-vector-int-ptr)
58 (setq type-val :int)
59 (setq type-val-ptr '(* :int))
60 (setq type-string "vector_int"))
61 ((equal typ '(complex (double-float)))
62 (setq type-ptr 'gsl-vector-complex-ptr)
63 (setq type-val 'gsl-complex)
64 (setq type-val-ptr '(* gsl-complex))
65 (setq type-string "vector_complex"))
66 ((equal typ '(complex (single-float)))
67 (setq type-ptr 'gsl-vector-complex-float-ptr)
68 (setq type-val 'gsl-complex-float)
69 (setq type-val-ptr '(* gsl-complex-float))
70 (setq type-string "vector_complex_float"))
71 (t
72 (error "no matching type.")))
73
74 `(progn
75 (defun-foreign ,(concatenate 'string "gsl_" type-string "_alloc")
76 ((size size-t))
77 ,type-ptr)
78
79 (defun-foreign ,(concatenate 'string "gsl_" type-string "_free")
80 ((v ,type-ptr))
81 :void)
82
83 (defun-foreign ,(concatenate 'string "gsl_" type-string "_get")
84 ((v ,type-ptr)
85 (i size-t))
86 ,type-val)
87
88 (defun-foreign ,(concatenate 'string "gsl_" type-string "_set")
89 ((v ,type-ptr)
90 (i size-t)
91 (x ,type-val))
92 :void)
93
94 (defun-foreign ,(concatenate 'string "gsl_" type-string "_set_all")
95 ((v ,type-ptr)
96 (x ,type-val))
97 :void)
98
99 (defun-foreign ,(concatenate 'string "gsl_" type-string "_set_zero")
100 ((v ,type-ptr))
101 :void)
102
103 (defun-foreign ,(concatenate 'string "gsl_" type-string "_set_basis")
104 ((v ,type-ptr)
105 (i size-t))
106 :void)
107
108 (defun-foreign ,(concatenate 'string "gsl_" type-string "_memcpy")
109 ((v1 ,type-ptr)
110 (v2 ,type-ptr))
111 :int)
112
113 (defun-foreign ,(concatenate 'string "gsl_" type-string "_swap")
114 ((v1 ,type-ptr)
115 (v2 ,type-ptr))
116 :int)
117
118 (defun-foreign ,(concatenate 'string "gsl_" type-string "_swap_elements")
119 ((v1 ,type-ptr)
120 (i size-t)
121 (j size-t))
122 :int)
123
124 (defun-foreign ,(concatenate 'string "gsl_" type-string "_reverse")
125 ((v1 ,type-ptr))
126 :int)
127
128 (defun-foreign ,(concatenate 'string "gsl_" type-string "_isnull")
129 ((vec ,type-ptr))
130 :int)
131
132 (defun-foreign ,(concatenate 'string "wrap_gsl_" type-string "_fwrite")
133 ((fn :cstring)
134 (v ,type-ptr))
135 :int)
136
137 (defun-foreign ,(concatenate 'string "wrap_gsl_" type-string "_fread")
138 ((fn :cstring)
139 (v ,type-ptr))
140 :int)
141
142 (defun-foreign ,(concatenate 'string "wrap_gsl_" type-string "_fprintf")
143 ((fn :cstring)
144 (v ,type-ptr))
145 :int)
146
147 (defun-foreign ,(concatenate 'string "wrap_gsl_" type-string "_fscanf")
148 ((fn :cstring)
149 (v ,type-ptr))
150 :int)
151
152 (defun-foreign ,(concatenate 'string "wrap_gsl_" type-string
153 "_subvector")
154 ((v ,type-ptr)
155 (offset size-t)
156 (n size-t))
157 ,type-ptr)
158
159 (defun-foreign ,(concatenate 'string "wrap_gsl_" type-string
160 "_subvector_with_stride")
161 ((v ,type-ptr)
162 (offset size-t)
163 (stride size-t)
164 (n size-t))
165 ,type-ptr)
166
167 ,(when is-real
168 `(progn
169 (defun-foreign ,(concatenate 'string "gsl_" type-string "_add")
170 ((va ,type-ptr)
171 (vb ,type-ptr))
172 :int)
173
174 (defun-foreign ,(concatenate 'string "gsl_" type-string "_sub")
175 ((va ,type-ptr)
176 (vb ,type-ptr))
177 :int)
178
179 (defun-foreign ,(concatenate 'string "gsl_" type-string "_mul")
180 ((va ,type-ptr)
181 (vb ,type-ptr))
182 :int)
183
184 (defun-foreign ,(concatenate 'string "gsl_" type-string "_div")
185 ((va ,type-ptr)
186 (vb ,type-ptr))
187 :int)
188
189 (defun-foreign ,(concatenate 'string "gsl_" type-string "_scale")
190 ((vec ,type-ptr)
191 ;; seems odd that this is :double for all types
192 (x :double))
193 :int)
194
195 (defun-foreign ,(concatenate 'string
196 "gsl_" type-string "_add_constant")
197 ((vec ,type-ptr)
198 ;; and again, :double for all types
199 (x :double))
200 :int)
201
202 (defun-foreign ,(concatenate 'string "gsl_" type-string "_max")
203 ((vec ,type-ptr))
204 ,type-val)
205
206 (defun-foreign ,(concatenate 'string "gsl_" type-string "_min")
207 ((vec ,type-ptr))
208 ,type-val)
209
210 (defun-foreign ,(concatenate 'string "gsl_" type-string "_minmax")
211 ((vec ,type-ptr)
212 (min ,type-val-ptr)
213 (max ,type-val-ptr))
214 :void)
215
216 (defun-foreign ,(concatenate 'string
217 "gsl_" type-string "_max_index")
218 ((vec ,type-ptr))
219 size-t)
220
221 (defun-foreign ,(concatenate 'string
222 "gsl_" type-string "_min_index")
223 ((vec ,type-ptr))
224 size-t)
225
226 (defun-foreign ,(concatenate 'string
227 "gsl_" type-string "_minmax_index")
228 ((vec ,type-ptr)
229 (min size-t-ptr)
230 (max size-t-ptr))
231 :void)
232 ))
233
234 ,(when (not is-real)
235 `(progn
236 (defun-foreign ,(concatenate 'string "gsl_" type-string "_ptr")
237 ((v ,type-ptr)
238 (i size-t))
239 (* ,type-val))
240
241 (defun-foreign ,(concatenate 'string "wrap_gsl_" type-string "_set")
242 ((v ,type-ptr)
243 (i size-t)
244 (z (* ,type-val)))
245 :void)
246
247 (defun-foreign ,(concatenate 'string
248 "wrap_gsl_" type-string "_set_all")
249 ((v ,type-ptr)
250 (z (* ,type-val)))
251 :void)))
252 )))
253
254
255 (def-vector-type-funcs% double-float)
256 (def-vector-type-funcs% single-float)
257 (def-vector-type-funcs% integer)
258 (def-vector-type-funcs% (complex (double-float)))
259 (def-vector-type-funcs% (complex (single-float)))
260
261
262 (defmacro def-vector-methods% (class-string func-string)
263 (let ((class-object (kmrcl:concat-symbol "gsl-vector-" class-string))
264 (is-real (or (string= class-string "integer")
265 (string= class-string "single-float")
266 (string= class-string "double-float"))))
267 `(progn
268
269 (defmethod alloc ((o ,class-object))
270 (setf (ptr o) (,(kmrcl:concat-symbol "gsl-vector-" func-string "alloc")
271 (size o)))
272 o)
273
274 (defmethod free ((o ,class-object))
275 (,(kmrcl:concat-symbol "gsl-vector-" func-string "free") (ptr o))
276 (setf (ptr o) nil)
277 (setf (size o) nil)
278 (setf (element-type o) nil))
279
280
281 (defmethod get-element ((o ,class-object) i &optional j)
282 (assert (and (typep i 'integer) (>= i 0) (< i (size o))))
283 ,(if is-real
284 `(,(kmrcl:concat-symbol "gsl-vector-" func-string "get")
285 (ptr o) i)
286 `(,(kmrcl:concat-symbol "gsl-" func-string ">complex")
287 (,(kmrcl:concat-symbol "gsl-vector-" func-string "ptr")
288 (ptr o) i))))
289
290 (defmethod set-element ((o ,class-object) i &optional x dummy)
291 (assert (typep x (element-type o)))
292 (assert (and (typep i 'integer) (>= i 0) (< i (size o))))
293 ,(if is-real
294 `(,(kmrcl:concat-symbol "gsl-vector-" func-string "set")
295 (ptr o) i x)
296 `(,(kmrcl:concat-symbol "with-" class-string "->gsl-" func-string
297 "ptr") (c-ptr x)
298 (,(kmrcl:concat-symbol "wrap-gsl-vector-" func-string "set")
299 (ptr o) i c-ptr)))
300 x)
301
302 (defmethod set-all ((o ,class-object) x)
303 (assert (typep x (element-type o)))
304 ,(if is-real
305 `(,(kmrcl:concat-symbol "gsl-vector-" func-string "set-all")
306 (ptr o) x)
307 `(,(kmrcl:concat-symbol "with-" class-string "->gsl-" func-string
308 "ptr") (c-ptr x)
309 (,(kmrcl:concat-symbol "wrap-gsl-vector-" func-string "set-all")
310 (ptr o) c-ptr)))
311 o)
312
313 (defmethod set-zero ((o ,class-object))
314 (,(kmrcl:concat-symbol "gsl-vector-" func-string "set-zero") (ptr o))
315 o)
316
317
318 (defmethod set-basis ((o ,class-object) i)
319 (assert (typep i 'integer))
320 (assert (and (>= i 0) (< i (size o))))
321 (,(kmrcl:concat-symbol "gsl-vector-" func-string "set-basis")
322 (ptr o) i)
323 o)
324
325
326 (defmethod read-from-binary-file ((o ,class-object) file-name)
327 (let ((status))
328 (uffi:with-cstring (c-file-name file-name)
329 (setq status
330 (,(kmrcl:concat-symbol "wrap-gsl-vector-" func-string
331 "fread") c-file-name (ptr o))))
332 (values o status)))
333
334 (defmethod read-from-file ((o ,class-object) file-name)
335 (let ((status))
336 (uffi:with-cstring (c-file-name file-name)
337 (setq status
338 (,(kmrcl:concat-symbol "wrap-gsl-vector-" func-string
339 "fscanf") c-file-name (ptr o))))
340 (values o status)))
341
342 (defmethod write-to-binary-file (file-name (o ,class-object))
343 (let ((status))
344 ;; TODO: check if uffi:with-string returns a result, docs unclear.
345 (uffi:with-cstring (c-file-name file-name)
346 (setq status
347 (,(kmrcl:concat-symbol "wrap-gsl-vector-" func-string
348 "fwrite") c-file-name (ptr o))))
349 status))
350
351 (defmethod write-to-file (file-name (o ,class-object))
352 (let ((status))
353 (uffi:with-cstring (c-file-name file-name)
354 (setq status
355 (,(kmrcl:concat-symbol "wrap-gsl-vector-" func-string
356 "fprintf") c-file-name (ptr o))))
357 status))
358
359 (defmethod swap ((o1 ,class-object) (o2 ,class-object))
360 (assert (= (size o1) (size o2)))
361 (let ((status (,(kmrcl:concat-symbol "gsl-vector-" func-string
362 "swap") (ptr o1) (ptr o2))))
363 (values o1 status)))
364
365 (defmethod swap-elements ((o ,class-object) i j)
366 (assert (and (typep i 'integer) (>= i 0) (< i (size o))))
367 (assert (and (typep j 'integer) (>= j 0) (< j (size o))))
368 (let ((status (,(kmrcl:concat-symbol "gsl-vector-" func-string
369 "swap-elements") (ptr o) i j)))
370 (values o status)))
371
372 (defmethod reverse-vector ((o ,class-object))
373 (let ((status (,(kmrcl:concat-symbol "gsl-vector-" func-string
374 "reverse") (ptr o))))
375 (values o status)))
376
377
378 (defmethod isnull ((o ,class-object))
379 (1/0->t/nil (,(kmrcl:concat-symbol "gsl-vector-" func-string
380 "isnull") (ptr o))))
381
382 ,(when is-real
383 `(progn
384 (defmethod add ((o1 ,class-object) (o2 ,class-object))
385 (assert (= (size o1) (size o2)))
386 (let ((status (,(kmrcl:concat-symbol "gsl-vector-" func-string
387 "add") (ptr o1) (ptr o2))))
388 (values o1 status)))
389
390 (defmethod sub ((o1 ,class-object) (o2 ,class-object))
391 (assert (= (size o1) (size o2)))
392 (let ((status (,(kmrcl:concat-symbol "gsl-vector-" func-string
393 "sub") (ptr o1) (ptr o2))))
394 (values o1 status)))
395
396 (defmethod mul ((o1 ,class-object) (o2 ,class-object))
397 (assert (= (size o1) (size o2)))
398 (let ((status (,(kmrcl:concat-symbol "gsl-vector-" func-string
399 "mul") (ptr o1) (ptr o2))))
400 (values o1 status)))
401
402 (defmethod div ((o1 ,class-object) (o2 ,class-object))
403 (assert (= (size o1) (size o2)))
404 (let ((status (,(kmrcl:concat-symbol "gsl-vector-" func-string
405 "div") (ptr o1) (ptr o2))))
406 (values o1 status)))
407
408 (defmethod scale ((o ,class-object) x)
409 (assert (typep x (element-type o)))
410 ;; coerce to double-float looks wrong, but isn't.
411 (,(kmrcl:concat-symbol "gsl-vector-" func-string "scale")
412 (ptr o) (coerce x 'double-float)))
413
414 (defmethod add-constant ((o ,class-object) x)
415 (assert (typep x (element-type o)))
416 ;; coerce to double-float looks wrong, but isn't.
417 (,(kmrcl:concat-symbol "gsl-vector-" func-string "add-constant")
418 (ptr o) (coerce x 'double-float)))
419
420 (defmethod max-value ((o ,class-object))
421 (,(kmrcl:concat-symbol "gsl-vector-" func-string "max") (ptr o)))
422
423 (defmethod min-value ((o ,class-object))
424 (,(kmrcl:concat-symbol "gsl-vector-" func-string "min") (ptr o)))
425
426 (defmethod max-index ((o ,class-object))
427 (,(kmrcl:concat-symbol "gsl-vector-" func-string "max-index")
428 (ptr o)))
429
430 (defmethod min-index ((o ,class-object))
431 (,(kmrcl:concat-symbol "gsl-vector-" func-string "min-index")
432 (ptr o)))
433
434 (defmethod min-max-indicies ((o ,class-object))
435 (let ((min-ptr (uffi:allocate-foreign-object 'size-t))
436 (max-ptr (uffi:allocate-foreign-object 'size-t)))
437 (,(kmrcl:concat-symbol "gsl-vector-" func-string
438 "minmax-index")
439 (ptr o) min-ptr max-ptr)
440 (prog1
441 (list (uffi:deref-pointer min-ptr 'size-t)
442 (uffi:deref-pointer max-ptr 'size-t))
443 (uffi:free-foreign-object min-ptr)
444 (uffi:free-foreign-object max-ptr))))
445
446 (defmethod min-max-values ((o ,class-object))
447 (destructuring-bind (min-index max-index)
448 (min-max-indicies o)
449 (list (get-element o min-index)
450 (get-element o max-index))))
451
452 )))))
453
454
455 (def-vector-methods% "integer" "int-")
456 (def-vector-methods% "single-float" "float-")
457 (def-vector-methods% "double-float" "")
458 (def-vector-methods% "complex-single-float" "complex-float-")
459 (def-vector-methods% "complex-double-float" "complex-")
460
461
462 (defun make-vector (size &key (element-type 'double-float) initial-element
463 initial-contents from-file from-binary-file)
464 (assert (and (typep size 'integer) (> size 0) ))
465 (assert (find element-type '(integer single-float double-float
466 (complex (single-float))
467 (complex (double-float))) :test #'equal))
468 (let ((v (cond
469 ((eq element-type 'integer)
470 (make-instance 'gsl-vector-integer
471 :size size :element-type element-type))
472 ((eq element-type 'double-float)
473 (make-instance 'gsl-vector-double-float
474 :size size :element-type element-type))
475 ((eq element-type 'single-float)
476 (make-instance 'gsl-vector-single-float
477 :size size :element-type element-type))
478 ((equal element-type '(complex (double-float)))
479 (make-instance 'gsl-vector-complex-double-float
480 :size size :element-type element-type))
481 ((equal element-type '(complex (single-float)))
482 (make-instance 'gsl-vector-complex-single-float
483 :size size :element-type element-type))
484 (t
485 (error "should never get here.")))))
486 (alloc v)
487 (cond
488 ((and initial-element initial-contents from-file from-binary-file)
489 (error "can only define one of the keys: initial-element, initial-contents, from-file, from-binary-file."))
490 (initial-element
491 (set-all v initial-element))
492 (initial-contents
493 (cond
494 ((listp initial-contents)
495 (do ((x initial-contents (cdr x))
496 (i 0 (1+ i)))
497 ((= i size))
498 (set-element v i (car x))))
499 ((vectorp initial-contents)
500 (do ((i 0 (1+ i)))
501 ((= i size))
502 (set-element v i (aref initial-contents i))))
503 (t
504 (error "initial-contents must be either a list or a vector."))))
505 (from-file
506 (read-from-file v from-file))
507 (from-binary-file
508 (read-from-binary-file v from-binary-file)))
509 v))
510
511
512 (defmacro with-vector
513 ((vec size &key element-type initial-element initial-contents from-file
514 from-binary-file) &body body)
515 `(let ((,vec (make-vector ,size
516 :element-type (or ,element-type 'double-float)
517 :initial-element ,initial-element
518 :initial-contents ,initial-contents
519 :from-file ,from-file
520 :from-binary-file ,from-binary-file)))
521 (unwind-protect
522 (progn ,@body)
523 (free ,vec))))
524
525
526 (defmacro def-vector-copy-method% (class-string func-string)
527 (let ((class-object (kmrcl:concat-symbol "gsl-vector-" class-string)))
528 `(defmethod copy ((o ,class-object))
529 (let* ((o-copy (make-vector (size o) :element-type (element-type o)))
530 (status (,(kmrcl:concat-symbol "gsl-vector-" func-string
531 "memcpy") (ptr o-copy) (ptr o))))
532 (values o-copy status)))))
533
534 (def-vector-copy-method% "integer" "int-")
535 (def-vector-copy-method% "single-float" "float-")
536 (def-vector-copy-method% "double-float" "")
537 (def-vector-copy-method% "complex-single-float" "complex-float-")
538 (def-vector-copy-method% "complex-double-float" "complex-")
539
540
541 (defmacro with-vector-copy ((vec-dest vec-src) &body body)
542 `(let ((,vec-dest (copy ,vec-src)))
543 (unwind-protect
544 ,@body
545 (free ,vec-dest))))
546
547
548 (defun gsl->lisp-vector (v)
549 (let ((a (make-array (size v) :element-type (element-type v))))
550 (dotimes (i (size v) a)
551 (setf (aref a i) (get-element v i)))))
552
553 ;; Function: gsl_vector_view gsl_vector_complex_real (gsl_vector_complex *v)
554 ;; Function: gsl_vector_view gsl_vector_complex_imag (gsl_vector_complex *v)
555

  ViewVC Help
Powered by ViewVC 1.1.5