From jivestgarden at common-lisp.net Sat Apr 14 18:43:41 2012 From: jivestgarden at common-lisp.net (jivestgarden at common-lisp.net) Date: Sat, 14 Apr 2012 11:43:41 -0700 Subject: [lisplab-cvs] r213 - in trunk/src: matrix1 util vector1 Message-ID: Author: jivestgarden Date: Sat Apr 14 11:43:40 2012 New Revision: 213 Log: Added integer matrices. Untested. Added: trunk/src/matrix1/level1-ub8.lisp trunk/src/vector1/vector1-idx.lisp trunk/src/vector1/vector1-ub1.lisp trunk/src/vector1/vector1-ub16.lisp trunk/src/vector1/vector1-ub32.lisp trunk/src/vector1/vector1-ub8.lisp Modified: trunk/src/util/level1-util.lisp trunk/src/util/type.lisp Added: trunk/src/matrix1/level1-ub8.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/matrix1/level1-ub8.lisp Sat Apr 14 11:43:40 2012 (r213) @@ -0,0 +1,69 @@ +;;; Lisplab, level1-ub8.lisp +;;; General, unsigned-byte 8 matrices + +;;; Copyright (C) 2012 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-ub8 (structure-general vector-ub8 implementation-base) + () + (:documentation "Matrix (rows x cols) with unsigned-byte 8.")) + +(defmethod initialize-instance :after ((m matrix-ub8) &key dim (value 0)) + (with-slots (rows cols size store) m + (setf rows (car dim) + cols (cadr dim) + size (* rows cols)) + (unless store + (setf store (allocate-ub8-store size value))))) + +(defmethod make-matrix-class ((a (eql :ub8)) (b (eql :ge)) (c (eql :any))) + (find-class 'matrix-ub8)) + +;;; All leve1 methods spcialized for dge + +(defmethod mref ((matrix matrix-ub8) row col) + (ref-ub8-store (slot-value matrix 'store) row col (slot-value matrix 'rows))) + +(defmethod (setf mref) (value (matrix matrix-ub8) row col) + (let ((val2 (mod value #xff))) + (declare (type (unsigned-byte 8) val2)) + (setf (ref-ub8-store (slot-value matrix 'store) + row col (slot-value matrix 'rows)) + val2) + val2)) + +(defmethod print-object ((matrix matrix-ub8) stream) + (if (not *lisplab-print-size*) + (call-next-method) + (progn + (format stream "~&#mub8(" ) + (print-matrix-contents matrix + :stream stream + :pr (if *lisplab-element-printer* + *lisplab-element-printer* + (lambda (x stream) + (format stream "~4d" x))) + :rmax (if (eq *lisplab-print-size* t) + (rows matrix) + *lisplab-print-size*) + :cmax (if (eq *lisplab-print-size* t) + (cols matrix) + *lisplab-print-size*) + :indent 6 + :braket-p t) + (format stream ")" )))) Modified: trunk/src/util/level1-util.lisp ============================================================================== --- trunk/src/util/level1-util.lisp Fri Mar 30 10:52:30 2012 (r212) +++ trunk/src/util/level1-util.lisp Sat Apr 14 11:43:40 2012 (r213) @@ -82,6 +82,38 @@ (setf (aref store i) rv))) store)) +;;; The unsigend-byte 1 store + +(defun allocate-ub1-store (size &optional (initial-element 0)) + (let ((x (coerce initial-element '(unsigned-byte 1)))) + (declare (type (unsigned-byte 1) x) + (type type-blas-idx size)) + ;; Stupid efficiency hack for SBCL. Allocations of arrays with zeros + ;; is significantly faster than others! + (if (= x 0) + (make-array size + :element-type '(unsigned-byte 1) + :initial-element 0) + (make-array size + :element-type '(unsigned-byte 1) + :initial-element x)))) + +;;; The unsigend-byte 8 store + +(defun allocate-idx-store (size &optional (initial-element 0)) + (let ((x (coerce initial-element 'type-blas-idx))) + (declare (type type-blas-idx x) + (type type-blas-idx size)) + ;; Stupid efficiency hack for SBCL. Allocations of arrays with zeros + ;; is significantly faster than others! + (if (= x 0) + (make-array size + :element-type 'type-blas-idx + :initial-element 0) + (make-array size + :element-type 'type-blas-idx + :initial-element x)))) + ;;; The unsigend-byte 8 store (defun allocate-ub8-store (size &optional (initial-element 0)) @@ -96,4 +128,36 @@ :initial-element 0) (make-array size :element-type '(unsigned-byte 8) + :initial-element x)))) + +;;; The unsigend-byte 16 store + +(defun allocate-ub16-store (size &optional (initial-element 0)) + (let ((x (coerce initial-element '(unsigned-byte 16)))) + (declare (type (unsigned-byte 16) x) + (type type-blas-idx size)) + ;; Stupid efficiency hack for SBCL. Allocations of arrays with zeros + ;; is significantly faster than others! + (if (= x 0) + (make-array size + :element-type '(unsigned-byte 16) + :initial-element 0) + (make-array size + :element-type '(unsigned-byte 16) + :initial-element x)))) + +;;; The unsigend-byte 32 store + +(defun allocate-ub32-store (size &optional (initial-element 0)) + (let ((x (coerce initial-element '(unsigned-byte 32)))) + (declare (type (unsigned-byte 32) x) + (type type-blas-idx size)) + ;; Stupid efficiency hack for SBCL. Allocations of arrays with zeros + ;; is significantly faster than others! + (if (= x 0) + (make-array size + :element-type '(unsigned-byte 32) + :initial-element 0) + (make-array size + :element-type '(unsigned-byte 32) :initial-element x)))) \ No newline at end of file Modified: trunk/src/util/type.lisp ============================================================================== --- trunk/src/util/type.lisp Fri Mar 30 10:52:30 2012 (r212) +++ trunk/src/util/type.lisp Sat Apr 14 11:43:40 2012 (r213) @@ -35,12 +35,20 @@ (deftype type-blas-store () '(simple-array double-float (*))) -#+(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) +#+(and :sbcl :x86) +(deftype type-blas-idx () '(MOD #x1FFFFFFF)) +#+(and :sbcl :x86) +(defconstant max-type-blas-idx #x1FFFFFFF) + +#+(and :sbcl :x86-64) +(deftype type-blas-idx () '(MOD #xFFFFFFFFFFFFFFD)) +#+(and :sbcl :x86-64) +(defconstant max-type-blas-idx #xFFFFFFFFFFFFFFD) + +#-:sbcl +(deftype type-blas-idx () 'fixnum) +#-:sbcl +(deconstant max-type-blas-idx most-positive-fixnum) (deftype type-idx-store () '(simple-array type-blas-idx (*))) Added: trunk/src/vector1/vector1-idx.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/vector1/vector1-idx.lisp Sat Apr 14 11:43:40 2012 (r213) @@ -0,0 +1,39 @@ +;;; Lisplab, vector1-idx.lisp +;;; reference for finite size integer vector + +;;; Copyright (C) 2012 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) + +;;;; ub8 vectors + +(defclass vector-idx (vector-base element-idx) + ((store :initarg :store + :initform nil + :reader vector-store + :type type-idx-store))) + +(defmethod vref ((vector vector-idx) i) + (ref-idx-store (slot-value vector 'store) i 0 1)) + +(defmethod (setf vref) (value (vector vector-idx) i) + (let ((val2 (mod value max-type-blas-idx))) + (declare (type type-blas-idx val2)) + (setf (ref-idx-store (slot-value vector 'store) i 0 1) + val2) + val2)) + Added: trunk/src/vector1/vector1-ub1.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/vector1/vector1-ub1.lisp Sat Apr 14 11:43:40 2012 (r213) @@ -0,0 +1,41 @@ +;;; Lisplab, vector1-ub1.lisp +;;; reference for finite size integer vector + +;;; Copyright (C) 2012 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. + +;;; Coluld cleaner with macros + +(in-package :lisplab) + +;;;; ub1 vectors + +(defclass vector-ub1 (vector-base element-ub1) + ((store :initarg :store + :initform nil + :reader vector-store + :type type-ub1-store))) + +(defmethod vref ((vector vector-ub1) i) + (ref-ub1-store (slot-value vector 'store) i 0 1)) + +(defmethod (setf vref) (value (vector vector-ub1) i) + (let ((val2 (mod value 2))) + (declare (type (unsigned-byte 1) val2)) + (setf (ref-ub1-store (slot-value vector 'store) i 0 1) + val2) + val2)) + Added: trunk/src/vector1/vector1-ub16.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/vector1/vector1-ub16.lisp Sat Apr 14 11:43:40 2012 (r213) @@ -0,0 +1,40 @@ +;;; Lisplab, vector1-ub16.lisp +;;; reference for finite size integer vector + +;;; Copyright (C) 2012 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. + +;;; Coluld cleaner with macros + +(in-package :lisplab) + +;;;; ub16 vectors + +(defclass vector-ub16 (vector-base element-ub16) + ((store :initarg :store + :initform nil + :reader vector-store + :type type-ub16-store))) + +(defmethod vref ((vector vector-ub16) i) + (ref-ub16-store (slot-value vector 'store) i 0 1)) + +(defmethod (setf vref) (value (vector vector-ub16) i) + (let ((val2 (mod value #xffff))) + (declare (type (unsigned-byte 16) val2)) + (setf (ref-ub16-store (slot-value vector 'store) i 0 1) + val2) + val2)) Added: trunk/src/vector1/vector1-ub32.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/vector1/vector1-ub32.lisp Sat Apr 14 11:43:40 2012 (r213) @@ -0,0 +1,40 @@ +;;; Lisplab, vector1-ub32.lisp +;;; reference for finite size integer vector + +;;; Copyright (C) 2012 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. + +;;; Coluld cleaner with macros + +(in-package :lisplab) + +;;;; ub32 vectors + +(defclass vector-ub32 (vector-base element-ub32) + ((store :initarg :store + :initform nil + :reader vector-store + :type type-ub32-store))) + +(defmethod vref ((vector vector-ub32) i) + (ref-ub32-store (slot-value vector 'store) i 0 1)) + +(defmethod (setf vref) (value (vector vector-ub32) i) + (let ((val2 (mod value #xffffffff))) + (declare (type (unsigned-byte 32) val2)) + (setf (ref-ub32-store (slot-value vector 'store) i 0 1) + val2) + val2)) \ No newline at end of file Added: trunk/src/vector1/vector1-ub8.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/vector1/vector1-ub8.lisp Sat Apr 14 11:43:40 2012 (r213) @@ -0,0 +1,39 @@ +;;; Lisplab, vector1-ub8.lisp +;;; reference for finite size integer vector + +;;; Copyright (C) 2012 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) + +;;;; ub8 vectors + +(defclass vector-ub8 (vector-base element-ub8) + ((store :initarg :store + :initform nil + :reader vector-store + :type type-ub8-store))) + +(defmethod vref ((vector vector-ub8) i) + (ref-ub8-store (slot-value vector 'store) i 0 1)) + +(defmethod (setf vref) (value (vector vector-ub8) i) + (let ((val2 (mod value #xff))) + (declare (type (unsigned-byte 8) val2)) + (setf (ref-ub8-store (slot-value vector 'store) i 0 1) + val2) + val2)) + From jivestgarden at common-lisp.net Sat Apr 14 19:08:20 2012 From: jivestgarden at common-lisp.net (jivestgarden at common-lisp.net) Date: Sat, 14 Apr 2012 12:08:20 -0700 Subject: [lisplab-cvs] r214 - in trunk: . src/matrix1 src/vector1 Message-ID: Author: jivestgarden Date: Sat Apr 14 12:08:19 2012 New Revision: 214 Log: rearranged code. Added: trunk/src/matrix1/matrix1-interface.lisp trunk/src/vector1/vector1-d.lisp trunk/src/vector1/vector1-z.lisp Modified: trunk/lisplab.asd trunk/src/vector1/level1-interface.lisp trunk/src/vector1/level1-vector.lisp Modified: trunk/lisplab.asd ============================================================================== --- trunk/lisplab.asd Sat Apr 14 11:43:40 2012 (r213) +++ trunk/lisplab.asd Sat Apr 14 12:08:19 2012 (r214) @@ -82,13 +82,16 @@ ((:file "level1-interface") (:file "level1-element") (:file "level1-vector") + (:file "vector1-d") + (:file "vector1-z") )) (:module :src/matrix1 :depends-on (:src/core :src/vector1) :serial t :components - ((:file "level1-classes") + ((:file "matrix1-interface") + (:file "level1-classes") (:file "level1-constructors") (:file "level1-matrix") Added: trunk/src/matrix1/matrix1-interface.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/matrix1/matrix1-interface.lisp Sat Apr 14 12:08:19 2012 (r214) @@ -0,0 +1,45 @@ +;;; Lisplab, matrix1-interface.lisp +;;; Level1, the interface for the 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. + +(in-package :lisplab) + +(defgeneric make-matrix-instance (type dim value) + (:documentation "Creates a new matrix instance")) + +(defgeneric ref (matrix &rest subscripts) + (:documentation "A general accessor.")) + +(defgeneric (setf ref) (value matrix &rest subscripts)) + +(defgeneric mref (matrix row col) + (:documentation "Matrix accessor.")) + +(defgeneric (setf mref) (value matrix row col)) + +(defgeneric rows (matrix) + (:documentation "The number of rows, ie (dim 0).")) + +(defgeneric (setf rows) (value matrix)) + +(defgeneric cols (matrix) + (:documentation "The number of columns, ie (dim 1).")) + +(defgeneric (setf cols) (value matrix)) + + \ No newline at end of file Modified: trunk/src/vector1/level1-interface.lisp ============================================================================== --- trunk/src/vector1/level1-interface.lisp Sat Apr 14 11:43:40 2012 (r213) +++ trunk/src/vector1/level1-interface.lisp Sat Apr 14 12:08:19 2012 (r214) @@ -25,20 +25,8 @@ Not all matrices will care about the value.") (defvar *lisplab-element-printer* nil - "The function used to print matrix elements. For is same as princ and prin1.") - -(defgeneric make-matrix-instance (type dim value) - (:documentation "Creates a new matrix instance")) - -(defgeneric ref (matrix &rest subscripts) - (:documentation "A general accessor.")) - -(defgeneric (setf ref) (value matrix &rest subscripts)) - -(defgeneric mref (matrix row col) - (:documentation "Matrix accessor.")) - -(defgeneric (setf mref) (value matrix row col)) + "The function used to print matrix elements. +For is same as princ and prin1.") (defgeneric vref (matrix idx) (:documentation "Vector accessor.")) @@ -66,18 +54,8 @@ (defgeneric (setf rank) (value matrix)) -(defgeneric rows (matrix) - (:documentation "The number of rows, ie (dim 0).")) - -(defgeneric (setf rows) (value matrix)) - -(defgeneric cols (matrix) - (:documentation "The number of columns, ie (dim 1).")) - -(defgeneric (setf cols) (value matrix)) - -;;; Integral routines for access to matrix store +;;; Internal routines for access to matrix store (declaim (inline vector-store)) Modified: trunk/src/vector1/level1-vector.lisp ============================================================================== --- trunk/src/vector1/level1-vector.lisp Sat Apr 14 11:43:40 2012 (r213) +++ trunk/src/vector1/level1-vector.lisp Sat Apr 14 12:08:19 2012 (r214) @@ -37,12 +37,6 @@ :reader vector-store :type (simple-array t (*))))) -(defclass vector-d (vector-base element-double-float) - ((store :initarg :store - :initform nil - :reader vector-store - :type type-blas-store))) - (defclass vector-z (vector-base element-complex-double-float) ((store :initarg :store :initform nil @@ -75,27 +69,4 @@ (setf (aref (slot-value vector 'store) idx) value)) -;;; Double-float vectors - -(defmethod vref ((vector vector-d) idx) - (aref (the type-blas-store (slot-value vector 'store)) idx)) - -(defmethod (setf vref) (value (vector vector-d) idx) - (let ((val2 (coerce value 'double-float))) - (declare (type double-float val2)) - (setf (aref (the type-blas-store (slot-value vector 'store)) idx) - val2) - val2)) - -;;; Complex double float vectors - -(defmethod vref ((vector vector-z) i) - (ref-blas-complex-store (slot-value vector 'store) i 0 1)) - -(defmethod (setf vref) (value (vector vector-z) i) - (let ((val2 (coerce value '(complex double-float)))) - (declare (type (complex double-float) val2)) - (setf (ref-blas-complex-store (slot-value vector 'store) i 0 1) - val2) - val2)) Added: trunk/src/vector1/vector1-d.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/vector1/vector1-d.lisp Sat Apr 14 12:08:19 2012 (r214) @@ -0,0 +1,36 @@ +;;; Lisplab, vector1-d.lisp +;;; Level1, double float vectors + +;;; Copyright (C) 2012 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 vector-d (vector-base element-double-float) + ((store :initarg :store + :initform nil + :reader vector-store + :type type-blas-store))) + +(defmethod vref ((vector vector-d) idx) + (aref (the type-blas-store (slot-value vector 'store)) idx)) + +(defmethod (setf vref) (value (vector vector-d) idx) + (let ((val2 (coerce value 'double-float))) + (declare (type double-float val2)) + (setf (aref (the type-blas-store (slot-value vector 'store)) idx) + val2) + val2)) Added: trunk/src/vector1/vector1-z.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/vector1/vector1-z.lisp Sat Apr 14 12:08:19 2012 (r214) @@ -0,0 +1,30 @@ +;;; Lisplab, vector1-d.lisp +;;; Level1, complex double float vectors + +;;; Copyright (C) 2012 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 vref ((vector vector-z) i) + (ref-blas-complex-store (slot-value vector 'store) i 0 1)) + +(defmethod (setf vref) (value (vector vector-z) i) + (let ((val2 (coerce value '(complex double-float)))) + (declare (type (complex double-float) val2)) + (setf (ref-blas-complex-store (slot-value vector 'store) i 0 1) + val2) + val2)) From jivestgarden at common-lisp.net Sun Apr 15 13:58:54 2012 From: jivestgarden at common-lisp.net (jivestgarden at common-lisp.net) Date: Sun, 15 Apr 2012 06:58:54 -0700 Subject: [lisplab-cvs] r216 - in trunk/src: matrix1 matrix2 util vector2 Message-ID: Author: jivestgarden Date: Sun Apr 15 06:58:53 2012 New Revision: 216 Log: More integer matrix stuff Added: trunk/src/matrix1/matrix1-ub1.lisp trunk/src/matrix1/matrix1-ub16.lisp trunk/src/matrix1/matrix1-ub32.lisp trunk/src/matrix2/matrix2-integer-constructors.lisp trunk/src/util/integer-store-functions.lisp trunk/src/vector2/vector2-integer-functions.lisp Added: trunk/src/matrix1/matrix1-ub1.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/matrix1/matrix1-ub1.lisp Sun Apr 15 06:58:53 2012 (r216) @@ -0,0 +1,69 @@ +;;; Lisplab, level1-ub8.lisp +;;; General, unsigned-byte 1 matrices + +;;; Copyright (C) 2012 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-ub1 (structure-general vector-ub1 implementation-base) + () + (:documentation "Matrix (rows x cols) with unsigned-byte 1.")) + +(defmethod initialize-instance :after ((m matrix-ub1) &key dim (value 0)) + (with-slots (rows cols size store) m + (setf rows (car dim) + cols (cadr dim) + size (* rows cols)) + (unless store + (setf store (allocate-ub1-store size value))))) + +(defmethod make-matrix-class ((a (eql :ub1)) (b (eql :ge)) (c (eql :any))) + (find-class 'matrix-ub1)) + +;;; All leve1 methods spcialized for dge + +(defmethod mref ((matrix matrix-ub1) row col) + (ref-ub1-store (slot-value matrix 'store) row col (slot-value matrix 'rows))) + +(defmethod (setf mref) (value (matrix matrix-ub1) row col) + (let ((val2 (mod value 2))) + (declare (type (unsigned-byte 1) val2)) + (setf (ref-ub1-store (slot-value matrix 'store) + row col (slot-value matrix 'rows)) + val2) + val2)) + +(defmethod print-object ((matrix matrix-ub1) stream) + (if (not *lisplab-print-size*) + (call-next-method) + (progn + (format stream "~&#mub1(" ) + (print-matrix-contents matrix + :stream stream + :pr (if *lisplab-element-printer* + *lisplab-element-printer* + (lambda (x stream) + (format stream "~1d" x))) + :rmax (if (eq *lisplab-print-size* t) + (rows matrix) + *lisplab-print-size*) + :cmax (if (eq *lisplab-print-size* t) + (cols matrix) + *lisplab-print-size*) + :indent 6 + :braket-p t) + (format stream ")" )))) Added: trunk/src/matrix1/matrix1-ub16.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/matrix1/matrix1-ub16.lisp Sun Apr 15 06:58:53 2012 (r216) @@ -0,0 +1,69 @@ +;;; Lisplab, level1-ub16.lisp +;;; General, unsigned-byte 16 matrices + +;;; Copyright (C) 2012 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-ub16 (structure-general vector-ub16 implementation-base) + () + (:documentation "Matrix (rows x cols) with unsigned-byte 16.")) + +(defmethod initialize-instance :after ((m matrix-ub16) &key dim (value 0)) + (with-slots (rows cols size store) m + (setf rows (car dim) + cols (cadr dim) + size (* rows cols)) + (unless store + (setf store (allocate-ub16-store size value))))) + +(defmethod make-matrix-class ((a (eql :ub16)) (b (eql :ge)) (c (eql :any))) + (find-class 'matrix-ub16)) + +;;; All leve1 methods spcialized for dge + +(defmethod mref ((matrix matrix-ub16) row col) + (ref-ub16-store (slot-value matrix 'store) row col (slot-value matrix 'rows))) + +(defmethod (setf mref) (value (matrix matrix-ub16) row col) + (let ((val2 (mod value #xffff))) + (declare (type (unsigned-byte 16) val2)) + (setf (ref-ub16-store (slot-value matrix 'store) + row col (slot-value matrix 'rows)) + val2) + val2)) + +(defmethod print-object ((matrix matrix-ub16) stream) + (if (not *lisplab-print-size*) + (call-next-method) + (progn + (format stream "~&#mub16(" ) + (print-matrix-contents matrix + :stream stream + :pr (if *lisplab-element-printer* + *lisplab-element-printer* + (lambda (x stream) + (format stream "~6d" x))) + :rmax (if (eq *lisplab-print-size* t) + (rows matrix) + *lisplab-print-size*) + :cmax (if (eq *lisplab-print-size* t) + (cols matrix) + *lisplab-print-size*) + :indent 7 + :braket-p t) + (format stream ")" )))) Added: trunk/src/matrix1/matrix1-ub32.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/matrix1/matrix1-ub32.lisp Sun Apr 15 06:58:53 2012 (r216) @@ -0,0 +1,69 @@ +;;; Lisplab, level1-ub32.lisp +;;; General, unsigned-byte 32 matrices + +;;; Copyright (C) 2012 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-ub32 (structure-general vector-ub32 implementation-base) + () + (:documentation "Matrix (rows x cols) with unsigned-byte 32.")) + +(defmethod initialize-instance :after ((m matrix-ub32) &key dim (value 0)) + (with-slots (rows cols size store) m + (setf rows (car dim) + cols (cadr dim) + size (* rows cols)) + (unless store + (setf store (allocate-ub32-store size value))))) + +(defmethod make-matrix-class ((a (eql :ub32)) (b (eql :ge)) (c (eql :any))) + (find-class 'matrix-ub32)) + +;;; All leve1 methods spcialized for dge + +(defmethod mref ((matrix matrix-ub32) row col) + (ref-ub32-store (slot-value matrix 'store) row col (slot-value matrix 'rows))) + +(defmethod (setf mref) (value (matrix matrix-ub32) row col) + (let ((val2 (mod value #xffffffff))) + (declare (type (unsigned-byte 32) val2)) + (setf (ref-ub32-store (slot-value matrix 'store) + row col (slot-value matrix 'rows)) + val2) + val2)) + +(defmethod print-object ((matrix matrix-ub32) stream) + (if (not *lisplab-print-size*) + (call-next-method) + (progn + (format stream "~&#mub32(" ) + (print-matrix-contents matrix + :stream stream + :pr (if *lisplab-element-printer* + *lisplab-element-printer* + (lambda (x stream) + (format stream "~10d" x))) + :rmax (if (eq *lisplab-print-size* t) + (rows matrix) + *lisplab-print-size*) + :cmax (if (eq *lisplab-print-size* t) + (cols matrix) + *lisplab-print-size*) + :indent 7 + :braket-p t) + (format stream ")" )))) Added: trunk/src/matrix2/matrix2-integer-constructors.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/matrix2/matrix2-integer-constructors.lisp Sun Apr 15 06:58:53 2012 (r216) @@ -0,0 +1,96 @@ +;;; Lisplab, matrix2-integer-constructors.lisp +;;; Level2 constructors for integer matrices + +;;; Copyright (C) 2012 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 ub1new (value rows cols) + (mnew 'matrix-ub1 value rows cols)) + +(defun ub1mat (x) + (mmat 'matrix-ub1 x)) + +(defun ub1row (&rest args) + (apply #'mrow 'matrix-ub1 args)) + +(defun ub1col (&rest args) + (apply #'mcol 'matrix-ub1 args)) + +(defun ub1rand (rows cols) + (mmap 'matrix-ub1 + (lambda (x) + (declare (ignore x)) + (random #xff)) + (ub1new 0 rows cols))) + +(defun ub8new (value rows cols) + (mnew 'matrix-ub8 value rows cols)) + +(defun ub8mat (x) + (mmat 'matrix-ub8 x)) + +(defun ub8row (&rest args) + (apply #'mrow 'matrix-ub8 args)) + +(defun ub8col (&rest args) + (apply #'mcol 'matrix-ub8 args)) + +(defun ub8rand (rows cols) + (mmap 'matrix-ub8 + (lambda (x) + (declare (ignore x)) + (random #xff)) + (ub8new 0 rows cols))) + +(defun ub16new (value rows cols) + (mnew 'matrix-ub16 value rows cols)) + +(defun ub16mat (x) + (mmat 'matrix-ub16 x)) + +(defun ub16row (&rest args) + (apply #'mrow 'matrix-ub16 args)) + +(defun ub16col (&rest args) + (apply #'mcol 'matrix-ub16 args)) + +(defun ub16rand (rows cols) + (mmap 'matrix-ub16 + (lambda (x) + (declare (ignore x)) + (random #xffff)) + (ub16new 0 rows cols))) + +(defun ub32new (value rows cols) + (mnew 'matrix-ub32 value rows cols)) + +(defun ub32mat (x) + (mmat 'matrix-ub32 x)) + +(defun ub32row (&rest args) + (apply #'mrow 'matrix-ub32 args)) + +(defun ub32col (&rest args) + (apply #'mcol 'matrix-ub32 args)) + +(defun ub32rand (rows cols) + (mmap 'matrix-ub32 + (lambda (x) + (declare (ignore x)) + (random #xffffffff)) + (ub32new 0 rows cols))) Added: trunk/src/util/integer-store-functions.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/util/integer-store-functions.lisp Sun Apr 15 06:58:53 2012 (r216) @@ -0,0 +1,76 @@ +;;; Lisplab, integer-store-functions.lisp +;;; Level2, functions and operations for integer stores + +;;; Copyright (C) 2012 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 defun-umat-op (name opname store-type mod-size) + (let ((a (gensym)) + (out (gensym)) + (i (gensym))) + `(defun ,name (,a ,out) + (declare (type ,store-type ,a ,out)) + (dotimes (,i (length ,a)) + (setf (aref ,out ,i) + (mod (,opname (aref ,a ,i)) + ,mod-size))) + (values)))) + +(defun-umat-op ub8-not lognot type-ub8-store #xff) + +(defmacro defun-umat-umat-fun (name funname store-type mod-size) + (let ((a (gensym)) + (b (gensym)) + (out (gensym)) + (i (gensym))) + `(defun ,name (,a ,b ,out) + (declare (type ,store-type ,a ,b ,out)) + (dotimes (,i (length ,a)) + (setf (aref ,out ,i) + (mod (,funname (aref ,a ,i) + (aref ,b ,i)) + ,mod-size))) + (values)))) + +(defun-umat-umat-fun ub8-ub8-and logand type-ub8-store #xff) +(defun-umat-umat-fun ub8-ub8-nand lognand type-ub8-store #xff) +(defun-umat-umat-fun ub8-ub8-or logior type-ub8-store #xff) +(defun-umat-umat-fun ub8-ub8-nor lognor type-ub8-store #xff) +(defun-umat-umat-fun ub8-ub8-xor logxor type-ub8-store #xff) + +(defmacro defun-umat-int-fun (name funname store-type elm-type mod-size) + (let ((a (gensym)) + (b (gensym)) + (out (gensym)) + (i (gensym))) + `(defun ,name (,a ,b ,out) + (declare (type integer ,b)) + (let ((,b (mod ,b ,mod-size))) + (declare (type ,store-type ,a ,out) + (type ,elm-type ,b)) + (dotimes (,i (length ,a)) + (setf (aref ,out ,i) + (mod (,funname (aref ,a ,i) ,b) + ,mod-size))) + (values))))) + +(defun-umat-int-fun ub8-int-and logand type-ub8-store (unsigned-byte 8) #xff) +(defun-umat-int-fun ub8-int-nand lognand type-ub8-store (unsigned-byte 8) #xff) +(defun-umat-int-fun ub8-int-or logior type-ub8-store (unsigned-byte 8) #xff) +(defun-umat-int-fun ub8-int-nor lognor type-ub8-store (unsigned-byte 8) #xff) +(defun-umat-int-fun ub8-int-xor logxor type-ub8-store (unsigned-byte 8) #xff) Added: trunk/src/vector2/vector2-integer-functions.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/vector2/vector2-integer-functions.lisp Sun Apr 15 06:58:53 2012 (r216) @@ -0,0 +1,98 @@ +;;; Lisplab, vector2-integer-functions.lisp +;;; Level2 integer functions + +;;; Copyright (C) 2012 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 def-unsigned-integer-methods (matrix-type) + (let ((a (gensym "a")) + (b (gensym "b")) + (c (gensym "c"))) + `(progn + (defmethod .not ((,a ,matrix-type)) + (let ((,b (mcreate ,a))) + (ub8-not (vector-store ,a) (vector-store ,b)) + ,b)) + + (defmethod .and ((,a ,matrix-type) (,b ,matrix-type)) + (let ((,c (mcreate ,a))) + (ub8-ub8-and (vector-store ,a) (vector-store ,b) (vector-store ,c)) + ,c)) + (defmethod .and ((,a ,matrix-type) (,b integer)) + (let ((,c (mcreate ,a))) + (ub8-int-and (vector-store ,a) ,b (vector-store ,c)) + ,c)) + (defmethod .and ((,b integer) (,a ,matrix-type)) + (let ((,c (mcreate ,a))) + (ub8-int-and (vector-store ,a) ,b (vector-store ,c)) + ,c)) + + (defmethod .nand ((,a ,matrix-type) (,b ,matrix-type)) + (let ((,c (mcreate ,a))) + (ub8-ub8-nand (vector-store ,a) (vector-store ,b) (vector-store ,c)) + ,c)) + (defmethod .nand ((,a ,matrix-type) (,b integer)) + (let ((,c (mcreate ,a))) + (ub8-int-nand (vector-store ,a) ,b (vector-store ,c)) + ,c)) + (defmethod .nand ((,b integer) (,a ,matrix-type)) + (let ((,c (mcreate ,a))) + (ub8-int-nand (vector-store ,a) ,b (vector-store ,c)) + ,c)) + + (defmethod .or ((,a ,matrix-type) (,b ,matrix-type)) + (let ((,c (mcreate ,a))) + (ub8-ub8-or (vector-store ,a) (vector-store ,b) (vector-store ,c)) + ,c)) + (defmethod .or ((,a ,matrix-type) (,b integer)) + (let ((,c (mcreate ,a))) + (ub8-int-or (vector-store ,a) ,b (vector-store ,c)) + ,c)) + (defmethod .or ((,b integer) (,a ,matrix-type)) + (let ((,c (mcreate ,a))) + (ub8-int-or (vector-store ,a) ,b (vector-store ,c)) + ,c)) + + (defmethod .nor ((,a ,matrix-type) (,b ,matrix-type)) + (let ((,c (mcreate ,a))) + (ub8-ub8-nor (vector-store ,a) (vector-store ,b) (vector-store ,c)) + ,c)) + (defmethod .nor ((,a ,matrix-type) (,b integer)) + (let ((,c (mcreate ,a))) + (ub8-int-nor (vector-store ,a) ,b (vector-store ,c)) + ,c)) + (defmethod .nor ((,b integer) (,a ,matrix-type)) + (let ((,c (mcreate ,a))) + (ub8-int-nor (vector-store ,a) ,b (vector-store ,c)) + ,c)) + + (defmethod .xor ((,a ,matrix-type) (,b ,matrix-type)) + (let ((,c (mcreate ,a))) + (ub8-ub8-xor (vector-store ,a) (vector-store ,b) (vector-store ,c)) + ,c)) + (defmethod .xor ((,a ,matrix-type) (,b integer)) + (let ((,c (mcreate ,a))) + (ub8-int-xor (vector-store ,a) ,b (vector-store ,c)) + ,c)) + (defmethod .xor ((,b integer) (,a ,matrix-type)) + (let ((,c (mcreate ,a))) + (ub8-int-xor (vector-store ,a) ,b (vector-store ,c)) + ,c)) + ))) + +(def-unsigned-integer-methods matrix-ub8 ) \ No newline at end of file From jivestgarden at common-lisp.net Sun Apr 15 14:12:31 2012 From: jivestgarden at common-lisp.net (jivestgarden at common-lisp.net) Date: Sun, 15 Apr 2012 07:12:31 -0700 Subject: [lisplab-cvs] r217 - in trunk/src/vector: . 1 1/df 1/ub 1/z 2 2/df 2/ub 2/z Message-ID: Author: jivestgarden Date: Sun Apr 15 07:12:30 2012 New Revision: 217 Log: part of refactoring Added: trunk/src/vector/ trunk/src/vector/1/ trunk/src/vector/1/df/ trunk/src/vector/1/ub/ trunk/src/vector/1/z/ trunk/src/vector/2/ trunk/src/vector/2/df/ trunk/src/vector/2/ub/ trunk/src/vector/2/z/ From jivestgarden at common-lisp.net Sun Apr 15 15:43:48 2012 From: jivestgarden at common-lisp.net (jivestgarden at common-lisp.net) Date: Sun, 15 Apr 2012 08:43:48 -0700 Subject: [lisplab-cvs] r219 - trunk/src/vector1 Message-ID: Author: jivestgarden Date: Sun Apr 15 08:43:47 2012 New Revision: 219 Log: Removed unused dir Deleted: trunk/src/vector1/ From jivestgarden at common-lisp.net Sun Apr 15 15:44:47 2012 From: jivestgarden at common-lisp.net (jivestgarden at common-lisp.net) Date: Sun, 15 Apr 2012 08:44:47 -0700 Subject: [lisplab-cvs] r220 - trunk/src/vector2 Message-ID: Author: jivestgarden Date: Sun Apr 15 08:44:46 2012 New Revision: 220 Log: Removed unused dir Deleted: trunk/src/vector2/ From jivestgarden at common-lisp.net Sun Apr 15 15:45:29 2012 From: jivestgarden at common-lisp.net (jivestgarden at common-lisp.net) Date: Sun, 15 Apr 2012 08:45:29 -0700 Subject: [lisplab-cvs] r221 - trunk/src/matrix2 Message-ID: Author: jivestgarden Date: Sun Apr 15 08:45:29 2012 New Revision: 221 Log: Removed unused dir Deleted: trunk/src/matrix2/ From jivestgarden at common-lisp.net Sun Apr 15 15:45:56 2012 From: jivestgarden at common-lisp.net (jivestgarden at common-lisp.net) Date: Sun, 15 Apr 2012 08:45:56 -0700 Subject: [lisplab-cvs] r222 - trunk/src/matrix1/generic Message-ID: Author: jivestgarden Date: Sun Apr 15 08:45:56 2012 New Revision: 222 Log: Removed unused dir Deleted: trunk/src/matrix1/generic/ From jivestgarden at common-lisp.net Sun Apr 15 15:46:58 2012 From: jivestgarden at common-lisp.net (jivestgarden at common-lisp.net) Date: Sun, 15 Apr 2012 08:46:58 -0700 Subject: [lisplab-cvs] r223 - trunk/src/matrix1 Message-ID: Author: jivestgarden Date: Sun Apr 15 08:46:58 2012 New Revision: 223 Log: Removed unused dir Deleted: trunk/src/matrix1/ From jivestgarden at common-lisp.net Sun Apr 15 19:16:31 2012 From: jivestgarden at common-lisp.net (jivestgarden at common-lisp.net) Date: Sun, 15 Apr 2012 12:16:31 -0700 Subject: [lisplab-cvs] r225 - trunk Message-ID: Author: jivestgarden Date: Sun Apr 15 12:16:31 2012 New Revision: 225 Log: Cleaned asdf file. Poorly tested Modified: trunk/lisplab.asd Modified: trunk/lisplab.asd ============================================================================== --- trunk/lisplab.asd Sun Apr 15 11:48:36 2012 (r224) +++ trunk/lisplab.asd Sun Apr 15 12:16:31 2012 (r225) @@ -26,6 +26,10 @@ ;; Default system, without all libs :depends-on (:lisplab-base + :lisplab-level0 + :lisplab-level1 + :lisplab-level2 + :lisplab-level3 :lisplab-matlisp :lisplab-fftw :slatec @@ -39,6 +43,7 @@ ; :depends-on (:lisplab-base :quadpack) :components ((:file "quadpack"))))) + (defsystem :lisplab-base :depends-on () :serial t @@ -59,16 +64,38 @@ (:file "store-ordinary-functions") (:file "integer-store-functions") (:file "permutation") - )) + )))) + +(defsystem :lisplab-level0 + :depends-on (:lisplab-base) + :components + ( (:module :src/interface/0 - :depends-on ("package") - :serial t + :depends-on () :components ((:file "level0-interface"))) + ;; + ;; All core none-matrix stuff (level 0) + ;; + (:module :src/core + :depends-on (:src/interface/0) + :components + ((:file "level0-functions") + (:file "level0-thread"))) - (:module :src/interface/1 + (:module :src/list :depends-on (:src/interface/0) + :components ((:file "list"))) + )) + + +(defsystem :lisplab-level1 + :depends-on (:lisplab-level0) + :components + ( + (:module :src/interface/1 + :depends-on () :serial t :components ((:file "level1-element") @@ -77,45 +104,18 @@ (:file "matrix1-interface") (:file "matrix1-classes"))) - (:module :src/interface/2 - :depends-on (:src/interface/1) - :serial t - :components - ((:file "vector2-interface") - (:file "matrix2-interface"))) - - (:module :src/interface/3 - :depends-on (:src/interface/2) - :serial t - :components - ((:file "level3-io-interface") - (:file "level3-linalg-interface") - (:file "level3-fft-interface"))) - - ;; - ;; All core none-matrix stuff (level 0) - ;; - (:module :src/core - :depends-on (:src/interface/0) - :components - ((:file "level0-functions") - (:file "level0-thread"))) - (:module :src/vector/1/df :depends-on (:src/interface/1) - :serial t :components ((:file "vector1-d"))) (:module :src/vector/1/z :depends-on (:src/interface/1) - :serial t :components ((:file "vector1-z"))) (:module :src/vector/1/ub :depends-on (:src/interface/1) - :serial t :components ((:file "vector1-ub1") (:file "vector1-ub8") @@ -140,29 +140,40 @@ (:module :src/matrix/1/df :depends-on (:src/interface/1) - :serial t :components ((:file "matrix1-dge") (:file "matrix1-ddiag") (:file "matrix1-dgt"))) (:module :src/matrix/1/z - :depends-on (:src/core :src/matrix/1 :src/vector/1/z) - :serial t + :depends-on (:src/interface/1) :components ((:file "matrix1-zge"))) (:module :src/matrix/1/ub - :depends-on (:src/interface/1 :src/vector/1/ub) - :serial t + :depends-on (:src/interface/1) :components ((:file "matrix1-ub1") (:file "matrix1-ub8") (:file "matrix1-ub16") - (:file "matrix1-ub32") - )) + (:file "matrix1-ub32"))) - (:module :src/vector/2 + )) + + +(defsystem :lisplab-level2 + :depends-on (:lisplab-level1) + :components + ( + (:module :src/interface/2 + :depends-on () + :serial t + :components + ((:file "vector2-interface") + (:file "matrix2-interface"))) + + +(:module :src/vector/2 :depends-on (:src/interface/2) :serial t :components @@ -171,60 +182,61 @@ (:file "vector2-function"))) (:module :src/vector/2/df - :depends-on (:src/interface/2 :src/vector/1/df) - :serial t + :depends-on (:src/interface/2) :components ( (:file "vector2-dge"))) (:module :src/vector/2/z - :depends-on (:src/vector/2 :src/vector/1/z) - :serial t + :depends-on (:src/interface/2) :components ((:file "vector2-zge"))) (:module :src/vector/2/ub - :depends-on (:src/interface/2 :src/vector/1/ub) - :serial t + :depends-on (:src/interface/2) :components ((:file "vector2-integer-functions"))) - (:module :src/list - :depends-on (:src/interface/0) - :serial t - :components ((:file "list"))) - (:module :src/matrix/2 - :depends-on (:src/interface/2 :src/matrix/1) - :serial t + :depends-on (:src/interface/2) :components ((:file "matrix2-constructors"))) (:module :src/matrix/2/generic - :depends-on (:src/interface/2 :src/matrix/1) + :depends-on (:src/interface/2) :serial t :components ((:file "matrix2-generic") (:file "matrix2-view"))) (:module :src/matrix/2/df - :depends-on (:src/interface/2 :src/vector/2/df) - :serial t + :depends-on (:src/interface/2) :components - ( - (:file "matrix2-dge"))) + ((:file "matrix2-dge"))) (:module :src/matrix/2/ub - :depends-on (:src/matrix/2 :src/vector/2/ub) - :serial t + :depends-on (:src/interface/2) :components ((:file "matrix2-integer-constructors"))) - + + )) + + +(defsystem :lisplab-level3 + :depends-on (:lisplab-level2) + :components + ( + (:module :src/interface/3 + :depends-on () + :components + ((:file "level3-io-interface") + (:file "level3-linalg-interface") + (:file "level3-fft-interface"))) + ;; ;; IO (level 3) ;; (:module :src/io - :depends-on (:src/matrix/2) - :serial t + :depends-on (:src/interface/3) :components ((:file "level3-io") (:file "ieee-floats") @@ -234,8 +246,7 @@ ;; Linear algebra lisp implementation (Level 3) ;; (:module :src/linalg - :depends-on (:src/matrix/2) - :serial t + :depends-on (:src/interface/3) :components ((:file "level3-linalg-generic") (:file "level3-linalg-dge"))) @@ -244,8 +255,7 @@ ;; Fast Fourier transform (Level 3) ;; (:module :src/fft - :depends-on (:src/matrix/2) - :serial t + :depends-on (:src/interface/3) :components ((:file "level3-fft-generic") (:file "level3-fft-zge"))) @@ -254,19 +264,18 @@ ;; Euler and Runge-Kutt solvers (Level 3) ;; (:module :src/extra - :depends-on (:src/matrix/2) - :serial t + :depends-on () :components - ( - (:file "level3-rk4") + ((:file "level3-rk4") (:file "level3-euler") (:file "extra") (:file "infpre") )) )) + (defsystem :lisplab-matlisp - :depends-on (:lisplab-base) + :depends-on (:lisplab-level3) :serial t :components ( @@ -305,7 +314,7 @@ (:file "tridiag"))))) (defsystem :lisplab-fftw - :depends-on (:lisplab-base) + :depends-on (:lisplab-level1) :serial t :components ( From jivestgarden at common-lisp.net Sun Apr 15 19:32:38 2012 From: jivestgarden at common-lisp.net (jivestgarden at common-lisp.net) Date: Sun, 15 Apr 2012 12:32:38 -0700 Subject: [lisplab-cvs] r226 - in trunk: . src/interface/1 src/vector/1/generic Message-ID: Author: jivestgarden Date: Sun Apr 15 12:32:38 2012 New Revision: 226 Log: moved code to new file Added: trunk/src/vector/1/generic/ trunk/src/vector/1/generic/vector1-generic.lisp Modified: trunk/lisplab.asd trunk/src/interface/1/vector1-base.lisp Modified: trunk/lisplab.asd ============================================================================== --- trunk/lisplab.asd Sun Apr 15 12:16:31 2012 (r225) +++ trunk/lisplab.asd Sun Apr 15 12:32:38 2012 (r226) @@ -104,6 +104,11 @@ (:file "matrix1-interface") (:file "matrix1-classes"))) + (:module :src/vector/1/generic + :depends-on (:src/interface/1) + :components + ((:file "vector1-generic"))) + (:module :src/vector/1/df :depends-on (:src/interface/1) :components Modified: trunk/src/interface/1/vector1-base.lisp ============================================================================== --- trunk/src/interface/1/vector1-base.lisp Sun Apr 15 12:16:31 2012 (r225) +++ trunk/src/interface/1/vector1-base.lisp Sun Apr 15 12:32:38 2012 (r226) @@ -17,12 +17,6 @@ ;;; with this program; if not, write to the Free Software Foundation, Inc., ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -;;; In lisplab, any matrix is a vector ! -;;; The vectors are 1D objects and respond to -;;; the methods: -;;; size, dim, element-type, vref, vector-p, rank - - (in-package :lisplab) (defclass vector-base () @@ -43,30 +37,4 @@ :reader vector-store :type type-blas-store))) -;;; General - -(defmethod print-object ((v vector-base) stream) - (print-unreadable-object (v stream :type t :identity t) - (dotimes (i (min (size v) *lisplab-print-size*)) - (format stream "~a " (vref v i))))) - -(defmethod vector-p ((x vector-base)) t) - -(defmethod rank ((x vector-base)) - 1) - -(defmethod dim ((x vector-base) &optional d) - (if d - (ecase d (0 (size x))) - (list (size x)))) - -;;; Untyped vectors - -(defmethod vref ((vector vector-any) idx) - (aref (slot-value vector 'store) idx)) - -(defmethod (setf vref) (value (vector vector-any) idx) - (setf (aref (slot-value vector 'store) idx) - value)) - Added: trunk/src/vector/1/generic/vector1-generic.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/vector/1/generic/vector1-generic.lisp Sun Apr 15 12:32:38 2012 (r226) @@ -0,0 +1,47 @@ +;;; Lisplab, vector1-generic.lisp +;;; Generic vector implementaion + +;;; 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) + +;;; General + +(defmethod print-object ((v vector-base) stream) + (print-unreadable-object (v stream :type t :identity t) + (dotimes (i (min (size v) *lisplab-print-size*)) + (format stream "~a " (vref v i))))) + +(defmethod vector-p ((x vector-base)) t) + +(defmethod rank ((x vector-base)) + 1) + +(defmethod dim ((x vector-base) &optional d) + (if d + (ecase d (0 (size x))) + (list (size x)))) + +;;; Untyped vectors + +(defmethod vref ((vector vector-any) idx) + (aref (slot-value vector 'store) idx)) + +(defmethod (setf vref) (value (vector vector-any) idx) + (setf (aref (slot-value vector 'store) idx) + value)) + From jivestgarden at common-lisp.net Sun Apr 15 19:36:01 2012 From: jivestgarden at common-lisp.net (jivestgarden at common-lisp.net) Date: Sun, 15 Apr 2012 12:36:01 -0700 Subject: [lisplab-cvs] r227 - in trunk/src: interface/1 vector/1/z Message-ID: Author: jivestgarden Date: Sun Apr 15 12:36:00 2012 New Revision: 227 Log: Moved class definition Modified: trunk/src/interface/1/vector1-base.lisp trunk/src/vector/1/z/vector1-z.lisp Modified: trunk/src/interface/1/vector1-base.lisp ============================================================================== --- trunk/src/interface/1/vector1-base.lisp Sun Apr 15 12:32:38 2012 (r226) +++ trunk/src/interface/1/vector1-base.lisp Sun Apr 15 12:36:00 2012 (r227) @@ -31,10 +31,5 @@ :reader vector-store :type (simple-array t (*))))) -(defclass vector-z (vector-base element-complex-double-float) - ((store :initarg :store - :initform nil - :reader vector-store - :type type-blas-store))) Modified: trunk/src/vector/1/z/vector1-z.lisp ============================================================================== --- trunk/src/vector/1/z/vector1-z.lisp Sun Apr 15 12:32:38 2012 (r226) +++ trunk/src/vector/1/z/vector1-z.lisp Sun Apr 15 12:36:00 2012 (r227) @@ -19,6 +19,12 @@ (in-package :lisplab) +(defclass vector-z (vector-base element-complex-double-float) + ((store :initarg :store + :initform nil + :reader vector-store + :type type-blas-store))) + (defmethod vref ((vector vector-z) i) (ref-blas-complex-store (slot-value vector 'store) i 0 1)) From jivestgarden at common-lisp.net Fri Apr 20 18:33:47 2012 From: jivestgarden at common-lisp.net (jivestgarden at common-lisp.net) Date: Fri, 20 Apr 2012 11:33:47 -0700 Subject: [lisplab-cvs] r228 - in trunk: . src/vector/2 src/vector/2/generic Message-ID: Author: jivestgarden Date: Fri Apr 20 11:33:46 2012 New Revision: 228 Log: Created vector generic Added: trunk/src/vector/2/generic/ trunk/src/vector/2/generic/vector2-function.lisp - copied unchanged from r227, trunk/src/vector/2/vector2-function.lisp trunk/src/vector/2/generic/vector2-generic.lisp - copied unchanged from r227, trunk/src/vector/2/vector2-generic.lisp trunk/src/vector/2/generic/vector2-operator.lisp - copied unchanged from r227, trunk/src/vector/2/vector2-operator.lisp Deleted: trunk/src/vector/2/vector2-function.lisp trunk/src/vector/2/vector2-generic.lisp trunk/src/vector/2/vector2-operator.lisp Modified: trunk/lisplab.asd Modified: trunk/lisplab.asd ============================================================================== --- trunk/lisplab.asd Sun Apr 15 12:36:00 2012 (r227) +++ trunk/lisplab.asd Fri Apr 20 11:33:46 2012 (r228) @@ -178,7 +178,7 @@ (:file "matrix2-interface"))) -(:module :src/vector/2 +(:module :src/vector/2/generic :depends-on (:src/interface/2) :serial t :components Copied: trunk/src/vector/2/generic/vector2-function.lisp (from r227, trunk/src/vector/2/vector2-function.lisp) ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/vector/2/generic/vector2-function.lisp Fri Apr 20 11:33:46 2012 (r228, copy of r227, trunk/src/vector/2/vector2-function.lisp) @@ -0,0 +1,79 @@ +;;; Lisplab, level2-generic.lisp +;;; Level2, non-specialized methods for functions. + +;;; 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 def-each-element-function (name) + (let ((a (gensym))) + `(defmethod ,name ((,a vector-base)) + (mmap t #',name ,a)))) + +(define-constant +ordinary-functions-number-to-number-list+ + '(.sin .cos .tan + .asin .acos .atan + .sinh .cosh .tanh + .asinh .acosh .atanh + .re .im .abs .sgn + .exp .ln .sqr .sqrt .conj .not)) + +(defmacro expand-each-element-ordinary-functions () + (cons 'progn + (mapcar (lambda (name) + `(def-each-element-function ,name)) + +ordinary-functions-number-to-number-list+ ))) + +(expand-each-element-ordinary-functions) + + +;;; Some special functions. Should maybe be separated out. + +(defmethod .erf ((a vector-base)) + (mmap t #'.erf a)) + +(defmethod .erfc ((a vector-base)) + (mmap t #'.erfc a)) + +(defmethod .gamma ((a vector-base)) + (mmap t #'.gamma a)) + +(defmethod .besj (n (a vector-base)) + (mmap t #'(lambda (x) (.besj n x)) a)) + +(defmethod .besj (n (a vector-base)) + (mmap t #'(lambda (x) (.besj n x)) a)) + +(defmethod .besj (n (a vector-base)) + (mmap t #'(lambda (x) (.besj n x)) a)) + +(defmethod .besy (n (a vector-base)) + (mmap t #'(lambda (x) (.besy n x)) a)) + +(defmethod .besi (n (a vector-base)) + (mmap t #'(lambda (x) (.besi n x)) a)) + +(defmethod .besk (n (a vector-base)) + (mmap t #'(lambda (x) (.besk n x)) a)) + +(defmethod .besh1 (n (a vector-base)) + (mmap t #'(lambda (x) (.besh1 n x)) a)) + +(defmethod .besh2 (n (a vector-base)) + (mmap t #'(lambda (x) (.besh2 n x)) a)) + + Copied: trunk/src/vector/2/generic/vector2-generic.lisp (from r227, trunk/src/vector/2/vector2-generic.lisp) ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/vector/2/generic/vector2-generic.lisp Fri Apr 20 11:33:46 2012 (r228, copy of r227, trunk/src/vector/2/vector2-generic.lisp) @@ -0,0 +1,161 @@ +;;; Lisplab, level2-generic.lisp +;;; Level2, non-specialized 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) + +;;; For general vector + +(defmethod vdot ((a vector-base) (b vector-base)) + (msum (.* a b))) + +(defmethod vcross :before ((a vector-base) (b vector-base)) + (assert (= (size a) (size b) 3))) + +(defmethod vcross ((a vector-base) (b vector-base)) + (let ((out (mcreate a))) + (setf (vref out 0) (.- (.* (vref a 1) (vref b 2)) + (.* (vref a 2) (vref b 1))) + (vref out 1) (.- (.* (vref a 2) (vref b 0)) + (.* (vref a 0) (vref b 2))) + (vref out 2) (.- (.* (vref a 0) (vref b 1)) + (.* (vref a 1) (vref b 0)))) + out)) + +(defmethod vnorm ((a vector-base)) + (.sqrt (vdot (.conj a) a))) + +;;; Vector operations (ignore structure) + +(defmethod copy ((a vector-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 mmap ((type (eql t)) f (a vector-base) &rest args) + "Maps with output type given by first matrix." + (apply #'mmap (type-of a) f a args)) + +(defmethod mmap ((b (eql nil)) f (a vector-base) &rest args) + (cond ((not args) + (dotimes (i (size a)) + (funcall f (vref a i)))) + ((not (cdr args)) + (let ((c (car args))) + (dotimes (i (size a)) + (funcall f (vref a i) (vref c i))))) + (t (dotimes (i (size a)) + (apply f (vref a i) + (mapcar (lambda (x) + (vref x i)) + args))))) + nil) + +(defmethod mmap ((type symbol) f (a vector-base) &rest args) + (apply #'mmap-into (make-matrix-instance type (dim a) 0) f a args)) + +(defmethod mmap ((type list) f (a vector-base) &rest args) + ;; The type here is a spec + (apply #'mmap-into (make-matrix-instance type (dim a) 0) f a args)) + +;; TODO map of matrix desciptions +(defmethod mmap-into ((b vector-base) f (a vector-base) &rest args) + (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 msum ((m vector-base)) + (let ((sum 0)) + (dotimes (i (size m)) + (setf sum (.+ sum (vref m i)))) + sum)) + +(defmethod mmax ((m vector-base)) + (let ((max (vref m 0)) + (idx 0)) + (dotimes (i (size m)) + (when (.> (vref m i) max) + (setf max (vref m i) + idx i))) + (values max idx))) + +(defmethod mmin ((m vector-base)) + (let ((min (vref m 0)) + (idx 0)) + (dotimes (i (size m)) + (when (.< (vref m i) min) + (setf min (vref m i) + idx i))) + (values min idx))) + +(defmethod mabsmax ((m vector-base)) + (let ((max (vref m 0)) + (idx 0)) + (dotimes (i (size m)) + (when (.> (abs (vref m i)) (abs max)) + (setf max (vref m i) + idx i))) + (values max idx))) + +(defmethod mabsmin ((m vector-base)) + (let ((min (vref m 0)) + (idx 0)) + (dotimes (i (size m)) + (when (.< (abs (vref m i)) (abs min)) + (setf min (vref m i) + idx i))) + (values min idx))) + +(defmethod mminmax ((m vector-base)) + (let ((max (vref m 0)) + (min (vref m 0))) + (dotimes (i (size m)) + (when (.> (vref m i) max) + (setf max (vref m i))) + (when (.< (vref m i) min) + (setf min (vref m i)))) + (list min max))) + +(defmethod mfill ((a vector-base) val) + (dotimes (i (size a)) + (setf (vref a i) val)) + val) + + Copied: trunk/src/vector/2/generic/vector2-operator.lisp (from r227, trunk/src/vector/2/vector2-operator.lisp) ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/vector/2/generic/vector2-operator.lisp Fri Apr 20 11:33:46 2012 (r228, copy of r227, trunk/src/vector/2/vector2-operator.lisp) @@ -0,0 +1,142 @@ +;;; Lisplab, level2-operator.lisp +;;; Level2, non-specialized 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) +#| +(defmethod .complex ((a vector-base) (b vector-base)) + (.+ a (.* %i b))) +(defmethod .complex ((a vector-base) b) + (.+ a (.* %i b))) +(defmethod .complex (a (b vector-base)) + (.+ a (.* %i b))) +|# + +(defmethod .some (pred (a vector-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 vector-base) &rest args) + (dotimes (i (size a)) + (unless (apply pred (mapcar (lambda (x) (vref x i)) (cons a args))) + (return-from .every nil))) + t) + +;;;; Basic boolean operators + +(defmethod .= ((a vector-base) (b vector-base) &optional acc) + (if acc + (.every (lambda (a b) (.= a b acc)) a b) + (.every #'.= a b))) + +(defmethod .= ((a vector-base) (b number) &optional acc) + (if acc + (.every (lambda (a) (.= a b acc)) a) + (.every (lambda (a) (.= a b)) a))) + +(defmethod .= ((a number) (b vector-base) &optional acc) + (if acc + (.every (lambda (b) (.= a b acc)) b) + (.every (lambda (b) (.= a b)) b))) + +(defmethod ./= ((a vector-base) (b vector-base) &optional acc) + (not (.= a b acc))) + +(defmethod ./= ((a vector-base) (b number) &optional acc) + (not (.= a b acc))) + +(defmethod ./= ((a number) (b vector-base) &optional acc) + (not (.= a b acc))) + +(defmacro def-vector-base-boolean-operator (op) + (let ((a (gensym)) + (b (gensym))) + `(progn + (defmethod ,op ((,a vector-base) (,b vector-base)) + (.every #',op ,a ,b)) + (defmethod ,op ((,a vector-base) (,b number)) + (.every (lambda (,a) (,op ,a ,b)) ,a)) + (defmethod ,op ((,a number) (,b vector-base)) + (.every (lambda (,b) (,op ,a ,b)) ,b))))) + +(def-vector-base-boolean-operator .<) + +(def-vector-base-boolean-operator .<=) + +(def-vector-base-boolean-operator .>) + +(def-vector-base-boolean-operator .>=) + +;;; Element-wise operators + +(defmethod mmap-operator (op (a vector-base) b output) + (mmap-into output (lambda (x) (funcall op x b)) a)) + +(defmethod mmap-operator (op a (b vector-base) output) + (mmap-into output (lambda (x) (funcall op a x)) b)) + +(defmethod mmap-operator (op (a vector-base) (b vector-base) output) + (mmap-into output op a b)) + +(defmacro defmethod-operator-vector-vector (name) + (let ((a (gensym)) + (b (gensym))) + `(defmethod ,name ((,a vector-base) (,b vector-base)) + (mmap-operator #',name ,a ,b (mcreate ,a))))) + +(defmacro defmethod-operator-vector-any (name) + (let ((a (gensym)) + (b (gensym)) + (out (gensym))) + `(defmethod ,name ((,a vector-base) ,b) + (let ((,out (mcreate ,a))) + (mmap-operator #',name ,a ,b ,out))))) + +(defmacro defmethod-operator-any-vector (name) + (let ((a (gensym)) + (b (gensym)) + (out (gensym))) + `(defmethod ,name (,a (,b vector-base)) + (let ((,out (mcreate ,b))) + (mmap-operator #',name ,a ,b ,out))))) + +(defmacro def-each-element-operator (name) + "Makes so that the binary operator can map element-wice." + `(progn + (defmethod-operator-vector-vector ,name) + (defmethod-operator-vector-any ,name) + (defmethod-operator-any-vector ,name) + 'thats-it)) + +(def-each-element-operator .complex) +(def-each-element-operator .add) +(def-each-element-operator .mul) +(def-each-element-operator .div) +(def-each-element-operator .sub) +(def-each-element-operator .expt) +(def-each-element-operator .max) +(def-each-element-operator .min) + +(def-each-element-operator .and) +(def-each-element-operator .nand) +(def-each-element-operator .or) +(def-each-element-operator .nor) +(def-each-element-operator .xor) + From jivestgarden at common-lisp.net Fri Apr 20 18:40:23 2012 From: jivestgarden at common-lisp.net (jivestgarden at common-lisp.net) Date: Fri, 20 Apr 2012 11:40:23 -0700 Subject: [lisplab-cvs] r229 - in trunk: . src/matrix/1 src/matrix/1/funmat Message-ID: Author: jivestgarden Date: Fri Apr 20 11:40:23 2012 New Revision: 229 Log: Moved funmat Added: trunk/src/matrix/1/funmat/ trunk/src/matrix/1/funmat/level1-funmat.lisp - copied unchanged from r227, trunk/src/matrix/1/level1-funmat.lisp Deleted: trunk/src/matrix/1/level1-funmat.lisp Modified: trunk/lisplab.asd Modified: trunk/lisplab.asd ============================================================================== --- trunk/lisplab.asd Fri Apr 20 11:33:46 2012 (r228) +++ trunk/lisplab.asd Fri Apr 20 11:40:23 2012 (r229) @@ -132,8 +132,13 @@ :depends-on (:src/interface/1) :serial t :components - ((:file "matrix1-constructors") - (:file "level1-funmat"))) + ((:file "matrix1-constructors"))) + + (:module :src/matrix/1/funmat + :depends-on (:src/interface/1) + :serial t + :components + ((:file "level1-funmat"))) (:module :src/matrix/1/generic :depends-on (:src/interface/1) Copied: trunk/src/matrix/1/funmat/level1-funmat.lisp (from r227, trunk/src/matrix/1/level1-funmat.lisp) ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/matrix/1/funmat/level1-funmat.lisp Fri Apr 20 11:40:23 2012 (r229, copy of r227, trunk/src/matrix/1/level1-funmat.lisp) @@ -0,0 +1,64 @@ +;;; Lisplab, level1-dge.lisp +;;; General, storeless 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) + +;;; Function matrices (matrices without a store) + +(defclass function-matrix + (structure-general element-base implementation-base vector-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.")) + +(defmethod initialize-instance :after ((m function-matrix) &key) + (with-slots (rows cols size) m + (setf size (* rows cols)))) + +;;; Level1 methods specialized for the 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)) From jivestgarden at common-lisp.net Fri Apr 20 19:42:29 2012 From: jivestgarden at common-lisp.net (jivestgarden at common-lisp.net) Date: Fri, 20 Apr 2012 12:42:29 -0700 Subject: [lisplab-cvs] r230 - in trunk: . src/matrix/1/funmat src/vector/1/funmat Message-ID: Author: jivestgarden Date: Fri Apr 20 12:42:28 2012 New Revision: 230 Log: Created function-vector Added: trunk/src/vector/1/funmat/ Modified: trunk/lisplab.asd trunk/src/matrix/1/funmat/level1-funmat.lisp Modified: trunk/lisplab.asd ============================================================================== --- trunk/lisplab.asd Fri Apr 20 11:40:23 2012 (r229) +++ trunk/lisplab.asd Fri Apr 20 12:42:28 2012 (r230) @@ -128,17 +128,17 @@ (:file "vector1-ub32") (:file "vector1-idx"))) - (:module :src/matrix/1 + (:module :src/vector/1/funmat :depends-on (:src/interface/1) :serial t :components - ((:file "matrix1-constructors"))) + ((:file "vector1-funmat"))) - (:module :src/matrix/1/funmat + (:module :src/matrix/1 :depends-on (:src/interface/1) :serial t :components - ((:file "level1-funmat"))) + ((:file "matrix1-constructors"))) (:module :src/matrix/1/generic :depends-on (:src/interface/1) @@ -167,6 +167,12 @@ (:file "matrix1-ub8") (:file "matrix1-ub16") (:file "matrix1-ub32"))) + + (:module :src/matrix/1/funmat + :depends-on (:src/interface/1) + :serial t + :components + ((:file "level1-funmat"))) )) Modified: trunk/src/matrix/1/funmat/level1-funmat.lisp ============================================================================== --- trunk/src/matrix/1/funmat/level1-funmat.lisp Fri Apr 20 11:40:23 2012 (r229) +++ trunk/src/matrix/1/funmat/level1-funmat.lisp Fri Apr 20 12:42:28 2012 (r230) @@ -1,7 +1,7 @@ -;;; Lisplab, level1-dge.lisp +;;; Lisplab, vector1-funmat.lisp ;;; General, storeless matrices -;;; Copyright (C) 2009 Joern Inge Vestgaarden +;;; Copyright (C) 2012 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 @@ -22,7 +22,7 @@ ;;; Function matrices (matrices without a store) (defclass function-matrix - (structure-general element-base implementation-base vector-base) + (structure-general element-base implementation-base function-vector) ((mref :initarg :mref :initform (constantly 0) @@ -32,16 +32,6 @@ :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.")) @@ -57,8 +47,3 @@ (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)) From jivestgarden at common-lisp.net Sat Apr 28 15:37:43 2012 From: jivestgarden at common-lisp.net (jivestgarden at common-lisp.net) Date: Sat, 28 Apr 2012 08:37:43 -0700 Subject: [lisplab-cvs] r231 - in trunk: . src/matrix/1/array src/matrix/2/array src/vector/1/array src/vector/1/funmat Message-ID: Author: jivestgarden Date: Sat Apr 28 08:37:42 2012 New Revision: 231 Log: arrays as matrices Added: trunk/src/matrix/1/array/ trunk/src/matrix/1/array/matrix1-array.lisp trunk/src/matrix/2/array/ trunk/src/matrix/2/array/matrix2-array.lisp trunk/src/vector/1/array/ trunk/src/vector/1/array/vector1-array.lisp trunk/src/vector/1/funmat/vector1-funmat.lisp Modified: trunk/lisplab.asd Modified: trunk/lisplab.asd ============================================================================== --- trunk/lisplab.asd Fri Apr 20 12:42:28 2012 (r230) +++ trunk/lisplab.asd Sat Apr 28 08:37:42 2012 (r231) @@ -130,13 +130,16 @@ (:module :src/vector/1/funmat :depends-on (:src/interface/1) - :serial t :components ((:file "vector1-funmat"))) + (:module :src/vector/1/array + :depends-on (:src/interface/1) + :components + ((:file "vector1-array"))) + (:module :src/matrix/1 :depends-on (:src/interface/1) - :serial t :components ((:file "matrix1-constructors"))) @@ -170,9 +173,13 @@ (:module :src/matrix/1/funmat :depends-on (:src/interface/1) - :serial t :components ((:file "level1-funmat"))) + + (:module :src/matrix/1/array + :depends-on (:src/interface/1) + :components + ((:file "matrix1-array"))) )) @@ -234,6 +241,11 @@ :components ((:file "matrix2-integer-constructors"))) + (:module :src/matrix/2/array + :depends-on (:src/interface/2) + :components + ((:file "matrix2-array"))) + )) Added: trunk/src/matrix/1/array/matrix1-array.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/matrix/1/array/matrix1-array.lisp Sat Apr 28 08:37:42 2012 (r231) @@ -0,0 +1,36 @@ +;;; Lisplab, matrix1-array.lisp +;;; Level1, treats normal lisp arrays as matrices + +;;; Copyright (C) 2012 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 rows ((a array)) + (array-dimension a 0)) + +(defmethod cols ((a array)) + (array-dimension a 1)) + +(defmethod mref ((a array) row col) + "Row major order" + (aref a row col)) + +(defmethod (setf mref) (value (a array) row col) + (setf (aref a row col) (convert value (element-type a)))) + +(defmethod make-matrix-instance ((x (eql 'array)) dim value) + (make-array dim :initial-element value)) \ No newline at end of file Added: trunk/src/matrix/2/array/matrix2-array.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/matrix/2/array/matrix2-array.lisp Sat Apr 28 08:37:42 2012 (r231) @@ -0,0 +1,30 @@ +;;; Lisplab, matrix2-array.lisp +;;; Lisp array methods. + +;;; Copyright (C) 2012 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 ((a array)) + (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))) + Added: trunk/src/vector/1/array/vector1-array.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/vector/1/array/vector1-array.lisp Sat Apr 28 08:37:42 2012 (r231) @@ -0,0 +1,47 @@ +;;; Lisplab, vector1-array.lisp +;;; Level1, treats normal lisp arrays as vectors + +;;; Copyright (C) 2012 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 vector-p ((a array)) + "True for any array through row-major-aref" + t) + +(defmethod dim ((a array) &optional axis) + (if axis + (array-dimension a axis) + (array-dimensions a))) + +(defmethod size ((a array)) + (reduce #'* (dim a))) + +(defmethod rank ((a array)) + (array-rank a)) + +(defmethod element-type ((a array)) + "Gets the element type of the array" + (array-element-type a)) + +(defmethod vref ((a array) idx) + "Row major order" + (row-major-aref a idx)) + +(defmethod (setf vref) (value (a array) idx) + (setf (row-major-aref a idx) value)) + Added: trunk/src/vector/1/funmat/vector1-funmat.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/vector/1/funmat/vector1-funmat.lisp Sat Apr 28 08:37:42 2012 (r231) @@ -0,0 +1,43 @@ +;;; Lisplab, vector1-funmat.lisp +;;; General, storeless vectors + +;;; Copyright (C) 2012 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) + +;;; Function matrices (matrices without a store) + +(defclass function-vector (vector-base) + ((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 "Vector without a store.")) + +;;; Level1 methods specialized for the function matrix + +(defmethod vref ((f function-vector) idx) + (funcall (function-matrix-vref f) f idx)) + +(defmethod (setf vref) (value (f function-vector) idx) + (funcall (function-matrix-set-vref f) value f idx)) From jivestgarden at common-lisp.net Sun Apr 29 19:24:02 2012 From: jivestgarden at common-lisp.net (jivestgarden at common-lisp.net) Date: Sun, 29 Apr 2012 12:24:02 -0700 Subject: [lisplab-cvs] r232 - in trunk/src: interface/1 vector/1/df Message-ID: Author: jivestgarden Date: Sun Apr 29 12:24:01 2012 New Revision: 232 Log: Unfinished macro stuff Modified: trunk/src/interface/1/vector1-base.lisp trunk/src/vector/1/df/vector1-d.lisp Modified: trunk/src/interface/1/vector1-base.lisp ============================================================================== --- trunk/src/interface/1/vector1-base.lisp Sat Apr 28 08:37:42 2012 (r231) +++ trunk/src/interface/1/vector1-base.lisp Sun Apr 29 12:24:01 2012 (r232) @@ -31,5 +31,33 @@ :reader vector-store :type (simple-array t (*))))) +;;; TODO make similar macros for integer types, that would be more useful +(defmacro ll-def-vector-class (class-name element-parent store-type) + `(defclass ,class-name (vector-base ,element-parent) + ((store :initarg :store + :initform nil + :reader vector-store + :type ,store-type)))) +(defmacro ll-def-vref (class-name store-type) + (let ((v (gensym "vector")) + (idx (gensym "idx"))) + `(defmethod vref ((,v ,class-name) ,idx) + (aref (the ,store-type (slot-value ,v 'store)) ,idx)))) + +(defmacro ll-def-setf-vref (class-name store-type element-type) + (let ((v (gensym "vector")) + (idx (gensym "idx")) + (value (gensym "value"))) + `(defmethod (setf vref) (,value (,v ,class-name) ,idx) + (let ((,value (coerce ,value ',element-type))) + (declare (type ,element-type ,value)) + (setf (aref (the ,store-type (slot-value ,v 'store)) ,idx) + ,value) + ,value)))) + +(defmacro ll-def-vector1-class-and-vref (class-name element-parent store-type element-type) + `(progn (ll-def-vector-class ,class-name ,element-parent ,store-type) + (ll-def-vref ,class-name ,store-type) + (ll-def-setf-vref ,class-name ,store-type ,element-type))) Modified: trunk/src/vector/1/df/vector1-d.lisp ============================================================================== --- trunk/src/vector/1/df/vector1-d.lisp Sat Apr 28 08:37:42 2012 (r231) +++ trunk/src/vector/1/df/vector1-d.lisp Sun Apr 29 12:24:01 2012 (r232) @@ -19,6 +19,8 @@ (in-package :lisplab) +;; (ll-def-vector1-class-and-vref vector-d element-double-float type-blas-store double-float) + (defclass vector-d (vector-base element-double-float) ((store :initarg :store :initform nil From jivestgarden at common-lisp.net Sun Apr 29 19:29:44 2012 From: jivestgarden at common-lisp.net (jivestgarden at common-lisp.net) Date: Sun, 29 Apr 2012 12:29:44 -0700 Subject: [lisplab-cvs] r233 - in trunk/src: draft test Message-ID: Author: jivestgarden Date: Sun Apr 29 12:29:43 2012 New Revision: 233 Log: Prepear new tests Added: trunk/src/draft/CLUnit.lisp - copied unchanged from r227, trunk/src/test/CLUnit.lisp trunk/src/draft/lisplab-test.lisp - copied unchanged from r227, trunk/src/test/lisplab-test.lisp trunk/src/draft/mat2txt.c - copied unchanged from r227, trunk/src/test/mat2txt.c Deleted: trunk/src/test/CLUnit.lisp trunk/src/test/lisplab-test.lisp trunk/src/test/mat2txt.c Copied: trunk/src/draft/CLUnit.lisp (from r227, trunk/src/test/CLUnit.lisp) ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/draft/CLUnit.lisp Sun Apr 29 12:29:43 2012 (r233, copy of r227, trunk/src/test/CLUnit.lisp) @@ -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 Copied: trunk/src/draft/lisplab-test.lisp (from r227, trunk/src/test/lisplab-test.lisp) ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/draft/lisplab-test.lisp Sun Apr 29 12:29:43 2012 (r233, copy of r227, trunk/src/test/lisplab-test.lisp) @@ -0,0 +1,36 @@ + + +#+nil (defpackage "LISPLAB.TEST" + (:use "COMMON-LISP" "ORG.ANCAR.CLUNIT")) + +(in-package :org.ancar.CLUnit) + +#+nil (in-package :lisplab.test) + +(deftest "level1-dge-new" + :test-fn (lambda () + (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 "level1-zge-new" + :test-fn (lambda () + (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 "level1-dge-mref" + :test-fn (lambda () + (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-zge-mref" + :test-fn (lambda () + (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 Copied: trunk/src/draft/mat2txt.c (from r227, trunk/src/test/mat2txt.c) ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/draft/mat2txt.c Sun Apr 29 12:29:43 2012 (r233, copy of r227, trunk/src/test/mat2txt.c) @@ -0,0 +1,69 @@ +/* A utility that converts binary matrix files to text files, + * i.e., files stored with lisplabs msave. + * + * This file should never be needed, but it gives + * some extra data safety to have to independent + * implementations of the same file protocol + * + * This file is in the public domain + */ + +#include +#include +#include +#include + +unsigned read_ui32 (FILE *f) { + unsigned buf; + fread(&buf, 1, 4, f); + return ntohl(buf); +} + +double read_f64 (FILE *f) { + double x; + fread(&x, 8, 1, f); + return x; +} + +int main (int argn, char *arg[]) { + FILE *f = NULL; + FILE *out = stdout; + unsigned rows = 0; + unsigned cols=0; + int i=-1,j=-1; + int hdr_len=-1; + double x = -1.0; + + if (argn == 1) { + printf("usage: %s binary_file [text_file]\n", arg[0]); + exit(1); + } + + f = fopen(arg[1],"r"); + assert(f); + assert(read_ui32 (f) == 154777230); + assert(read_ui32 (f) == 10000042); + hdr_len = read_ui32(f); + for (i = 0; i < hdr_len; i++) getc(f); + + rows = read_ui32 (f); + cols = read_ui32 (f); + + if (argn > 2) { + out = fopen(arg[2],"w"); + assert(out); + } + + for (i = 0; i < rows; i++) { + for (j = 0; j < cols; j++) { + fprintf(out,"%.14g ", read_f64(f)); + } + if (i < rows - 1) + fprintf(out,"\n"); + } + if (argn > 2) + fclose(out); + + fclose(f); + return 0; +}