Function: math-combine-prod

math-combine-prod is an autoloaded and byte-compiled function defined in calc-arith.el.gz.

Signature

(math-combine-prod A B INVA INVB SCALAR-OKAY)

Source Code

;; Defined in /usr/src/emacs/lisp/calc/calc-arith.el.gz
(defun math-combine-prod (a b inva invb scalar-okay)
  (cond
   ((or (and inva (Math-zerop a))
	(and invb (Math-zerop b)))
    nil)
   ((and scalar-okay (Math-objvecp a) (Math-objvecp b))
    (setq a (math-mul-or-div a b inva invb))
    (and (Math-objvecp a)
	 a))
   ((and (eq (car-safe a) '^)
	 inva
	 (math-looks-negp (nth 2 a)))
    (math-mul (math-pow (nth 1 a) (math-neg (nth 2 a))) b))
   ((and (eq (car-safe b) '^)
	 invb
	 (math-looks-negp (nth 2 b)))
    (math-mul a (math-pow (nth 1 b) (math-neg (nth 2 b)))))
   ((and math-simplifying
         (math-combine-prod-trig a b)))
   (t (let ((apow 1) (bpow 1))
	(and (consp a)
	     (cond ((and (eq (car a) '^)
			 (or math-simplifying
			     (Math-numberp (nth 2 a))))
		    (setq apow (nth 2 a)
			  a (nth 1 a)))
		   ((eq (car a) 'calcFunc-sqrt)
		    (setq apow '(frac 1 2)
			  a (nth 1 a)))
		   ((and (eq (car a) 'calcFunc-exp)
			 (or math-simplifying
			     (Math-numberp (nth 1 a))))
		    (setq apow (nth 1 a)
			  a math-combine-prod-e))))
	(and (consp a) (eq (car a) 'frac)
	     (Math-lessp (nth 1 a) (nth 2 a))
	     (setq a (math-div 1 a) apow (math-neg apow)))
	(and (consp b)
	     (cond ((and (eq (car b) '^)
			 (or math-simplifying
			     (Math-numberp (nth 2 b))))
		    (setq bpow (nth 2 b)
			  b (nth 1 b)))
		   ((eq (car b) 'calcFunc-sqrt)
		    (setq bpow '(frac 1 2)
			  b (nth 1 b)))
		   ((and (eq (car b) 'calcFunc-exp)
			 (or math-simplifying
			     (Math-numberp (nth 1 b))))
		    (setq bpow (nth 1 b)
			  b math-combine-prod-e))))
	(and (consp b) (eq (car b) 'frac)
	     (Math-lessp (nth 1 b) (nth 2 b))
	     (setq b (math-div 1 b) bpow (math-neg bpow)))
	(if inva (setq apow (math-neg apow)))
	(if invb (setq bpow (math-neg bpow)))
	(or (and (if math-simplifying
		     (math-commutative-equal a b)
		   (equal a b))
		 (let ((sumpow (math-add apow bpow)))
		   (and (or (not (Math-integerp a))
			    (Math-zerop sumpow)
			    (eq (eq (car-safe apow) 'frac)
				(eq (car-safe bpow) 'frac)))
			(progn
			  (and (math-looks-negp sumpow)
			       (Math-ratp a) (Math-posp a)
			       (setq a (math-div 1 a)
				     sumpow (math-neg sumpow)))
			  (cond ((equal sumpow '(frac 1 2))
				 (list 'calcFunc-sqrt a))
				((equal sumpow '(frac -1 2))
				 (math-div 1 (list 'calcFunc-sqrt a)))
				((and (eq a math-combine-prod-e)
				      (eq a b))
				 (list 'calcFunc-exp sumpow))
				(t
				 (condition-case nil
				     (math-pow a sumpow)
				   (inexact-result (list '^ a sumpow)))))))))
	    (and math-simplifying-units
		 math-combining-units
		 (let* ((ua (math-check-unit-name a))
			ub)
		   (and ua
			(eq ua (setq ub (math-check-unit-name b)))
			(progn
			  (setq ua (if (eq (nth 1 a) (car ua))
				       1
				     (nth 1 (assq (aref (symbol-name (nth 1 a))
							0)
						  math-unit-prefixes)))
				ub (if (eq (nth 1 b) (car ub))
				       1
				     (nth 1 (assq (aref (symbol-name (nth 1 b))
							0)
						  math-unit-prefixes))))
			  (if (Math-lessp ua ub)
			      (let (temp)
				(setq temp a a b b temp
				      temp ua ua ub ub temp
				      temp apow apow bpow bpow temp)))
			  (math-mul (math-pow (math-div ua ub) apow)
				    (math-pow b (math-add apow bpow)))))))
	    (and (equal apow bpow)
		 (Math-natnump a) (Math-natnump b)
		 (cond ((equal apow '(frac 1 2))
			(list 'calcFunc-sqrt (math-mul a b)))
		       ((equal apow '(frac -1 2))
			(math-div 1 (list 'calcFunc-sqrt (math-mul a b))))
		       (t
			(setq a (math-mul a b))
			(condition-case nil
			    (math-pow a apow)
			  (inexact-result (list '^ a apow)))))))))))