lsmath.lsp

   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.
   5
   6 ;;;; lsmath -- Install vectorized arithmetic functions
   7 ;;;;
   8 ;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
   9 ;;;; unrestricted use.
  10
  11 ;;; Package Setup
  12
  13 (in-package :cl-user)
  14
  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"))
  38
  39 (in-package :lisp-stat-math)
  40
  41 ;;; Patch up some type definitions
  42
  43 ;;(deftype float () 'common-lisp:float)
  44 ;;(deftype complex () 'common-lisp:complex)
  45
  46 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  47 ;;;
  48 ;;; Install the vectorized math functions
  49 ;;;
  50 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  51
  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)
  55
  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)
  67
  68 (make-rv-function-1 log base-log)
  69 (make-rv-function exp base-exp x)
  70 (make-rv-function sqrt base-sqrt x)
  71
  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)
  84
  85 (make-rv-function-1 float base-float)
  86 (make-rv-function-1 random common-lisp:random)
  87
  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)
  92
  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)
  98
  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:>)
 105
 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)
 111
 112 (defun min-1 (x)
 113   (if (numberp x)
 114     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)))))))))
 129
 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))))
 134
 135 (defun max-1 (x)
 136   (if (numberp x)
 137     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)))))))))
 152
 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))))
 157
 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)
 162
 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)