code.delx.au - gnu-emacs/blob - lisp/calc/calc-cplx.el

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