external/clem/src/extrema.lisp

   1 ;;; extrema.lisp
   2 ;;; macros, functions and methods for finding matrix extrema
   3 ;;;
   4 ;;; Copyright (c) 2004-2006 Cyrus Harmon (ch-lisp@bobobeach.com)
   5 ;;; All rights reserved.
   6 ;;;
   7 ;;; Redistribution and use in source and binary forms, with or without
   8 ;;; modification, are permitted provided that the following conditions
   9 ;;; are met:
  10 ;;;
  11 ;;;   * Redistributions of source code must retain the above copyright
  12 ;;;     notice, this list of conditions and the following disclaimer.
  13 ;;;
  14 ;;;   * Redistributions in binary form must reproduce the above
  15 ;;;     copyright notice, this list of conditions and the following
  16 ;;;     disclaimer in the documentation and/or other materials
  17 ;;;     provided with the distribution.
  18 ;;;
  19 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  20 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  21 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  22 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  23 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  24 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  25 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  26 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  27 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  28 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  29 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  30 ;;;
  31
  32 (in-package :clem)
  33
  34 ;;; slow functions
  35
  36 (defmethod min-range ((m matrix) (startr fixnum) (endr fixnum) (startc fixnum) (endc fixnum))
  37   (declare (dynamic-extent startr endr startc endc)
  38            (fixnum startr endr startc endc))
  39   (let ((retval (val m startr startc)))
  40     (map-range m startr endr startc endc
  41                #'(lambda (v i j)
  42                    (declare (ignore i j))
  43                    (setf retval (min retval v))))
  44     retval))
  45
  46 (defmethod max-range ((m matrix) (startr fixnum) (endr fixnum) (startc fixnum) (endc fixnum))
  47   (let ((retval (val m startr startc)))
  48     (map-range m startr endr startc endc
  49                #'(lambda (v i j)
  50                    (declare (ignore i j))
  51                    (setf retval (max retval v))))
  52     retval))
  53
  54 (defmethod min-val ((m matrix))
  55   (let ((minval (row-major-mref m 0)))
  56     (loop for i from 0 below (matrix-total-size m)
  57        do (setf minval (min minval (row-major-mref m i))))
  58     minval))
  59
  60 (defmethod max-val ((m matrix))
  61   (let ((maxval (row-major-mref m 0)))
  62     (loop for i from 0 below (matrix-total-size m)
  63        do (setf maxval (max maxval (row-major-mref m i))))
  64     maxval))
  65
  66 ;;; fast functions
  67
  68 (defmacro def-matrix-min-max (type)
  69   (let ((element-type (element-type (find-class `,type)))
  70         (accumulator-element-type (element-type (find-class `,type))))
  71     `(progn
  72        (defmethod min-range ((m ,type) (startr fixnum) (endr fixnum) (startc fixnum) (endc fixnum))
  73          (let ((acc (coerce (aref (matrix-vals m) startr startc) ',accumulator-element-type)))
  74            (declare (type ,accumulator-element-type acc))
  75            (with-map-range m ,element-type startr endr startc endc (a i j)
  76              (when (< (aref a i j) acc)
  77                (setf acc (aref a i j))))
  78            acc))
  79
  80        (defmethod max-range ((m ,type) (startr fixnum) (endr fixnum) (startc fixnum) (endc fixnum))
  81          (let ((acc (coerce (aref (matrix-vals m) startr startc) ',accumulator-element-type)))
  82            (declare (type ,accumulator-element-type acc))
  83            (with-map-range m ,element-type startr endr startc endc (a i j)
  84              (when (> (aref a i j) acc)
  85                (setf acc (aref a i j))))
  86            acc)))))
  87
  88 (macrolet ((frob (type)
  89              `(def-matrix-min-max ,type)))
  90   (frob double-float-matrix)
  91   (frob single-float-matrix)
  92   (frob ub8-matrix)
  93   (frob ub16-matrix)
  94   (frob ub32-matrix)
  95   (frob sb8-matrix)
  96   (frob sb16-matrix)
  97   (frob sb32-matrix)
  98   (frob fixnum-matrix)
  99   (frob bit-matrix)
 100   (frob integer-matrix)
 101   (frob real-matrix))
 102