From jivestgarden at common-lisp.net Fri Oct 16 18:20:15 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Fri, 16 Oct 2009 14:20:15 -0400 Subject: [lisplab-cvs] r100 - src/fft Message-ID: Author: jivestgarden Date: Fri Oct 16 14:20:14 2009 New Revision: 100 Log: fft-shift Modified: src/fft/level3-fft-generic.lisp src/fft/level3-fft-zge.lisp Modified: src/fft/level3-fft-generic.lisp ============================================================================== --- src/fft/level3-fft-generic.lisp (original) +++ src/fft/level3-fft-generic.lisp Fri Oct 16 14:20:14 2009 @@ -53,3 +53,27 @@ (defmethod fft2 ((x matrix-base-zge) &key) (fft2! (copy x))) + +(defmethod fft-shift ((m matrix-base)) + (let* ((rows (rows m)) + (fr (floor rows 2)) + (cr (ceiling rows 2)) + (cols (cols m)) + (fc (floor cols 2)) + (cc (ceiling cols 2))) + (fmat (type-of m) (list rows cols) (i j) + (mref m + (if (< i fr) (+ i cr) (- i fr)) + (if (< j fc) (+ j cc) (- j fc)))))) + +(defmethod ifft-shift ((m matrix-base)) + (let* ((rows (rows m)) + (fr (floor rows 2)) + (cr (ceiling rows 2)) + (cols (cols m)) + (fc (floor cols 2)) + (cc (ceiling cols 2))) + (fmat (type-of m) (list rows cols) (i j) + (mref m + (if (< i cr) (+ i fr) (- i cr)) + (if (< j cc) (+ j fc) (- j cc)))))) Modified: src/fft/level3-fft-zge.lisp ============================================================================== --- src/fft/level3-fft-zge.lisp (original) +++ src/fft/level3-fft-zge.lisp Fri Oct 16 14:20:14 2009 @@ -21,12 +21,8 @@ (in-package :lisplab) - - ;;;; The implementing methods - - (defmethod fft1! ((x matrix-lisp-zge) &key) (assert (= 1 (logcount (rows x)))) (dotimes (i (cols x)) @@ -163,24 +159,3 @@ (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 From jivestgarden at common-lisp.net Fri Oct 16 18:29:21 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Fri, 16 Oct 2009 14:29:21 -0400 Subject: [lisplab-cvs] r101 - in src: io matrix Message-ID: Author: jivestgarden Date: Fri Oct 16 14:29:21 2009 New Revision: 101 Log: minor fix Modified: src/io/level3-io.lisp src/matrix/level2-constructors.lisp Modified: src/io/level3-io.lisp ============================================================================== --- src/io/level3-io.lisp (original) +++ src/io/level3-io.lisp Fri Oct 16 14:29:21 2009 @@ -25,6 +25,10 @@ (in-package :lisplab) +(defmethod dlmwrite ((x number) out &key (printer #'prin1) dlm) + (declare (ignore dlm)) + (dlmwrite (dcol x) out :printer printer)) + (defmethod dlmwrite ((a matrix-base) (stream stream) &key @@ -176,58 +180,3 @@ (format out "~2,'0X" c))) (format out "~%")) (format out "showpage~%")))) - - -;;;; Trash - - -#+nil (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)))))) - -#+nil (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))) Modified: src/matrix/level2-constructors.lisp ============================================================================== --- src/matrix/level2-constructors.lisp (original) +++ src/matrix/level2-constructors.lisp Fri Oct 16 14:29:21 2009 @@ -148,6 +148,17 @@ "Creates a matrix-zge matrix" (mnew 'matrix-zge value rows cols)) +(defun zgrid (xv yv) + (let* ((r (size xv)) + (c (size yv)) + (x (znew 0 r c)) + (y (znew 0 r c))) + (dotimes (i r) + (dotimes (j c) + (setf (mref x i j) (vref xv i) + (mref y i j) (vref yv j)))) + (list x y))) + ;;; Function matrix @@ -164,7 +175,7 @@ :rows ,rows2 :cols ,cols2 :mref (lambda (self , at args) - #+cbcl(declare (sb-ext::muffle-conditions style-warning)) + #+sbcl(declare (sb-ext::muffle-conditions style-warning)) , at body) :vref (lambda (self ,i) ;; Default self vector reference in column major order From jivestgarden at common-lisp.net Fri Oct 16 18:44:23 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Fri, 16 Oct 2009 14:44:23 -0400 Subject: [lisplab-cvs] r102 - in src: core io Message-ID: Author: jivestgarden Date: Fri Oct 16 14:44:23 2009 New Revision: 102 Log: moved things round Modified: src/core/level0-basic.lisp src/io/level3-io.lisp Modified: src/core/level0-basic.lisp ============================================================================== --- src/core/level0-basic.lisp (original) +++ src/core/level0-basic.lisp Fri Oct 16 14:44:23 2009 @@ -48,25 +48,6 @@ ,value) ,@(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) - (,path (merge-pathnames (if (pathnamep ,dir2) - ,dir2 - (pathname (strcat ,dir2 "/"))) - *default-pathname-defaults*))) - (ensure-directories-exist ,path) - (unless (probe-file ,path) - (error "<~S> is no directory" ,path )) - (let ((*default-pathname-defaults* ,path)) - , at body)))) - (defun to-df (x) "Coerce x to double float." (coerce x 'double-float)) Modified: src/io/level3-io.lisp ============================================================================== --- src/io/level3-io.lisp (original) +++ src/io/level3-io.lisp Fri Oct 16 14:44:23 2009 @@ -18,13 +18,34 @@ ;;; 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? +;;; TODO: make a generic function for bitmap export +;;; (mexport 'eps "filname.eps" m :keys ...) +;;; Leave dlmread and dlmwrite as they are. + (in-package :lisplab) +(defun strcat (&rest args) + "Concatenates the strings." + (apply #'concatenate (append (list 'string) args))) + +(defmacro in-dir (dir &body body) + "Temperarily binds *default-pathname-defaults* to dir. When directory +does not exists, it is created." + ;; TODO move to the part dealing with files + (let ((path (gensym)) + (dir2 (gensym))) + `(let* ((,dir2 ,dir) + (,path (merge-pathnames (if (pathnamep ,dir2) + ,dir2 + (pathname (strcat ,dir2 "/"))) + *default-pathname-defaults*))) + (ensure-directories-exist ,path) + (unless (probe-file ,path) + (error "<~S> is no directory" ,path )) + (let ((*default-pathname-defaults* ,path)) + , at body)))) + (defmethod dlmwrite ((x number) out &key (printer #'prin1) dlm) (declare (ignore dlm)) (dlmwrite (dcol x) out :printer printer)) @@ -119,7 +140,6 @@ (defun pswrite (m filename &key - (verbose nil) (max (mmax m)) (min (mmin m))) "Writes matrix as postscript bitmap. Port of a2ps.c by Eric Weeks." @@ -130,16 +150,16 @@ (setf max 1.0 min 0.0 )) (let* ((DTXSCALE 1.0787) (DTYSCALE 1.0) - (DTHRES 513) - (DTVRES 481) + #+nil (DTHRES 513) + #+nil (DTVRES 481) (XOFFSET 54) ; 3/4 inch. 72 units = 1 inch. (YOFFSET 288) ; /* 4 inches. */ (nbits 8) (scale 1) - (invert 0) - (count 0) - (title nil) + #+nil (invert 0) + #+nil (count 0) + #+nil (title nil) (xsc 1.0) ; (ysc 1.0 ) (ysc (/ (cols m) (rows m) 1.0)) @@ -156,7 +176,7 @@ (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 + #+nil (when title (format out "/Times-Roman findfont 30 scalefont setfont~%") (format out "50.0 50.0 moveto~%") (format out "(~A) show~%" filename)) From jivestgarden at common-lisp.net Fri Oct 16 18:53:31 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Fri, 16 Oct 2009 14:53:31 -0400 Subject: [lisplab-cvs] r103 - src/matrix Message-ID: Author: jivestgarden Date: Fri Oct 16 14:53:31 2009 New Revision: 103 Log: minor fixes Modified: src/matrix/level1-sparse.lisp Modified: src/matrix/level1-sparse.lisp ============================================================================== --- src/matrix/level1-sparse.lisp (original) +++ src/matrix/level1-sparse.lisp Fri Oct 16 14:53:31 2009 @@ -17,10 +17,10 @@ ;;; with this program; if not, write to the Free Software Foundation, Inc., ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -;;; Note that there is probably not much to save using this on most operations +;;; Purpose of the sparse matrices is to save space. +;;; Currently you won't save much time on most operations ;;; since they by default go through all elements. - (in-package :lisplab) (defclass matrix-sparse @@ -39,11 +39,13 @@ (with-slots (rows cols size hash-store default-element ) m (setf size (* rows cols)) (unless hash-store - (setf hash-store (make-hash-table :test 'eq))) + ;; Uses eq as test. It should be safe since the keys are matrix indices + ;; and they should be fixnum (or fixnum size) on most platforms. + (setf hash-store (make-hash-table :test 'eq))) (unless default-element (setf default-element value)))) -;;; Add clases to the description system +;;; Adds classes to the description system (add-matrix-class 'matrix-sparse :any :sparse :any) (defmethod mref ((matrix matrix-sparse) row col) @@ -55,9 +57,11 @@ (slot-value matrix 'default-element)))) (defmethod (setf mref) (value (matrix matrix-sparse) row col) - (setf (gethash (column-major-idx row col (slot-value matrix 'rows)) - (slot-value matrix 'hash-store)) - value)) + (if (eql value (slot-value matrix 'default-element)) + value + (setf (gethash (column-major-idx row col (slot-value matrix 'rows)) + (slot-value matrix 'hash-store)) + value))) (defmethod vref ((matrix matrix-sparse) idx) (multiple-value-bind (val ok) From jivestgarden at common-lisp.net Mon Oct 26 11:50:00 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Mon, 26 Oct 2009 07:50:00 -0400 Subject: [lisplab-cvs] r104 - src/matrix Message-ID: Author: jivestgarden Date: Mon Oct 26 07:50:00 2009 New Revision: 104 Log: 64 bits matrices on sbcl x86 64 Modified: src/matrix/level1-util.lisp Modified: src/matrix/level1-util.lisp ============================================================================== --- src/matrix/level1-util.lisp (original) +++ src/matrix/level1-util.lisp Mon Oct 26 07:50:00 2009 @@ -18,13 +18,20 @@ ;;; with this program; if not, write to the Free Software Foundation, Inc., ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +;;; TODO: change name of this to something about blas store + (in-package :lisplab) (deftype type-blas-store () '(simple-array double-float (*))) -(deftype type-blas-idx () - '(MOD 536870911)) +#+(and :sbcl :x86) (deftype type-blas-idx () + '(MOD #x1FFFFFFF)) +#+(and :sbcl :x86-64) (deftype type-blas-idx () + '(MOD #xFFFFFFFFFFFFFFD)) +#-:sbcl (deftype type-blas-idx () + 'fixnum) + (declaim (inline column-major-idx)) (declaim (inline ref-blas-real-store (setf ref-blas-real-store))) From jivestgarden at common-lisp.net Mon Oct 26 19:37:39 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Mon, 26 Oct 2009 15:37:39 -0400 Subject: [lisplab-cvs] r105 - Message-ID: Author: jivestgarden Date: Mon Oct 26 15:37:38 2009 New Revision: 105 Log: tanaa target Modified: Makefile Modified: Makefile ============================================================================== --- Makefile (original) +++ Makefile Mon Oct 26 15:37:38 2009 @@ -1,7 +1,7 @@ TARDIR=lisplab-0.1.0 # Makefile for admin tasks -.PHONY: first, manual, touch, lispclean, clean, distclean +.PHONY: first, manual, touch, lispclean, clean, distclean, tinaa first: echo "Please specify target." @@ -15,6 +15,13 @@ manual: make -C"doc/manual" all +tinaa: + sbcl \ + --eval "(require :tinaa)" \ + --eval "(require :lisplab)" \ + --eval "(tinaa:document-system 'asdf-system 'lisplab #P\"tinaa/\")" \ + --eval "(sb-ext::quit)" + touch: touch system/lisplab.asd From jivestgarden at common-lisp.net Mon Oct 26 19:42:54 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Mon, 26 Oct 2009 15:42:54 -0400 Subject: [lisplab-cvs] r106 - src/linalg Message-ID: Author: jivestgarden Date: Mon Oct 26 15:42:54 2009 New Revision: 106 Log: minor doc Modified: src/linalg/level3-linalg-interface.lisp Modified: src/linalg/level3-linalg-interface.lisp ============================================================================== --- src/linalg/level3-linalg-interface.lisp (original) +++ src/linalg/level3-linalg-interface.lisp Mon Oct 26 15:42:54 2009 @@ -48,7 +48,7 @@ (assert (square-matrix? m)))) (defgeneric m* (a b) - (:documentation "Matrix product.") + (:documentation "Matrix multiplication.") (:method :before (a b) (assert (= (cols a) (rows b)))))