external/clem/src/vector.lisp

   1 ;;; vector.lisp
   2 ;;; macros, functions and methods for matrix element access
   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 ;;; this might all go away soon, but for the moment put some stuff
  33 ;;; that is common between row-vector and column-vector in here.
  34
  35 (in-package :clem)
  36
  37 (defclass base-vector (matrix) ())
  38
  39 (defgeneric vec-dim (vec))
  40 (defgeneric vec-val (vec i))
  41 (defgeneric vec-set-val (vec i val))
  42
  43 (defclass row-vector (base-vector) ())
  44 (defclass col-vector (base-vector) ())
  45
  46 (defmethod allocate-matrix-vals ((object row-vector) &key rows cols adjustable initial-element)
  47   (declare (ignore rows))
  48   (setf (slot-value object 'm)
  49         (make-array (list cols)
  50                     :adjustable adjustable
  51                     :initial-element initial-element
  52                     :element-type (element-type (class-of object)))))
  53
  54 (defgeneric array->row-vector (a))
  55 (defmethod array->row-vector ((a array))
  56   (let ((d (array-dimensions a)))
  57     (cond ((= (length d) 2)
  58            (let* ((cols (second d))
  59                   (m (make-instance 'row-vector :cols cols)))
  60              (dotimes (i cols)
  61                (vec-set-val m i (aref a 0 i)))
  62              m))
  63           ((= (length d) 1)
  64            (let ((m (make-instance 'row-vector :cols (first d))))
  65              (dotimes (i (first d)) (vec-set-val m i (aref a i)))
  66              m)))))
  67
  68 (defmethod vec-dim ((rv row-vector)) (array-dimensions (matrix-vals rv)))
  69 (defmethod vec-val ((rv row-vector) i) (aref (matrix-vals rv) i))
  70 (defmethod vec-set-val ((rv row-vector) i v) (setf (aref (matrix-vals rv) i) v))
  71
  72 (defmethod dim ((rv row-vector)) (append '(1) (vec-dim rv)))
  73 (defmethod rows ((rv row-vector)) 1)
  74 (defmethod cols ((rv row-vector)) (first (array-dimensions (matrix-vals rv))))
  75 (defmethod val ((rv row-vector) i j) (declare (ignore i)) (vec-val rv j))
  76 (defmethod set-val ((rv row-vector) i j v &key (coerce t))
  77   (declare (ignore i))
  78   (vec-set-val rv j (if coerce (coerce v (element-type (class-of rv))) v)))
  79
  80 (defmethod transpose ((rv row-vector))
  81   (let ((c (cols rv)))
  82     (let ((cv (make-instance 'col-vector :rows c)))
  83       (dotimes (j c cv)
  84         (vec-set-val cv j (vec-val rv j))))))
  85
  86 (defmethod print-matrix ((rv row-vector))
  87   (let ((d (vec-dim rv)))
  88     (format t "~&((")
  89     (dotimes (i (first d))
  90       (format t (if (= i 0) "~a" " ~a") (vec-val rv i)))
  91     (format t "))")))
  92
  93 (defmethod set-row ((m matrix) r (v row-vector))
  94   (do
  95       ((i 0 (+ i 1)))
  96       ((= i (cols v)))
  97     (set-val m r i (vec-val v i))))
  98
  99 (defmethod set-col ((m matrix) r (v row-vector))
 100   (do
 101       ((i 0 (+ i 1)))
 102       ((= i (cols v)))
 103     (set-val m i r (vec-val v i))))
 104
 105 (defgeneric get-row-vector (m r))
 106 (defmethod get-row-vector ((m matrix) r)
 107   (let ((rv (make-instance 'row-vector :cols (second (dim m)))))
 108     (dotimes (i (second (dim m)))
 109       (vec-set-val rv i (val m r i)))))
 110
 111 (defgeneric zero-row-vector (j))
 112 (defmethod zero-row-vector((j fixnum))
 113   (zero-matrix 1 j))
 114
 115 (defmethod allocate-matrix-vals ((object col-vector) &key rows cols adjustable initial-element)
 116   (declare (ignore cols))
 117   (setf (slot-value object 'm)
 118         (make-array (list rows)
 119                     :adjustable adjustable
 120                     :initial-element initial-element
 121                     :element-type (element-type (class-of object)))))
 122
 123 (defmethod vec-dim ((cv col-vector)) (array-dimensions (matrix-vals cv)))
 124 (defmethod vec-val ((cv col-vector) i) (aref (matrix-vals cv) i))
 125 (defmethod vec-set-val ((cv col-vector) i v) (setf (aref (matrix-vals cv) i) v))
 126
 127 (defmethod dim ((cv col-vector)) (append (vec-dim cv) '(1)))
 128 (defmethod rows ((cv col-vector)) (first (array-dimensions (matrix-vals cv))))
 129 (defmethod cols ((cv col-vector)) 1)
 130 (defmethod val ((cv col-vector) i j) (declare (ignore j)) (vec-val cv i))
 131 (defmethod set-val ((cv col-vector) i j v &key (coerce t))
 132   (declare (ignore j))
 133   (vec-set-val cv i (if coerce (coerce v (element-type (class-of cv))) v)))
 134
 135 (defgeneric array->col-vector (a))
 136
 137 (defmethod array->col-vector ((a array))
 138   (let ((d (array-dimensions a)))
 139     (cond ((= (length d) 2)
 140            (let* ((rows (first d))
 141                   (m (make-instance 'col-vector :rows rows)))
 142              (dotimes (i rows) (vec-set-val m i (aref a i 0)))
 143              m))
 144           ((= (length d) 1)
 145            (let ((m (make-instance 'col-vector :rows (first d))))
 146              (dotimes (i (first d)) (vec-set-val m i (aref a i)))
 147              m)))))
 148
 149 (defmethod transpose ((cv col-vector))
 150   (let ((r (rows cv)))
 151     (let ((rv (make-instance 'row-vector :cols r)))
 152       (dotimes (j r rv)
 153         (vec-set-val rv j (vec-val cv j))))))
 154
 155 (defmethod print-matrix ((cv col-vector))
 156   (let ((d (vec-dim cv)))
 157     (format t "~&(")
 158     (dotimes (i (first d))
 159       (format t (if (= i 0) "(~a)" " (~a)") (vec-val cv i)))
 160     (format t ")")))
 161
 162 (defmethod set-row ((m matrix) r (v col-vector))
 163   (do
 164       ((i 0 (+ i 1)))
 165       ((= i (rows v)))
 166     (set-val m r i (vec-val v i))))
 167
 168 (defmethod set-col ((m matrix) c (v col-vector))
 169   (do
 170       ((i 0 (+ i 1)))
 171       ((= i (first (dim v))))
 172     (set-val m i c (val v i 0))))
 173
 174 (defgeneric get-row-as-col-vector (m r))
 175 (defmethod get-row-as-col-vector ((m matrix) r)
 176   (let ((cv (make-instance 'col-vector :rows (second (dim m)))))
 177     (dotimes (i (second (dim m)))
 178       (vec-set-val cv i (val m r i)))))
 179
 180 (defgeneric get-col-vector (m r))
 181 (defmethod get-col-vector ((m matrix) r)
 182   (let ((cv (make-instance 'col-vector :rows (first (dim m)))))
 183     (dotimes (i (first (dim m)))
 184       (vec-set-val cv i (val m i r)))))
 185
 186 (defgeneric zero-col-vector (j))
 187 (defmethod zero-col-vector((j fixnum))
 188   (zero-matrix j 1))