merged from ansiClib
[CommonLispStat.git] / ladata.lsp
blobbc1c0060140af25baffe8e9c89fa8c9768fd4ed9
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.
6 ;;;; ladata -- Data handling functions for linear algebra interface
7 ;;;;
8 ;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
9 ;;;; unrestricted use.
11 ;;;;
12 ;;;; Package Setup
13 ;;;;
15 (in-package #:lisp-stat-basics)
17 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
18 ;;;;
19 ;;;; Data Mode Functions
20 ;;;;
21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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)
31 (defun mode-of (x)
32 (etypecase x
33 (fixnum +mode-in+)
34 (rational +mode-re+)
35 (float +mode-re+)
36 (complex +mode-cx+)))
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)))))
52 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
53 ;;;;
54 ;;;; Internal Allocation Funcitons
55 ;;;;
56 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
58 (defvar *la-allocations* nil)
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))
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)))
73 (defun la-cleanup-allocations ()
74 (let ((allocs (copy-list *la-allocations*)))
75 (dolist (p allocs) (la-free p))))
77 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
78 ;;;;
79 ;;;; C Vector and Array Allocation
80 ;;;;
81 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
83 (defun la-vector(n mode) (la-allocate n (la-mode-size mode)))
84 (defun la-free-vector (v) (la-free v))
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))
92 (defun la-free-matrix (matrix n)
93 (dotimes (i n)
94 (la-free (la-get-pointer matrix i)))
95 (la-free matrix))
98 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
99 ;;;;
100 ;;;; C to/from Lisp Data Conversion
101 ;;;;
102 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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))
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))
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)
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)