maref.lisp 5.75 KB
Newer Older
1
2
;; Get/set array or elements: cl-array, maref
;; Liam Healy 2008-08-27 22:43:10EDT maref.lisp
Liam Healy's avatar
Liam Healy committed
3
;; Time-stamp: <2009-12-06 19:51:39EST maref.lisp>
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
;; $Id: $

(in-package :gsl)

(export '(cl-array maref))

;;; These functions handle the details of converting between the GSL
;;; representation of arrays and Common Lisp arrays.  The function
;;; #'maref can be treated like #'aref for reading and setting
;;; elements, except that it is limited to two indices (vectors or
;;; matrices only) and requires a final argument with the element
;;; type when taking a GSL pointer as the first argument (only needed
;;; in the case of solve-minimize-fit for callbacks and some return
;;; values).

;;; Both these functions take one of the following class arguments for
;;; the array:
Liam Healy's avatar
Liam Healy committed
21
;;; - a foreign-array
22
23
24
25
26
27
28
29
30
;;; - a Common Lisp array
;;; - a pointer to a GSL vector or matrix structure

;;;;****************************************************************************
;;;; Get the entire array:  cl-array
;;;;****************************************************************************

(defgeneric cl-array (object &optional array-rank element-type)
  (:documentation
Liam Healy's avatar
Liam Healy committed
31
   "The array as a CL native array.  The object may be a foreign-array object,
32
33
34
    a pointer to a GSL vector or matrix, or an ordinary CL array of one
    or two dimensions.  Optional arguments array-rank and element-type
    are used only for pointers.")
Liam Healy's avatar
Liam Healy committed
35
  (:method ((object foreign-array) &optional array-rank element-type)
36
    (declare (ignore array-rank element-type))
Liam Healy's avatar
Liam Healy committed
37
    #-native (copy-c-to-cl object)
38
39
40
41
    (slot-value object 'cl-array))
  (:method ((object array) &optional array-rank element-type)
    ;; For compatibility, work on CL arrays as well.
    (declare (ignore array-rank element-type))
42
    object))
43
44
45
46
47
48
49

;;;;****************************************************************************
;;;; Get or set elements of the array:  maref, (setf maref)
;;;;****************************************************************************

(defgeneric maref (object index &optional index2 type)
  (:documentation
Liam Healy's avatar
Liam Healy committed
50
   "An element of the data.  The object may be a foreign-array object, a pointer to
51
    a GSL vector or matrix, or an ordinary CL array of one or two dimensions.")
Liam Healy's avatar
Liam Healy committed
52
  (:method ((object foreign-array) index &optional index2 type)
53
    (declare (ignore type))
Liam Healy's avatar
Liam Healy committed
54
    #-native (copy-c-to-cl object)
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
    (if index2
	(aref (cl-array object) index index2)
	(aref (cl-array object) index)))
  (:method ((object array) index &optional index2 type)
    ;; For compatibility, work on CL arrays as well.
    (declare (ignore type))
    (if index2
	(aref object index index2)
	(aref object index))))

;;; Alternative to complete copy is to mark which elements have
;;; changed and just copy them.  Is it worth it?

(defgeneric (setf maref) (value object index &optional index2 type)
  (:documentation
Liam Healy's avatar
Liam Healy committed
70
   "Set an element of the data.  The object may be a foreign-array object,
71
72
    a pointer to a GSL vector or matrix, or an ordinary CL array
    of one or two dimensions.")
Liam Healy's avatar
Liam Healy committed
73
  (:method (value (object foreign-array) index &optional index2 type)
74
75
76
77
    (declare (ignore type))
    (if index2
	(setf (aref (slot-value object 'cl-array) index index2) value)
	(setf (aref (slot-value object 'cl-array) index) value))
78
    #-native (setf (c-invalid object) t))
79
80
81
82
83
84
85
86
87
88
89
90
91
  (:method (value (object array) index &optional index2 type)
    ;; For compatibility, work on CL arrays as well.
    (declare (ignore type))
    (if index2
	(setf (aref object index index2) value)
	(setf (aref object index) value))))

;;; Normally we won't need to set or get directly from the GSL
;;; vector/matrix pointer.  However, it is necessary to have access to
;;; elements from the GSL vector/matrix pointers for things like
;;; callback functions in solve-minimize-fit and in #'cl-array method
;;; for pointers.

92
93
(defmacro maref-function-picker
    (type-symbol category ffrestargs &optional value-symbol)
94
95
96
97
98
99
100
101
102
103
  "Generate sexp to select on the various gsl_{vector,matrix}*_{get,set} functions."
  (cons 'cond
	(mapcar (lambda (tp)
		  `((equal ,type-symbol ',tp)
		    (cffi:foreign-funcall
		     ,(actual-gsl-function-name
		       `("gsl_" :category :type ,(if value-symbol "_set" "_get"))
		       category tp)
		     ,@ffrestargs
		     ,@(if value-symbol
Liam Healy's avatar
Liam Healy committed
104
105
			   (list (c-array:cl-cffi tp) value-symbol)
			   (list (c-array:cl-cffi tp))))))
106
		*array-element-types*)))
107
108
109
110
111

(defmethod maref
    ((pointer #.+foreign-pointer-class+) index &optional index2
     (type 'double-float))
  (if index2
112
113
114
115
116
117
      (maref-function-picker
	 type matrix
	 (:pointer pointer sizet index sizet index2))
      (maref-function-picker
	 type vector
	 (:pointer pointer sizet index))))
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140

;;; Index the GSL function names to maref
#.(cons 'progn
	(append
	 (mapcar (lambda (tp)
		   `(map-name
		     'maref
		     ,(actual-gsl-function-name
		       `("gsl_" :category :type ,"_get")
		       'vector tp)))
		 *array-element-types*)
	 (mapcar (lambda (tp)
		   `(map-name
		     'maref
		     ,(actual-gsl-function-name
		       `("gsl_" :category :type ,"_get")
		       'matrix tp)))
		 *array-element-types*)))

(defmethod (setf maref)
    (value (pointer #.+foreign-pointer-class+) index &optional index2
     (type 'double-float))
  (if index2
141
142
143
144
145
146
      (maref-function-picker
       type matrix
       (:pointer pointer sizet index sizet index2) value)
      (maref-function-picker
       type vector
       (:pointer pointer sizet index) value)))
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168

;;; Index the GSL function names to (setf maref)
#.(cons 'progn
	(append
	 (mapcar (lambda (tp)
		   `(map-name
		     '(setf maref)
		     ,(actual-gsl-function-name
		       `("gsl_" :category :type ,"_set")
		       'vector tp)))
		 *array-element-types*)
	 (mapcar (lambda (tp)
		   `(map-name
		     '(setf maref)
		     ,(actual-gsl-function-name
		       `("gsl_" :category :type ,"_set")
		       'matrix tp)))
		 *array-element-types*)))