mobject.lisp 11.5 KB
Newer Older
1
2
;; Definition of GSL objects and ways to use them.
;; Liam Healy, Sun Dec  3 2006 - 10:21
3
;; Time-stamp: <2009-02-15 17:06:23EST mobject.lisp>
4

5
6
7
8
9
10
11
;;; GSL objects are represented in GSLL as and instance of a 'mobject.
;;; The macro demobject takes care of defining the appropriate
;;; subclass, the methods #'initialize-instance,
;;; #'reinitialize-instance, and #'allocate, and the function
;;; #'make-<class-name>, which is what the user calls to make the
;;; object.

12
13
(in-package :gsl)

Liam Healy's avatar
Liam Healy committed
14
15
16
17
;;;;****************************************************************************
;;;; The class definition
;;;;****************************************************************************

18
(defclass mobject ()
19
  ((mpointer :initarg :mpointer :reader mpointer
Liam Healy's avatar
Liam Healy committed
20
21
	     :documentation "A pointer to the GSL representation of the object.")))

22
23
(defconstant +callback-argument-name+ 'callback)

Liam Healy's avatar
Liam Healy committed
24
(defmacro defmobject
25
    (class prefix allocation-args description 
Liam Healy's avatar
Liam Healy committed
26
27
     &key documentation initialize-suffix initialize-name initialize-args
     arglists-function inputs gsl-version allocator allocate-inputs freer
28
     (superclasses '(mobject))
29
     class-slots-instance ci-class-slots singular)
30
31
  "Define the class, the allocate, initialize-instance and
   reinitialize-instance methods, and the make-* function for the GSL object."
Liam Healy's avatar
Liam Healy committed
32
33
34
  ;; Argument 'initialize-suffix: string appended to prefix to form
  ;; GSL function name or a list of such a string and the c-return
  ;; argument.
35
  (let* ((settingp (make-symbol "SETTINGP"))
36
37
	 (callbackp
	  (member-if (lambda (cl) (subtypep cl 'callback-included)) superclasses))
38
39
40
41
42
43
	 (arglists
	  (when arglists-function
	    (funcall (coerce arglists-function 'function) settingp)))
	 (maker (intern (format nil "MAKE-~:@(~a~)" class) :gsl))
	 (cl-alloc-args (variables-used-in-c-arguments allocation-args))
	 (cl-initialize-args
44
45
	  (callback-replace-arg
	   'functions (variables-used-in-c-arguments initialize-args)))
Liam Healy's avatar
Liam Healy committed
46
47
48
	 (initializerp (or initialize-name initialize-suffix))
	 (initargs ; arguments that are exclusively for reinitialize-instance
	  (remove-if (lambda (s) (member s cl-alloc-args)) cl-initialize-args)))
Liam Healy's avatar
Liam Healy committed
49
50
    (if (have-at-least-gsl-version gsl-version)
	`(progn
51
	   ,(if callbackp
52
53
54
		`(,(if (member 'dimensions cl-alloc-args)
		       'def-ci-subclass 'def-ci-subclass-1d)
		   ,class
55
		   ,superclasses
56
		   ,(format nil "The GSL representation of the ~a." description)
57
58
59
60
61
		   ,@ci-class-slots)
		`(defclass ,class ,superclasses
		   nil
		   (:documentation
		    ,(format nil "The GSL representation of the ~a." description))))
Liam Healy's avatar
Liam Healy committed
62

Liam Healy's avatar
Liam Healy committed
63
	   (defmfun allocate ((object ,class) &key ,@cl-alloc-args)
Liam Healy's avatar
Liam Healy committed
64
	     ,(or allocator (format nil "~a_alloc" prefix))
Liam Healy's avatar
Liam Healy committed
65
	     ,allocation-args
Liam Healy's avatar
Liam Healy committed
66
	     ,@(if allocate-inputs `(:inputs ,allocate-inputs))
Liam Healy's avatar
Liam Healy committed
67
68
69
	     :definition :method
	     :c-return :pointer
	     :index ,maker)
Liam Healy's avatar
Liam Healy committed
70

71
72
	   ,(make-initialize-instance
	     class cl-alloc-args cl-initialize-args prefix freer)
Liam Healy's avatar
Liam Healy committed
73
	   ,@(when initializerp
74
75
		   (make-reinitialize-instance
		    class cl-initialize-args initialize-name prefix
76
		    initialize-suffix initialize-args inputs
77
		    (and callbackp
78
			 (not (callback-arg-p class-slots-instance)))))
Liam Healy's avatar
Liam Healy committed
79
	   (export ',maker)
80
81
	   ,(mobject-maker
	     maker arglists initargs class cl-alloc-args cl-initialize-args
82
	     description documentation initialize-args initializerp settingp
83
	     singular class-slots-instance))
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
	`(progn
	   (export ',maker)
	   (defun ,maker (&rest args)
	     (declare (ignore args))
	     (error 'obsolete-gsl-version
		    :name ',class :gsl-name ,prefix
		    :gsl-version ',gsl-version))))))

(defun make-initialize-instance
    (class cl-alloc-args cl-initialize-args prefix freer)
  `(defmethod initialize-instance :after
       ((object ,class) &key mpointer ,@(union cl-alloc-args cl-initialize-args))
     ,@(let ((not-alloc (set-difference cl-initialize-args cl-alloc-args)))
	    (when not-alloc)
	    `((declare (ignore ,@not-alloc))))
     (unless mpointer
       (setf mpointer
	     (allocate object ,@(symbol-keyword-symbol cl-alloc-args))
	     (slot-value object 'mpointer) mpointer))
     (tg:finalize object
		  (lambda ()
		    (cffi:foreign-funcall
		     ,(or freer (format nil "~a_free" prefix))
		     :pointer mpointer :void)))))

(defun make-reinitialize-instance
    (class cl-initialize-args initialize-name prefix
111
     initialize-suffix initialize-args inputs
112
     callback)
113
114
115
116
117
118
119
  "Expand the reinitialize-instance form.  In the GSL arglist, the callback
   structure pointer should be named the value of +callback-argument-name+."
  (let ((cbstruct (make-symbol "CBSTRUCT")))
    `((defmfun reinitialize-instance
	  ((object ,class)
	   &key
	   ,@cl-initialize-args
120
121
	   ,@(when callback
		   `(&aux (,cbstruct (make-cbstruct-object object)))))
122
123
124
125
126
127
	,(or initialize-name
	     (format nil "~a_~a" prefix
		     (if (listp initialize-suffix)
			 (first initialize-suffix)
			 initialize-suffix)))
	(((mpointer object) :pointer)
128
	 ,@(callback-replace-arg cbstruct initialize-args))
129
130
131
132
133
134
135
136
137
138
139
140
141
142
	:definition :method
	:qualifier :after
	,@(when (and initialize-suffix (listp initialize-suffix))
		`(:c-return ,(second initialize-suffix)))
	:return (object)
	,@(when inputs `(:inputs ,inputs))
	,@(when callback
		`(:after
		  ((trivial-garbage:finalize 
		    object
		    (lambda ()
		      (cffi:foreign-free ,cbstruct))))))
	:export nil
	:index (reinitialize-instance ,class)))))
143
144
145

(defun mobject-maker
    (maker arglists initargs class cl-alloc-args cl-initialize-args
146
     description documentation initialize-args initializerp settingp
147
     singular class-slots-instance)
148
149
150
151
  "Make the defun form that makes the mobject."
  `(defun ,maker
       ,(if arglists
	    (first arglists)
152
153
154
	    (singularize
	     singular
	     `(,@cl-alloc-args
155
	       ,@(callback-replace-arg 'functions class-slots-instance)
156
157
158
159
160
	       ,@(when initargs
		       (append
			(list
			 '&optional (list (first initargs) nil settingp))
			(rest initargs))))))
161
162
163
164
165
166
     ,(format
       nil "Create the GSL object representing a ~a (class ~a).~@[~&~a~]"
       description class documentation)
     (let ((object
	    (make-instance
	     ',class
167
168
	     ,@(symbol-keyword-symbol (callback-remove-arg class-slots-instance))
	     ,@(when (callback-arg-p class-slots-instance)
169
		     (symbol-keyword-symbol 'functions))
170
171
	     ,@(if arglists
		   (second arglists)
172
		   (symbol-keyword-symbol cl-alloc-args singular)))))
173
       ;; There is callback slot variable
174
       ,@(when (callback-arg-p class-slots-instance)
175
176
177
178
	       (with-unique-names (cbs)
		 `((let ((,cbs (make-cbstruct-object object)))
		     (setf (slot-value object '#.+callback-argument-name+) ,cbs)
		     (tg:finalize object (lambda () (foreign-free ,cbs)))))))
179
180
181
       ;; There is an initialization step
       ,@(when initializerp
	       (if initialize-args	; with arguments
182
183
		   (let ((reii 
			  `(reinitialize-instance
184
185
186
			    object
			    ,@(if arglists
				  (third arglists)
187
188
				  (symbol-keyword-symbol
				   cl-initialize-args singular)))))
189
		     (if initargs `((when ,settingp ,reii)) `(,reii)))
190
191
192
		   '((reinitialize-instance object)))) ; without arguments
       object)))

193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
(defun plural-symbol (symbol)
  "Make the plural form of this symbol."
  (intern (format nil "~aS" (symbol-name symbol))
	  (find-package :gsl)))

(defun singular-symbol (symbol)
  "Make the singular form of this symbol."
  (let ((string (symbol-name symbol)))
    (if (eq #\S (aref string (1- (length string))))
	(intern (subseq string 0 (1- (length string)))
		(find-package :gsl)))))

(defun singularize (symbols form)
  "In the form, replace the plural symbol with the singular symbol
   given."
  (if symbols
      (if (listp symbols)
	  (singularize (first symbols) (singularize (rest symbols) form))
	  (subst symbols (plural-symbol symbols) form))
      form))

(defun symbol-keyword-symbol (symbol &optional singular)
  "Make a list of key symbol, listifying if singular."
216
  (if (listp symbol)
217
218
219
220
221
222
      (mapcan (lambda (s) (symbol-keyword-symbol s singular)) symbol)
      (if (member (singular-symbol symbol) singular)
	  (list (intern (symbol-name symbol) :keyword)
		`(list ,(singular-symbol symbol)))
	  (list (intern (symbol-name symbol) :keyword)
		symbol))))
223

Liam Healy's avatar
Liam Healy committed
224
225
226
;;;;****************************************************************************
;;;; Generic functions
;;;;****************************************************************************
Liam Healy's avatar
Liam Healy committed
227

228
229
230
231
(defgeneric allocate (object &key &allow-other-keys)
  (:documentation
   "Use GSL to allocate memory.  Returns pointer but does not bind mpointer slot."))

232
233
234
235
(export 'name)
(defgeneric name (object)
  (:documentation "The name given to the GSL object."))

236
237
238
239
(export 'evaluate)
(defgeneric evaluate (object point &key)
  (:documentation "Evaluate the GSL object."))

240
;;; Pointer type
241
242
243
244
245
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defconstant +foreign-pointer-class+ (class-name (class-of (cffi:null-pointer)))
    "The class in which foreign pointers fall.")
  (defconstant +foreign-pointer-type+ (type-of (cffi:null-pointer))
    "The type of foreign pointers."))
246
247
248
249
250
251
252
253
254
255
256
257
258

;;; Some functions in solve-minimize-fit return a pointer to a GSL
;;; vector with double-floats.  This function will return a contents
;;; form suitable for make-marray.  There is no choice but to copy
;;; over the data even on native implementations; because GSL is doing
;;; the mallocing, the data are not CL-accessible.

(defgeneric contents-from-pointer (pointer struct-type &optional element-type)
  (:documentation
   "Create a contents list from the GSL object of type struct-type
    referenced by pointer."))

(defmethod mpointer ((object #.+foreign-pointer-class+))
259
  (check-type object #.+foreign-pointer-type+)
260
  object)
Liam Healy's avatar
Liam Healy committed
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312

;;;;****************************************************************************
;;;; Making objects from existing objects
;;;;****************************************************************************

(export 'copy)
(defgeneric copy (object &optional destination)
  (:documentation "Create a duplicate object.")
  ;; This method is used for all GSL objects except arrays.
  (:method ((object mobject) &optional destination)
    (if destination
	(copy-to-destination object destination)
	(copy-making-destination object))))

(defgeneric copy-to-destination (object destination)
  ;; This copies values into an existing object.  Methods are defined
  ;; for non-array GSL objects that have _memcpy functions defined.
  ;; Defined for
  ;; random-number-generator, quasi-random-number-generator,
  ;; histogram, histogram2d, permutation, combination.
  (:documentation "Copy contents into existing object."))

(defgeneric copy-making-destination (object)
  (:documentation "Create new duplicate object.")
  (:method :around ((object mobject))
    (if (next-method-p)
	;; The subclass method should only return the malloced
	;; mpointer (as from a "_clone" function); it will be put into
	;; the CL object here.  The initial-instance method for these
	;; objects must be written to do nothing if the mpointer is
	;; already defined.
	;; Defined for
	;; histogram, histogram2d, 
	;; random-number-generator, quasi-random-number-generator,
	(make-instance (class-of object) :mpointer (call-next-method))
	;; The subclass does not supply a method, so this will be called
	;; by default.  We can only try to make something from the load form.
	(eval (make-load-form object)))))

;;; Could be part of copy when the second argument is optional?
(export 'clone)
(defgeneric clone (object)
  (:documentation "Create a duplicate object.")
  (:method :around ((object mobject))
	   (make-instance (class-of object) :mpointer (call-next-method))))


;;; To make-load-form
;;; (make-basis-spline (bspline-order bspline) (number-of-breakpoints bspline))
;;; Then initialize by making a vector from (breakpoint i bspline)
;;; and calling knots.