mobject.lisp 14.1 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-08-25 20:45:31EDT 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
;;; 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
;;; 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.
55 56
;;; switch
;;;   Same as for defmfun.
57 58
;;; ri-c-return
;;;   The c-return for the reinitialize-instance function.
59

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

Liam Healy's avatar
Liam Healy committed
100
	   (defmfun allocate ((object ,class) &key ,@cl-alloc-args)
Liam Healy's avatar
Liam Healy committed
101
	     ,(or allocator (format nil "~a_alloc" prefix))
Liam Healy's avatar
Liam Healy committed
102
	     ,allocation-args
Liam Healy's avatar
Liam Healy committed
103
	     ,@(if allocate-inputs `(:inputs ,allocate-inputs))
Liam Healy's avatar
Liam Healy committed
104 105 106
	     :definition :method
	     :c-return :pointer
	     :index ,maker)
Liam Healy's avatar
Liam Healy committed
107

108 109
	   ,(make-initialize-instance
	     class cl-alloc-args cl-initialize-args prefix freer)
Liam Healy's avatar
Liam Healy committed
110
	   ,@(when initializerp
111 112
		   (make-reinitialize-instance
		    class cl-initialize-args initialize-name prefix
113
		    initialize-suffix initialize-args inputs
Liam Healy's avatar
Liam Healy committed
114
		    cbinfo
115
		    superclasses
116
		    switch ri-c-return))
Liam Healy's avatar
Liam Healy committed
117
	   (export '(,maker ,class))
Liam Healy's avatar
Liam Healy committed
118 119
	   ,@(when cbinfo `((record-callbacks-for-class ',class ',cbinfo)))
	   ,@(when cbinfo (make-mobject-defmcallbacks cbinfo class))
120
	   ,(mobject-maker
Liam Healy's avatar
Liam Healy committed
121
	     maker arglists class cl-alloc-args cl-initialize-args
122
	     description documentation initialize-args initializerp settingp
Liam Healy's avatar
Liam Healy committed
123
	     singular cbinfo))
