mobject.lisp 13.8 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-03-29 23:04:45EDT 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 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56
;;; Required arguments for defmobject:
;;;  class           Name of class being made.
;;;  prefix          String that starts each GSL function name
;;;  allocation-args Arguments used in the allocation (initialization)
;;;  description     Short string describing class

;;; Key arguments for defmobject:
;;; documentation
;;;  Docstring for the object maker.
;;; initialize-suffix
;;;  The string appended to prefix to form GSL function name or a list of
;;;  such a string and the c-return argument.
;;; initialize-name
;;;  A string with the name of the GSL function for initialization; defaults to
;;;  prefix + initialize-suffix.
;;; initialize-args
;;; arglists-function
;;;  A function of one symbol, a flag indicating that an optional
;;;  argument has been set.  It returns a list of three forms: the
;;;  arglists for the maker defun, the arguments that will be applied
;;;  therein to the inititializer and to the reinitializer.
;;; inputs, gsl-version
;;;  Defmfun arguments for reinitializer.
;;; allocator
;;; allocate-inputs
;;; freer
;;; class-slots-instance
;;; callbacks
;;;   See callbacks.lisp
;;; superclasses
;;;   List of superclasses other than 'mobject.
;;; singular
;;;   Where a list of several objects like 'functions is specified, this permits
;;;   a single one with the singular form, like 'function.

