lisp/calc/calc-cplx.el

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