124 125 126 127 128 129 130 131
	`(progn
	   (export ',maker)
	   (defun ,maker (&rest args)
	     (declare (ignore args))
	     (error 'obsolete-gsl-version
		    :name ',class :gsl-name ,prefix
		    :gsl-version ',gsl-version))))))

132 133 134 135 136 137
(defun initialize-suffix-switched-foreign (initialize-suffix)
  "The specified initialize-suffix indicates that there are two
   foreign functions that can be called; which one is called
   is dependent on the presence or absense of certain arguments."
  (and initialize-suffix (listp initialize-suffix)))

138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156
(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
157
     initialize-suffix initialize-args inputs
158
     cbinfo superclasses switch ri-c-return)
159
  "Expand the reinitialize-instance form."
160 161 162 163 164 165 166 167 168 169 170 171 172
  (flet ((add-suffix (suffix) (format nil "~a_~a" prefix suffix)))
    (let* ((cbstruct (make-symbol "CBSTRUCT"))
	   (initialize-suffix-switched-foreign
	    (initialize-suffix-switched-foreign initialize-suffix)))
      `((defmfun reinitialize-instance
	    ((object ,class)
	     &key
	     ,@cl-initialize-args
	     ,@(when cbinfo
		     `(&aux (,cbstruct ,(make-cbstruct-object class)))))
	  ,(or initialize-name
	       (if initialize-suffix-switched-foreign
		   (mapcar #'add-suffix initialize-suffix)
173
		   (add-suffix initialize-suffix)))
174 175 176 177 178 179
	  ,(if initialize-suffix-switched-foreign
	       (mapcar (lambda (ia)
			 `(((mpointer object) :pointer)
			   ,@(callback-replace-arg cbstruct ia cbinfo)))
		       initialize-args)
	       `(((mpointer object) :pointer)
180
		 ,@(callback-replace-arg cbstruct initialize-args cbinfo)))
181 182 183
	  :definition :method
	  ,@(when cbinfo '(:callback-object object))
	  :qualifier :after
184
	  ,@(when ri-c-return `(:c-return ,ri-c-return))
185 186 187 188 189 190 191 192 193 194 195 196 197 198 199
	  ,@(when switch (list :switch switch))
	  :return (object)
	  ,@(when inputs `(:inputs ,inputs))
	  ,@(when cbinfo
		  `(:before
		    (,@(when (member 'callback-included-cl superclasses)
			     `((setf (slot-value object 'callback) ,cbstruct)))
		       (make-funcallables-for-object object))
		    :after
		    ((trivial-garbage:finalize 
		      object
		      (lambda ()
			(cffi:foreign-free ,cbstruct))))))
	  :export nil
	  :index (reinitialize-instance ,class))))))
200 201

(defun mobject-maker
Liam Healy's avatar
Liam Healy committed
202
    (maker arglists class cl-alloc-args cl-initialize-args
203
     description documentation initialize-args initializerp settingp
Liam Healy's avatar
Liam Healy committed
204
     singular cbinfo)
205
  "Make the defun form that makes the mobject."
Liam Healy's avatar
Liam Healy committed
206
  (when cbinfo
Liam Healy's avatar
Liam Healy committed
207 208 209 210 211 212 213 214 215 216 217 218
    (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
		 ,@(when initargs
			 (append
			  (list
219 220 221 222
			   '&optional
			   (if (listp (first initargs))
			       `(,@(first initargs) ,settingp)
			       `(,(first initargs) nil ,settingp)))
Liam Healy's avatar
Liam Healy committed
223 224 225 226 227 228 229
			  (rest initargs))))))
       ,(format
	 nil "Create the GSL object representing a ~a (class ~a).~@[~&~a~]"
	 description class documentation)
       (let ((object
	      (make-instance
	       ',class
Liam Healy's avatar
Liam Healy committed
230
	       ,@(when cbinfo `(:cbinfo ',cbinfo))
Liam Healy's avatar
Liam Healy committed
231 232 233 234 235
	       ,@(if arglists
		     (second arglists)
		     (symbol-keyword-symbol cl-alloc-args singular)))))
	 ;; There is an initialization step
	 ,@(when initializerp
236
		 (if (or initialize-args arglists)	; with arguments
Liam Healy's avatar
Liam Healy committed
237 238 239 240 241 242 243 244 245 246 247
		     (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))))
248

249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271
(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."
272
  (if (listp symbol)
Liam Healy's avatar
Liam Healy committed
273
      (mappend (lambda (s) (symbol-keyword-symbol s singular)) symbol)
274 275 276 277 278
      (if (member (singular-symbol symbol) singular)
	  (list (intern (symbol-name symbol) :keyword)
		`(list ,(singular-symbol symbol)))
	  (list (intern (symbol-name symbol) :keyword)
		symbol))))
279

Liam Healy's avatar
Liam Healy committed
280 281 282
;;;;****************************************************************************
;;;; Generic functions
;;;;****************************************************************************
Liam Healy's avatar
Liam Healy committed
283

284 285 286 287
(defgeneric allocate (object &key &allow-other-keys)
  (:documentation
   "Use GSL to allocate memory.  Returns pointer but does not bind mpointer slot."))

288 289 290 291
(export 'name)
(defgeneric name (object)
  (:documentation "The name given to the GSL object."))

Liam Healy's avatar
Liam Healy committed
292 293 294 295 296 297
(export 'size)
(defgeneric size (object)
  (:documentation "The size of the GSL object.")
  (:method ((object array))
    (array-total-size object)))

298
(export 'evaluate)
299
(defgeneric evaluate (object point &key #+sbcl &allow-other-keys)
300 301
  (:documentation "Evaluate the GSL object."))

302
;;; Pointer type
303 304 305 306 307
(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."))
308

309 310 311 312 313 314 315 316 317 318 319 320 321
;;; 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)

322 323 324 325 326 327 328
;;; 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+))
329
  #+clisp (check-type object #.+foreign-pointer-type+)
330
  object)
Liam Healy's avatar
Liam Healy committed
331

332 333 334 335
(export 'order)
(defgeneric order (object)
  (:documentation "The order of the GSL object."))

Liam Healy's avatar
Liam Healy committed
336 337 338 339 340
;;;;****************************************************************************
;;;; Making objects from existing objects
;;;;****************************************************************************

(export 'copy)
Liam Healy's avatar
Liam Healy committed
341 342 343 344 345
(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
346 347 348 349 350 351 352 353 354 355 356 357

(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
358 359 360 361 362 363 364 365 366 367 368 369 370 371 372
      (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
373 374 375 376 377 378 379 380 381 382 383 384 385 386

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