diff --git a/histogram/updating-accessing.lisp b/histogram/updating-accessing.lisp index 6785413c4d6169f8c7f8a6c5fb1d695f6409ee81..750910eff23ee1be254b439903d82f63337bbf70 100644 --- a/histogram/updating-accessing.lisp +++ b/histogram/updating-accessing.lisp @@ -1,8 +1,8 @@ ;; Updating and accessing histogram elements. ;; Liam Healy, Mon Jan 1 2007 - 14:43 -;; Time-stamp: <2012-01-13 12:01:27EST updating-accessing.lisp> +;; Time-stamp: <2014-02-22 15:33:57EST updating-accessing.lisp> ;; -;; Copyright 2007, 2008, 2009, 2011 Liam M. Healy +;; Copyright 2007, 2008, 2009, 2011, 2012, 2014 Liam M. Healy ;; Distributed under the terms of the GNU General Public License ;; ;; This program is free software: you can redistribute it and/or modify @@ -26,12 +26,9 @@ ;;; Missing: 2D functions/methods; the 1D functions will need to be made into methods if not already. ;;; http://www.gnu.org/s/gsl/manual/html_node/Updating-and-accessing-2D-histogram-elements.html -(defmfun increment (histogram value &optional weight) - ("gsl_histogram_increment" "gsl_histogram_accumulate") - ((((mpointer histogram) :pointer) (value :double)) - (((mpointer histogram) :pointer) (value :double) (weight :double))) - :documentation - "Update the histogram by adding the weight +(defgeneric increment (histogram value &optional weight) + (:documentation + "Update the histogram by adding the weight (which defaults to 1.0) to the bin whose range contains the coordinate x. @@ -43,7 +40,19 @@ issues a warning input-domain, and none of the bins are modified. The error handler is not called, however, since it is often necessary to compute histograms for a small range of a larger dataset, ignoring the values - outside the range of interest.") + outside the range of interest.")) + +(defmfun increment ((histogram histogram) value &optional weight) + ("gsl_histogram_increment" "gsl_histogram_accumulate") + ((((mpointer histogram) :pointer) (value :double)) + (((mpointer histogram) :pointer) (value :double) (weight :double))) + :definition :method) + +(defmfun increment ((histogram histogram2d) values &optional weight) + ("gsl_histogram2d_increment" "gsl_histogram2d_accumulate") + ((((mpointer histogram) :pointer) ((first values) :double) ((second values) :double)) + (((mpointer histogram) :pointer) ((first values) :double) ((second values) :double) (weight :double))) + :definition :method) (defmfun grid:aref ((histogram histogram) &rest indices) "gsl_histogram_get" @@ -56,12 +65,18 @@ If i lies outside the valid range of index for the histogram then an error (input-domain) is signalled.") -(defmfun range (histogram i) - "gsl_histogram_get_range" - (((mpointer histogram) :pointer) (i :sizet) - (lower (:pointer :double)) (upper (:pointer :double))) - :documentation ; FDL - "Find the upper and lower range limits of the i-th +(defmfun grid:aref ((histogram histogram2d) &rest indices) + "gsl_histogram2d_get" + (((mpointer histogram) :pointer) ((first indices) :sizet) ((second indices) :sizet)) + :definition :method + :c-return :double + :index grid:aref + :documentation + "Return the contents of the i-th, j-th bin of the 2D histogram. If either index lies outside the valid range of index for the histogram then an error (input-domain) is signalled.") + +(defgeneric range (histogram i) + (:documentation + "Find the upper and lower range limits of the i-th bin of the histogram. If the index i is valid then the corresponding range limits are stored in lower and upper. The lower limit is inclusive (i.e. events with this coordinate are @@ -70,20 +85,82 @@ neighboring higher bin, if it exists). If i lies outside the valid range of indices for the histogram, then the error input-domain is signalled.") + (:method ((histogram histogram2d) i) + (list + (funcall + (defmfun nil (histogram i) + "gsl_histogram2d_get_xrange" + (((mpointer histogram) :pointer) (i :sizet))) + histogram) + (funcall + (defmfun nil (histogram i) + "gsl_histogram2d_get_yrange" + (((mpointer histogram) :pointer) (i :sizet))) + histogram)))) + +(map-name 'range "gsl_histogram2d_get_xrange") +(map-name 'range "gsl_histogram2d_get_yrange") +(export 'range) -(defmfun max-range (histogram) +(defmfun range ((histogram histogram) i) + "gsl_histogram_get_range" + (((mpointer histogram) :pointer) (i :sizet) + (lower (:pointer :double)) (upper (:pointer :double))) + :definition :method) + +(defgeneric max-range (histogram) + (:documentation "The maximum upper range limit(s) of the histogram.") + (:method ((histogram histogram2d)) + (list + (funcall + (defmfun nil (histogram) + "gsl_histogram2d_xmax" + (((mpointer histogram) :pointer)) + :c-return :double) + histogram) + (funcall + (defmfun nil (histogram) + "gsl_histogram2d_ymax" + (((mpointer histogram) :pointer)) + :c-return :double) + histogram)))) + +(map-name 'max-range "gsl_histogram2d_xmax") +(map-name 'max-range "gsl_histogram2d_ymax") +(export 'max-range) + +(defmfun max-range ((histogram histogram)) "gsl_histogram_max" (((mpointer histogram) :pointer)) :c-return :double - :documentation ; FDL - "The maximum upper range limit of the histogram.") + :definition :method) + +(defgeneric min-range (histogram) + (:documentation "The minimum lower range limit(s) of the histogram.") + (:method ((histogram histogram2d)) + (list + (funcall + (defmfun nil (histogram) + "gsl_histogram2d_xmin" + (((mpointer histogram) :pointer)) + :c-return :double) + histogram) + (funcall + (defmfun nil (histogram) + "gsl_histogram2d_ymin" + (((mpointer histogram) :pointer)) + :c-return :double) + histogram)))) + +(map-name 'min-range "gsl_histogram2d_xmin") +(map-name 'min-range "gsl_histogram2d_ymin") +(export 'min-range) -(defmfun min-range (histogram) +(defmfun min-range ((histogram histogram)) "gsl_histogram_min" (((mpointer histogram) :pointer)) :c-return :double - :documentation ; FDL - "The minimum lower range limit of the histogram.") + :definition :method) (defmfun grid:dimensions ((histogram histogram)) "gsl_histogram_bins" @@ -94,6 +171,24 @@ :documentation ; FDL "The number of bins in the histogram.") +(defmethod grid:dimensions ((histogram histogram2d)) + (list + (funcall + (defmfun nil (histogram) + "gsl_histogram2d_nx" + (((mpointer histogram) :pointer)) + :c-return :sizet) + histogram) + (funcall + (defmfun nil (histogram) + "gsl_histogram2d_ny" + (((mpointer histogram) :pointer)) + :c-return :sizet) + histogram))) + +(map-name 'grid:dimensions "gsl_histogram2d_nx") +(map-name 'grid:dimensions "gsl_histogram2d_ny") + (defmfun set-zero ((histogram histogram)) "gsl_histogram_reset" (((mpointer histogram) :pointer)) @@ -102,6 +197,14 @@ :documentation ; FDL "Reset all the bins in the histogram to zero.") +(defmfun set-zero ((histogram histogram2d)) + "gsl_histogram2d_reset" + (((mpointer histogram) :pointer)) + :definition :method + :c-return :void + :documentation ; FDL + "Reset all the bins in the histogram to zero.") + (defmfun histogram-find (histogram x-value &optional y-value) ("gsl_histogram_find" "gsl_histogram2d_find") ((((mpointer histogram) :pointer) (x-value :double) (bin (:pointer :sizet))) diff --git a/init/defmfun.lisp b/init/defmfun.lisp index ef02ae6d5d898b7a511934307472e4c96ab64bad..3f6db860439d7e72d6e0c8d05f0d3af2a8d7b4a5 100644 --- a/init/defmfun.lisp +++ b/init/defmfun.lisp @@ -1,8 +1,8 @@ ;; Macro for defining GSL functions. ;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp -;; Time-stamp: <2010-08-11 09:07:31EDT defmfun.lisp> +;; Time-stamp: <2014-02-16 09:11:46EST defmfun.lisp> ;; -;; Copyright 2009 Liam M. Healy +;; Copyright 2008, 2009, 2010, 2014 Liam M. Healy ;; Distributed under the terms of the GNU General Public License ;; ;; This program is free software: you can redistribute it and/or modify @@ -33,7 +33,7 @@ ;;; the interfaces to all the specific GSL functions. ;;; Required arguments to defmfun: -;;; name The name of the function being defined in CL +;;; name The name of the function being defined in CL; if NIL, then a lambda is created. ;;; arglist The CL argument list for the function ;;; gsl-name A string or list of strings representing the name(s) of ;;; the GSL function(s) @@ -122,9 +122,9 @@ (when (or cbinfo callback-object) (if callback-object (let ((class - (if (listp callback-object) - (second (first callback-object)) - (category-for-argument arglist callback-object)))) + (if (listp callback-object) + (second (first callback-object)) + (category-for-argument arglist callback-object)))) (list (mobject-fnvnames class (number-of-callbacks (get-callbacks-for-class class))) @@ -135,7 +135,7 @@ (list name 'dynfn) num-callbacks :gsl) (make-symbol-cardinals (list name 'cbfn) num-callbacks :gsl))))) - #+fsbv fsbv-functions #+fsbv (list)) + #+fsbv fsbv-functions #+fsbv (list)) (wrap-index-export (cond ((eq definition :generic) @@ -146,35 +146,45 @@ (expand-defmfun-defmethods name arglist gsl-name c-arguments key-args)) ((optional-args-to-switch-gsl-functions arglist gsl-name) (expand-defmfun-optional name arglist gsl-name c-arguments key-args)) - ((eq definition :function) - (complete-definition 'cl:defun name arglist gsl-name c-arguments key-args))) + ((member definition '(nil :function)) + (if name + (complete-definition 'cl:defun name arglist gsl-name c-arguments key-args) + (complete-definition 'cl:lambda nil arglist gsl-name c-arguments key-args)))) name gsl-name key-args)))) +(defun wrap-progn (args) + "Wrap the arguments in a progn." + (if (rest args) + #-clisp (cons 'progn args) + #+clisp (append (list 'let nil) args) ; CLISP bug workaround + (first args))) + (defun wrap-index-export (expanded-body name gsl-name key-args) "Wrap the expanded-body with index and export if requested. Use a progn if needed." (with-defmfun-key-args key-args (let ((index-export - (progn - (if (eq index t) (setf index name)) - (flet ((mapnfn (gslnm) `(map-name ',index ,gslnm))) - (append - (when index - (if indexed-functions - (mapcar #'mapnfn indexed-functions) - (if (listp gsl-name) - (mapcar #'mapnfn gsl-name) - (list (mapnfn gsl-name))))) - (when export `((export ',name)))))))) - `(let () ; no progn here because of CLISP bug - ,@(if (symbolp (first expanded-body)) (list expanded-body) expanded-body) - ,@(make-defmcallbacks - cbinfo - (second callback-dynamic-variables) - (first callback-dynamic-variables)) - #+fsbv - ,@fsbv-functions - ,@index-export)))) + (when name + (if (eq index t) (setf index name)) + (flet ((mapnfn (gslnm) `(map-name ',index ,gslnm))) + (append + (when index + (if indexed-functions + (mapcar #'mapnfn indexed-functions) + (if (listp gsl-name) + (mapcar #'mapnfn gsl-name) + (list (mapnfn gsl-name))))) + (when export `((export ',name)))))))) + (wrap-progn + (append + (if (symbolp (first expanded-body)) (list expanded-body) expanded-body) + (make-defmcallbacks + cbinfo + (second callback-dynamic-variables) + (first callback-dynamic-variables)) + #+fsbv + fsbv-functions + index-export))))) ;;;;**************************************************************************** ;;;; A method for a generic function, on any class