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