external/clem/src/early-matrix.lisp

   1 ;;; early-matrix.lisp
   2 ;;;
   3 ;;; Copyright (c) 2004-2006 Cyrus Harmon (ch-lisp@bobobeach.com)
   4 ;;; All rights reserved.
   5 ;;;
   6 ;;; Redistribution and use in source and binary forms, with or without
   7 ;;; modification, are permitted provided that the following conditions
   8 ;;; are met:
   9 ;;;
  10 ;;;   * Redistributions of source code must retain the above copyright
  11 ;;;     notice, this list of conditions and the following disclaimer.
  12 ;;;
  13 ;;;   * Redistributions in binary form must reproduce the above
  14 ;;;     copyright notice, this list of conditions and the following
  15 ;;;     disclaimer in the documentation and/or other materials
  16 ;;;     provided with the distribution.
  17 ;;;
  18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  21 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  29 ;;;
  30
  31 (in-package :clem)
  32
  33 (define-condition matrix-condition () ())
  34
  35 (define-condition matrix-error (simple-error matrix-condition) ())
  36
  37 (define-condition matrix-argument-error (matrix-error)
  38   ()
  39   (:report (lambda (condition stream)
  40              (format stream "~?"
  41                      (simple-condition-format-control condition)
  42                      (simple-condition-format-arguments condition)))))
  43
  44 (deftype index-type ()
  45   '(integer 0 #.(1- array-dimension-limit)))
  46
  47 (defclass matrix ()
  48   ((m :accessor matrix-vals)
  49    (dimensions :initarg :dimensions :initform '(1) :type (or list null))
  50    (initial-element :accessor initial-element :initarg :initial-element :initform 0d0)
  51    (adjustable :accessor adjustable :initarg :adjustable :initform nil)
  52    (resizeable :accessor resizable :initform nil))
  53   (:metaclass standard-matrix-class)
  54   (:element-type double-float)
  55   (:val-format "~4,9F")
  56   (:minval nil)
  57   (:maxval nil))
  58
  59 (defmethod make-load-form ((matrix matrix) &optional env)
  60   "Creates and returns a creation form and an initialization form
  61 that can be used to externalize matrices."
  62   (make-load-form-saving-slots matrix :environment env))
  63
  64 (defgeneric allocate-matrix-vals (object &key adjustable initial-element &allow-other-keys))
  65
  66 (defmethod allocate-matrix-vals ((object matrix)
  67                                  &key
  68                                  (dimensions '(1))
  69                                  adjustable
  70                                  (initial-element 0))
  71   (setf (slot-value object 'm)
  72         (make-array dimensions
  73                     :adjustable adjustable
  74                     :initial-element (coerce initial-element (element-type (class-of object)))
  75                     :element-type (element-type (class-of object)))))
  76
  77 (defmethod shared-initialize :before
  78     ((object matrix) slot-names &rest initargs &key dimensions rows cols adjustable initial-element)
  79   (declare (ignore slot-names initargs dimensions adjustable initial-element)
  80            (optimize (debug 3)))
  81   (when (and rows cols)
  82     (setf (slot-value object 'dimensions)
  83           (list rows cols))))
  84
  85 (defmethod shared-initialize :after
  86     ((object matrix) slot-names &rest initargs &key dimensions rows cols adjustable initial-element)
  87   (declare (ignore slot-names initargs dimensions adjustable initial-element)
  88            (optimize (debug 3)))
  89   (apply #'allocate-matrix-vals object
  90          (append
  91           (list :dimensions (slot-value object 'dimensions))
  92           (list :adjustable (slot-value object 'adjustable))
  93           (when (slot-value object 'initial-element)
  94             (list :initial-element (slot-value object 'initial-element))))))
  95