[lisplab-cvs] r36 - src src/core src/io src/linalg src/matrix system
Jørn Inge Vestgården
jivestgarden at common-lisp.net
Fri May 22 17:23:22 UTC 2009
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
More information about the lisplab-cvs
mailing list