2 ;;; Copyright (c) 2005--2007, by A.J. Rossini <blindglobe@gmail.com>
3 ;;; See COPYRIGHT file for any additional restrictions (BSD license).
4 ;;; Since 1991, ANSI was finally finished. Edited for ANSI Common Lisp.
6 ;;;; lsmath -- Install vectorized arithmetic functions
8 ;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
13 ;; in another world...
14 (defpackage :lisp-stat-math
16 :lisp-stat-object-system
19 ;; Shadow the symbols in the lisp package that will be redefined
20 (:shadow expt
+ -
* / ** mod rem abs
1+ 1- log exp sqrt sin cos tan
21 asin acos atan sinh cosh tanh asinh acosh atanh float random
22 truncate floor ceiling round minusp zerop plusp evenp oddp
23 < <= = /= >= > complex conjugate realpart imagpart phase
24 min max logand logior logxor lognot ffloor fceiling
25 ftruncate fround signum cis
)
26 (:export ^
** expt
+ -
* / mod rem pmin pmax abs
1+ 1- log exp sqrt sin cos
27 tan asin acos atan sinh cosh tanh asinh acosh atanh float random
28 truncate floor ceiling round minusp zerop plusp evenp oddp
< <= =
29 /= >= > complex conjugate realpart imagpart phase min max
30 logand logior logxor lognot ffloor fceiling ftruncate fround
32 (:documentation
"Vectorization of numerical functions"))
34 (in-package :lisp-stat-math
)
36 ;; (in-package #:lisp-stat)
37 ;; (shadowing-import (package-shadowing-symbols 'lisp-stat-object-system))
38 ;; (shadowing-import (package-shadowing-symbols 'lisp-stat-basics))
39 ;; (use-package 'lisp-stat-object-system)
40 ;; (use-package 'lisp-stat-basics)
42 ;;; Import some symbols
44 #+(and kcl fast-c-code internal-c-math
)
46 ;; (import 'ls-basics::install-rv-function)
47 (import '(ls-basics::rv-expt ls-basics
::rv-
+ ls-basics
::rv--
48 ls-basics
::rv-
* ls-basics
::rv-
/ ls-basics
::rv-mod
49 ls-basics
::rv-rem ls-basics
::rv-pmin ls-basics
::rv-pmax
50 ls-basics
::rv-1
+ ls-basics
::rv-1- ls-basics
::rv-exp
51 ls-basics
::rv-log ls-basics
::rv-sqrt ls-basics
::rv-sin
52 ls-basics
::rv-cos ls-basics
::rv-tan ls-basics
::rv-atan
53 ls-basics
::rv-float ls-basics
::rv-random ls-basics
::rv-floor
54 ls-basics
::rv-ceiling ls-basics
::rv-truncate ls-basics
::rv-round
55 ls-basics
::rv-zerop ls-basics
::rv-plusp ls-basics
::rv-minusp
56 ls-basics
::rv-oddp ls-basics
::rv-evenp ls-basics
::rv-
<
57 ls-basics
::rv-
<= ls-basics
::rv-
= ls-basics
::rv-
/=
58 ls-basics
::rv-
>= ls-basics
::rv-
> ls-basics
::rv-complex
59 ls-basics
::rv-realpart ls-basics
::rv-imagpart
60 ls-basics
::rv-conjugate
)))
62 ;; found in lisp-stat-float
63 ;; (import '(ls-basics::base-expt ls-basics::base-log ls-basics::base-exp
64 ;; ls-basics::base-sqrt ls-basics::base-sin ls-basics::base-cos
65 ;; ls-basics::base-tan ls-basics::base-asin ls-basics::base-acos
66 ;; ls-basics::base-atan ls-basics::base-sinh ls-basics::base-cosh
67 ;; ls-basics::base-tanh ls-basics::base-asinh ls-basics::base-acosh
68 ;; ls-basics::base-atanh ls-basics::base-float ls-basics::base-abs
69 ;; ls-basics::base-phase ls-basics::base-ffloor
70 ;; ls-basics::base-fceiling ls-basics::base-ftruncate
71 ;; ls-basics::base-fround ls-basics::base-signum
72 ;; ls-basics::base-cis))
75 ;;; Patch up some type definitions
77 (deftype float
() 'common-lisp
:float
)
78 (deftype complex
() 'common-lisp
:complex
)
80 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
82 ;;; Install the vectorized math functions
84 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
86 (make-rv-function ^ base-expt x y
)
87 (make-rv-function ** base-expt x y
)
88 (make-rv-function expt base-expt x y
)
90 (make-rv-function + common-lisp
:+)
91 (make-rv-function-1 - common-lisp
:-
)
92 (make-rv-function * common-lisp
:*)
93 (make-rv-function-1 / common-lisp
:/)
94 (make-rv-function mod common-lisp
:mod x y
)
95 (make-rv-function rem common-lisp
:rem x y
)
96 (make-rv-function-1 pmin common-lisp
:min
)
97 (make-rv-function-1 pmax common-lisp
:max
)
98 (make-rv-function abs base-abs x
)
99 (make-rv-function 1+ common-lisp
:1+ x
)
100 (make-rv-function 1- common-lisp
:1- x
)
102 (make-rv-function-1 log base-log
)
103 (make-rv-function exp base-exp x
)
104 (make-rv-function sqrt base-sqrt x
)
106 (make-rv-function sin base-sin x
)
107 (make-rv-function cos base-cos x
)
108 (make-rv-function tan base-tan x
)
109 (make-rv-function asin base-asin x
)
110 (make-rv-function acos base-acos x
)
111 (make-rv-function-1 atan base-atan
)
112 (make-rv-function sinh base-sinh x
)
113 (make-rv-function cosh base-cosh x
)
114 (make-rv-function tanh base-tanh x
)
115 (make-rv-function asinh base-asinh x
)
116 (make-rv-function acosh base-acosh x
)
117 (make-rv-function atanh base-atanh x
)
119 (make-rv-function-1 float base-float
)
120 (make-rv-function-1 random common-lisp
:random
)
122 (make-rv-function-1 floor common-lisp
:floor
)
123 (make-rv-function-1 ceiling common-lisp
:ceiling
)
124 (make-rv-function-1 truncate common-lisp
:truncate
)
125 (make-rv-function-1 round common-lisp
:round
)
127 (make-rv-function zerop common-lisp
:zerop x
)
128 (make-rv-function plusp common-lisp
:plusp x
)
129 (make-rv-function minusp common-lisp
:minusp x
)
130 (make-rv-function oddp common-lisp
:oddp x
)
131 (make-rv-function evenp common-lisp
:evenp x
)
133 (make-rv-function-1 < common-lisp
:<)
134 (make-rv-function-1 <= common-lisp
:<=)
135 (make-rv-function-1 = common-lisp
:=)
136 (make-rv-function-1 /= common-lisp
:/=)
137 (make-rv-function-1 >= common-lisp
:>=)
138 (make-rv-function-1 > common-lisp
:>)
140 (make-rv-function-1 complex common-lisp
:complex
)
141 (make-rv-function realpart common-lisp
:realpart x
)
142 (make-rv-function imagpart common-lisp
:imagpart x
)
143 (make-rv-function conjugate common-lisp
:conjugate x
)
144 (make-rv-function phase base-phase x
)
149 (let* ((seq (compound-data-seq x
))
151 (result (if (numberp first
) first
(min-1 first
))))
153 (dolist (x (rest seq
) result
)
154 (let ((r (if (numberp x
) x
(min-1 x
))))
155 (if (common-lisp:< r result
) (setf result r
))))
156 (let ((n (length seq
)))
158 (dotimes (i n result
)
160 (let* ((x (aref seq i
))
161 (r (if (numberp x
) x
(min-1 x
))))
162 (if (common-lisp:< r result
) (setf result r
)))))))))
164 (defun min (x &optional
(y nil has-y
) &rest args
)
165 (if (and (null args
) (numberp x
) (numberp y
))
166 (common-lisp:min x y
)
167 (if has-y
(min-1 (cons x
(cons y args
))) (min-1 x
))))
172 (let* ((seq (compound-data-seq x
))
174 (result (if (numberp first
) first
(max-1 first
))))
176 (dolist (x (rest seq
) result
)
177 (let ((r (if (numberp x
) x
(max-1 x
))))
178 (if (common-lisp:> r result
) (setf result r
))))
179 (let ((n (length seq
)))
181 (dotimes (i n result
)
183 (let* ((x (aref seq i
))
184 (r (if (numberp x
) x
(max-1 x
))))
185 (if (common-lisp:> r result
) (setf result r
)))))))))
187 (defun max (x &optional
(y nil has-y
) &rest args
)
188 (if (and (null args
) (numberp x
) (numberp y
))
189 (common-lisp:max x y
)
190 (if has-y
(max-1 (cons x
(cons y args
))) (max-1 x
))))
192 (make-rv-function logand common-lisp
:logand
)
193 (make-rv-function logior common-lisp
:logior
)
194 (make-rv-function logxor common-lisp
:logxor
)
195 (make-rv-function lognot common-lisp
:lognot x
)
197 (make-rv-function-1 ffloor base-ffloor
)
198 (make-rv-function-1 fceiling base-fceiling
)
199 (make-rv-function-1 ftruncate base-ftruncate
)
200 (make-rv-function-1 fround base-fround
)
201 (make-rv-function signum base-signum x
)
202 (make-rv-function cis base-cis x
)