[lisplab-cvs] r182 - in trunk: . src/core src/extra src/io src/matrix2 src/test src/util src/vector1 src/vector2
Jørn Inge Vestgården
jivestgarden at common-lisp.net
Tue Sep 14 19:00:17 UTC 2010
Author: jivestgarden
Date: Tue Sep 14 15:00:17 2010
New Revision: 182
Log:
finished separation of vectors and matrices
Added:
trunk/src/extra/extra.lisp
trunk/src/extra/infpre.lisp
- copied unchanged from r179, /trunk/src/core/level0-infpre.lisp
trunk/src/extra/level3-euler.lisp
- copied unchanged from r179, /trunk/src/util/level3-euler.lisp
trunk/src/extra/level3-rk4.lisp
- copied unchanged from r179, /trunk/src/util/level3-rk4.lisp
trunk/src/matrix2/level2-constructors.lisp
- copied unchanged from r181, /trunk/src/vector2/level2-constructors.lisp
trunk/src/matrix2/level2-view.lisp
- copied unchanged from r181, /trunk/src/vector2/level2-view.lisp
trunk/src/matrix2/matrix2-generic.lisp
trunk/src/util/level1-util.lisp
- copied unchanged from r181, /trunk/src/vector1/level1-util.lisp
trunk/src/util/permutation.lisp
- copied unchanged from r181, /trunk/src/vector2/permutation.lisp
trunk/src/util/store-operators.lisp
- copied unchanged from r181, /trunk/src/vector2/store-operators.lisp
trunk/src/util/store-ordinary-functions.lisp
- copied unchanged from r181, /trunk/src/vector2/store-ordinary-functions.lisp
Removed:
trunk/src/core/level0-infpre.lisp
trunk/src/util/level3-euler.lisp
trunk/src/util/level3-rk4.lisp
trunk/src/vector1/level1-util.lisp
trunk/src/vector2/level2-constructors.lisp
trunk/src/vector2/level2-view.lisp
trunk/src/vector2/permutation.lisp
trunk/src/vector2/store-operators.lisp
trunk/src/vector2/store-ordinary-functions.lisp
Modified:
trunk/lisplab.asd
trunk/src/io/level3-io.lisp
trunk/src/test/test-methods.lisp
trunk/src/vector2/level2-generic.lisp
trunk/src/vector2/level2-list.lisp
Modified: trunk/lisplab.asd
==============================================================================
--- trunk/lisplab.asd (original)
+++ trunk/lisplab.asd Tue Sep 14 15:00:17 2010
@@ -60,15 +60,23 @@
;; (:file "level0-default")
(:file "level0-functions")
(:file "level0-thread")
- (:file "level0-infpre")))
+ ))
+
+ (:module :src/util
+ :depends-on ()
+ :serial t
+ :components
+ ((:file "level1-util")
+ (:file "store-operators")
+ (:file "store-ordinary-functions")
+ (:file "permutation")
+ ))
(:module :src/vector1
- :depends-on (:src/core)
+ :depends-on (:src/core :src/util)
:serial t
:components
- (
- (:file "level1-interface")
- (:file "level1-util")
+ ((:file "level1-interface")
(:file "level1-vector")
))
@@ -76,55 +84,47 @@
:depends-on (:src/core :src/vector1)
:serial t
:components
- (
- (:file "level1-classes")
- (:file "level1-constructors")
-
- (:file "level1-matrix")
-
- (:file "level1-ge")
- (:file "level1-dge")
- (:file "level1-zge")
- (:file "level1-ddiag")
- (:file "level1-dgt")
- (:file "level1-funmat")
- (:file "level1-sparse")
- (:file "level1-array")
+ ((:file "level1-classes")
+ (:file "level1-constructors")
+
+ (:file "level1-matrix")
+ (:file "level1-ge")
+ (:file "level1-dge")
+ (:file "level1-zge")
+ (:file "level1-ddiag")
+ (:file "level1-dgt")
+ (:file "level1-funmat")
+ (:file "level1-sparse")
+ (:file "level1-array")
))
(:module :src/vector2
:depends-on (:src/core :src/vector1)
:serial t
:components
- ( ;; Level2, non-spezialized
-
- (:file "store-operators")
- (:file "store-ordinary-functions")
- (:file "permutation")
-
+ ((:file "level2-interface")
+ (:file "level2-generic")
+ (:file "level2-operator")
+ (:file "level2-function")
+
+ ;; Level2, spezialized
+ (:file "level2-matrix-dge")
+ (:file "level2-matrix-zge")
- (:file "level2-interface")
- (:file "level2-constructors")
- (:file "level2-generic")
- (:file "level2-operator")
- (:file "level2-function")
-
- ;; Level2, spezialized
- (:file "level2-matrix-dge")
- (:file "level2-matrix-zge")
- (:file "level2-view")
- (:file "level2-list")
- (:file "level2-vector")
- ))
+ (:file "level2-list")
+ (:file "level2-vector")
+ ))
(:module :src/matrix2
:depends-on (:src/core :src/vector1 :src/matrix1)
:serial t
:components
- ())
+ ((:file "level2-constructors")
+ (:file "matrix2-generic")
+ (:file "level2-view")
+ ))
-
;;
;; IO (level 3)
;;
@@ -160,14 +160,16 @@
;;
;; Euler and Runge-Kutt solvers (Level 3)
;;
-(:module :src/util
+ (:module :src/extra
:depends-on (:src/matrix2)
:serial t
:components
(
(:file "level3-rk4")
- (:file "level3-euler")))
-
+ (:file "level3-euler")
+ (:file "extra")
+ (:file "infpre")
+ ))
))
(defsystem :lisplab-matlisp
Added: trunk/src/extra/extra.lisp
==============================================================================
--- (empty file)
+++ trunk/src/extra/extra.lisp Tue Sep 14 15:00:17 2010
@@ -0,0 +1,41 @@
+;;; Lisplab, extra.lisp
+;;; Some string and file utilities
+
+;;; 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 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."
+ (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))))
+
Modified: trunk/src/io/level3-io.lisp
==============================================================================
--- trunk/src/io/level3-io.lisp (original)
+++ trunk/src/io/level3-io.lisp Tue Sep 14 15:00:17 2010
@@ -25,26 +25,6 @@
(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."
- (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 (out (x number) &key (printer #'prin1) dlm)
(declare (ignore dlm))
(dlmwrite (dcol x) out :printer printer))
Added: trunk/src/matrix2/matrix2-generic.lisp
==============================================================================
--- (empty file)
+++ trunk/src/matrix2/matrix2-generic.lisp Tue Sep 14 15:00:17 2010
@@ -0,0 +1,151 @@
+;;; Lisplab, matrix2-generic.lisp
+;;; Level2, non-specialized matrix 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.
+
+
+;;; Implementation principles:
+;;; - all operators in this film should specialize for matrix-base and only
+;;; assume level0 and level1 generic function (mref, vref, size, dim, etc.)
+;;; - The methods in this file should not assume anything about implementation of
+;;; the matrices.
+;;; - The methods in this file should be as short and clean as possible.
+;;; - Avoid optimizations (Exept: call other level2 functions, such as mmap, as much as possible.)
+;;;
+
+
+(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)))
+
+(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 sub-matrix (m rr cc)
+ (unless (cddr rr)
+ (setf rr (cons (car rr) (cons 1 (cdr rr)))))
+ (unless (cddr cc)
+ (setf cc (cons (car cc) (cons 1 (cdr cc)))))
+ (destructuring-bind (r0 r-step r1) rr
+ (destructuring-bind (c0 c-step c1) cc
+ (when (>= r1 (rows m))
+ (setf r1 (1- (rows m))))
+ (when (>= c1 (cols m))
+ (setf c1 (1- (cols m))))
+ (let* ((rows (1+ (floor (- r1 r0) r-step)))
+ (cols (1+ (floor (- c1 c0) c-step)))
+ (m1 (mcreate m 0 (list rows cols))))
+ (dotimes (i rows)
+ (dotimes (j cols)
+ (setf (mref m1 i j)
+ (mref m (+ r0 (* r-step i)) (+ c0 (* c-step j))))))
+ m1))))
+
+(defmethod circ-shift ((A matrix-base) shift)
+ ;; TODO move to level3
+ (let ((B (mcreate A))
+ (rows (rows A))
+ (cols (cols A))
+ (dr (first shift))
+ (dc (second shift)))
+ (dotimes (i rows)
+ (dotimes (j cols)
+ (setf (mref B (mod (+ i dr) rows) (mod (+ j dc) cols))
+ (mref A i j))))
+ B))
+
+(defmethod pad-shift ((A matrix-base) shift &optional (value 0))
+ ;; TODO move to level3
+ (let ((B (mcreate A value))
+ (rows (rows A))
+ (cols (cols A))
+ (dr (first shift))
+ (dc (second shift)))
+ (loop for i from (max 0 dr) below (min rows (+ rows dr)) do
+ (loop for j from (max 0 dc) below (min cols (+ cols dc)) do
+ (setf (mref B i j)
+ (mref A (- i dr) (- j dc)))))
+ B))
+
+(defmethod mreverse ((A matrix-base))
+ (let ((B (mcreate A))
+ (len (size A)))
+ (dotimes (i len)
+ (setf (vref B (- len i 1))
+ (vref A i)))
+ B))
+
+(defmethod export-list ((m matrix-base))
+ (let ((res nil))
+ (dotimes (i (size m))
+ (push (vref m i) res))
+ (nreverse res)))
+
+(defmethod import-list ((m matrix-base) list)
+ (let ((tmp list))
+ (dotimes (i (size m))
+ (unless tmp
+ (return-from import-list m))
+ (setf (vref m i) (car tmp)
+ tmp (cdr tmp)))
+ m))
+
+(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 matrix-base))
+ (reshape a (list (size a) 1)))
+
+(defmethod to-matrix ((a matrix-base) rows)
+ (reshape a (list rows (/ (size a) rows) 1)))
+
+
+(defmethod row-swap! (A i j)
+ (dotimes (c (cols A))
+ (psetf (mref A i c) (mref A j c)
+ (mref A j c) (mref A i c)))
+ A)
+
+(defmethod row-mul! (A i num)
+ (dotimes (c (cols A))
+ (setf (mref A i c) (.* num (mref A i c))))
+ A)
+
+(defmethod row-add! (A i j num)
+ (dotimes (c (cols A))
+ (setf (mref A i c) (.+ (mref A i c) (.* num (mref A j c)))))
+ A)
+
Modified: trunk/src/test/test-methods.lisp
==============================================================================
--- trunk/src/test/test-methods.lisp (original)
+++ trunk/src/test/test-methods.lisp Tue Sep 14 15:00:17 2010
@@ -22,9 +22,9 @@
(let* ((a 1)
(b 1d0)
(c %i)
- (x #md((1 2) (3 4)))
- (y #md((1 2) (3 4)))
- (w #mm((1 2) (3 4)))
+ (x #md((1 2 ) (3 4)))
+ (y #md((1 2 3) (3 4 3)))
+ (w #mm((1 2 2) (3 4 3) (1 100000 1000000))
(args (list a b c x y w)))
(mapc (lambda (fun)
(mapc (lambda (x)
Modified: trunk/src/vector2/level2-generic.lisp
==============================================================================
--- trunk/src/vector2/level2-generic.lisp (original)
+++ trunk/src/vector2/level2-generic.lisp Tue Sep 14 15:00:17 2010
@@ -132,125 +132,3 @@
val)
-;;; Matrix operations (depend on structure)
-
-
-;;; 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)))
-
-(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 sub-matrix (m rr cc)
- (unless (cddr rr)
- (setf rr (cons (car rr) (cons 1 (cdr rr)))))
- (unless (cddr cc)
- (setf cc (cons (car cc) (cons 1 (cdr cc)))))
- (destructuring-bind (r0 r-step r1) rr
- (destructuring-bind (c0 c-step c1) cc
- (when (>= r1 (rows m))
- (setf r1 (1- (rows m))))
- (when (>= c1 (cols m))
- (setf c1 (1- (cols m))))
- (let* ((rows (1+ (floor (- r1 r0) r-step)))
- (cols (1+ (floor (- c1 c0) c-step)))
- (m1 (mcreate m 0 (list rows cols))))
- (dotimes (i rows)
- (dotimes (j cols)
- (setf (mref m1 i j)
- (mref m (+ r0 (* r-step i)) (+ c0 (* c-step j))))))
- m1))))
-
-(defmethod circ-shift ((A matrix-base) shift)
- ;; TODO move to level3
- (let ((B (mcreate A))
- (rows (rows A))
- (cols (cols A))
- (dr (first shift))
- (dc (second shift)))
- (dotimes (i rows)
- (dotimes (j cols)
- (setf (mref B (mod (+ i dr) rows) (mod (+ j dc) cols))
- (mref A i j))))
- B))
-
-(defmethod pad-shift ((A matrix-base) shift &optional (value 0))
- ;; TODO move to level3
- (let ((B (mcreate A value))
- (rows (rows A))
- (cols (cols A))
- (dr (first shift))
- (dc (second shift)))
- (loop for i from (max 0 dr) below (min rows (+ rows dr)) do
- (loop for j from (max 0 dc) below (min cols (+ cols dc)) do
- (setf (mref B i j)
- (mref A (- i dr) (- j dc)))))
- B))
-
-(defmethod mreverse ((A matrix-base))
- (let ((B (mcreate A))
- (len (size A)))
- (dotimes (i len)
- (setf (vref B (- len i 1))
- (vref A i)))
- B))
-
-(defmethod export-list ((m matrix-base))
- (let ((res nil))
- (dotimes (i (size m))
- (push (vref m i) res))
- (nreverse res)))
-
-(defmethod import-list ((m matrix-base) list)
- (let ((tmp list))
- (dotimes (i (size m))
- (unless tmp
- (return-from import-list m))
- (setf (vref m i) (car tmp)
- tmp (cdr tmp)))
- m))
-
-(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 matrix-base))
- (reshape a (list (size a) 1)))
-
-(defmethod to-matrix ((a matrix-base) rows)
- (reshape a (list rows (/ (size a) rows) 1)))
-
-
-(defmethod row-swap! (A i j)
- (dotimes (c (cols A))
- (psetf (mref A i c) (mref A j c)
- (mref A j c) (mref A i c)))
- A)
-
-(defmethod row-mul! (A i num)
- (dotimes (c (cols A))
- (setf (mref A i c) (.* num (mref A i c))))
- A)
-
-(defmethod row-add! (A i j num)
- (dotimes (c (cols A))
- (setf (mref A i c) (.+ (mref A i c) (.* num (mref A j c)))))
- A)
-
Modified: trunk/src/vector2/level2-list.lisp
==============================================================================
--- trunk/src/vector2/level2-list.lisp (original)
+++ trunk/src/vector2/level2-list.lisp Tue Sep 14 15:00:17 2010
@@ -17,7 +17,7 @@
;;; with this program; if not, write to the Free Software Foundation, Inc.,
;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-;;; Should it be somewhere else. It has nothing to do with matrices really.
+;;; Should it be somewhere else. It has nothing to do with matrices, really.
(in-package :lisplab)
More information about the lisplab-cvs
mailing list