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 ;;(in-package :cl-user)
  17
  18 (defpackage :lisp-stat-linalg-data
  19   (:use :common-lisp
  20         :cffi
  21         :lisp-stat-ffi-int
  22         :lisp-stat-types
  23         :lisp-stat-compound-data
  24         :lisp-stat-matrix)
  25   (:export ;; more to add
  26       +mode-in+ +mode-re+ +mode-cx+ mode-of
  27
  28       la-data-mode la-allocate la-free
  29
  30       la-get-double la-put-double
  31       la-put-integer
  32
  33       la-matrix la-free-matrix la-matrix-to-data la-data-to-matrix
  34       la-vector la-free-vector la-vector-to-data la-data-to-vector ))
  35
  36
  37 (in-package :lisp-stat-linalg-data)
  38
  39
  40
  41
  42 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  43 ;;;
  44 ;;;                        Data Mode Functions
  45 ;;;
  46 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  47
  48 ;;;;
  49 ;;;; These constants need to be redefined if IN, RE or CX in linalg.h
  50 ;;;; are changed.
  51 ;;;;
  52
  53 ;;; FIXME:AJR: This is how Luke got around having appropriate
  54 ;;; approaches for Linear Algebra.  We want to cheat and instead use
  55 ;;; CLEM or MATLISP as the underlying linear algebra package.
  56
  57 (defparameter +mode-in+ 0)
  58 (defparameter +mode-re+ 1)
  59 (defparameter +mode-cx+ 2)
  60
  61 (defun mode-of (x)
  62   (etypecase x
  63              (fixnum +mode-in+)
  64              (rational +mode-re+)
  65              (float +mode-re+)
  66              (complex +mode-cx+)))
  67
  68 (defun la-data-mode (data)
  69   (let ((data (compound-data-seq data))
  70         (mode 0))
  71     (cond
  72      ((vectorp data)
  73       (let ((n (length data)))
  74         (declare (fixnum n))
  75         (dotimes (i n mode)
  76                  (declare (fixnum i))
  77                  (setf mode (max mode (mode-of (aref data i)))))))
  78      ((consp data) (dolist (x data mode) (setf mode (max mode (mode-of x)))))
  79      (t (error "bad sequence - ~s" data)))))
  80
  81
  82 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  83 ;;;;
  84 ;;;;                        Internal Allocation Funcitons
  85 ;;;;
  86 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  87
  88 (defvar *la-allocations* nil)
  89
  90 ;;;
  91 ;;; CFFI glue for...     Storage Allocation Functions
  92 ;;;
  93
  94 (defun null-ptr-p (p) (cffi:null-pointer-p p))
  95 (defun ptr-eq (p q) (cffi:pointer-eq p q))
  96
  97 (cffi:defcfun ("la_base_allocate" ccl-la-base-allocate)
  98     :pointer (n :int) (m :int))
  99 (defun la-base-allocate (n m)
 100   (ccl-la-base-allocate n m))
 101
 102 (cffi:defcfun ("la_base_free_alloc" ccl-la-base-free-alloc)
 103     :void (p :pointer))
 104 (defun la-base-free (p)
 105   (ccl-la-base-free-alloc p))
 106
 107 (cffi:defcfun ("la_mode_size" ccl-la-mode-size)
 108     :int (x :int))
 109
 110 (defun la-mode-size (mode)
 111   (ccl-la-mode-size mode))
 112
 113 ;;;
 114 ;;;             Callbacks for Internal Storage
 115 ;;;
 116
 117 (cffi:defcallback lisp-la-allocate :void ((n :long) (m :long))
 118                   (ccl-store-ptr (la-allocate n m)))
 119 (cffi:defcfun ("register_la_allocate" register-la-allocate)
 120     :void (p :pointer))
 121 (register-la-allocate (cffi:callback lisp-la-allocate))
 122 (cffi:defcfun ("la_allocate" la)
 123     :pointer (x :int) (y :int))
 124
 125 (cffi:defcallback lisp-la-free-alloc
 126     :void ((p :pointer))
 127   (la-free p))
 128
 129 (cffi:defcfun ("register_la_free_alloc" register-la-free-alloc)
 130     :void (p :pointer))
 131 (register-la-free-alloc (cffi:callback lisp-la-free-alloc))
 132 (cffi:defcfun ("la_free_alloc" lf)
 133     :void (p :pointer))
 134
 135
 136
 137 ;;; CFFI glue for...         Storage Access Functions
 138
 139
 140 (cffi:defcfun ("la_get_integer" ccl-la-get-integer)
 141     :int (p :pointer) (i :int))
 142 (defun la-get-integer (p i)
 143   (ccl-la-get-integer p i))
 144
 145 (cffi:defcfun ("la_get_double" ccl-la-get-double)
 146     :double (p :pointer) (i :int))
 147 (defun la-get-double (p i)
 148   (ccl-la-get-double p i))
 149
 150 (cffi:defcfun ("la_get_complex_real" ccl-la-get-complex-real)
 151     :double (p :pointer) (i :int))
 152 (defun la-get-complex-real (p i)
 153   (ccl-la-get-complex-real p i))
 154
 155 (cffi:defcfun ("la_get_complex_imag" ccl-la-get-complex-imag)
 156     :double (p :pointer) (i :int))
 157 (defun la-get-complex-imag (p i)
 158   (ccl-la-get-complex-imag p i))
 159
 160 (defun la-get-complex (p i)
 161   (complex (la-get-complex-real p i) (la-get-complex-imag p i)))
 162
 163 (cffi:defcfun ("la_get_pointer" ccl-la-get-pointer)
 164     :pointer (p :pointer) (i :int))
 165 (defun la-get-pointer (p i)
 166   (ccl-la-get-pointer p i))
 167
 168
 169 ;;; CFFI glue for     Storage Mutation Functions
 170
 171 (cffi:defcfun ("la_put_integer" ccl-la-put-integer)
 172     :void (p :pointer) (i :int) (x :int))
 173 (defun la-put-integer (p i x)
 174   (ccl-la-put-integer p i x))
 175
 176 (cffi:defcfun ("la_put_double" ccl-la-put-double)
 177     :void (p :pointer) (i :int) (x :double))
 178 (defun la-put-double (p i x)
 179   (ccl-la-put-double p i (float x 1d0)))
 180
 181 (cffi:defcfun ("la_put_complex" ccl-la-put-complex)
 182     :void (p :pointer) (i :int) (x :double) (y :double))
 183 (defun la-put-complex (p i x y)
 184   (ccl-la-put-complex p i (float x 1d0) (float y 1d0)))
 185
 186 (cffi:defcfun ("la_put_pointer" ccl-la-put-pointer)
 187     :void (p :pointer) (i :int) (q :pointer))
 188 (defun la-put-pointer (p i q)
 189   (ccl-la-put-pointer p i q))
 190
 191
 192 ;; User interface (exported)
 193
 194 (defun la-allocate (n m)
 195   (let ((p (la-base-allocate n m)))
 196     (if (null-ptr-p p) (error "allocation failed"))
 197     (if (member p *la-allocations* :test #'ptr-eq)
 198       (error "pointer is already on the list"))
 199     (push p *la-allocations*)
 200     p))
 201
 202 (defun la-free (p)
 203   (when (and (not (null-ptr-p p)) (member p *la-allocations* :test #'ptr-eq))
 204         (setf *la-allocations* (delete p *la-allocations* :test #'ptr-eq))
 205         (la-base-free p)))
 206
 207 (defun la-cleanup-allocations ()
 208   (let ((allocs (copy-list *la-allocations*)))
 209     (dolist (p allocs) (la-free p))))
 210
 211 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 212 ;;;;
 213 ;;;;                       C Vector and Array Allocation
 214 ;;;;
 215 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 216
 217 (defun la-vector(n mode) (la-allocate n (la-mode-size mode)))
 218 (defun la-free-vector (v) (la-free v))
 219
 220 (defun la-matrix (n m mode)
 221   (let ((matrix (la-allocate n (la-mode-size +mode-in+))))
 222     (dotimes (i n)
 223       (la-put-pointer matrix i (la-allocate m (la-mode-size mode))))
 224     matrix))
 225
 226 (defun la-free-matrix (matrix n)
 227   (dotimes (i n)
 228     (la-free (la-get-pointer matrix i)))
 229   (la-free matrix))
 230
 231
 232 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 233 ;;;;
 234 ;;;;                   C to/from Lisp Data Conversion
 235 ;;;;
 236 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 237
 238 (defun la-data-to-vector (data mode)
 239   (check-sequence data)
 240   (let* ((n (length data))
 241          (vec (la-vector n mode))
 242          (d (make-next-element data)))
 243     (declare (fixnum n))
 244     (cond
 245      ((= mode +mode-in+)
 246       (dotimes (i n)
 247         (declare (fixnum i))
 248         (la-put-integer vec i (get-next-element d i))))
 249      ((= mode +mode-re+)
 250       (dotimes (i n)
 251         (declare (fixnum i))
 252         (la-put-double vec i (get-next-element d i))))
 253       ((= mode +mode-cx+)
 254        (dotimes (i n)
 255          (declare (fixnum i))
 256          (let ((x (get-next-element d i)))
 257            (la-put-complex vec i (realpart x) (imagpart x))))))
 258     vec))
 259
 260 (defun la-data-to-matrix (data mode)
 261   (check-matrix data)
 262   (let* ((n (num-rows data))
 263          (m (num-cols data))
 264          (mat (la-matrix n m mode)))
 265     (declare (fixnum n m))
 266     (cond
 267      ((= mode +mode-in+)
 268       (dotimes (i n)
 269         (declare (fixnum i))
 270         (let ((vec (la-get-pointer mat i)))
 271           (dotimes (j m)
 272             (la-put-integer vec j (aref data i j))))))
 273       ((= mode +mode-re+)
 274        (dotimes (i n)
 275          (declare (fixnum i))
 276          (let ((vec (la-get-pointer mat i)))
 277            (dotimes (j m)
 278              (la-put-double vec j (aref data i j))))))
 279       ((= mode +mode-cx+)
 280        (dotimes (i n)
 281          (declare (fixnum i))
 282          (let ((vec (la-get-pointer mat i)))
 283            (dotimes (j m)
 284              (let ((x (aref data i j)))
 285                (la-put-complex vec i (realpart x) (imagpart x))))))))
 286     mat))
 287
 288 (defun la-vector-to-data (vec n mode data)
 289   (declare (fixnum n))
 290   (check-sequence data)
 291   (let ((d (make-next-element data))
 292         (gf (cond
 293               ((= mode +mode-in+) #'la-get-integer)
 294               ((= mode +mode-re+) #'la-get-double)
 295               ((= mode +mode-cx+) #'la-get-complex))))
 296     (dotimes (i n)
 297       (declare (fixnum i))
 298       (set-next-element d i (funcall gf vec i))))
 299   data)
 300
 301 (defun la-matrix-to-data (mat n m mode result)
 302   (declare (fixnum n m))
 303   (check-matrix result)
 304   (let ((gf (cond
 305               ((= mode +mode-in+) #'la-get-integer)
 306               ((= mode +mode-re+) #'la-get-double)
 307               ((= mode +mode-cx+) #'la-get-complex))))
 308     (dotimes (i n)
 309       (declare (fixnum i))
 310       (let ((vec (la-get-pointer mat i)))
 311         (dotimes (j m)
 312           (declare (fixnum j))
 313           (setf (aref result i j) (funcall gf vec j))))))
 314   result)
 315