Commit 99408223 by Liam M. Healy

Merge branch 'clnet/defmfun-lambda'

Merge in definitions of 2D histograms.
parents 6e6df93e 9857f92c
;; 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)))
......
;; 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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment