;;;generic polar complex (defpackage :polar (:use :common-lisp :ga ) (:shadowing-import-from :ga "+" "-" "/" "*" "expt" ;binary arith "=" "/=" ">" "<" "<=" ">=" ;binary comparisons "sin" "cos" "tan" ;... more trig "atan" "asin" "acos" ;... more inverse trig "sinh" "cosh" "atanh" ;... more hyperbolic "expt" "log" "exp" "sqrt" ;... more exponential, powers "1-" "1+" "abs" "incf" "decf" "tocl" "re-intern" "numerator" "denominator" "realpart" "complex" "imagpart" ) (:export "polar" ) ) (provide "polar" ) (in-package :polar) ;; x= r*cos(theta) ;; y= r*sin(theta) ;; r= sqrt(x^2+y^2) ;should be careful to avoid float overflow. ;; theta= arctan(y/x) , ;; polar numbers r>=0, -pi r 0)(incf th pi)(setf r (- r))) (setf th (norm th)) (if (<(abs th)) #.(* 2 double-float-epsilon)) r ; no longer a polar object, arg is 0 (polar r th))) ;; otherwise (defmethod polarnorm((r t)(th t)) (polar r th)) ;; + is not engineered for extreme bounds or preventing overflow on x^2+y^2 (defmethod ga::two-arg-+((p1 polar)(p2 polar)) (with-polar-rect2 p1 p2 (a1 b1)(a2 b2) ; a1+b1*i, a2+b2*i (let* ((a3 (+ a1 a2)) ; answer is a3+b3*i (b3 (+ b1 b2)) (th3 (atan2 b3 a3)) (r3 (sqrt (+(* a3 a3)(* b3 b3))))) (polarnorm r3 th3)))) (defmethod ga::two-arg-+((p1 polar)(p2 t)) ;p2 is presumed NOT complex (with-polar-rect1 p1 (a1 b1) ; p1 = a1+b1*i (let* ((a3 (+ a1 p2)) (th3 (atan2 b1 a3 )) ;;(th3 (/ b1 a3)) ;should use atan2. theta (r3 (sqrt (+(* a3 a3)(* b1 b1))))) (polarnorm r3 th3)))) (defmethod ga::two-arg-+((p2 t)(p1 polar)) ;reverse the args. (ga::two-arg-+ p1 p2)) (defmethod rect ((p polar)) ;; convert polar to rectangular form in ma (um, a choice) (with-polar-rect1 p (a b)(+ a (* b (ma::ma 'i))))) (defun polarize (a b) ;; convert a+b*i to polar. (let ((r (sqrt (+ (* a a)(* b b)))) (th (atan2 b a))) (polarnorm r th))) (defmethod ga::two-arg--((p1 polar)(p2 polar)) (with-polar-rect2 p1 p2 (a1 b1)(a2 b2) ; a1+b1*i, a2+b2*i (let* ((a3 (- a1 a2)) ; answer is a3+b3*i (b3 (- b1 b2)) (th3 (atan2 b3 a3)) (r3 (sqrt (+(* a3 a3)(* b3 b3))))) (polarnorm r3 th3)))) (defmethod ga::two-arg--((p1 polar)(p2 t)) ;p2 is presumed NOT complex (with-polar-rect1 p1 (a1 b1) ; p1 = a1+b1*i (let* ((a3 (- a1 p2)) (th3 (atan2 b1 a3)) (r3 (sqrt (+(* a3 a3)(* b1 b1))))) (polarnorm r3 th3)))) (defmethod ga::two-arg--((p2 t)(p1 polar)) ;reverse the args. (ga::two-arg-- p1 p2)) (defmethod atan2( (y number) (x number))(cl::atan y x)) (defmethod atan2( (y t)(x t)) (ma::ma `(atan2 ,y ,x))) ;;; need / and expt. ;;; need to write the sin, cos, tan, etc. ;;; need exponential, log ;;; orderings of complex objects all false, or error? ;;; except for = and /= (defmethod ga::abs((x polar))(polar-r x)) (defmacro defcomparison (op) (let ((two-arg (intern (concatenate 'string "two-arg-" (symbol-name op)) :ga ))) `(progn ;; very few compares work. Just notequal. See below (defmethod ,two-arg ((arg1 polar) (arg2 number)) nil) (defmethod ,two-arg ((arg1 number) (arg2 polar)) nil) (defmethod ,two-arg ((arg1 polar) (arg2 polar)) nil) (compile ',two-arg) ',op))) (defcomparison >) (defcomparison <) (defcomparison <=) (defcomparison >=) (defmethod ga::two-arg-= ((arg1 polar) (arg2 polar)) (with-polar2 arg1 arg2 (a b)(c d) (and (= a c)(= b d)))) (defmethod ga::two-arg-/= ((arg1 polar) (arg2 polar)) (with-polar2 arg1 arg2 (a b)(c d) (or (/= a c)(/= b d)))) (defmethod ga::two-arg-= ((arg1 polar) (arg2 t))nil) (defmethod ga::two-arg-/= ((arg1 polar) (arg2 t))t)