Liam Healy's avatar
Liam Healy committed
57
(defmacro defmobject
58
    (class prefix allocation-args description 
Liam Healy's avatar
Liam Healy committed
59 60
     &key documentation initialize-suffix initialize-name initialize-args
     arglists-function inputs gsl-version allocator allocate-inputs freer
Liam Healy's avatar
Liam Healy committed
61
     class-slots-instance callbacks
62 63
     (superclasses (if callbacks '(callback-included) '(mobject)))
     singular)
64 65
  "Define the class, the allocate, initialize-instance and
   reinitialize-instance methods, and the make-* function for the GSL object."
66 67 68 69 70 71 72
  (let* ((settingp (make-symbol "SETTINGP"))
	 (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
73
	  (callback-replace-arg
74 75 76
	   'functions
	   (variables-used-in-c-arguments initialize-args)
	   callbacks))
Liam Healy's avatar
Liam Healy committed
77
	 (initializerp (or initialize-name initialize-suffix)))
78 79
    ;; Need callback information for macroexpansion make-cbstruct-object
    (when callbacks (record-callbacks-for-class class callbacks))
Liam Healy's avatar
Liam Healy committed
80 81
    (if (have-at-least-gsl-version gsl-version)
	`(progn
82
	   ,(if callbacks
83 84 85
		`(,(if (member 'dimensions cl-alloc-args)
		       'def-ci-subclass 'def-ci-subclass-1d)
		   ,class
86
		   ,superclasses
87
		   ,(format nil "The GSL representation of the ~a." description)
88
		   ,(parse-callback-static callbacks 'dimension-names))
89 90 91 92
		`(defclass ,class ,superclasses
		   nil
		   (:documentation
		    ,(format nil "The GSL representation of the ~a." description))))
Liam Healy's avatar
Liam Healy committed
93

Liam Healy's avatar
Liam Healy committed
94
	   (defmfun allocate ((object ,class) &key ,@cl-alloc-args)
Liam Healy's avatar
Liam Healy committed
95
	     ,(or allocator (format nil "~a_alloc" prefix))
Liam Healy's avatar
Liam Healy committed
96
	     ,allocation-args
Liam Healy's avatar
Liam Healy committed
97
	     ,@(if allocate-inputs `(:inputs ,allocate-inputs))
Liam Healy's avatar
Liam Healy committed
98 99 100
	     :definition :method
	     :c-return :pointer
	     :index ,maker)
Liam Healy's avatar
Liam Healy committed
101

102 103
	   ,(make-initialize-instance
	     class cl-alloc-args cl-initialize-args prefix freer)
Liam Healy's avatar
Liam Healy committed
104
	   ,@(when initializerp
105 106
		   (make-reinitialize-instance
		    class cl-initialize-args initialize-name prefix
107
		    initialize-suffix initialize-args inputs
108
		    (and (not (callback-arg-p class-slots-instance callbacks))
109 110
			 callbacks)
		    superclasses))
Liam Healy's avatar
Liam Healy committed
111
	   (export '(,maker ,class))
112 113
	   ,@(when callbacks `((record-callbacks-for-class ',class ',callbacks)))
	   ,@(when callbacks (make-mobject-defmcallbacks callbacks class))
114
	   ,(mobject-maker
Liam Healy's avatar
Liam Healy committed
115
	     maker arglists class cl-alloc-args cl-initialize-args
116
	     description documentation initialize-args initializerp settingp
117
	     singular class-slots-instance callbacks))
118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144
	`(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
145
     initialize-suffix initialize-args inputs
146
     callbacks superclasses)
147
  "Expand the reinitialize-instance form."
148 149 150 151 152
  (let ((cbstruct (make-symbol "CBSTRUCT")))
    `((defmfun reinitialize-instance
	  ((object ,class)
	   &key
	   ,@cl-initialize-args
153
	   ,@(when callbacks
154
		   `(&aux (,cbstruct ,(make-cbstruct-object class)))))
155 156 157 158 159 160
	,(or initialize-name
	     (format nil "~a_~a" prefix
		     (if (listp initialize-suffix)
			 (first initialize-suffix)
			 initialize-suffix)))
	(((mpointer object) :pointer)
161
	 ,@(callback-replace-arg cbstruct initialize-args callbacks))
162
	:definition :method
163
	,@(when callbacks '(:callback-object object))
164 165 166 167 168
	:qualifier :after
	,@(when (and initialize-suffix (listp initialize-suffix))
		`(:c-return ,(second initialize-suffix)))
	:return (object)
	,@(when inputs `(:inputs ,inputs))
169
	,@(when callbacks
170
		`(:before
171 172 173
		  (,@(when (member 'callback-included-cl superclasses)
			   `((setf (slot-value object 'callback) ,cbstruct)))
		   (make-funcallables-for-object object))
174
		  :after
175 176 177 178 179 180
		  ((trivial-garbage:finalize 
		    object
		    (lambda ()
		      (cffi:foreign-free ,cbstruct))))))
	:export nil
	:index (reinitialize-instance ,class)))))
181 182

(defun mobject-maker
Liam Healy's avatar
Liam Healy committed
183
    (maker arglists class cl-alloc-args cl-initialize-args
184
     description documentation initialize-args initializerp settingp
185
     singular class-slots-instance callbacks)
186
  "Make the defun form that makes the mobject."
187
  (when callbacks
Liam Healy's avatar
Liam Healy committed
188 189 190 191 192 193 194 195 196 197 198 199 200 201
    (setf cl-initialize-args (append cl-initialize-args '((scalarsp t)))))
  (let ((initargs ; arguments that are exclusively for reinitialize-instance
	 (remove-if (lambda (s) (member s cl-alloc-args)) cl-initialize-args)))
    `(defun ,maker
	 ,(if arglists
	      (first arglists)
	      (singularize
	       singular
	       `(,@cl-alloc-args
		 ,@(callback-replace-arg
		    'functions class-slots-instance callbacks)
		 ,@(when initargs
			 (append
			  (list
202 203 204 205
			   '&optional
			   (if (listp (first initargs))
			       `(,@(first initargs) ,settingp)
			       `(,(first initargs) nil ,settingp)))
Liam Healy's avatar
Liam Healy committed
206 207 208 209 210 211 212
			  (rest initargs))))))
       ,(format
	 nil "Create the GSL object representing a ~a (class ~a).~@[~&~a~]"
	 description class documentation)
       (let ((object
	      (make-instance
	       ',class
213
	       ,@(when callbacks `(:callbacks ',callbacks))
Liam Healy's avatar
Liam Healy committed
214 215 216 217 218 219 220 221 222 223
	       ,@(symbol-keyword-symbol
		  (callback-remove-arg class-slots-instance callbacks))
	       ,@(when (callback-arg-p class-slots-instance callbacks)
		       (symbol-keyword-symbol 'functions))
	       ,@(if arglists
		     (second arglists)
		     (symbol-keyword-symbol cl-alloc-args singular)))))
	 ;; There is callback slot variable
	 ,@(when (callback-arg-p class-slots-instance callbacks)
		 (with-unique-names (cbs)
224
		   `((let ((,cbs ,(make-cbstruct-object class)))
Liam Healy's avatar
Liam Healy committed
225 226 227 228 229 230 231
		       (setf (slot-value
			      object
			      ',(parse-callback-static callbacks 'foreign-argument))
			     ,cbs)
		       (tg:finalize object (lambda () (foreign-free ,cbs)))))))
	 ;; There is an initialization step
	 ,@(when initializerp
232
		 (if (or initialize-args arglists)	; with arguments
Liam Healy's avatar
Liam Healy committed
233 234 235 236 237 238 239 240 241 242 243
		     (let ((reii 
			    `(reinitialize-instance
			      object
			      ,@(if arglists
				    (third arglists)
				    (symbol-keyword-symbol
				     (arglist-plain-and-categories cl-initialize-args)
				     singular)))))
		       (if initargs `((when ,settingp ,reii)) `(,reii)))
		     '((reinitialize-instance object)))) ; without arguments
	 object))))
244

245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267
(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."
268
  (if (listp symbol)
269 270 271 272 273 274
      (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))))
275

Liam Healy's avatar
Liam Healy committed
276 277 278
;;;;****************************************************************************
;;;; Generic functions
;;;;****************************************************************************
Liam Healy's avatar
Liam Healy committed
279

280 281 282 283
(defgeneric allocate (object &key &allow-other-keys)
  (:documentation
   "Use GSL to allocate memory.  Returns pointer but does not bind mpointer slot."))

284 285 286 287
(export 'name)
(defgeneric name (object)
  (:documentation "The name given to the GSL object."))

288
(export 'evaluate)
289
(defgeneric evaluate (object point &key #+sbcl &allow-other-keys)
290 291
  (:documentation "Evaluate the GSL object."))

292
;;; Pointer type
293 294 295 296 297
(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."))
298

299 300 301 302 303 304 305 306 307 308 309 310 311
;;; Note: clisp has a foreign pointer class = T, so it would be best
;;; to narrow down methods that dispatch on this class.
(defmacro foreign-pointer-method (pointer form)
  "Execute this form only if the pointer is of +foreign-pointer-type+;
   otherwise call the next method."
  #-clisp (declare (ignore pointer))
  #+clisp
  `(if (typep ,pointer +foreign-pointer-type+)
       ,form
       (call-next-method))
  #-clisp
  form)

312 313 314 315 316 317 318
;;; 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.

(defmethod mpointer ((object #.+foreign-pointer-class+))
319
  #+clisp (check-type object #.+foreign-pointer-type+)
320
  object)
Liam Healy's avatar
Liam Healy committed
321

322 323 324 325
(export 'order)
(defgeneric order (object)
  (:documentation "The order of the GSL object."))

Liam Healy's avatar
Liam Healy committed
326 327 328 329 330
;;;;****************************************************************************
;;;; Making objects from existing objects
;;;;****************************************************************************

(export 'copy)
Liam Healy's avatar
Liam Healy committed
331 332 333 334 335
(defun copy (object &optional destination)
  "Create a duplicate object."
  (if destination
      (copy-to-destination object destination)
      (copy-making-destination object)))
Liam Healy's avatar
Liam Healy committed
336 337 338 339 340 341 342 343 344 345 346 347

(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))
Liam Healy's avatar
Liam Healy committed
348 349 350 351 352 353 354 355 356 357 358 359 360 361 362
      (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,
	  (if (typep object 'marray)
	      (call-next-method)
	      (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)))))
Liam Healy's avatar
Liam Healy committed
363 364 365 366 367 368 369 370 371 372 373 374 375 376

;;; 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.