src/basics/lsmath.lsp

   1 ;;; -*- mode: lisp -*-
   2
   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.
   7
   8 ;;; lsmath -- Install vectorized arithmetic functions
   9 ;;;
  10 ;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
  11 ;;; unrestricted use.
  12
  13 (in-package :lisp-stat-math)
  14
  15 ;;; Patch up some type definitions
  16
  17 ;;(deftype float () 'common-lisp:float)
  18 ;;(deftype complex () 'common-lisp:complex)
  19
  20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21 ;;;
  22 ;;; Install the vectorized math functions
  23 ;;;
  24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25
  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)
  29
  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)
  41
  42 (make-rv-function-1 log base-log)
  43 (make-rv-function exp base-exp x)
  44 (make-rv-function sqrt base-sqrt x)
  45
  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)
  58
  59 (make-rv-function-1 float base-float)
  60 (make-rv-function-1 random common-lisp:random)
  61
  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)
  66
  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)
  72
  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:>)
  79
  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)
  85
  86 (defun min-1 (x)
  87   (if (numberp x)
  88     x
  89     (let* ((seq (compound-data-seq x))
  90            (first (elt seq 0))
  91            (result (if (numberp first) first (min-1 first))))
  92       (if (consp seq)
  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)))
  97           (declare (fixnum n))
  98           (dotimes (i n result)
  99             (declare (fixnum i))
 100             (let* ((x (aref seq i))
 101                    (r (if (numberp x) x (min-1 x))))
 102               (if (common-lisp:< r result) (setf result r)))))))))
 103
 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))))
 108
 109 (defun max-1 (x)
 110   (if (numberp x)
 111     x
 112     (let* ((seq (compound-data-seq x))
 113            (first (elt seq 0))
 114            (result (if (numberp first) first (max-1 first))))
 115       (if (consp seq)
 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)))
 120           (declare (fixnum n))
 121           (dotimes (i n result)
 122             (declare (fixnum i))
 123             (let* ((x (aref seq i))
 124                    (r (if (numberp x) x (max-1 x))))
 125               (if (common-lisp:> r result) (setf result r)))))))))
 126
 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))))
 131
 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)
 136
 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)