cgit.sxemacs.org Git - packages/blob - xemacs-packages/calc/calc-cplx.el

   1 ;; Calculator for GNU Emacs, part II [calc-cplx.el]
   2 ;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
   3 ;; Written by Dave Gillespie, daveg@synaptics.com.
   4
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; GNU Emacs is distributed in the hope that it will be useful,
   8 ;; but WITHOUT ANY WARRANTY.  No author or distributor
   9 ;; accepts responsibility to anyone for the consequences of using it
  10 ;; or for whether it serves any particular purpose or works at all,
  11 ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  12 ;; License for full details.
  13
  14 ;; Everyone is granted permission to copy, modify and redistribute
  15 ;; GNU Emacs, but only under the conditions described in the
  16 ;; GNU Emacs General Public License.   A copy of this license is
  17 ;; supposed to have been given to you along with GNU Emacs so you
  18 ;; can know your rights and responsibilities.  It should be in a
  19 ;; file named COPYING.  Among other things, the copyright notice
  20 ;; and this notice must be preserved on all copies.
  21
  22
  23
  24 ;; This file is autoloaded from calc-ext.el.
  25 (require 'calc-ext)
  26
  27 (require 'calc-macs)
  28
  29 (defun calc-Need-calc-cplx () nil)
  30
  31
  32 (defun calc-argument (arg)
  33   (interactive "P")
  34   (calc-slow-wrapper
  35    (calc-unary-op "arg" 'calcFunc-arg arg))
  36 )
  37
  38 (defun calc-re (arg)
  39   (interactive "P")
  40   (calc-slow-wrapper
  41    (calc-unary-op "re" 'calcFunc-re arg))
  42 )
  43
  44 (defun calc-im (arg)
  45   (interactive "P")
  46   (calc-slow-wrapper
  47    (calc-unary-op "im" 'calcFunc-im arg))
  48 )
  49
  50
  51 (defun calc-polar ()
  52   (interactive)
  53   (calc-slow-wrapper
  54    (let ((arg (calc-top-n 1)))
  55      (if (or (calc-is-inverse)
  56              (eq (car-safe arg) 'polar))
  57          (calc-enter-result 1 "p-r" (list 'calcFunc-rect arg))
  58        (calc-enter-result 1 "r-p" (list 'calcFunc-polar arg)))))
  59 )
  60
  61
  62
  63
  64 (defun calc-complex-notation ()
  65   (interactive)
  66   (calc-wrapper
  67    (calc-change-mode 'calc-complex-format nil t)
  68    (message "Displaying complex numbers in (X,Y) format."))
  69 )
  70
  71 (defun calc-i-notation ()
  72   (interactive)
  73   (calc-wrapper
  74    (calc-change-mode 'calc-complex-format 'i t)
  75    (message "Displaying complex numbers in X+Yi format."))
  76 )
  77
  78 (defun calc-j-notation ()
  79   (interactive)
  80   (calc-wrapper
  81    (calc-change-mode 'calc-complex-format 'j t)
  82    (message "Displaying complex numbers in X+Yj format."))
  83 )
  84
  85
  86 (defun calc-polar-mode (n)
  87   (interactive "P")
  88   (calc-wrapper
  89    (if (if n
  90            (> (prefix-numeric-value n) 0)
  91          (eq calc-complex-mode 'cplx))
  92        (progn
  93          (calc-change-mode 'calc-complex-mode 'polar)
  94          (message "Preferred complex form is polar."))
  95      (calc-change-mode 'calc-complex-mode 'cplx)
  96      (message "Preferred complex form is rectangular.")))
  97 )
  98
  99
 100 ;;;; Complex numbers.
 101
 102 (defun math-normalize-polar (a)
 103   (let ((r (math-normalize (nth 1 a)))
 104         (th (math-normalize (nth 2 a))))
 105     (cond ((math-zerop r)
 106            '(polar 0 0))
 107           ((or (math-zerop th))
 108            r)
 109           ((and (not (eq calc-angle-mode 'rad))
 110                 (or (equal th '(float 18 1))
 111                     (equal th 180)))
 112            (math-neg r))
 113           ((math-negp r)
 114            (math-neg (list 'polar (math-neg r) th)))
 115           (t
 116            (list 'polar r th))))
 117 )
 118
 119
 120 ;;; Coerce A to be complex (rectangular form).  [c N]
 121 (defun math-complex (a)
 122   (cond ((eq (car-safe a) 'cplx) a)
 123         ((eq (car-safe a) 'polar)
 124          (if (math-zerop (nth 1 a))
 125              (nth 1 a)
 126            (let ((sc (calcFunc-sincos (nth 2 a))))
 127              (list 'cplx
 128                    (math-mul (nth 1 a) (nth 1 sc))
 129                    (math-mul (nth 1 a) (nth 2 sc))))))
 130         (t (list 'cplx a 0)))
 131 )
 132
 133 ;;; Coerce A to be complex (polar form).  [c N]
 134 (defun math-polar (a)
 135   (cond ((eq (car-safe a) 'polar) a)
 136         ((math-zerop a) '(polar 0 0))
 137         (t
 138          (list 'polar
 139                (math-abs a)
 140                (calcFunc-arg a))))
 141 )
 142
 143 ;;; Multiply A by the imaginary constant i.  [N N] [Public]
 144 (defun math-imaginary (a)
 145   (if (and (or (Math-objvecp a) (math-infinitep a))
 146            (not calc-symbolic-mode))
 147       (math-mul a
 148                 (if (or (eq (car-safe a) 'polar)
 149                         (and (not (eq (car-safe a) 'cplx))
 150                              (eq calc-complex-mode 'polar)))
 151                     (list 'polar 1 (math-quarter-circle nil))
 152                   '(cplx 0 1)))
 153     (math-mul a '(var i var-i)))
 154 )
 155
 156
 157
 158
 159 (defun math-want-polar (a b)
 160   (cond ((eq (car-safe a) 'polar)
 161          (if (eq (car-safe b) 'cplx)
 162              (eq calc-complex-mode 'polar)
 163            t))
 164         ((eq (car-safe a) 'cplx)
 165          (if (eq (car-safe b) 'polar)
 166              (eq calc-complex-mode 'polar)
 167            nil))
 168         ((eq (car-safe b) 'polar)
 169          t)
 170         ((eq (car-safe b) 'cplx)
 171          nil)
 172         (t (eq calc-complex-mode 'polar)))
 173 )
 174
 175 ;;; Force A to be in the (-pi,pi] or (-180,180] range.
 176 (defun math-fix-circular (a &optional dir)   ; [R R]
 177   (cond ((eq (car-safe a) 'hms)
 178          (cond ((and (Math-lessp 180 (nth 1 a)) (not (eq dir 1)))
 179                 (math-fix-circular (math-add a '(float -36 1)) -1))
 180                ((or (Math-lessp -180 (nth 1 a)) (eq dir -1))
 181                 a)
 182                (t
 183                 (math-fix-circular (math-add a '(float 36 1)) 1))))
 184         ((eq calc-angle-mode 'rad)
 185          (cond ((and (Math-lessp (math-pi) a) (not (eq dir 1)))
 186                 (math-fix-circular (math-sub a (math-two-pi)) -1))
 187                ((or (Math-lessp (math-neg (math-pi)) a) (eq dir -1))
 188                 a)
 189                (t
 190                 (math-fix-circular (math-add a (math-two-pi)) 1))))
 191         (t
 192          (cond ((and (Math-lessp '(float 18 1) a) (not (eq dir 1)))
 193                 (math-fix-circular (math-add a '(float -36 1)) -1))
 194                ((or (Math-lessp '(float -18 1) a) (eq dir -1))
 195                 a)
 196                (t
 197                 (math-fix-circular (math-add a '(float 36 1)) 1)))))
 198 )
 199
 200
 201 ;;;; Complex numbers.
 202
 203 (defun calcFunc-polar (a)   ; [C N] [Public]
 204   (cond ((Math-vectorp a)
 205          (math-map-vec 'calcFunc-polar a))
 206         ((Math-realp a) a)
 207         ((Math-numberp a)
 208          (math-normalize (math-polar a)))
 209         (t (list 'calcFunc-polar a)))
 210 )
 211
 212 (defun calcFunc-rect (a)   ; [N N] [Public]
 213   (cond ((Math-vectorp a)
 214          (math-map-vec 'calcFunc-rect a))
 215         ((Math-realp a) a)
 216         ((Math-numberp a)
 217          (math-normalize (math-complex a)))
 218         (t (list 'calcFunc-rect a)))
 219 )
 220
 221 ;;; Compute the complex conjugate of A.  [O O] [Public]
 222 (defun calcFunc-conj (a)
 223   (let (aa bb)
 224     (cond ((Math-realp a)
 225            a)
 226           ((eq (car a) 'cplx)
 227            (list 'cplx (nth 1 a) (math-neg (nth 2 a))))
 228           ((eq (car a) 'polar)
 229            (list 'polar (nth 1 a) (math-neg (nth 2 a))))
 230           ((eq (car a) 'vec)
 231            (math-map-vec 'calcFunc-conj a))
 232           ((eq (car a) 'calcFunc-conj)
 233            (nth 1 a))
 234           ((math-known-realp a)
 235            a)
 236           ((and (equal a '(var i var-i))
 237                 (math-imaginary-i))
 238            (math-neg a))
 239           ((and (memq (car a) '(+ - * /))
 240                 (progn
 241                   (setq aa (calcFunc-conj (nth 1 a))
 242                         bb (calcFunc-conj (nth 2 a)))
 243                   (or (not (eq (car-safe aa) 'calcFunc-conj))
 244                       (not (eq (car-safe bb) 'calcFunc-conj)))))
 245            (if (eq (car a) '+)
 246                (math-add aa bb)
 247              (if (eq (car a) '-)
 248                  (math-sub aa bb)
 249                (if (eq (car a) '*)
 250                    (math-mul aa bb)
 251                  (math-div aa bb)))))
 252           ((eq (car a) 'neg)
 253            (math-neg (calcFunc-conj (nth 1 a))))
 254           ((let ((inf (math-infinitep a)))
 255              (and inf
 256                   (math-mul (calcFunc-conj (math-infinite-dir a inf)) inf))))
 257           (t (calc-record-why 'numberp a)
 258              (list 'calcFunc-conj a))))
 259 )
 260
 261
 262 ;;; Compute the complex argument of A.  [F N] [Public]
 263 (defun calcFunc-arg (a)
 264   (cond ((Math-anglep a)
 265          (if (math-negp a) (math-half-circle nil) 0))
 266         ((eq (car-safe a) 'cplx)
 267          (calcFunc-arctan2 (nth 2 a) (nth 1 a)))
 268         ((eq (car-safe a) 'polar)
 269          (nth 2 a))
 270         ((eq (car a) 'vec)
 271          (math-map-vec 'calcFunc-arg a))
 272         ((and (equal a '(var i var-i))
 273               (math-imaginary-i))
 274          (math-quarter-circle t))
 275         ((and (equal a '(neg (var i var-i)))
 276               (math-imaginary-i))
 277          (math-neg (math-quarter-circle t)))
 278         ((let ((signs (math-possible-signs a)))
 279            (or (and (memq signs '(2 4 6)) 0)
 280                (and (eq signs 1) (math-half-circle nil)))))
 281         ((math-infinitep a)
 282          (if (or (equal a '(var uinf var-uinf))
 283                  (equal a '(var nan var-nan)))
 284              '(var nan var-nan)
 285            (calcFunc-arg (math-infinite-dir a))))
 286         (t (calc-record-why 'numvecp a)
 287            (list 'calcFunc-arg a)))
 288 )
 289
 290 (defun math-imaginary-i ()
 291   (let ((val (calc-var-value 'var-i)))
 292     (or (eq (car-safe val) 'special-const)
 293         (equal val '(cplx 0 1))
 294         (and (eq (car-safe val) 'polar)
 295              (eq (nth 1 val) 0)
 296              (Math-equal (nth 1 val) (math-quarter-circle nil)))))
 297 )
 298
 299 ;;; Extract the real or complex part of a complex number.  [R N] [Public]
 300 ;;; Also extracts the real part of a modulo form.
 301 (defun calcFunc-re (a)
 302   (let (aa bb)
 303     (cond ((Math-realp a) a)
 304           ((memq (car a) '(mod cplx))
 305            (nth 1 a))
 306           ((eq (car a) 'polar)
 307            (math-mul (nth 1 a) (calcFunc-cos (nth 2 a))))
 308           ((eq (car a) 'vec)
 309            (math-map-vec 'calcFunc-re a))
 310           ((math-known-realp a) a)
 311           ((eq (car a) 'calcFunc-conj)
 312            (calcFunc-re (nth 1 a)))
 313           ((and (equal a '(var i var-i))
 314                 (math-imaginary-i))
 315            0)
 316           ((and (memq (car a) '(+ - *))
 317                 (progn
 318                   (setq aa (calcFunc-re (nth 1 a))
 319                         bb (calcFunc-re (nth 2 a)))
 320                   (or (not (eq (car-safe aa) 'calcFunc-re))
 321                       (not (eq (car-safe bb) 'calcFunc-re)))))
 322            (if (eq (car a) '+)
 323                (math-add aa bb)
 324              (if (eq (car a) '-)
 325                  (math-sub aa bb)
 326                (math-sub (math-mul aa bb)
 327                          (math-mul (calcFunc-im (nth 1 a))
 328                                    (calcFunc-im (nth 2 a)))))))
 329           ((and (eq (car a) '/)
 330                 (math-known-realp (nth 2 a)))
 331            (math-div (calcFunc-re (nth 1 a)) (nth 2 a)))
 332           ((eq (car a) 'neg)
 333            (math-neg (calcFunc-re (nth 1 a))))
 334           (t (calc-record-why 'numberp a)
 335              (list 'calcFunc-re a))))
 336 )
 337
 338 (defun calcFunc-im (a)
 339   (let (aa bb)
 340     (cond ((Math-realp a)
 341            (if (math-floatp a) '(float 0 0) 0))
 342           ((eq (car a) 'cplx)
 343            (nth 2 a))
 344           ((eq (car a) 'polar)
 345            (math-mul (nth 1 a) (calcFunc-sin (nth 2 a))))
 346           ((eq (car a) 'vec)
 347            (math-map-vec 'calcFunc-im a))
 348           ((math-known-realp a)
 349            0)
 350           ((eq (car a) 'calcFunc-conj)
 351            (math-neg (calcFunc-im (nth 1 a))))
 352           ((and (equal a '(var i var-i))
 353                 (math-imaginary-i))
 354            1)
 355           ((and (memq (car a) '(+ - *))
 356                 (progn
 357                   (setq aa (calcFunc-im (nth 1 a))
 358                         bb (calcFunc-im (nth 2 a)))
 359                   (or (not (eq (car-safe aa) 'calcFunc-im))
 360                       (not (eq (car-safe bb) 'calcFunc-im)))))
 361            (if (eq (car a) '+)
 362                (math-add aa bb)
 363              (if (eq (car a) '-)
 364                  (math-sub aa bb)
 365                (math-add (math-mul (calcFunc-re (nth 1 a)) bb)
 366                          (math-mul aa (calcFunc-re (nth 2 a)))))))
 367           ((and (eq (car a) '/)
 368                 (math-known-realp (nth 2 a)))
 369            (math-div (calcFunc-im (nth 1 a)) (nth 2 a)))
 370           ((eq (car a) 'neg)
 371            (math-neg (calcFunc-im (nth 1 a))))
 372           (t (calc-record-why 'numberp a)
 373              (list 'calcFunc-im a))))
 374 )
 375
 376
 377