home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
vis-ftp.cs.umass.edu
/
vis-ftp.cs.umass.edu.tar
/
vis-ftp.cs.umass.edu
/
pub
/
Software
/
ASCENDER
/
ascender.tar.Z
/
ascender.tar
/
Epipolar
/
histogram.lisp
< prev
next >
Wrap
Lisp/Scheme
|
1995-07-21
|
7KB
|
179 lines
;------------------------------------------------------------------
; HISTOGRAM.LISP - histogram creation and manipulation
; Bob Collins - file created 08/08/88 14:38:13
;------------------------------------------------------------------
; Contents:
;------------------------------------------------------------------
; (c) Copyright 1988 by The University of Massachusetts
;------------------------------------------------------------------
(in-package 'histogram :nicknames '(hist))
(export '(make-histogram clear-histogram
index-to-value index-to-range value-to-index
accumulate-by-value accumulate-by-index merge-histograms
bucket-count find-highest-peak))
(defstruct (histogram (:constructor internal-make-histogram))
(num-buckets 256)
(min-value 0)
(max-value 256)
(bucket-width 1)
(range-handler :threshold)
(array nil))
(defsubst threshold (value min-thresh max-thresh)
" Thresholds value to lie in range (min-thresh,max-thresh) inclusive."
(min (max value min-thresh) max-thresh))
(defsubst in-range-p (value low high)
"Tests whether low <= value < high."
(and (<= low value) (< value high)))
(defsubst index-error-check (hist index)
(when (or (< index 0) (> index (1- (histogram-num-buckets hist))))
(error "The index value ~d is out of histogram index range [~d,~d]"
index 0 (1- (histogram-num-buckets hist)))))
(defun make-histogram-array (num-buckets &key (element-type 'single-float)
(initial-element 0.0))
(make-array num-buckets
:element-type element-type
:initial-element initial-element))
(defun make-histogram (&key (num-buckets 256) (min-value 0) (max-value 255)
(out-of-range-handler :threshold)
(element-type 'single-float))
" Initialize and return a histogram structure for range [min,max).
Note that max-value is NOT within the histogram range. The argument
out-of-range-handler specifies what to do with values that fall
outside of the range [min,max). Options are :THRESHOLD to the
appropriate end bucket, :IGNORE the value completely, or signal
an :ERROR."
(unless (> num-buckets 0) ;;some rudimentary error checking
(error "num-buckets must be a positive integer"))
(unless (>= max-value min-value)
(error "max-value must not be less than min-value"))
(ecase out-of-range-handler
((:threshold :ignore :error)))
(internal-make-histogram
:num-buckets num-buckets :min-value min-value
:max-value max-value
:bucket-width (/ (- max-value min-value) num-buckets)
:array (make-histogram-array num-buckets :element-type element-type)
:range-handler out-of-range-handler))
(defun clear-histogram (hist &key (clear-value 0.0))
"Clear the histogram, returning it to its initial state."
(let ((arr (histogram-array hist)))
(dotimes (i (length arr) hist)
(setf (aref arr i) clear-value))))
(defsubst subst-index-to-value (hist index)
(coerce (+ (histogram-min-value hist)
(* index (histogram-bucket-width hist)))
'single-float))
(defun index-to-value (hist index)
" Compute the midpoint value of a given histogram bucket.
Giving an index off the histogram is treated as an error."
(index-error-check hist index)
(subst-index-to-value hist (+ 0.5 (truncate index))))
(defun index-to-range (hist index)
" Compute the value range of a given histogram bucket. The range is returned
as a list of (low high). If either low or high is nil, the range is open ended
in that direction."
(index-error-check hist index)
(setf index (truncate index))
(let ((low (subst-index-to-value hist index))
(high (subst-index-to-value hist (+ index 1)))
(thresholding? (eq (histogram-range-handler hist) :threshold)))
(list (if (and thresholding? (zerop index))
nil
low)
(if (and thresholding?
(= index (1- (histogram-num-buckets hist))))
nil
high))))
(defsubst subst-value-to-index (hist value)
(truncate (/ (- value (histogram-min-value hist))
(histogram-bucket-width hist))))
(defun value-to-index (hist value)
" Given a value, determine which histogram bucket it falls into.
Nil is returned if the value is out of range and histogram-range-handler
is :ignore."
(if (in-range-p value (histogram-min-value hist) (histogram-max-value hist))
(subst-value-to-index hist value)
(ecase (histogram-range-handler hist)
(:threshold (threshold
(subst-value-to-index hist value)
0 (1- (histogram-num-buckets hist))))
(:error (error "The value ~d is out of histogram value range [~d,~d)"
value (histogram-min-value hist)
(histogram-max-value hist)))
(:ignore nil))))
(defun accumulate-by-value (hist value &optional (weight 1.0))
" Increment histogram bucket containing the given value. The default
increment amount is 1.0, but can be specified by optional argument weight."
(incf (aref (histogram-array hist) (value-to-index hist value)) weight))
(defun accumulate-by-index (hist index &optional (weight 1.0))
" Increment histogram bucket having the given index. The default increment
amount is 1.0, but can be specified by optional argument weight."
(setf index (threshold (truncate index) 0 (1- (histogram-num-buckets hist))))
(incf (aref (histogram-array hist) index) weight))
(defun merge-histograms (hist1 hist2)
" Destructively increment hist1 by the accumulated amounts in hist2.
The two histograms must be compatible (same min-value, max-value and
number of buckets)."
(let ((arr1 (histogram-array hist1))
(arr2 (histogram-array hist2)))
(if (and (= (length arr1) (length arr2))
(= (histogram-min-value hist1) (histogram-min-value hist2))
(= (histogram-max-value hist1) (histogram-max-value hist2)))
(dotimes (i (length arr1) hist1)
(incf (aref arr1 i) (aref arr2 i)))
(error "Histograms to merge are incompatible."))))
(defun bucket-count (hist index)
"Returns the amount accumulated in the specified histogram bucket."
(index-error-check hist index)
(aref (histogram-array hist) (truncate index)))
(defun posmax (sequence &optional (excluded-indices nil))
" Find position and max value of sequence and return as multiple values.
Excluded-indices is a list of indices to be excluded from processing."
(let ((len (length sequence))
(pos -1)
(max most-negative-single-float))
(when (= len 0) (error "null sequence sent to posmax"))
(dotimes (i len)
(when (and (not (find i excluded-indices))
(> (elt sequence i) max))
(setf max (elt sequence i))
(setf pos i)))
(if (= pos -1)
nil ;(error "Error in posmax, have you excluded all the indices?")
(values pos max))))
(defun find-highest-peak (hist &optional (excluded-indices nil))
" Returns index of highest histogram peak and its height (the count in
that bucket) as multiple values. Excluded-indices is a list of indices to
be excluded from processing."
(posmax (histogram-array hist) excluded-indices))
(defun scale-histogram (hist scale-factor)
(let ((arr (histogram-array hist)))
(dotimes (i (length arr) hist)
(setf (aref arr i) (* (aref arr i) scale-factor)))))