lsmath.lsp

   1 ;;;; lsmath -- Install vectorized arithmetic functions
   2 ;;;;
   3 ;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
   4 ;;;; unrestricted use.
   5
   6 (provide "lsmath")
   7
   8 ;;;;
   9 ;;;; Package Setup
  10 ;;;;
  11
  12 #+:CLtL2
  13 (progn
  14   (defpackage "LISP-STAT"
  15     (:nicknames "LS" "STATS")
  16     (:use "COMMON-LISP" "LISP-STAT-BASICS" "LISP-STAT-OBJECT-SYSTEM"))
  17
  18   (in-package lisp-stat))
  19 #-:CLtL2
  20 (in-package 'lisp-stat
  21             :nicknames '(ls stats)
  22             :use '(lisp ls-basics lsos))
  23
  24 (shadowing-import (package-shadowing-symbols 'lisp-stat-object-system))
  25 (shadowing-import (package-shadowing-symbols 'lisp-stat-basics))
  26 (use-package 'lisp-stat-object-system)
  27 (use-package 'lisp-stat-basics)
  28
  29 ;;;
  30 ;;; Shadow the symbols in the lisp package that will be redefined
  31 ;;;
  32
  33 (shadow '(expt + - * / ** mod rem abs 1+ 1- log exp sqrt sin cos tan
  34           asin acos atan sinh cosh tanh asinh acosh atanh float random
  35           truncate floor ceiling round minusp zerop plusp evenp oddp
  36           < <= = /= >= > complex conjugate realpart imagpart phase
  37           min max logand logior logxor lognot ffloor fceiling
  38           ftruncate fround signum cis))
  39
  40 (export '(^ ** expt + - * / mod rem pmin pmax abs 1+ 1- log exp sqrt sin cos
  41           tan asin acos atan sinh cosh tanh asinh acosh atanh float random
  42           truncate floor ceiling round minusp zerop plusp evenp oddp < <= =
  43           /= >= > complex conjugate realpart imagpart phase min max
  44           logand logior logxor lognot ffloor fceiling ftruncate fround
  45           signum cis))
  46
  47 ;;;;
  48 ;;;; Import some symbols
  49 ;;;;
  50
  51 (import '(ls-basics::make-rv-function ls-basics::make-rv-function-1))
  52
  53 #+(and kcl fast-c-code internal-c-math)
  54 (progn
  55 (import 'ls-basics::install-rv-function)
  56 (import '(ls-basics::rv-expt ls-basics::rv-+ ls-basics::rv--
  57           ls-basics::rv-* ls-basics::rv-/ ls-basics::rv-mod
  58           ls-basics::rv-rem ls-basics::rv-pmin ls-basics::rv-pmax
  59           ls-basics::rv-1+ ls-basics::rv-1- ls-basics::rv-exp
  60           ls-basics::rv-log ls-basics::rv-sqrt ls-basics::rv-sin
  61           ls-basics::rv-cos ls-basics::rv-tan ls-basics::rv-atan
  62           ls-basics::rv-float ls-basics::rv-random ls-basics::rv-floor
  63           ls-basics::rv-ceiling ls-basics::rv-truncate ls-basics::rv-round
  64           ls-basics::rv-zerop ls-basics::rv-plusp ls-basics::rv-minusp
  65           ls-basics::rv-oddp ls-basics::rv-evenp ls-basics::rv-<
  66           ls-basics::rv-<= ls-basics::rv-= ls-basics::rv-/=
  67           ls-basics::rv->= ls-basics::rv-> ls-basics::rv-complex
  68           ls-basics::rv-realpart ls-basics::rv-imagpart
  69           ls-basics::rv-conjugate))
  70 )
  71
  72 (import '(ls-basics::base-expt ls-basics::base-log ls-basics::base-exp
  73           ls-basics::base-sqrt ls-basics::base-sin ls-basics::base-cos
  74           ls-basics::base-tan ls-basics::base-asin ls-basics::base-acos
  75           ls-basics::base-atan ls-basics::base-sinh ls-basics::base-cosh
  76           ls-basics::base-tanh ls-basics::base-asinh ls-basics::base-acosh
  77           ls-basics::base-atanh ls-basics::base-float ls-basics::base-abs
  78           ls-basics::base-phase ls-basics::base-ffloor
  79           ls-basics::base-fceiling ls-basics::base-ftruncate
  80           ls-basics::base-fround ls-basics::base-signum
  81           ls-basics::base-cis))
  82
  83 ;;;;
  84 ;;;; Patch up some type definitions
  85 ;;;;
  86
  87 (deftype float () 'lisp:float)
  88 (deftype complex () 'lisp:complex)
  89
  90 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  91 ;;;
  92 ;;; Install the vectorized math functions
  93 ;;;
  94 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  95
  96 (make-rv-function ^ base-expt x y)
  97 (make-rv-function ** base-expt x y)
  98 (make-rv-function expt base-expt x y)
  99
 100 (make-rv-function + lisp:+)
 101 (make-rv-function-1 - lisp:-)
 102 (make-rv-function * lisp:*)
 103 (make-rv-function-1 / lisp:/)
 104 (make-rv-function mod lisp:mod x y)
 105 (make-rv-function rem lisp:rem x y)
 106 (make-rv-function-1 pmin lisp:min)
 107 (make-rv-function-1 pmax lisp:max)
 108 (make-rv-function abs base-abs x)
 109 (make-rv-function 1+ lisp:1+ x)
 110 (make-rv-function 1- lisp:1- x)
 111
 112 (make-rv-function-1 log base-log)
 113 (make-rv-function exp base-exp x)
 114 (make-rv-function sqrt base-sqrt x)
 115
 116 (make-rv-function sin base-sin x)
 117 (make-rv-function cos base-cos x)
 118 (make-rv-function tan base-tan x)
 119 (make-rv-function asin base-asin x)
 120 (make-rv-function acos base-acos x)
 121 (make-rv-function-1 atan base-atan)
 122 (make-rv-function sinh base-sinh x)
 123 (make-rv-function cosh base-cosh x)
 124 (make-rv-function tanh base-tanh x)
 125 (make-rv-function asinh base-asinh x)
 126 (make-rv-function acosh base-acosh x)
 127 (make-rv-function atanh base-atanh x)
 128
 129 (make-rv-function-1 float base-float)
 130 (make-rv-function-1 random lisp:random)
 131
 132 (make-rv-function-1 floor lisp:floor)
 133 (make-rv-function-1 ceiling lisp:ceiling)
 134 (make-rv-function-1 truncate lisp:truncate)
 135 (make-rv-function-1 round lisp:round)
 136
 137 (make-rv-function zerop lisp:zerop x)
 138 (make-rv-function plusp lisp:plusp x)
 139 (make-rv-function minusp lisp:minusp x)
 140 (make-rv-function oddp lisp:oddp x)
 141 (make-rv-function evenp lisp:evenp x)
 142
 143 (make-rv-function-1 < lisp:<)
 144 (make-rv-function-1 <= lisp:<=)
 145 (make-rv-function-1 = lisp:=)
 146 (make-rv-function-1 /= lisp:/=)
 147 (make-rv-function-1 >= lisp:>=)
 148 (make-rv-function-1 > lisp:>)
 149
 150 (make-rv-function-1 complex lisp:complex)
 151 (make-rv-function realpart lisp:realpart x)
 152 (make-rv-function imagpart lisp:imagpart x)
 153 (make-rv-function conjugate lisp:conjugate x)
 154 (make-rv-function phase base-phase x)
 155
 156 (defun min-1 (x)
 157   (if (numberp x)
 158     x
 159     (let* ((seq (compound-data-seq x))
 160            (first (elt seq 0))
 161            (result (if (numberp first) first (min-1 first))))
 162       (if (consp seq)
 163         (dolist (x (rest seq) result)
 164           (let ((r (if (numberp x) x (min-1 x))))
 165             (if (lisp:< r result) (setf result r))))
 166         (let ((n (length seq)))
 167           (declare (fixnum n))
 168           (dotimes (i n result)
 169             (declare (fixnum i))
 170             (let* ((x (aref seq i))
 171                    (r (if (numberp x) x (min-1 x))))
 172               (if (lisp:< r result) (setf result r)))))))))
 173
 174 (defun min (x &optional (y nil has-y) &rest args)
 175   (if (and (null args) (numberp x) (numberp y))
 176     (lisp:min x y)
 177     (if has-y (min-1 (cons x (cons y args))) (min-1 x))))
 178
 179 (defun max-1 (x)
 180   (if (numberp x)
 181     x
 182     (let* ((seq (compound-data-seq x))
 183            (first (elt seq 0))
 184            (result (if (numberp first) first (max-1 first))))
 185       (if (consp seq)
 186         (dolist (x (rest seq) result)
 187           (let ((r (if (numberp x) x (max-1 x))))
 188             (if (lisp:> r result) (setf result r))))
 189         (let ((n (length seq)))
 190           (declare (fixnum n))
 191           (dotimes (i n result)
 192             (declare (fixnum i))
 193             (let* ((x (aref seq i))
 194                    (r (if (numberp x) x (max-1 x))))
 195               (if (lisp:> r result) (setf result r)))))))))
 196
 197 (defun max (x &optional (y nil has-y) &rest args)
 198   (if (and (null args) (numberp x) (numberp y))
 199     (lisp:max x y)
 200     (if has-y (max-1 (cons x (cons y args))) (max-1 x))))
 201
 202 (make-rv-function logand lisp:logand)
 203 (make-rv-function logior lisp:logior)
 204 (make-rv-function logxor lisp:logxor)
 205 (make-rv-function lognot lisp:lognot x)
 206
 207 (make-rv-function-1 ffloor base-ffloor)
 208 (make-rv-function-1 fceiling base-fceiling)
 209 (make-rv-function-1 ftruncate base-ftruncate)
 210 (make-rv-function-1 fround base-fround)
 211 (make-rv-function signum base-signum x)
 212 (make-rv-function cis base-cis x)