[lisplab-cvs] r85 - src/core src/matrix src/test
Jørn Inge Vestgården
jivestgarden at common-lisp.net
Mon Aug 17 19:21:52 UTC 2009
Author: jivestgarden
Date: Mon Aug 17 15:21:51 2009
New Revision: 85
Log:
testing and fixing
Added:
src/test/test-methods.lisp
Modified:
lisplab.asd
package.lisp
src/core/level0-functions.lisp
src/core/level0-interface.lisp
src/matrix/level2-matrix-dge.lisp
Modified: lisplab.asd
==============================================================================
--- lisplab.asd (original)
+++ lisplab.asd Mon Aug 17 15:21:51 2009
@@ -243,14 +243,12 @@
:depends-on (:lisplab-base)
:components
(
-
- ;;
- ;; Slatec in lisplab
- ;;
(:module :src/specfunc
:depends-on (:shared/slatec)
:components ((:file "level0-specfunc")))
-
+ ;;
+ ;; Slatec in lisplab
+ ;;
(:module :shared/slatec
:components
(
Modified: package.lisp
==============================================================================
--- package.lisp (original)
+++ package.lisp Mon Aug 17 15:21:51 2009
@@ -204,10 +204,14 @@
"EIGENVECTORS"
;; FFT
- "ffT1"
+ "FFT1"
"IFFT1"
"FFT2"
"IFFT2"
"FFT-SHIFT"
"IFFT-SHIFT"
))
+
+(defpackage "LISPLAB-USER"
+ (:use "COMMON-LISP" "LISPLAB" "SB-EXT")
+ (:nicknames "LL-USER"))
\ No newline at end of file
Modified: src/core/level0-functions.lisp
==============================================================================
--- src/core/level0-functions.lisp (original)
+++ src/core/level0-functions.lisp Mon Aug 17 15:21:51 2009
@@ -116,7 +116,7 @@
`(progn
(defmethod ,(car name) ((a number))
(,(cdr name) a))))
- +functions-real-to-real+)))
+ +ordinary-functions-number-to-number+ )))
(expand-num-num)
@@ -125,16 +125,8 @@
(log x base)
(log x)))
-(defmethod .log ((x real) &optional (base nil))
- (if base
- (log (to-df x) base)
- (log (to-df x))))
-
(defmethod .sqr ((x number))
(* x x))
-(defmethod .sqr ((x float))
- (let ((x (to-df x)))
- (* x x)))
Modified: src/core/level0-interface.lisp
==============================================================================
--- src/core/level0-interface.lisp (original)
+++ src/core/level0-interface.lisp Mon Aug 17 15:21:51 2009
@@ -22,9 +22,11 @@
(define-constant +functions-real-to-real+
'((.sin . sin) (.cos . cos) (.tan . tan)
- (.asin . asin) (.acos . acos) (.atan . atan)
+ ;; (.asin . asin) (.acos . acos)
+ (.atan . atan)
(.sinh . sinh) (.cosh . cosh) (.tanh . tanh)
- (.asinh . asinh) (.acosh . acosh) (.atanh . atanh)
+ (.asinh . asinh) (.acosh . acosh)
+ ;; (.atanh . atanh)
(.exp . exp) (.sqr . .sqr) (.sqrt . sqrt) (.conj . conjugate)
(.realpart . realpart) (.imagpart . imagpart) (.abs . abs)
(.erf . .erf) (.erfc . .erfc)
@@ -32,17 +34,29 @@
"Functions of one argument that map real to real.")
;; Other functions: log, .besj, .besy, .besi, .besk, .besh1, .besh2, .ai
+;;; yes, and: asin, acos, atanh
(define-constant +functions-complex-to-complex+
'((.sin . sin) (.cos . cos) (.tan . tan)
(.asin . asin) (.acos . acos) (.atan . atan)
(.sinh . sinh) (.cosh . cosh) (.tanh . tanh)
(.asinh . asinh) (.acosh . acosh) (.atanh . atanh)
- (.exp . exp) (.sqrt . sqrt) (.conj . conjugate)
+ (.realpart . realpart) (.imagpart . imagpart) (.abs . abs)
+ (.exp . exp) (.sqr . .sqr) (.sqrt . sqrt) (.conj . conjugate)
(.erf . .erf) (.erfc . .erfc)
(.gamma . .gamma))
"Functions of one argument that maps complex to complex.")
+(define-constant +ordinary-functions-number-to-number+
+ '((.sin . sin) (.cos . cos) (.tan . tan)
+ (.asin . asin) (.acos . acos) (.atan . atan)
+ (.sinh . sinh) (.cosh . cosh) (.tanh . tanh)
+ (.asinh . asinh) (.acosh . acosh) (.atanh . atanh)
+ (.exp . exp) (.sqrt . sqrt) (.conj . conjugate))
+ "Functions with a twin in the Common Lisp package.")
+
+
+
(defgeneric scalar? (x)
(:documentation "A scalar is a object with ignored internal structure."))
Modified: src/matrix/level2-matrix-dge.lisp
==============================================================================
--- src/matrix/level2-matrix-dge.lisp (original)
+++ src/matrix/level2-matrix-dge.lisp Mon Aug 17 15:21:51 2009
@@ -175,6 +175,15 @@
(setf (vref ,b ,i) ,form)))
,b)))
+(defmethod .asin ((x matrix-base-dge))
+ (each-matrix-element-df-to-complex-df x (asin x)))
+
+(defmethod .acos ((x matrix-base-dge))
+ (each-matrix-element-df-to-complex-df x (asin x)))
+
+(defmethod .atanh ((x matrix-base-dge))
+ (each-matrix-element-df-to-complex-df x (asin x)))
+
(defmethod .besh1 (n (x matrix-base-dge))
(each-matrix-element-df-to-complex-df x (.besh1 n x)))
Added: src/test/test-methods.lisp
==============================================================================
--- (empty file)
+++ src/test/test-methods.lisp Mon Aug 17 15:21:51 2009
@@ -0,0 +1,118 @@
+;; Simple test routines. Just calls the methods and
+;; prints if there are errors or conditions.
+;; The purpose of just to look for obvious flaws.
+;; Just run an instpect the output.
+;;
+;; (Ideally the output should be zero, but it isn't)
+
+(in-package :lisplab-user)
+
+(defun simple-non-nil-check (fun args)
+ (multiple-value-bind (ok err)
+ (ignore-errors
+ (apply fun args))
+ (if ok
+ (format t "~&OK : (~a ~s) ~%" fun (mapcar #'type-of args))
+ (progn
+ (format t "~&FAILED: (~a ~s) ~%" fun (mapcar #'type-of args))
+ (format t "~& - ~s~%" err)))
+ ok))
+
+(defun test-level0-methods ()
+ (let* ((a 1)
+ (b 1.0)
+ (c %i)
+ (x (dmat (1 2) (3 4)))
+ (y (zmat (1 2) (3 4)))
+ (w (mat 'matrix-ge (1 2) (3 4)))
+ (args (list a b c x y w)))
+ (mapc (lambda (fun)
+ (mapc (lambda (x)
+ (simple-non-nil-check fun (list x)))
+ args))
+ ;; The following list is hard coded to make
+ ;; the test independent of Lisplab.
+ '(.sin .cos .tan
+ .asin .acos .atan
+ .sinh .cosh .tanh
+ .asinh .acosh .atanh
+ .exp .sqr .sqrt .conj
+ .realpart .imagpart .abs
+ .erf .erfc
+ .gamma ))
+ (mapc (lambda (x) (simple-non-nil-check '.besj (list 1 x))) args)
+ (mapc (lambda (x) (simple-non-nil-check '.besy (list 1 x))) args)
+ (mapc (lambda (x) (simple-non-nil-check '.besi (list 1 x))) args)
+ (mapc (lambda (x) (simple-non-nil-check '.besk (list 1 x))) args)
+ (mapc (lambda (x) (simple-non-nil-check '.besh1 (list 1 x))) args)
+ (mapc (lambda (x) (simple-non-nil-check '.besh2 (list 1 x))) args)
+
+ (mapc (lambda (x) (simple-non-nil-check '.besj (list 5 x))) args)
+ (mapc (lambda (x) (simple-non-nil-check '.besy (list 5 x))) args)
+ (mapc (lambda (x) (simple-non-nil-check '.besi (list 5 x))) args)
+ (mapc (lambda (x) (simple-non-nil-check '.besk (list 5 x))) args)
+ (mapc (lambda (x) (simple-non-nil-check '.besh1 (list 5 x))) args)
+ (mapc (lambda (x) (simple-non-nil-check '.besh2 (list 5 x))) args)
+
+ (mapc (lambda (x) (simple-non-nil-check '.besj (list 7.1 x))) args)
+ (mapc (lambda (x) (simple-non-nil-check '.besy (list 7.1 x))) args)
+ (mapc (lambda (x) (simple-non-nil-check '.besi (list 7.1 x))) args)
+ (mapc (lambda (x) (simple-non-nil-check '.besk (list 7.1 x))) args)
+ (mapc (lambda (x) (simple-non-nil-check '.besh1 (list 7.1 x))) args)
+ (mapc (lambda (x) (simple-non-nil-check '.besh2 (list 7.1 x))) args)
+ 'done))
+
+
+(defun test-level3-fft ()
+ (let ((a (dmat (1 2) (3 4)))
+ (b (zmat (1 2) (3 5)))
+ (c (dmat (1 2 -1) (3 4 9) (1 1 1)))
+ (d (zmat (1 2 2.1) (3 5 %i) (-%i -%i -%i))))
+ (simple-non-nil-check #'fft1 (list a))
+ (simple-non-nil-check #'fft1 (list b))
+ (simple-non-nil-check #'fft2 (list a))
+ (simple-non-nil-check #'fft2 (list b))
+ (simple-non-nil-check #'fft1 (list c))
+ (simple-non-nil-check #'fft1 (list d))
+ (simple-non-nil-check #'fft2 (list c))
+ (simple-non-nil-check #'fft2 (list d))
+ (simple-non-nil-check #'ifft1 (list a))
+ (simple-non-nil-check #'ifft1 (list b))
+ (simple-non-nil-check #'ifft2 (list a))
+ (simple-non-nil-check #'ifft2 (list b))
+ (simple-non-nil-check #'ifft1 (list c))
+ (simple-non-nil-check #'ifft1 (list d))
+ (simple-non-nil-check #'ifft2 (list c))
+ (simple-non-nil-check #'ifft2 (list d))
+ (simple-non-nil-check #'fft-shift (list a))
+ (simple-non-nil-check #'fft-shift (list b))
+ (simple-non-nil-check #'fft-shift (list c))
+ (simple-non-nil-check #'fft-shift (list d))
+ (simple-non-nil-check #'ifft-shift (list a))
+ (simple-non-nil-check #'ifft-shift (list b))
+ (simple-non-nil-check #'ifft-shift (list c))
+ (simple-non-nil-check #'ifft-shift (list d))
+ 'done))
+
+(defun test-level3-linalg ()
+ (let* ((a (dmat (1 2) (3 4)))
+ (b (zmat (1 2) (3 5)))
+ (c (dmat (1 2 -1) (3 4 9) (1 1 1)))
+ (d (zmat (1 2 2.1) (3 5 %i) (-%i %i -%i)))
+ (x (mat 'matrix-ge (1 2 2.1) (3 5 %i) (-%i %i -%i)))
+ (args (list a b c d x)))
+ (mapc (lambda (x) (simple-non-nil-check #'mtp (list x))) args)
+ (mapc (lambda (x) (simple-non-nil-check #'mct (list x))) args)
+ (mapc (lambda (x) (simple-non-nil-check #'minv (list x))) args)
+ (mapc (lambda (x) (simple-non-nil-check #'mdet (list x))) args)
+ (mapc (lambda (x) (simple-non-nil-check #'mtr (list x))) args)
+ (mapc (lambda (x) (simple-non-nil-check #'LU-factor (list x))) args)
+ (mapc (lambda (x) (simple-non-nil-check #'m* (list x x))) args)
+ (mapc (lambda (x) (simple-non-nil-check #'m/ (list x x))) args)
+ )
+ 'done)
+
+(defun test-all ()
+ (test-level0-methods)
+ (test-level3-fft)
+ (test-level3-linalg))
\ No newline at end of file
More information about the lisplab-cvs
mailing list