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 (defparameter +mode-in+ 0)
  28 (defparameter +mode-re+ 1)
  29 (defparameter +mode-cx+ 2)
  30
  31 (defun mode-of (x)
  32   (etypecase x
  33              (fixnum +mode-in+)
  34              (rational +mode-re+)
  35              (float +mode-re+)
  36              (complex +mode-cx+)))
  37
  38 (defun la-data-mode (data)
  39   (let ((data (compound-data-seq data))
  40         (mode 0))
  41     (cond
  42      ((vectorp data)
  43       (let ((n (length data)))
  44         (declare (fixnum n))
  45         (dotimes (i n mode)
  46                  (declare (fixnum i))
  47                  (setf mode (max mode (mode-of (aref data i)))))))
  48      ((consp data) (dolist (x data mode) (setf mode (max mode (mode-of x)))))
  49      (t (error "bad sequence - ~s" data)))))
  50
  51
  52 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  53 ;;;;
  54 ;;;;                        Internal Allocation Funcitons
  55 ;;;;
  56 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  57
  58 (defvar *la-allocations* nil)
  59
  60 (defun la-allocate (n m)
  61   (let ((p (la-base-allocate n m)))
  62     (if (null-ptr-p p) (error "allocation failed"))
  63     (if (member p *la-allocations* :test #'ptr-eq)
  64       (error "pointer is already on the list"))
  65     (push p *la-allocations*)
  66     p))
  67
  68 (defun la-free (p)
  69   (when (and (not (null-ptr-p p)) (member p *la-allocations* :test #'ptr-eq))
  70         (setf *la-allocations* (delete p *la-allocations* :test #'ptr-eq))
  71         (la-base-free p)))
  72
  73 (defun la-cleanup-allocations ()
  74   (let ((allocs (copy-list *la-allocations*)))
  75     (dolist (p allocs) (la-free p))))
  76
  77 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  78 ;;;;
  79 ;;;;                       C Vector and Array Allocation
  80 ;;;;
  81 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  82
  83 (defun la-vector(n mode) (la-allocate n (la-mode-size mode)))
  84 (defun la-free-vector (v) (la-free v))
  85
  86 (defun la-matrix (n m mode)
  87   (let ((matrix (la-allocate n (la-mode-size +mode-in+))))
  88     (dotimes (i n)
  89       (la-put-pointer matrix i (la-allocate m (la-mode-size mode))))
  90     matrix))
  91
  92 (defun la-free-matrix (matrix n)
  93   (dotimes (i n)
  94     (la-free (la-get-pointer matrix i)))
  95   (la-free matrix))
  96
  97
  98 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  99 ;;;;
 100 ;;;;                   C to/from Lisp Data Conversion
 101 ;;;;
 102 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 103
 104 (defun la-data-to-vector (data mode)
 105   (check-sequence data)
 106   (let* ((n (length data))
 107          (vec (la-vector n mode))
 108          (d (make-next-element data)))
 109     (declare (fixnum n))
 110     (cond
 111      ((= mode +mode-in+)
 112       (dotimes (i n)
 113         (declare (fixnum i))
 114         (la-put-integer vec i (get-next-element d i))))
 115      ((= mode +mode-re+)
 116       (dotimes (i n)
 117         (declare (fixnum i))
 118         (la-put-double vec i (get-next-element d i))))
 119       ((= mode +mode-cx+)
 120        (dotimes (i n)
 121          (declare (fixnum i))
 122          (let ((x (get-next-element d i)))
 123            (la-put-complex vec i (realpart x) (imagpart x))))))
 124     vec))
 125
 126 (defun la-data-to-matrix (data mode)
 127   (check-matrix data)
 128   (let* ((n (num-rows data))
 129          (m (num-cols data))
 130          (mat (la-matrix n m mode)))
 131     (declare (fixnum n m))
 132     (cond
 133      ((= mode +mode-in+)
 134       (dotimes (i n)
 135         (declare (fixnum i))
 136         (let ((vec (la-get-pointer mat i)))
 137           (dotimes (j m)
 138             (la-put-integer vec j (aref data i j))))))
 139       ((= mode +mode-re+)
 140        (dotimes (i n)
 141          (declare (fixnum i))
 142          (let ((vec (la-get-pointer mat i)))
 143            (dotimes (j m)
 144              (la-put-double vec j (aref data i j))))))
 145       ((= mode +mode-cx+)
 146        (dotimes (i n)
 147          (declare (fixnum i))
 148          (let ((vec (la-get-pointer mat i)))
 149            (dotimes (j m)
 150              (let ((x (aref data i j)))
 151                (la-put-complex vec i (realpart x) (imagpart x))))))))
 152     mat))
 153
 154 (defun la-vector-to-data (vec n mode data)
 155   (declare (fixnum n))
 156   (check-sequence data)
 157   (let ((d (make-next-element data))
 158         (gf (cond
 159               ((= mode +mode-in+) #'la-get-integer)
 160               ((= mode +mode-re+) #'la-get-double)
 161               ((= mode +mode-cx+) #'la-get-complex))))
 162     (dotimes (i n)
 163       (declare (fixnum i))
 164       (set-next-element d i (funcall gf vec i))))
 165   data)
 166
 167 (defun la-matrix-to-data (mat n m mode result)
 168   (declare (fixnum n m))
 169   (check-matrix result)
 170   (let ((gf (cond
 171               ((= mode +mode-in+) #'la-get-integer)
 172               ((= mode +mode-re+) #'la-get-double)
 173               ((= mode +mode-cx+) #'la-get-complex))))
 174     (dotimes (i n)
 175       (declare (fixnum i))
 176       (let ((vec (la-get-pointer mat i)))
 177         (dotimes (j m)
 178           (declare (fixnum j))
 179           (setf (aref result i j) (funcall gf vec j))))))
 180   result)