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 / ascendMar8.tar / UMass / Epipolar / histogram.lisp < prev    next >
Lisp/Scheme  |  1995-07-21  |  7KB  |  179 lines
  1.  
  2. ;------------------------------------------------------------------
  3. ;  HISTOGRAM.LISP - histogram creation and manipulation
  4. ;  Bob Collins - file created 08/08/88 14:38:13
  5. ;------------------------------------------------------------------
  6. ;  Contents:
  7. ;------------------------------------------------------------------
  8. ; (c) Copyright 1988 by The University of Massachusetts
  9. ;------------------------------------------------------------------
  10.  
  11. (in-package 'histogram :nicknames '(hist))
  12.  
  13. (export '(make-histogram  clear-histogram
  14.      index-to-value  index-to-range  value-to-index
  15.      accumulate-by-value  accumulate-by-index  merge-histograms
  16.      bucket-count  find-highest-peak))
  17.  
  18.  
  19. (defstruct (histogram (:constructor internal-make-histogram))
  20.   (num-buckets 256)
  21.   (min-value 0)
  22.   (max-value 256)
  23.   (bucket-width 1)
  24.   (range-handler :threshold)
  25.   (array nil))
  26.  
  27. (defsubst threshold (value min-thresh max-thresh)
  28.   "  Thresholds value to lie in range (min-thresh,max-thresh) inclusive."
  29.   (min (max value min-thresh) max-thresh))
  30.  
  31. (defsubst in-range-p (value low high)
  32.   "Tests whether low <= value < high."
  33.   (and (<= low value) (< value high)))
  34.  
  35. (defsubst index-error-check (hist index)
  36.   (when (or (< index 0) (> index (1- (histogram-num-buckets hist))))
  37.     (error "The index value ~d is out of histogram index range [~d,~d]"
  38.        index 0 (1- (histogram-num-buckets hist)))))
  39.  
  40. (defun make-histogram-array (num-buckets &key (element-type 'single-float)
  41.                      (initial-element 0.0))
  42.   (make-array num-buckets
  43.           :element-type element-type
  44.           :initial-element initial-element))
  45.  
  46. (defun make-histogram (&key (num-buckets 256) (min-value 0) (max-value 255) 
  47.                (out-of-range-handler :threshold)
  48.                (element-type 'single-float))
  49.   "  Initialize and return a histogram structure for range [min,max).
  50.   Note that max-value is NOT within the histogram range. The argument
  51.   out-of-range-handler specifies what to do with values that fall 
  52.   outside of the range [min,max).  Options are :THRESHOLD to the
  53.   appropriate end bucket, :IGNORE the value completely, or signal
  54.   an :ERROR."
  55.   (unless (> num-buckets 0)     ;;some rudimentary error checking
  56.     (error "num-buckets must be a positive integer"))
  57.   (unless (>= max-value min-value)
  58.     (error "max-value must not be less than min-value"))
  59.   (ecase out-of-range-handler
  60.     ((:threshold :ignore :error)))
  61.   (internal-make-histogram 
  62.     :num-buckets num-buckets :min-value min-value
  63.     :max-value max-value
  64.     :bucket-width (/ (- max-value min-value) num-buckets)
  65.     :array (make-histogram-array num-buckets :element-type element-type)
  66.     :range-handler out-of-range-handler))
  67.  
  68. (defun clear-histogram (hist &key (clear-value 0.0))
  69.   "Clear the histogram, returning it to its initial state."
  70.   (let ((arr (histogram-array hist)))
  71.     (dotimes (i (length arr) hist)
  72.        (setf (aref arr i) clear-value))))
  73.  
  74. (defsubst subst-index-to-value (hist index)
  75.   (coerce (+ (histogram-min-value hist)
  76.          (* index (histogram-bucket-width hist)))
  77.       'single-float))
  78.  
  79. (defun index-to-value (hist index)
  80.   "  Compute the midpoint value of a given histogram bucket. 
  81.   Giving an index off the histogram is treated as an error."
  82.   (index-error-check hist index)
  83.   (subst-index-to-value hist (+ 0.5 (truncate index))))
  84.  
  85. (defun index-to-range (hist index)
  86.   "  Compute the value range of a given histogram bucket.  The range is returned
  87.   as a list of (low high).  If either low or high is nil, the range is open ended
  88.   in that direction."
  89.   (index-error-check hist index)
  90.   (setf index (truncate index))
  91.   (let ((low (subst-index-to-value hist index))
  92.     (high (subst-index-to-value hist (+ index 1)))
  93.     (thresholding? (eq (histogram-range-handler hist) :threshold)))
  94.     (list (if (and thresholding? (zerop index))
  95.           nil
  96.           low)
  97.       (if (and thresholding?
  98.            (= index (1- (histogram-num-buckets hist))))
  99.           nil
  100.           high))))
  101.  
  102. (defsubst subst-value-to-index (hist value)
  103.   (truncate (/ (- value (histogram-min-value hist))
  104.            (histogram-bucket-width hist))))
  105.  
  106. (defun value-to-index (hist value) 
  107.   "  Given a value, determine which histogram bucket it falls into.
  108.   Nil is returned if the value is out of range and histogram-range-handler
  109.   is :ignore."
  110.   (if (in-range-p value (histogram-min-value hist) (histogram-max-value hist))
  111.       (subst-value-to-index hist value)
  112.       (ecase (histogram-range-handler hist)
  113.     (:threshold (threshold
  114.                (subst-value-to-index hist value)
  115.                0  (1- (histogram-num-buckets hist))))
  116.     (:error (error "The value ~d is out of histogram value range [~d,~d)"
  117.                value (histogram-min-value hist)
  118.                (histogram-max-value hist)))
  119.     (:ignore nil))))
  120.  
  121. (defun accumulate-by-value (hist value &optional (weight 1.0))
  122.   "  Increment histogram bucket containing the given value.  The default
  123.   increment amount is 1.0, but can be specified by optional argument weight."
  124.   (incf (aref (histogram-array hist) (value-to-index hist value)) weight))
  125.  
  126. (defun accumulate-by-index (hist index &optional (weight 1.0))
  127.   "  Increment histogram bucket having the given index.  The default increment
  128.   amount is 1.0, but can be specified by optional argument weight."
  129.   (setf index (threshold (truncate index) 0 (1- (histogram-num-buckets hist))))
  130.   (incf (aref (histogram-array hist) index) weight))
  131.  
  132. (defun merge-histograms (hist1 hist2)
  133.   "  Destructively increment hist1 by the accumulated amounts in hist2.
  134.   The two histograms must be compatible (same min-value, max-value and
  135.   number of buckets)."
  136.   (let ((arr1 (histogram-array hist1))
  137.     (arr2 (histogram-array hist2)))
  138.     (if (and (= (length arr1) (length arr2))
  139.          (= (histogram-min-value hist1) (histogram-min-value hist2))
  140.          (= (histogram-max-value hist1) (histogram-max-value hist2)))
  141.     (dotimes (i (length arr1) hist1)
  142.         (incf (aref arr1 i) (aref arr2 i)))
  143.         (error "Histograms to merge are incompatible."))))
  144.  
  145. (defun bucket-count (hist index)
  146.   "Returns the amount accumulated in the specified histogram bucket."
  147.   (index-error-check hist index)
  148.   (aref (histogram-array hist) (truncate index)))
  149.  
  150. (defun posmax (sequence &optional (excluded-indices nil))
  151.   "  Find position and max value of sequence and return as multiple values.
  152.   Excluded-indices is a list of indices to be excluded from processing."
  153.   (let ((len (length sequence))
  154.     (pos -1)
  155.     (max most-negative-single-float))
  156.     (when (= len 0) (error "null sequence sent to posmax"))
  157.     (dotimes (i len)
  158.        (when (and (not (find i excluded-indices))
  159.           (> (elt sequence i) max))
  160.          (setf max (elt sequence i))
  161.          (setf pos i)))
  162.     (if (= pos -1)
  163.     nil  ;(error "Error in posmax, have you excluded all the indices?")
  164.         (values pos max))))
  165.  
  166. (defun find-highest-peak (hist &optional (excluded-indices nil))
  167.   "  Returns index of highest histogram peak and its height (the count in
  168.   that bucket) as multiple values.  Excluded-indices is a list of indices to
  169.   be excluded from processing."
  170.   (posmax (histogram-array hist) excluded-indices))
  171.  
  172. (defun scale-histogram (hist scale-factor)
  173.   (let ((arr (histogram-array hist)))
  174.     (dotimes (i (length arr) hist)
  175.       (setf (aref arr i) (* (aref arr i) scale-factor)))))
  176.  
  177.  
  178.  
  179.