[lisplab-cvs] r228 - in trunk: . src/vector/2 src/vector/2/generic
jivestgarden at common-lisp.net
jivestgarden at common-lisp.net
Fri Apr 20 18:33:47 UTC 2012
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)
+
More information about the lisplab-cvs
mailing list