/[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 - (hide 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 edenny 1.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 edenny 1.9 (in-package #:cl-gsl-array)
21 edenny 1.1
22 edenny 1.8
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 edenny 1.10 ;; TODO: have a (defmethod initialize-instance : after) that calls alloc?
29 edenny 1.8
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 edenny 1.1 (defmacro def-vector-type-funcs% (typ)
38     (let ((type-ptr)
39     (type-val)
40     (type-val-ptr)
41 edenny 1.8 (type-string)
42     (is-real (or (eq typ 'double-float)
43     (eq typ 'single-float)
44     (eq typ 'integer))))
45 edenny 1.1 (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 edenny 1.3 ((equal typ '(complex (double-float)))
62 edenny 1.1 (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 edenny 1.3 ((equal typ '(complex (single-float)))
67 edenny 1.1 (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 edenny 1.7 ((v ,type-ptr)
155 edenny 1.1 (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 edenny 1.7 ((v ,type-ptr)
162 edenny 1.1 (offset size-t)
163     (stride size-t)
164     (n size-t))
165 edenny 1.8 ,type-ptr)
166 edenny 1.1
167 edenny 1.8 ,(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 edenny 1.1
254 edenny 1.4
255 edenny 1.1 (def-vector-type-funcs% double-float)
256     (def-vector-type-funcs% single-float)
257     (def-vector-type-funcs% integer)
258 edenny 1.3 (def-vector-type-funcs% (complex (double-float)))
259     (def-vector-type-funcs% (complex (single-float)))
260 edenny 1.1
261 edenny 1.8
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 edenny 1.9 (defmethod get-element ((o ,class-object) i &optional j)
282     (assert (and (typep i 'integer) (>= i 0) (< i (size o))))
283 edenny 1.8 ,(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 edenny 1.9 (defmethod set-element ((o ,class-object) i &optional x dummy)
291 edenny 1.8 (assert (typep x (element-type o)))
292 edenny 1.9 (assert (and (typep i 'integer) (>= i 0) (< i (size o))))
293 edenny 1.8 ,(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 edenny 1.9 (defmethod read-from-binary-file ((o ,class-object) file-name)
327 edenny 1.8 (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 edenny 1.9 (defmethod read-from-file ((o ,class-object) file-name)
335 edenny 1.8 (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 edenny 1.1
461    
462     (defun make-vector (size &key (element-type 'double-float) initial-element
463 edenny 1.6 initial-contents from-file from-binary-file)
464 edenny 1.8 (assert (and (typep size 'integer) (> size 0) ))
465 edenny 1.1 (assert (find element-type '(integer single-float double-float
466 edenny 1.3 (complex (single-float))
467     (complex (double-float))) :test #'equal))
468 edenny 1.8 (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 edenny 1.1 (cond
488 edenny 1.6 ((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 edenny 1.1 (initial-element
491 edenny 1.8 (set-all v initial-element))
492 edenny 1.1 (initial-contents
493     (cond
494     ((listp initial-contents)
495     (do ((x initial-contents (cdr x))
496     (i 0 (1+ i)))
497     ((= i size))
498 edenny 1.8 (set-element v i (car x))))
499 edenny 1.1 ((vectorp initial-contents)
500     (do ((i 0 (1+ i)))
501     ((= i size))
502 edenny 1.8 (set-element v i (aref initial-contents i))))
503 edenny 1.1 (t
504 edenny 1.6 (error "initial-contents must be either a list or a vector."))))
505     (from-file
506 edenny 1.9 (read-from-file v from-file))
507 edenny 1.6 (from-binary-file
508 edenny 1.9 (read-from-binary-file v from-binary-file)))
509 edenny 1.1 v))
510    
511    
512 edenny 1.6 (defmacro with-vector
513     ((vec size &key element-type initial-element initial-contents from-file
514     from-binary-file) &body body)
515 edenny 1.5 `(let ((,vec (make-vector ,size
516     :element-type (or ,element-type 'double-float)
517     :initial-element ,initial-element
518 edenny 1.6 :initial-contents ,initial-contents
519     :from-file ,from-file
520     :from-binary-file ,from-binary-file)))
521 edenny 1.5 (unwind-protect
522 edenny 1.6 (progn ,@body)
523 edenny 1.5 (free ,vec))))
524    
525    
526 edenny 1.8 (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 edenny 1.5
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 edenny 1.1
547    
548 edenny 1.7 (defun gsl->lisp-vector (v)
549 edenny 1.8 (let ((a (make-array (size v) :element-type (element-type v))))
550     (dotimes (i (size v) a)
551 edenny 1.6 (setf (aref a i) (get-element v i)))))
552 edenny 1.1
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 edenny 1.4

  ViewVC Help
Powered by ViewVC 1.1.5