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.