Mercurial > emacs
diff lisp/calc/calc-cplx.el @ 40785:2fb9d407ae73
Initial import of Calc 2.02f.
author | Eli Zaretskii <eliz@gnu.org> |
---|---|
date | Tue, 06 Nov 2001 18:59:06 +0000 |
parents | |
children | 73f364fd8aaa |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/calc/calc-cplx.el Tue Nov 06 18:59:06 2001 +0000 @@ -0,0 +1,377 @@ +;; Calculator for GNU Emacs, part II [calc-cplx.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, daveg@synaptics.com. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-cplx () nil) + + +(defun calc-argument (arg) + (interactive "P") + (calc-slow-wrapper + (calc-unary-op "arg" 'calcFunc-arg arg)) +) + +(defun calc-re (arg) + (interactive "P") + (calc-slow-wrapper + (calc-unary-op "re" 'calcFunc-re arg)) +) + +(defun calc-im (arg) + (interactive "P") + (calc-slow-wrapper + (calc-unary-op "im" 'calcFunc-im arg)) +) + + +(defun calc-polar () + (interactive) + (calc-slow-wrapper + (let ((arg (calc-top-n 1))) + (if (or (calc-is-inverse) + (eq (car-safe arg) 'polar)) + (calc-enter-result 1 "p-r" (list 'calcFunc-rect arg)) + (calc-enter-result 1 "r-p" (list 'calcFunc-polar arg))))) +) + + + + +(defun calc-complex-notation () + (interactive) + (calc-wrapper + (calc-change-mode 'calc-complex-format nil t) + (message "Displaying complex numbers in (X,Y) format.")) +) + +(defun calc-i-notation () + (interactive) + (calc-wrapper + (calc-change-mode 'calc-complex-format 'i t) + (message "Displaying complex numbers in X+Yi format.")) +) + +(defun calc-j-notation () + (interactive) + (calc-wrapper + (calc-change-mode 'calc-complex-format 'j t) + (message "Displaying complex numbers in X+Yj format.")) +) + + +(defun calc-polar-mode (n) + (interactive "P") + (calc-wrapper + (if (if n + (> (prefix-numeric-value n) 0) + (eq calc-complex-mode 'cplx)) + (progn + (calc-change-mode 'calc-complex-mode 'polar) + (message "Preferred complex form is polar.")) + (calc-change-mode 'calc-complex-mode 'cplx) + (message "Preferred complex form is rectangular."))) +) + + +;;;; Complex numbers. + +(defun math-normalize-polar (a) + (let ((r (math-normalize (nth 1 a))) + (th (math-normalize (nth 2 a)))) + (cond ((math-zerop r) + '(polar 0 0)) + ((or (math-zerop th)) + r) + ((and (not (eq calc-angle-mode 'rad)) + (or (equal th '(float 18 1)) + (equal th 180))) + (math-neg r)) + ((math-negp r) + (math-neg (list 'polar (math-neg r) th))) + (t + (list 'polar r th)))) +) + + +;;; Coerce A to be complex (rectangular form). [c N] +(defun math-complex (a) + (cond ((eq (car-safe a) 'cplx) a) + ((eq (car-safe a) 'polar) + (if (math-zerop (nth 1 a)) + (nth 1 a) + (let ((sc (calcFunc-sincos (nth 2 a)))) + (list 'cplx + (math-mul (nth 1 a) (nth 1 sc)) + (math-mul (nth 1 a) (nth 2 sc)))))) + (t (list 'cplx a 0))) +) + +;;; Coerce A to be complex (polar form). [c N] +(defun math-polar (a) + (cond ((eq (car-safe a) 'polar) a) + ((math-zerop a) '(polar 0 0)) + (t + (list 'polar + (math-abs a) + (calcFunc-arg a)))) +) + +;;; Multiply A by the imaginary constant i. [N N] [Public] +(defun math-imaginary (a) + (if (and (or (Math-objvecp a) (math-infinitep a)) + (not calc-symbolic-mode)) + (math-mul a + (if (or (eq (car-safe a) 'polar) + (and (not (eq (car-safe a) 'cplx)) + (eq calc-complex-mode 'polar))) + (list 'polar 1 (math-quarter-circle nil)) + '(cplx 0 1))) + (math-mul a '(var i var-i))) +) + + + + +(defun math-want-polar (a b) + (cond ((eq (car-safe a) 'polar) + (if (eq (car-safe b) 'cplx) + (eq calc-complex-mode 'polar) + t)) + ((eq (car-safe a) 'cplx) + (if (eq (car-safe b) 'polar) + (eq calc-complex-mode 'polar) + nil)) + ((eq (car-safe b) 'polar) + t) + ((eq (car-safe b) 'cplx) + nil) + (t (eq calc-complex-mode 'polar))) +) + +;;; Force A to be in the (-pi,pi] or (-180,180] range. +(defun math-fix-circular (a &optional dir) ; [R R] + (cond ((eq (car-safe a) 'hms) + (cond ((and (Math-lessp 180 (nth 1 a)) (not (eq dir 1))) + (math-fix-circular (math-add a '(float -36 1)) -1)) + ((or (Math-lessp -180 (nth 1 a)) (eq dir -1)) + a) + (t + (math-fix-circular (math-add a '(float 36 1)) 1)))) + ((eq calc-angle-mode 'rad) + (cond ((and (Math-lessp (math-pi) a) (not (eq dir 1))) + (math-fix-circular (math-sub a (math-two-pi)) -1)) + ((or (Math-lessp (math-neg (math-pi)) a) (eq dir -1)) + a) + (t + (math-fix-circular (math-add a (math-two-pi)) 1)))) + (t + (cond ((and (Math-lessp '(float 18 1) a) (not (eq dir 1))) + (math-fix-circular (math-add a '(float -36 1)) -1)) + ((or (Math-lessp '(float -18 1) a) (eq dir -1)) + a) + (t + (math-fix-circular (math-add a '(float 36 1)) 1))))) +) + + +;;;; Complex numbers. + +(defun calcFunc-polar (a) ; [C N] [Public] + (cond ((Math-vectorp a) + (math-map-vec 'calcFunc-polar a)) + ((Math-realp a) a) + ((Math-numberp a) + (math-normalize (math-polar a))) + (t (list 'calcFunc-polar a))) +) + +(defun calcFunc-rect (a) ; [N N] [Public] + (cond ((Math-vectorp a) + (math-map-vec 'calcFunc-rect a)) + ((Math-realp a) a) + ((Math-numberp a) + (math-normalize (math-complex a))) + (t (list 'calcFunc-rect a))) +) + +;;; Compute the complex conjugate of A. [O O] [Public] +(defun calcFunc-conj (a) + (let (aa bb) + (cond ((Math-realp a) + a) + ((eq (car a) 'cplx) + (list 'cplx (nth 1 a) (math-neg (nth 2 a)))) + ((eq (car a) 'polar) + (list 'polar (nth 1 a) (math-neg (nth 2 a)))) + ((eq (car a) 'vec) + (math-map-vec 'calcFunc-conj a)) + ((eq (car a) 'calcFunc-conj) + (nth 1 a)) + ((math-known-realp a) + a) + ((and (equal a '(var i var-i)) + (math-imaginary-i)) + (math-neg a)) + ((and (memq (car a) '(+ - * /)) + (progn + (setq aa (calcFunc-conj (nth 1 a)) + bb (calcFunc-conj (nth 2 a))) + (or (not (eq (car-safe aa) 'calcFunc-conj)) + (not (eq (car-safe bb) 'calcFunc-conj))))) + (if (eq (car a) '+) + (math-add aa bb) + (if (eq (car a) '-) + (math-sub aa bb) + (if (eq (car a) '*) + (math-mul aa bb) + (math-div aa bb))))) + ((eq (car a) 'neg) + (math-neg (calcFunc-conj (nth 1 a)))) + ((let ((inf (math-infinitep a))) + (and inf + (math-mul (calcFunc-conj (math-infinite-dir a inf)) inf)))) + (t (calc-record-why 'numberp a) + (list 'calcFunc-conj a)))) +) + + +;;; Compute the complex argument of A. [F N] [Public] +(defun calcFunc-arg (a) + (cond ((Math-anglep a) + (if (math-negp a) (math-half-circle nil) 0)) + ((eq (car-safe a) 'cplx) + (calcFunc-arctan2 (nth 2 a) (nth 1 a))) + ((eq (car-safe a) 'polar) + (nth 2 a)) + ((eq (car a) 'vec) + (math-map-vec 'calcFunc-arg a)) + ((and (equal a '(var i var-i)) + (math-imaginary-i)) + (math-quarter-circle t)) + ((and (equal a '(neg (var i var-i))) + (math-imaginary-i)) + (math-neg (math-quarter-circle t))) + ((let ((signs (math-possible-signs a))) + (or (and (memq signs '(2 4 6)) 0) + (and (eq signs 1) (math-half-circle nil))))) + ((math-infinitep a) + (if (or (equal a '(var uinf var-uinf)) + (equal a '(var nan var-nan))) + '(var nan var-nan) + (calcFunc-arg (math-infinite-dir a)))) + (t (calc-record-why 'numvecp a) + (list 'calcFunc-arg a))) +) + +(defun math-imaginary-i () + (let ((val (calc-var-value 'var-i))) + (or (eq (car-safe val) 'special-const) + (equal val '(cplx 0 1)) + (and (eq (car-safe val) 'polar) + (eq (nth 1 val) 0) + (Math-equal (nth 1 val) (math-quarter-circle nil))))) +) + +;;; Extract the real or complex part of a complex number. [R N] [Public] +;;; Also extracts the real part of a modulo form. +(defun calcFunc-re (a) + (let (aa bb) + (cond ((Math-realp a) a) + ((memq (car a) '(mod cplx)) + (nth 1 a)) + ((eq (car a) 'polar) + (math-mul (nth 1 a) (calcFunc-cos (nth 2 a)))) + ((eq (car a) 'vec) + (math-map-vec 'calcFunc-re a)) + ((math-known-realp a) a) + ((eq (car a) 'calcFunc-conj) + (calcFunc-re (nth 1 a))) + ((and (equal a '(var i var-i)) + (math-imaginary-i)) + 0) + ((and (memq (car a) '(+ - *)) + (progn + (setq aa (calcFunc-re (nth 1 a)) + bb (calcFunc-re (nth 2 a))) + (or (not (eq (car-safe aa) 'calcFunc-re)) + (not (eq (car-safe bb) 'calcFunc-re))))) + (if (eq (car a) '+) + (math-add aa bb) + (if (eq (car a) '-) + (math-sub aa bb) + (math-sub (math-mul aa bb) + (math-mul (calcFunc-im (nth 1 a)) + (calcFunc-im (nth 2 a))))))) + ((and (eq (car a) '/) + (math-known-realp (nth 2 a))) + (math-div (calcFunc-re (nth 1 a)) (nth 2 a))) + ((eq (car a) 'neg) + (math-neg (calcFunc-re (nth 1 a)))) + (t (calc-record-why 'numberp a) + (list 'calcFunc-re a)))) +) + +(defun calcFunc-im (a) + (let (aa bb) + (cond ((Math-realp a) + (if (math-floatp a) '(float 0 0) 0)) + ((eq (car a) 'cplx) + (nth 2 a)) + ((eq (car a) 'polar) + (math-mul (nth 1 a) (calcFunc-sin (nth 2 a)))) + ((eq (car a) 'vec) + (math-map-vec 'calcFunc-im a)) + ((math-known-realp a) + 0) + ((eq (car a) 'calcFunc-conj) + (math-neg (calcFunc-im (nth 1 a)))) + ((and (equal a '(var i var-i)) + (math-imaginary-i)) + 1) + ((and (memq (car a) '(+ - *)) + (progn + (setq aa (calcFunc-im (nth 1 a)) + bb (calcFunc-im (nth 2 a))) + (or (not (eq (car-safe aa) 'calcFunc-im)) + (not (eq (car-safe bb) 'calcFunc-im))))) + (if (eq (car a) '+) + (math-add aa bb) + (if (eq (car a) '-) + (math-sub aa bb) + (math-add (math-mul (calcFunc-re (nth 1 a)) bb) + (math-mul aa (calcFunc-re (nth 2 a))))))) + ((and (eq (car a) '/) + (math-known-realp (nth 2 a))) + (math-div (calcFunc-im (nth 1 a)) (nth 2 a))) + ((eq (car a) 'neg) + (math-neg (calcFunc-im (nth 1 a)))) + (t (calc-record-why 'numberp a) + (list 'calcFunc-im a)))) +) + + +