Initial CLOS-based statistical data structure.
[CommonLispStat.git] / lsmath.lsp
blob1baa4b0ae1bc4f8646ebc1e367ba2686ab182f47
1 ;;; -*- mode: lisp -*-
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
7 ;;;;
8 ;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
9 ;;;; unrestricted use.
11 ;;; Package Setup
13 (in-package :cl-user)
15 (defpackage :lisp-stat-math
16 (:use :common-lisp
17 :lisp-stat-object-system
18 :lisp-stat-macros
19 :lisp-stat-compound-data
20 :lisp-stat-float)
21 (:shadowing-import-from :lisp-stat-object-system
22 slot-value call-method call-next-method)
23 (:shadow expt + - * / ** mod rem abs 1+ 1- log exp sqrt sin cos tan
24 asin acos atan sinh cosh tanh asinh acosh atanh float random
25 truncate floor ceiling round minusp zerop plusp evenp oddp
26 < <= = /= >= > ;; complex
27 conjugate realpart imagpart phase
28 min max logand logior logxor lognot ffloor fceiling
29 ftruncate fround signum cis)
30 (:export ^ ** expt + - * / mod rem pmin pmax abs 1+ 1- log exp sqrt sin cos
31 tan asin acos atan sinh cosh tanh asinh acosh atanh float random
32 truncate floor ceiling round minusp zerop plusp evenp oddp < <= =
33 /= >= > ;; complex
34 conjugate realpart imagpart phase min max
35 logand logior logxor lognot ffloor fceiling ftruncate fround
36 signum cis)
37 (:documentation "Vectorization of numerical functions"))
39 (in-package :lisp-stat-math)
41 ;;; Patch up some type definitions
43 ;;(deftype float () 'common-lisp:float)
44 ;;(deftype complex () 'common-lisp:complex)
46 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
47 ;;;
48 ;;; Install the vectorized math functions
49 ;;;
50 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
52 (make-rv-function ^ base-expt x y)
53 (make-rv-function ** base-expt x y)
54 (make-rv-function expt base-expt x y)
56 (make-rv-function + common-lisp:+)
57 (make-rv-function-1 - common-lisp:-)
58 (make-rv-function * common-lisp:*)
59 (make-rv-function-1 / common-lisp:/)
60 (make-rv-function mod common-lisp:mod x y)
61 (make-rv-function rem common-lisp:rem x y)
62 (make-rv-function-1 pmin common-lisp:min)
63 (make-rv-function-1 pmax common-lisp:max)
64 (make-rv-function abs base-abs x)
65 (make-rv-function 1+ common-lisp:1+ x)
66 (make-rv-function 1- common-lisp:1- x)
68 (make-rv-function-1 log base-log)
69 (make-rv-function exp base-exp x)
70 (make-rv-function sqrt base-sqrt x)
72 (make-rv-function sin base-sin x)
73 (make-rv-function cos base-cos x)
74 (make-rv-function tan base-tan x)
75 (make-rv-function asin base-asin x)
76 (make-rv-function acos base-acos x)
77 (make-rv-function-1 atan base-atan)
78 (make-rv-function sinh base-sinh x)
79 (make-rv-function cosh base-cosh x)
80 (make-rv-function tanh base-tanh x)
81 (make-rv-function asinh base-asinh x)
82 (make-rv-function acosh base-acosh x)
83 (make-rv-function atanh base-atanh x)
85 (make-rv-function-1 float base-float)
86 (make-rv-function-1 random common-lisp:random)
88 (make-rv-function-1 floor common-lisp:floor)
89 (make-rv-function-1 ceiling common-lisp:ceiling)
90 (make-rv-function-1 truncate common-lisp:truncate)
91 (make-rv-function-1 round common-lisp:round)
93 (make-rv-function zerop common-lisp:zerop x)
94 (make-rv-function plusp common-lisp:plusp x)
95 (make-rv-function minusp common-lisp:minusp x)
96 (make-rv-function oddp common-lisp:oddp x)
97 (make-rv-function evenp common-lisp:evenp x)
99 (make-rv-function-1 < common-lisp:<)
100 (make-rv-function-1 <= common-lisp:<=)
101 (make-rv-function-1 = common-lisp:=)
102 (make-rv-function-1 /= common-lisp:/=)
103 (make-rv-function-1 >= common-lisp:>=)
104 (make-rv-function-1 > common-lisp:>)
106 ;;(make-rv-function-1 complex common-lisp:complex)
107 (make-rv-function realpart common-lisp:realpart x)
108 (make-rv-function imagpart common-lisp:imagpart x)
109 (make-rv-function conjugate common-lisp:conjugate x)
110 (make-rv-function phase base-phase x)
112 (defun min-1 (x)
113 (if (numberp x)
115 (let* ((seq (compound-data-seq x))
116 (first (elt seq 0))
117 (result (if (numberp first) first (min-1 first))))
118 (if (consp seq)
119 (dolist (x (rest seq) result)
120 (let ((r (if (numberp x) x (min-1 x))))
121 (if (common-lisp:< r result) (setf result r))))
122 (let ((n (length seq)))
123 (declare (fixnum n))
124 (dotimes (i n result)
125 (declare (fixnum i))
126 (let* ((x (aref seq i))
127 (r (if (numberp x) x (min-1 x))))
128 (if (common-lisp:< r result) (setf result r)))))))))
130 (defun min (x &optional (y nil has-y) &rest args)
131 (if (and (null args) (numberp x) (numberp y))
132 (common-lisp:min x y)
133 (if has-y (min-1 (cons x (cons y args))) (min-1 x))))
135 (defun max-1 (x)
136 (if (numberp x)
138 (let* ((seq (compound-data-seq x))
139 (first (elt seq 0))
140 (result (if (numberp first) first (max-1 first))))
141 (if (consp seq)
142 (dolist (x (rest seq) result)
143 (let ((r (if (numberp x) x (max-1 x))))
144 (if (common-lisp:> r result) (setf result r))))
145 (let ((n (length seq)))
146 (declare (fixnum n))
147 (dotimes (i n result)
148 (declare (fixnum i))
149 (let* ((x (aref seq i))
150 (r (if (numberp x) x (max-1 x))))
151 (if (common-lisp:> r result) (setf result r)))))))))
153 (defun max (x &optional (y nil has-y) &rest args)
154 (if (and (null args) (numberp x) (numberp y))
155 (common-lisp:max x y)
156 (if has-y (max-1 (cons x (cons y args))) (max-1 x))))
158 (make-rv-function logand common-lisp:logand)
159 (make-rv-function logior common-lisp:logior)
160 (make-rv-function logxor common-lisp:logxor)
161 (make-rv-function lognot common-lisp:lognot x)
163 (make-rv-function-1 ffloor base-ffloor)
164 (make-rv-function-1 fceiling base-fceiling)
165 (make-rv-function-1 ftruncate base-ftruncate)
166 (make-rv-function-1 fround base-fround)
167 (make-rv-function signum base-signum x)
168 (make-rv-function cis base-cis x)