Skip to content
Snippets Groups Projects
Commit 99408223 authored by Liam M. Healy's avatar Liam M. Healy
Browse files

Merge branch 'clnet/defmfun-lambda'

Merge in definitions of 2D histograms.
parents 6e6df93e 9857f92c
No related branches found
No related tags found
No related merge requests found
;; Updating and accessing histogram elements. ;; Updating and accessing histogram elements.
;; Liam Healy, Mon Jan 1 2007 - 14:43 ;; 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 ;; Distributed under the terms of the GNU General Public License
;; ;;
;; This program is free software: you can redistribute it and/or modify ;; This program is free software: you can redistribute it and/or modify
...@@ -26,12 +26,9 @@ ...@@ -26,12 +26,9 @@
;;; Missing: 2D functions/methods; the 1D functions will need to be made into methods if not already. ;;; 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 ;;; http://www.gnu.org/s/gsl/manual/html_node/Updating-and-accessing-2D-histogram-elements.html
(defmfun increment (histogram value &optional weight) (defgeneric increment (histogram value &optional weight)
("gsl_histogram_increment" "gsl_histogram_accumulate") (:documentation
((((mpointer histogram) :pointer) (value :double)) "Update the histogram by adding the weight
(((mpointer histogram) :pointer) (value :double) (weight :double)))
:documentation
"Update the histogram by adding the weight
(which defaults to 1.0) to the (which defaults to 1.0) to the
bin whose range contains the coordinate x. bin whose range contains the coordinate x.
...@@ -43,7 +40,19 @@ ...@@ -43,7 +40,19 @@
issues a warning input-domain, and none of the bins are modified. The error 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 handler is not called, however, since it is often necessary to compute
histograms for a small range of a larger dataset, ignoring the values 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) (defmfun grid:aref ((histogram histogram) &rest indices)
"gsl_histogram_get" "gsl_histogram_get"
...@@ -56,12 +65,18 @@ ...@@ -56,12 +65,18 @@
If i lies outside the valid range of index for the If i lies outside the valid range of index for the
histogram then an error (input-domain) is signalled.") histogram then an error (input-domain) is signalled.")
(defmfun range (histogram i) (defmfun grid:aref ((histogram histogram2d) &rest indices)
"gsl_histogram_get_range" "gsl_histogram2d_get"
(((mpointer histogram) :pointer) (i :sizet) (((mpointer histogram) :pointer) ((first indices) :sizet) ((second indices) :sizet))
(lower (:pointer :double)) (upper (:pointer :double))) :definition :method
:documentation ; FDL :c-return :double
"Find the upper and lower range limits of the i-th :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 bin of the histogram. If the index i is valid then the
corresponding range limits are stored in lower and upper. corresponding range limits are stored in lower and upper.
The lower limit is inclusive (i.e. events with this coordinate are The lower limit is inclusive (i.e. events with this coordinate are
...@@ -70,20 +85,82 @@ ...@@ -70,20 +85,82 @@
neighboring higher bin, if it exists). neighboring higher bin, if it exists).
If i lies outside the valid range of indices for If i lies outside the valid range of indices for
the histogram, then the error input-domain is signalled.") 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" "gsl_histogram_max"
(((mpointer histogram) :pointer)) (((mpointer histogram) :pointer))
:c-return :double :c-return :double
:documentation ; FDL :definition :method)
"The maximum upper range limit of the histogram.")
(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" "gsl_histogram_min"
(((mpointer histogram) :pointer)) (((mpointer histogram) :pointer))
:c-return :double :c-return :double
:documentation ; FDL :definition :method)
"The minimum lower range limit of the histogram.")
(defmfun grid:dimensions ((histogram histogram)) (defmfun grid:dimensions ((histogram histogram))
"gsl_histogram_bins" "gsl_histogram_bins"
...@@ -94,6 +171,24 @@ ...@@ -94,6 +171,24 @@
:documentation ; FDL :documentation ; FDL
"The number of bins in the histogram.") "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)) (defmfun set-zero ((histogram histogram))
"gsl_histogram_reset" "gsl_histogram_reset"
(((mpointer histogram) :pointer)) (((mpointer histogram) :pointer))
...@@ -102,6 +197,14 @@ ...@@ -102,6 +197,14 @@
:documentation ; FDL :documentation ; FDL
"Reset all the bins in the histogram to zero.") "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) (defmfun histogram-find (histogram x-value &optional y-value)
("gsl_histogram_find" "gsl_histogram2d_find") ("gsl_histogram_find" "gsl_histogram2d_find")
((((mpointer histogram) :pointer) (x-value :double) (bin (:pointer :sizet))) ((((mpointer histogram) :pointer) (x-value :double) (bin (:pointer :sizet)))
......
;; Macro for defining GSL functions. ;; Macro for defining GSL functions.
;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp ;; 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 ;; Distributed under the terms of the GNU General Public License
;; ;;
;; This program is free software: you can redistribute it and/or modify ;; This program is free software: you can redistribute it and/or modify
...@@ -33,7 +33,7 @@ ...@@ -33,7 +33,7 @@
;;; the interfaces to all the specific GSL functions. ;;; the interfaces to all the specific GSL functions.
;;; Required arguments to defmfun: ;;; 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 ;;; arglist The CL argument list for the function
;;; gsl-name A string or list of strings representing the name(s) of ;;; gsl-name A string or list of strings representing the name(s) of
;;; the GSL function(s) ;;; the GSL function(s)
...@@ -122,9 +122,9 @@ ...@@ -122,9 +122,9 @@
(when (or cbinfo callback-object) (when (or cbinfo callback-object)
(if callback-object (if callback-object
(let ((class (let ((class
(if (listp callback-object) (if (listp callback-object)
(second (first callback-object)) (second (first callback-object))
(category-for-argument arglist callback-object)))) (category-for-argument arglist callback-object))))
(list (mobject-fnvnames (list (mobject-fnvnames
class class
(number-of-callbacks (get-callbacks-for-class class))) (number-of-callbacks (get-callbacks-for-class class)))
...@@ -135,7 +135,7 @@ ...@@ -135,7 +135,7 @@
(list name 'dynfn) num-callbacks :gsl) (list name 'dynfn) num-callbacks :gsl)
(make-symbol-cardinals (make-symbol-cardinals
(list name 'cbfn) num-callbacks :gsl))))) (list name 'cbfn) num-callbacks :gsl)))))
#+fsbv fsbv-functions #+fsbv (list)) #+fsbv fsbv-functions #+fsbv (list))
(wrap-index-export (wrap-index-export
(cond (cond
((eq definition :generic) ((eq definition :generic)
...@@ -146,35 +146,45 @@ ...@@ -146,35 +146,45 @@
(expand-defmfun-defmethods name arglist gsl-name c-arguments key-args)) (expand-defmfun-defmethods name arglist gsl-name c-arguments key-args))
((optional-args-to-switch-gsl-functions arglist gsl-name) ((optional-args-to-switch-gsl-functions arglist gsl-name)
(expand-defmfun-optional name arglist gsl-name c-arguments key-args)) (expand-defmfun-optional name arglist gsl-name c-arguments key-args))
((eq definition :function) ((member definition '(nil :function))
(complete-definition 'cl:defun name arglist gsl-name c-arguments key-args))) (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)))) 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) (defun wrap-index-export (expanded-body name gsl-name key-args)
"Wrap the expanded-body with index and export if requested. "Wrap the expanded-body with index and export if requested.
Use a progn if needed." Use a progn if needed."
(with-defmfun-key-args key-args (with-defmfun-key-args key-args
(let ((index-export (let ((index-export
(progn (when name
(if (eq index t) (setf index name)) (if (eq index t) (setf index name))
(flet ((mapnfn (gslnm) `(map-name ',index ,gslnm))) (flet ((mapnfn (gslnm) `(map-name ',index ,gslnm)))
(append (append
(when index (when index
(if indexed-functions (if indexed-functions
(mapcar #'mapnfn indexed-functions) (mapcar #'mapnfn indexed-functions)
(if (listp gsl-name) (if (listp gsl-name)
(mapcar #'mapnfn gsl-name) (mapcar #'mapnfn gsl-name)
(list (mapnfn gsl-name))))) (list (mapnfn gsl-name)))))
(when export `((export ',name)))))))) (when export `((export ',name))))))))
`(let () ; no progn here because of CLISP bug (wrap-progn
,@(if (symbolp (first expanded-body)) (list expanded-body) expanded-body) (append
,@(make-defmcallbacks (if (symbolp (first expanded-body)) (list expanded-body) expanded-body)
cbinfo (make-defmcallbacks
(second callback-dynamic-variables) cbinfo
(first callback-dynamic-variables)) (second callback-dynamic-variables)
#+fsbv (first callback-dynamic-variables))
,@fsbv-functions #+fsbv
,@index-export)))) fsbv-functions
index-export)))))
;;;;**************************************************************************** ;;;;****************************************************************************
;;;; A method for a generic function, on any class ;;;; A method for a generic function, on any class
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment