external/oct/qd-class.lisp

   1 ;;;; -*- Mode: lisp -*-
   2 ;;;;
   3 ;;;; Copyright (c) 2007 Raymond Toy
   4 ;;;;
   5 ;;;; Permission is hereby granted, free of charge, to any person
   6 ;;;; obtaining a copy of this software and associated documentation
   7 ;;;; files (the "Software"), to deal in the Software without
   8 ;;;; restriction, including without limitation the rights to use,
   9 ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell
  10 ;;;; copies of the Software, and to permit persons to whom the
  11 ;;;; Software is furnished to do so, subject to the following
  12 ;;;; conditions:
  13 ;;;;
  14 ;;;; The above copyright notice and this permission notice shall be
  15 ;;;; included in all copies or substantial portions of the Software.
  16 ;;;;
  17 ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  18 ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
  19 ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  20 ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  21 ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  22 ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  23 ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
  24 ;;;; OTHER DEALINGS IN THE SOFTWARE.
  25
  26 (in-package #:qd)
  27
  28 (define-symbol-macro * cl:*)
  29 (define-symbol-macro - cl:-)
  30 (define-symbol-macro / cl:/)
  31
  32 (defclass qd-real ()
  33   ((qd :initform +qd-zero+
  34        :reader qd-value
  35        :initarg :value
  36        :type %quad-double)))
  37
  38 (defclass qd-complex ()
  39   ((real :initform +qd-zero+
  40          :reader qd-real
  41          :initarg :real
  42          :type %quad-double)
  43    (imag :initform +qd-zero+
  44          :reader qd-imag
  45          :initarg :imag
  46          :type %quad-double)))
  47
  48 #-cmu
  49 (defmethod print-object ((qd qd-real) stream)
  50   (format stream "~/qdi::qd-format/" (qd-value qd)))
  51
  52 #+cmu
  53 (defun print-qd (q stream)
  54   (declare (type %quad-double q))
  55   (if (or (ext:float-infinity-p (qd-0 q))
  56           (ext:float-nan-p (qd-0 q)))
  57       (format stream "~/qdi::qd-format/" q)
  58       (format stream "#q~/qdi::qd-format/" q)))
  59 #+cmu
  60 (defmethod print-object ((qd qd-real) stream)
  61   (print-qd (qd-value qd) stream))
  62
  63 (defmethod make-qd ((x real))
  64   (make-instance 'qd-real :value (make-qd-d (float x 1d0))))
  65
  66 (defmethod make-qd ((x qd-real))
  67   (make-instance 'qd-real :value (qd-value x)))
  68
  69 (defmethod print-object ((qd qd-complex) stream)
  70   (format stream "#q(~/qdi::qd-format/ ~/qdi::qd-format/)"
  71           (qd-real qd)
  72           (qd-imag qd)))
  73
  74 (defmethod print-object ((qd qd-complex) stream)
  75   (write-string "#q(" stream)
  76   (print-qd (qd-real qd) stream)
  77   (write-char #\space stream)
  78   (print-qd (qd-imag qd) stream)
  79   (write-string ")" stream))
  80
  81 (defmethod qd-value ((x real))
  82   (make-qd-d (float x 1d0)))
  83
  84 (defmethod make-load-form ((qd qd-real) &optional environment)
  85   (declare (ignore environment))
  86   `(make-instance ',(class-of qd)
  87                   :value ',(qd-value qd)))
  88
  89 (defmethod make-load-form ((qd qd-complex) &optional environment)
  90   (declare (ignore environment))
  91   `(make-instance ',(class-of qd)
  92                   :real ',(qd-value (realpart qd))
  93                   :imag ',(qd-value (imagpart qd))))
  94
  95 (defmethod describe-object ((q qd-real) stream)
  96   (multiple-value-bind (q0 q1 q2 q3)
  97       (qd-parts (qd-value q))
  98     (format stream "~&~S is a QD-REAL with components ~
  99                     ~%  ~A, ~A, ~A, ~A~%"
 100             q q0 q1 q2 q3)))
 101
 102 (defmethod describe-object ((q qd-complex) stream)
 103   (format stream "~&~S is a QD-COMPLEX" q)
 104   (format stream "~&It has components~&REAL: ")
 105   (describe (realpart q))
 106   (format stream "~&IMAG: ")
 107   (describe (imagpart q)))
 108
 109 \f
 110 (defgeneric add1 (a)
 111   (:documentation "Add 1"))
 112
 113 (defgeneric sub1 (a)
 114   (:documentation "Subtract 1"))
 115
 116
 117 (defgeneric two-arg-+ (a b)
 118   (:documentation "A + B"))
 119
 120 (defgeneric two-arg-- (a b)
 121   (:documentation "A - B"))
 122
 123 (defgeneric two-arg-* (a b)
 124   (:documentation "A * B"))
 125
 126 (defgeneric two-arg-/ (a b)
 127   (:documentation "A / B"))
 128
 129 (defgeneric two-arg-< (a b)
 130   (:documentation "A < B"))
 131
 132 (defgeneric two-arg-> (a b)
 133   (:documentation "A > B"))
 134
 135 (defgeneric two-arg-<= (a b)
 136   (:documentation "A <= B"))
 137
 138 (defgeneric two-arg->= (a b)
 139   (:documentation "A >= B"))
 140
 141 (defgeneric two-arg-= (a b)
 142   (:documentation "A = B?"))
 143
 144
 145 (defgeneric unary-minus (a)
 146   (:documentation "-A"))
 147
 148 (defgeneric unary-divide (a)
 149   (:documentation "1 / A"))
 150
 151 (defgeneric qzerop (a)
 152   (:documentation "A = 0?"))
 153
 154 (defgeneric qplusp (a)
 155   (:documentation "A > 0"))
 156
 157 (defgeneric qminusp (a)
 158   (:documentation "A < 0"))
 159
 160 (defgeneric qfloat (x ftype)
 161   (:documentation "Convert X to a float of the same type a FLOAT"))
 162
 163 (defgeneric qrealpart (x)
 164   (:documentation "The real part of X"))
 165
 166 (defgeneric qimagpart (x)
 167   (:documentation "The imaginary part of X"))
 168
 169 (defgeneric qconjugate (z)
 170   (:documentation "The complex conjugate of Z"))
 171
 172 (defgeneric qscale-float (x n)
 173   (:documentation "Multiply the float X by 2^N"))
 174
 175 (defgeneric qabs (x)
 176   (:documentation "Absolute value of X"))
 177
 178 (defgeneric qexp (x)
 179   (:documentation "Exponential of X"))
 180
 181 (defgeneric qsin (x)
 182   (:documentation "Sine of X"))
 183
 184 (defgeneric qcos (x)
 185   (:documentation "Cosine of X"))
 186
 187 (defgeneric qtan (x)
 188   (:documentation "Tangent of X"))
 189
 190 (defgeneric qsinh (x)
 191   (:documentation "Hyperbolic sine of X"))
 192
 193 (defgeneric qcosh (x)
 194   (:documentation "Hyperbolic cosine of X"))
 195
 196 (defgeneric qtanh (x)
 197   (:documentation "Hyperbolic tangent of X"))
 198
 199 (defgeneric qsqrt (x)
 200   (:documentation "Square root of X"))
 201
 202 (defgeneric qlog (a &optional b)
 203   (:documentation "Log of A base B.  If B not given, then natural log"))
 204
 205 (defgeneric log1p (x)
 206   (:documentation "log(1+x)"))
 207
 208 (defgeneric qatan (y &optional x)
 209   (:documentation "If X not given, atan(y).  If X is given, atan(y/x), taking
 210  the quadrant into account"))
 211
 212 (defgeneric qexpt (x y)
 213   (:documentation "X^Y"))
 214
 215 (defgeneric qcomplex (x &optional y)
 216   (:documentation "Create a complex number with components X and Y.  If Y not given, assume 0"))
 217
 218 (defgeneric qinteger-decode-float (f)
 219   (:documentation "integer-decode-float"))
 220
 221 (defgeneric qdecode-float (f)
 222   (:documentation "decode-float"))
 223
 224 (defgeneric qfloor (x &optional y))
 225
 226 (defgeneric qffloor (x &optional y))
 227
 228 (defgeneric %unary-round (x))
 229
 230 (defgeneric qfloat-sign (a &optional b)
 231   (:documentation "Transfer sign of A to B.  If B not given, assume 1"))
 232
 233 (defgeneric qasin (x)
 234   (:documentation "Inverse sine of X"))
 235
 236 (defgeneric qacos (x)
 237   (:documentation "Inverse cosine of X"))
 238
 239 (defgeneric qacosh (x)
 240   (:documentation "Inverse hyperbolic cosine of X"))
 241
 242 (defgeneric qatanh (x)
 243   (:documentation "Inverse hyperbolic tangent of X"))
 244
 245 (defgeneric qcis (x)
 246   (:documentation "(complex (cos x) (sin x))"))
 247
 248 (defgeneric qphase (x)
 249   (:documentation "Phase of X"))
 250
 251 (defgeneric coerce (x type)
 252   (:documentation "COERCE"))
 253
 254 (defgeneric random (x &optional state)
 255   (:documentation "RANDOM"))
 256