From jivestgarden at common-lisp.net Sun Mar 1 10:44:25 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sun, 01 Mar 2009 10:44:25 +0000 Subject: [lisplab-cvs] r2 - src src/matlisp Message-ID: Author: jivestgarden Date: Sun Mar 1 10:44:24 2009 New Revision: 2 Log: bugix in geev. Cleaning. Modified: src/level3-linalg-interface.lisp src/matlisp/geev.lisp start.lisp Modified: src/level3-linalg-interface.lisp ============================================================================== --- src/level3-linalg-interface.lisp (original) +++ src/level3-linalg-interface.lisp Sun Mar 1 10:44:24 2009 @@ -21,67 +21,66 @@ (export '(mtp mtp! mconj mconj! mct mct! mtr mdet minv! minv - m* m*! m/ m/!)) + m* m*! m/ m/! + LU-factor LU-factor! + lin-solve + eigenvalues + eigenvectors)) (defgeneric mtp (matrix) - (:documentation "Matrix transpose")) + (:documentation "Matrix transpose.")) (defgeneric mtp! (matrix) - (:documentation "Matrix transpose. Destructive")) + (:documentation "Matrix transpose. Destructive.")) (defgeneric mconj (matrix) - (:documentation "Matrix conjugate")) + (:documentation "Matrix conjugate.")) (defgeneric mconj! (matrix) - (:documentation "Matrix conjugate. Destructive")) + (:documentation "Matrix conjugate. Destructive.")) (defgeneric mct (matrix) - (:documentation "Matrix conjugate transpose")) + (:documentation "Matrix conjugate transpose.")) (defgeneric mct! (matrix) - (:documentation "Matrix conjugate transpose. Destructive")) + (:documentation "Matrix conjugate transpose. Destructive.")) (defgeneric mtr (matrix) - (:documentation "Matrix trace (sum of diagonal elements)")) + (:documentation "Matrix trace (sum of diagonal elements).")) (defgeneric mdet (matrix) - (:documentation "Matrix determinant")) + (:documentation "Matrix determinant.")) (defgeneric minv! (a) - (:documentation "Matrix inverse. Destructive")) + (:documentation "Matrix inverse. Destructive.")) (defgeneric minv (a) - (:documentation "Matrix inverse")) + (:documentation "Matrix inverse.")) (defgeneric m* (a b) - (:documentation "Matrix product")) + (:documentation "Matrix product.")) (defgeneric m*! (a b) - (:documentation "Matrix product. Destructive")) + (:documentation "Matrix product. Destructive.")) (defgeneric m/ (a b) - (:documentation "Short for (m* a (minv b))")) + (:documentation "Short for (m* a (minv b)).")) (defgeneric m/! (a b) - (:documentation "Short for (m*! a (minv b)). Destructive")) + (:documentation "Short for (m*! a (minv b)). Destructive.")) (defgeneric LU-factor! (matrix pivotes) (:documentation "LU-factorization with pivoting. Destructive.")) (defgeneric LU-factor (matrix) (:documentation "LU-factorization with pivoting. Outputs (m p) where -m is the LU-matrix and p is the pivot permutations")) - -#+nil (defgeneric L-solve (L b w/diag) - (:documentation "Solves the system Lx=b, when L is an upper triangular matrix")) - -#+nil (defgeneric U-solve (U b w/diag) - (:documentation "Solves the system Ux=b, when U is an upper triangular matrix")) - -#+nil (defgeneric LU-solve (LU b) - (:documentation "Solves the system LUx=Pb, when L,U,and P are the outputs from -the LU-factorization")) +m is the LU-matrix and p is the pivot permutations.")) (defgeneric lin-solve (A b) - (:documentation "Solves the linear system of equations Ax=b")) + (:documentation "Solves the linear system of equations Ax=b.")) + +(defgeneric eigenvectors (a) + (:documentation "Returns (P d) where P is matrix of right eigenvector and d is a vector of eigenvalues.")) +(defgeneric eigenvalues (a) + (:documentation "Returns the vector of eigenvalues.")) Modified: src/matlisp/geev.lisp ============================================================================== --- src/matlisp/geev.lisp (original) +++ src/matlisp/geev.lisp Sun Mar 1 10:44:24 2009 @@ -32,20 +32,6 @@ (in-package :lisplab) -(defgeneric eigenvectors (a) - (:documentation "Returns (P d) where P is matrix of right eigenvector and d is a vector of eigenvalues")) - -(defgeneric eigenvalues (a) - (:documentation "Returns the vector of eigenvalues")) - -(defgeneric diagonalize (a) - (:documentation "Return (U D V) where A=UDV, and D is diagnoal matrix.")) - -(defmethod diagonalize ((a blas-real)) - (destructuring-bind (evals vl-mat vr-mat) - (dgeev (copy a) (create a 0) (create a 0)) - (list vl-mat (diag evals) vr-mat))) - (defmethod eigenvectors ((a blas-real)) (destructuring-bind (evals vl-mat vr-mat) (dgeev (copy a) nil (create a 0)) @@ -57,7 +43,8 @@ evals)) (defgeneric rearrange-eigenvector-matrix (v p)) -(defmethod rearrange-eigenvector-matrix ((v blas-real) (p blas-real)) + +(defmethod rearrange-eigenvector-matrix (v p) p) (defmethod rearrange-eigenvector-matrix ((evals blas-complex) (p blas-real )) @@ -110,6 +97,7 @@ (ceiling (realpart (aref work 0)))))) (defun dgeev (a vl-mat vr-mat) + "Wrapper for f77:dgeev. Potentially destructive." (let* ((n (rows a)) (xxx (allocate-real-store 1)) (wr (allocate-real-store n)) @@ -140,502 +128,65 @@ (vr-mat2 (rearrange-eigenvector-matrix evec vr-mat))) (list evec vl-mat2 vr-mat2))))) -(defmethod eigenvectors ((a blas-complex)) - (destructuring-bind (w p) - (zgeev-right! (copy a) (create a 0)) - (list p w))) - +(defmethod eigenvectors ((a blas-complex)) + (destructuring-bind (evals vl-mat vr-mat) + (zgeev (copy a) nil (create a 0)) + (list evals vr-mat))) + (defmethod eigenvalues ((a blas-complex)) - (car (zgeev-right! (copy a) nil))) + (destructuring-bind (evals vl-mat vr-mat) + (zgeev (copy a) nil nil) + evals)) -(defun zgeev-workspace-size (n vectors?) +(defun zgeev-workspace-size (n lv? rv?) ;; Ask geev how much space it wants for the work array (let* ((work (allocate-real-store 1))) - (multiple-value-bind (store-a store-w store-vl store-vr work info) - (f77::zgeev - "N" - (if vectors? "V" "N") - n ; N - work ; A - n ; LDA - work ; W - work ; VL - 1 ; LDVL - work ; VR - (if vectors? n 1) ; LDVR - work ; WORK - -1 ; LWORK - work ; RWORK - 0 ) ; INFO - (declare (ignore store-a store-w store-vl store-vr info)) - ;; The desired size in in work[0], which we convert to an - ;; integer. - (ceiling (aref work 0))))) + (f77::zgeev + (if lv? "V" "N") + (if rv? "V" "N") + n ; N + work ; A + n ; LDA + work ; W + work ; VL + (if lv? n 1) ; LDVL + work ; VR + (if rv? n 1) ; LDVR + work ; WORK + -1 ; LWORK + work ; RWORK + 0 ) ; INFO + ;; The desired size in in work[0], which we convert to an + ;; integer. + (ceiling (aref work 0)))) -(defun zgeev-right! (a vr-mat) +(defun zgeev (a vl-mat vr-mat) + "Wrapper for f77:zgeev. Potentially destructive." (let* ((n (rows a)) (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)) - (lwork (zgeev-workspace-size n (if vr-mat t nil))) + (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))) - (multiple-value-bind (store-a store-w store-vl store-vr work info) - (f77::zgeev - "N" ;; JOBVL - (if vr-mat "V" "N") ;; JOBVR - n ;; N - (store a) ;; A - n ;; LDA - (store w) ;; W - xxx ;; VL - 1 ;; LDVL - vr ;; VR - (if vr-mat n 1) ;; LDVR - work ;; WORK - lwork ;; LWORK - rwork ;; RWORK - 0 ) ;; INFO - (declare (ignore store-a store-w store-vl store-vr work)) - (list w vr-mat) - ))) - -#+nil (defun geev-values (a) - (destructuring-bind (wr wi vr) - (dgeev-right! (copy a) nil) - (let* ((n (rows a)) - (wr2 (convert (make-instance 'blas-real :rows n :cols 1 :size n :store wr) - 'blas-complex)) - (wi2 (convert (make-instance 'blas-real :rows n :cols 1 :size n :store wi) - 'blas-complex))) - (.+ wr2 (.* %i wi2))))) - -#+nil (defun geev-vectors (a) - (destructuring-bind (wr wi vr) - (dgeev-right! (copy a) (create a 0)) - (let* ((n (rows a)) - (wr2 (convert (make-instance 'blas-real :rows n :cols 1 :size n :store wr) - 'blas-complex)) - (wi2 (convert (make-instance 'blas-real :rows n :cols 1 :size n :store wi) - 'blas-complex)) - (evals (.+ wr2 (.* %i wi2))) - (vr2 (make-instance 'blas-real :rows n :cols n :size (* n n) :store vr)) - (evec (cnew 0 n n))) - (do ((col 0 (incf col))) - ((>= col n)) - (if (zerop (imagpart (vref evals col ))) - (dotimes (row n) - (setf (mref evec row col) - (mref vr2 row col))) - (progn - (dotimes (row n) - (let ((c (complex (mref vr2 row col) (mref vr2 row (1+ col))))) - (setf (mref evec row col) c - (mref evec row (1+ col)) (conjugate c)))) - (incf col)))) - (list evals evec)))) - - - - - - - - - - - - - - -#+nil (defgeneric geev (a) - (:documentation "")) - -#+nil (defun dgeev-workspace-inquiry (n job) - ;; Ask geev how much space it wants for the work array - (multiple-value-bind (jobvl jobvr) - (case job - (:nn (values "N" "N")) - ((:vn t) (values "N" "V")) - (:nv (values "V" "N")) - (:vv (values "V" "V"))) - (let* ((work (allocate-real-store 1)) - (ldvr (if (equal jobvr "V") n 1)) - (ldvl (if (equal jobvl "V") n 1))) - (multiple-value-bind (store-a store-wr store-wi store-vl store-vr - work info) - (f77::dgeev jobvl - jobvr - n ; N - work ; A - n ; LDA - work ; WR - work ; WI - work ; VL - ldvl ; LDVL - work ; VR - ldvr ; LDVR - work ; WORK - -1 ; LWORK - 0 ) ; INFO - (declare (ignore store-a store-wr store-wi store-vl store-vr)) - (assert (zerop info)) - (ceiling (realpart (aref work 0))))))) - -#+nil (defmethod geev ((a blas-real)) - (let* ((n (rows a)) - (a (copy a)) - (xxx (allocate-real-store 1)) - (wr (allocate-real-store n)) - (wi (allocate-real-store n)) - (lwork (dgeev-workspace-inquiry n :nn)) - (work (allocate-real-store lwork))) - (format t "Now call fortran. Lwork = ~A " lwork) - (multiple-value-bind (a wr wi vl vr work info) - (f77::dgeev "N" ; JOBVL - "N" ; JOBVR - n ; N - (store a) ; A - n ; LDA - wr ; WR - wi ; WI - xxx ; VL - 1 ; LDVL - xxx ; VR - 1 ; LDVR - work ; WORK - lwork ; LWORK - 0 ) ; INFO - (declare (ignore a work)) - (if (zerop info) - (values n wr wi vr vl nil nil) - (values nil nil))))) - - - -#| - - -(defun geev-fix-up-eigen (n wr wi vr vl left-eig right-eig) - (let ((res nil) - ;; Eigenvalues are real unless the max of wi is not zero. - (real-eig (zerop (aref wi (1- (blas::idamax n wi 1)))))) - - (when right-eig - (push (geev-fix-up-eigvec n real-eig wi vr) res)) - - (if real-eig - (if (or right-eig left-eig) - (let ((eigval (make-real-matrix n n))) - (dotimes (k n) - (setf (matrix-ref eigval k k) (aref wr k))) - (push eigval res)) - (let ((eigval (make-real-matrix n 1))) - (dotimes (k n) - (setf (matrix-ref eigval k) (aref wr k))) - (push eigval res))) - (if (or right-eig left-eig) - (let ((eigval (make-complex-matrix n n))) - (dotimes (k n) - (setf (matrix-ref eigval k k) (complex (aref wr k) (aref wi k)))) - (push eigval res)) - (let ((eigval (make-complex-matrix n 1))) - (dotimes (k n) - (setf (matrix-ref eigval k) (complex (aref wr k) (aref wi k)))) - (push eigval res)))) - - (when left-eig - (push (geev-fix-up-eigvec n real-eig wi vl) res)) - - (push t res) - (values-list (nreverse res)))) - - -(let ((work (allocate-real-store 1))) - (defun dgeev-workspace-inquiry (n job) - ;; Ask geev how much space it wants for the work array - (multiple-value-bind (jobvl jobvr) - (case job - (:nn (values "N" "N")) - ((:vn t) (values "N" "V")) - (:nv (values "V" "N")) - (:vv (values "V" "V"))) - - (let* ((ldvr (if (equal jobvr "V") n 1)) - (ldvl (if (equal jobvl "V") n 1))) - - (multiple-value-bind (store-a store-wr store-wi store-vl store-vr - work info) - (dgeev jobvl - jobvr - n ; N - work ; A - n ; LDA - work ; WR - work ; WI - work ; VL - ldvl ; LDVL - work ; VR - ldvr ; LDVR - work ; WORK - -1 ; LWORK - 0 ) ; INFO - (declare (ignore store-a store-wr store-wi store-vl store-vr)) - (assert (zerop info)) - (ceiling (realpart (aref work 0)))))))) - - -(defmethod geev ((a real-matrix) &optional (job :NN)) - (let* ((n (nrows a)) - (a (copy a)) - (xxx (allocate-real-store 1)) - (wr (allocate-real-store n)) - (wi (allocate-real-store n)) - (lwork (dgeev-workspace-inquiry n job)) - (work (allocate-real-store lwork))) - - (declare (type fixnum n) - (type (simple-array real-matrix-element-type (*)) xxx wr wi)) - - (case job - (:nn - (multiple-value-bind (a wr wi vl vr work info) - (dgeev "N" ; JOBVL - "N" ; JOBVR - n ; N - (store a) ; A - n ; LDA - wr ; WR - wi ; WI - xxx ; VL - 1 ; LDVL - xxx ; VR - 1 ; LDVR - work ; WORK - lwork ; LWORK - 0 ) ; INFO - (declare (ignore a work)) - (if (zerop info) - (geev-fix-up-eigen n wr wi vr vl nil nil) - (values nil nil)))) - - ((:vn t) - (let* ((vr (allocate-real-store (* n n)))) - (multiple-value-bind (a wr wi vl vr work info) - (dgeev "N" ;; JOBVL - "V" ;; JOBVR - n ;; N - (store a) ;; A - n ;; LDA - wr ;; WR - wi ;; WI - xxx ;; VL - 1 ;; LDVL - vr ;; VR - n ;; LDVR - work ;; WORK - lwork ;; LWORK - 0 ) ;; INFO - (declare (ignore a work)) - (if (zerop info) - (geev-fix-up-eigen n wr wi vr vl nil t) - (values nil nil))))) - - (:nv - (let* ((vl (allocate-real-store (* n n)))) - - (multiple-value-bind (a wr wi vl vr work info) - (dgeev "V" ;; JOBVL - "N" ;; JOBVR - n ;; N - (store a) ;; A - n ;; LDA - wr ;; WR - wi ;; WI - vl ;; VL - n ;; LDVL - xxx ;; VR - 1 ;; LDVR - work ;; WORK - lwork ;; LWORK - 0 ) ;; INFO - (declare (ignore a work)) - (if (zerop info) - (geev-fix-up-eigen n wr wi vr vl t nil) - (values nil nil))))) - - (:vv - (let* ((vl (allocate-real-store (* n n))) - (vr (allocate-real-store (* n n)))) - - (multiple-value-bind (a wr wi vl vr work info) - (dgeev "V" ;; JOBVL - "V" ;; JOBVR - n ;; N - (store a) ;; A - n ;; LDA - wr ;; WR - wi ;; WI - vl ;; VL - n ;; LDVL - vr ;; VR - n ;; LDVR - work ;; WORK - lwork ;; LWORK - 0 ) ;; INFO - (declare (ignore a work)) - (if (zerop info) - (geev-fix-up-eigen n wr wi vr vl t t) - (values nil nil))))) - - - ))) - - -(let ((work (allocate-complex-store 1))) - (defun zgeev-workspace-inquiry (n job) - ;; Ask geev how much space it wants for the work array - (multiple-value-bind (jobvl jobvr) - (case job - (:nn (values "N" "N")) - ((:vn t) (values "N" "V")) - (:nv (values "V" "N")) - (:vv (values "V" "V"))) - - (let* ((ldvr (if (equal jobvr "V") n 1)) - (ldvl (if (equal jobvl "V") n 1))) - - (multiple-value-bind (store-a store-w store-vl store-vr work info) - (zgeev jobvl - jobvr - n ; N - work ; A - n ; LDA - work ; W - work ; VL - 1 ; LDVL - work ; VR - ldvr ; LDVR - work ; WORK - -1 ; LWORK - work ; RWORK - 0 ) ; INFO - (declare (ignore store-a store-w store-vl store-vr info)) - ;; The desired size in in work[0], which we convert to an - ;; integer. - (ceiling (aref work 0))))))) - -;; Hmm, should this really be 4 (5) different methods, one for each -;; possible value of job? - -(defmethod geev ((a complex-matrix) &optional (job :NN)) - (let* ((n (nrows a)) - (a (copy a)) - (w (make-complex-matrix-dim n 1)) - (xxx (allocate-complex-store 1)) - (lwork (zgeev-workspace-inquiry n job)) - (work (allocate-complex-store lwork)) - (rwork (allocate-complex-store n))) - - (declare (type fixnum lwork n) - (type (simple-array complex-matrix-element-type (*)) xxx work) - (type (simple-array real-matrix-element-type (*)) rwork)) - - (case job - (:nn - (multiple-value-bind (store-a store-w store-vl store-vr work info) - (zgeev "N" ; JOBVL - "N" ; JOBVR - n ; N - (store a) ; A - n ; LDA - (store w) ; W - xxx ; VL - 1 ; LDVL - xxx ; VR - 1 ; LDVR - work ; WORK - lwork ; LWORK - rwork ; RWORK - 0 ) ; INFO - (declare (ignore store-a store-w store-vl store-vr work)) - (if (zerop info) - (values w t) - (values nil nil)))) - - ((:vn t) - (let* ((vr (make-complex-matrix-dim n n))) - - (multiple-value-bind (store-a store-w store-vl store-vr work info) - (zgeev "N" ;; JOBVL - "V" ;; JOBVR - n ;; N - (store a) ;; A - n ;; LDA - (store w) ;; W - xxx ;; VL - 1 ;; LDVL - (store vr) ;; VR - n ;; LDVR - work ;; WORK - lwork ;; LWORK - rwork ;; RWORK - 0 ) ;; INFO - (declare (ignore store-a store-w store-vl store-vr work)) - (if (zerop info) - (values vr (diag w) t) - (values nil nil))))) - - (:nv - (let* ((vl (make-complex-matrix-dim n n))) - - (multiple-value-bind (store-a store-w store-vl store-vr work info) - (zgeev "V" ;; JOBVL - "N" ;; JOBVR - n ;; N - (store a) ;; A - n ;; LDA - (store w) ;; W - (store vl) ;; VL - n ;; LDVL - xxx ;; VR - 1 ;; LDVR - work ;; WORK - lwork ;; LWORK - rwork ;; RWORK - 0 ) ;; INFO - (declare (ignore store-a store-w store-vl store-vr work)) - (if (zerop info) - (values (diag w) vl t) - (values nil nil))))) - - (:vv - (let* ((vr (make-complex-matrix-dim n n)) - (vl (make-complex-matrix-dim n n))) - - - (multiple-value-bind (store-a store-w store-vl store-vr work info) - (zgeev "V" ;; JOBVL - "V" ;; JOBVR - n ;; N - (store a) ;; A - n ;; LDA - (store w) ;; W - (store vl) ;; VL - n ;; LDVL - (store vr) ;; VR - n ;; LDVR - work ;; WORK - lwork ;; LWORK - rwork ;; RWORK - 0 ) ;; INFO - (declare (ignore store-a store-w store-vl store-vr work)) - (if (zerop info) - (values vr (diag w) vl t) - (values nil nil))))) - - - ))) - -|# \ No newline at end of file + ;; TODO get info for error + (f77::zgeev + (if vl-mat "V" "N") ;; JOBVL + (if vr-mat "V" "N") ;; JOBVR + n ;; N + (store a) ;; A + n ;; LDA + (store w) ;; W + vl ;; VL + (if vl-mat n 1) ;; LDVL + vr ;; VR + (if vr-mat n 1) ;; LDVR + work ;; WORK + lwork ;; LWORK + rwork ;; RWORK + 0 ) ;; INFO + (let* ((vl-mat2 (rearrange-eigenvector-matrix w vl-mat)) + (vr-mat2 (rearrange-eigenvector-matrix w vr-mat))) + (list w vl-mat2 vr-mat2)))) Modified: start.lisp ============================================================================== --- start.lisp (original) +++ start.lisp Sun Mar 1 10:44:24 2009 @@ -5,25 +5,8 @@ *default-pathname-defaults*) *central-registry*) -(defparameter *lisplab-external-libraries* '("/usr/lib/atlas/libblas.so.3.0" - "/usr/lib/atlas/liblapack.so.3.0")) - -#+nil (defmethod asdf:perform :after ((op asdf:load-op) (c (eql :lisplab-matlisp))) - (print "hei") - (sb-alien:load-shared-object "/usr/lib/atlas/libblas.so.3.0") - (sb-alien:load-shared-object "/usr/lib/atlas/liblapack.so.3.0")) +(defparameter *lisplab-external-libraries* + '("/usr/lib/atlas/libblas.so.3.0" + "/usr/lib/atlas/liblapack.so.3.0")) (asdf:operate 'asdf:load-op 'lisplab) - -#+nil (in-package :ll) - -#+nil (run-program "/usr/bin/make" '("-C" "lib-src")) - -#+nil (load-libs "lib/") - -#+nil (asdf:operate 'asdf:load-op 'brandt) - -#+nil (in-dir "fft-sim/" - (load "region.lisp") - (load "fft-sim.lisp") - (load "script.lisp")) From jivestgarden at common-lisp.net Sun Mar 1 10:45:55 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sun, 01 Mar 2009 10:45:55 +0000 Subject: [lisplab-cvs] r3 - lib-src shared system Message-ID: Author: jivestgarden Date: Sun Mar 1 10:45:54 2009 New Revision: 3 Log: changed name of shared directory Added: shared/ (props changed) - copied from r1, /lib-src/ Removed: lib-src/ Modified: system/lisplab.asd Modified: system/lisplab.asd ============================================================================== --- system/lisplab.asd (original) +++ system/lisplab.asd Sun Mar 1 10:45:54 2009 @@ -125,7 +125,7 @@ ;; (:module "f2cl-lib" :depends-on () - :pathname "../lib-src/quadpack/" + :pathname "../shared/quadpack/" :components ((:file "f2cl-package") (:file "f2cl-macros") @@ -137,7 +137,7 @@ ;; (:module "quadpack" :depends-on ("f2cl-lib") - :pathname "../lib-src/quadpack/" + :pathname "../shared/quadpack/" :serial t :components ( From jivestgarden at common-lisp.net Sun Mar 1 11:13:48 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sun, 01 Mar 2009 11:13:48 +0000 Subject: [lisplab-cvs] r4 - src Message-ID: Author: jivestgarden Date: Sun Mar 1 11:13:48 2009 New Revision: 4 Log: Minor README documentation Added: Makefile README Removed: src/README Added: Makefile ============================================================================== --- (empty file) +++ Makefile Sun Mar 1 11:13:48 2009 @@ -0,0 +1,14 @@ + +first: + echo "Plase specify target." + +touch: + touch system/lisplab.asd + +lispclean: + -find . -name "*.fasl" -execdir rm \{} \; + +clean: lispclean + +distclean: clean + -find . -name "*~" -execdir rm \{} \; \ No newline at end of file Added: README ============================================================================== --- (empty file) +++ README Sun Mar 1 11:13:48 2009 @@ -0,0 +1,47 @@ +INTRODUCTION +Lisplab is a mathematics library for common lisp. +Directory structure: + src/ Lisplab source code + src/matliap From the Matlisp project. Rewritten for Lisplab matrices. + shared/ Unmodified code from other projects. + doc/ Documentation. + system/ Package and asdf-system definitions. + + +NAMING CONVENTION +The levels in the names of source code is dependency levels: +level 0: + Methods that work on non-index objects, + but the methods here are also typically reimplemented + for matrices. + Exampels: copy, .+, .*, ... +level 1: + Basic matrix/tensor methods for indexing, element reference + and dimensionality. In order to make a new kind of matrix, all + mathods on this level must be reimplmented. + Examples: mref, dim, rows, cols, new, ... +level 2: + Basic functionality related to matrices. + Examples: mmax, mmap, diag, ... +level 3: + Linear algebra and anything else based on the matrices. + Examples: minv, m*, ... + + +INSTALLING +Lisplab is asdf-installable. It has only been tested on SBCL on Linux, +but should be fairly portable to other platforms, as soon as some minor +dependencies of the package sb-ext are resolved. + +The Matlisp linear algebra depends on externally libraries and these must +be specified in the variable asdf:*lisplab-external-libraries* before loading, +as seen in start.lisp. The order of the libraries matter and Blas must be +before Lapack. + +On Linux the Blas and Lapack libraries can often be installed by the operating +system package system. In Ubuntu, to get the Atlas build of Blas/Lapack, type + % aptitude install libatlas3gf-base + + + + From jivestgarden at common-lisp.net Sun Mar 1 11:30:43 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sun, 01 Mar 2009 11:30:43 +0000 Subject: [lisplab-cvs] r5 - Message-ID: Author: jivestgarden Date: Sun Mar 1 11:30:43 2009 New Revision: 5 Log: Doc Modified: README TODO Modified: README ============================================================================== --- README (original) +++ README Sun Mar 1 11:30:43 2009 @@ -1,5 +1,6 @@ INTRODUCTION -Lisplab is a mathematics library for common lisp. +Lisplab is a mathematics library for common lisp, released under GPL. + Directory structure: src/ Lisplab source code src/matliap From the Matlisp project. Rewritten for Lisplab matrices. @@ -7,8 +8,14 @@ doc/ Documentation. system/ Package and asdf-system definitions. +STATUS +The project is not in finished state and names will change without warning. +However, the basic matrix code is a level where it is useful for doing +mathematical modelling. NAMING CONVENTION +The files including "interface" in the name defines generic functions only. +The files including "generic" in the name defines only unspecialized methods. The levels in the names of source code is dependency levels: level 0: Methods that work on non-index objects, @@ -43,5 +50,7 @@ % aptitude install libatlas3gf-base - - +GOOD TO KNOW +Lisplab only works with double floats and single-floats should not be used. +To ensure this, use +(setf *READ-DEFAULT-FLOAT-FORMAT* 'double-float) Modified: TODO ============================================================================== --- TODO (original) +++ TODO Sun Mar 1 11:30:43 2009 @@ -1,3 +1,14 @@ -TODOS -* Check if there is some non-threadsafe code in the fortran interface, +TODO +o Check if there is some non-threadsafe code in the fortran interface, 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. +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. + \ No newline at end of file From jivestgarden at common-lisp.net Sun Mar 1 11:44:17 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sun, 01 Mar 2009 11:44:17 +0000 Subject: [lisplab-cvs] r6 - Message-ID: Author: jivestgarden Date: Sun Mar 1 11:44:17 2009 New Revision: 6 Log: Doc Modified: TODO Modified: TODO ============================================================================== --- TODO (original) +++ TODO Sun Mar 1 11:44:17 2009 @@ -4,6 +4,8 @@ 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 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. From jivestgarden at common-lisp.net Sun Mar 1 13:24:41 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sun, 01 Mar 2009 13:24:41 +0000 Subject: [lisplab-cvs] r7 - src/test Message-ID: Author: jivestgarden Date: Sun Mar 1 13:24:41 2009 New Revision: 7 Log: test catalog Added: src/test/ From jivestgarden at common-lisp.net Sun Mar 1 19:27:45 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sun, 01 Mar 2009 19:27:45 +0000 Subject: [lisplab-cvs] r8 - src Message-ID: Author: jivestgarden Date: Sun Mar 1 19:27:44 2009 New Revision: 8 Log: Bufix and example Added: example.lisp Modified: src/level1-blas-complex.lisp Added: example.lisp ============================================================================== --- (empty file) +++ example.lisp Sun Mar 1 19:27:44 2009 @@ -0,0 +1,57 @@ +;;; A simple demonstration of how to use lisplab + +(in-package :ll) + +;;; 19 ways to create a matrix +(defparameter *test-matrices* + (list + + ;; 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) + + ;; 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) + + ;; 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))))) + +(mapcar (lambda (x) (mref x 0 0)) *test-matrices*) + +(mapcar (lambda (x) (vref x 2)) *test-matrices*) + +;; 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)))) + (.+ (.* 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)))) + (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))) Modified: src/level1-blas-complex.lisp ============================================================================== --- src/level1-blas-complex.lisp (original) +++ src/level1-blas-complex.lisp Sun Mar 1 19:27:44 2009 @@ -68,13 +68,20 @@ (declare (ignore type)) (unless (consp dim) (setf dim (list dim 1))) (unless value (setf value 0.0)) - (let ((rows (car dim)) - (cols (if (cdr dim) (cadr dim) 1))) + (let* ((rows (car dim)) + (cols (if (cdr dim) (cadr dim) 1)) + (size (* rows cols)) + (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)) (make-instance 'blas-complex - :store (allocate-real-store (* 2 (* rows cols)) value) + :store store :rows rows :cols cols - :size (* rows cols)))) + :size size))) (defmethod mref ((matrix blas-complex) row col) (ref-blas-complex-store (store matrix) From jivestgarden at common-lisp.net Sun Mar 1 19:28:37 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sun, 01 Mar 2009 19:28:37 +0000 Subject: [lisplab-cvs] r9 - src/test Message-ID: Author: jivestgarden Date: Sun Mar 1 19:28:36 2009 New Revision: 9 Log: unfinished test code Added: src/test/CLUnit.lisp src/test/lisplab-test.lisp Added: src/test/CLUnit.lisp ============================================================================== --- (empty file) +++ src/test/CLUnit.lisp Sun Mar 1 19:28:36 2009 @@ -0,0 +1,387 @@ +;;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: USER; Base:10 -*- +;;;; +;;;; Author: Frank A. Adrian +;;;; +;;;; Release history: +;;;; 20021126 - Release 1.3 +;;;; 20021125 - Release 1.2a +;;;; 20021124 - Release 1.2 +;;;; 20010605 - Release 1.1 +;;;; 20010527 - Release 1.0 +;;;; +;;;; Modification history: +;;;; 20021126 - Fixed compilation issues +;;;; 20021125 - Fixed :nconc-name issue for Corman Lisp +;;;; 20021124 - Fixed "AND error", switched from test object to structure +;;;; 20010605 - Added licensing text, compare-fn keyword. +;;;; 20010604 - Added :input-form and :output-form options, +;;;; failed-tests function +;;;; 20010524 - Code readied for public distribution. +;;;; 20010219 - Added list-* functions. +;;;; 20000614 - Added input-fn, output-fn. +;;;; 20000520 - Added categories. +;;;; 20000502 - Added deftest. +;;;; 20000428 - Initial Revision. +;;;; +;;;; Copyright (c) 2000-2002. Frank A. Adrian. All rights reserved. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;;;; +;;;; The author also requests that any changes and/or improvents to the +;;;; code be shared with the author for use in subsequent releases. Author's +;;;; E-mail: fadrian at ancar.org. +;;;; +;;;; + +(defpackage :org.ancar.CLUnit + (:use "COMMON-LISP") +;Kill the next form in Corman and Franz Lisps because their defpackage :documentation +;option is not present. +#-(or :cormanlisp excl) + (:documentation + "This package contains a unit testing environment for Common Lisp. + All tests are held in the system image. Each test has a name and + a category. All tests in the system can be run, as can all tests + in a given category. + + The tests are specified by a test function that is normally written + so as to take no input and to return T if the test passes. Optionally, + an input function and/or an output function can also be specified. + If an input function is specified, the test function is applied to + the return value(s) of the input function. If the output function + is specified, then the return value(s) of the test function is + compared (via #'eql) to the return value(s) of the output function + to check if the test succeeded. + + The package provides several functions and a deftest macro that makes + specifying a test simple: + clear-tests: Remove all tests from the system. + remove-test: Remove a test from the system by name. + run-category: Run all tests from a given category. + run-all-tests: Run all the tests in the system. + list-categories: List the categories of tests in the system. + list-tests: List all of the tests in the system. + run-named-test: Run the test of the given name (mainly for + debugging use after a given test has not + passed). + failed-tests: Return a list of all tests that failed during the + last run-all-tests or run-category call. + deftest: Define a test for the system.")) + +(in-package :org.ancar.CLUnit) +(provide :org.ancar.CLUnit) + +(defparameter *not-categorized* "*UNCATEGORIZED*") +(defun t-func () t) +(defun nil-func () nil)` +(defun equal-func (x y) (funcall (symbol-function 'equal) x y)) + +(defun print-test (test str depth) + (declare (ignore depth)) + (print-unreadable-object (test str :type t :identity t) + (format str "~A/~A" (descr test) (category test)))) + +(defstruct (test (:conc-name nil) (:print-function print-test)) + + "Test holds information that enables test to be located and run. + Slots: + descr: Test name. + category: Category test belongs to. + test-fn: Function run for test - by default, a zero-input, + boolean output function. T means the test succeeded. + compare-fn: Function that compares test function output to the + expected output. Takes 2 lists of values. + input-fn: Function that provides input to the test. When this + item is used, test-fn is applied to the values returned + by this function. + output-fn: Function that provides data that the output of test-fn + is compared against." + descr (category *not-categorized*) test-fn compare-fn input-fn output-fn) + + +(defvar *all-tests* nil + "Currently, this is a simple list of tests. If the number of tests + starts becoming too large, this should probably turn into a hash-table + of tests hashed on category name.") + +(defun clear-tests () + "Remove all tests from the system." + (setf *all-tests* nil)) + +(defun remove-test (test-name) + "Remove the test with the given name." + ;(format t "In remove-test~%") + (setf *all-tests* + (delete-if #'(lambda (i) (string-equal (descr i) test-name)) *all-tests*))) + +(defun run-unprotected (test) + "Run a test. No protection against errors." + (let* ((input-fn (input-fn test)) + (output-fn (output-fn test)) + (test-fn (test-fn test)) + (has-specified-input-fn input-fn)) + + (unless input-fn (setf input-fn #'nil-func)) + (unless output-fn (setf output-fn #'t-func)) + (let ((test-input (multiple-value-list (funcall input-fn)))) + ;(format t "~&Input: ~A~%" test-input) + (let ((vals (multiple-value-list + (if has-specified-input-fn + (apply test-fn test-input) + (funcall test-fn)))) + (tvals (multiple-value-list (funcall output-fn)))) + ;(format t "~&Test output: ~A~%Expected output: ~A~%" + ; vals tvals) + (funcall (compare-fn test) vals tvals))))) + +(defun run-protected (test) + "Protect the test while running with ignore-errors." + (let ((vals (multiple-value-list (ignore-errors (run-unprotected test))))) + ;(format t "~&vals: ~A~%" vals) + (unless (eq (car vals) t) + (if (cadr vals) + (format t "~&~A occurred in test ~S~%" + (cadr vals) (descr test)) + (format t "~&Output did not match expected output in test ~S~%" + (descr test)))) + vals)) + +(defun test-or-tests (count) + "This is for Corman Lisp which does not handle ~[ quite correctly." + (if (eq count 1) "test" "tests")) + +(defvar *failed-tests* nil + "Holds the set of failed tests from last test run.") + +(defun failed-tests () + "Return the set of tests that failed during the last test run" + *failed-tests*) + +(defun run-tests (tests) + "Run the set of tests passed in." + (let ((passed-tests nil) + (failed-tests nil)) + (loop for test in tests do + ;(format t "~&Running test: ~A~%" test) + (let ((test-result (run-protected test))) + (if (eq (car test-result) t) + (push test passed-tests) + (push test failed-tests)))) + (setf *failed-tests* failed-tests) +; (format t "~&Passed tests: ~A; failed tests: ~A.~%" +; passed-tests failed-tests) + (let ((passed-count (length passed-tests)) + (failed-count (length failed-tests))) +; (format t "~&Passed count: ~A; failed count: ~A~%" +; passed-count failed-count) +; (format t "~&~A ~[tests~;test~:;tests~] run; ~A ~[tests~;test~:;tests~] passed; ~A ~[tests~;test~:;tests~] failed.~%" +; (+ passed-count failed-count) (+ passed-count failed-count) +; passed-count passed-count failed-count failed-count) + (format t "~&~A ~A run; ~A ~A passed; ~A ~A failed.~%" + (+ passed-count failed-count) (test-or-tests (+ passed-count failed-count)) + passed-count (test-or-tests passed-count) + failed-count (test-or-tests failed-count)) + (values (null failed-tests) failed-count passed-count)))) + +(defun filter-tests (category) + "Filter tests by category." + (remove-if #'(lambda (test) ;(format t "~&~A~A~%" category (category test)) + (not (string-equal category (category test)))) + *all-tests*)) + +(defun run-category (category) + "Run all the tests in a given category." + (run-tests (filter-tests category))) + +(defun run-all-tests () + "Run all tests in the system." + (run-tests *all-tests*)) + +(defmacro form-to-fn (form) + "Return a function that will return the form when evaluated. + Will be used when we add input-form and output-form parameters to + deftest." + `#'(lambda () ,form)) + +(defmacro deftest (description &key category + test-fn + (input-fn nil input-fn-present) + (output-fn nil output-fn-present) + (input-form nil input-form-present) + (output-form nil output-form-present) + compare-fn) + + "Use of :input-fn and :output-fn keywords override use of :input-form and + :output-form keywords respectively." + + (let ((mia-args-gen (gensym)) + (cat-gen (gensym)) + (inst-gen (gensym)) + (ifmfn `#'(lambda () ,input-form)) + (ofmfn `#'(lambda () ,output-form)) + (cf-gen (gensym)) + (tf-gen (gensym))) + `(let (,mia-args-gen + (,cat-gen ,category) + (,cf-gen ,compare-fn) + (,tf-gen ,test-fn)) + (push :descr ,mia-args-gen) (push ,description ,mia-args-gen) + (when ,cat-gen + (push :category ,mia-args-gen) (push ,cat-gen ,mia-args-gen)) + (push :compare-fn ,mia-args-gen) (push (if ,cf-gen ,cf-gen #'equal) ,mia-args-gen) + (push :test-fn ,mia-args-gen) (push (if ,tf-gen ,tf-gen #'t-func) ,mia-args-gen) + (when (and ,output-form-present (not ,output-fn-present)) + (push :output-fn ,mia-args-gen) (push ,ofmfn ,mia-args-gen)) + (when ,output-fn-present + (push :output-fn ,mia-args-gen) (push ,output-fn ,mia-args-gen)) + (when (and ,input-form-present (not ,input-fn-present)) + (push :input-fn ,mia-args-gen) (push ,ifmfn ,mia-args-gen)) + (when ,input-fn-present + (push :input-fn ,mia-args-gen) (push ,input-fn ,mia-args-gen)) + (let ((,inst-gen (apply #'make-test (nreverse ,mia-args-gen)))) + (remove-test (descr ,inst-gen)) + (push ,inst-gen *all-tests*))))) + +(defun list-categories () + "List all of the categories in the system." + (let (cats) + (loop for test in *all-tests* doing + (setf cats (adjoin (category test) cats :test #'string-equal))) + cats)) + +(defun list-tests (&optional category) + "List the tets in the system / category." + (let ((tests (if category (filter-tests category) *all-tests*))) + (loop for test in tests collecting + (concatenate 'string (descr test) "/" (category test))))) + +(defun run-named-test (name &optional protected) + "Run the given test in either protected or unprotected mode." + (let ((test (find name *all-tests* :key #'descr :test #'string-equal))) + (when test + (if protected + (run-protected test) + (run-unprotected test))))) + +(export '( + run-category + run-all-tests + clear-tests + remove-test + deftest + list-categories + list-tests + run-named-test + failed-tests + clear-tests + ;with-supressed-summary + )) + +#| + +(in-package "COMMON-LISP-USER") +(use-package :org.ancar.CLUnit) + +;;; +;;; Self test... +;;; + +;; tests basic test definition +(load-time-value (progn + +(deftest "test1" :category "CLUnit-pass1" + :test-fn #'(lambda () (eq (car '(a)) 'a))) + +;; tests input-fn +(deftest "test-2" :category "CLUnit-pass1" + :input-fn #'(lambda () '(a)) + :test-fn #'(lambda (x) (eq (car x) 'a))) + +;; tests output-fn +(deftest "test-3" :category "CLUnit-pass1" + :input-fn #'(lambda () '(a)) + :output-fn #'(lambda () 'a) + :test-fn #'(lambda (x) (car x))) + +;; tests remove-test, run-category, and multiple-values in test-fn and +;; output-fn +(deftest "meta" :category "CLUnit-meta" + :input-fn #'(lambda () (remove-test "test1")) + :test-fn #'(lambda (x) (declare (ignore x)) (run-category "CLUnit-pass1")) + :output-fn #'(lambda () (values t 0 2))) + +;; tests multiple values from input-fn to test-fn +(deftest "test1" :category "CLUnit-pass2" + :input-fn #'(lambda () (values 'a '(b))) + :test-fn #'cons + :output-fn #'(lambda () '(a b))) + +;;check error trapping +(deftest "meta2" :category "CLUnit-meta" + :input-fn + #'(lambda () (deftest "Error test" :category "CLUnit-pass3" + :test-fn #'(lambda () + (remove-test "Error test") (error "Dummy error")))) + :test-fn #'(lambda (x) (declare (ignore x)) (run-category "CLUnit-pass3")) + :output-fn #'(lambda () (values nil 1 0))) + +;;check input-form +(deftest "testx" :category "CLUnit" + :input-form '(a b c) + :test-fn #'car + :output-fn #'(lambda () 'a)) + +;;check output form +(deftest "testx2" :category "CLUnit" + :input-form '(a b c) + :test-fn #'car + :output-form 'a) + +;;check multiple input-forms +(deftest "testx3" :category "CLUnit" + :input-form (values '(1 2 3) '(10 20 30)) + :test-fn #'(lambda (&rest lists) (car lists)) + :output-fn #'(lambda () '(1 2 3))) + +;;check multiple output-forms +(deftest "testx4" :category "CLUnit" + :input-form (values '(1 2 3) '(10 20 30)) + :test-fn #'(lambda (&rest lists) (apply #'values lists)) + :output-fn #'(lambda () (values '(1 2 3) '(10 20 30)))) + +;;check failed-tests +(deftest "meta5" :category "CLUnit-meta" + :input-fn + #'(lambda () (deftest "Error test" :category "CLUnit-pass4" + :test-fn #'(lambda () + (remove-test "Error test") (error "Dummy error")))) + :test-fn #'(lambda (x) (declare (ignore x)) + (run-category "CLUnit-pass4") + (values (length (failed-tests)) (org.ancar.CLUnit::descr (car (failed-tests))))) + :output-fn #'(lambda () (values 1 "Error test"))) + +(deftest "Test compare-fn" + :test-fn #'(lambda () "abc") + :output-form "abc" + :compare-fn #'(lambda (rlist1 rlist2) + (not (null (reduce #'(lambda (x y) (and x y)) + (mapcar #'string-equal rlist1 rlist2) :initial-value t))))) + +;;; run self test +(when (run-all-tests) + (format t "~&CLUnit self-test passed.~%") + (clear-tests) + (values)))) +|# \ No newline at end of file Added: src/test/lisplab-test.lisp ============================================================================== --- (empty file) +++ src/test/lisplab-test.lisp Sun Mar 1 19:28:36 2009 @@ -0,0 +1,102 @@ + + +(defpackage "LISPLAB.TEST" + (:use "COMMON-LISP" "ORG.ANCAR.CLUNIT")) + +(in-package :lisplab.test) + +(defparameter *a22* #2a((1 4) (1 -2))) +(defparameter *a33* #2a((1 4 7) (3 4 2) (1 -2 -8))) + +(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 .*" + :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)) + )) + +(deftest "level0 ./" + :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)) + )) + +(deftest "level0 .^" + :test-fn (lambda () + (= 1 (ll:.^ 7 0)) + (= 64 (ll:.^ 4 3)) + (= 15.620749173070115 (ll:.^ 2.3 3.3)) + (= 9/49 (ll:.^ 3/7 2)) + )) + +(deftest "level1 blas-real" + :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)))))) + + + From jivestgarden at common-lisp.net Thu Mar 26 18:19:25 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Thu, 26 Mar 2009 18:19:25 +0000 Subject: [lisplab-cvs] r10 - src Message-ID: Author: jivestgarden Date: Thu Mar 26 18:19:24 2009 New Revision: 10 Log: non-finished template code Added: src/template.lisp Added: src/template.lisp ============================================================================== --- (empty file) +++ src/template.lisp Thu Mar 26 18:19:24 2009 @@ -0,0 +1,420 @@ +(in-package :lisplab) + +(defclass template () + ((symbol + :initarg :symbol + :accessor template-symbol + :documentation "The variable") + ;; TODO some gensym symbol for dynamic symbol + #+nil (type + :initarg :type + :accessor template-type + :documentation "The actual run-time type") + )) + +(defclass template-blas-real (template) + ((store-symbol + :initform (gensym) + :accessor template-store-symbol + :documentation "Temp variable store") + (rows-symbol + :initform (gensym) + :accessor template-rows-symbol + :documentation "Temp variable store") + )) + + +(defgeneric create-template (type symbol &rest rest )) + +(defgeneric apply-template (template code)) + +(defgeneric make-template-let*-forms (template)) + +(defgeneric make-template-declare-forms (template)) + +;;;; Blas real templates + +(defmethod create-template ((type (eql 'blas-real)) + symbol &rest rest) + (make-instance 'template-blas-real :symbol symbol)) + +(defmethod make-template-declare-forms ((tl template-blas-real)) + `((type type-blas-store ,(template-store-symbol tl) ) + (type type-blas-idx ,(template-rows-symbol tl) ))) + +(defmethod make-template-let*-forms ((tl template-blas-real )) + `((,(template-store-symbol tl) (store ,(template-symbol tl) )) + (,(template-rows-symbol tl) (rows ,(template-symbol tl))))) + +(defmethod apply-template ((