ladata.lsp

   1 ;;; -*- mode: lisp -*-
   2 ;;; Copyright (c) 2005--2007, by A.J. Rossini <blindglobe@gmail.com>
   3 ;;; See COPYRIGHT file for any additional restrictions (BSD license).
   4 ;;; Since 1991, ANSI was finally finished.  Edited for ANSI Common Lisp.
   5
   6 ;;;; ladata -- Data handling functions for linear algebra interface
   7 ;;;;
   8 ;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
   9 ;;;; unrestricted use.
  10
  11 ;;;;
  12 ;;;; Package Setup
  13 ;;;;
  14
  15 (in-package #:lisp-stat-basics)
  16
  17 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18 ;;;;
  19 ;;;;                        Data Mode Functions
  20 ;;;;
  21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22
  23 ;;;;
  24 ;;;; These constants need to be redefined if IN, RE or CX in linalg.h
  25 ;;;; are changed.
  26 ;;;;
  27
  28 ;;; FIXME:AJR: This is how Luke got around having appropriate
  29 ;;; approaches for Linear Algebra.  We want to cheat and instead use
  30 ;;; CLEM or MATLISP as the underlying linear algebra package.
  31
  32 (defparameter +mode-in+ 0)
  33 (defparameter +mode-re+ 1)
  34 (defparameter +mode-cx+ 2)
  35
  36 (defun mode-of (x)
  37   (etypecase x
  38              (fixnum +mode-in+)
  39              (rational +mode-re+)
  40              (float +mode-re+)
  41              (complex +mode-cx+)))
  42
  43 (defun la-data-mode (data)
  44   (let ((data (compound-data-seq data))
  45         (mode 0))
  46     (cond
  47      ((vectorp data)
  48       (let ((n (length data)))
  49         (declare (fixnum n))
  50         (dotimes (i n mode)
  51                  (declare (fixnum i))
  52                  (setf mode (max mode (mode-of (aref data i)))))))
  53      ((consp data) (dolist (x data mode) (setf mode (max mode (mode-of x)))))
  54      (t (error "bad sequence - ~s" data)))))
  55
  56
  57 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  58 ;;;;
  59 ;;;;                        Internal Allocation Funcitons
  60 ;;;;
  61 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  62
  63 (defvar *la-allocations* nil)
  64
  65 (defun la-allocate (n m)
  66   (let ((p (la-base-allocate n m)))
  67     (if (null-ptr-p p) (error "allocation failed"))
  68     (if (member p *la-allocations* :test #'ptr-eq)
  69       (error "pointer is already on the list"))
  70     (push p *la-allocations*)
  71     p))
  72
  73 (defun la-free (p)
  74   (when (and (not (null-ptr-p p)) (member p *la-allocations* :test #'ptr-eq))
  75         (setf *la-allocations* (delete p *la-allocations* :test #'ptr-eq))
  76         (la-base-free p)))
  77
  78 (defun la-cleanup-allocations ()
  79   (let ((allocs (copy-list *la-allocations*)))
  80     (dolist (p allocs) (la-free p))))
  81
  82 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  83 ;;;;
  84 ;;;;                       C Vector and Array Allocation
  85 ;;;;
  86 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  87
  88 (defun la-vector(n mode) (la-allocate n (la-mode-size mode)))
  89 (defun la-free-vector (v) (la-free v))
  90
  91 (defun la-matrix (n m mode)
  92   (let ((matrix (la-allocate n (la-mode-size +mode-in+))))
  93     (dotimes (i n)
  94       (la-put-pointer matrix i (la-allocate m (la-mode-size mode))))
  95     matrix))
  96
  97 (defun la-free-matrix (matrix n)
  98   (dotimes (i n)
  99     (la-free (la-get-pointer matrix i)))
 100   (la-free matrix))
 101
 102
 103 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 104 ;;;;
 105 ;;;;                   C to/from Lisp Data Conversion
 106 ;;;;
 107 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 108
 109 (defun la-data-to-vector (data mode)
 110   (check-sequence data)
 111   (let* ((n (length data))
 112          (vec (la-vector n mode))
 113          (d (make-next-element data)))
 114     (declare (fixnum n))
 115     (cond
 116      ((= mode +mode-in+)
 117       (dotimes (i n)
 118         (declare (fixnum i))
 119         (la-put-integer vec i (get-next-element d i))))
 120      ((= mode +mode-re+)
 121       (dotimes (i n)
 122         (declare (fixnum i))
 123         (la-put-double vec i (get-next-element d i))))
 124       ((= mode +mode-cx+)
 125        (dotimes (i n)
 126          (declare (fixnum i))
 127          (let ((x (get-next-element d i)))
 128            (la-put-complex vec i (realpart x) (imagpart x))))))
 129     vec))
 130
 131 (defun la-data-to-matrix (data mode)
 132   (check-matrix data)
 133   (let* ((n (num-rows data))
 134          (m (num-cols data))
 135          (mat (la-matrix n m mode)))
 136     (declare (fixnum n m))
 137     (cond
 138      ((= mode +mode-in+)
 139       (dotimes (i n)
 140         (declare (fixnum i))
 141         (let ((vec (la-get-pointer mat i)))
 142           (dotimes (j m)
 143             (la-put-integer vec j (aref data i j))))))
 144       ((= mode +mode-re+)
 145        (dotimes (i n)
 146          (declare (fixnum i))
 147          (let ((vec (la-get-pointer mat i)))
 148            (dotimes (j m)
 149              (la-put-double vec j (aref data i j))))))
 150       ((= mode +mode-cx+)
 151        (dotimes (i n)
 152          (declare (fixnum i))
 153          (let ((vec (la-get-pointer mat i)))
 154            (dotimes (j m)
 155              (let ((x (aref data i j)))
 156                (la-put-complex vec i (realpart x) (imagpart x))))))))
 157     mat))
 158
 159 (defun la-vector-to-data (vec n mode data)
 160   (declare (fixnum n))
 161   (check-sequence data)
 162   (let ((d (make-next-element data))
 163         (gf (cond
 164               ((= mode +mode-in+) #'la-get-integer)
 165               ((= mode +mode-re+) #'la-get-double)
 166               ((= mode +mode-cx+) #'la-get-complex))))
 167     (dotimes (i n)
 168       (declare (fixnum i))
 169       (set-next-element d i (funcall gf vec i))))
 170   data)
 171
 172 (defun la-matrix-to-data (mat n m mode result)
 173   (declare (fixnum n m))
 174   (check-matrix result)
 175   (let ((gf (cond
 176               ((= mode +mode-in+) #'la-get-integer)
 177               ((= mode +mode-re+) #'la-get-double)
 178               ((= mode +mode-cx+) #'la-get-complex))))
 179     (dotimes (i n)
 180       (declare (fixnum i))
 181       (let ((vec (la-get-pointer mat i)))
 182         (dotimes (j m)
 183           (declare (fixnum j))
 184           (setf (aref result i j) (funcall gf vec j))))))
 185   result)