From jivestgarden at common-lisp.net Tue May 5 19:36:47 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Tue, 05 May 2009 15:36:47 -0400 Subject: [lisplab-cvs] r14 - src src/core src/fft src/linalg src/matrix src/util system Message-ID: Author: jivestgarden Date: Tue May 5 15:36:47 2009 New Revision: 14 Log: refactored directories Added: src/core/ src/core/level0-basic.lisp (props changed) - copied unchanged from r1, /src/level0-basic.lisp src/core/level0-const.lisp (props changed) - copied unchanged from r1, /src/level0-const.lisp src/core/level0-expression.lisp (props changed) - copied unchanged from r1, /src/level0-expression.lisp src/core/level0-generic.lisp (props changed) - copied unchanged from r1, /src/level0-generic.lisp src/core/level0-infpre.lisp (props changed) - copied unchanged from r1, /src/level0-infpre.lisp src/core/level0-interface.lisp (props changed) - copied unchanged from r1, /src/level0-interface.lisp src/core/level0-permutation.lisp (props changed) - copied unchanged from r1, /src/level0-permutation.lisp src/fft/ src/fft/level3-fft-blas.lisp (props changed) - copied unchanged from r1, /src/level3-fft-blas.lisp src/fft/level3-fft-generic.lisp (props changed) - copied unchanged from r1, /src/level3-fft-generic.lisp src/fft/level3-fft-interface.lisp (props changed) - copied unchanged from r1, /src/level3-fft-interface.lisp src/linalg/ src/linalg/level3-linalg-blas-real.lisp (props changed) - copied unchanged from r1, /src/level3-linalg-blas-real.lisp src/linalg/level3-linalg-generic.lisp (props changed) - copied unchanged from r1, /src/level3-linalg-generic.lisp src/linalg/level3-linalg-interface.lisp (props changed) - copied unchanged from r2, /src/level3-linalg-interface.lisp src/matrix/ src/matrix/level1-array.lisp (props changed) - copied unchanged from r1, /src/level1-array.lisp src/matrix/level1-blas-complex.lisp (props changed) - copied unchanged from r8, /src/level1-blas-complex.lisp src/matrix/level1-blas-real.lisp (props changed) - copied unchanged from r11, /src/level1-blas-real.lisp src/matrix/level1-blas.lisp (props changed) - copied unchanged from r1, /src/level1-blas.lisp src/matrix/level1-funmat.lisp (props changed) - copied unchanged from r1, /src/level1-funmat.lisp src/matrix/level1-generic.lisp (props changed) - copied unchanged from r1, /src/level1-generic.lisp src/matrix/level1-interface.lisp (props changed) - copied unchanged from r1, /src/level1-interface.lisp src/matrix/level1-list.lisp (props changed) - copied unchanged from r1, /src/level1-list.lisp src/matrix/level2-blas-complex.lisp (props changed) - copied unchanged from r1, /src/level2-blas-complex.lisp src/matrix/level2-blas-real.lisp (props changed) - copied unchanged from r1, /src/level2-blas-real.lisp src/matrix/level2-blas.lisp (props changed) - copied unchanged from r1, /src/level2-blas.lisp src/matrix/level2-funmat.lisp (props changed) - copied unchanged from r1, /src/level2-funmat.lisp src/matrix/level2-generic.lisp (props changed) - copied unchanged from r1, /src/level2-generic.lisp src/matrix/level2-interface.lisp (props changed) - copied unchanged from r1, /src/level2-interface.lisp src/util/ src/util/level3-euler.lisp (props changed) - copied unchanged from r1, /src/level3-euler.lisp src/util/level3-rk4.lisp (props changed) - copied unchanged from r1, /src/level3-rk4.lisp Removed: src/level0-basic.lisp src/level0-const.lisp src/level0-expression.lisp src/level0-generic.lisp src/level0-infpre.lisp src/level0-interface.lisp src/level0-permutation.lisp src/level1-array.lisp src/level1-blas-complex.lisp src/level1-blas-real.lisp src/level1-blas.lisp src/level1-funmat.lisp src/level1-generic.lisp src/level1-interface.lisp src/level1-list.lisp src/level2-blas-complex.lisp src/level2-blas-real.lisp src/level2-blas.lisp src/level2-funmat.lisp src/level2-generic.lisp src/level2-interface.lisp src/level3-euler.lisp src/level3-fft-blas.lisp src/level3-fft-generic.lisp src/level3-fft-interface.lisp src/level3-linalg-blas-real.lisp src/level3-linalg-generic.lisp src/level3-linalg-interface.lisp src/level3-rk4.lisp Modified: system/lisplab.asd Modified: system/lisplab.asd ============================================================================== --- system/lisplab.asd (original) +++ system/lisplab.asd Tue May 5 15:36:47 2009 @@ -2,14 +2,15 @@ (defsystem :lisplab :depends-on () :components - ((:file "package") + ( + (:file "package") ;; - ;; All core matrix and none-matrix stuff (level0 level1, level2) + ;; All core none-matrix stuff (level 0) ;; - (:module :lisplab-core + (:module :core :depends-on ("package") - :pathname "../src/" + :pathname "../src/core/" :serial t :components ( @@ -18,8 +19,17 @@ (:file "level0-interface") (:file "level0-generic") (:file "level0-permutation") - (:file "level0-infpre") + (:file "level0-infpre"))) + ;; + ;; All core matrix stuff (level 1 and 2) + ;; + (:module :matrix + :depends-on (:core) + :pathname "../src/matrix/" + :serial t + :components + ( (:file "level1-interface") (:file "level1-generic") (:file "level1-array") @@ -34,71 +44,61 @@ (:file "level2-funmat") (:file "level2-blas") (:file "level2-blas-real") - (:file "level2-blas-complex") - ) - ) + (:file "level2-blas-complex"))) ;; ;; Linear algebra interface(Level 3) ;; - (:module :lisplab-linalg-interface - :depends-on (:lisplab-core) - :pathname "../src/" + (:module :linalg-interface + :depends-on (:matrix) + :pathname "../src/linalg/" :serial t :components ( - (:file "level3-linalg-interface") - ) - ) + (:file "level3-linalg-interface"))) ;; ;; Linear algebra lisp implementation (Level 3) ;; - (:module :lisplab-linalg-native - :depends-on (:lisplab-core :lisplab-linalg-interface) - :pathname "../src/" + (:module :linalg-native + :depends-on (:matrix :linalg-interface) + :pathname "../src/linalg/" :serial t :components ( (:file "level3-linalg-generic") - (:file "level3-linalg-blas-real") - ) - ) + (:file "level3-linalg-blas-real"))) ;; ;; Fast Fourier transform (Level 3) ;; - (:module :lisplab-fft - :depends-on (:lisplab-core) - :pathname "../src/" + (:module :fft + :depends-on (:matrix) + :pathname "../src/fft/" :serial t :components ( (:file "level3-fft-interface") (:file "level3-fft-generic") - (:file "level3-fft-blas") - ) - ) + (:file "level3-fft-blas"))) ;; ;; Euler and Runge-Kutt solvers (Level 3) ;; - (:module :lisplab-diffsolve - :depends-on (:lisplab-core) - :pathname "../src/" + (:module :diffsolve + :depends-on (:matrix) + :pathname "../src/util/" :serial t :components ( (:file "level3-rk4") - (:file "level3-euler") - ) - ) + (:file "level3-euler"))) ;; ;; Blas and Lapack implmentations (Level 3) ;; (:module :matlisp - :depends-on (:lisplab-core :lisplab-linalg-interface) + :depends-on (:matrix :linalg-interface) :pathname "../src/matlisp/" :serial t :components @@ -109,16 +109,15 @@ (:file "lapack") (:file "mul") (:file "inv") - (:file "geev") - ) + (:file "geev")) + :perform (asdf:load-op :after (op c) - (dolist (lib asdf::*lisplab-external-libraries*) - (sb-alien:load-shared-object lib))) - :explain (asdf:load-op :after (op c) - (dolist (lib asdf::*lisplab-external-libraries*) - (format t "Loads alien object <~A>" lib))) + (dolist (lib asdf::*lisplab-external-libraries*) + (sb-alien:load-shared-object lib))) - ) + :explain (asdf:load-op :after (op c) + (dolist (lib asdf::*lisplab-external-libraries*) + (format t "Loads alien object <~A>" lib)))) ;; From jivestgarden at common-lisp.net Wed May 6 18:06:24 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Wed, 06 May 2009 14:06:24 -0400 Subject: [lisplab-cvs] r15 - src/matrix Message-ID: Author: jivestgarden Date: Wed May 6 14:06:23 2009 New Revision: 15 Log: removed dead code Modified: src/matrix/level1-array.lisp Modified: src/matrix/level1-array.lisp ============================================================================== --- src/matrix/level1-array.lisp (original) +++ src/matrix/level1-array.lisp Wed May 6 14:06:23 2009 @@ -87,140 +87,3 @@ (defmethod cols ((a array)) (array-dimension a 1)) - - - -;;;; TRASH - -#+to-remove (defmethod create ((a array) &optional (value 0) dim) - (unless dim (setf dim (dim a))) - (unless (consp dim) (setf dim (list dim 1))) - (let ((tp (element-type a))) - (make-array dim - :element-type tp - :initial-element (coerce value tp)))) - -#+to-remove (defmethod ref ((a array) &rest idx) - "Row major order" - (if (cdr idx) - (aref a (car idx) (cadr idx)) - (row-major-aref a (car idx)))) - -#+to-remove (defmethod (setf ref) (value (a array) &rest idx) - (if (cdr idx) - (setf (aref a (car idx) (cadr idx)) - (convert value (element-type a))) - (setf (row-major-aref a (car idx)) - (convert value (element-type a))))) - - -#+to-remove (defmethod ->1d! ((a array)) - "Destructively makes the array one dimensional" - (if (vector? a) - a - (make-array (size a) :displaced-to a :element-type (element-type a)))) - -#+to-remove (defmethod .fill! ((a array) val) - (let ((b (->1d! a))) - (map b (constantly val) b) - val)) - -#+to-remove (defmethod copy-dim ((a array)) - (make-array (dim a) :element-type (element-type a))) - -#+to-remove (defmethod copy ((a array)) - "Copy array, dimensions and contents. No fill-pointer and such things -TODO speed up, it's important" - (let* ((a1 (->1d! a)) - (b (make-array (dim a) - :element-type (element-type a))) - (b1 (->1d! b))) - (dotimes (i (size a1)) - (setf (aref b1 i) (aref a1 i))) - b)) - -#+to-remove (defmethod mtranspose! ((a array)) - "Destrutive matrix transpose" - (assert (= (dim a 0) (dim a 1))) - (dotimes (i (rows a)) - (dotimes (j (cols a)) - (let ((tmp (aref a i j))) - (setf (aref a j i) (aref a i j) - (aref a j i) tmp)))) - a) - -#+to-remove (defmethod ->1d ((a array)) - "Unrolls the array to a vector" - (let ((b (make-array (size a) :element-type (element-type a)))) - (dotimes (i (size b)) - (setf (aref b i) - (row-major-aref a i))) - b)) - - - - -#+nil (defmethod mtranspose ((a array)) - "Matrix transpose" ; TODO remove - (let ((b (make-array (reverse (dim A)) :element-type (element-type a)))) - (dotimes (i (rows a)) - (dotimes (j (cols a)) - (setf (aref b i j) (aref a j i)))) - b)) - - - -#+nil (defmethod coerce-element-type ((a array) type) - "Makes an new array with the elements -converted to the new type" - (let ((b (make-array (dim a) :element-type type))) - (dotimes (i (size a)) - (setf (row-major-aref b i) - (coerce - (row-major-aref a i) - type))) - b)) - -#+nil (defmethod get-row! (A row) - (make-array (cols A) - :displaced-to A - :displaced-index-offset (* row (cols A)) - :element-type (element-type A))) - -#+nil (defmethod get-row ((A array) row) - (let ((x (1d (zero A) (cols A)))) - (dotimes (i (cols A)) - (setf (aref x i) (aref A row i))) - x)) - -#+nil (defmethod get-col ((A array) col) - (let ((x (1d (zero A) (rows A)))) - (dotimes (i (rows A)) - (setf (aref x i) (aref A i col))) - x)) - -#+nil (defmethod set-row ((A array) row (x array)) - (dotimes (i (cols A)) - (setf (aref A row i) (aref x i))) - A) - -#+nil (defmethod set-col ((A array) col (x array)) - (dotimes (i (rows A)) - (setf (aref A i col) (aref x i))) - A) - - - - -#+nil (defmethod take-type (a) - "Take the approximate type of the object" - (if (rationalp a) - 'rational - (type-of a))) - -#+nil (defmethod take-type ((a array)) - (array-element-type a)) - -#+nil (defmethod size ((a array)) - "The unrolled length of the indexed object" - (reduce '* (dim a))) From jivestgarden at common-lisp.net Wed May 6 19:02:17 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Wed, 06 May 2009 15:02:17 -0400 Subject: [lisplab-cvs] r16 - in src: core specfunc Message-ID: Author: jivestgarden Date: Wed May 6 15:02:17 2009 New Revision: 16 Log: started adding special functions. Not complete Added: src/specfunc/ src/specfunc/level0-specfunc.lisp Modified: src/core/level0-interface.lisp Modified: src/core/level0-interface.lisp ============================================================================== --- src/core/level0-interface.lisp (original) +++ src/core/level0-interface.lisp Wed May 6 15:02:17 2009 @@ -92,3 +92,21 @@ (defgeneric .expt! (a b)) +(defgeneric .Ai (x)) + +(defgeneric .besj (n x)) + +(defgeneric .besy (n x)) + +(defgeneric .besi (n x)) + +(defgeneric .besk (n x)) + +(defgeneric .besh (n x)) + +(defgeneric .erf (x)) + +(defgeneric .erfc (x)) + +(defgeneric .gamma (x)) + Added: src/specfunc/level0-specfunc.lisp ============================================================================== --- (empty file) +++ src/specfunc/level0-specfunc.lisp Wed May 6 15:02:17 2009 @@ -0,0 +1,92 @@ +;;; Lisplab, level0-specunc.lisp +;;; Special functions for numeric arguments. Using Slatec. +;;; + +;;; Copyright (C) 2009 Joern Inge Vestgaarden +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License along +;;; with this program; if not, write to the Free Software Foundation, Inc., +;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +(in-package :lisplab) + +(defun to-df (x) + (coerce x 'double-float)) + +(defun dvec (n) + (make-array n :element-type 'double-float)) + +(defmethod .besj (n (x number)) + ;; Bessel J function, for n >=0, real and complex numbers. + ;; TODO: what about negaive n and complex n? + (typecase x + (complex (let ((rx (to-df (realpart x))) + (cx (to-df (imagpart x))) + (ry (dvec 1)) + (cy (dvec 1))) + (slatec:zbesj rx cx (to-df n) 1 1 ry cy 0 0) + (complex (aref ry 0) (aref cy 0)))) + (t (let ((x (to-df x))) + (case n + (0 (slatec:dbesj0 x)) + (1 (slatec:dbesj1 x)) + (t (let ((y (dvec 1))) + (slatec:dbesj x (to-df n) 1 y 0) + (aref y 0)))))))) + +(defmethod .besy (n (x number)) + ;; Bessel Y function (Neumann function), for n >=0, x>0, real and complex numbers. + ;; TODO: what about negaive n, negative x and complex n? + (typecase x + (complex (let ((rx (to-df (realpart x))) + (cx (to-df (imagpart x))) + (ry (dvec 1)) + (cy (dvec 1)) + (rw (dvec 1)) + (cw (dvec 1))) + (slatec:zbesy rx cx (to-df n) 1 1 ry cy 0 rw cw 0) + (complex (aref ry 0) (aref cy 0)))) + (t (let ((x (to-df x))) + (case n + (0 (slatec:dbesy0 x)) + (1 (slatec:dbesy1 x)) + (t (let ((y (dvec 1))) + (slatec:dbesy x (to-df n) 1 y) + (aref y 0)))))))) + + + + + +#| + + +(defgeneric .besy (n x)) + +(defgeneric .besi (n x)) + +(defgeneric .besk (n x)) + +(defgeneric .besh (n x)) + +(defgeneric .erf (x)) + +(defgeneric .erfc (x)) + +(defgeneric .gamma (x)) + +(defmethod .Ai (x) + (slatec:dai x)) + + +|# \ No newline at end of file From jivestgarden at common-lisp.net Sun May 10 18:59:06 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sun, 10 May 2009 14:59:06 -0400 Subject: [lisplab-cvs] r17 - shared/slatec src/core src/specfunc system Message-ID: Author: jivestgarden Date: Sun May 10 14:59:06 2009 New Revision: 17 Log: added more functions for numbers Added: src/core/level0-functions.lisp Modified: shared/slatec/slatec.lisp src/core/level0-generic.lisp src/core/level0-interface.lisp src/specfunc/level0-specfunc.lisp system/lisplab.asd Modified: shared/slatec/slatec.lisp ============================================================================== --- shared/slatec/slatec.lisp (original) +++ shared/slatec/slatec.lisp Sun May 10 14:59:06 2009 @@ -19,6 +19,9 @@ ;; Bessel function: H #:zbesh + + ;; Gamma function + #:dgamma ;; Airy functions #:dai #:zairy #:djairy #:dbi #:zbiry #:dyairy Added: src/core/level0-functions.lisp ============================================================================== --- (empty file) +++ src/core/level0-functions.lisp Sun May 10 14:59:06 2009 @@ -0,0 +1,93 @@ +;;; Lisplab, level0-functions.lisp + +;;; Copyright (C) 2009 Joern Inge Vestgaarden +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License along +;;; with this program; if not, write to the Free Software Foundation, Inc., +;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +(in-package :lisplab) + +(defmethod .abs ((a number)) + (abs a)) + +(defmethod .realpart ((a number)) + (realpart a)) + +(defmethod .imagpart ((a number)) + (imagpart a)) + +(defmethod .= ((a number) (b number) &optional (accuracy)) + (if accuracy + (< (abs (- a b)) accuracy) + (= a b))) + +(defmethod ./= ((a number) (b number) &optional (accuracy)) + (apply '.= a b accuracy)) + +(defmethod .< ((a number) (b number)) + (< a b)) + +(defmethod .<= ((a number) (b number)) + (<= a b)) + +(defmethod .> ((a number) (b number)) + (> a b)) + +(defmethod .>= ((a number) (b number)) + (>= a b)) + +(defmethod .add ((a number) (b number)) + (+ a b)) + +(defmethod .mul ((a number) (b number)) + (* a b)) + +(defmethod .div ((a number) (b number)) + (/ a b)) + +(defmethod .sub ((a number) (b number)) + (- a b)) + +(defmethod .expt ((a number) (b number)) + (expt a b)) + +(defmethod .sin ((x number)) + (sin x)) + +(defmethod .cos ((x number)) + (cos x)) + +(defmethod .tan ((x number)) + (tan x)) + +(defmethod .log ((x number) &optional (base nil)) + (if base + (log x base) + (log x))) + +(defmethod .exp ((x number)) + (exp x)) + +(defmethod .sinh ((x number)) + (sinh x)) + +(defmethod .cosh ((x number)) + (cosh x)) + +(defmethod .tanh ((x number)) + (tanh x)) + + + + Modified: src/core/level0-generic.lisp ============================================================================== --- src/core/level0-generic.lisp (original) +++ src/core/level0-generic.lisp Sun May 10 14:59:06 2009 @@ -50,51 +50,5 @@ ;; Hm this is dagenrous if someone forgets to overload copy. a) -;; Todo move such things to another file - (defmethod scalar? ((a number)) - t) - -(defmethod .abs ((a number)) - (abs a)) - -(defmethod .realpart ((a number)) - (realpart a)) - -(defmethod .imagpart ((a number)) - (imagpart a)) - -(defmethod .= ((a number) (b number) &optional (accuracy)) - (if accuracy - (< (abs (- a b)) accuracy) - (= a b))) - -(defmethod ./= ((a number) (b number) &optional (accuracy)) - (apply '.= a b accuracy)) - -(defmethod .< ((a number) (b number)) - (< a b)) - -(defmethod .<= ((a number) (b number)) - (<= a b)) - -(defmethod .> ((a number) (b number)) - (> a b)) - -(defmethod .>= ((a number) (b number)) - (>= a b)) - -(defmethod .add ((a number) (b number)) - (+ a b)) - -(defmethod .mul ((a number) (b number)) - (* a b)) - -(defmethod .div ((a number) (b number)) - (/ a b)) - -(defmethod .sub ((a number) (b number)) - (- a b)) - -(defmethod .expt ((a number) (b number)) - (expt a b)) + t) ;; Is this right? Modified: src/core/level0-interface.lisp ============================================================================== --- src/core/level0-interface.lisp (original) +++ src/core/level0-interface.lisp Sun May 10 14:59:06 2009 @@ -28,7 +28,15 @@ .mul mul! .div .div! .sub .sub! - .expt .expt!)) + .expt .expt! + + .sin .cos .tan + .sinh .cosh .tanh + .log .exp + .Ai + .besj .besy .besi .besk .besh1 .besh2 + .erf .erfc + .gamma)) (defgeneric copy (a) (:documentation "Copies the elements and structure, but ignore @@ -92,21 +100,63 @@ (defgeneric .expt! (a b)) -(defgeneric .Ai (x)) -(defgeneric .besj (n x)) +;;; Ordinary functions + +(defgeneric .sin (x) + (:documentation "Sine function : sin(x).")) + +(defgeneric .cos (x) + (:documentation "Cosine function : cos(x).")) + +(defgeneric .tan (x) + (:documentation "Tangent function : tan(x).")) + +(defgeneric .log (x &optional base) + (:documentation "Logarithm function")) + +(defgeneric .exp (x) + (:documentation "Exponential function : exp(x).")) + +(defgeneric .sinh (x) + (:documentation "Hyperbolic sine function : sinh(x).")) + +(defgeneric .cosh (x) + (:documentation "Hyperbolic cosine function : cosh(x).")) + +(defgeneric .tanh (x) + (:documentation "Hyperbolic tangent function : tanh(x).")) + + +;;; Special functions + +(defgeneric .Ai (x) ;; TODO: implement this bastard + ) + +(defgeneric .besj (n x) + (:documentation "Bessel functions of the first kind : J_n(x).")) + +(defgeneric .besy (n x) + (:documentation "The Neumann function. Bessel functions of the second kind : Y_n(x).")) -(defgeneric .besy (n x)) +(defgeneric .besi (n x) + (:documentation "Modified Bessel functions : I_n(x).")) -(defgeneric .besi (n x)) +(defgeneric .besk (n x) + (:documentation "Modified Bessel functions : K_n(x).")) -(defgeneric .besk (n x)) +(defgeneric .besh1 (n x) + (:documentation "Hankel function 1. Bessel functions of the third kind : H^(1)_n(x).")) -(defgeneric .besh (n x)) +(defgeneric .besh2 (n x) + (:documentation "Hankel function 2. Bessel functions of the third kind : H^(2)_n(x).")) -(defgeneric .erf (x)) +(defgeneric .erf (x) + (:documentation "The error function : erf(x)")) -(defgeneric .erfc (x)) +(defgeneric .erfc (x) + (:documentation "The complementary error function : erfc(x)")) -(defgeneric .gamma (x)) +(defgeneric .gamma (x) + (:documentation "The gamma function : gamma(x)")) Modified: src/specfunc/level0-specfunc.lisp ============================================================================== --- src/specfunc/level0-specfunc.lisp (original) +++ src/specfunc/level0-specfunc.lisp Sun May 10 14:59:06 2009 @@ -27,6 +27,7 @@ (make-array n :element-type 'double-float)) (defmethod .besj (n (x number)) + "f2cl slatec based implementation" ;; Bessel J function, for n >=0, real and complex numbers. ;; TODO: what about negaive n and complex n? (typecase x @@ -45,6 +46,7 @@ (aref y 0)))))))) (defmethod .besy (n (x number)) + "f2cl slatec based implementation" ;; Bessel Y function (Neumann function), for n >=0, x>0, real and complex numbers. ;; TODO: what about negaive n, negative x and complex n? (typecase x @@ -63,23 +65,88 @@ (t (let ((y (dvec 1))) (slatec:dbesy x (to-df n) 1 y) (aref y 0)))))))) - - +(defmethod .besi (n (x number)) + "f2cl slatec based implementation" + ;; Bessel I function, for n >=0, x>0, real and complex numbers. + ;; TODO: what about negaive n, negative x and complex n? + (typecase x + (complex (let ((rx (to-df (realpart x))) + (cx (to-df (imagpart x))) + (ry (dvec 1)) + (cy (dvec 1))) + (slatec:zbesi rx cx (to-df n) 1 1 ry cy 0 0) + (complex (aref ry 0) (aref cy 0)))) + (t (let ((x (to-df x))) + (case n + (0 (slatec:dbesi0 x)) + (1 (slatec:dbesi1 x)) + (t (let ((y (dvec 1))) + (slatec:dbesi x (to-df n) 1 1 y 0) + (aref y 0)))))))) +(defmethod .besk (n (x number)) + "f2cl slatec based implementation" + ;; Bessel K function, for n >=0, x>0, real and complex numbers. + ;; TODO: what about negaive n, negative x and complex n? + (typecase x + (complex (let ((rx (to-df (realpart x))) + (cx (to-df (imagpart x))) + (ry (dvec 1)) + (cy (dvec 1))) + (slatec:zbesk rx cx (to-df n) 1 1 ry cy 0 0) + (complex (aref ry 0) (aref cy 0)))) + (t (let ((x (to-df x))) + (case n + (0 (slatec:dbesk0 x)) + (1 (slatec:dbesk1 x)) + (t (let ((y (dvec 1))) + (slatec:dbesk x (to-df n) 1 1 y 0) + (aref y 0)))))))) -#| +(defmethod .besh1 (n (x number)) + "f2cl slatec based implementation" + ;; Bessel H1 function, for n >=0, x>0, real and complex numbers. + ;; TODO: what about negaive n, negative x and complex n? + (let ((rx (to-df (realpart x))) + (cx (to-df (imagpart x))) + (ry (dvec 1)) + (cy (dvec 1))) + (slatec:zbesh rx cx (to-df n) 1 1 1 ry cy 0 0 ) + (complex (aref ry 0) (aref cy 0)))) + +(defmethod .besh2 (n (x number)) + "f2cl slatec based implementation" + ;; Bessel H2 function, for n >=0, x>0, real and complex numbers. + ;; TODO: what about negaive n, negative x and complex n? + (let ((rx (to-df (realpart x))) + (cx (to-df (imagpart x))) + (ry (dvec 1)) + (cy (dvec 1))) + (slatec:zbesh rx cx (to-df n) 1 2 1 ry cy 0 0 ) + (complex (aref ry 0) (aref cy 0)))) + +(defmethod .erf ((x number)) + "f2cl slatec based implementation" + (let ((x (to-df x))) + (slatec:derf x))) + +(defmethod .erfc ((x number)) + "f2cl slatec based implementation" + (let ((x (to-df x))) + (slatec:derfc x))) + +(defmethod .gamma ((x number)) + "f2cl slatec based implementation" + (let ((x (to-df x))) + (slatec:dgamma x))) -(defgeneric .besy (n x)) -(defgeneric .besi (n x)) +#| -(defgeneric .besk (n x)) -(defgeneric .besh (n x)) -(defgeneric .erf (x)) (defgeneric .erfc (x)) Modified: system/lisplab.asd ============================================================================== --- system/lisplab.asd (original) +++ system/lisplab.asd Sun May 10 14:59:06 2009 @@ -18,6 +18,7 @@ (:file "level0-const") (:file "level0-interface") (:file "level0-generic") + (:file "level0-functions") (:file "level0-permutation") (:file "level0-infpre"))) From jivestgarden at common-lisp.net Mon May 11 19:04:12 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Mon, 11 May 2009 15:04:12 -0400 Subject: [lisplab-cvs] r18 - src/matrix system Message-ID: Author: jivestgarden Date: Mon May 11 15:04:11 2009 New Revision: 18 Log: added operator defaults for arrays Added: src/matrix/level2-array-functions.lisp Modified: src/matrix/level2-generic.lisp system/lisplab.asd Added: src/matrix/level2-array-functions.lisp ============================================================================== --- (empty file) +++ src/matrix/level2-array-functions.lisp Mon May 11 15:04:11 2009 @@ -0,0 +1,288 @@ +;;; Lisplab, level2-array-functions.lisp +;;; Level2, algbra functions on arrays +;;; TOOD: Make fast methods also for integers. + + +;;; Copyright (C) 2009 Joern Inge Vestgaarden +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License along +;;; with this program; if not, write to the Free Software Foundation, Inc., +;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +(in-package :lisplab) + +(defmacro define-array-binary-operator (new old) + (let ((a (gensym)) + (b (gensym)) + (c (gensym)) + (i (gensym))) + `(progn + + ;; two array + (defmethod ,new ((,a array) (,b array)) + (if (and (eql (element-type ,a) 'double-float) + (subtypep (type-of ,a) 'simple-array) + (eql (element-type ,b) 'double-float) + (subtypep (type-of ,b) 'simple-array)) + (let ((,c (copy ,a))) + (declare ((simple-array double-float) ,b ,c)) + (dotimes (,i (min (size ,c) (size ,a))) + (setf (row-major-aref ,c ,i) + (,old (row-major-aref ,c ,i) (row-major-aref ,b ,i)))) + ,c) + (let ((,c (create ,a t))) + (dotimes (,i (min (size ,c) (size ,a))) + (setf (vref ,c ,i) + (,new (vref ,c ,i) (vref ,b ,i)))) + ,c))) + + ;; array and number + (defmethod ,new ((,a array) (,b number)) + (if (and (eql (element-type ,a) 'double-float) + (subtypep (type-of ,a) 'simple-array) + (realp ,b)) + (let ((,b (coerce ,b 'double-float)) + (,c (copy ,a))) + (declare ((simple-array double-float) ,c)) + (dotimes (,i (size ,c)) + (setf (row-major-aref ,c ,i) + (,old (row-major-aref ,c ,i) ,b))) + ,c) + (let ((,c (create ,a t))) + (dotimes (,i (size ,c)) + (setf (vref ,c ,i) + (,new (vref ,c ,i) ,b))) + ,c))) + + ;; number and array + (defmethod ,new ((,a number) (,b array)) + (if (and (eql (element-type ,b) 'double-float) + (subtypep (type-of ,b) 'simple-array) + (realp ,a)) + (let ((,b (coerce ,a 'double-float)) + (,c (copy ,b))) + (declare ((simple-array double-float) ,c)) + (dotimes (,i (size ,c)) + (setf (row-major-aref ,c ,i) + (,old ,b (row-major-aref ,c ,i)))) + ,c) + (let ((,c (create ,b t))) + (dotimes (,i (size ,c)) + (setf (vref ,c ,i) + (,new ,b (vref ,c ,i)))) + ,c)))))) + +(define-array-binary-operator .add +) +(define-array-binary-operator .sub -) +(define-array-binary-operator .mul *) +(define-array-binary-operator .div /) +(define-array-binary-operator .expt expt) + + + + + + + + + + +#| + +#+nil (defun combine-types (a b) + (typecase a + (double-float + (typecase b + ((complex double-float) '(complex double-float)) + (complex 'complex) + (t 'double-float))) + ((complex double-float) + (typecase b + ((complex double-float) '(complex double-float)) + (complex 'complex) + (t '(complex double-float)))) + (t t))) + + +(defmethod .add ((a array) (b array)) + (if (and (eql (element-type a) 'double-float) + (subtypep (type-of a) 'simple-array) + (eql (element-type b) 'double-float) + (subtypep (type-of b) 'simple-array)) + (let ((c (copy a))) + (declare ((simple-array double-float) b c)) + (dotimes (i (min (size c) (size a))) + (setf (row-major-aref c i) + (+ (row-major-aref c i) (row-major-aref a i)))) + c) + (let ((c (create a t))) + (dotimes (i (min (size c) (size a))) + (setf (vref c i) + (.+ (vref c i) (vref a i)))) + c))) + +(defmethod .add ((a array) (b number)) + (if (and (eql (element-type a) 'double-float) + (subtypep (type-of a) 'simple-array) + (realp b)) + (let ((b (coerce b 'double-float)) + (c (copy a))) + (declare ((simple-array double-float) c)) + (dotimes (i (size c)) + (setf (row-major-aref c i) + (+ (row-major-aref c i) b))) + c) + (let ((c (create a t))) + (dotimes (i (size c)) + (setf (vref c i) + (.+ (vref c i) b))) + c))) + +(defmethod .add ((a number) (b array)) + (if (and (eql (element-type b) 'double-float) + (subtypep (type-of b) 'simple-array) + (realp a)) + (let ((b (coerce a 'double-float)) + (c (copy b))) + (declare ((simple-array double-float) c)) + (dotimes (i (size c)) + (setf (row-major-aref c i) + (+ b (row-major-aref c i)))) + c) + (let ((c (create a t))) + (dotimes (i (min (size c) (size a))) + (setf (vref c i) + (.+ b (vref c i)))) + c))) + + + + + +(defmethod .add ((a array) (b number)) + (if (and (eql (element-type a) 'double-float) + (subtypep (type-of a) 'simple-array) + (realp + (subtypep (type-of b) 'simple-array)) + (let ((c (copy a))) + (declare ((simple-array double-float) a c)) + (dotimes (i (min (size c) (size a))) + (incf (row-major-aref c i) (row-major-aref a i)))) + (let ((c (copy a))) + (dotimes (i (min (size c) (size a))) + (setf (vref c i) + (.+ (vref c i) (vref a i)))) + c))) + + + + +(defmethod .= (a b &optional (acc LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT )) + (cond ((scalar? b) + (dotimes (i (size a)) + (when (>= (abs (- (vref a i) b)) acc) + (return-from .= nil))) + t) + ((scalar? a) + (dotimes (i (size b)) + (when (>= (abs (- a (vref b i))) acc) + (return-from .= nil))) + t) + ((= (size a) (size b)) + (dotimes (i (size a)) + (when (>= (abs (- (vref a i) (vref b i))) acc) + (return-from .= nil))) + t) + (t nil))) + +(defmacro def-bin-bool-op-default (op) + "Makes a non-specialized binary method with op which applies op on all elements +and returns true if it holds for all elements, nil otherwise." + (let ((a (gensym)) + (b (gensym)) + (i (gensym))) + `(defmethod ,op (,a ,b) + (cond ((scalar? ,b) + (dotimes (,i (size ,a)) + (unless (,op (vref ,a ,i) ,b) + (return-from ,op nil))) + t) + ((scalar? ,a) + (dotimes (,i (size ,b)) + (unless(,op ,a (vref ,b ,i)) + (return-from ,op nil))) + t) + ((= (size ,a) (size ,b)) + (dotimes (,i (size ,a)) + (unless (,op (vref ,a ,i) (vref ,b ,i)) + (return-from ,op nil))) + t) + (t nil))))) + +(def-bin-bool-op-default .<) + +(def-bin-bool-op-default .<=) + +(def-bin-bool-op-default .>) + +(def-bin-bool-op-default .>=) + +(defmacro def-function-default (fun) + (let ((a (gensym)) + (b (gensym)) + (i (gensym))) + `(defmethod ,fun (,a) + (let ((,b (copy ,a))) + (dotimes (,i (size ,b)) + (setf (vref ,b ,i) (,fun (vref ,b ,i)))) + ,b)))) + +(def-function-default .imagpart) + +(def-function-default .realpart) + +(def-function-default .abs) + +(defmacro def-bin-op-default (new) + (let ((i (gensym "i")) + (a (gensym "a")) + (b (gensym "b"))) + `(defmethod ,new (,a ,b) + (cond ((scalar? ,a) + (let ((,b (copy ,b))) + (dotimes (,i (size ,b)) + (setf (vref ,b ,i) (,new ,a (vref ,b ,i)))) + ,b)) + ((scalar? ,b) + (let ((,a (copy ,a))) + (dotimes (,i (size ,a)) + (setf (vref ,a ,i) (,new (vref ,a ,i) ,b))) + ,a)) + (t + (let ((,a (copy ,a))) + (dotimes (,i (size ,a)) + (setf (vref ,a ,i) (,new (vref ,a ,i) (vref ,b ,i)))) + ,a)))))) + +(def-bin-op-default .add) + +(def-bin-op-default .mul) + +(def-bin-op-default .sub) + +(def-bin-op-default .div) + +(def-bin-op-default .expt) + + +|# \ No newline at end of file Modified: src/matrix/level2-generic.lisp ============================================================================== --- src/matrix/level2-generic.lisp (original) +++ src/matrix/level2-generic.lisp Mon May 11 15:04:11 2009 @@ -29,72 +29,6 @@ (setf (mref a i i) (vref v i))) a)) -(defmethod .= (a b &optional (acc LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT )) - (cond ((scalar? b) - (dotimes (i (size a)) - (when (>= (abs (- (vref a i) b)) acc) - (return-from .= nil))) - t) - ((scalar? a) - (dotimes (i (size b)) - (when (>= (abs (- a (vref b i))) acc) - (return-from .= nil))) - t) - ((= (size a) (size b)) - (dotimes (i (size a)) - (when (>= (abs (- (vref a i) (vref b i))) acc) - (return-from .= nil))) - t) - (t nil))) - -(defmacro def-bin-bool-op-default (op) - "Makes a non-specialized binary method with op which applies op on all elements -and returns true if it holds for all elements, nil otherwise." - (let ((a (gensym)) - (b (gensym)) - (i (gensym))) - `(defmethod ,op (,a ,b) - (cond ((scalar? ,b) - (dotimes (,i (size ,a)) - (unless (,op (vref ,a ,i) ,b) - (return-from ,op nil))) - t) - ((scalar? ,a) - (dotimes (,i (size ,b)) - (unless(,op ,a (vref ,b ,i)) - (return-from ,op nil))) - t) - ((= (size ,a) (size ,b)) - (dotimes (,i (size ,a)) - (unless (,op (vref ,a ,i) (vref ,b ,i)) - (return-from ,op nil))) - t) - (t nil))))) - -(def-bin-bool-op-default .<) - -(def-bin-bool-op-default .<=) - -(def-bin-bool-op-default .>) - -(def-bin-bool-op-default .>=) - -(defmacro def-function-default (fun) - (let ((a (gensym)) - (b (gensym)) - (i (gensym))) - `(defmethod ,fun (,a) - (let ((,b (copy ,a))) - (dotimes (,i (size ,b)) - (setf (vref ,b ,i) (,fun (vref ,b ,i)))) - ,b)))) - -(def-function-default .imagpart) - -(def-function-default .realpart) - -(def-function-default .abs) - (defmethod msum (m) "Sums all elements of m." (let ((sum 0)) @@ -140,37 +74,6 @@ (setf (vref a i) val)) val) -(defmacro def-bin-op-default (new) - (let ((i (gensym "i")) - (a (gensym "a")) - (b (gensym "b"))) - `(defmethod ,new (,a ,b) - (cond ((scalar? ,a) - (let ((,b (copy ,b))) - (dotimes (,i (size ,b)) - (setf (vref ,b ,i) (,new ,a (vref ,b ,i)))) - ,b)) - ((scalar? ,b) - (let ((,a (copy ,a))) - (dotimes (,i (size ,a)) - (setf (vref ,a ,i) (,new (vref ,a ,i) ,b))) - ,a)) - (t - (let ((,a (copy ,a))) - (dotimes (,i (size ,a)) - (setf (vref ,a ,i) (,new (vref ,a ,i) (vref ,b ,i)))) - ,a)))))) - -(def-bin-op-default .add) - -(def-bin-op-default .mul) - -(def-bin-op-default .sub) - -(def-bin-op-default .div) - -(def-bin-op-default .expt) - (defmethod mmap (type f a &rest args) (let ((b (new type (dim a) ))) (cond ((not args) Modified: system/lisplab.asd ============================================================================== --- system/lisplab.asd (original) +++ system/lisplab.asd Mon May 11 15:04:11 2009 @@ -41,6 +41,7 @@ (:file "level1-funmat") (:file "level2-interface") + (:file "level2-array-functions") (:file "level2-generic") (:file "level2-funmat") (:file "level2-blas") From jivestgarden at common-lisp.net Tue May 12 19:40:37 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Tue, 12 May 2009 15:40:37 -0400 Subject: [lisplab-cvs] r19 - src/matrix Message-ID: Author: jivestgarden Date: Tue May 12 15:40:36 2009 New Revision: 19 Log: Added array specializations for operators and functions Modified: src/matrix/level1-array.lisp src/matrix/level2-array-functions.lisp Modified: src/matrix/level1-array.lisp ============================================================================== --- src/matrix/level1-array.lisp (original) +++ src/matrix/level1-array.lisp Tue May 12 15:40:36 2009 @@ -27,6 +27,15 @@ "True for an array of rank 2" (= (rank a) 1)) +(defmethod copy ((a array)) + (if (vector? a) + (copy-seq a) + (let ((y (make-array (dim a) :element-type (element-type a)))) + (dotimes (i (size a)) + (setf (row-major-aref y i) + (row-major-aref a i))) + y))) + (defmethod new ((class (eql 'array)) dim &optional (element-type t) (value 0)) (unless (consp dim) (setf dim (list dim 1))) (make-array dim Modified: src/matrix/level2-array-functions.lisp ============================================================================== --- src/matrix/level2-array-functions.lisp (original) +++ src/matrix/level2-array-functions.lisp Tue May 12 15:40:36 2009 @@ -1,5 +1,6 @@ ;;; Lisplab, level2-array-functions.lisp -;;; Level2, algbra functions on arrays +;;; Level2, algbraic functions on arrays +;;; ;;; TOOD: Make fast methods also for integers. @@ -20,30 +21,43 @@ ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. (in-package :lisplab) - + +;;; Array specialization for the main algebraic operators and functions. +;;; It is obviously usefull to have .+, .-, etc. and .sin .cos, etc. +;;; to operate on arrays. But what about predicates: .=, .<, etc. +;;; It might be an idea to do specialized these for arrays, but so far +;;; they are not. + + (defmacro define-array-binary-operator (new old) + ;; Creates methods for binary operators specialized on arrys. + ;; This is not easy to do in an efficient way, which is one + ;; main reason to make specialized matrices (such as blas-real). + ;; However I have put in optimizations for double floats. It + ;; might be usefull to also do so for complex double-float and some + ;; integer types and bytes. (let ((a (gensym)) (b (gensym)) (c (gensym)) (i (gensym))) `(progn - ;; two array + ;; two arrays (defmethod ,new ((,a array) (,b array)) (if (and (eql (element-type ,a) 'double-float) (subtypep (type-of ,a) 'simple-array) (eql (element-type ,b) 'double-float) (subtypep (type-of ,b) 'simple-array)) (let ((,c (copy ,a))) - (declare ((simple-array double-float) ,b ,c)) + (declare (type (simple-array double-float) ,b ,c)) (dotimes (,i (min (size ,c) (size ,a))) (setf (row-major-aref ,c ,i) (,old (row-major-aref ,c ,i) (row-major-aref ,b ,i)))) ,c) - (let ((,c (create ,a t))) + (let ((,c (create ,a 0))) (dotimes (,i (min (size ,c) (size ,a))) (setf (vref ,c ,i) - (,new (vref ,c ,i) (vref ,b ,i)))) + (,new (vref ,a ,i) (vref ,b ,i)))) ,c))) ;; array and number @@ -53,15 +67,15 @@ (realp ,b)) (let ((,b (coerce ,b 'double-float)) (,c (copy ,a))) - (declare ((simple-array double-float) ,c)) + (declare (type (simple-array double-float) ,c)) (dotimes (,i (size ,c)) (setf (row-major-aref ,c ,i) (,old (row-major-aref ,c ,i) ,b))) ,c) - (let ((,c (create ,a t))) + (let ((,c (create ,a 0))) (dotimes (,i (size ,c)) (setf (vref ,c ,i) - (,new (vref ,c ,i) ,b))) + (,new (vref ,a ,i) ,b))) ,c))) ;; number and array @@ -71,15 +85,15 @@ (realp ,a)) (let ((,b (coerce ,a 'double-float)) (,c (copy ,b))) - (declare ((simple-array double-float) ,c)) + (declare (type (simple-array double-float) ,c)) (dotimes (,i (size ,c)) (setf (row-major-aref ,c ,i) (,old ,b (row-major-aref ,c ,i)))) ,c) - (let ((,c (create ,b t))) + (let ((,c (create ,b 0))) (dotimes (,i (size ,c)) (setf (vref ,c ,i) - (,new ,b (vref ,c ,i)))) + (,new ,b (vref ,b ,i)))) ,c)))))) (define-array-binary-operator .add +) @@ -88,16 +102,148 @@ (define-array-binary-operator .div /) (define-array-binary-operator .expt expt) +(defmacro each-array-element-df-to-df (x form) + "Applies a form on each element of an array. The form must +make real output for real arguments" + (let ((i (gensym)) + (y (gensym))) + `(if (and (eql (element-type ,x) 'double-float) + (subtypep (type-of ,x) 'simple-array)) + (let ((,y (copy ,x))) + (declare (type (simple-array double-float) ,y)) + (dotimes (,i (size ,y)) + (let ((,x (row-major-aref ,y ,i))) + (declare (type double-float ,x)) + (setf (row-major-aref ,y ,i) ,form))) + ,y) + (let ((,y (create ,x 0))) + (dotimes (,i (size ,y)) + (let ((,x (vref ,x ,i))) + (setf (vref ,y ,i) ,form))) + ,y)))) + +(defmacro each-array-element-df-to-complex-df (x form) + "Applies a form on each element of an array. The form must +make complex output for real arguments" + (let ((i (gensym)) + (y (gensym))) + `(if (and (eql (element-type ,x) 'double-float) + (subtypep (type-of ,x) 'simple-array)) + (let ((,y (make-array (dim ,x) :element-type '(complex double-float)))) + (declare (type (simple-array (complex double-float)) ,y)) + (dotimes (,i (size ,y)) + (let ((,x (row-major-aref ,x ,i))) + (declare (type double-float ,x)) + (setf (row-major-aref ,y ,i) ,form))) + ,y) + (let ((,y (create ,x 0))) ; TOOD must make sure to allow complex values + (dotimes (,i (size ,y)) + (let ((,x (vref ,x ,i))) + (setf (vref ,y ,i) ,form))) + ,y)))) + +;;; Trignometric functions + +(defmethod .sin ((x array)) + (each-array-element-df-to-df x (.sin x))) + +(defmethod .cos ((x array)) + (each-array-element-df-to-df x (.cos x))) + +(defmethod .tan ((x array)) + (each-array-element-df-to-df x (.tan x))) + +;;; Hyperbolic functions + +(defmethod .sinh ((x array)) + (each-array-element-df-to-df x (.sinh x))) + +(defmethod .cosh ((x array)) + (each-array-element-df-to-df x (.cosh x))) + +(defmethod .tanh ((x array)) + (each-array-element-df-to-df x (.tanh x))) + +(defmethod .log ((x array) &optional base) + (each-array-element-df-to-df x (.log x base))) + +(defmethod .exp ((x array)) + (each-array-element-df-to-df x (.exp x))) + +;;; Bessel functions + +(defmethod .besj (n (x array)) + (each-array-element-df-to-df x (.besj n x))) + +(defmethod .besy (n (x array)) + (each-array-element-df-to-df x (.besy n x))) + +(defmethod .besi (n (x array)) + (each-array-element-df-to-df x (.besi n x))) + +(defmethod .besk (n (x array)) + (each-array-element-df-to-df x (.besk n x))) +;;; Hankel functions. NB! These are complex with real arguments. +(defmethod .besh1 (n (x array)) + (each-array-element-df-to-complex-df x (.besh1 n x))) +(defmethod .besh2 (n (x array)) + (each-array-element-df-to-complex-df x (.besh2 n x))) +#| -#| + +(defmacro define-array-binary-bool-operator (new old) + (let ((a (gensym)) + (b (gensym)) + (i (gensym))) + `(progn + + ;; two arrays + (defmethod ,new ((,a array) (,b array)) + (if (and (eql (element-type ,a) 'double-float) + (subtypep (type-of ,a) 'simple-array) + (eql (element-type ,b) 'double-float) + (subtypep (type-of ,b) 'simple-array)) + (let () + (declare (type (simple-array double-float) ,a ,b)) + (dotimes (,i (min (size ,a) (size ,b)) t) + (unless (,old (row-major-aref ,a ,i) + (row-major-aref ,b ,i)) + (return-from ,new nil)))) + (dotimes (,i (min (size ,a) (size ,b)) t) + (unless (,new (vref ,a ,i) + (vref ,b ,i)) + (return-from ,new nil))))) + + ;; array and number + (defmethod ,new ((,a array) (,b number)) + (if (and (eql (element-type ,a) 'double-float) + (subtypep (type-of ,a) 'simple-array) + (eql (element-type ,b) 'double-float) + (subtypep (type-of ,b) 'simple-array)) + (let () + (declare (type (simple-array double-float) ,a ,b)) + (dotimes (,i (min (size ,a) (size ,b)) t) + (unless (,old (row-major-aref ,a ,i) + (row-major-aref ,b ,i)) + (return-from ,new nil)))) + (dotimes (,i (min (size ,a) (size ,b)) t) + (unless (,new (vref ,a ,i) + (vref ,b ,i)) + (return-from ,new nil))))) + + ;; number and array + (defmethod ,new ((,a number) (,b array)))))) + +(define-array-binary-bool-operator .< <) + #+nil (defun combine-types (a b) (typecase a From jivestgarden at common-lisp.net Sat May 16 08:54:55 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sat, 16 May 2009 04:54:55 -0400 Subject: [lisplab-cvs] r20 - src/matrix system Message-ID: Author: jivestgarden Date: Sat May 16 04:54:55 2009 New Revision: 20 Log: started a new object model for matrices Added: src/matrix/level1-classes.lisp src/matrix/level1-matrix.lisp src/matrix/level1-util.lisp Modified: Makefile src/matrix/level1-blas-complex.lisp src/matrix/level1-blas-real.lisp src/matrix/level1-blas.lisp system/lisplab.asd Modified: Makefile ============================================================================== --- Makefile (original) +++ Makefile Sat May 16 04:54:55 2009 @@ -1,6 +1,6 @@ first: - echo "Plase specify target." + echo "Please specify target." touch: touch system/lisplab.asd Modified: src/matrix/level1-blas-complex.lisp ============================================================================== --- src/matrix/level1-blas-complex.lisp (original) +++ src/matrix/level1-blas-complex.lisp Sat May 16 04:54:55 2009 @@ -24,46 +24,6 @@ (defclass blas-complex (blas) ()) -(declaim (ftype (function - (type-blas-store - type-blas-idx - type-blas-idx - type-blas-idx) - (complex double-float)) - ref-blas-complex-store)) - -(declaim (ftype (function - ((complex double-float) - type-blas-store - type-blas-idx - type-blas-idx - type-blas-idx - ) - (complex double-float)) - (setf ref-blas-complex-store))) - -(declaim (inline ref-blas-complex-store (setf ref-blas-complex-store))) - -(defun ref-blas-complex-store (store row col rows) - "Accessor for the complet blas store" - (let ((idx (truly-the type-blas-idx - (* 2 (column-major-idx (truly-the type-blas-idx row) - (truly-the type-blas-idx col) - rows))))) - (declare (type-blas-idx idx)) - (complex (aref store idx) - (aref store (1+ idx))))) - -(defun (setf ref-blas-complex-store) (value store row col rows) - (let ((idx (truly-the type-blas-idx - (* 2 (column-major-idx (truly-the type-blas-idx row) - (truly-the type-blas-idx col) - rows))))) - (declare (type-blas-idx idx)) - (setf (aref store idx) (realpart value) - (aref store (1+ idx)) (imagpart value)) - value)) - (defmethod new ((class (eql 'blas-complex)) dim &optional type value) (declare (ignore type)) (unless (consp dim) (setf dim (list dim 1))) Modified: src/matrix/level1-blas-real.lisp ============================================================================== --- src/matrix/level1-blas-real.lisp (original) +++ src/matrix/level1-blas-real.lisp Sat May 16 04:54:55 2009 @@ -24,47 +24,6 @@ (defclass blas-real (blas) ()) -(declaim (ftype (function - (type-blas-store - type-blas-idx - type-blas-idx - type-blas-idx) - double-float) - ref-blas-real-store)) - -(declaim (ftype (function - (double-float - type-blas-store - type-blas-idx - type-blas-idx - type-blas-idx - ) - double-float) - (setf ref-blas-real-store))) - -(declaim (inline ref-blas-real-store (setf ref-blas-real-store))) - -(defun ref-blas-real-store (store row col rows) - "Accessor for the real blas store" - (aref (truly-the type-blas-store store) - (truly-the type-blas-idx - (column-major-idx (truly-the type-blas-idx row) - (truly-the type-blas-idx col) - rows)))) - -(defun (setf ref-blas-real-store) (value store row col rows) - (setf (aref (truly-the type-blas-store store) - (truly-the type-blas-idx - (column-major-idx (truly-the type-blas-idx row) - (truly-the type-blas-idx col) - rows))) - value)) - -(defun allocate-real-store (size &optional (initial-element 0.0)) - (make-array size :element-type 'double-float - :initial-element - (coerce initial-element 'double-float))) - (defmethod new ((class (eql 'blas-real)) dim &optional type value) (if (and type (subtypep type 'complex)) (new 'blas-complex dim type value) Modified: src/matrix/level1-blas.lisp ============================================================================== --- src/matrix/level1-blas.lisp (original) +++ src/matrix/level1-blas.lisp Sat May 16 04:54:55 2009 @@ -19,23 +19,6 @@ (in-package :lisplab) -(deftype type-blas-store () - '(simple-array double-float (*))) - -(deftype type-blas-idx () - '(MOD 536870911)) - -(declaim (ftype (function - (type-blas-idx - type-blas-idx - type-blas-idx) - type-blas-idx) - column-major-idx)) - -(declaim (inline column-major-idx)) -(defun column-major-idx (i j rows) - (truly-the type-blas-idx (+ i (truly-the type-blas-idx (* j rows))))) - (defclass blas () ((store :initarg :store @@ -98,3 +81,9 @@ (0 (rows matrix)) (1 (cols matrix))) (list (rows matrix) (cols matrix)))) + + + + + + Added: src/matrix/level1-classes.lisp ============================================================================== --- (empty file) +++ src/matrix/level1-classes.lisp Sat May 16 04:54:55 2009 @@ -0,0 +1,149 @@ +;;; Lisplab, level1-classes.lisp +;;; Level1, matrix classes +;;; + +;;; Copyright (C) 2009 Joern Inge Vestgaarden +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License along +;;; with this program; if not, write to the Free Software Foundation, Inc., +;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +(in-package :lisplab) + +(defclass matrix-base () ()) + +;;; The matrix element tells the element type of the matrix + +(defclass matrix-element-base () + ((element-type + :allocation :class + :initform t + :reader element-type))) + +(defclass matrix-element-complex-double-float (matrix-element-base) + ((element-type + :allocation :class + :initform '(complex double-float) + :reader element-type))) + +(defclass matrix-element-double-float (matrix-element-complex-double-float) + ((element-type + :allocation :class + :initform 'double-float + :reader element-type))) + +;;; A way to solve conflicts if there is one foreign and one local implementation + +(defclass matrix-implementation-base () ()) + +(defclass matrix-implementation-lisp (matrix-implementation-base) ()) + +(defclass matrix-implementation-blas (matrix-implementation-lisp) ()) + +;;; The matrix structure tells the structure of the matrix + +(defclass matrix-structure-base (matrix-base) ()) + +(defclass matrix-structure-general (matrix-structure-base) + ((rows + :initarg :rows + :initform 0 + :reader rows + :type type-blas-idx + :documentation "Number of rows in the matrix") + (cols + :initarg :cols + :initform 0 + :reader cols + :type type-blas-idx + :documentation "Number of columns in the matrix") + (size + :reader size + :type type-blas-idx))) + +(defclass matrix-structure-diagonal (matrix-structure-base) + ((size + :initarg :size + :initform 0 + :accessor size + :type type-blas-idx))) + + +;;; The actual classes ment for instantiation + + +;;; Double float general matrices + +(defclass matrix-base-dge + (matrix-structure-general matrix-element-double-float matrix-implementation-base) + ((matrix-store + :initarg :store + :initform nil + :reader matrix-store + :type type-blas-store))) + +(defmethod initialize-instance :after ((m matrix-base-dge) &key (value 0)) + (with-slots (rows cols size matrix-store) m + (setf size (* rows cols)) + (unless matrix-store + (setf matrix-store (allocate-real-store size value))))) + +(defclass matrix-lisp-dge (matrix-implementation-lisp matrix-base-dge) ()) + +(defclass matrix-dge (matrix-implementation-blas matrix-lisp-dge) ()) + +(defclass matrix-dge (matrix-blas-dge) () + (:documentation "General matrix with double float elements.")) + +;;; Complex double float general matrices + +(defclass matrix-base-zge + (matrix-structure-general matrix-element-complex-double-float matrix-implementation-base) + ((matrix-store + :initarg :store + :initform nil + :accessor matrix-store + :type type-blas-store))) + +(defmethod initialize-instance :after ((m matrix-base-zge) &key (value 0)) + (with-slots (rows cols size matrix-store) m + (setf size (* rows cols)) + (unless matrix-store + ;; Todo: fix initialization! + (setf matrix-store (allocate-real-store (* 2 size) value))))) + +(defclass matrix-lisp-zge (matrix-implementation-lisp matrix-base-zge) ()) + +(defclass matrix-blas-zge (matrix-implementation-blas matrix-lisp-zge) ()) + +(defclass matrix-zge (matrix-blas-zge) () + (:documentation "General matrix with complex double float elements.")) + +;;; Double float diagonal matrices + +(defclass matrix-base-ddi + (matrix-structure-diagonal matrix-element-double-float matrix-implementation-base) + ()) + +;;; Complex double float diagonal matrices + +(defclass matrix-base-zdi + (matrix-structure-diagonal matrix-element-complex-double-float matrix-implementation-base) + ()) + + + + + + + Added: src/matrix/level1-matrix.lisp ============================================================================== --- (empty file) +++ src/matrix/level1-matrix.lisp Sat May 16 04:54:55 2009 @@ -0,0 +1,90 @@ +;;; Lisplab, level1-matrix.lisp +;;; Level1, matrix basic methods +;;; + +;;; Copyright (C) 2009 Joern Inge Vestgaarden +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License along +;;; with this program; if not, write to the Free Software Foundation, Inc., +;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +(in-package :lisplab) + +;;; Generic methods + +(defmethod dim ((matrix matrix-base) &optional direction) + (if direction + (ecase direction + (0 (rows matrix)) + (1 (cols matrix))) + (list (rows matrix) (cols matrix)))) + +(defmethod print-object ((matrix matrix-base) stream) + (print-unreadable-object (matrix stream :type t :identity t) + (let ((rows (min (rows matrix) *lisplab-print-size*)) + (cols (min (cols matrix) *lisplab-print-size*))) + (format stream " ~Ax~A~&" (rows matrix) (cols matrix)) + (dotimes (i rows) + (dotimes (j cols) + (format stream "~S " (mref matrix i j))) + (when (< cols (cols matrix)) + (format stream "...")) + (princ #\Newline stream)) + (when (< rows (rows matrix)) + (format stream "...~%"))))) + +;;; Spcialized for blas-dge + +(defmethod mref ((matrix matrix-base-dge) row col) + (aref (the type-blas-store (matrix-store matrix)) + (truly-the type-blas-idx (column-major-idx (truly-the type-blas-idx row) + (truly-the type-blas-idx col) + (rows matrix))))) + +(defmethod (setf mref) (value (matrix matrix-base-dge) row col) + (setf (aref (the type-blas-store (matrix-store matrix)) + (column-major-idx (truly-the type-blas-idx row) + (truly-the type-blas-idx col) + (rows matrix))) + (truly-the double-float (coerce value 'double-float)))) + +(defmethod vref ((matrix matrix-base-dge) idx) + (aref (the type-blas-store (matrix-store matrix)) idx)) + +(defmethod (setf vref) (value (matrix matrix-base-dge) idx) + (setf (aref (the type-blas-store (matrix-store matrix)) idx) + (the double-float (coerce value 'double-float)))) + +;;; Spcialized for blas-zge + +(defmethod mref ((matrix matrix-base-zge) row col) + (ref-blas-complex-store (matrix-store matrix) + (column-major-idx row col (rows matrix)) + 0 1)) + +(defmethod (setf mref) (value (matrix matrix-base-zge) row col) + (setf (ref-blas-complex-store (matrix-store matrix) + (column-major-idx row col (rows matrix)) + 0 1) + (coerce value '(complex double-float))) + value) + +(defmethod vref ((matrix matrix-base-zge) i) + (ref-blas-complex-store (store matrix) i 0 1)) + +(defmethod (setf vref) (value (matrix matrix-base-zge) i) + (setf (ref-blas-complex-store (matrix-store matrix) i 0 1) + (coerce value '(complex double-float))) + value) + + Added: src/matrix/level1-util.lisp ============================================================================== --- (empty file) +++ src/matrix/level1-util.lisp Sat May 16 04:54:55 2009 @@ -0,0 +1,120 @@ +;;; Lisplab, level1-util.lisp +;;; Level1, utility functions for matrix defenitions +;;; + +;;; Copyright (C) 2009 Joern Inge Vestgaarden +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License along +;;; with this program; if not, write to the Free Software Foundation, Inc., +;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +(in-package :lisplab) + +(deftype type-blas-store () + '(simple-array double-float (*))) + +(deftype type-blas-idx () + '(MOD 536870911)) + +(declaim (ftype (function + (type-blas-idx + type-blas-idx + type-blas-idx) + type-blas-idx) + column-major-idx)) + +(declaim (inline column-major-idx)) +(defun column-major-idx (i j rows) + (truly-the type-blas-idx (+ i (truly-the type-blas-idx (* j rows))))) + +(declaim (ftype (function + (type-blas-store + type-blas-idx + type-blas-idx + type-blas-idx) + double-float) + ref-blas-real-store)) + +(declaim (ftype (function + (double-float + type-blas-store + type-blas-idx + type-blas-idx + type-blas-idx + ) + double-float) + (setf ref-blas-real-store))) + +(declaim (inline ref-blas-real-store (setf ref-blas-real-store))) + +(defun ref-blas-real-store (store row col rows) + "Accessor for the real blas store" + (aref (truly-the type-blas-store store) + (truly-the type-blas-idx + (column-major-idx (truly-the type-blas-idx row) + (truly-the type-blas-idx col) + rows)))) + +(defun (setf ref-blas-real-store) (value store row col rows) + (setf (aref (truly-the type-blas-store store) + (truly-the type-blas-idx + (column-major-idx (truly-the type-blas-idx row) + (truly-the type-blas-idx col) + rows))) + value)) + +(defun allocate-real-store (size &optional (initial-element 0.0)) + (make-array size :element-type 'double-float + :initial-element + (coerce initial-element 'double-float))) + + +(declaim (ftype (function + (type-blas-store + type-blas-idx + type-blas-idx + type-blas-idx) + (complex double-float)) + ref-blas-complex-store)) + +(declaim (ftype (function + ((complex double-float) + type-blas-store + type-blas-idx + type-blas-idx + type-blas-idx + ) + (complex double-float)) + (setf ref-blas-complex-store))) + +(declaim (inline ref-blas-complex-store (setf ref-blas-complex-store))) + +(defun ref-blas-complex-store (store row col rows) + "Accessor for the complet blas store" + (let ((idx (truly-the type-blas-idx + (* 2 (column-major-idx (truly-the type-blas-idx row) + (truly-the type-blas-idx col) + rows))))) + (declare (type-blas-idx idx)) + (complex (aref store idx) + (aref store (1+ idx))))) + +(defun (setf ref-blas-complex-store) (value store row col rows) + (let ((idx (truly-the type-blas-idx + (* 2 (column-major-idx (truly-the type-blas-idx row) + (truly-the type-blas-idx col) + rows))))) + (declare (type-blas-idx idx)) + (setf (aref store idx) (realpart value) + (aref store (1+ idx)) (imagpart value)) + value)) \ No newline at end of file Modified: system/lisplab.asd ============================================================================== --- system/lisplab.asd (original) +++ system/lisplab.asd Sat May 16 04:54:55 2009 @@ -32,6 +32,7 @@ :components ( (:file "level1-interface") + (:file "level1-util") (:file "level1-generic") (:file "level1-array") (:file "level1-list") From jivestgarden at common-lisp.net Sat May 16 08:58:44 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sat, 16 May 2009 04:58:44 -0400 Subject: [lisplab-cvs] r21 - Message-ID: Author: jivestgarden Date: Sat May 16 04:58:44 2009 New Revision: 21 Log: updated todo list Modified: TODO Modified: TODO ============================================================================== --- TODO (original) +++ TODO Sat May 16 04:58:44 2009 @@ -4,13 +4,11 @@ o Find out how to dynamically switch between common-lisp specialized blas-arrays and fortan specialized blas-arrays. Currently this is a mess. -o Make test code. +o Test code. o Error handling. -o Steal special functions from somewhere. What about f2cl on toms? - Or just take it from Maxima? o Added spcialized matrix types, in an ordered way. Extensions: o Symbolic maniputions, similar to Ginac in C++. -o Threaded and paralell execution. +o Threaded and paralell execution. Use CUDA? \ No newline at end of file From jivestgarden at common-lisp.net Sat May 16 08:59:16 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sat, 16 May 2009 04:59:16 -0400 Subject: [lisplab-cvs] r22 - Message-ID: Author: jivestgarden Date: Sat May 16 04:59:15 2009 New Revision: 22 Log: updated todo list Modified: TODO Modified: TODO ============================================================================== --- TODO (original) +++ TODO Sat May 16 04:59:15 2009 @@ -1,6 +1,7 @@ TODO +o Documentation. o Check if there is some non-threadsafe code in the fortran interface, - i.e. array pre-alocation for the workspaces + i.e. array pre-alocation for the workspaces. o Find out how to dynamically switch between common-lisp specialized blas-arrays and fortan specialized blas-arrays. Currently this is a mess. From jivestgarden at common-lisp.net Sat May 16 09:00:34 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sat, 16 May 2009 05:00:34 -0400 Subject: [lisplab-cvs] r23 - Message-ID: Author: jivestgarden Date: Sat May 16 05:00:33 2009 New Revision: 23 Log: updated todo list Modified: TODO Modified: TODO ============================================================================== --- TODO (original) +++ TODO Sat May 16 05:00:33 2009 @@ -8,6 +8,7 @@ o Test code. o Error handling. o Added spcialized matrix types, in an ordered way. +o Package structure. Extensions: o Symbolic maniputions, similar to Ginac in C++. From jivestgarden at common-lisp.net Sat May 16 15:01:13 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sat, 16 May 2009 11:01:13 -0400 Subject: [lisplab-cvs] r24 - in src: core matrix Message-ID: Author: jivestgarden Date: Sat May 16 11:01:12 2009 New Revision: 24 Log: prepreared for new matrix object model Added: src/matrix/level1-constructors.lisp src/matrix/level2-matrix-dge.lisp Modified: src/core/level0-basic.lisp src/matrix/level1-blas-real.lisp src/matrix/level1-classes.lisp src/matrix/level1-generic.lisp src/matrix/level1-interface.lisp src/matrix/level1-matrix.lisp src/matrix/level1-util.lisp Modified: src/core/level0-basic.lisp ============================================================================== --- src/core/level0-basic.lisp (original) +++ src/core/level0-basic.lisp Sat May 16 11:01:12 2009 @@ -21,9 +21,9 @@ (in-package :lisplab) -(export '(*lisplab-print-size* in-dir )) +(export '(in-dir )) -(setf *READ-DEFAULT-FLOAT-FORMAT* 'double-float) +(setf *READ-DEFAULT-FLOAT-FORMAT* 'double-float) ; TODO make part of pacakge import? (defmacro with-gensyms ((&rest names) . body) `(let ,(loop for n in names collect `(,n (gensym))) Modified: src/matrix/level1-blas-real.lisp ============================================================================== --- src/matrix/level1-blas-real.lisp (original) +++ src/matrix/level1-blas-real.lisp Sat May 16 11:01:12 2009 @@ -97,6 +97,3 @@ (defun rnew (value rows &optional (cols 1)) "Creates a new blas-real matrix" (new 'blas-real (list rows cols) t value)) - - - Modified: src/matrix/level1-classes.lisp ============================================================================== --- src/matrix/level1-classes.lisp (original) +++ src/matrix/level1-classes.lisp Sat May 16 11:01:12 2009 @@ -42,7 +42,7 @@ :initform 'double-float :reader element-type))) -;;; A way to solve conflicts if there is one foreign and one local implementation +;;; A way to solve conflicts if there is one foreign and one native implementation (defclass matrix-implementation-base () ()) @@ -119,8 +119,7 @@ (with-slots (rows cols size matrix-store) m (setf size (* rows cols)) (unless matrix-store - ;; Todo: fix initialization! - (setf matrix-store (allocate-real-store (* 2 size) value))))) + (setf matrix-store (allocate-complex-store size value))))) (defclass matrix-lisp-zge (matrix-implementation-lisp matrix-base-zge) ()) @@ -131,12 +130,16 @@ ;;; Double float diagonal matrices +;;; TODO + (defclass matrix-base-ddi (matrix-structure-diagonal matrix-element-double-float matrix-implementation-base) ()) ;;; Complex double float diagonal matrices +;;; TODO + (defclass matrix-base-zdi (matrix-structure-diagonal matrix-element-complex-double-float matrix-implementation-base) ()) Added: src/matrix/level1-constructors.lisp ============================================================================== --- (empty file) +++ src/matrix/level1-constructors.lisp Sat May 16 11:01:12 2009 @@ -0,0 +1,20 @@ +;;; Lisplab, level1-constructors.lisp +;;; + +;;; Copyright (C) 2009 Joern Inge Vestgaarden +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License along +;;; with this program; if not, write to the Free Software Foundation, Inc., +;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +(in-package :lisplab) \ No newline at end of file Modified: src/matrix/level1-generic.lisp ============================================================================== --- src/matrix/level1-generic.lisp (original) +++ src/matrix/level1-generic.lisp Sat May 16 11:01:12 2009 @@ -19,6 +19,10 @@ (in-package :lisplab) +(defmethod new (class dim &optional (element-type t) (value 0)) + ;;; TODO get rid of this default that calls the new constructor + (mnew class dim element-type value)) + (defmethod scalar? (x) (numberp x)) Modified: src/matrix/level1-interface.lisp ============================================================================== --- src/matrix/level1-interface.lisp (original) +++ src/matrix/level1-interface.lisp Sat May 16 11:01:12 2009 @@ -20,8 +20,8 @@ (in-package :lisplab) -(export '( *lisplab-print-size* - vector? matrix? new ref mref vref +(export '(*lisplab-print-size* + vector? matrix? new mnew ref mref vref dim element-type create size rank rows cols )) @@ -34,7 +34,10 @@ (:documentation "A matrix is a object whose elements are accesible with mref.")) (defgeneric new (class dim &optional element-type value) - (:documentation "Creates a new matrix filled with numeric arguments.")) + (:documentation "Deprecated. Use mnew in stead. Creates a new matrix filled with numeric arguments.")) + +(defgeneric mnew (class dim &optional element-type value) + (:documentation "General matrix constructor. Creates a new matrix filled with numeric arguments.")) (defgeneric ref (matrix &rest subscripts) (:documentation "A general accessor.")) Modified: src/matrix/level1-matrix.lisp ============================================================================== --- src/matrix/level1-matrix.lisp (original) +++ src/matrix/level1-matrix.lisp Sat May 16 11:01:12 2009 @@ -45,6 +45,9 @@ ;;; Spcialized for blas-dge +(defmethod mnew ((class (eql 'matrix-dge)) dim &optional (element-type t) (value 0)) + (make-matrix-new-instance class dim element-type value)) + (defmethod mref ((matrix matrix-base-dge) row col) (aref (the type-blas-store (matrix-store matrix)) (truly-the type-blas-idx (column-major-idx (truly-the type-blas-idx row) Modified: src/matrix/level1-util.lisp ============================================================================== --- src/matrix/level1-util.lisp (original) +++ src/matrix/level1-util.lisp Sat May 16 11:01:12 2009 @@ -20,6 +20,17 @@ (in-package :lisplab) +(defun make-matrix-new-instance (class dim &optional (element-type t) (value 0)) + (declare (ignore element-type)) + (unless (consp dim) (setf dim (list dim 1))) + (let ((rows (car dim)) + (cols (if (cdr dim) (cadr dim) 1))) + (make-instance class + :value value + :rows rows + :cols cols))) + + (deftype type-blas-store () '(simple-array double-float (*))) @@ -117,4 +128,14 @@ (declare (type-blas-idx idx)) (setf (aref store idx) (realpart value) (aref store (1+ idx)) (imagpart value)) - value)) \ No newline at end of file + value)) + +(defun allocate-complex-store (size &optional (value 0.0)) + (let* ((2size (* 2 size)) + (rv (coerce (realpart value) 'double-float)) + (iv (coerce (imagpart value) 'double-float)) + (store (allocate-real-store 2size iv))) + (loop for i from 0 below 2size by 2 do + (setf (aref store i) rv)) + store)) + Added: src/matrix/level2-matrix-dge.lisp ============================================================================== --- (empty file) +++ src/matrix/level2-matrix-dge.lisp Sat May 16 11:01:12 2009 @@ -0,0 +1,99 @@ +;;; Lisplab, level2-matrix-dge.lisp +;;; Optimizations for blas real matrices. + +;;; Copyright (C) 2009 Joern Inge Vestgaarden +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License along +;;; with this program; if not, write to the Free Software Foundation, Inc., +;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +(in-package :lisplab) + +(defmethod copy ((matrix matrix-base-dge)) + (make-instance (class-name (class-of matrix)) + :store (copy-seq (matrix-store matrix)) + :rows (rows matrix) + :cols (cols matrix))) + +;; Maybe this should done general base on element type class? +#+todo (defmethod convert ((a blas-real) 'blas-complex) + (let* ((b (cnew 0 (rows a) (cols a))) + (store-a (store a)) + (store-b (store b))) + (declare (type type-blas-store store-a store-b)) + (dotimes (i (the type-blas-idx (size a))) + (declare (type type-blas-idx i)) + (setf (aref store-b (truly-the type-blas-idx (* i 2))) (aref store-a i))) + b)) + +(defmacro def-binary-op-matrix-lisp-dge (new old) + (let ((a (gensym "a")) + (b (gensym "b")) + (len (gensym "len")) + (store (gensym "store")) + (store2 (gensym "store2")) + (i (gensym "i"))) + `(progn + (defmethod ,new ((,a matrix-lisp-dge) ,b) + (let* ((,a (copy ,a)) + (,store (matrix-store ,a)) + (,b (coerce ,b 'double-float)) + (,len (size ,a))) + (declare (type double-float ,b) + (type type-blas-store ,store) + (type type-blas-idx ,len)) + (dotimes (,i ,len) + (setf (aref ,store ,i) (,old (aref ,store ,i) ,b))) + ,a)) + (defmethod ,new (,a (,b matrix-lisp-dge)) + (let* ((,b (copy ,b)) + (,store (matrix-store ,b)) + (,a (coerce ,a 'double-float)) + (,len (size ,b))) + (declare (type double-float ,a) + (type type-blas-store ,store) + (type type-blas-idx ,len)) + (dotimes (,i ,len) + (setf (aref ,store ,i) (,old ,a (aref ,store ,i)))) + ,b)) + (defmethod ,new ((,a matrix-lisp-dge) (,b matrix-lisp-dge)) + (let* ((,a (copy ,a)) + (,store (matrix-store ,a)) + (,store2 (matrix-store ,b)) + (,len (size ,a))) + (declare (type type-blas-store ,store) + (type type-blas-store ,store2) + (type type-blas-idx ,len)) + (dotimes (,i ,len) + (setf (aref ,store ,i) (,old (aref ,store ,i) (aref ,store2 ,i)))) + ,a))))) + +(def-binary-op-matrix-lisp-dge .add +) + +(def-binary-op-matrix-lisp-dge .mul *) + +(def-binary-op-matrix-lisp-dge .sub -) + +(def-binary-op-matrix-lisp-dge .div /) + +(def-binary-op-matrix-lisp-dge .expt expt) + +(defmethod .map (f (a matrix-lisp-dge) &rest args) + (let ((b (copy a))) + (apply #'map-into + (matrix-store b) + (lambda (&rest args) + (coerce (apply f args) 'double-float)) + (matrix-store a) (mapcar #'store args)) + b)) + From jivestgarden at common-lisp.net Sat May 16 17:55:29 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sat, 16 May 2009 13:55:29 -0400 Subject: [lisplab-cvs] r25 - src/matrix system Message-ID: Author: jivestgarden Date: Sat May 16 13:55:28 2009 New Revision: 25 Log: Heavy refactoring. not finished Added: src/matrix/level2-matrix-zge.lisp Modified: src/matrix/level1-constructors.lisp src/matrix/level1-generic.lisp src/matrix/level1-interface.lisp src/matrix/level1-matrix.lisp src/matrix/level1-util.lisp src/matrix/level2-blas-complex.lisp src/matrix/level2-matrix-dge.lisp system/lisplab.asd Modified: src/matrix/level1-constructors.lisp ============================================================================== --- src/matrix/level1-constructors.lisp (original) +++ src/matrix/level1-constructors.lisp Sat May 16 13:55:28 2009 @@ -17,4 +17,70 @@ ;;; with this program; if not, write to the Free Software Foundation, Inc., ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -(in-package :lisplab) \ No newline at end of file +(in-package :lisplab) + +(export '(mat new col row)) + +(export '(rmat rnew rcol rrow)) + +(export '(cmat cnew ccol crow)) + + +(defmacro mat (type &body args) + "Creates a matrics" + `(convert + ,(cons 'list (mapcar (lambda (x) + (cons 'list x)) + args)) + ,type)) + +(defun col (type &rest args) + "Creates a column matrix" + (convert (mapcar 'list args) type)) + +(defun row (type &rest args) + "Creates a row matrix" + (convert args type)) + + +(defmacro rmat (&body args) + "Creates a blas-real matrics" + `(convert + ,(cons 'list (mapcar (lambda (x) + (cons 'list x)) + args)) + + 'matrix-dge)) + +(defun rcol (&rest args) + "Creates a blas-real column matrix" + (convert (mapcar 'list args) 'matrix-dge)) + +(defun rrow (&rest args) + "Creates a blas-real row matrix" + (convert args 'matrix-dge)) + +(defun rnew (value rows &optional (cols 1)) + "Creates a new blas-real matrix" + (new 'matrix-dge (list rows cols) t value)) + +(defmacro cmat (&body args) + "Creates a blas-complex matrics" + `(convert + ,(cons 'list (mapcar (lambda (x) + (cons 'list x)) + args)) + + 'matrix-zge)) + +(defun ccol (&rest args) + "Creates a blas-complex column matrix" + (convert (mapcar 'list args) 'matrix-zge)) + +(defun crow (&rest args) + "Creates a blas-complex row matrix" + (convert args 'matrix-zge)) + +(defun cnew (value rows &optional (cols 1)) + "Create a new blas-complex matrix" + (new 'matrix-zge (list rows cols) t value)) \ No newline at end of file Modified: src/matrix/level1-generic.lisp ============================================================================== --- src/matrix/level1-generic.lisp (original) +++ src/matrix/level1-generic.lisp Sat May 16 13:55:28 2009 @@ -17,30 +17,18 @@ ;;; with this program; if not, write to the Free Software Foundation, Inc., ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -(in-package :lisplab) - -(defmethod new (class dim &optional (element-type t) (value 0)) - ;;; TODO get rid of this default that calls the new constructor - (mnew class dim element-type value)) - -(defmethod scalar? (x) - (numberp x)) - -(defmethod vector? (x) - nil) -(defmethod matrix? (x) - nil) -(defmethod size (matrix) (reduce '* (dim matrix))) +;;; TODO Get rid of this file and have no non-specialized matrix level1 methods -(defmethod rank (matrix) (length (dim matrix))) -(defmethod cols (matrix) (dim matrix 0)) +(in-package :lisplab) -(defmethod rows (matrix) (dim matrix 1)) +#-todo-remove(defmethod new (class dim &optional (element-type t) (value 0)) + ;;; TODO get rid of this default that calls the new constructor + (mnew class dim element-type value)) -(defmethod convert (obj type) +#+todo-remove(defmethod convert (obj type) (if (not (or (vector? obj) (matrix? obj))) (coerce obj type) (let ((new (new type (dim obj) (element-type obj)))) @@ -52,7 +40,7 @@ (setf (mref new i j) (mref obj i j)))))) new))) -(defmethod copy (a) +#+todo-remove(defmethod copy (a) (typecase a (list (copy-list a)) (sequence (copy-seq a)) @@ -61,6 +49,15 @@ (setf (vref b i) (vref a i))) b)))) +#-todo-remove(defmethod create (a &optional value dim) + (unless dim (setf dim (dim a))) + (unless (consp dim) (setf dim (list dim 1))) + (if value + (new (class-name (class-of a)) dim (element-type a) value) + (new (class-name (class-of a)) dim))) + + +;;; This is OK, but could be optimzied! (defmacro w/mat (a args &body body) (let ((a2 (gensym)) (x (first args)) @@ -73,27 +70,3 @@ (setf (mref ,a2 ,i ,j) , at body)))) ,a2))) - -(defmacro mat (type &body args) - "Creates a matrics" - `(convert - ,(cons 'list (mapcar (lambda (x) - (cons 'list x)) - args)) - ,type)) - -(defun col (type &rest args) - "Creates a column matrix" - (convert (mapcar 'list args) type)) - -(defun row (type &rest args) - "Creates a row matrix" - (convert args type)) - -(defmethod create (a &optional value dim) - (unless dim (setf dim (dim a))) - (unless (consp dim) (setf dim (list dim 1))) - (if value - (new (class-name (class-of a)) dim (element-type a) value) - (new (class-name (class-of a)) dim))) - Modified: src/matrix/level1-interface.lisp ============================================================================== --- src/matrix/level1-interface.lisp (original) +++ src/matrix/level1-interface.lisp Sat May 16 13:55:28 2009 @@ -21,7 +21,10 @@ (in-package :lisplab) (export '(*lisplab-print-size* - vector? matrix? new mnew ref mref vref + vector? matrix? + new mnew + create mcreate + ref mref vref dim element-type create size rank rows cols )) @@ -66,9 +69,17 @@ (defgeneric (setf element-type) (value matrix)) (defgeneric create (a &optional value dim) + (:documentation "Deprecated. Use mcreate in stead. Creates a new matrix of the same type and with the same value as the other, +but with all elements set to value.")) + +(defgeneric mcreate (a &optional value dim) (:documentation "Creates a new matrix of the same type and with the same value as the other, but with all elements set to value.")) +(defgeneric mmcreate (a b &optional value dim) + (:documentation "Creates a new matrix. The new matrix has a type derived from a and b, +and all elements set to value.")) + (defgeneric size (matrix) (:documentation "Gives the number of elements in the object.")) Modified: src/matrix/level1-matrix.lisp ============================================================================== --- src/matrix/level1-matrix.lisp (original) +++ src/matrix/level1-matrix.lisp Sat May 16 13:55:28 2009 @@ -22,6 +22,14 @@ ;;; Generic methods +(defmethod scalar? ((x matrix-base)) nil) + +(defmethod vector? ((x matrix-base)) t) + +(defmethod matrix? ((x matrix-base)) t) + +(defmethod rank ((matrix matrix-base)) 2) + (defmethod dim ((matrix matrix-base) &optional direction) (if direction (ecase direction @@ -43,10 +51,25 @@ (when (< rows (rows matrix)) (format stream "...~%"))))) +(defmethod mcreate ((a matrix-base) &optional (value 0) dim) + (unless dim + (setf dim (dim a))) + (make-matrix-instance (class-of a) dim value)) + +(defmethod mmcreate ((a matrix-base) (b matrix-base) &optional (value 0) dim) + ;; TODO make real implmentaiton of this + (unless dim + (setf dim (dim a))) + (if (or (equal '(complex double-float) (element-type a)) + (equal '(complex double-float) (element-type b))) + (make-matrix-instance 'matrix-zge dim value) + (make-matrix-instance 'matrix-dge dim value))) + ;;; Spcialized for blas-dge (defmethod mnew ((class (eql 'matrix-dge)) dim &optional (element-type t) (value 0)) - (make-matrix-new-instance class dim element-type value)) + (declare (ignore element-type)) + (make-matrix-instance class dim value)) (defmethod mref ((matrix matrix-base-dge) row col) (aref (the type-blas-store (matrix-store matrix)) @@ -70,6 +93,10 @@ ;;; Spcialized for blas-zge +(defmethod mnew ((class (eql 'matrix-zge)) dim &optional (element-type t) (value 0)) + (declare (ignore element-type)) + (make-matrix-instance class dim value)) + (defmethod mref ((matrix matrix-base-zge) row col) (ref-blas-complex-store (matrix-store matrix) (column-major-idx row col (rows matrix)) Modified: src/matrix/level1-util.lisp ============================================================================== --- src/matrix/level1-util.lisp (original) +++ src/matrix/level1-util.lisp Sat May 16 13:55:28 2009 @@ -20,8 +20,7 @@ (in-package :lisplab) -(defun make-matrix-new-instance (class dim &optional (element-type t) (value 0)) - (declare (ignore element-type)) +(defun make-matrix-instance (class dim value) (unless (consp dim) (setf dim (list dim 1))) (let ((rows (car dim)) (cols (if (cdr dim) (cadr dim) 1))) @@ -30,7 +29,6 @@ :rows rows :cols cols))) - (deftype type-blas-store () '(simple-array double-float (*))) Modified: src/matrix/level2-blas-complex.lisp ============================================================================== --- src/matrix/level2-blas-complex.lisp (original) +++ src/matrix/level2-blas-complex.lisp Sat May 16 13:55:28 2009 @@ -23,8 +23,7 @@ (make-instance 'blas-complex :store (copy (store matrix)) :rows (rows matrix) - :cols (cols matrix) - :size (size matrix))) + :cols (cols matrix))) (defmethod convert ((a blas-complex) 'blas-real) (let* ((b (rnew 0 (rows a) (cols a))) Modified: src/matrix/level2-matrix-dge.lisp ============================================================================== --- src/matrix/level2-matrix-dge.lisp (original) +++ src/matrix/level2-matrix-dge.lisp Sat May 16 13:55:28 2009 @@ -1,5 +1,5 @@ ;;; Lisplab, level2-matrix-dge.lisp -;;; Optimizations for blas real matrices. +;;; Optimizations for real matrices. ;;; Copyright (C) 2009 Joern Inge Vestgaarden ;;; @@ -19,7 +19,7 @@ (in-package :lisplab) -(defmethod copy ((matrix matrix-base-dge)) +(defmethod copy ((matrix matrix-base-dge)) (make-instance (class-name (class-of matrix)) :store (copy-seq (matrix-store matrix)) :rows (rows matrix) Added: src/matrix/level2-matrix-zge.lisp ============================================================================== --- (empty file) +++ src/matrix/level2-matrix-zge.lisp Sat May 16 13:55:28 2009 @@ -0,0 +1,109 @@ +;;; Lisplab, level2-matrix-zge.lisp +;;; Optimizations for complex matrices. + + +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License along +;;; with this program; if not, write to the Free Software Foundation, Inc., +;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +(in-package :lisplab) + +(defmethod copy ((matrix matrix-base-zge)) + (make-instance (class-name (class-of matrix)) + :store (copy-seq (matrix-store matrix)) + :rows (rows matrix) + :cols (cols matrix))) + +(defmacro def-binary-op-blas-complex (new old) + ;;; TODO speed up for real numbers + (let ((a (gensym "a")) + (b (gensym "b")) + (len (gensym "len")) + (store (gensym "store")) + (store2 (gensym "store2")) + (i (gensym "i"))) + `(progn + (defmethod ,new ((,a matrix-zge) ,b) + (let* ((,a (copy ,a)) + (,store (matrix-store ,a)) + (,b (coerce ,b '(complex double-float))) + (,len (size ,a))) + (declare (type (complex double-float) ,b) + (type type-blas-store ,store) + (type type-blas-idx ,len)) + (dotimes (,i ,len) + (setf (ref-blas-complex-store ,store ,i 0 ,len) + (,old (ref-blas-complex-store ,store ,i 0 ,len) ,b))) + ,a)) + (defmethod ,new (,a (,b matrix-zge)) + (let* ((,b (copy ,b)) + (,store (matrix-store ,b)) + (,a (coerce ,a '(complex double-float))) + (,len (size ,b))) + (declare (type (complex double-float) ,a) + (type type-blas-store ,store) + (type type-blas-idx ,len)) + (dotimes (,i ,len) + (setf (ref-blas-complex-store ,store ,i 0 ,len) + (,old ,a (ref-blas-complex-store ,store ,i 0 ,len)))) + ,b)) + (defmethod ,new ((,a matrix-zge) (,b matrix-zge)) + (let* ((,a (copy ,a)) + (,store (matrix-store ,a)) + (,store2 (matrix-store ,b)) + (,len (size ,a))) + (declare (type type-blas-store ,store) + (type type-blas-store ,store2) + (type type-blas-idx ,len)) + (dotimes (,i ,len) + (setf (ref-blas-complex-store ,store ,i 0 ,len) + (,old (ref-blas-complex-store ,store ,i 0 ,len) + (ref-blas-complex-store ,store2 ,i 0 ,len)))) + ,a)) + (defmethod ,new ((,a matrix-zge) (,b matrix-dge)) + (let* ((,a (copy ,a)) + (,store (matrix-store ,a)) + (,store2 (matrix-store ,b)) + (,len (size ,a))) + (declare (type type-blas-store ,store) + (type type-blas-store ,store2) + (type type-blas-idx ,len)) + (dotimes (,i ,len) + (setf (ref-blas-complex-store ,store ,i 0 ,len) + (,old (ref-blas-complex-store ,store ,i 0 ,len) + (aref ,store2 ,i)))) + ,a)) + (defmethod ,new ((,a matrix-dge) (,b matrix-zge)) + (let* ((,b (copy ,b)) + (,store (matrix-store ,a)) + (,store2 (matrix-store ,b)) + (,len (size ,a))) + (declare (type type-blas-store ,store) + (type type-blas-store ,store2) + (type type-blas-idx ,len)) + (dotimes (,i ,len) + (setf (ref-blas-complex-store ,store2 ,i 0 ,len) + (,old (aref ,store ,i) + (ref-blas-complex-store ,store2 ,i 0 ,len)))) + ,b))))) + +(def-binary-op-blas-complex .add +) + +(def-binary-op-blas-complex .mul *) + +(def-binary-op-blas-complex .sub -) + +(def-binary-op-blas-complex .div /) + +(def-binary-op-blas-complex .expt expt) + Modified: system/lisplab.asd ============================================================================== --- system/lisplab.asd (original) +++ system/lisplab.asd Sat May 16 13:55:28 2009 @@ -31,23 +31,42 @@ :serial t :components ( - (:file "level1-interface") - (:file "level1-util") - (:file "level1-generic") - (:file "level1-array") - (:file "level1-list") - (:file "level1-blas") - (:file "level1-blas-real") - (:file "level1-blas-complex") - (:file "level1-funmat") - - (:file "level2-interface") - (:file "level2-array-functions") - (:file "level2-generic") - (:file "level2-funmat") - (:file "level2-blas") - (:file "level2-blas-real") - (:file "level2-blas-complex"))) + (:file "level1-interface") + + (:file "level1-array") + + (:file "level1-util") + (:file "level1-classes") + (:file "level1-matrix") + (:file "level1-constructors") + + (:file "level2-interface") + + (:file "level2-matrix-dge") + (:file "level2-matrix-zge") + + (:file "level2-array-functions") + +; (:file "level1-interface") +; (:file "level1-util") +; (:file "level1-generic") +; (:file "level1-array") +; (:file "level1-list") + + +; (:file "level1-blas") +; (:file "level1-blas-real") +; (:file "level1-blas-complex") +; (:file "level1-funmat") + +; (:file "level2-interface") +; (:file "level2-array-functions") +; (:file "level2-generic") +; (:file "level2-funmat") +; (:file "level2-blas") +; (:file "level2-blas-real") +; (:file "level2-blas-complex") + )) ;; ;; Linear algebra interface(Level 3) @@ -63,7 +82,7 @@ ;; ;; Linear algebra lisp implementation (Level 3) ;; - (:module :linalg-native + #+nil (:module :linalg-native :depends-on (:matrix :linalg-interface) :pathname "../src/linalg/" :serial t @@ -75,7 +94,7 @@ ;; ;; Fast Fourier transform (Level 3) ;; - (:module :fft + #+nil (:module :fft :depends-on (:matrix) :pathname "../src/fft/" :serial t @@ -100,7 +119,7 @@ ;; ;; Blas and Lapack implmentations (Level 3) ;; - (:module :matlisp + #+nil (:module :matlisp :depends-on (:matrix :linalg-interface) :pathname "../src/matlisp/" :serial t From jivestgarden at common-lisp.net Sun May 17 19:02:05 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sun, 17 May 2009 15:02:05 -0400 Subject: [lisplab-cvs] r26 - src/fft src/linalg src/matlisp src/matrix system Message-ID: Author: jivestgarden Date: Sun May 17 15:02:03 2009 New Revision: 26 Log: refactoring almost complete. Needs tidying Modified: TODO src/fft/level3-fft-blas.lisp src/linalg/level3-linalg-blas-real.lisp src/linalg/level3-linalg-generic.lisp src/matlisp/geev.lisp src/matlisp/inv.lisp src/matlisp/mul.lisp src/matrix/level1-classes.lisp src/matrix/level1-constructors.lisp src/matrix/level1-generic.lisp src/matrix/level1-interface.lisp src/matrix/level1-matrix.lisp src/matrix/level1-util.lisp src/matrix/level2-generic.lisp src/matrix/level2-matrix-dge.lisp src/matrix/level2-matrix-zge.lisp system/lisplab.asd Modified: TODO ============================================================================== --- TODO (original) +++ TODO Sun May 17 15:02:03 2009 @@ -1,4 +1,5 @@ TODO +o Some way to just extend the exact input matrix type o Documentation. o Check if there is some non-threadsafe code in the fortran interface, i.e. array pre-alocation for the workspaces. Modified: src/fft/level3-fft-blas.lisp ============================================================================== --- src/fft/level3-fft-blas.lisp (original) +++ src/fft/level3-fft-blas.lisp Sun May 17 15:02:03 2009 @@ -19,41 +19,59 @@ ;;; TODO should use the normal ref-blas-complex-store +;;; TODO fix the methods so that they use the actual input matrix type, not just +;;; the eql spezializer. + (in-package :lisplab) -(defmethod fft1 ((x blas-real)) - (fft1! (convert x 'blas-complex))) +;;;; Real matrices + +(defmethod fft1 ((x matrix-lisp-dge)) + (fft1! (convert x 'matrix-zge))) + +(defmethod ifft1 ((x matrix-lisp-dge)) + (ifft1! (convert x 'matrix-zge))) + +(defmethod ifft2 ((x matrix-lisp-dge)) + (ifft2! (convert x 'matrix-zge))) + +(defmethod fft2 ((x matrix-lisp-dge)) + (fft2! (convert x 'matrix-zge))) + +;;; Complex matrices -(defmethod ifft1 ((x blas-real)) - (ifft1! (convert x 'blas-complex))) +(defmethod fft1 ((x matrix-lisp-zge)) + (fft1! (copy x))) -(defmethod ifft2 ((x blas-real)) - (ifft2! (convert x 'blas-complex))) +(defmethod ifft1 ((x matrix-lisp-zge)) + (ifft1! (copy x))) -(defmethod fft2 ((x blas-real)) - (fft2! (convert x 'blas-complex))) +(defmethod ifft2 ((x matrix-lisp-zge)) + (ifft2! (copy x))) +(defmethod fft2 ((x matrix-lisp-zge)) + (fft2! (copy x))) -(defmethod fft1! ((x blas-complex)) +(defmethod fft1! ((x matrix-lisp-zge)) (dotimes (i (cols x)) - (fft-radix-2-blas-complex-store! :f (store x) (rows x) (* (rows x) i) 1)) + (fft-radix-2-blas-complex-store! :f (matrix-store x) (rows x) (* (rows x) i) 1)) x) -(defmethod ifft1! ((x blas-complex)) +(defmethod ifft1! ((x matrix-lisp-zge)) (dotimes (i (cols x)) - (fft-radix-2-blas-complex-store! :r (store x) (rows x) (* (rows x) i) 1)) + (fft-radix-2-blas-complex-store! :r (matrix-store x) (rows x) (* (rows x) i) 1)) x) -(defmethod fft2! ((x blas-complex)) +(defmethod fft2! ((x matrix-lisp-zge)) (fft1! x) (dotimes (i (rows x)) - (fft-radix-2-blas-complex-store! :f (store x) (cols x) i (rows x))) + (fft-radix-2-blas-complex-store! :f (matrix-store x) (cols x) i (rows x))) x) -(defmethod ifft2! ((x blas-complex)) +(defmethod ifft2! ((x matrix-lisp-zge)) (ifft1! x) (dotimes (i (rows x)) - (fft-radix-2-blas-complex-store! :r (store x) (cols x) i (rows x))) + (fft-radix-2-blas-complex-store! :r (matrix-store x) (cols x) i (rows x))) x) (declaim (ftype (function Modified: src/linalg/level3-linalg-blas-real.lisp ============================================================================== --- src/linalg/level3-linalg-blas-real.lisp (original) +++ src/linalg/level3-linalg-blas-real.lisp Sun May 17 15:02:03 2009 @@ -19,14 +19,6 @@ (in-package :lisplab) -;; TODO move these optimized functions to library - -(defmacro *df (a b) `(truly-the double-float (* ,a ,b))) -(defmacro /df (a b) `(truly-the double-float (/ ,a ,b))) -(defmacro +df (a b) `(truly-the double-float (+ ,a ,b))) -(defmacro -df (a b) `(truly-the double-float (- ,a ,b))) - - #+todo (defmethod mtr (matrix) (let ((ans 0)) (dotimes (i (rows matrix)) @@ -34,26 +26,26 @@ ans)) #+todo (defmethod mtp (a) - (let ((b (create a 0 (list (cols a) (rows a))))) + (let ((b (mcreate a 0 (list (cols a) (rows a))))) (dotimes (i (rows b)) (dotimes (j (cols b)) (setf (mref b i j) (mref a j i)))) b)) -(defmethod mconj ((a blas-real)) +(defmethod mconj ((a matrix-lisp-dge)) (copy a)) -(defmethod mct ((a blas-real)) +(defmethod mct ((a matrix-lisp-dge)) (mtp a)) -(defmethod m* ((a blas-real) (b blas-real)) +(defmethod m* ((a matrix-lisp-dge) (b matrix-lisp-dge)) (let* ((N (rows a)) (M (cols b)) (S (rows b)) - (c (create a 0 (list N M))) - (a2 (store a)) - (b2 (store b)) - (c2 (store c))) + (c (mcreate a 0 (list N M))) + (a2 (matrix-store a)) + (b2 (matrix-store b)) + (c2 (matrix-store c))) (declare (type-blas-store a2 b2 c2) (type-blas-idx N M S)) (macrolet ((refa (i j) `(ref-blas-real-store A2 ,i ,j N)) @@ -68,7 +60,7 @@ (setf (refc i j) cij)))) c))) -(defmethod LU-factor! ((A blas-real) p) +(defmethod LU-factor! ((A matrix-lisp-dge) p) ;; Translation from GSL. ;; Destructive LU factorization. The outout is PA=LU, ;; stored in one matrix, where the diagonal elements belong @@ -76,7 +68,7 @@ ;; Assumes the permutation vector to be initilized (let ((N (rows A)) (sign 1) - (A2 (store A))) + (A2 (matrix-store A))) (declare (type-blas-idx N) (fixnum sign) (type-blas-store a2) @@ -111,9 +103,9 @@ (defun L-solve!-blas-real (L x col) ;; Solve Lx=b - (declare (blas-real L x)) - (let ((L2 (store L)) - (x2 (store x)) + (declare (matrix-lisp-dge L x)) + (let ((L2 (matrix-store L)) + (x2 (matrix-store x)) (N (rows x))) (declare (type-blas-store L2 x2) (type-blas-idx N col)) @@ -128,9 +120,9 @@ x) (defun U-solve!-blas-real (U x col) - (declare (blas-real U x)) - (let* ((U2 (store U)) - (x2 (store x)) + (declare (matrix-lisp-dge U x)) + (let* ((U2 (matrix-store U)) + (x2 (matrix-store x)) (N (rows x)) (N-1 (1- N)) (N-2 (1- N-1))) @@ -152,7 +144,7 @@ (U-solve!-blas-real LU x col) x) -(defmethod lin-solve ((A blas-real) (b blas-real)) +(defmethod lin-solve ((A matrix-lisp-dge) (b matrix-lisp-dge)) (destructuring-bind (LU pvec sign) (LU-factor A) (let ((b2 (copy b))) (dotimes (i (rows A)) @@ -170,10 +162,10 @@ (LU-solve!-blas-real LU A (vref p i))))) A) -(defmethod minv! ((A blas-real)) +(defmethod minv! ((A matrix-lisp-dge)) (minv!-blas-real A)) -(defmethod minv ((A blas-real)) +(defmethod minv ((A matrix-lisp-dge)) (minv! (copy A))) Modified: src/linalg/level3-linalg-generic.lisp ============================================================================== --- src/linalg/level3-linalg-generic.lisp (original) +++ src/linalg/level3-linalg-generic.lisp Sun May 17 15:02:03 2009 @@ -17,6 +17,9 @@ ;;; with this program; if not, write to the Free Software Foundation, Inc., ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +;;; TODO clean up. Move read and write out + (in-package :lisplab) (export '(pgmwrite)) @@ -28,14 +31,14 @@ ans)) (defmethod mtp (a) - (let ((b (create a 0 (list (cols a) (rows a))))) + (let ((b (mcreate a 0 (list (cols a) (rows a))))) (dotimes (i (rows b)) (dotimes (j (cols b)) (setf (mref b i j) (mref a j i)))) b)) (defmethod mconj (a) - (let ((b (create a #C(0 0) (list (rows a) (cols a)) ))) + (let ((b (mcreate a #C(0 0) (list (rows a) (cols a)) ))) (dotimes (i (size b)) (setf (vref b i) (conjugate (vref a i)))) b)) @@ -44,7 +47,7 @@ (mconj (mtp a))) (defmethod m* (a b) - (let ((c (create a 0 (list (rows a) (cols b))))) + (let ((c (mcreate a 0 (list (rows a) (cols b))))) (dotimes (i (rows c)) (dotimes (j (cols c)) (dotimes (k (cols a)) @@ -197,7 +200,7 @@ (make-permutation-vector (rows A))) (let ((L A) (U (copy A)) - (Pmat (create A 0))) + (Pmat (mcreate A 0))) (w/mat L (x i j) (cond ((> i j) x) ((= i j) 1) (t 0))) (w/mat U (x i j) (cond ((<= i j) x) (t 0))) (dotimes (i (rows P)) @@ -265,82 +268,5 @@ - -;;; TRASH - -#+nil (defun apply-permutation (a p) - this is inverse - (let ((b (create a 0))) - (dotimes (row (rows a)) - (let ((s (vref p row))) - (dotimes (col (cols a)) - (setf (mref b row col) (mref a s col))))) - b)) - -#+nil (defun apply-inverse-permutation (a p) - this is forward - (let ((b (create a 0))) - (dotimes (row (rows a)) - (let ((s (vref p row))) - (dotimes (col (cols a)) - (setf (mref b s col) (mref a row col))))) - b)) - - -#+nil (defmethod LU-factor! (A p) - ;; Versjon fra boka! - (let* ((N (rows A)) - (N-1 (1- N)) - (det 1)) - (dotimes (i N) - (setf (vref p i) i)) - (dotimes (i N-1) - (let ((i-pivot i)) - (loop for j from (1+ i) below N do - (when (> (abs (mref A j i)) - (abs (mref A i-pivot i))) - (setf i-pivot j))) - (unless (= i-pivot i) - (let ((tmp (vref p i))) - (setf (vref p i) (vref p i-pivot) - (vref p i-pivot) tmp - det (- det))) - (dotimes (j N) - (let ((tmp (mref A i j))) - (setf (mref A i j) (mref A i-pivot j) - (mref A i-pivot j) tmp))))) - ;; Now reduce all elementsbelow the i'th row - (unless (zerop (mref A i i)) - (loop for r from (1+ i) below N do - (print (list 'foerr 'i i 'r r A)) - (setf (mref A r i) (./ (mref A r i) (mref A i i))) - (loop for c from (1+ i) below N do - (setf (mref A r c) (.- (mref A r c) - (.* (mref A r i) (mref A i c)))) - (print (list 'mellom 'r r 'c c (mref A r c)))) - (print (list 'etter 'i i 'r r A))))) - (list A p det))) - -#+nil (defun tmp-LU-mul (A) - ;; Test code. TODO move and make to an automated test - (destructuring-bind (LU p det) - (LU-factor A) - (let ((L (create LU 0)) - (U (create LU 0))) - (dotimes (i (rows A)) - (setf (mref L i i) 1) - (loop for j from 0 below i do - (setf (mref L i j) - (mref LU i j)))) - (dotimes (i (rows A)) - #+nil (setf (mref U i i) 1) - (loop for j from i below (cols A) do - (setf (mref U i j) - (mref LU i j)))) - (list A - (apply-inverse-permutation (m* L U) p) - LU - p L U)))) - Modified: src/matlisp/geev.lisp ============================================================================== --- src/matlisp/geev.lisp (original) +++ src/matlisp/geev.lisp Sun May 17 15:02:03 2009 @@ -32,12 +32,12 @@ (in-package :lisplab) -(defmethod eigenvectors ((a blas-real)) +(defmethod eigenvectors ((a matrix-blas-dge)) (destructuring-bind (evals vl-mat vr-mat) (dgeev (copy a) nil (create a 0)) (list evals vr-mat))) -(defmethod eigenvalues ((a blas-real)) +(defmethod eigenvalues ((a matrix-blas-dge)) (destructuring-bind (evals vl-mat vr-mat) (dgeev (copy a) nil nil) evals)) @@ -47,7 +47,7 @@ (defmethod rearrange-eigenvector-matrix (v p) p) -(defmethod rearrange-eigenvector-matrix ((evals blas-complex) (p blas-real )) +(defmethod rearrange-eigenvector-matrix ((evals matrix-blas-zge) (p matrix-blas-dge)) (let* ((n (size evals)) (evec (cnew 0 n n))) (do ((col 0 (incf col))) @@ -66,11 +66,11 @@ (defun combine-ri-vectors (wr wi) (let* ((n (size wr)) - (wr2 (make-instance 'blas-real :rows n :cols 1 :size n :store wr)) - (wi2 (make-instance 'blas-real :rows n :cols 1 :size n :store wi))) + (wr2 (make-instance 'matrix-dge :rows n :cols 1 :store wr)) + (wi2 (make-instance 'matrix-dge :rows n :cols 1 :store wi))) (if (.= wi2 0) wr2 - (.+ wr2 (.* %i (convert wi2 'blas-complex)))))) + (.+ wr2 (.* %i (convert wi2 'matrix-zge)))))) (defun dgeev-workspace-size (n lv? rv?) ;; Ask geev how much space it wants for the work array @@ -112,7 +112,7 @@ (if vl-mat "V" "N") ; JOBVL (if vr-mat "V" "N") ; JOBVR n ; N - (store a) ; A + (matrix-store a) ; A n ; LDA wr ; WR wi ; WI @@ -128,12 +128,12 @@ (vr-mat2 (rearrange-eigenvector-matrix evec vr-mat))) (list evec vl-mat2 vr-mat2))))) -(defmethod eigenvectors ((a blas-complex)) +(defmethod eigenvectors ((a matrix-zge)) (destructuring-bind (evals vl-mat vr-mat) (zgeev (copy a) nil (create a 0)) (list evals vr-mat))) -(defmethod eigenvalues ((a blas-complex)) +(defmethod eigenvalues ((a matrix-zge)) (destructuring-bind (evals vl-mat vr-mat) (zgeev (copy a) nil nil) evals)) @@ -166,8 +166,8 @@ (2n (* 2 n)) (xxx (allocate-real-store 2)) (w (cnew 0 n 1)) - (vl (if vl-mat (store vl-mat) xxx)) - (vr (if vr-mat (store vr-mat) xxx)) + (vl (if vl-mat (matrix-store vl-mat) xxx)) + (vr (if vr-mat (matrix-store vr-mat) xxx)) (lwork (zgeev-workspace-size n (if vl-mat t nil) (if vr-mat t nil))) (work (allocate-real-store lwork)) (rwork (allocate-real-store 2n))) @@ -176,9 +176,9 @@ (if vl-mat "V" "N") ;; JOBVL (if vr-mat "V" "N") ;; JOBVR n ;; N - (store a) ;; A + (matrix-store a) ;; A n ;; LDA - (store w) ;; W + (matrix-store w) ;; W vl ;; VL (if vl-mat n 1) ;; LDVL vr ;; VR Modified: src/matlisp/inv.lisp ============================================================================== --- src/matlisp/inv.lisp (original) +++ src/matlisp/inv.lisp Sun May 17 15:02:03 2009 @@ -19,44 +19,44 @@ (in-package :lisplab) -(defmethod minv! ((a blas-real)) +(defmethod minv! ((a matrix-blas-dge)) (let* ((N (rows a)) (ipiv (make-array N :element-type '(unsigned-byte 32))) (msg "argument A given to minv is singular to working machine precision")) (multiple-value-bind (_ ipiv info) - (f77::dgetrf N N (store a) N ipiv 0) + (f77::dgetrf N N (matrix-store a) N ipiv 0) (declare (ignore _)) (unless (zerop info) (error msg)) (let ((work (make-array N :element-type 'double-float))) (multiple-value-bind (_ __ info) - (f77::dgetri N (store a) N ipiv work N 0) + (f77::dgetri N (matrix-store a) N ipiv work N 0) (declare (ignore _ __)) (unless (zerop info) (error msg)) a))))) -(defmethod minv ((a blas-real)) +(defmethod minv ((a matrix-blas-dge)) (minv! (copy a))) -(defmethod minv! ((a blas-complex)) +(defmethod minv! ((a matrix-blas-zge)) (let* ((N (rows a)) (ipiv (make-array N :element-type '(unsigned-byte 32))) (msg "argument A given to mdiv is singular to working machine precision")) (multiple-value-bind (_ ipiv info) - (f77::zgetrf N N (store a) N ipiv 0) + (f77::zgetrf N N (matrix-store a) N ipiv 0) (declare (ignore _)) (unless (zerop info) (error msg )) (let ((work (make-array (* 2 N) :element-type 'double-float))) (multiple-value-bind (_ __ info) - (f77::zgetri N (store a) N ipiv work N 0) + (f77::zgetri N (matrix-store a) N ipiv work N 0) (declare (ignore _ __)) (unless (zerop info) (error msg)) a))))) -(defmethod minv ((a blas-complex)) +(defmethod minv ((a matrix-blas-zge)) (minv! (copy a))) Modified: src/matlisp/mul.lisp ============================================================================== --- src/matlisp/mul.lisp (original) +++ src/matlisp/mul.lisp Sun May 17 15:02:03 2009 @@ -19,18 +19,18 @@ (in-package :lisplab) -(defmethod m* ((a blas-real) (b blas-real)) +(defmethod m* ((a matrix-blas-dge) (b matrix-blas-dge)) (let* ((m (rows a)) (n (cols b)) (k (cols a)) - (c (new 'blas-real (list m n) t 0.0))) - (f77::dgemm "N" "N" m n k 1.0 (store a) m (store b) k 0.0 (store c) m) + (c (mcreate a 0 (list m n)))) + (f77::dgemm "N" "N" m n k 1.0 (matrix-store a) m (matrix-store b) k 0.0 (matrix-store c) m) c)) -(defmethod m* ((a blas-complex) (b blas-complex)) +(defmethod m* ((a matrix-blas-zge) (b matrix-blas-zge)) (let* ((m (rows a)) (n (cols b)) (k (cols a)) - (c (new 'blas-complex (list m n) t 0.0))) - (f77::zgemm "N" "N" m n k #C(1.0 0.0) (store a) m (store b) k #C(0.0 0.0) (store c) m) + (c (mcreate a 0 (list m n)))) + (f77::zgemm "N" "N" m n k #C(1.0 0.0) (matrix-store a) m (matrix-store b) k #C(0.0 0.0) (matrix-store c) m) c)) Modified: src/matrix/level1-classes.lisp ============================================================================== --- src/matrix/level1-classes.lisp (original) +++ src/matrix/level1-classes.lisp Sun May 17 15:02:03 2009 @@ -100,7 +100,7 @@ (defclass matrix-lisp-dge (matrix-implementation-lisp matrix-base-dge) ()) -(defclass matrix-dge (matrix-implementation-blas matrix-lisp-dge) ()) +(defclass matrix-blas-dge (matrix-implementation-blas matrix-lisp-dge) ()) (defclass matrix-dge (matrix-blas-dge) () (:documentation "General matrix with double float elements.")) @@ -144,7 +144,31 @@ (matrix-structure-diagonal matrix-element-complex-double-float matrix-implementation-base) ()) +;;; Function matrices (matrices without a store) +(defclass function-matrix + (matrix-structure-general matrix-element-base matrix-implementation-base) + ((mref + :initarg :mref + :initform (constantly 0) + :accessor function-matrix-mref + :type function) + (set-mref + :initarg :set-mref + :initform (constantly nil) + :accessor function-matrix-set-mref + :type function) + (vref + :initarg :vref + :initform (constantly 0) + :accessor function-matrix-vref + :type function) + (set-vref + :initarg :set-vref + :initform (constantly nil) + :accessor function-matrix-set-vref + :type function)) + (:documentation "Matrix without a store.")) Modified: src/matrix/level1-constructors.lisp ============================================================================== --- src/matrix/level1-constructors.lisp (original) +++ src/matrix/level1-constructors.lisp Sun May 17 15:02:03 2009 @@ -19,14 +19,14 @@ (in-package :lisplab) -(export '(mat new col row)) +#+nil (export '(mat new col row)) -(export '(rmat rnew rcol rrow)) +(export '(funmat + rmat rnew rcol rrow + cmat cnew ccol crow)) -(export '(cmat cnew ccol crow)) - -(defmacro mat (type &body args) +#+nil (defmacro mat (type &body args) "Creates a matrics" `(convert ,(cons 'list (mapcar (lambda (x) @@ -34,11 +34,11 @@ args)) ,type)) -(defun col (type &rest args) +#+nil (defun col (type &rest args) "Creates a column matrix" (convert (mapcar 'list args) type)) -(defun row (type &rest args) +#+nil (defun row (type &rest args) "Creates a row matrix" (convert args type)) @@ -62,7 +62,7 @@ (defun rnew (value rows &optional (cols 1)) "Creates a new blas-real matrix" - (new 'matrix-dge (list rows cols) t value)) + (mnew 'matrix-dge value rows cols)) (defmacro cmat (&body args) "Creates a blas-complex matrics" @@ -83,4 +83,27 @@ (defun cnew (value rows &optional (cols 1)) "Create a new blas-complex matrix" - (new 'matrix-zge (list rows cols) t value)) \ No newline at end of file + (mnew 'matrix-zge value rows cols)) + + +;;; Function matrix + +(defmacro funmat (rows cols args &body body) + "Creates a read only function matrix" + (let ((rows2 (gensym "rows")) + (cols2 (gensym "cols")) + (i (gensym)) + (r (gensym)) + (c (gensym))) + `(let ((,rows2 ,rows) + (,cols2 ,cols)) + (make-instance 'function-matrix + :rows ,rows2 + :cols ,cols2 + :mref (lambda (self , at args) + (declare (muffle-conditions style-warning)) + , at body) + :vref (lambda (self ,i) + ;; Default self vector reference in column major order + (multiple-value-bind (,r ,c) (floor ,i ,rows2) + (mref self ,r ,c))))))) Modified: src/matrix/level1-generic.lisp ============================================================================== --- src/matrix/level1-generic.lisp (original) +++ src/matrix/level1-generic.lisp Sun May 17 15:02:03 2009 @@ -26,7 +26,7 @@ #-todo-remove(defmethod new (class dim &optional (element-type t) (value 0)) ;;; TODO get rid of this default that calls the new constructor - (mnew class dim element-type value)) + (mnew class value (car dim) (cadr dim))) #+todo-remove(defmethod convert (obj type) (if (not (or (vector? obj) (matrix? obj))) Modified: src/matrix/level1-interface.lisp ============================================================================== --- src/matrix/level1-interface.lisp (original) +++ src/matrix/level1-interface.lisp Sun May 17 15:02:03 2009 @@ -39,7 +39,7 @@ (defgeneric new (class dim &optional element-type value) (:documentation "Deprecated. Use mnew in stead. Creates a new matrix filled with numeric arguments.")) -(defgeneric mnew (class dim &optional element-type value) +(defgeneric mnew (class value rows &optional cols) (:documentation "General matrix constructor. Creates a new matrix filled with numeric arguments.")) (defgeneric ref (matrix &rest subscripts) Modified: src/matrix/level1-matrix.lisp ============================================================================== --- src/matrix/level1-matrix.lisp (original) +++ src/matrix/level1-matrix.lisp Sun May 17 15:02:03 2009 @@ -20,7 +20,38 @@ (in-package :lisplab) -;;; Generic methods +;;; This is OK, but could be optimzied! +(defmacro w/mat (a args &body body) + (let ((a2 (gensym)) + (x (first args)) + (i (second args)) + (j (third args))) + `(let ((,a2 ,a)) + (dotimes (,i (rows ,a2)) + (dotimes (,j (cols ,a2)) + (let ((,x (mref ,a2 ,i ,j))) + (setf (mref ,a2 ,i ,j) + , at body)))) + ,a2))) + + +;;; Generic methods and functions + +(defun convert-list-to-matrix (list type) + (let* ((rows (length list)) + (cols (length (car list))) + (m (mnew type 0 rows cols))) + (fill-matrix-with-list m list))) + +(defun convert-matrix-to-matrix (m0 type) + (let* ((rows (rows m0)) + (cols (cols m0)) + (m (mnew type 0 rows cols))) + (dotimes (i rows) + (dotimes (j cols) + (setf (mref m i j) (mref m0 i j)))) + m)) + (defmethod scalar? ((x matrix-base)) nil) @@ -65,11 +96,20 @@ (make-matrix-instance 'matrix-zge dim value) (make-matrix-instance 'matrix-dge dim value))) + + + + ;;; Spcialized for blas-dge -(defmethod mnew ((class (eql 'matrix-dge)) dim &optional (element-type t) (value 0)) - (declare (ignore element-type)) - (make-matrix-instance class dim value)) +(defmethod convert ((x cons) (type (eql 'matrix-dge))) + (convert-list-to-matrix x type)) + +(defmethod convert ((x matrix-base) (type (eql 'matrix-dge))) + (convert-matrix-to-matrix x type)) + +(defmethod mnew ((class (eql 'matrix-dge)) value rows &optional (cols 1)) + (make-matrix-instance class (list rows cols) value)) (defmethod mref ((matrix matrix-base-dge) row col) (aref (the type-blas-store (matrix-store matrix)) @@ -91,11 +131,18 @@ (setf (aref (the type-blas-store (matrix-store matrix)) idx) (the double-float (coerce value 'double-float)))) + + ;;; Spcialized for blas-zge -(defmethod mnew ((class (eql 'matrix-zge)) dim &optional (element-type t) (value 0)) - (declare (ignore element-type)) - (make-matrix-instance class dim value)) +(defmethod convert ((x cons) (type (eql 'matrix-zge))) + (convert-list-to-matrix x type)) + +(defmethod convert ((x matrix-base) (type (eql 'matrix-zge))) + (convert-matrix-to-matrix x type)) + +(defmethod mnew ((class (eql 'matrix-zge)) value rows &optional (cols 1)) + (make-matrix-instance class (list rows cols) value)) (defmethod mref ((matrix matrix-base-zge) row col) (ref-blas-complex-store (matrix-store matrix) @@ -110,11 +157,24 @@ value) (defmethod vref ((matrix matrix-base-zge) i) - (ref-blas-complex-store (store matrix) i 0 1)) + (ref-blas-complex-store (matrix-store matrix) i 0 1)) (defmethod (setf vref) (value (matrix matrix-base-zge) i) (setf (ref-blas-complex-store (matrix-store matrix) i 0 1) (coerce value '(complex double-float))) value) +;;; Function matrix + +(defmethod mref ((f function-matrix) row col) + (funcall (function-matrix-mref f) f row col)) + +(defmethod (setf mref) (value (f function-matrix) row col) + (funcall (function-matrix-set-mref f) value f row col)) + +(defmethod vref ((f function-matrix) idx) + (funcall (function-matrix-vref f) f idx)) + +(defmethod (setf vref) (value (f function-matrix) idx) + (funcall (function-matrix-set-vref f) value f idx)) Modified: src/matrix/level1-util.lisp ============================================================================== --- src/matrix/level1-util.lisp (original) +++ src/matrix/level1-util.lisp Sun May 17 15:02:03 2009 @@ -29,6 +29,18 @@ :rows rows :cols cols))) +(defun fill-matrix-with-list (m x) + (let* ((rows (rows m)) + (cols (cols m))) + (do ((xx x (cdr xx)) + (i 0 (1+ i))) + ((= i rows)) + (do ((yy (car xx) (cdr yy)) + (j 0 (1+ j))) + ((= j cols)) + (setf (mref m i j) (car yy)))) + m)) + (deftype type-blas-store () '(simple-array double-float (*))) Modified: src/matrix/level2-generic.lisp ============================================================================== --- src/matrix/level2-generic.lisp (original) +++ src/matrix/level2-generic.lisp Sun May 17 15:02:03 2009 @@ -17,6 +17,8 @@ ;;; with this program; if not, write to the Free Software Foundation, Inc., ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +;;; TODO clean this up + (in-package :lisplab) (defmethod square-matrix? (x) Modified: src/matrix/level2-matrix-dge.lisp ============================================================================== --- src/matrix/level2-matrix-dge.lisp (original) +++ src/matrix/level2-matrix-dge.lisp Sun May 17 15:02:03 2009 @@ -19,6 +19,11 @@ (in-package :lisplab) +(defmethod fill! ((a matrix-dge) value) + (let ((x (coerce value 'double-float)) + (store (matrix-store a))) + (fill store x))) + (defmethod copy ((matrix matrix-base-dge)) (make-instance (class-name (class-of matrix)) :store (copy-seq (matrix-store matrix)) @@ -94,6 +99,6 @@ (matrix-store b) (lambda (&rest args) (coerce (apply f args) 'double-float)) - (matrix-store a) (mapcar #'store args)) + (matrix-store a) (mapcar #'matrix-store args)) b)) Modified: src/matrix/level2-matrix-zge.lisp ============================================================================== --- src/matrix/level2-matrix-zge.lisp (original) +++ src/matrix/level2-matrix-zge.lisp Sun May 17 15:02:03 2009 @@ -18,6 +18,15 @@ (in-package :lisplab) +(defmethod fill! ((a matrix-zge) value) + (let ((rx (coerce (realpart value) 'double-float)) + (cx (coerce (imagpart value) 'double-float)) + (store (matrix-store a))) + (loop for i from 0 below (length store) by 2 do + (setf (aref store i) rx + (aref store (1+ i)) cx)))) + + (defmethod copy ((matrix matrix-base-zge)) (make-instance (class-name (class-of matrix)) :store (copy-seq (matrix-store matrix)) Modified: system/lisplab.asd ============================================================================== --- system/lisplab.asd (original) +++ system/lisplab.asd Sun May 17 15:02:03 2009 @@ -41,11 +41,12 @@ (:file "level1-constructors") (:file "level2-interface") - + (:file "level2-generic") + (:file "level2-array-functions") (:file "level2-matrix-dge") (:file "level2-matrix-zge") - (:file "level2-array-functions") + ; (:file "level1-interface") ; (:file "level1-util") @@ -82,7 +83,7 @@ ;; ;; Linear algebra lisp implementation (Level 3) ;; - #+nil (:module :linalg-native + (:module :linalg-native :depends-on (:matrix :linalg-interface) :pathname "../src/linalg/" :serial t @@ -94,14 +95,14 @@ ;; ;; Fast Fourier transform (Level 3) ;; - #+nil (:module :fft + (:module :fft :depends-on (:matrix) :pathname "../src/fft/" :serial t :components ( (:file "level3-fft-interface") - (:file "level3-fft-generic") + #+nil (:file "level3-fft-generic") (:file "level3-fft-blas"))) ;; @@ -119,7 +120,7 @@ ;; ;; Blas and Lapack implmentations (Level 3) ;; - #+nil (:module :matlisp + (:module :matlisp :depends-on (:matrix :linalg-interface) :pathname "../src/matlisp/" :serial t From jivestgarden at common-lisp.net Wed May 20 20:05:58 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Wed, 20 May 2009 16:05:58 -0400 Subject: [lisplab-cvs] r27 - in src: matlisp matrix Message-ID: Author: jivestgarden Date: Wed May 20 16:05:54 2009 New Revision: 27 Log: refactored. Almost finished Modified: src/matlisp/geev.lisp src/matrix/level1-classes.lisp src/matrix/level1-constructors.lisp src/matrix/level1-generic.lisp src/matrix/level1-interface.lisp src/matrix/level1-matrix.lisp src/matrix/level1-util.lisp src/matrix/level2-generic.lisp src/matrix/level2-interface.lisp Modified: src/matlisp/geev.lisp ============================================================================== --- src/matlisp/geev.lisp (original) +++ src/matlisp/geev.lisp Wed May 20 16:05:54 2009 @@ -102,8 +102,8 @@ (xxx (allocate-real-store 1)) (wr (allocate-real-store n)) (wi (allocate-real-store n)) - (vl (if vl-mat (store vl-mat) xxx)) - (vr (if vr-mat (store vr-mat) xxx)) + (vl (if vl-mat (matrix-store vl-mat) xxx)) + (vr (if vr-mat (matrix-store vr-mat) xxx)) (lwork (dgeev-workspace-size n (if vl-mat t nil) (if vr-mat t nil) )) (work (allocate-real-store lwork))) (multiple-value-bind (a wr wi vl vr work info) Modified: src/matrix/level1-classes.lisp ============================================================================== --- src/matrix/level1-classes.lisp (original) +++ src/matrix/level1-classes.lisp Wed May 20 16:05:54 2009 @@ -1,6 +1,5 @@ ;;; Lisplab, level1-classes.lisp ;;; Level1, matrix classes -;;; ;;; Copyright (C) 2009 Joern Inge Vestgaarden ;;; @@ -18,8 +17,40 @@ ;;; with this program; if not, write to the Free Software Foundation, Inc., ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +;;; The class structure is inspired by the stream example +;;; in Object-Oriented programming in Common Lisp, by Sonja E. Keene. + + (in-package :lisplab) +;; A scheme for matrix creations + +(defvar *matrix-class-to-description* (make-hash-table)) +(defvar *matrix-description-to-class* (make-hash-table :test #'equal)) + +(defun add-matrix-class (class element-type structure implementation) + (setf (gethash (list element-type structure implementation) + *matrix-description-to-class*) + class + (gethash class + *matrix-class-to-description* ) + (list element-type structure implementation))) + +(defun find-matrix-class (description) + (let* ((entry (gethash description + *matrix-description-to-class*))) + (unless entry + (error "No matrix of structure ~A." description)) + entry)) + +(defun find-matrix-description (class) + (let* ((entry (gethash class + *matrix-class-to-description*))) + (unless entry + (error "No matrix description of class ~A." class)) + entry)) + + (defclass matrix-base () ()) ;;; The matrix element tells the element type of the matrix @@ -172,5 +203,20 @@ +;;; Adding all the matrix descriptions + +(add-matrix-class 'matrix-base-dge :d :ge :base) +(add-matrix-class 'matrix-lisp-dge :d :ge :lisp) +(add-matrix-class 'matrix-blas-dge :d :ge :blas) +(add-matrix-class 'matrix-dge :d :ge :any) + +(add-matrix-class 'matrix-base-zge :z :ge :base) +(add-matrix-class 'matrix-lisp-zge :z :ge :lisp) +(add-matrix-class 'matrix-blas-zge :z :ge :blas) +(add-matrix-class 'matrix-zge :z :ge :any) + +;;; TODO the other types need also conventions + + Modified: src/matrix/level1-constructors.lisp ============================================================================== --- src/matrix/level1-constructors.lisp (original) +++ src/matrix/level1-constructors.lisp Wed May 20 16:05:54 2009 @@ -17,6 +17,9 @@ ;;; with this program; if not, write to the Free Software Foundation, Inc., ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +;;; TODO: should be level2 not level1 + + (in-package :lisplab) #+nil (export '(mat new col row)) Modified: src/matrix/level1-generic.lisp ============================================================================== --- src/matrix/level1-generic.lisp (original) +++ src/matrix/level1-generic.lisp Wed May 20 16:05:54 2009 @@ -24,49 +24,4 @@ (in-package :lisplab) -#-todo-remove(defmethod new (class dim &optional (element-type t) (value 0)) - ;;; TODO get rid of this default that calls the new constructor - (mnew class value (car dim) (cadr dim))) -#+todo-remove(defmethod convert (obj type) - (if (not (or (vector? obj) (matrix? obj))) - (coerce obj type) - (let ((new (new type (dim obj) (element-type obj)))) - (ecase (rank obj) - (1 (dotimes (i (size obj)) - (setf (vref new i) (vref obj i)))) - (2 (dotimes (i (rows obj)) - (dotimes (j (cols obj)) - (setf (mref new i j) (mref obj i j)))))) - new))) - -#+todo-remove(defmethod copy (a) - (typecase a - (list (copy-list a)) - (sequence (copy-seq a)) - (t (let ((b (create a))) - (dotimes (i (size a)) - (setf (vref b i) (vref a i))) - b)))) - -#-todo-remove(defmethod create (a &optional value dim) - (unless dim (setf dim (dim a))) - (unless (consp dim) (setf dim (list dim 1))) - (if value - (new (class-name (class-of a)) dim (element-type a) value) - (new (class-name (class-of a)) dim))) - - -;;; This is OK, but could be optimzied! -(defmacro w/mat (a args &body body) - (let ((a2 (gensym)) - (x (first args)) - (i (second args)) - (j (third args))) - `(let ((,a2 ,a)) - (dotimes (,i (rows ,a2)) - (dotimes (,j (cols ,a2)) - (let ((,x (mref ,a2 ,i ,j))) - (setf (mref ,a2 ,i ,j) - , at body)))) - ,a2))) Modified: src/matrix/level1-interface.lisp ============================================================================== --- src/matrix/level1-interface.lisp (original) +++ src/matrix/level1-interface.lisp Wed May 20 16:05:54 2009 @@ -21,12 +21,11 @@ (in-package :lisplab) (export '(*lisplab-print-size* - vector? matrix? - new mnew - create mcreate + vector? matrix? + make-matrix-instance ref mref vref - dim element-type create - size rank rows cols )) + dim element-type + size rank rows cols)) (defvar *lisplab-print-size* 10 "Suggested number of rows and columns printed to standard output. Not all matrices, such as ordinary lisp arrays, will care about the value.") @@ -36,11 +35,8 @@ (defgeneric matrix? (x) (:documentation "A matrix is a object whose elements are accesible with mref.")) -(defgeneric new (class dim &optional element-type value) - (:documentation "Deprecated. Use mnew in stead. Creates a new matrix filled with numeric arguments.")) - -(defgeneric mnew (class value rows &optional cols) - (:documentation "General matrix constructor. Creates a new matrix filled with numeric arguments.")) +(defgeneric make-matrix-instance (type dim value) + (:documentation "Creates a new matrix instance")) (defgeneric ref (matrix &rest subscripts) (:documentation "A general accessor.")) @@ -68,18 +64,6 @@ (defgeneric (setf element-type) (value matrix)) -(defgeneric create (a &optional value dim) - (:documentation "Deprecated. Use mcreate in stead. Creates a new matrix of the same type and with the same value as the other, -but with all elements set to value.")) - -(defgeneric mcreate (a &optional value dim) - (:documentation "Creates a new matrix of the same type and with the same value as the other, -but with all elements set to value.")) - -(defgeneric mmcreate (a b &optional value dim) - (:documentation "Creates a new matrix. The new matrix has a type derived from a and b, -and all elements set to value.")) - (defgeneric size (matrix) (:documentation "Gives the number of elements in the object.")) Modified: src/matrix/level1-matrix.lisp ============================================================================== --- src/matrix/level1-matrix.lisp (original) +++ src/matrix/level1-matrix.lisp Wed May 20 16:05:54 2009 @@ -18,40 +18,9 @@ ;;; with this program; if not, write to the Free Software Foundation, Inc., ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -(in-package :lisplab) - -;;; This is OK, but could be optimzied! -(defmacro w/mat (a args &body body) - (let ((a2 (gensym)) - (x (first args)) - (i (second args)) - (j (third args))) - `(let ((,a2 ,a)) - (dotimes (,i (rows ,a2)) - (dotimes (,j (cols ,a2)) - (let ((,x (mref ,a2 ,i ,j))) - (setf (mref ,a2 ,i ,j) - , at body)))) - ,a2))) - - -;;; Generic methods and functions - -(defun convert-list-to-matrix (list type) - (let* ((rows (length list)) - (cols (length (car list))) - (m (mnew type 0 rows cols))) - (fill-matrix-with-list m list))) - -(defun convert-matrix-to-matrix (m0 type) - (let* ((rows (rows m0)) - (cols (cols m0)) - (m (mnew type 0 rows cols))) - (dotimes (i rows) - (dotimes (j cols) - (setf (mref m i j) (mref m0 i j)))) - m)) +;;; TODO: clean up +(in-package :lisplab) (defmethod scalar? ((x matrix-base)) nil) @@ -82,35 +51,20 @@ (when (< rows (rows matrix)) (format stream "...~%"))))) -(defmethod mcreate ((a matrix-base) &optional (value 0) dim) - (unless dim - (setf dim (dim a))) - (make-matrix-instance (class-of a) dim value)) - -(defmethod mmcreate ((a matrix-base) (b matrix-base) &optional (value 0) dim) - ;; TODO make real implmentaiton of this - (unless dim - (setf dim (dim a))) - (if (or (equal '(complex double-float) (element-type a)) - (equal '(complex double-float) (element-type b))) - (make-matrix-instance 'matrix-zge dim value) - (make-matrix-instance 'matrix-dge dim value))) - +;;;; General cration +(defmethod make-matrix-instance ((type symbol) dim value) + (make-instance type :rows (car dim) :cols (cadr dim) :value value)) +(defmethod make-matrix-instance ((type standard-class) dim value) + (make-instance type :rows (car dim) :cols (cadr dim) :value value)) +(defmethod make-matrix-instance ((description list) dim value) + (make-matrix-instance (find-matrix-class description) dim value)) + ;;; Spcialized for blas-dge -(defmethod convert ((x cons) (type (eql 'matrix-dge))) - (convert-list-to-matrix x type)) - -(defmethod convert ((x matrix-base) (type (eql 'matrix-dge))) - (convert-matrix-to-matrix x type)) - -(defmethod mnew ((class (eql 'matrix-dge)) value rows &optional (cols 1)) - (make-matrix-instance class (list rows cols) value)) - (defmethod mref ((matrix matrix-base-dge) row col) (aref (the type-blas-store (matrix-store matrix)) (truly-the type-blas-idx (column-major-idx (truly-the type-blas-idx row) @@ -132,18 +86,8 @@ (the double-float (coerce value 'double-float)))) - ;;; Spcialized for blas-zge -(defmethod convert ((x cons) (type (eql 'matrix-zge))) - (convert-list-to-matrix x type)) - -(defmethod convert ((x matrix-base) (type (eql 'matrix-zge))) - (convert-matrix-to-matrix x type)) - -(defmethod mnew ((class (eql 'matrix-zge)) value rows &optional (cols 1)) - (make-matrix-instance class (list rows cols) value)) - (defmethod mref ((matrix matrix-base-zge) row col) (ref-blas-complex-store (matrix-store matrix) (column-major-idx row col (rows matrix)) Modified: src/matrix/level1-util.lisp ============================================================================== --- src/matrix/level1-util.lisp (original) +++ src/matrix/level1-util.lisp Wed May 20 16:05:54 2009 @@ -20,15 +20,6 @@ (in-package :lisplab) -(defun make-matrix-instance (class dim value) - (unless (consp dim) (setf dim (list dim 1))) - (let ((rows (car dim)) - (cols (if (cdr dim) (cadr dim) 1))) - (make-instance class - :value value - :rows rows - :cols cols))) - (defun fill-matrix-with-list (m x) (let* ((rows (rows m)) (cols (cols m))) Modified: src/matrix/level2-generic.lisp ============================================================================== --- src/matrix/level2-generic.lisp (original) +++ src/matrix/level2-generic.lisp Wed May 20 16:05:54 2009 @@ -21,6 +21,156 @@ (in-package :lisplab) +;;; This is OK, but could be optimzied! +(defmacro w/mat (a args &body body) + (let ((a2 (gensym)) + (x (first args)) + (i (second args)) + (j (third args))) + `(let ((,a2 ,a)) + (dotimes (,i (rows ,a2)) + (dotimes (,j (cols ,a2)) + (let ((,x (mref ,a2 ,i ,j))) + (setf (mref ,a2 ,i ,j) + , at body)))) + ,a2))) + +#-todo-remove(defmethod new (class dim &optional (element-type t) (value 0)) + ;;; TODO get rid of this default that calls the new constructor + (mnew class value (car dim) (cadr dim))) + +#+todo-remove(defmethod convert (obj type) + (if (not (or (vector? obj) (matrix? obj))) + (coerce obj type) + (let ((new (new type (dim obj) (element-type obj)))) + (ecase (rank obj) + (1 (dotimes (i (size obj)) + (setf (vref new i) (vref obj i)))) + (2 (dotimes (i (rows obj)) + (dotimes (j (cols obj)) + (setf (mref new i j) (mref obj i j)))))) + new))) + +#+todo-remove(defmethod copy (a) + (typecase a + (list (copy-list a)) + (sequence (copy-seq a)) + (t (let ((b (create a))) + (dotimes (i (size a)) + (setf (vref b i) (vref a i))) + b)))) + +#-todo-remove (defmethod create (a &optional value dim) + (mcreate a value dim)) + +;; Helper function. +(defun convert-list-to-matrix (list type) + (let* ((rows (length list)) + (cols (length (car list))) + (m (make-matrix-instance type (list rows cols) 0))) + (fill-matrix-with-list m list))) + +;; Helper function. +(defun convert-matrix-to-matrix (m0 type) + (let* ((rows (rows m0)) + (cols (cols m0)) + (m (make-matrix-instance type (dim m0) 0))) + (dotimes (i rows) + (dotimes (j cols) + (setf (mref m i j) (mref m0 i j)))) + m)) + +(defmethod mcreate ((a matrix-base) &optional (value 0) dim) + (unless dim + (setf dim (dim a))) + (make-matrix-instance (class-of a) dim value)) + +(defmethod mmcreate ((a matrix-base) (b matrix-base) &optional (value 0) dim) + ;; TODO make real implmentaiton of this based on descriptions + (unless dim + (setf dim (dim a))) + (if (or (equal '(complex double-float) (element-type a)) + (equal '(complex double-float) (element-type b))) + (make-matrix-instance 'matrix-zge dim value) + (make-matrix-instance 'matrix-dge dim value))) + +;;; TODO move to dge code + +#+todo-remove(defmethod convert ((x cons) (type (eql 'matrix-dge))) + (convert-list-to-matrix x type)) + +#+todo-remove(defmethod convert ((x matrix-base) (type (eql 'matrix-dge))) + (convert-matrix-to-matrix x type)) + +#+todo-remove(defmethod mnew ((class (eql 'matrix-dge)) value rows &optional (cols 1)) + (make-matrix-instance class (list rows cols) value)) + +;;; TODO move to zge code + +#+todo-remove(defmethod convert ((x cons) (type (eql 'matrix-zge))) + (convert-list-to-matrix x type)) + +#+todo-remove(defmethod convert ((x matrix-base) (type (eql 'matrix-zge))) + (convert-matrix-to-matrix x type)) + +#+todo-remove(defmethod mnew ((class (eql 'matrix-zge)) value rows &optional (cols 1)) + (make-matrix-instance class (list rows cols) value)) + +;; Should this be specialized to subclasses of matrix-base? +;; This question also holds for other methds in this file +(defmethod convert (x type) + (print "hei") + (let ((y (make-matrix-instance type (dim x) 0))) + ;; Note that I cannot use vref, since some matrix implmentations + ;; have different ordering. + (dotimes (i (rows x)) + (dotimes (j (cols x)) + (setf (mref y i j) (mref x i j)))) + y)) + +(defmethod convert ((x cons) type) + ;; TODO some better way ... some more general guessing routine + ;; like guess-best-element-type + (if (consp (car x)) + (let* ((cols (length (car x))) + (rows (length x)) + (m (make-matrix-instance type (list rows cols) 0))) + (do ((xx x (cdr xx)) + (i 0 (1+ i))) + ((= i rows)) + (do ((yy (car xx) (cdr yy)) + (j 0 (1+ j))) + ((= j cols)) + (setf (mref m i j) (car yy)))) + m) + ;; else make a row vector + (convert (list x) type))) + +(defmethod mmap (type f a &rest args) + (let ((b (new type (dim a) ))) + (cond ((not args) + (dotimes (i (size a)) + (setf (vref b i) (funcall f (vref a i))))) + ((not (cdr args)) + (let ((c (car args))) + (dotimes (i (size a)) + (setf (vref b i) (funcall f (vref a i) (vref c i)))))) + (t (dotimes (i (size a)) + (setf (vref b i) (apply f (vref a i) + (mapcar (lambda (x) + (vref x i)) + args)))))) + b)) + +(defmethod .map (f a &rest args) + (apply #'mmap (class-name (class-of a)) f a args)) + + + + + + + (defmethod square-matrix? (x) (and (matrix? x) (= (rows x) (cols x)))) @@ -76,44 +226,10 @@ (setf (vref a i) val)) val) -(defmethod mmap (type f a &rest args) - (let ((b (new type (dim a) ))) - (cond ((not args) - (dotimes (i (size a)) - (setf (vref b i) (funcall f (vref a i))))) - ((not (cdr args)) - (let ((c (car args))) - (dotimes (i (size a)) - (setf (vref b i) (funcall f (vref a i) (vref c i)))))) - (t (dotimes (i (size a)) - (setf (vref b i) (apply f (vref a i) - (mapcar (lambda (x) - (vref x i)) - args)))))) - b)) - -(defmethod .map (f a &rest args) - (apply #'mmap (class-name (class-of a)) f a args)) -(defmethod convert ((x cons) type) - ;; TODO some better way ... some more general guessing routine - ;; like guess-best-element-type - (if (consp (car x)) - (let* ((cols (length (car x))) - (rows (length x)) - (m (new type (list rows cols)))) - (do ((xx x (cdr xx)) - (i 0 (1+ i))) - ((= i rows)) - (do ((yy (car xx) (cdr yy)) - (j 0 (1+ j))) - ((= j cols)) - (setf (mref m i j) (car yy)))) - m) - ;; else make a row vector - (convert (list x) type))) (defmethod circ-shift (A shift) + ;; TODO move to level3 (let ((B (create A)) (rows (rows A)) (cols (cols A)) @@ -126,6 +242,7 @@ B)) (defmethod pad-shift (A shift &optional (value 0)) + ;; TODO move to level3 (let ((B (create A value)) (rows (rows A)) (cols (cols A)) Modified: src/matrix/level2-interface.lisp ============================================================================== --- src/matrix/level2-interface.lisp (original) +++ src/matrix/level2-interface.lisp Wed May 20 16:05:54 2009 @@ -19,7 +19,10 @@ (in-package :lisplab) -(export '(square-matrix? +(export '( + new mnew + create mcreate + square-matrix? diag .map mmap fill! dlmwrite dlmread @@ -37,6 +40,25 @@ circ-shift pad-shift)) + +(defgeneric new (class dim &optional element-type value) + (:documentation "Deprecated. Use mnew in stead. Creates a new matrix filled with numeric arguments.")) + +(defgeneric mnew (class value rows &optional cols) + (:documentation "General matrix constructor. Creates a new matrix filled with numeric arguments.")) + +(defgeneric create (a &optional value dim) + (:documentation "Deprecated. Use mcreate in stead. Creates a new matrix of the same type and with the same value as the other, +but with all elements set to value.")) + +(defgeneric mcreate (a &optional value dim) + (:documentation "Creates a new matrix of the same type and with the same value as the other, +but with all elements set to value.")) + +(defgeneric mmcreate (a b &optional value dim) + (:documentation "Creates a new matrix. The new matrix has a type derived from a and b, +and all elements set to value.")) + (defgeneric square-matrix? (x) (:documentation "True when the matrix is square, obviously.")) From jivestgarden at common-lisp.net Thu May 21 09:34:47 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Thu, 21 May 2009 05:34:47 -0400 Subject: [lisplab-cvs] r28 - src/core src/matrix src/specfunc system Message-ID: Author: jivestgarden Date: Thu May 21 05:34:44 2009 New Revision: 28 Log: refactoring getting shape Added: src/matrix/level2-constructors.lisp Modified: src/core/level0-basic.lisp src/core/level0-functions.lisp src/matrix/level1-classes.lisp src/matrix/level1-constructors.lisp src/matrix/level2-generic.lisp src/matrix/level2-matrix-dge.lisp src/specfunc/level0-specfunc.lisp system/lisplab.asd Modified: src/core/level0-basic.lisp ============================================================================== --- src/core/level0-basic.lisp (original) +++ src/core/level0-basic.lisp Thu May 21 05:34:44 2009 @@ -26,6 +26,7 @@ (setf *READ-DEFAULT-FLOAT-FORMAT* 'double-float) ; TODO make part of pacakge import? (defmacro with-gensyms ((&rest names) . body) + ;; TODO remove? Is it used at all? `(let ,(loop for n in names collect `(,n (gensym))) , at body)) @@ -43,9 +44,11 @@ ,@(when doc (list doc))))) (defun strcat (&rest args) + ;; TODO move to the part dealing with files (apply #'concatenate (append (list 'string) args))) (defmacro in-dir (dir &body body) + ;; TODO move to the part dealing with files (let ((path (gensym)) (dir2 (gensym))) `(let* ((,dir2 ,dir) @@ -59,3 +62,10 @@ (let ((*default-pathname-defaults* ,path)) , at body)))) +(defun to-df (x) + "Coerce x to double float." + (coerce x 'double-float)) + +(defun dvec (n) + "Creates a double vector with n elements." + (make-array n :element-type 'double-float :initial-element 0.0)) \ No newline at end of file Modified: src/core/level0-functions.lisp ============================================================================== --- src/core/level0-functions.lisp (original) +++ src/core/level0-functions.lisp Thu May 21 05:34:44 2009 @@ -33,7 +33,7 @@ (= a b))) (defmethod ./= ((a number) (b number) &optional (accuracy)) - (apply '.= a b accuracy)) + (not (.= a b accuracy))) (defmethod .< ((a number) (b number)) (< a b)) @@ -59,35 +59,66 @@ (defmethod .sub ((a number) (b number)) (- a b)) + + (defmethod .expt ((a number) (b number)) (expt a b)) +(defmethod .expt ((a real) (b real)) + (expt (to-df a) b)) + (defmethod .sin ((x number)) (sin x)) +(defmethod .sin ((x real)) + (sin (to-df x))) + (defmethod .cos ((x number)) (cos x)) +(defmethod .cos ((x real)) + (cos (to-df x))) + (defmethod .tan ((x number)) (tan x)) +(defmethod .tan ((x real)) + (tan (to-df x))) + (defmethod .log ((x number) &optional (base nil)) (if base (log x base) (log x))) +(defmethod .log ((x real) &optional (base nil)) + (if base + (log (to-df x) base) + (log (to-df x)))) + (defmethod .exp ((x number)) (exp x)) +(defmethod .exp ((x real)) + (exp (to-df x))) + (defmethod .sinh ((x number)) (sinh x)) +(defmethod .sinh ((x real)) + (sinh (to-df x))) + (defmethod .cosh ((x number)) (cosh x)) +(defmethod .cosh ((x real)) + (cosh (to-df x))) + (defmethod .tanh ((x number)) (tanh x)) +(defmethod .tanh ((x real)) + (tanh (to-df x))) + Modified: src/matrix/level1-classes.lisp ============================================================================== --- src/matrix/level1-classes.lisp (original) +++ src/matrix/level1-classes.lisp Thu May 21 05:34:44 2009 @@ -23,34 +23,6 @@ (in-package :lisplab) -;; A scheme for matrix creations - -(defvar *matrix-class-to-description* (make-hash-table)) -(defvar *matrix-description-to-class* (make-hash-table :test #'equal)) - -(defun add-matrix-class (class element-type structure implementation) - (setf (gethash (list element-type structure implementation) - *matrix-description-to-class*) - class - (gethash class - *matrix-class-to-description* ) - (list element-type structure implementation))) - -(defun find-matrix-class (description) - (let* ((entry (gethash description - *matrix-description-to-class*))) - (unless entry - (error "No matrix of structure ~A." description)) - entry)) - -(defun find-matrix-description (class) - (let* ((entry (gethash class - *matrix-class-to-description*))) - (unless entry - (error "No matrix description of class ~A." class)) - entry)) - - (defclass matrix-base () ()) ;;; The matrix element tells the element type of the matrix @@ -203,19 +175,6 @@ -;;; Adding all the matrix descriptions - -(add-matrix-class 'matrix-base-dge :d :ge :base) -(add-matrix-class 'matrix-lisp-dge :d :ge :lisp) -(add-matrix-class 'matrix-blas-dge :d :ge :blas) -(add-matrix-class 'matrix-dge :d :ge :any) - -(add-matrix-class 'matrix-base-zge :z :ge :base) -(add-matrix-class 'matrix-lisp-zge :z :ge :lisp) -(add-matrix-class 'matrix-blas-zge :z :ge :blas) -(add-matrix-class 'matrix-zge :z :ge :any) - -;;; TODO the other types need also conventions Modified: src/matrix/level1-constructors.lisp ============================================================================== --- src/matrix/level1-constructors.lisp (original) +++ src/matrix/level1-constructors.lisp Thu May 21 05:34:44 2009 @@ -17,96 +17,55 @@ ;;; with this program; if not, write to the Free Software Foundation, Inc., ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -;;; TODO: should be level2 not level1 +(in-package :lisplab) +;; A scheme for matrix creations -(in-package :lisplab) +(defvar *matrix-class-to-description* (make-hash-table)) +(defvar *matrix-description-to-class* (make-hash-table :test #'equal)) + +(defun add-matrix-class (class element-type structure implementation) + (setf (gethash (list element-type structure implementation) + *matrix-description-to-class*) + class + (gethash class + *matrix-class-to-description* ) + (list element-type structure implementation))) + +(defun find-matrix-class (description) + (let* ((entry (gethash description + *matrix-description-to-class*))) + (unless entry + (error "No matrix of structure ~A." description)) + entry)) + +(defun find-matrix-description (class) + (let* ((entry (gethash class + *matrix-class-to-description*))) + (unless entry + (error "No matrix description of class ~A." class)) + entry)) + +(defun create-matrix-description (d0 &key et s i) + "A simple language to modify matrix descriptions. Uses +the obejct as foundation of the description, but you can +override the description with the keywords." + (list + (if et et (first d0)) + (if s s (second d0)) + (if i i (third d0)))) + +;;; Adding all the matrix descriptions + +(add-matrix-class 'matrix-base-dge :d :ge :base) +(add-matrix-class 'matrix-lisp-dge :d :ge :lisp) +(add-matrix-class 'matrix-blas-dge :d :ge :blas) +(add-matrix-class 'matrix-dge :d :ge :any) + +(add-matrix-class 'matrix-base-zge :z :ge :base) +(add-matrix-class 'matrix-lisp-zge :z :ge :lisp) +(add-matrix-class 'matrix-blas-zge :z :ge :blas) +(add-matrix-class 'matrix-zge :z :ge :any) -#+nil (export '(mat new col row)) +;;; TODO the other types need also conventions -(export '(funmat - rmat rnew rcol rrow - cmat cnew ccol crow)) - - -#+nil (defmacro mat (type &body args) - "Creates a matrics" - `(convert - ,(cons 'list (mapcar (lambda (x) - (cons 'list x)) - args)) - ,type)) - -#+nil (defun col (type &rest args) - "Creates a column matrix" - (convert (mapcar 'list args) type)) - -#+nil (defun row (type &rest args) - "Creates a row matrix" - (convert args type)) - - -(defmacro rmat (&body args) - "Creates a blas-real matrics" - `(convert - ,(cons 'list (mapcar (lambda (x) - (cons 'list x)) - args)) - - 'matrix-dge)) - -(defun rcol (&rest args) - "Creates a blas-real column matrix" - (convert (mapcar 'list args) 'matrix-dge)) - -(defun rrow (&rest args) - "Creates a blas-real row matrix" - (convert args 'matrix-dge)) - -(defun rnew (value rows &optional (cols 1)) - "Creates a new blas-real matrix" - (mnew 'matrix-dge value rows cols)) - -(defmacro cmat (&body args) - "Creates a blas-complex matrics" - `(convert - ,(cons 'list (mapcar (lambda (x) - (cons 'list x)) - args)) - - 'matrix-zge)) - -(defun ccol (&rest args) - "Creates a blas-complex column matrix" - (convert (mapcar 'list args) 'matrix-zge)) - -(defun crow (&rest args) - "Creates a blas-complex row matrix" - (convert args 'matrix-zge)) - -(defun cnew (value rows &optional (cols 1)) - "Create a new blas-complex matrix" - (mnew 'matrix-zge value rows cols)) - - -;;; Function matrix - -(defmacro funmat (rows cols args &body body) - "Creates a read only function matrix" - (let ((rows2 (gensym "rows")) - (cols2 (gensym "cols")) - (i (gensym)) - (r (gensym)) - (c (gensym))) - `(let ((,rows2 ,rows) - (,cols2 ,cols)) - (make-instance 'function-matrix - :rows ,rows2 - :cols ,cols2 - :mref (lambda (self , at args) - (declare (muffle-conditions style-warning)) - , at body) - :vref (lambda (self ,i) - ;; Default self vector reference in column major order - (multiple-value-bind (,r ,c) (floor ,i ,rows2) - (mref self ,r ,c))))))) Added: src/matrix/level2-constructors.lisp ============================================================================== --- (empty file) +++ src/matrix/level2-constructors.lisp Thu May 21 05:34:44 2009 @@ -0,0 +1,170 @@ +;;; Lisplab, level2-constructors.lisp +;;; Possible and impossible ways to create matrices. + +;;; Copyright (C) 2009 Joern Inge Vestgaarden +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License along +;;; with this program; if not, write to the Free Software Foundation, Inc., +;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +(in-package :lisplab) + +(export '(funmat + fmat + mat col row + dmat dnew dcol drow + zmat znew zcol zrow)) + +;; Helper function. +(defun convert-list-to-matrix (list type) + (let* ((rows (length list)) + (cols (length (car list))) + (m (make-matrix-instance type (list rows cols) 0))) + (fill-matrix-with-list m list))) + +;; Helper function. +(defun convert-matrix-to-matrix (m0 type) + (let* ((rows (rows m0)) + (cols (cols m0)) + (m (make-matrix-instance type (dim m0) 0))) + (dotimes (i rows) + (dotimes (j cols) + (setf (mref m i j) (mref m0 i j)))) + m)) + +(defmethod mcreate ((a matrix-base) &optional (value 0) dim) + (unless dim + (setf dim (dim a))) + (make-matrix-instance (class-of a) dim value)) + +(defmethod mmcreate ((a matrix-base) (b matrix-base) &optional (value 0) dim) + ;; TODO make real implmentaiton of this based on descriptions + (unless dim + (setf dim (dim a))) + (if (or (equal '(complex double-float) (element-type a)) + (equal '(complex double-float) (element-type b))) + (make-matrix-instance 'matrix-zge dim value) + (make-matrix-instance 'matrix-dge dim value))) + +;; Should this be specialized to subclasses of matrix-base? +;; This question also holds for other methds in this file +(defmethod convert (x type) + (let ((y (make-matrix-instance type (dim x) 0))) + ;; Note that I cannot use vref, since some matrix implmentations + ;; have different ordering. + (dotimes (i (rows x)) + (dotimes (j (cols x)) + (setf (mref y i j) (mref x i j)))) + y)) + +(defmethod convert ((x cons) type) + ;; TODO some better way ... some more general guessing routine + ;; like guess-best-element-type + (if (consp (car x)) + (let* ((cols (length (car x))) + (rows (length x)) + (m (make-matrix-instance type (list rows cols) 0))) + (do ((xx x (cdr xx)) + (i 0 (1+ i))) + ((= i rows)) + (do ((yy (car xx) (cdr yy)) + (j 0 (1+ j))) + ((= j cols)) + (setf (mref m i j) (car yy)))) + m) + ;; else make a row vector + (convert (list x) type))) + +(defmethod mnew (type value rows &optional cols) + (make-matrix-instance type (list rows cols) value)) + +(defmacro mat (type &body args) + "Creates a matrix." + `(convert + ,(cons 'list (mapcar (lambda (x) + (cons 'list x)) + args)) + ,type)) + +(defun col (type &rest args) + "Creates a column matrix." + (convert (mapcar 'list args) type)) + +(defun row (type &rest args) + "Creates a row matrix." + (convert args type)) + +(defmacro rmat (&body args) + "Creates a matrix-dge matrix." + `(mat 'matrix-dge , at args)) + +;;; Constructors for matrix-dge + +(defun dcol (&rest args) + "Creates a matrix-dge column matrix." + (apply #'col 'matrix-dge args)) + +(defun drow (&rest args) + "Creates a matrix-dge row matrix." + (apply #'row 'matrix-dge args)) + +(defun dnew (value rows &optional (cols 1)) + "Creates a matrix-dge matrix" + (mnew 'matrix-dge value rows cols)) + +;;; Constructors for matrix-zge + +(defmacro zmat (&body args) + "Creates a matrix-dge matrix." + `(mat 'matrix-zge , at args)) + +(defun zcol (&rest args) + "Creates a matrix-zge column matrix." + (apply #'col 'matrix-zge args)) + +(defun zrow (&rest args) + "Creates a matrix-zge row matrix." + (apply #'row 'matrix-zge args)) + +(defun znew (value rows &optional (cols 1)) + "Creates a matrix-zge matrix" + (mnew 'matrix-zge value rows cols)) + + +;;; Function matrix + +(defmacro funmat (dim args &body body) + "Creates a read only function matrix" + (let ((rows2 (gensym "rows")) + (cols2 (gensym "cols")) + (i (gensym)) + (r (gensym)) + (c (gensym))) + `(let ((,rows2 (first ,dim)) + (,cols2 (second ,dim))) + (make-instance 'function-matrix + :rows ,rows2 + :cols ,cols2 + :mref (lambda (self , at args) + (declare (muffle-conditions style-warning)) + , at body) + :vref (lambda (self ,i) + ;; Default self vector reference in column major order + (multiple-value-bind (,r ,c) (floor ,i ,rows2) + (mref self ,r ,c))))))) + +(defmacro fmat (type dim args &body body) + `(convert (funmat ,dim ,args , at body) + ,type)) + + Modified: src/matrix/level2-generic.lisp ============================================================================== --- src/matrix/level2-generic.lisp (original) +++ src/matrix/level2-generic.lisp Thu May 21 05:34:44 2009 @@ -35,117 +35,6 @@ , at body)))) ,a2))) -#-todo-remove(defmethod new (class dim &optional (element-type t) (value 0)) - ;;; TODO get rid of this default that calls the new constructor - (mnew class value (car dim) (cadr dim))) - -#+todo-remove(defmethod convert (obj type) - (if (not (or (vector? obj) (matrix? obj))) - (coerce obj type) - (let ((new (new type (dim obj) (element-type obj)))) - (ecase (rank obj) - (1 (dotimes (i (size obj)) - (setf (vref new i) (vref obj i)))) - (2 (dotimes (i (rows obj)) - (dotimes (j (cols obj)) - (setf (mref new i j) (mref obj i j)))))) - new))) - -#+todo-remove(defmethod copy (a) - (typecase a - (list (copy-list a)) - (sequence (copy-seq a)) - (t (let ((b (create a))) - (dotimes (i (size a)) - (setf (vref b i) (vref a i))) - b)))) - -#-todo-remove (defmethod create (a &optional value dim) - (mcreate a value dim)) - -;; Helper function. -(defun convert-list-to-matrix (list type) - (let* ((rows (length list)) - (cols (length (car list))) - (m (make-matrix-instance type (list rows cols) 0))) - (fill-matrix-with-list m list))) - -;; Helper function. -(defun convert-matrix-to-matrix (m0 type) - (let* ((rows (rows m0)) - (cols (cols m0)) - (m (make-matrix-instance type (dim m0) 0))) - (dotimes (i rows) - (dotimes (j cols) - (setf (mref m i j) (mref m0 i j)))) - m)) - -(defmethod mcreate ((a matrix-base) &optional (value 0) dim) - (unless dim - (setf dim (dim a))) - (make-matrix-instance (class-of a) dim value)) - -(defmethod mmcreate ((a matrix-base) (b matrix-base) &optional (value 0) dim) - ;; TODO make real implmentaiton of this based on descriptions - (unless dim - (setf dim (dim a))) - (if (or (equal '(complex double-float) (element-type a)) - (equal '(complex double-float) (element-type b))) - (make-matrix-instance 'matrix-zge dim value) - (make-matrix-instance 'matrix-dge dim value))) - -;;; TODO move to dge code - -#+todo-remove(defmethod convert ((x cons) (type (eql 'matrix-dge))) - (convert-list-to-matrix x type)) - -#+todo-remove(defmethod convert ((x matrix-base) (type (eql 'matrix-dge))) - (convert-matrix-to-matrix x type)) - -#+todo-remove(defmethod mnew ((class (eql 'matrix-dge)) value rows &optional (cols 1)) - (make-matrix-instance class (list rows cols) value)) - -;;; TODO move to zge code - -#+todo-remove(defmethod convert ((x cons) (type (eql 'matrix-zge))) - (convert-list-to-matrix x type)) - -#+todo-remove(defmethod convert ((x matrix-base) (type (eql 'matrix-zge))) - (convert-matrix-to-matrix x type)) - -#+todo-remove(defmethod mnew ((class (eql 'matrix-zge)) value rows &optional (cols 1)) - (make-matrix-instance class (list rows cols) value)) - -;; Should this be specialized to subclasses of matrix-base? -;; This question also holds for other methds in this file -(defmethod convert (x type) - (print "hei") - (let ((y (make-matrix-instance type (dim x) 0))) - ;; Note that I cannot use vref, since some matrix implmentations - ;; have different ordering. - (dotimes (i (rows x)) - (dotimes (j (cols x)) - (setf (mref y i j) (mref x i j)))) - y)) - -(defmethod convert ((x cons) type) - ;; TODO some better way ... some more general guessing routine - ;; like guess-best-element-type - (if (consp (car x)) - (let* ((cols (length (car x))) - (rows (length x)) - (m (make-matrix-instance type (list rows cols) 0))) - (do ((xx x (cdr xx)) - (i 0 (1+ i))) - ((= i rows)) - (do ((yy (car xx) (cdr yy)) - (j 0 (1+ j))) - ((= j cols)) - (setf (mref m i j) (car yy)))) - m) - ;; else make a row vector - (convert (list x) type))) - (defmethod mmap (type f a &rest args) (let ((b (new type (dim a) ))) (cond ((not args) @@ -165,12 +54,6 @@ (defmethod .map (f a &rest args) (apply #'mmap (class-name (class-of a)) f a args)) - - - - - - (defmethod square-matrix? (x) (and (matrix? x) (= (rows x) (cols x)))) @@ -269,3 +152,54 @@ ;;; TRASH + + +#+todo-remove(defmethod new (class dim &optional (element-type t) (value 0)) + ;;; TODO get rid of this default that calls the new constructor + (mnew class value (car dim) (cadr dim))) + +#+todo-remove(defmethod convert (obj type) + (if (not (or (vector? obj) (matrix? obj))) + (coerce obj type) + (let ((new (new type (dim obj) (element-type obj)))) + (ecase (rank obj) + (1 (dotimes (i (size obj)) + (setf (vref new i) (vref obj i)))) + (2 (dotimes (i (rows obj)) + (dotimes (j (cols obj)) + (setf (mref new i j) (mref obj i j)))))) + new))) + +#+todo-remove(defmethod copy (a) + (typecase a + (list (copy-list a)) + (sequence (copy-seq a)) + (t (let ((b (create a))) + (dotimes (i (size a)) + (setf (vref b i) (vref a i))) + b)))) + +#+todo-remove (defmethod create (a &optional value dim) + (mcreate a value dim)) + +;;; TODO move to dge code + +#+todo-remove(defmethod convert ((x cons) (type (eql 'matrix-dge))) + (convert-list-to-matrix x type)) + +#+todo-remove(defmethod convert ((x matrix-base) (type (eql 'matrix-dge))) + (convert-matrix-to-matrix x type)) + +#+todo-remove(defmethod mnew ((class (eql 'matrix-dge)) value rows &optional (cols 1)) + (make-matrix-instance class (list rows cols) value)) + +;;; TODO move to zge code + +#+todo-remove(defmethod convert ((x cons) (type (eql 'matrix-zge))) + (convert-list-to-matrix x type)) + +#+todo-remove(defmethod convert ((x matrix-base) (type (eql 'matrix-zge))) + (convert-matrix-to-matrix x type)) + +#+todo-remove(defmethod mnew ((class (eql 'matrix-zge)) value rows &optional (cols 1)) + (make-matrix-instance class (list rows cols) value)) Modified: src/matrix/level2-matrix-dge.lisp ============================================================================== --- src/matrix/level2-matrix-dge.lisp (original) +++ src/matrix/level2-matrix-dge.lisp Thu May 21 05:34:44 2009 @@ -19,26 +19,24 @@ (in-package :lisplab) -(defmethod fill! ((a matrix-dge) value) +(defmethod fill! ((a matrix-lisp-dge) value) (let ((x (coerce value 'double-float)) (store (matrix-store a))) (fill store x))) -(defmethod copy ((matrix matrix-base-dge)) +(defmethod copy ((matrix matrix-lisp-dge)) (make-instance (class-name (class-of matrix)) :store (copy-seq (matrix-store matrix)) :rows (rows matrix) :cols (cols matrix))) -;; Maybe this should done general base on element type class? -#+todo (defmethod convert ((a blas-real) 'blas-complex) - (let* ((b (cnew 0 (rows a) (cols a))) - (store-a (store a)) - (store-b (store b))) - (declare (type type-blas-store store-a store-b)) - (dotimes (i (the type-blas-idx (size a))) - (declare (type type-blas-idx i)) - (setf (aref store-b (truly-the type-blas-idx (* i 2))) (aref store-a i))) +(defmethod .map (f (a matrix-lisp-dge) &rest args) + (let ((b (copy a))) + (apply #'map-into + (matrix-store b) + (lambda (&rest args) + (coerce (apply f args) 'double-float)) + (matrix-store a) (mapcar #'matrix-store args)) b)) (defmacro def-binary-op-matrix-lisp-dge (new old) @@ -93,12 +91,75 @@ (def-binary-op-matrix-lisp-dge .expt expt) -(defmethod .map (f (a matrix-lisp-dge) &rest args) - (let ((b (copy a))) - (apply #'map-into - (matrix-store b) - (lambda (&rest args) - (coerce (apply f args) 'double-float)) - (matrix-store a) (mapcar #'matrix-store args)) - b)) +(defmacro each-matrix-element-df-to-df (x form) + "Applies a form on each element of an matrix-dge. The form must +make real output for real arguments" + (let ((i (gensym)) + (store (gensym))) + `(let* ((,x (copy ,x)) + (,store (matrix-store ,x))) + (declare (type type-blas-store ,store)) + (dotimes (,i (length ,store)) + (let ((,x (aref ,store ,i))) + (declare (type type-blas-idx ,i) + (type double-float ,x)) + (setf (aref ,store ,i) + ,form))) + ,x))) + +(defmacro each-matrix-element-df-to-complex-df (x form) + "Applies a form on each element of an matrix-dge. The form must +make complex output for real arguments. TODO optimize? Probably no need. The +Hankel functions are slow anyway." + (let ((i (gensym)) + (a (gensym)) + (b (gensym)) + (spec-a (gensym))) + `(let* ((spec-a (find-matrix-description ,a)) + (,b (convert ,a (cons :z (cdr ,spec-a) )))) + (dotimes (,i (size ,a)) + (let ((,x (mref ,a ,i))) + (setf (mref ,b ,i) ,form))) + ,b))) + +;;; Trignometric functions + +(defmethod .sin ((x matrix-lisp-dge)) + (each-matrix-element-df-to-df x (sin x))) + +(defmethod .cos ((x matrix-lisp-dge)) + (each-matrix-element-df-to-df x (cos x))) + +(defmethod .tan ((x matrix-lisp-dge)) + (each-matrix-element-df-to-df x (tan x))) + +;;; Hyperbolic functions + +(defmethod .sinh ((x matrix-lisp-dge)) + (each-matrix-element-df-to-df x (.sinh x))) + +(defmethod .cosh ((x matrix-lisp-dge)) + (each-matrix-element-df-to-df x (.cosh x))) + +(defmethod .tanh ((x matrix-lisp-dge)) + (each-matrix-element-df-to-df x (.tanh x))) + +(defmethod .log ((x matrix-lisp-dge) &optional base) + (each-matrix-element-df-to-df x (.log x base))) + +(defmethod .exp ((x matrix-lisp-dge)) + (each-matrix-element-df-to-df x (.exp x))) + +;;; Bessel functions + +(defmethod .besj (n (x matrix-lisp-dge)) + (each-matrix-element-df-to-df x (.besj n x))) + +(defmethod .besy (n (x matrix-lisp-dge)) + (each-matrix-element-df-to-df x (.besy n x))) + +(defmethod .besi (n (x matrix-lisp-dge)) + (each-matrix-element-df-to-df x (.besi n x))) +(defmethod .besk (n (x matrix-lisp-dge)) + (each-matrix-element-df-to-df x (.besk n x))) \ No newline at end of file Modified: src/specfunc/level0-specfunc.lisp ============================================================================== --- src/specfunc/level0-specfunc.lisp (original) +++ src/specfunc/level0-specfunc.lisp Thu May 21 05:34:44 2009 @@ -20,12 +20,6 @@ (in-package :lisplab) -(defun to-df (x) - (coerce x 'double-float)) - -(defun dvec (n) - (make-array n :element-type 'double-float)) - (defmethod .besj (n (x number)) "f2cl slatec based implementation" ;; Bessel J function, for n >=0, real and complex numbers. Modified: system/lisplab.asd ============================================================================== --- system/lisplab.asd (original) +++ system/lisplab.asd Thu May 21 05:34:44 2009 @@ -23,10 +23,21 @@ (:file "level0-infpre"))) ;; + ;; Special functions + ;; + (:module :specfunc + :depends-on (:core) + :pathname "../src/specfunc/" + :serial t + :components + ( + (:file "level0-specfunc"))) + + ;; ;; All core matrix stuff (level 1 and 2) ;; (:module :matrix - :depends-on (:core) + :depends-on (:core :specfunc) :pathname "../src/matrix/" :serial t :components @@ -37,10 +48,11 @@ (:file "level1-util") (:file "level1-classes") - (:file "level1-matrix") (:file "level1-constructors") + (:file "level1-matrix") (:file "level2-interface") + (:file "level2-constructors") (:file "level2-generic") (:file "level2-array-functions") (:file "level2-matrix-dge") From jivestgarden at common-lisp.net Thu May 21 14:02:27 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Thu, 21 May 2009 10:02:27 -0400 Subject: [lisplab-cvs] r29 - src/core src/matrix Message-ID: Author: jivestgarden Date: Thu May 21 10:02:18 2009 New Revision: 29 Log: refactoring almost complete. Should now remove old code Modified: TODO src/core/level0-interface.lisp src/matrix/level1-array.lisp src/matrix/level1-constructors.lisp src/matrix/level1-interface.lisp src/matrix/level2-constructors.lisp src/matrix/level2-generic.lisp src/matrix/level2-interface.lisp src/matrix/level2-matrix-dge.lisp src/matrix/level2-matrix-zge.lisp Modified: TODO ============================================================================== --- TODO (original) +++ TODO Thu May 21 10:02:18 2009 @@ -1,4 +1,8 @@ TODO +o About arrays. Handle them by making wrappers in the matrix + hierarcy. This will be rather slow but saves work. + And in this way it is possible to avoid the non-speialized methods. +o Matrices with general element type. o Some way to just extend the exact input matrix type o Documentation. o Check if there is some non-threadsafe code in the fortran interface, Modified: src/core/level0-interface.lisp ============================================================================== --- src/core/level0-interface.lisp (original) +++ src/core/level0-interface.lisp Thu May 21 10:02:18 2009 @@ -1,6 +1,6 @@ ;;; Lisplab, level0-interface.lisp -;;; Generic function definitions that also contain -;;; non-matrix methods. +;;; Defines a basic algebra. +;;; ;;; Copyright (C) 2009 Joern Inge Vestgaarden ;;; @@ -22,6 +22,7 @@ (export '(copy convert scalar? + vector? matrix? .abs .imagpart .realpart .= ./= .< .<= .> .>= .add .add! @@ -38,6 +39,15 @@ .erf .erfc .gamma)) +(defgeneric scalar? (x) + (:documentation "A scalar is a object with ignored internal structure.")) + +(defgeneric vector? (x) + (:documentation "A vector is a object whose elements are accessible with vref.")) + +(defgeneric matrix? (x) + (:documentation "A matrix is a object whose elements are accesible with mref.")) + (defgeneric copy (a) (:documentation "Copies the elements and structure, but ignore shared state, like fill pointers etc.")) @@ -45,9 +55,6 @@ (defgeneric convert (x type) (:documentation "Generalized coerce.")) -(defgeneric scalar? (x) - (:documentation "A scalar is a object with ignored internal structure.")) - (defgeneric .abs (a) (:documentation "Generialized abs")) @@ -57,6 +64,8 @@ (defgeneric .imagpart (a) (:documentation "Generialized abs")) +;;; Binary boolean operators + (defgeneric .= (a b &optional (accuracy)) (:documentation "Element-wise test of equality, with presition.")) @@ -75,6 +84,8 @@ (defgeneric .>= (a b) (:documentation "Generalized >=." )) +;;; Binary operators + (defgeneric .add (a b) (:documentation "Addes a and b elementwise. Called by .+")) Modified: src/matrix/level1-array.lisp ============================================================================== --- src/matrix/level1-array.lisp (original) +++ src/matrix/level1-array.lisp Thu May 21 10:02:18 2009 @@ -24,41 +24,25 @@ (= (rank a) 2)) (defmethod vector? ((a array)) - "True for an array of rank 2" - (= (rank a) 1)) + "True for any array through row-major-aref" + t) -(defmethod copy ((a array)) - (if (vector? a) - (copy-seq a) - (let ((y (make-array (dim a) :element-type (element-type a)))) - (dotimes (i (size a)) - (setf (row-major-aref y i) - (row-major-aref a i))) - y))) +(defmethod dim ((a array) &optional axis) + (if axis + (array-dimension a axis) + (array-dimensions a))) -(defmethod new ((class (eql 'array)) dim &optional (element-type t) (value 0)) - (unless (consp dim) (setf dim (list dim 1))) - (make-array dim - :element-type element-type - :initial-element (convert value element-type))) +(defmethod size ((a array)) + (reduce #'* (dim a))) -(defmethod new ((class (eql 'simple-array)) dim &optional (element-type t) (value 0)) - (unless (consp dim) (setf dim (list dim 1))) - (make-array dim - :element-type element-type - :initial-element (convert value element-type))) +(defmethod rank ((a array)) + (array-rank a)) -(defmethod new ((class (eql 'vector)) dim &optional (element-type t) (value 0)) - (unless (consp dim) (setf dim (list dim 1))) - (make-array dim - :element-type element-type - :initial-element (convert value element-type))) +(defmethod rows ((a array)) + (array-dimension a 0)) -(defmethod new ((class (eql 'simple-vector)) dim &optional (element-type t) (value 0)) - (unless (consp dim) (setf dim (list dim 1))) - (make-array dim - :element-type element-type - :initial-element (convert value element-type))) +(defmethod cols ((a array)) + (array-dimension a 1)) (defmethod element-type ((a array)) "Gets the element type of the array" @@ -78,21 +62,39 @@ (defmethod (setf vref) (value (a array) idx) (setf (row-major-aref a idx) value)) -(defmethod dim ((a array) &optional axis) - (if axis - (array-dimension a axis) - (array-dimensions a))) +(defmethod make-matrix-instance ((x (eql 'array)) dim value) + (make-array dim :initial-element value)) -(defmethod vector? ((a array)) - "True for an array of rank 1" - (= (rank a) 1)) +(defmethod copy ((a array)) + ;; TODO move to level2 + (if (vectorp a) + (copy-seq a) + (let ((y (make-array (dim a) :element-type (element-type a)))) + (dotimes (i (size a)) + (setf (row-major-aref y i) + (row-major-aref a i))) + y))) -(defmethod rank ((a array)) - (array-rank a)) +#+nil (defmethod new ((class (eql 'array)) dim &optional (element-type t) (value 0)) + (unless (consp dim) (setf dim (list dim 1))) + (make-array dim + :element-type element-type + :initial-element (convert value element-type))) -(defmethod rows ((a array)) - (array-dimension a 0)) +#+nil (defmethod new ((class (eql 'simple-array)) dim &optional (element-type t) (value 0)) + (unless (consp dim) (setf dim (list dim 1))) + (make-array dim + :element-type element-type + :initial-element (convert value element-type))) -(defmethod cols ((a array)) - (array-dimension a 1)) +#+nil (defmethod new ((class (eql 'vector)) dim &optional (element-type t) (value 0)) + (unless (consp dim) (setf dim (list dim 1))) + (make-array dim + :element-type element-type + :initial-element (convert value element-type))) +#+nil (defmethod new ((class (eql 'simple-vector)) dim &optional (element-type t) (value 0)) + (unless (consp dim) (setf dim (list dim 1))) + (make-array dim + :element-type element-type + :initial-element (convert value element-type))) Modified: src/matrix/level1-constructors.lisp ============================================================================== --- src/matrix/level1-constructors.lisp (original) +++ src/matrix/level1-constructors.lisp Thu May 21 10:02:18 2009 @@ -17,6 +17,9 @@ ;;; with this program; if not, write to the Free Software Foundation, Inc., ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +;;; TODO: maybe I should store constructors rather than symbols. +;;;; Then it would be possible to use this also for arrays. + (in-package :lisplab) ;; A scheme for matrix creations @@ -46,15 +49,16 @@ (error "No matrix description of class ~A." class)) entry)) -(defun create-matrix-description (d0 &key et s i) +(defun create-matrix-description (obj &key et s i) "A simple language to modify matrix descriptions. Uses the obejct as foundation of the description, but you can override the description with the keywords." - (list - (if et et (first d0)) - (if s s (second d0)) - (if i i (third d0)))) - + (let ((d0 (find-matrix-description (class-name (class-of obj))))) + (list + (if et et (first d0)) + (if s s (second d0)) + (if i i (third d0))))) + ;;; Adding all the matrix descriptions (add-matrix-class 'matrix-base-dge :d :ge :base) Modified: src/matrix/level1-interface.lisp ============================================================================== --- src/matrix/level1-interface.lisp (original) +++ src/matrix/level1-interface.lisp Thu May 21 10:02:18 2009 @@ -21,7 +21,6 @@ (in-package :lisplab) (export '(*lisplab-print-size* - vector? matrix? make-matrix-instance ref mref vref dim element-type @@ -29,12 +28,6 @@ (defvar *lisplab-print-size* 10 "Suggested number of rows and columns printed to standard output. Not all matrices, such as ordinary lisp arrays, will care about the value.") -(defgeneric vector? (x) - (:documentation "A vector is a object whose elements are accessible with vref.")) - -(defgeneric matrix? (x) - (:documentation "A matrix is a object whose elements are accesible with mref.")) - (defgeneric make-matrix-instance (type dim value) (:documentation "Creates a new matrix instance")) Modified: src/matrix/level2-constructors.lisp ============================================================================== --- src/matrix/level2-constructors.lisp (original) +++ src/matrix/level2-constructors.lisp Thu May 21 10:02:18 2009 @@ -104,12 +104,12 @@ "Creates a row matrix." (convert args type)) -(defmacro rmat (&body args) +;;; Constructors for matrix-dge + +(defmacro dmat (&body args) "Creates a matrix-dge matrix." `(mat 'matrix-dge , at args)) -;;; Constructors for matrix-dge - (defun dcol (&rest args) "Creates a matrix-dge column matrix." (apply #'col 'matrix-dge args)) Modified: src/matrix/level2-generic.lisp ============================================================================== --- src/matrix/level2-generic.lisp (original) +++ src/matrix/level2-generic.lisp Thu May 21 10:02:18 2009 @@ -17,7 +17,10 @@ ;;; with this program; if not, write to the Free Software Foundation, Inc., ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -;;; TODO clean this up +;;; TODO clean it up. + +;;; TOOD introduce an array wrapper matrix type +;;; and spezialize these methods to matrix-base (in-package :lisplab) @@ -35,8 +38,26 @@ , at body)))) ,a2))) -(defmethod mmap (type f a &rest args) - (let ((b (new type (dim a) ))) +(defmethod copy-contents ((a matrix-base) (b matrix-base) &optional (converter #'identity)) + (dotimes (i (rows a)) + (dotimes (j (cols a)) + (setf (mref b i j) (funcall converter (mref a i j)))) + b)) + +(defmethod .some (pred (a matrix-base) &rest args) + (dotimes (i (size a)) + (when (apply pred (mapcar (lambda (x) (vref x i)) (cons a args))) + (return-from .some t)) + nil)) + +(defmethod .every (pred (a matrix-base) &rest args) + (dotimes (i (size a)) + (unless (apply pred (mapcar (lambda (x) (vref x i)) (cons a args))) + (return-from .every nil)) + t)) + +(defmethod mmap (type f (a matrix-base) &rest args) + (let ((b (make-matrix-instance type (dim a) 0))) (cond ((not args) (dotimes (i (size a)) (setf (vref b i) (funcall f (vref a i))))) @@ -51,69 +72,67 @@ args)))))) b)) -(defmethod .map (f a &rest args) +(defmethod .map (f (a matrix-base) &rest args) (apply #'mmap (class-name (class-of a)) f a args)) -(defmethod square-matrix? (x) - (and (matrix? x) (= (rows x) (cols x)))) +(defmethod square-matrix? ((x matrix-base)) + (= (rows x) (cols x))) -(defmethod diag (v) +#+todo-remove (defmethod diag (v) (let* ((n (size v)) - (a (create v 0 (list n n)))) + (a (mcreate v 0 (list n n)))) (dotimes (i n) (setf (mref a i i) (vref v i))) a)) -(defmethod msum (m) +(defmethod msum ((m matrix-base)) "Sums all elements of m." (let ((sum 0)) (dotimes (i (size m)) - (incf sum (vref m i))) + (setf sum (.+ sum (vref m i)))) sum)) -(defmethod mmax (m) +(defmethod mmax ((m matrix-base)) "Retuns the maximum element of m." (let ((max (vref m 0))) (dotimes (i (size m)) - (when (> (vref m i) max) + (when (.> (vref m i) max) (setf max (vref m i)))) max)) -(defmethod mmin (m) +(defmethod mmin ((m matrix-base)) "Retuns the minimum element of m." (let ((min (vref m 0))) (dotimes (i (size m)) - (when (< (vref m i) min) + (when (.< (vref m i) min) (setf min (vref m i)))) min)) -(defmethod mabsmax (m) +(defmethod mabsmax ((m matrix-base)) "Retuns the element of m with highes absolute value." (let ((max (vref m 0))) (dotimes (i (size m)) - (when (> (abs (vref m i)) (abs max)) + (when (.> (abs (vref m i)) (abs max)) (setf max (vref m i)))) max)) -(defmethod mabsmin (m) +(defmethod mabsmin ((m matrix-base)) "Retuns the element of m with smallest absolute value." (let ((min (vref m 0))) (dotimes (i (size m)) - (when (< (abs (vref m i)) (abs min)) + (when (.< (abs (vref m i)) (abs min)) (setf min (vref m i)))) min)) -(defmethod fill! (a val) +(defmethod fill! ((a matrix-base) val) "Sets all elemnts of a to val." (dotimes (i (size a)) (setf (vref a i) val)) val) - - -(defmethod circ-shift (A shift) +(defmethod circ-shift ((A matrix-base) shift) ;; TODO move to level3 - (let ((B (create A)) + (let ((B (mcreate A)) (rows (rows A)) (cols (cols A)) (dr (first shift)) @@ -124,9 +143,9 @@ (mref A i j)))) B)) -(defmethod pad-shift (A shift &optional (value 0)) +(defmethod pad-shift ((A matrix-base) shift &optional (value 0)) ;; TODO move to level3 - (let ((B (create A value)) + (let ((B (mcreate A value)) (rows (rows A)) (cols (cols A)) (dr (first shift)) @@ -137,19 +156,73 @@ (mref A (- i dr) (- j dc))))) B)) -(defmethod reshape (a shape) - (let ((B (create a 0 shape))) +(defmethod reshape ((a matrix-base) shape) + (let ((B (mcreate a 0 shape))) (dotimes (i (size B)) (setf (vref B i) (vref A i))) B)) -(defmethod to-vector (a) +(defmethod to-vector ((a matrix-base)) (reshape a (list (size a) 1))) -(defmethod to-matrix (a rows) +(defmethod to-matrix ((a matrix-base) rows) (reshape a (list rows (/ (size a) rows) 1))) +;;;; Basic boolean operators + + +;;;; The boolean operators + +(defmethod .= ((a matrix-base) (b matrix-base) &optional acc) + (if acc + (.every (lambda (a b) (.= a b acc)) a b) + (.every #'.= a b))) + +(defmethod .= ((a matrix-base) (b number) &optional acc) + (if acc + (.every (lambda (a) (.= a b acc)) a) + (.every (lambda (a) (.= a b)) a))) + +(defmethod .= ((a number) (b matrix-base) &optional acc) + (if acc + (.every (lambda (b) (.= a b acc)) b) + (.every (lambda (b) (.= a b)) b))) + +(defmethod ./= ((a matrix-base) (b matrix-base) &optional acc) + (not (.= a b acc))) + +(defmethod ./= ((a matrix-base) (b number) &optional acc) + (not (.= a b acc))) + +(defmethod ./= ((a number) (b matrix-base) &optional acc) + (not (.= a b acc))) + +(defmacro def-matrix-base-boolean-operator (op) + (let ((a (gensym)) + (b (gensym))) + `(progn + (defmethod ,op ((,a matrix-base) (,b matrix-base)) + (.every #',op ,a ,b)) + (defmethod ,op ((,a matrix-base) (,b number)) + (.every (lambda (,a) (,op ,a ,b)) ,a)) + (defmethod ,op ((,a number) (,b matrix-base)) + (.every (lambda (,b) (,op ,a ,b)) ,b))))) + +(def-matrix-base-boolean-operator .<) + +(def-matrix-base-boolean-operator .<=) + +(def-matrix-base-boolean-operator .>) + +(def-matrix-base-boolean-operator .>=) + + + + + + + ;;; TRASH Modified: src/matrix/level2-interface.lisp ============================================================================== --- src/matrix/level2-interface.lisp (original) +++ src/matrix/level2-interface.lisp Thu May 21 10:02:18 2009 @@ -19,10 +19,15 @@ (in-package :lisplab) -(export '( +;;; TODO sort and possibly move to other levels + +(export '( + .every .some ; to level0 ? + + square-matrix? new mnew create mcreate - square-matrix? + copy-contents diag .map mmap fill! dlmwrite dlmread @@ -40,6 +45,14 @@ circ-shift pad-shift)) +(defgeneric .some (pred a &rest matrices) + (:documentation "Generalizes some")) + +(defgeneric .every (pred a &rest matrices) + (:documentation "Generalizes every.")) + +(defgeneric copy-contents (a b &optional converter) + (:documentation "Copies all elements from a to b.")) (defgeneric new (class dim &optional element-type value) (:documentation "Deprecated. Use mnew in stead. Creates a new matrix filled with numeric arguments.")) Modified: src/matrix/level2-matrix-dge.lisp ============================================================================== --- src/matrix/level2-matrix-dge.lisp (original) +++ src/matrix/level2-matrix-dge.lisp Thu May 21 10:02:18 2009 @@ -39,6 +39,25 @@ (matrix-store a) (mapcar #'matrix-store args)) b)) +(defmethod .imagpart ((a matrix-lisp-dge)) + (mcreate a 0)) + +(defmethod .realpart ((a matrix-lisp-dge)) + (copy a)) + +(defmethod .abs ((a matrix-lisp-dge)) + (let ((b (mcreate a))) + (copy-contents a b #'abs) + b)) + +(defmethod .some (pred (a matrix-lisp-dge) &rest args) + (let ((stores (mapcar #'matrix-store (cons a args)))) + (apply #'some pred stores))) + +(defmethod .every (pred (a matrix-lisp-dge) &rest args) + (let ((stores (mapcar #'matrix-store (cons a args)))) + (apply #'every pred stores))) + (defmacro def-binary-op-matrix-lisp-dge (new old) (let ((a (gensym "a")) (b (gensym "b")) Modified: src/matrix/level2-matrix-zge.lisp ============================================================================== --- src/matrix/level2-matrix-zge.lisp (original) +++ src/matrix/level2-matrix-zge.lisp Thu May 21 10:02:18 2009 @@ -33,6 +33,28 @@ :rows (rows matrix) :cols (cols matrix))) +(defmethod .imagpart ((a matrix-lisp-zge)) + (let* ((description (create-matrix-description a :et :d)) + (b (make-matrix-instance description (dim a) 0))) + (copy-contents a b #'imagpart) + b)) + +(defmethod .realpart ((a matrix-lisp-zge)) + (let* ((description (create-matrix-description a :et :d)) + (b (make-matrix-instance description (dim a) 0))) + (copy-contents a b #'realpart) + b)) + +(defmethod .abs ((a matrix-lisp-zge)) + (let* ((description (create-matrix-description a :et :d)) + (b (make-matrix-instance description (dim a) 0))) + (copy-contents a b #'abs) + b)) + + + + + (defmacro def-binary-op-blas-complex (new old) ;;; TODO speed up for real numbers (let ((a (gensym "a")) From jivestgarden at common-lisp.net Thu May 21 14:18:39 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Thu, 21 May 2009 10:18:39 -0400 Subject: [lisplab-cvs] r30 - src/matrix Message-ID: Author: jivestgarden Date: Thu May 21 10:18:38 2009 New Revision: 30 Log: Cleaned up further Modified: src/matrix/level2-constructors.lisp src/matrix/level2-generic.lisp src/matrix/level2-interface.lisp Modified: src/matrix/level2-constructors.lisp ============================================================================== --- src/matrix/level2-constructors.lisp (original) +++ src/matrix/level2-constructors.lisp Thu May 21 10:18:38 2009 @@ -25,23 +25,6 @@ dmat dnew dcol drow zmat znew zcol zrow)) -;; Helper function. -(defun convert-list-to-matrix (list type) - (let* ((rows (length list)) - (cols (length (car list))) - (m (make-matrix-instance type (list rows cols) 0))) - (fill-matrix-with-list m list))) - -;; Helper function. -(defun convert-matrix-to-matrix (m0 type) - (let* ((rows (rows m0)) - (cols (cols m0)) - (m (make-matrix-instance type (dim m0) 0))) - (dotimes (i rows) - (dotimes (j cols) - (setf (mref m i j) (mref m0 i j)))) - m)) - (defmethod mcreate ((a matrix-base) &optional (value 0) dim) (unless dim (setf dim (dim a))) @@ -56,31 +39,20 @@ (make-matrix-instance 'matrix-zge dim value) (make-matrix-instance 'matrix-dge dim value))) -;; Should this be specialized to subclasses of matrix-base? -;; This question also holds for other methds in this file -(defmethod convert (x type) +(defmethod convert ((x matrix-base) type) (let ((y (make-matrix-instance type (dim x) 0))) - ;; Note that I cannot use vref, since some matrix implmentations - ;; have different ordering. - (dotimes (i (rows x)) - (dotimes (j (cols x)) - (setf (mref y i j) (mref x i j)))) + (copy-contents x y) y)) (defmethod convert ((x cons) type) + ;; Should it be moved to some other file? ;; TODO some better way ... some more general guessing routine ;; like guess-best-element-type (if (consp (car x)) (let* ((cols (length (car x))) (rows (length x)) (m (make-matrix-instance type (list rows cols) 0))) - (do ((xx x (cdr xx)) - (i 0 (1+ i))) - ((= i rows)) - (do ((yy (car xx) (cdr yy)) - (j 0 (1+ j))) - ((= j cols)) - (setf (mref m i j) (car yy)))) + (fill-matrix-with-list m x) m) ;; else make a row vector (convert (list x) type))) Modified: src/matrix/level2-generic.lisp ============================================================================== --- src/matrix/level2-generic.lisp (original) +++ src/matrix/level2-generic.lisp Thu May 21 10:18:38 2009 @@ -24,6 +24,27 @@ (in-package :lisplab) +;; Helper function. +#+nil (defun convert-list-to-matrix (list type) + (let* ((rows (length list)) + (cols (length (car list))) + (m (make-matrix-instance type (list rows cols) 0))) + (fill-matrix-with-list m list))) + +;; Helper function. +#+nil (defun convert-matrix-to-matrix (m0 type) + (let* ((rows (rows m0)) + (cols (cols m0)) + (m (make-matrix-instance type (dim m0) 0))) + (dotimes (i rows) + (dotimes (j cols) + (setf (mref m i j) (mref m0 i j)))) + m)) + +(defmethod square-matrix? ((x matrix-base)) + (= (rows x) (cols x))) + + ;;; This is OK, but could be optimzied! (defmacro w/mat (a args &body body) (let ((a2 (gensym)) @@ -75,9 +96,6 @@ (defmethod .map (f (a matrix-base) &rest args) (apply #'mmap (class-name (class-of a)) f a args)) -(defmethod square-matrix? ((x matrix-base)) - (= (rows x) (cols x))) - #+todo-remove (defmethod diag (v) (let* ((n (size v)) (a (mcreate v 0 (list n n)))) Modified: src/matrix/level2-interface.lisp ============================================================================== --- src/matrix/level2-interface.lisp (original) +++ src/matrix/level2-interface.lisp Thu May 21 10:18:38 2009 @@ -22,13 +22,14 @@ ;;; TODO sort and possibly move to other levels (export '( - .every .some ; to level0 ? - + .every .some ; to level0 ? square-matrix? - new mnew - create mcreate + ; new + mnew + ; create + mcreate copy-contents - diag + ; diag .map mmap fill! dlmwrite dlmread to-vector! to-vector From jivestgarden at common-lisp.net Thu May 21 15:21:26 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Thu, 21 May 2009 11:21:26 -0400 Subject: [lisplab-cvs] r31 - src/fft src/matrix system Message-ID: Author: jivestgarden Date: Thu May 21 11:21:25 2009 New Revision: 31 Log: removed unused old matrix types Removed: src/fft/level3-fft-generic.lisp src/matrix/level1-blas-complex.lisp src/matrix/level1-blas-real.lisp src/matrix/level1-blas.lisp src/matrix/level1-list.lisp src/matrix/level2-blas-complex.lisp src/matrix/level2-blas-real.lisp src/matrix/level2-blas.lisp Modified: system/lisplab.asd Modified: system/lisplab.asd ============================================================================== --- system/lisplab.asd (original) +++ system/lisplab.asd Thu May 21 11:21:25 2009 @@ -43,43 +43,18 @@ :components ( (:file "level1-interface") - - (:file "level1-array") - (:file "level1-util") (:file "level1-classes") (:file "level1-constructors") (:file "level1-matrix") + (:file "level1-array") (:file "level2-interface") (:file "level2-constructors") (:file "level2-generic") - (:file "level2-array-functions") (:file "level2-matrix-dge") (:file "level2-matrix-zge") - - - -; (:file "level1-interface") -; (:file "level1-util") -; (:file "level1-generic") -; (:file "level1-array") -; (:file "level1-list") - - -; (:file "level1-blas") -; (:file "level1-blas-real") -; (:file "level1-blas-complex") -; (:file "level1-funmat") - -; (:file "level2-interface") -; (:file "level2-array-functions") -; (:file "level2-generic") -; (:file "level2-funmat") -; (:file "level2-blas") -; (:file "level2-blas-real") -; (:file "level2-blas-complex") - )) + (:file "level2-array-functions"))) ;; ;; Linear algebra interface(Level 3) @@ -114,7 +89,6 @@ :components ( (:file "level3-fft-interface") - #+nil (:file "level3-fft-generic") (:file "level3-fft-blas"))) ;; From jivestgarden at common-lisp.net Thu May 21 19:14:55 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Thu, 21 May 2009 15:14:55 -0400 Subject: [lisplab-cvs] r33 - Message-ID: Author: jivestgarden Date: Thu May 21 15:14:54 2009 New Revision: 33 Log: Updated the exampes Modified: example.lisp Modified: example.lisp ============================================================================== --- example.lisp (original) +++ example.lisp Thu May 21 15:14:54 2009 @@ -5,33 +5,40 @@ ;;; 19 ways to create a matrix (defparameter *test-matrices* (list + ;; Blank matrices + + (mnew 'matrix-dge 0 3 5) + ; same as + (dnew 0 3 5) + ; same as + (mnew '(:d :ge :any) 0 3 5) + + (mnew 'matrix-zge 0 3 5) + ; same as + (znew 0 3 5) + ; same as + (mnew '(:z :ge :any) 0 3 5) + + (drow 2 4 2) + (dcol 2 3 1) + (zrow 2 %i 1) + (zcol 2 %i 1) ;; Setting of individual elements - #2a((1 4) (-2 3)) - (rmat (0 4 -2) (1 3 -5) (-2 4 0)) - (cmat (0 #C(0 2) -2) (1 3 -5) (-2 %i 0)) - (funmat 4 4 (i j) (if (= i j) 1 0)) - (rrow 2 4 2) - (rcol 2 3 1) - (crow 2 %i 1) - (ccol 2 %i 1) + (dmat (0 4 -2) (1 3 -5) (-2 4 0)) + (zmat (0 #C(0 2) -2) (1 3 -5) (-2 %i 0)) ;; Setting of structure - (make-array '(3 4) :element-type 'double-float) - (rnew 1 3 5) - - ; (cnew %i 2 5) - (new 'array '(3 5) t 4) - (new 'blas-real '(3 5) t 4) - (new 'blas-complex '(3 5) t 4) + (funmat '(4 4) (i j) (if (= i j) 1 0)) + (fmat 'matrix-dge '(3 4) (i j) (if (< i j) 1 0.5)) ;; From another matrix - (copy #2a((1 4) (-2 3))) - (create #2a((1 4) (-2 3))) - (convert '((3 2 4) (1 4 2)) 'array) - (convert (funmat 3 3 (i j) (random 1.0)) 'blas-real) - (mmap 'blas-real #'random (rnew 1 3 3)) - (.+ 3 (rmat (2 3) (-2 9))))) + (copy (dmat (1 4) (-2 3))) + (mcreate (dmat (1 4) (-2 3))) + (convert '((3 2 4) (1 4 2)) 'matrix-dge) + (convert (funmat '(3 3) (i j) (random 1.0)) 'matrix-dge) + (mmap '(:z :ge :any) #'random (mnew '(:d :ge :any) 1 3 3)) + (.+ 3 (dmat (2 3) (-2 9))))) (mapcar (lambda (x) (mref x 0 0)) *test-matrices*) @@ -39,19 +46,17 @@ ;; Arithmetics -(let ((a (rmat (0 4 -2) (1 3 -5) (-2 4 0))) - (b (cmat (0 #C(0 2) -2) (1 3 -5) (-2 %i 0)))) +(let ((a (dmat (0 4 -2) (1 3 -5) (-2 4 0))) + (b (zmat (0 #C(0 2) -2) (1 3 -5) (-2 %i 0)))) (.+ (.* 3 a) b)) ;; Infix arithmetics -(let ((a (rmat (0 4 -2) (1 3 -5) (-2 4 0))) - (b (cmat (0 #C(0 2) -2) (1 3 -5) (-2 %i 0)))) +(let ((a (dmat (0 4 -2) (1 3 -5) (-2 4 0))) + (b (zmat (0 #C(0 2) -2) (1 3 -5) (-2 %i 0)))) (w/infix 3 .* a .+ b)) ;; Matrix inversion -(minv #2a((0 4 -2) (1 3 -5) (-2 4 0))) - -(minv (rmat (0 4 -2) (1 3 -5) (-2 4 0))) +(minv (dmat (0 4 -2) (1 3 -5) (-2 4 0))) From jivestgarden at common-lisp.net Thu May 21 19:40:40 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Thu, 21 May 2009 15:40:40 -0400 Subject: [lisplab-cvs] r34 - in src: core matrix test Message-ID: Author: jivestgarden Date: Thu May 21 15:40:40 2009 New Revision: 34 Log: added some more tests and some more exports Modified: src/core/level0-const.lisp src/matrix/level1-classes.lisp src/test/lisplab-test.lisp Modified: src/core/level0-const.lisp ============================================================================== --- src/core/level0-const.lisp (original) +++ src/core/level0-const.lisp Thu May 21 15:40:40 2009 @@ -19,12 +19,15 @@ (in-package :lisplab) +(export '(%i %e -%i)) + ;;; Float and complex constants (define-constant %e (exp 1.0)) (define-constant %i #C(0.0 1.0)) (define-constant -%i #C(0.0 -1.0)) ;;; Type constants +;;; TODO: throw them out or use deftype in stead (define-constant %df 'double-float) (define-constant %cdf '(complex double-float)) (define-constant %sb32 '(signed-byte 32)) @@ -32,7 +35,9 @@ -;;;; Constants from gsl +;;;; Constants from gsl. + +;;; TODO: throw them out (define-constant +lisplab-dbl-epsilon+ 2.2204460492503131e-16) (define-constant +lisplab-sqrt-dbl-epsilon+ 1.4901161193847656e-08) Modified: src/matrix/level1-classes.lisp ============================================================================== --- src/matrix/level1-classes.lisp (original) +++ src/matrix/level1-classes.lisp Thu May 21 15:40:40 2009 @@ -23,6 +23,13 @@ (in-package :lisplab) +(export '(matrix-base + matrix-dge + matrix-zge + function-matrix + ;; Do we need the others? + )) + (defclass matrix-base () ()) ;;; The matrix element tells the element type of the matrix Modified: src/test/lisplab-test.lisp ============================================================================== --- src/test/lisplab-test.lisp (original) +++ src/test/lisplab-test.lisp Thu May 21 15:40:40 2009 @@ -1,102 +1,36 @@ -(defpackage "LISPLAB.TEST" +#+nil (defpackage "LISPLAB.TEST" (:use "COMMON-LISP" "ORG.ANCAR.CLUNIT")) -(in-package :lisplab.test) +(in-package :org.ancar.CLUnit) -(defparameter *a22* #2a((1 4) (1 -2))) -(defparameter *a33* #2a((1 4 7) (3 4 2) (1 -2 -8))) +#+nil (in-package :lisplab.test) -(defparameter *r22* (ll:rmat (1 4) (1 -2))) -(defparameter *r33* (ll:rmat (1 4 7) (3 4 2) (1 -2 -8))) - -(defparameter *c22* (ll:cmat (1 4) (1 -2))) -(defparameter *c33* (ll:cmat (1 4 7) (3 4 2) (1 -2 -8))) - -(deftest "level0 .=" - :test-fn (lambda () - (ll:.= 0 0) - (ll:.= 42 42.0) - (ll:.= 'x 'x))) - -(deftest "level0 .+" - :test-fn (lambda () - (= 4 (ll:.+ 0 4)) - (= 7 (ll:.+ 3 4)) - (= 0.5 (ll:.+ 1 -0.25 -0.25)) - (= 10.3 (ll:.+ 6.3 4)) - (= 3/4 (ll:.+ 1/2 1/4)) - )) - -(deftest "level0 .-" - :test-fn (lambda () - (= -4 (ll:.- 0 4)) - (= -1 (ll:.- 3 4)) - (= 1.5 (ll:.- 1 -0.25 -0.25)) - (= 2.3 (ll:.- 6.3 4)) - (= 1/4 (ll:.- 1/2 1/4)) - )) - -(deftest "level0 .*" +(deftest "level1-dge-new" :test-fn (lambda () - (= 0 (ll:.* 0 4)) - (= 12 (ll:.* 3 4)) - (= 1.5 (ll:.* 1 -0.25 -6)) - (= 26 (ll:.* 6.5 4)) - (= 12/10 (ll:.* 4/5 3/2)) - )) + (and + (equalp (ll:dim (ll:mnew 'll:matrix-dge 0 3 7)) '(3 7)) + (equalp (ll:dim (ll:mnew '(:d :ge :any) 0 3 7)) '(3 7)) + (equalp (ll:dim (ll:dnew 0 3 7)) '(3 7))))) -(deftest "level0 ./" +(deftest "level1-zge-new" :test-fn (lambda () - (= 0 (ll:./ 0 4)) - (= 3/4 (ll:./ 3 4)) - (= 1.5 (ll:./ 1 -0.25 -6)) - (= 26 (ll:./ 6.5 4)) - (= 8/15 (ll:./ 4/5 3/2)) - )) + (and + (equalp (ll:dim (ll:mnew 'll:matrix-zge 0 3 7)) '(3 7)) + (equalp (ll:dim (ll:mnew '(:z :ge :any) 0 3 7)) '(3 7)) + (equalp (ll:dim (ll:znew 0 3 7)) '(3 7)) ))) -(deftest "level0 .^" +(deftest "level1-dge-mref" :test-fn (lambda () - (= 1 (ll:.^ 7 0)) - (= 64 (ll:.^ 4 3)) - (= 15.620749173070115 (ll:.^ 2.3 3.3)) - (= 9/49 (ll:.^ 3/7 2)) - )) + (let ((A (ll:dnew 42 3 7))) + (setf (ll:mref A 2 2) 7) + (and (= 42 (ll:mref A 0 1)) + (= 7 (ll:mref A 2 2)))))) -(deftest "level1 blas-real" +(deftest "level1-zge-mref" :test-fn (lambda () - (let ((x1 (ll:rnew 1 3 4)) - (x2 (ll:rmat (4 3) (-1 4))) - (c1 (ll:rrow 2 7 8)) - (c2 (ll:rcol 3 2 4))) - (and (= 1 (ll:vref x1 1)) - (= -1 (ll:vref x2 1)) ; row major order - (= 8 (ll:mref c1 0 2)) - (= 4 (ll:mref c2 2 0)) - (= 3 (ll:mref x2 0 1)))))) - -(deftest "level1 blas-complex" - :test-fn (lambda () - (let ((x1 (ll:cnew 1 3 4)) - (x2 (ll:cmat (4 3) (-1 4))) - (c1 (ll:crow 2 7 8)) - (c2 (ll:ccol 3 2 4))) - (and (= 1 (ll:vref x1 1)) - (= -1 (ll:vref x2 1)) ; row major order - (= 8 (ll:mref c1 0 2)) - (= 4 (ll:mref c2 2 0)) - (= 3 (ll:mref x2 0 1)))))) - -(deftest "level1 array" - :test-fn (lambda () - (let ((x2 #2a((4 3) (-1 4))) - (c1 #a(2 7 8))) - (and (= 1 (ll:vref x1 1)) - (= -1 (ll:vref x2 1)) ; row major order - (= 8 (ll:mref c1 0 2)) - (= 4 (ll:mref c2 2 0)) - (= 3 (ll:mref x2 0 1)))))) - - - + (let ((A (ll:znew ll:%i 3 7))) + (setf (ll:mref A 2 2) 7) + (and (= ll:%i (ll:mref A 0 1)) + (= 7 (ll:mref A 2 2)))))) \ No newline at end of file From jivestgarden at common-lisp.net Fri May 22 09:02:11 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Fri, 22 May 2009 05:02:11 -0400 Subject: [lisplab-cvs] r35 - in src: fft matrix Message-ID: Author: jivestgarden Date: Fri May 22 05:02:08 2009 New Revision: 35 Log: optimized and cleaned up Modified: src/fft/level3-fft-blas.lisp src/fft/level3-fft-interface.lisp src/matrix/level1-classes.lisp src/matrix/level1-interface.lisp src/matrix/level1-matrix.lisp src/matrix/level1-util.lisp src/matrix/level2-matrix-dge.lisp src/matrix/level2-matrix-zge.lisp Modified: src/fft/level3-fft-blas.lisp ============================================================================== --- src/fft/level3-fft-blas.lisp (original) +++ src/fft/level3-fft-blas.lisp Fri May 22 05:02:08 2009 @@ -92,19 +92,20 @@ (complex double-float)) (setf ref-blas-complex-store2))) -(declaim (inline ref-blas-complex-store2 (setf ref-blas-complex-store))) +(declaim (inline ref-blas-complex-store2 (setf ref-blas-complex-store2))) (defun ref-blas-complex-store2 (store i start step) "Accessor for the complex blas store" (declare (type-blas-idx i start step) (type-blas-store store)) - (let ((idx (truly-the type-blas-idx - (* 2 (+ - (truly-the type-blas-idx (* step i)) - start))))) - (declare (type-blas-idx idx)) - (complex (aref store idx) - (aref store (1+ idx))))) + (let* ((idx (truly-the type-blas-idx + (* 2 (+ (truly-the type-blas-idx (* step i)) + start)))) + (val (complex (aref store idx) + (aref store (1+ idx))))) + (declare (type type-blas-idx idx) + (type (complex double-float) val)) + val)) (defun (setf ref-blas-complex-store2) (value store i start step) (declare (type-blas-idx i start step) @@ -136,10 +137,10 @@ (let* ((dual (expt 2 bit)) (W #C(1.0 0.0)) (tmp (- (exp (/ (* sign %i pi) dual)) 1.0 ))) - (declare (type-blas-idx dual) - ((integer 0 30) bit) - ((complex double-float) W tmp)) - (loop for b from 0 to (- n 1) by (* 2 dual) do + (declare (type type-blas-idx dual) + (type (integer 0 30) bit) + (type (complex double-float) W tmp)) + (loop for b from 0 below n by (* 2 dual) do (let* ((wd (ref-blas-complex-store2 ftx (truly-the type-blas-idx (+ b dual)) start step))) (declare (type-blas-idx b) ((complex double-float) Wd)) @@ -162,8 +163,6 @@ wd)))))) ftx)) - - (defun bit-reverse-blas-complex-store! (vec n start step) ;; This is the Goldrader bit-reversal algorithm (let ((j 0)) @@ -177,8 +176,29 @@ (setf (ref-blas-complex-store2 vec i start step) (ref-blas-complex-store2 vec j start step) (ref-blas-complex-store2 vec j start step) tmp))) (do () ((> k j)) - (setf j (the fixnum (- j k)) + (setf j (the type-blas-idx (- j k)) k (floor k 2))) (incf j k)))) vec) +(defmethod fft-shift ((k matrix-base)) + "Only for 2D. TODO 1d." + (let ((out (copy k)) + (r/2 (/ (rows k) 2)) + (c/2 (/ (cols k) 2))) + (dotimes (i (rows k)) + (dotimes (j (cols k)) + (setf (mref out i j) + (cond ((and (< i r/2) (< j c/2)) + (mref k (+ i r/2) (+ j c/2))) + ((and (< i r/2) (>= j c/2)) + (mref k (+ i r/2) (- j c/2))) + ((and (>= i r/2) (< j c/2)) + (mref k (- i r/2) (+ j c/2))) + (t + (mref k (- i r/2) (- j c/2))))))) + out)) + +(defmethod ifft-shift ((k matrix-base)) + "Currently the same as fft-shift since only grids with power 2 sized grids are allowed." + (fft-shift k)) \ No newline at end of file Modified: src/fft/level3-fft-interface.lisp ============================================================================== --- src/fft/level3-fft-interface.lisp (original) +++ src/fft/level3-fft-interface.lisp Fri May 22 05:02:08 2009 @@ -49,7 +49,7 @@ (:documentation "Inverse fast fourier transform on all rows and columns. Destructive")) (defgeneric fft-shift (x) - (:documentation "Resucturing of Brillouin zones")) + (:documentation "Restructuring of Brillouin zones")) (defgeneric ifft-shift (x) - (:documentation "Resucturing of Brillouin zones")) + (:documentation "Inverse restructuring of Brillouin zones")) Modified: src/matrix/level1-classes.lisp ============================================================================== --- src/matrix/level1-classes.lisp (original) +++ src/matrix/level1-classes.lisp Fri May 22 05:02:08 2009 @@ -30,6 +30,8 @@ ;; Do we need the others? )) +(declaim (inline matrix-store)) + (defclass matrix-base () ()) ;;; The matrix element tells the element type of the matrix @@ -69,14 +71,12 @@ :initarg :rows :initform 0 :reader rows - :type type-blas-idx - :documentation "Number of rows in the matrix") + :type type-blas-idx) (cols :initarg :cols :initform 0 :reader cols - :type type-blas-idx - :documentation "Number of columns in the matrix") + :type type-blas-idx) (size :reader size :type type-blas-idx))) Modified: src/matrix/level1-interface.lisp ============================================================================== --- src/matrix/level1-interface.lisp (original) +++ src/matrix/level1-interface.lisp Fri May 22 05:02:08 2009 @@ -68,7 +68,7 @@ (defgeneric (setf rank) (value matrix)) (defgeneric rows (matrix) - (:documentation "The number of columns, ie (dim 0).")) + (:documentation "The number of rows, ie (dim 0).")) (defgeneric (setf rows) (value matrix)) Modified: src/matrix/level1-matrix.lisp ============================================================================== --- src/matrix/level1-matrix.lisp (original) +++ src/matrix/level1-matrix.lisp Fri May 22 05:02:08 2009 @@ -66,47 +66,47 @@ ;;; Spcialized for blas-dge (defmethod mref ((matrix matrix-base-dge) row col) - (aref (the type-blas-store (matrix-store matrix)) - (truly-the type-blas-idx (column-major-idx (truly-the type-blas-idx row) - (truly-the type-blas-idx col) - (rows matrix))))) - -(defmethod (setf mref) (value (matrix matrix-base-dge) row col) - (setf (aref (the type-blas-store (matrix-store matrix)) - (column-major-idx (truly-the type-blas-idx row) - (truly-the type-blas-idx col) - (rows matrix))) - (truly-the double-float (coerce value 'double-float)))) + (ref-blas-real-store (matrix-store matrix) row col (rows matrix))) + +(defmethod (setf mref) (value (matrix matrix-base-dge) row col) + (let ((val2 (coerce value 'double-float))) + (declare (type double-float val2)) + (setf (ref-blas-real-store (matrix-store matrix) row col (rows matrix)) + val2) + val2)) (defmethod vref ((matrix matrix-base-dge) idx) (aref (the type-blas-store (matrix-store matrix)) idx)) (defmethod (setf vref) (value (matrix matrix-base-dge) idx) - (setf (aref (the type-blas-store (matrix-store matrix)) idx) - (the double-float (coerce value 'double-float)))) - + (let ((val2 (coerce value 'double-float))) + (declare (type double-float val2)) + (setf (aref (the type-blas-store (matrix-store matrix)) idx) + val2) + val2)) ;;; Spcialized for blas-zge (defmethod mref ((matrix matrix-base-zge) row col) - (ref-blas-complex-store (matrix-store matrix) - (column-major-idx row col (rows matrix)) - 0 1)) + (ref-blas-complex-store (matrix-store matrix) + row col (rows matrix))) (defmethod (setf mref) (value (matrix matrix-base-zge) row col) - (setf (ref-blas-complex-store (matrix-store matrix) - (column-major-idx row col (rows matrix)) - 0 1) - (coerce value '(complex double-float))) - value) + (let ((val2 (coerce value '(complex double-float)))) + (declare (type (complex double-float) val2)) + (setf (ref-blas-complex-store (matrix-store matrix) row col (rows matrix)) + val2) + val2)) (defmethod vref ((matrix matrix-base-zge) i) (ref-blas-complex-store (matrix-store matrix) i 0 1)) (defmethod (setf vref) (value (matrix matrix-base-zge) i) - (setf (ref-blas-complex-store (matrix-store matrix) i 0 1) - (coerce value '(complex double-float))) - value) + (let ((val2 (coerce value '(complex double-float)))) + (declare (type (complex double-float) val2)) + (setf (ref-blas-complex-store (matrix-store matrix) i 0 1) + val2) + val2)) ;;; Function matrix Modified: src/matrix/level1-util.lisp ============================================================================== --- src/matrix/level1-util.lisp (original) +++ src/matrix/level1-util.lisp Fri May 22 05:02:08 2009 @@ -38,6 +38,10 @@ (deftype type-blas-idx () '(MOD 536870911)) +(declaim (inline column-major-idx)) +(declaim (inline ref-blas-real-store (setf ref-blas-real-store))) +(declaim (inline ref-blas-complex-store (setf ref-blas-complex-store))) + (declaim (ftype (function (type-blas-idx type-blas-idx @@ -45,10 +49,6 @@ type-blas-idx) column-major-idx)) -(declaim (inline column-major-idx)) -(defun column-major-idx (i j rows) - (truly-the type-blas-idx (+ i (truly-the type-blas-idx (* j rows))))) - (declaim (ftype (function (type-blas-store type-blas-idx @@ -66,8 +66,26 @@ ) double-float) (setf ref-blas-real-store))) +(declaim (ftype (function + (type-blas-store + type-blas-idx + type-blas-idx + type-blas-idx) + (complex double-float)) + ref-blas-complex-store)) -(declaim (inline ref-blas-real-store (setf ref-blas-real-store))) +(declaim (ftype (function + ((complex double-float) + type-blas-store + type-blas-idx + type-blas-idx + type-blas-idx + ) + (complex double-float)) + (setf ref-blas-complex-store))) + +(defun column-major-idx (i j rows) + (truly-the type-blas-idx (+ i (truly-the type-blas-idx (* j rows))))) (defun ref-blas-real-store (store row col rows) "Accessor for the real blas store" @@ -90,27 +108,6 @@ :initial-element (coerce initial-element 'double-float))) - -(declaim (ftype (function - (type-blas-store - type-blas-idx - type-blas-idx - type-blas-idx) - (complex double-float)) - ref-blas-complex-store)) - -(declaim (ftype (function - ((complex double-float) - type-blas-store - type-blas-idx - type-blas-idx - type-blas-idx - ) - (complex double-float)) - (setf ref-blas-complex-store))) - -(declaim (inline ref-blas-complex-store (setf ref-blas-complex-store))) - (defun ref-blas-complex-store (store row col rows) "Accessor for the complet blas store" (let ((idx (truly-the type-blas-idx @@ -136,6 +133,7 @@ (rv (coerce (realpart value) 'double-float)) (iv (coerce (imagpart value) 'double-float)) (store (allocate-real-store 2size iv))) + (declare (type type-blas-idx 2size)) (loop for i from 0 below 2size by 2 do (setf (aref store i) rv)) store)) Modified: src/matrix/level2-matrix-dge.lisp ============================================================================== --- src/matrix/level2-matrix-dge.lisp (original) +++ src/matrix/level2-matrix-dge.lisp Fri May 22 05:02:08 2009 @@ -22,11 +22,12 @@ (defmethod fill! ((a matrix-lisp-dge) value) (let ((x (coerce value 'double-float)) (store (matrix-store a))) + (declare (type type-blas-store store)) (fill store x))) (defmethod copy ((matrix matrix-lisp-dge)) (make-instance (class-name (class-of matrix)) - :store (copy-seq (matrix-store matrix)) + :store (copy-seq (the type-blas-store (matrix-store matrix))) :rows (rows matrix) :cols (cols matrix))) Modified: src/matrix/level2-matrix-zge.lisp ============================================================================== --- src/matrix/level2-matrix-zge.lisp (original) +++ src/matrix/level2-matrix-zge.lisp Fri May 22 05:02:08 2009 @@ -26,10 +26,9 @@ (setf (aref store i) rx (aref store (1+ i)) cx)))) - -(defmethod copy ((matrix matrix-base-zge)) +(defmethod copy ((matrix matrix-lisp-zge)) (make-instance (class-name (class-of matrix)) - :store (copy-seq (matrix-store matrix)) + :store (copy-seq (the type-blas-store (matrix-store matrix))) :rows (rows matrix) :cols (cols matrix))) @@ -51,10 +50,6 @@ (copy-contents a b #'abs) b)) - - - - (defmacro def-binary-op-blas-complex (new old) ;;; TODO speed up for real numbers (let ((a (gensym "a")) From jivestgarden at common-lisp.net Fri May 22 17:23:22 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Fri, 22 May 2009 13:23:22 -0400 Subject: [lisplab-cvs] r36 - src src/core src/io src/linalg src/matrix system Message-ID: Author: jivestgarden Date: Fri May 22 13:23:21 2009 New Revision: 36 Log: moved io routines to separate file Added: src/core/template.lisp (props changed) - copied unchanged from r12, /src/template.lisp src/io/ src/io/level3-io.lisp Removed: src/template.lisp Modified: src/linalg/level3-linalg-generic.lisp src/matrix/level2-interface.lisp system/lisplab.asd Added: src/io/level3-io.lisp ============================================================================== --- (empty file) +++ src/io/level3-io.lisp Fri May 22 13:23:21 2009 @@ -0,0 +1,169 @@ +;;; Lisplab, level3-io.lisp +;;; Input output operations + +;;; Copyright (C) 2009 Joern Inge Vestgaarden +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License along +;;; with this program; if not, write to the Free Software Foundation, Inc., +;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + + +;;; TODO: some more system on io. Make methods, but then I need +;;; more control on the parameters. Maybee need some layers. +;;; one generic stream layer and then one for opening and +;;; closing files? + +(in-package :lisplab) + +(export '(pgmwrite dlmread dlmwrite)) + +(defun dlmwrite (a &optional (out t) + &key + (dlm " ") + (fmt "~S")) + "Write matrix as a delimited anscii test file." + (let* ((out (if (eq out t) *standard-output* out))) + (flet ((printit (out) + (if (scalar? a) + (prin1 a out) + (progn + (format out "~&") + (dotimes (i (rows a)) + (dotimes (j (cols a)) + (format out fmt (mref a i j)) + (when (< j (1- (cols a))) + (princ dlm out))) + (when (< i (1- (rows a))) + (princ #\Newline out))))))) + (if (streamp out) + (printit out) + (with-open-file (out out :direction :output :if-exists :supersede) + (printit out)))))) + +(defun dlmread (class &optional (in t)) + "Reads a delimited anscii test file and returns a matrix. Currently only space delimited." + ;; TODO: Fixit. Non-space formated matrices + (let* ((in (if (eq in t) *standard-input* in)) + (end (gensym)) + (rows nil)) + (labels ((line (in) (let ((line (read-line in nil end nil))) + (if (eq line end) + end + (if (eql (char line 0) #\#) + (line in) + line)))) + (element (in) (read in nil end nil)) + (getit (in) + (do ((line (line in) (line in))) + ((eq line end)) + (let ((s (make-string-input-stream line)) + (cols nil)) + (do ((elm (element s) (element s))) + ((eq elm end)) + (push elm cols)) + (push (reverse cols) rows))))) + (if (streamp in) + (getit in) + (with-open-file (in in :direction :input) + (getit in)))) + (convert (reverse rows) class))) + +(defun pgmwrite (m filename + &key + (verbose nil) + (max (mmax m)) + (min (mmin m))) + "Writes matrix as a binary pgm file." + (let* ((rows (rows m)) + (cols (cols m)) + (scale (- max min))) + (if (<= (- max min) 0.0) + (setf max 1.0 min 0.0 scale 1.0)) + (with-open-file (out filename :direction :output :if-exists :supersede) + (format out "P5~%") + (format out "~A ~A~%" cols rows) + (format out "255~%")) + (with-open-file (out filename + :direction :output + :if-exists :append :element-type 'unsigned-byte) + (dotimes (i rows) + (dotimes (j cols) + (write-byte (floor (* 255 + (- (min (max (mref m i j) min) max) min) + (/ scale))) + out)))) + (when verbose + (format t "pgmwrite ~20A (~3Ax~3A)~%" filename rows cols)) + t)) + +(defun pswrite (m filename + &key + (verbose nil) + (max (mmax m)) + (min (mmin m))) + "Writes matrix as postscipt bitmap. Port of a2ps.c by Eric Weeks." + (let* ((DTXSCALE 1.0787) + (DTYSCALE 1.0) + (DTHRES 513) + (DTVRES 481) + (XOFFSET 54) ; 3/4 inch. 72 units = 1 inch. + (YOFFSET 288) ; /* 4 inches. */ + + (nbits 8) + (scale 0.5) + (invert 0) + (count 0) + (title 0) + (xsc 1.0) + (ysc 1.0) + + (xscale (floor (* DTXSCALE scale 432 xsc))) + (yscale (floor (* DTYSCALE scale 432 ysc))) + (xof XOFFSET) + (yof YOFFSET) + ; (hres DTHRES) + (hres (rows m)) + ; (vres DTVRES) + (vres (cols m))) + ;; ? fscanf(fp,"%ld %ld",&hres,&vres); + + ;; Write the necessary starting junk + (with-open-file (out filename :direction :output :if-exists :supersede) + (format out "\%!~%") ;; Identifies job as Postscript. + (format out "\%\%BoundingBox ~A ~A ~A ~A~%" 0 0 xscale yscale) + (format out "gsave~%") + (when (= title 1) + (format out "/Times-Roman findfont 30 scalefont setfont~%") + (format out "50.0 50.0 moveto~%") + (format out "(~A) show~%" filename)) + + (format out "0 0 moveto~%grestore~%"); + (format out "/picstr ~A string def~%" hres) + (format out "~A ~A translate~%" xof yof) + (format out "~A ~A scale~%" xscale yscale) + (format out "~A ~A ~A~%" hres vres nbits) + (format out "[~A 0 0 -~A 0 ~A]~%" hres vres vres) + (format out "{currentfile~%") + (format out " picstr readhexstring pop}~%") + (format out "image~%") + + ;; Now write byte for byte as hex. + (dotimes (j vres) + (dotimes (i hres) + (let ((c (floor (* 255 + (- (min (max (mref m i j) min) max) min) + (/ (- max min)))))) + (format out "~2,'0X" c))) + (format out "~%")) + (format out "showpage~%")))) + Modified: src/linalg/level3-linalg-generic.lisp ============================================================================== --- src/linalg/level3-linalg-generic.lisp (original) +++ src/linalg/level3-linalg-generic.lisp Fri May 22 13:23:21 2009 @@ -22,8 +22,6 @@ (in-package :lisplab) -(export '(pgmwrite)) - (defmethod mtr (matrix) (let ((ans 0)) (dotimes (i (rows matrix)) @@ -58,6 +56,18 @@ (defmethod minv (a) (minv! (copy a))) +(defmethod minv! (a) + "Matrix inversion based on LU-factorization." + (let ((LU (copy A))) + (destructuring-bind (LU p det) + (LU-factor! LU (make-permutation-vector (rows A))) + (fill! A 0) ; Use A for the results + (dotimes (i (rows A)) + (let ((col (view-col A (vref p i)))) + (setf (vref col i) 1) + (LU-solve! LU col)))) + A)) + #+nil (defmethod minv! (a) ;; Flawed. Does not work on when pivoting is needed "Brute force O(n^3) implementation of matrix inverse. @@ -79,84 +89,6 @@ (setf (mref a j k) (.- (mref a j k) (.* temp (mref a i k)))))))))) -(defmethod dlmwrite (a &optional (out t) - &key - (dlm " ") - (fmt "~S")) - (let* ((out (if (eq out t) *standard-output* out))) - (flet ((printit (out) - (if (scalar? a) - (prin1 a out) - (progn - (format out "~&") - (dotimes (i (rows a)) - (dotimes (j (cols a)) - (format out fmt (mref a i j)) - (when (< j (1- (cols a))) - (princ dlm out))) - (when (< i (1- (rows a))) - (princ #\Newline out))))))) - (if (streamp out) - (printit out) - (with-open-file (out out :direction :output :if-exists :supersede) - (printit out)))))) - -(defmethod dlmread (class &optional (in t) &rest args) - ;; Fixit. Non-space formated matrices - (declare (ignore args)) - (let* ((in (if (eq in t) *standard-input* in)) - (end (gensym)) - (rows nil)) - (labels ((line (in) (let ((line (read-line in nil end nil))) - (if (eq line end) - end - (if (eql (char line 0) #\#) - (line in) - line)))) - (element (in) (read in nil end nil)) - (getit (in) - (do ((line (line in) (line in))) - ((eq line end)) - (let ((s (make-string-input-stream line)) - (cols nil)) - (do ((elm (element s) (element s))) - ((eq elm end)) - (push elm cols)) - (push (reverse cols) rows))))) - (if (streamp in) - (getit in) - (with-open-file (in in :direction :input) - (getit in)))) - (convert (reverse rows) class))) - -(defun pgmwrite (m filename - &key - (verbose nil) - (max (mmax m)) - (min (mmin m))) - "Writes matrix as a binary pgm file" - (let* ((rows (rows m)) - (cols (cols m)) - (scale (- max min))) - (if (<= (- max min) 0.0) - (setf max 1.0 min 0.0 scale 1.0)) - (with-open-file (out filename :direction :output :if-exists :supersede) - (format out "P5~%") - (format out "~A ~A~%" cols rows) - (format out "255~%")) - (with-open-file (out filename - :direction :output - :if-exists :append :element-type 'unsigned-byte) - (dotimes (i rows) - (dotimes (j cols) - (write-byte (floor (* 255 - (- (min (max (mref m i j) min) max) min) - (/ scale))) - out)))) - (when verbose - (format t "pgmwrite ~20A (~3Ax~3A)~%" filename rows cols)) - t)) - (defmethod LU-factor! (A p) ;; Translation from GSL. ;; Destructive LU factorization. The outout is PA=LU, @@ -251,18 +183,6 @@ (setf det (.* det (mref LU i i)))) det)) -(defmethod minv! (a) - "Based on LU-factorization" - (let ((LU (copy A))) - (destructuring-bind (LU p det) - (LU-factor! LU (make-permutation-vector (rows A))) - (fill! A 0) ; Use A for the results - (dotimes (i (rows A)) - (let ((col (view-col A (vref p i)))) - (setf (vref col i) 1) - (LU-solve! LU col)))) - A)) - Modified: src/matrix/level2-interface.lisp ============================================================================== --- src/matrix/level2-interface.lisp (original) +++ src/matrix/level2-interface.lisp Fri May 22 13:23:21 2009 @@ -24,14 +24,11 @@ (export '( .every .some ; to level0 ? square-matrix? - ; new mnew - ; create mcreate copy-contents - ; diag .map mmap fill! - dlmwrite dlmread +; dlmwrite dlmread to-vector! to-vector to-matrix! to-matrix reshape! reshape @@ -79,11 +76,11 @@ (defgeneric diag (v) (:documentation "Creates a diagnoal matrix from the vector.")) -(defgeneric dlmwrite (matrix &optional file &rest args) +#+nil (defgeneric dlmwrite (matrix &optional file &rest args) (:documentation "Write all elements to a text file or stream in row major order. File t means standard output.")) -(defgeneric dlmread (class &optional file-or-stream &rest args) +#+nil (defgeneric dlmread (class &optional file-or-stream &rest args) (:documentation "Reads a text file or stream and outputs a matrix")) (defgeneric to-vector! (a) Modified: system/lisplab.asd ============================================================================== --- system/lisplab.asd (original) +++ system/lisplab.asd Fri May 22 13:23:21 2009 @@ -57,6 +57,17 @@ (:file "level2-array-functions"))) ;; + ;; IO (level 3) + ;; + (:module :io + :depends-on (:matrix) + :pathname "../src/io/" + :serial t + :components + ( + (:file "level3-io"))) + + ;; ;; Linear algebra interface(Level 3) ;; (:module :linalg-interface From jivestgarden at common-lisp.net Fri May 22 19:04:12 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Fri, 22 May 2009 15:04:12 -0400 Subject: [lisplab-cvs] r37 - in src: io linalg Message-ID: Author: jivestgarden Date: Fri May 22 15:04:11 2009 New Revision: 37 Log: Cleaned up Modified: src/io/level3-io.lisp src/linalg/level3-linalg-generic.lisp Modified: src/io/level3-io.lisp ============================================================================== --- src/io/level3-io.lisp (original) +++ src/io/level3-io.lisp Fri May 22 15:04:11 2009 @@ -111,7 +111,9 @@ (verbose nil) (max (mmax m)) (min (mmin m))) - "Writes matrix as postscipt bitmap. Port of a2ps.c by Eric Weeks." + "Writes matrix as postsrcipt bitmap. Port of a2ps.c by Eric Weeks." + ;; TODO: clean up and some more lispifying. + ;; TODO: more testing. (let* ((DTXSCALE 1.0787) (DTYSCALE 1.0) (DTHRES 513) @@ -120,12 +122,13 @@ (YOFFSET 288) ; /* 4 inches. */ (nbits 8) - (scale 0.5) + (scale 1) (invert 0) (count 0) - (title 0) + (title nil) (xsc 1.0) - (ysc 1.0) + ; (ysc 1.0 ) + (ysc (/ (cols m) (rows m) 1.0)) (xscale (floor (* DTXSCALE scale 432 xsc))) (yscale (floor (* DTYSCALE scale 432 ysc))) @@ -135,14 +138,11 @@ (hres (rows m)) ; (vres DTVRES) (vres (cols m))) - ;; ? fscanf(fp,"%ld %ld",&hres,&vres); - - ;; Write the necessary starting junk (with-open-file (out filename :direction :output :if-exists :supersede) - (format out "\%!~%") ;; Identifies job as Postscript. - (format out "\%\%BoundingBox ~A ~A ~A ~A~%" 0 0 xscale yscale) + (format out "\%!PS-Adobe-3.0 EPSF-3.0~%") ;; Identifies job as Postscript. + (format out "\%\%BoundingBox: ~A ~A ~A ~A~%" xof yof (+ xscale xof) (+ yscale yof)) (format out "gsave~%") - (when (= title 1) + (when title (format out "/Times-Roman findfont 30 scalefont setfont~%") (format out "50.0 50.0 moveto~%") (format out "(~A) show~%" filename)) Modified: src/linalg/level3-linalg-generic.lisp ============================================================================== --- src/linalg/level3-linalg-generic.lisp (original) +++ src/linalg/level3-linalg-generic.lisp Fri May 22 15:04:11 2009 @@ -22,29 +22,30 @@ (in-package :lisplab) -(defmethod mtr (matrix) +(defmethod mtr ((matrix matrix-base)) (let ((ans 0)) (dotimes (i (rows matrix)) (setf ans (.+ ans (mref matrix i i)))) ans)) -(defmethod mtp (a) +(defmethod mtp ((a matrix-base)) (let ((b (mcreate a 0 (list (cols a) (rows a))))) (dotimes (i (rows b)) (dotimes (j (cols b)) (setf (mref b i j) (mref a j i)))) b)) -(defmethod mconj (a) +(defmethod mconj ((a matrix-base)) + ;; TODO this should be .conj and be level0 (let ((b (mcreate a #C(0 0) (list (rows a) (cols a)) ))) (dotimes (i (size b)) (setf (vref b i) (conjugate (vref a i)))) b)) -(defmethod mct (a) +(defmethod mct ((a matrix-base)) (mconj (mtp a))) -(defmethod m* (a b) +(defmethod m* ((a matrix-base) (b matrix-base)) (let ((c (mcreate a 0 (list (rows a) (cols b))))) (dotimes (i (rows c)) (dotimes (j (cols c)) @@ -53,10 +54,10 @@ (.* (mref a i k) (mref b k j))))))) c)) -(defmethod minv (a) +(defmethod minv ((a matrix-base)) (minv! (copy a))) -(defmethod minv! (a) +(defmethod minv! ((a matrix-base)) "Matrix inversion based on LU-factorization." (let ((LU (copy A))) (destructuring-bind (LU p det) @@ -68,7 +69,7 @@ (LU-solve! LU col)))) A)) -#+nil (defmethod minv! (a) +#+nil (defmethod minv! ((a matrix-base)) ;; Flawed. Does not work on when pivoting is needed "Brute force O(n^3) implementation of matrix inverse. Think I'll keep this for the general case since it works also @@ -89,11 +90,14 @@ (setf (mref a j k) (.- (mref a j k) (.* temp (mref a i k)))))))))) -(defmethod LU-factor! (A p) +(defmethod LU-factor! ((A matrix-base) p) ;; Translation from GSL. ;; Destructive LU factorization. The outout is PA=LU, ;; stored in one matrix, where the diagonal elements belong ;; to U and L has implicite ones at diagonal. + + ;; TODO: handle permutations better! + ;; TODO: Change unatural i and j indexing. (let ((N (rows A)) (sign 1)) @@ -126,7 +130,7 @@ (.* Aij (mref A j k))))))))) (list A p sign))) -(defmethod LU-factor (A) +(defmethod LU-factor ((A matrix-base)) (destructuring-bind (A p sign) (LU-factor! (copy A) (make-permutation-vector (rows A))) @@ -139,7 +143,7 @@ (setf (mref Pmat i (vref p i) ) 1)) (list L U Pmat)))) -(defun L-solve! (L x w/diag) +(defun L-solve! ((L matrix-base) (x matrix-base) w/diag) ;; Solve Lx=b (setf (vref x 0) (./ (vref x 0) (if w/diag (mref L 0 0) 1))) @@ -152,7 +156,7 @@ (if w/diag (mref L i i) 1))))) x) -(defun U-solve! (U x w/diag) +(defun U-solve! ((U matrix-base) (x matrix-base) w/diag) (let* ((N (size x)) (N-1 (1- N))) (setf (vref x N-1) (./ (vref x N-1) @@ -165,19 +169,19 @@ (if w/diag (mref U i i) 1))))) x)) -(defun LU-solve! (LU x) +(defun LU-solve! ((LU matrix-base) (x matrix-base)) (L-solve! LU x nil) (U-solve! LU x t) x) -(defmethod lin-solve (A b) +(defmethod lin-solve ((A matrix-base) (b matrix-base)) (destructuring-bind (LU pvec sign) (LU-factor A) (let ((b2 (copy b))) (dotimes (i (rows A)) (setf (vref b2 (vref pvec i)) (vref b i))) (LU-solve! LU b2)))) -(defmethod mdet (A) +(defmethod mdet ((A matrix-base)) (destructuring-bind (LU pvec det) (LU-factor A) (dotimes (i (rows A)) (setf det (.* det (mref LU i i)))) From jivestgarden at common-lisp.net Fri May 22 19:06:14 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Fri, 22 May 2009 15:06:14 -0400 Subject: [lisplab-cvs] r38 - src/linalg Message-ID: Author: jivestgarden Date: Fri May 22 15:06:11 2009 New Revision: 38 Log: Bugfix Modified: src/linalg/level3-linalg-generic.lisp Modified: src/linalg/level3-linalg-generic.lisp ============================================================================== --- src/linalg/level3-linalg-generic.lisp (original) +++ src/linalg/level3-linalg-generic.lisp Fri May 22 15:06:11 2009 @@ -143,7 +143,7 @@ (setf (mref Pmat i (vref p i) ) 1)) (list L U Pmat)))) -(defun L-solve! ((L matrix-base) (x matrix-base) w/diag) +(defun L-solve! (L x w/diag) ;; Solve Lx=b (setf (vref x 0) (./ (vref x 0) (if w/diag (mref L 0 0) 1))) @@ -156,7 +156,7 @@ (if w/diag (mref L i i) 1))))) x) -(defun U-solve! ((U matrix-base) (x matrix-base) w/diag) +(defun U-solve! (U x w/diag) (let* ((N (size x)) (N-1 (1- N))) (setf (vref x N-1) (./ (vref x N-1) @@ -169,7 +169,7 @@ (if w/diag (mref U i i) 1))))) x)) -(defun LU-solve! ((LU matrix-base) (x matrix-base)) +(defun LU-solve! (LU x) (L-solve! LU x nil) (U-solve! LU x t) x) From jivestgarden at common-lisp.net Sat May 23 09:46:26 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sat, 23 May 2009 05:46:26 -0400 Subject: [lisplab-cvs] r39 - in src: core linalg matrix Message-ID: Author: jivestgarden Date: Sat May 23 05:46:23 2009 New Revision: 39 Log: added new matrix types Modified: src/core/level0-functions.lisp src/core/level0-interface.lisp src/linalg/level3-linalg-blas-real.lisp src/linalg/level3-linalg-generic.lisp src/linalg/level3-linalg-interface.lisp src/matrix/level1-classes.lisp src/matrix/level1-constructors.lisp src/matrix/level1-matrix.lisp src/matrix/level2-generic.lisp src/matrix/level2-matrix-dge.lisp Modified: src/core/level0-functions.lisp ============================================================================== --- src/core/level0-functions.lisp (original) +++ src/core/level0-functions.lisp Sat May 23 05:46:23 2009 @@ -27,6 +27,9 @@ (defmethod .imagpart ((a number)) (imagpart a)) +(defmethod .conj ((a number)) + (conjugate a)) + (defmethod .= ((a number) (b number) &optional (accuracy)) (if accuracy (< (abs (- a b)) accuracy) Modified: src/core/level0-interface.lisp ============================================================================== --- src/core/level0-interface.lisp (original) +++ src/core/level0-interface.lisp Sat May 23 05:46:23 2009 @@ -31,6 +31,7 @@ .sub .sub! .expt .expt! + .conj .sin .cos .tan .sinh .cosh .tanh .log .exp @@ -56,13 +57,16 @@ (:documentation "Generalized coerce.")) (defgeneric .abs (a) - (:documentation "Generialized abs")) + (:documentation "Generialized abs.")) (defgeneric .realpart (a) - (:documentation "Generialized realpart")) + (:documentation "Generialized realpart.")) (defgeneric .imagpart (a) - (:documentation "Generialized abs")) + (:documentation "Generialized abs.")) + +(defgeneric .conj (a) + (:documentation "Generalized conjugate.")) ;;; Binary boolean operators Modified: src/linalg/level3-linalg-blas-real.lisp ============================================================================== --- src/linalg/level3-linalg-blas-real.lisp (original) +++ src/linalg/level3-linalg-blas-real.lisp Sat May 23 05:46:23 2009 @@ -32,9 +32,6 @@ (setf (mref b i j) (mref a j i)))) b)) -(defmethod mconj ((a matrix-lisp-dge)) - (copy a)) - (defmethod mct ((a matrix-lisp-dge)) (mtp a)) Modified: src/linalg/level3-linalg-generic.lisp ============================================================================== --- src/linalg/level3-linalg-generic.lisp (original) +++ src/linalg/level3-linalg-generic.lisp Sat May 23 05:46:23 2009 @@ -35,13 +35,6 @@ (setf (mref b i j) (mref a j i)))) b)) -(defmethod mconj ((a matrix-base)) - ;; TODO this should be .conj and be level0 - (let ((b (mcreate a #C(0 0) (list (rows a) (cols a)) ))) - (dotimes (i (size b)) - (setf (vref b i) (conjugate (vref a i)))) - b)) - (defmethod mct ((a matrix-base)) (mconj (mtp a))) Modified: src/linalg/level3-linalg-interface.lisp ============================================================================== --- src/linalg/level3-linalg-interface.lisp (original) +++ src/linalg/level3-linalg-interface.lisp Sat May 23 05:46:23 2009 @@ -19,7 +19,7 @@ (in-package :lisplab) -(export '(mtp mtp! mconj mconj! mct mct! +(export '(mtp mtp! mct mct! mtr mdet minv! minv m* m*! m/ m/! LU-factor LU-factor! @@ -33,12 +33,6 @@ (defgeneric mtp! (matrix) (:documentation "Matrix transpose. Destructive.")) -(defgeneric mconj (matrix) - (:documentation "Matrix conjugate.")) - -(defgeneric mconj! (matrix) - (:documentation "Matrix conjugate. Destructive.")) - (defgeneric mct (matrix) (:documentation "Matrix conjugate transpose.")) Modified: src/matrix/level1-classes.lisp ============================================================================== --- src/matrix/level1-classes.lisp (original) +++ src/matrix/level1-classes.lisp Sat May 23 05:46:23 2009 @@ -42,13 +42,31 @@ :initform t :reader element-type))) -(defclass matrix-element-complex-double-float (matrix-element-base) +(defclass matrix-element-number (matrix-element-base) + ((element-type + :allocation :class + :initform 'number + :reader element-type))) + +(defclass matrix-element-complex (matrix-element-number) + ((element-type + :allocation :class + :initform 'complex + :reader element-type))) + +(defclass matrix-element-complex-double-float (matrix-element-complex) ((element-type :allocation :class :initform '(complex double-float) :reader element-type))) -(defclass matrix-element-double-float (matrix-element-complex-double-float) +(defclass matrix-element-real (matrix-element-number) + ((element-type + :allocation :class + :initform 'real + :reader element-type))) + +(defclass matrix-element-double-float (matrix-element-real) ((element-type :allocation :class :initform 'double-float @@ -88,9 +106,22 @@ :accessor size :type type-blas-idx))) - ;;; The actual classes ment for instantiation +(defclass matrix-ge + (matrix-structure-general matrix-element-base matrix-implementation-lisp) + ((matrix-store + :initarg :store + :initform nil + :reader matrix-store + :type (array t (*)))) + (:documentation "A full matrix (rows x cols) with unspecified matrix element types.")) + +(defmethod initialize-instance :after ((m matrix-ge) &key (value 0)) + (with-slots (rows cols size matrix-store) m + (setf size (* rows cols)) + (unless matrix-store + (setf matrix-store (make-array size :initial-element value))))) ;;; Double float general matrices @@ -108,12 +139,17 @@ (unless matrix-store (setf matrix-store (allocate-real-store size value))))) -(defclass matrix-lisp-dge (matrix-implementation-lisp matrix-base-dge) ()) - -(defclass matrix-blas-dge (matrix-implementation-blas matrix-lisp-dge) ()) +(defclass matrix-lisp-dge (matrix-implementation-lisp matrix-base-dge) () + (:documentation "A full matrix (rows x cols) with double float elements. +Executes in lisp only.")) + +(defclass matrix-blas-dge (matrix-implementation-blas matrix-lisp-dge) () + (:documentation "A full matrix (rows x cols) with double float elements. +Executes in alien blas/lapack only.")) (defclass matrix-dge (matrix-blas-dge) () - (:documentation "General matrix with double float elements.")) + (:documentation "A full matrix (rows x cols) with double float matrix elements. +Executes first in alien blas/lapack if possible. If not it executes in lisp.")) ;;; Complex double float general matrices @@ -131,12 +167,17 @@ (unless matrix-store (setf matrix-store (allocate-complex-store size value))))) -(defclass matrix-lisp-zge (matrix-implementation-lisp matrix-base-zge) ()) - -(defclass matrix-blas-zge (matrix-implementation-blas matrix-lisp-zge) ()) +(defclass matrix-lisp-zge (matrix-implementation-lisp matrix-base-zge) () + (:documentation "A full matrix (rows x cols) with complex double float elements. +Executes in lisp only.")) + +(defclass matrix-blas-zge (matrix-implementation-blas matrix-lisp-zge) () + (:documentation "A full matrix (rows x cols) with complex double float elements. +Executes in alien blas/lapack only.")) (defclass matrix-zge (matrix-blas-zge) () - (:documentation "General matrix with complex double float elements.")) + (:documentation "A full matrix (rows x cols) with complex double float matrix elements. +Executes first in alien blas/lapack if possible. If not it executes in lisp.")) ;;; Double float diagonal matrices Modified: src/matrix/level1-constructors.lisp ============================================================================== --- src/matrix/level1-constructors.lisp (original) +++ src/matrix/level1-constructors.lisp Sat May 23 05:46:23 2009 @@ -61,6 +61,8 @@ ;;; Adding all the matrix descriptions +(add-matrix-class 'matrix-ge :any :ge :lisp) + (add-matrix-class 'matrix-base-dge :d :ge :base) (add-matrix-class 'matrix-lisp-dge :d :ge :lisp) (add-matrix-class 'matrix-blas-dge :d :ge :blas) Modified: src/matrix/level1-matrix.lisp ============================================================================== --- src/matrix/level1-matrix.lisp (original) +++ src/matrix/level1-matrix.lisp Sat May 23 05:46:23 2009 @@ -61,7 +61,22 @@ (defmethod make-matrix-instance ((description list) dim value) (make-matrix-instance (find-matrix-class description) dim value)) - + +;;; The general matrix + +(defmethod mref ((matrix matrix-ge) row col) + (aref (matrix-store matrix) (column-major-idx row col (rows matrix)))) + +(defmethod (setf mref) (value (matrix matrix-ge) row col) + (setf (aref (matrix-store matrix) (column-major-idx row col (rows matrix))) + value)) + +(defmethod vref ((matrix matrix-ge) idx) + (aref (matrix-store matrix) idx)) + +(defmethod (setf vref) (value (matrix matrix-ge) idx) + (setf (aref (matrix-store matrix) idx) + value)) ;;; Spcialized for blas-dge Modified: src/matrix/level2-generic.lisp ============================================================================== --- src/matrix/level2-generic.lisp (original) +++ src/matrix/level2-generic.lisp Sat May 23 05:46:23 2009 @@ -24,6 +24,14 @@ (in-package :lisplab) +(defmethod .conj ((a matrix-element-complex-double-float)) + (let ((b (mcreate a))) + (dotimes (i (size b)) + (setf (vref b i) (conjugate (vref a i)))) + b)) + + + ;; Helper function. #+nil (defun convert-list-to-matrix (list type) (let* ((rows (length list)) Modified: src/matrix/level2-matrix-dge.lisp ============================================================================== --- src/matrix/level2-matrix-dge.lisp (original) +++ src/matrix/level2-matrix-dge.lisp Sat May 23 05:46:23 2009 @@ -51,6 +51,9 @@ (copy-contents a b #'abs) b)) +(defmethod .conj ((a matrix-lisp-dge)) + (copy a)) + (defmethod .some (pred (a matrix-lisp-dge) &rest args) (let ((stores (mapcar #'matrix-store (cons a args)))) (apply #'some pred stores))) From jivestgarden at common-lisp.net Sat May 23 11:39:44 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sat, 23 May 2009 07:39:44 -0400 Subject: [lisplab-cvs] r40 - src/matrix Message-ID: Author: jivestgarden Date: Sat May 23 07:39:44 2009 New Revision: 40 Log: bugfix Modified: src/matrix/level2-generic.lisp Modified: src/matrix/level2-generic.lisp ============================================================================== --- src/matrix/level2-generic.lisp (original) +++ src/matrix/level2-generic.lisp Sat May 23 07:39:44 2009 @@ -76,14 +76,14 @@ (defmethod .some (pred (a matrix-base) &rest args) (dotimes (i (size a)) (when (apply pred (mapcar (lambda (x) (vref x i)) (cons a args))) - (return-from .some t)) - nil)) + (return-from .some t))) + nil) (defmethod .every (pred (a matrix-base) &rest args) (dotimes (i (size a)) - (unless (apply pred (mapcar (lambda (x) (vref x i)) (cons a args))) - (return-from .every nil)) - t)) + (unless (apply pred (mapcar (lambda (x) (vref x i)) (cons a args))) + (return-from .every nil))) + t) (defmethod mmap (type f (a matrix-base) &rest args) (let ((b (make-matrix-instance type (dim a) 0))) From jivestgarden at common-lisp.net Sun May 24 08:56:15 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sun, 24 May 2009 04:56:15 -0400 Subject: [lisplab-cvs] r41 - src/matrix Message-ID: Author: jivestgarden Date: Sun May 24 04:56:13 2009 New Revision: 41 Log: fixed the standard operators and functions Modified: src/matrix/level2-generic.lisp src/matrix/level2-matrix-dge.lisp src/matrix/level2-matrix-zge.lisp Modified: src/matrix/level2-generic.lisp ============================================================================== --- src/matrix/level2-generic.lisp (original) +++ src/matrix/level2-generic.lisp Sun May 24 04:56:13 2009 @@ -244,10 +244,103 @@ (def-matrix-base-boolean-operator .>=) - +;; Specialize operators for matrix-ge. It is dangerous to spezialize for matrix-base +;; since the output type depends on the kind of operator. It is possible to +;; make it better by separating between complex and real number and matrices, but +;; I'm too laza to do it. +(defmacro def-binary-op-matrix-ge (op) + (let ((a (gensym "a")) + (b (gensym "b")) + (len (gensym "len")) + (i (gensym "i"))) + `(progn + (defmethod ,op ((,a matrix-ge) ,b) + (let* ((,a (copy ,a)) + (,len (size ,a))) + (dotimes (,i ,len) + (setf (vref ,a ,i) (,op (vref ,a ,i) ,b))) + ,a)) + (defmethod ,op (,a (,b matrix-ge)) + (let* ((,b (copy ,b)) + (,len (size ,b))) + (dotimes (,i ,len) + (setf (vref ,b ,i) (,op ,a (vref ,b ,i)))) + ,b)) + (defmethod ,op ((,a matrix-ge) (,b matrix-ge)) + (let* ((,a (copy ,a)) + (,len (size ,a))) + (dotimes (,i ,len) + (setf (vref ,a ,i) (,op (vref ,a ,i) (vref ,b ,i)))) + ,a))))) + +(def-binary-op-matrix-ge .add) + +(def-binary-op-matrix-ge .mul) + +(def-binary-op-matrix-ge .sub) + +(def-binary-op-matrix-ge .div) + +(def-binary-op-matrix-ge .expt) + +(defmacro each-element-function-matrix-ge (x form) + "Applies a form on each element of an matrix-ge." + (let ((i (gensym)) + (y (gensym))) + `(let* ((,y (copy ,x))) + (dotimes (,i (size ,y)) + (let ((,x (vref ,y ,i))) + (setf (vref ,y ,i) + ,form))) + ,y))) + +;;; Trignometric functions + +(defmethod .sin ((x matrix-ge)) + (each-element-function-matrix-ge x (.sin x))) + +(defmethod .cos ((x matrix-ge)) + (each-element-function-matrix-ge x (.cos x))) + +(defmethod .tan ((x matrix-ge)) + (each-element-function-matrix-ge x (.tan x))) + +;;; Hyperbolic functions + +(defmethod .sinh ((x matrix-ge)) + (each-element-function-matrix-ge x (.sinh x))) + +(defmethod .cosh ((x matrix-ge)) + (each-element-function-matrix-ge x (.cosh x))) + +(defmethod .tanh ((x matrix-ge)) + (each-element-function-matrix-ge x (.tanh x))) + +(defmethod .log ((x matrix-ge) &optional base) + (each-element-function-matrix-ge x (.log x base))) + +(defmethod .exp ((x matrix-ge)) + (each-element-function-matrix-ge x (.exp x))) + +;;; Bessel functions + +(defmethod .besj (n (x matrix-ge)) + (each-element-function-matrix-ge x (.besj n x))) + +(defmethod .besy (n (x matrix-ge)) + (each-element-function-matrix-ge x (.besy n x))) + +(defmethod .besi (n (x matrix-ge)) + (each-element-function-matrix-ge x (.besi n x))) +(defmethod .besk (n (x matrix-ge)) + (each-element-function-matrix-ge x (.besk n x))) +(defmethod .besh1 (n (x matrix-ge)) + (each-element-function-matrix-ge x (.besh1 n x))) +(defmethod .besh2 (n (x matrix-ge)) + (each-element-function-matrix-ge x (.besh2 n x))) ;;; TRASH Modified: src/matrix/level2-matrix-dge.lisp ============================================================================== --- src/matrix/level2-matrix-dge.lisp (original) +++ src/matrix/level2-matrix-dge.lisp Sun May 24 04:56:13 2009 @@ -70,7 +70,7 @@ (store2 (gensym "store2")) (i (gensym "i"))) `(progn - (defmethod ,new ((,a matrix-lisp-dge) ,b) + (defmethod ,new ((,a matrix-lisp-dge) (,b real)) (let* ((,a (copy ,a)) (,store (matrix-store ,a)) (,b (coerce ,b 'double-float)) @@ -81,7 +81,7 @@ (dotimes (,i ,len) (setf (aref ,store ,i) (,old (aref ,store ,i) ,b))) ,a)) - (defmethod ,new (,a (,b matrix-lisp-dge)) + (defmethod ,new ((,a real) (,b matrix-lisp-dge)) (let* ((,b (copy ,b)) (,store (matrix-store ,b)) (,a (coerce ,a 'double-float)) @@ -135,14 +135,13 @@ make complex output for real arguments. TODO optimize? Probably no need. The Hankel functions are slow anyway." (let ((i (gensym)) - (a (gensym)) (b (gensym)) - (spec-a (gensym))) - `(let* ((spec-a (find-matrix-description ,a)) - (,b (convert ,a (cons :z (cdr ,spec-a) )))) - (dotimes (,i (size ,a)) - (let ((,x (mref ,a ,i))) - (setf (mref ,b ,i) ,form))) + (spec-b (gensym))) + `(let* ((,spec-b (create-matrix-description ,x :et :z)) + (,b (convert ,x ,spec-b) )) + (dotimes (,i (size ,x)) + (let ((,x (vref ,x ,i))) + (setf (vref ,b ,i) ,form))) ,b))) ;;; Trignometric functions @@ -159,19 +158,21 @@ ;;; Hyperbolic functions (defmethod .sinh ((x matrix-lisp-dge)) - (each-matrix-element-df-to-df x (.sinh x))) + (each-matrix-element-df-to-df x (sinh x))) (defmethod .cosh ((x matrix-lisp-dge)) - (each-matrix-element-df-to-df x (.cosh x))) + (each-matrix-element-df-to-df x (cosh x))) (defmethod .tanh ((x matrix-lisp-dge)) - (each-matrix-element-df-to-df x (.tanh x))) + (each-matrix-element-df-to-df x (tanh x))) (defmethod .log ((x matrix-lisp-dge) &optional base) - (each-matrix-element-df-to-df x (.log x base))) + (if base + (each-matrix-element-df-to-df x (log x base)) + (each-matrix-element-df-to-df x (log x)))) (defmethod .exp ((x matrix-lisp-dge)) - (each-matrix-element-df-to-df x (.exp x))) + (each-matrix-element-df-to-df x (exp x))) ;;; Bessel functions @@ -185,4 +186,10 @@ (each-matrix-element-df-to-df x (.besi n x))) (defmethod .besk (n (x matrix-lisp-dge)) - (each-matrix-element-df-to-df x (.besk n x))) \ No newline at end of file + (each-matrix-element-df-to-df x (.besk n x))) + +(defmethod .besh1 (n (x matrix-lisp-dge)) + (each-matrix-element-df-to-complex-df x (.besh1 n x))) + +(defmethod .besh2 (n (x matrix-lisp-dge)) + (each-matrix-element-df-to-complex-df x (.besh2 n x))) \ No newline at end of file Modified: src/matrix/level2-matrix-zge.lisp ============================================================================== --- src/matrix/level2-matrix-zge.lisp (original) +++ src/matrix/level2-matrix-zge.lisp Sun May 24 04:56:13 2009 @@ -51,7 +51,7 @@ b)) (defmacro def-binary-op-blas-complex (new old) - ;;; TODO speed up for real numbers + ;;; TODO speed up for real numbers. Is it worth the work? (let ((a (gensym "a")) (b (gensym "b")) (len (gensym "len")) @@ -59,7 +59,7 @@ (store2 (gensym "store2")) (i (gensym "i"))) `(progn - (defmethod ,new ((,a matrix-zge) ,b) + (defmethod ,new ((,a matrix-zge) (,b number)) (let* ((,a (copy ,a)) (,store (matrix-store ,a)) (,b (coerce ,b '(complex double-float))) @@ -71,7 +71,7 @@ (setf (ref-blas-complex-store ,store ,i 0 ,len) (,old (ref-blas-complex-store ,store ,i 0 ,len) ,b))) ,a)) - (defmethod ,new (,a (,b matrix-zge)) + (defmethod ,new ((,a number) (,b matrix-zge)) (let* ((,b (copy ,b)) (,store (matrix-store ,b)) (,a (coerce ,a '(complex double-float))) @@ -91,6 +91,7 @@ (declare (type type-blas-store ,store) (type type-blas-store ,store2) (type type-blas-idx ,len)) + (dotimes (,i ,len) (setf (ref-blas-complex-store ,store ,i 0 ,len) (,old (ref-blas-complex-store ,store ,i 0 ,len) @@ -133,3 +134,65 @@ (def-binary-op-blas-complex .expt expt) +(defmacro each-element-function-matrix-zge (x form) + "Applies a form on each element of an matrix-zge." + (let ((i (gensym)) + (y (gensym))) + `(let* ((,y (copy ,x))) + (declare (type matrix-zge ,y)) + (dotimes (,i (size ,y)) + (let ((,x (vref ,y ,i))) + (declare (type (complex double-float) ,x)) + (setf (vref ,y ,i) + ,form))) + ,y))) + +;;; Trignometric functions + +(defmethod .sin ((x matrix-lisp-zge)) + (each-element-function-matrix-zge x (sin x))) + +(defmethod .cos ((x matrix-lisp-zge)) + (each-element-function-matrix-zge x (cos x))) + +(defmethod .tan ((x matrix-lisp-zge)) + (each-element-function-matrix-zge x (tan x))) + +;;; Hyperbolic functions + +(defmethod .sinh ((x matrix-lisp-zge)) + (each-element-function-matrix-zge x (sinh x))) + +(defmethod .cosh ((x matrix-lisp-zge)) + (each-element-function-matrix-zge x (cosh x))) + +(defmethod .tanh ((x matrix-lisp-zge)) + (each-element-function-matrix-zge x (tanh x))) + +(defmethod .log ((x matrix-lisp-zge) &optional base) + (if base + (each-element-function-matrix-zge x (log x base)) + (each-element-function-matrix-zge x (log x)))) + +(defmethod .exp ((x matrix-lisp-zge)) + (each-element-function-matrix-zge x (exp x))) + +;;; Bessel functions + +(defmethod .besj (n (x matrix-lisp-zge)) + (each-element-function-matrix-zge x (.besj n x))) + +(defmethod .besy (n (x matrix-lisp-zge)) + (each-element-function-matrix-zge x (.besy n x))) + +(defmethod .besi (n (x matrix-lisp-zge)) + (each-element-function-matrix-zge x (.besi n x))) + +(defmethod .besk (n (x matrix-lisp-zge)) + (each-element-function-matrix-zge x (.besk n x))) + +(defmethod .besh1 (n (x matrix-lisp-zge)) + (each-element-function-matrix-zge x (.besh1 n x))) + +(defmethod .besh2 (n (x matrix-lisp-zge)) + (each-element-function-matrix-zge x (.besh2 n x))) From jivestgarden at common-lisp.net Sun May 24 11:37:25 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sun, 24 May 2009 07:37:25 -0400 Subject: [lisplab-cvs] r42 - in src: core matrix Message-ID: Author: jivestgarden Date: Sun May 24 07:37:23 2009 New Revision: 42 Log: fixes and added incomplete view Added: src/matrix/level2-view.lisp Modified: src/core/level0-generic.lisp src/core/level0-interface.lisp src/matrix/level1-classes.lisp src/matrix/level2-generic.lisp src/matrix/level2-matrix-zge.lisp Modified: src/core/level0-generic.lisp ============================================================================== --- src/core/level0-generic.lisp (original) +++ src/core/level0-generic.lisp Sun May 24 07:37:23 2009 @@ -21,34 +21,40 @@ (export '(.+ .* ./ .- .^ ^)) +(defmethod copy (a) + ;; Hm this is dagenrous if someone forgets to overload copy. + a) + +(defmethod scalar? ((a number)) + t) ;; Is this right? + (defun ^ (x n) "Synonym for expt" (expt x n)) (defun .+ (&rest args) + "Generlized +. Reduces the arguments with .add." (if (and args (cdr args)) (reduce #'.add args) (car args))) (defun .* (&rest args) + "Generalized *. Reduces the arguments with .mul." (if (and args (cdr args)) (reduce #'.mul args) (car args))) (defun ./ (&rest args) + "Generalized /. Reduces the arguments with .div." (if (and args (cdr args)) (reduce #'.div args) (./ 1 (car args)))) (defun .- (&rest args) + "Generalized -. Reduces the arguments with .sub." (if (and args (cdr args)) (reduce #'.sub args) (.- 0 (car args)))) (defun .^ (&rest args) + "Generlized expt. Reduces the arguments with .expt." (reduce #'.expt args)) -(defmethod copy (a) - ;; Hm this is dagenrous if someone forgets to overload copy. - a) - -(defmethod scalar? ((a number)) - t) ;; Is this right? Modified: src/core/level0-interface.lisp ============================================================================== --- src/core/level0-interface.lisp (original) +++ src/core/level0-interface.lisp Sun May 24 07:37:23 2009 @@ -54,7 +54,7 @@ shared state, like fill pointers etc.")) (defgeneric convert (x type) - (:documentation "Generalized coerce.")) + (:documentation "Converts the object to the specified type. Non-destructive.")) (defgeneric .abs (a) (:documentation "Generialized abs.")) Modified: src/matrix/level1-classes.lisp ============================================================================== --- src/matrix/level1-classes.lisp (original) +++ src/matrix/level1-classes.lisp Sun May 24 07:37:23 2009 @@ -221,6 +221,9 @@ :type function)) (:documentation "Matrix without a store.")) +(defmethod initialize-instance :after ((m function-matrix) &key) + (with-slots (rows cols size matrix-store) m + (setf size (* rows cols)))) Modified: src/matrix/level2-generic.lisp ============================================================================== --- src/matrix/level2-generic.lisp (original) +++ src/matrix/level2-generic.lisp Sun May 24 07:37:23 2009 @@ -24,35 +24,9 @@ (in-package :lisplab) -(defmethod .conj ((a matrix-element-complex-double-float)) - (let ((b (mcreate a))) - (dotimes (i (size b)) - (setf (vref b i) (conjugate (vref a i)))) - b)) - - - -;; Helper function. -#+nil (defun convert-list-to-matrix (list type) - (let* ((rows (length list)) - (cols (length (car list))) - (m (make-matrix-instance type (list rows cols) 0))) - (fill-matrix-with-list m list))) - -;; Helper function. -#+nil (defun convert-matrix-to-matrix (m0 type) - (let* ((rows (rows m0)) - (cols (cols m0)) - (m (make-matrix-instance type (dim m0) 0))) - (dotimes (i rows) - (dotimes (j cols) - (setf (mref m i j) (mref m0 i j)))) - m)) - (defmethod square-matrix? ((x matrix-base)) (= (rows x) (cols x))) - ;;; This is OK, but could be optimzied! (defmacro w/mat (a args &body body) (let ((a2 (gensym)) @@ -104,13 +78,6 @@ (defmethod .map (f (a matrix-base) &rest args) (apply #'mmap (class-name (class-of a)) f a args)) -#+todo-remove (defmethod diag (v) - (let* ((n (size v)) - (a (mcreate v 0 (list n n)))) - (dotimes (i n) - (setf (mref a i i) (vref v i))) - a)) - (defmethod msum ((m matrix-base)) "Sums all elements of m." (let ((sum 0)) @@ -194,12 +161,8 @@ (defmethod to-matrix ((a matrix-base) rows) (reshape a (list rows (/ (size a) rows) 1))) - ;;;; Basic boolean operators - -;;;; The boolean operators - (defmethod .= ((a matrix-base) (b matrix-base) &optional acc) (if acc (.every (lambda (a b) (.= a b acc)) a b) @@ -243,7 +206,6 @@ (def-matrix-base-boolean-operator .>=) - ;; Specialize operators for matrix-ge. It is dangerous to spezialize for matrix-base ;; since the output type depends on the kind of operator. It is possible to ;; make it better by separating between complex and real number and matrices, but @@ -294,6 +256,20 @@ ,form))) ,y))) + + +(defmethod .imagpart ((x matrix-ge)) + (each-element-function-matrix-ge x (.imagpart x))) + +(defmethod .realpart ((x matrix-ge)) + (each-element-function-matrix-ge x (.realpart x))) + +(defmethod .abs ((x matrix-ge)) + (each-element-function-matrix-ge x (.abs x))) + +(defmethod .conj ((x matrix-ge)) + (each-element-function-matrix-ge x (.conj x))) + ;;; Trignometric functions (defmethod .sin ((x matrix-ge)) @@ -345,53 +321,3 @@ ;;; TRASH - -#+todo-remove(defmethod new (class dim &optional (element-type t) (value 0)) - ;;; TODO get rid of this default that calls the new constructor - (mnew class value (car dim) (cadr dim))) - -#+todo-remove(defmethod convert (obj type) - (if (not (or (vector? obj) (matrix? obj))) - (coerce obj type) - (let ((new (new type (dim obj) (element-type obj)))) - (ecase (rank obj) - (1 (dotimes (i (size obj)) - (setf (vref new i) (vref obj i)))) - (2 (dotimes (i (rows obj)) - (dotimes (j (cols obj)) - (setf (mref new i j) (mref obj i j)))))) - new))) - -#+todo-remove(defmethod copy (a) - (typecase a - (list (copy-list a)) - (sequence (copy-seq a)) - (t (let ((b (create a))) - (dotimes (i (size a)) - (setf (vref b i) (vref a i))) - b)))) - -#+todo-remove (defmethod create (a &optional value dim) - (mcreate a value dim)) - -;;; TODO move to dge code - -#+todo-remove(defmethod convert ((x cons) (type (eql 'matrix-dge))) - (convert-list-to-matrix x type)) - -#+todo-remove(defmethod convert ((x matrix-base) (type (eql 'matrix-dge))) - (convert-matrix-to-matrix x type)) - -#+todo-remove(defmethod mnew ((class (eql 'matrix-dge)) value rows &optional (cols 1)) - (make-matrix-instance class (list rows cols) value)) - -;;; TODO move to zge code - -#+todo-remove(defmethod convert ((x cons) (type (eql 'matrix-zge))) - (convert-list-to-matrix x type)) - -#+todo-remove(defmethod convert ((x matrix-base) (type (eql 'matrix-zge))) - (convert-matrix-to-matrix x type)) - -#+todo-remove(defmethod mnew ((class (eql 'matrix-zge)) value rows &optional (cols 1)) - (make-matrix-instance class (list rows cols) value)) Modified: src/matrix/level2-matrix-zge.lisp ============================================================================== --- src/matrix/level2-matrix-zge.lisp (original) +++ src/matrix/level2-matrix-zge.lisp Sun May 24 07:37:23 2009 @@ -147,6 +147,9 @@ ,form))) ,y))) +(defmethod .conj ((x matrix-lisp-zge)) + (each-element-function-matrix-zge x (conjugate x))) + ;;; Trignometric functions (defmethod .sin ((x matrix-lisp-zge)) Added: src/matrix/level2-view.lisp ============================================================================== --- (empty file) +++ src/matrix/level2-view.lisp Sun May 24 07:37:23 2009 @@ -0,0 +1,107 @@ +;;; Level2-view.lisp +;;; Matrix views + +;;; Copyright (C) 2009 Joern Inge Vestgaarden +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License along +;;; with this program; if not, write to the Free Software Foundation, Inc., +;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +(in-package :lisplab) + +#+todo-make-this(defmethod view-matrix (matrix shape &optional (type)) + "Outputs a function matrix" + (declare (ignore type)) + (let* ((rows (car shape)) + (cols (cadr shape)) + (size (* rows cols))) + (make-instance 'function-matrix + :rows rows + :cols cols + :size size + :element-type (element-type matrix) + :mref #'(lambda (x i j) + (declare (ignore x)) + (vref matrix (column-major-idx i j rows))) + :set-mref #'(lambda (value x i j) + (declare (ignore x)) + (setf (vref matrix (column-major-idx i j rows)) value)) + :vref #'(lambda (x i) + (declare (ignore x)) + (vref matrix i)) + :set-vref #'(lambda (value x i) + (declare (ignore x)) + (setf (vref matrix i) value))))) + +(defmethod view-row (matrix row) + "Outputs a function matrix." + (make-instance + 'function-matrix + :rows (cols matrix) + :cols 1 + :mref #'(lambda (x i j) + (declare (ignore x j)) + (mref matrix row i)) + :set-mref #'(lambda (value x i j) + (declare (ignore x i)) + (setf (mref matrix row j) value)) + :vref #'(lambda (x i) + (declare (ignore x)) + (mref matrix row i)) + :set-vref #'(lambda (value x i) + (declare (ignore x)) + (setf (mref matrix row i) value)))) + +(defmethod view-col (matrix col) + "Outputs a function matrix." + (make-instance + 'function-matrix + :rows (rows matrix) + :cols 1 + :mref #'(lambda (x i j) + (declare (ignore x j)) + (mref matrix i col)) + :set-mref #'(lambda (value x i j) + (declare (ignore x j)) + (setf (mref matrix i col) value)) + :vref #'(lambda (x i) + (declare (ignore x)) + (mref matrix i col)) + :set-vref #'(lambda (value x i) + (declare (ignore x)) + (setf (mref matrix i col) value)))) + +#+todo-make-this(defmethod view-transpose (matrix) + "Outputs a function matrix" + (make-instance 'function-matrix + :rows (cols matrix) + :cols (rows matrix) + :size (size matrix) + :element-type (element-type matrix) + :mref #'(lambda (x i j) + (declare (ignore x)) + (mref matrix j i)) + :set-mref #'(lambda (value x i j) + (declare (ignore x)) + (setf (mref matrix j i) value)) + :vref #'(lambda (x i) + (declare (ignore x)) + (vref matrix i)) + :set-vref #'(lambda (value x i) + (declare (ignore x)) + (setf (vref matrix i) value)))) + + + + + From jivestgarden at common-lisp.net Sun May 24 15:09:33 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sun, 24 May 2009 11:09:33 -0400 Subject: [lisplab-cvs] r43 - in src: core linalg matrix Message-ID: Author: jivestgarden Date: Sun May 24 11:09:27 2009 New Revision: 43 Log: bugfix Modified: src/core/level0-functions.lisp src/core/level0-generic.lisp src/linalg/level3-linalg-generic.lisp src/matrix/level2-constructors.lisp Modified: src/core/level0-functions.lisp ============================================================================== --- src/core/level0-functions.lisp (original) +++ src/core/level0-functions.lisp Sun May 24 11:09:27 2009 @@ -18,6 +18,44 @@ (in-package :lisplab) +(export '(.+ .* ./ .- .^ ^)) + +(defmethod matrix? ((a number)) nil) + +(defmethod vector? ((a number)) nil) + +(defmethod scalar? ((a number)) t) + +(defun ^ (x n) "Synonym for expt" (expt x n)) + +(defun .+ (&rest args) + "Generlized +. Reduces the arguments with .add." + (if (and args (cdr args)) + (reduce #'.add args) + (car args))) + +(defun .* (&rest args) + "Generalized *. Reduces the arguments with .mul." + (if (and args (cdr args)) + (reduce #'.mul args) + (car args))) + +(defun ./ (&rest args) + "Generalized /. Reduces the arguments with .div." + (if (and args (cdr args)) + (reduce #'.div args) + (./ 1 (car args)))) + +(defun .- (&rest args) + "Generalized -. Reduces the arguments with .sub." + (if (and args (cdr args)) + (reduce #'.sub args) + (.- 0 (car args)))) + +(defun .^ (&rest args) + "Generlized expt. Reduces the arguments with .expt." + (reduce #'.expt args)) + (defmethod .abs ((a number)) (abs a)) Modified: src/core/level0-generic.lisp ============================================================================== --- src/core/level0-generic.lisp (original) +++ src/core/level0-generic.lisp Sun May 24 11:09:27 2009 @@ -19,42 +19,4 @@ (in-package :lisplab) -(export '(.+ .* ./ .- .^ ^)) - -(defmethod copy (a) - ;; Hm this is dagenrous if someone forgets to overload copy. - a) - -(defmethod scalar? ((a number)) - t) ;; Is this right? - -(defun ^ (x n) "Synonym for expt" (expt x n)) - -(defun .+ (&rest args) - "Generlized +. Reduces the arguments with .add." - (if (and args (cdr args)) - (reduce #'.add args) - (car args))) - -(defun .* (&rest args) - "Generalized *. Reduces the arguments with .mul." - (if (and args (cdr args)) - (reduce #'.mul args) - (car args))) - -(defun ./ (&rest args) - "Generalized /. Reduces the arguments with .div." - (if (and args (cdr args)) - (reduce #'.div args) - (./ 1 (car args)))) - -(defun .- (&rest args) - "Generalized -. Reduces the arguments with .sub." - (if (and args (cdr args)) - (reduce #'.sub args) - (.- 0 (car args)))) - -(defun .^ (&rest args) - "Generlized expt. Reduces the arguments with .expt." - (reduce #'.expt args)) - +;; TODO delete file \ No newline at end of file Modified: src/linalg/level3-linalg-generic.lisp ============================================================================== --- src/linalg/level3-linalg-generic.lisp (original) +++ src/linalg/level3-linalg-generic.lisp Sun May 24 11:09:27 2009 @@ -36,7 +36,7 @@ b)) (defmethod mct ((a matrix-base)) - (mconj (mtp a))) + (.conj (mtp a))) (defmethod m* ((a matrix-base) (b matrix-base)) (let ((c (mcreate a 0 (list (rows a) (cols b))))) @@ -136,35 +136,32 @@ (setf (mref Pmat i (vref p i) ) 1)) (list L U Pmat)))) -(defun L-solve! (L x w/diag) - ;; Solve Lx=b - (setf (vref x 0) (./ (vref x 0) - (if w/diag (mref L 0 0) 1))) +(defun L-solve! (L x) + ;; Solves Lx=b (loop for i from 1 below (size x) do (let ((sum (vref x i))) (loop for j from 0 below i do (setf sum (.- sum (.* (mref L i j) (vref x j))))) - (setf (vref x i) - (./ sum - (if w/diag (mref L i i) 1))))) + (setf (vref x i) sum))) x) -(defun U-solve! (U x w/diag) +(defun U-solve! (U x) + ;; Solves Ux=b (let* ((N (size x)) (N-1 (1- N))) (setf (vref x N-1) (./ (vref x N-1) - (if w/diag (mref U N-1 N-1) 1))) + (mref U N-1 N-1))) (loop for i from (- N-1 1) downto 0 do (let ((sum (vref x i))) (loop for j from (1+ i) below N do (setf sum (.- sum (.* (mref U i j) (vref x j))))) (setf (vref x i) (./ sum - (if w/diag (mref U i i) 1))))) + (mref U i i))))) x)) (defun LU-solve! (LU x) - (L-solve! LU x nil) - (U-solve! LU x t) + (L-solve! LU x) + (U-solve! LU x) x) (defmethod lin-solve ((A matrix-base) (b matrix-base)) Modified: src/matrix/level2-constructors.lisp ============================================================================== --- src/matrix/level2-constructors.lisp (original) +++ src/matrix/level2-constructors.lisp Sun May 24 11:09:27 2009 @@ -25,6 +25,12 @@ dmat dnew dcol drow zmat znew zcol zrow)) +(defmethod copy ((a matrix-base)) + (let ((x (make-matrix-instance (class-of a) (dim a) 0))) + (dotimes (i (size x)) + (setf (vref x i) (vref a i))) + x)) + (defmethod mcreate ((a matrix-base) &optional (value 0) dim) (unless dim (setf dim (dim a))) From jivestgarden at common-lisp.net Sun May 24 18:08:34 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sun, 24 May 2009 14:08:34 -0400 Subject: [lisplab-cvs] r44 - src/core system Message-ID: Author: jivestgarden Date: Sun May 24 14:08:32 2009 New Revision: 44 Log: movd content to level1-functions Removed: src/core/level0-generic.lisp Modified: system/lisplab.asd Modified: system/lisplab.asd ============================================================================== --- system/lisplab.asd (original) +++ system/lisplab.asd Sun May 24 14:08:32 2009 @@ -17,7 +17,6 @@ (:file "level0-basic") (:file "level0-const") (:file "level0-interface") - (:file "level0-generic") (:file "level0-functions") (:file "level0-permutation") (:file "level0-infpre"))) From jivestgarden at common-lisp.net Wed May 27 17:56:15 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Wed, 27 May 2009 13:56:15 -0400 Subject: [lisplab-cvs] r45 - src/fft src/matlisp system Message-ID: Author: jivestgarden Date: Wed May 27 13:56:14 2009 New Revision: 45 Log: added ffiw lib. Not yet tested Added: src/fft/fftw-ffi-package.lisp src/fft/fftw-ffi.lisp src/fft/level3-fft-fftw.lisp src/matlisp/f77-package.lisp Modified: src/fft/level3-fft-blas.lisp src/matlisp/geev.lisp system/lisplab.asd system/package.lisp Added: src/fft/fftw-ffi-package.lisp ============================================================================== --- (empty file) +++ src/fft/fftw-ffi-package.lisp Wed May 27 13:56:14 2009 @@ -0,0 +1,25 @@ +;;; Copyright (C) 2009 Joern Inge Vestgaarden +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License along +;;; with this program; if not, write to the Free Software Foundation, Inc., +;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +(defpackage "FFTW-FFI" + (:use "COMMON-LISP" "SB-ALIEN" "SB-SYS") + (:export "+DOUBLE_FLOAT-BYTES+" + "+FFTW-ESTIMATE+" + "+FFTW-FORWARD+" + "+FFTW-BACKWARD+" + "FFTW-FFT1" + "FFTW-FFT2") + (:documentation "Simple ffi for fftw.")) Added: src/fft/fftw-ffi.lisp ============================================================================== --- (empty file) +++ src/fft/fftw-ffi.lisp Wed May 27 13:56:14 2009 @@ -0,0 +1,89 @@ +;;; Foreign function interfaces for FFTW + +;;; Copyright (C) 2009 Joern Inge Vestgaarden +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License along +;;; with this program; if not, write to the Free Software Foundation, Inc., +;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +(in-package :fftw-ffi) + +(defconstant +double-float-bytes+ (truncate (sb-alien:ALIEN-SIZE sb-alien:double-float) 8)) + +(defconstant +FFTW-ESTIMATE+ 64) + +(defconstant +FFTW-FORWARD+ -1) + +(defconstant +FFTW-BACKWARD+ 1) + +(declaim (inline |fftw_plan_dft_1d|)) +(define-alien-routine |fftw_plan_dft_1d| + (* t) + (n int) + (in (* double-float)) + (out (* double-float)) + (sign int) + (flags int)) + +(declaim (inline |fftw_plan_dft_2d|)) +(define-alien-routine |fftw_plan_dft_2d| + (* t) + (n0 int) + (n1 int) + (in (* double-float)) + (out (* double-float)) + (sign int) + (flags int)) + +(declaim (inline |fftw_execute|)) +(define-alien-routine |fftw_execute| + void + (plan (* t))) + +(declaim (inline |fftw_destroy_plan|)) +(define-alien-routine |fftw_destroy_plan| + void + (plan (* t))) + +(defun fftw-fft1 (n a astart b bstart direction flag) + "One dimensional fft by forign call to fftw." + ;; TODO we should handle conditions to avoid mem-leaks + (let ((astart (* astart +double-float-bytes+)) + (bstart (* bstart +double-float-bytes+))) + (without-gcing + (let ((plan (|fftw_plan_dft_1d| + n + (sap+ (vector-sap a) astart) + (sap+ (vector-sap b) bstart) + direction + flag))) + (|fftw_execute| plan) + (|fftw_destroy_plan| plan))) + b)) + +(defun fftw-fft2 (m n in out direction flag) + "Two dimensional fft by forign call to fftw." + ;; TODO we should handle conditions to avoid mem-leaks + (without-gcing + (let ((plan (|fftw_plan_dft_2d| + n ; swap n and m due to row major order + m + (vector-sap in) + (vector-sap out) + direction + flag))) + (|fftw_execute| plan) + (|fftw_destroy_plan| plan))) + out) + + Modified: src/fft/level3-fft-blas.lisp ============================================================================== --- src/fft/level3-fft-blas.lisp (original) +++ src/fft/level3-fft-blas.lisp Wed May 27 13:56:14 2009 @@ -52,6 +52,8 @@ (defmethod fft2 ((x matrix-lisp-zge)) (fft2! (copy x))) +;;;; The implementing methods + (defmethod fft1! ((x matrix-lisp-zge)) (dotimes (i (cols x)) (fft-radix-2-blas-complex-store! :f (matrix-store x) (rows x) (* (rows x) i) 1)) Added: src/fft/level3-fft-fftw.lisp ============================================================================== --- (empty file) +++ src/fft/level3-fft-fftw.lisp Wed May 27 13:56:14 2009 @@ -0,0 +1,59 @@ +;;; Level3-fft-fftw.lisp, fast fourier by fftw. + +;;; Copyright (C) 2009 Joern Inge Vestgaarden +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License along +;;; with this program; if not, write to the Free Software Foundation, Inc., +;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +(in-package :lisplab) + +(defun fft1!-forward-or-backward (x direction) + (let* ((rows (rows x)) + (cols (cols x)) + (store (matrix-store x))) + (print "allois") + (dotimes (i cols) + (fftw-ffi:fftw-fft1 + rows + store + (* i cols) + store + (* i cols) + direction + fftw-ffi:+FFTW-ESTIMATE+))) + x) + +(defmethod fft1! ((x matrix-blas-zge)) + (fft1!-forward-or-backward x fftw-ffi:+fftw-forward+)) + +(defmethod ifft1! ((x matrix-blas-zge)) + (fft1!-forward-or-backward x fftw-ffi:+fftw-backward+)) + +(defmethod fft2! ((x matrix-blas-zge)) + (fftw-ffi:fftw-fft2 + (rows x) + (cols x) + (matrix-store x) + (matrix-store x) + fftw-ffi:+fftw-forward+ + fftw-ffi:+FFTW-ESTIMATE+)) + +(defmethod fft2! ((x matrix-blas-zge)) + (fftw-ffi:fftw-fft2 + (rows x) + (cols x) + (matrix-store x) + (matrix-store x) + fftw-ffi:+fftw-backward+ + fftw-ffi:+FFTW-ESTIMATE+)) Added: src/matlisp/f77-package.lisp ============================================================================== --- (empty file) +++ src/matlisp/f77-package.lisp Wed May 27 13:56:14 2009 @@ -0,0 +1,5 @@ + +(defpackage "F77" + (:use "COMMON-LISP" "SB-EXT" "FORTRAN-FFI-ACCESSORS") + ;; I'm too lazy to export. Just force way to get the functions. + (:documentation "Wrappers for Fortran functions")) \ No newline at end of file Modified: src/matlisp/geev.lisp ============================================================================== --- src/matlisp/geev.lisp (original) +++ src/matlisp/geev.lisp Wed May 27 13:56:14 2009 @@ -49,7 +49,7 @@ (defmethod rearrange-eigenvector-matrix ((evals matrix-blas-zge) (p matrix-blas-dge)) (let* ((n (size evals)) - (evec (cnew 0 n n))) + (evec (znew 0 n n))) ; TODO aggregate input type (do ((col 0 (incf col))) ((>= col n)) (if (zerop (imagpart (vref evals col ))) @@ -165,7 +165,7 @@ (let* ((n (rows a)) (2n (* 2 n)) (xxx (allocate-real-store 2)) - (w (cnew 0 n 1)) + (w (znew 0 n 1)) ; TODO aggregate type (vl (if vl-mat (matrix-store vl-mat) xxx)) (vr (if vr-mat (matrix-store vr-mat) xxx)) (lwork (zgeev-workspace-size n (if vl-mat t nil) (if vr-mat t nil))) Modified: system/lisplab.asd ============================================================================== --- system/lisplab.asd (original) +++ system/lisplab.asd Wed May 27 13:56:14 2009 @@ -121,7 +121,7 @@ :pathname "../src/matlisp/" :serial t :components - ( + ((:file "f77-package") (:file "f77-mangling") (:file "ffi-sbcl") (:file "blas") @@ -138,6 +138,21 @@ (dolist (lib asdf::*lisplab-external-libraries*) (format t "Loads alien object <~A>" lib)))) + + ;; + ;; Blas and Lapack implmentations (Level 3) + ;; + (:module :fftw + :depends-on (:matrix :fft) + :pathname "../src/fft/" + :serial t + :components + ((:file "fftw-ffi-package") + (:file "fftw-ffi") + (:file "level3-fft-fftw")) + :perform (asdf:load-op :after (op c) + (sb-alien:load-shared-object "/usr/lib/libfftw3.so.3"))) + ;; ;; Euler and Runge-Kutt solvers (Level 3) ;; Modified: system/package.lisp ============================================================================== --- system/package.lisp (original) +++ system/package.lisp Wed May 27 13:56:14 2009 @@ -17,6 +17,8 @@ ;;; with this program; if not, write to the Free Software Foundation, Inc., ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +;;; TODO split this out + (defpackage "LISPLAB" (:nicknames "LL") (:use "COMMON-LISP" "SB-EXT") @@ -29,10 +31,6 @@ "INCF-SAP" "WITH-VECTOR-DATA-ADDRESSES") (:documentation "Fortran foreign function interface")) - -(defpackage "F77" - (:use "COMMON-LISP" "SB-EXT" "FORTRAN-FFI-ACCESSORS") - (:documentation "Wrappers for Fortran functions")) (defpackage "LISPLAB-BLAS" (:nicknames "LL-BLAS")