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
Loading
Loading
Loading
Loading
+124 −21
Original line number Diff line number Diff line
;; 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,11 +26,8 @@
;;; 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
(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,11 +65,17 @@
   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
(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.
@@ -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)

(defmfun min-range (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 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)))
+39 −29
Original line number Diff line number Diff line
;; 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)
@@ -146,16 +146,25 @@
	  (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
	    (when name
	      (if (eq index t) (setf index name))
	      (flet ((mapnfn (gslnm) `(map-name ',index ,gslnm)))
		(append
@@ -166,15 +175,16 @@
			   (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
      (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))))
	fsbv-functions
	index-export)))))

;;;;****************************************************************************
;;;; A method for a generic function, on any class