3 ;;; Copyright (c) 2005--2008, by A.J. Rossini <blindglobe@gmail.com>
4 ;;; See COPYRIGHT file for any additional restrictions (BSD license).
5 ;;; Since 1991, ANSI Common Lisp was finally finished and those
6 ;;; changes are reflected in this update.
8 ;;; lsmath -- Install vectorized arithmetic functions
10 ;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
13 (in-package :lisp-stat-math
)
15 ;;; Patch up some type definitions
17 ;;(deftype float () 'common-lisp:float)
18 ;;(deftype complex () 'common-lisp:complex)
20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
22 ;;; Install the vectorized math functions
24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26 (make-rv-function ^ base-expt x y
)
27 (make-rv-function ** base-expt x y
)
28 (make-rv-function expt base-expt x y
)
30 (make-rv-function + common-lisp
:+)
31 (make-rv-function-1 - common-lisp
:-
)
32 (make-rv-function * common-lisp
:*)
33 (make-rv-function-1 / common-lisp
:/)
34 (make-rv-function mod common-lisp
:mod x y
)
35 (make-rv-function rem common-lisp
:rem x y
)
36 (make-rv-function-1 pmin common-lisp
:min
)
37 (make-rv-function-1 pmax common-lisp
:max
)
38 (make-rv-function abs base-abs x
)
39 (make-rv-function 1+ common-lisp
:1+ x
)
40 (make-rv-function 1- common-lisp
:1- x
)
42 (make-rv-function-1 log base-log
)
43 (make-rv-function exp base-exp x
)
44 (make-rv-function sqrt base-sqrt x
)
46 (make-rv-function sin base-sin x
)
47 (make-rv-function cos base-cos x
)
48 (make-rv-function tan base-tan x
)
49 (make-rv-function asin base-asin x
)
50 (make-rv-function acos base-acos x
)
51 (make-rv-function-1 atan base-atan
)
52 (make-rv-function sinh base-sinh x
)
53 (make-rv-function cosh base-cosh x
)
54 (make-rv-function tanh base-tanh x
)
55 (make-rv-function asinh base-asinh x
)
56 (make-rv-function acosh base-acosh x
)
57 (make-rv-function atanh base-atanh x
)
59 (make-rv-function-1 float base-float
)
60 (make-rv-function-1 random common-lisp
:random
)
62 (make-rv-function-1 floor common-lisp
:floor
)
63 (make-rv-function-1 ceiling common-lisp
:ceiling
)
64 (make-rv-function-1 truncate common-lisp
:truncate
)
65 (make-rv-function-1 round common-lisp
:round
)
67 (make-rv-function zerop common-lisp
:zerop x
)
68 (make-rv-function plusp common-lisp
:plusp x
)
69 (make-rv-function minusp common-lisp
:minusp x
)
70 (make-rv-function oddp common-lisp
:oddp x
)
71 (make-rv-function evenp common-lisp
:evenp x
)
73 (make-rv-function-1 < common-lisp
:<)
74 (make-rv-function-1 <= common-lisp
:<=)
75 (make-rv-function-1 = common-lisp
:=)
76 (make-rv-function-1 /= common-lisp
:/=)
77 (make-rv-function-1 >= common-lisp
:>=)
78 (make-rv-function-1 > common-lisp
:>)
80 ;;(make-rv-function-1 complex common-lisp:complex)
81 (make-rv-function realpart common-lisp
:realpart x
)
82 (make-rv-function imagpart common-lisp
:imagpart x
)
83 (make-rv-function conjugate common-lisp
:conjugate x
)
84 (make-rv-function phase base-phase x
)
89 (let* ((seq (compound-data-seq x
))
91 (result (if (numberp first
) first
(min-1 first
))))
93 (dolist (x (rest seq
) result
)
94 (let ((r (if (numberp x
) x
(min-1 x
))))
95 (if (common-lisp:< r result
) (setf result r
))))
96 (let ((n (length seq
)))
100 (let* ((x (aref seq i
))
101 (r (if (numberp x
) x
(min-1 x
))))
102 (if (common-lisp:< r result
) (setf result r
)))))))))
104 (defun min (x &optional
(y nil has-y
) &rest args
)
105 (if (and (null args
) (numberp x
) (numberp y
))
106 (common-lisp:min x y
)
107 (if has-y
(min-1 (cons x
(cons y args
))) (min-1 x
))))
112 (let* ((seq (compound-data-seq x
))
114 (result (if (numberp first
) first
(max-1 first
))))
116 (dolist (x (rest seq
) result
)
117 (let ((r (if (numberp x
) x
(max-1 x
))))
118 (if (common-lisp:> r result
) (setf result r
))))
119 (let ((n (length seq
)))
121 (dotimes (i n result
)
123 (let* ((x (aref seq i
))
124 (r (if (numberp x
) x
(max-1 x
))))
125 (if (common-lisp:> r result
) (setf result r
)))))))))
127 (defun max (x &optional
(y nil has-y
) &rest args
)
128 (if (and (null args
) (numberp x
) (numberp y
))
129 (common-lisp:max x y
)
130 (if has-y
(max-1 (cons x
(cons y args
))) (max-1 x
))))
132 (make-rv-function logand common-lisp
:logand
)
133 (make-rv-function logior common-lisp
:logior
)
134 (make-rv-function logxor common-lisp
:logxor
)
135 (make-rv-function lognot common-lisp
:lognot x
)
137 (make-rv-function-1 ffloor base-ffloor
)
138 (make-rv-function-1 fceiling base-fceiling
)
139 (make-rv-function-1 ftruncate base-ftruncate
)
140 (make-rv-function-1 fround base-fround
)
141 (make-rv-function signum base-signum x
)
142 (make-rv-function cis base-cis x
)