;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;     The data in this file contains enhancments.                    ;;;;;
;;;                                                                    ;;;;;
;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
;;;     All rights reserved                                            ;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package "MAXIMA")
(macsyma-module troper)


(TRANSL-MODULE TROPER)

;;; The basic OPERATORS properties translators.


(declare-top (MUZZLED T)) ; TURN OFF CLOSED COMPILATION MESSAGE

(DEF%TR MMINUS (FORM)
  (SETQ FORM (TRANSLATE (CADR FORM)))
  (COND ((NUMBERP (CDR FORM))
	 `(,(CAR FORM) . ,(MINUS (CDR FORM))))
	((EQ '$FIXNUM (CAR FORM)) `($FIXNUM - ,(CDR FORM)))
	((EQ '$FLOAT (CAR FORM)) `($FLOAT -$ ,(CDR FORM)))
	((EQ '$NUMBER (CAR FORM)) `($NUMBER MINUS ,(CDR FORM)))
	((EQ '$RATIONAL (CAR FORM))
	 (COND ((AND (NOT (ATOM (CADDR FORM))) (EQ 'RAT (CAAR (CADDR FORM))))
		(SETQ FORM (CDADDR FORM))
		`($RATIONAL QUOTE ((RAT) ,(f- (CAR FORM)) ,(CADR FORM))))
	       (T `($RATIONAL RTIMES -1 ,(CDR FORM)))))
	(T `($ANY . (*MMINUS ,(CDR FORM))))))
(declare-top (MUZZLED NIL))

(DEF%TR MPLUS (FORM)
  (LET   (ARGS MODE)
    (DO ((L (CDR FORM) (CDR L))) ((NULL L))
	(SETQ ARGS (CONS (TRANSLATE (CAR L)) ARGS)
	      MODE (*UNION-MODE (CAR (CAR ARGS)) MODE)))
    (SETQ ARGS (NREVERSE ARGS))
    (COND ((EQ '$FIXNUM MODE) `($FIXNUM f+ . ,(MAPCAR 'CDR ARGS)))
	  ((EQ '$FLOAT MODE) `($FLOAT +$ . ,(MAPCAR 'DCONV-$FLOAT ARGS)))
	  ((EQ '$RATIONAL MODE) `($RATIONAL RPLUS . ,(MAPCAR 'CDR ARGS)))
	  ((EQ '$NUMBER MODE) `($NUMBER PLUS . ,(MAPCAR 'CDR ARGS)))
	  (T `($ANY ADD* . ,(MAPCAR 'DCONVX ARGS))))))


(DEFUN NESTIFY (OP L)
  (DO ((L (CDR L) (CDR L)) (NL (CAR L))) ((NULL L) NL)
      (SETQ NL (LIST OP NL (CAR L)))))

(DEF%TR MTIMES (FORM)
  (LET
   (ARGS MODE)
   (COND
    ((EQUAL -1 (CADR FORM))
     (TRANSLATE `((MMINUS) ((MTIMES) . ,(CDDR FORM)))))
    (t
     (DO ((L (CDR FORM) (CDR L))) ((NULL L))
	 (SETQ ARGS (CONS (TRANSLATE (CAR L)) ARGS)
	       MODE (*UNION-MODE (CAR (CAR ARGS)) MODE)))
     (SETQ ARGS (NREVERSE ARGS))
     (COND ((EQ '$FIXNUM MODE) `($FIXNUM f* . ,(MAPCAR 'CDR ARGS)))
	   ((EQ '$FLOAT MODE) `($FLOAT *$ . ,(MAPCAR 'DCONV-$FLOAT ARGS)))
	   ((EQ '$RATIONAL MODE) `($RATIONAL RTIMES . ,(MAPCAR 'CDR ARGS)))
	   ((EQ '$NUMBER MODE) `($NUMBER TIMES . ,(MAPCAR 'CDR ARGS)))
	   (T `($ANY MUL* . ,(MAPCAR 'DCONVX ARGS))))))))


(DEF%TR MQUOTIENT (FORM)
	(let (ARG1 ARG2 MODE)
	     (SETQ ARG1 (TRANSLATE (CADR FORM)) ARG2 (TRANSLATE (CADDR FORM))
		   MODE (*UNION-MODE (CAR ARG1) (CAR ARG2))
		   ARG1 (DCONV ARG1 MODE) ARG2 (DCONV ARG2 MODE))
	     (COND ((EQ '$FLOAT MODE)
		    (SETQ ARG1 (IF (zl-MEMBER ARG1 '(1 1.0)) (LIST ARG2)
				   (LIST ARG1 ARG2)))
		    `($FLOAT //$ . ,ARG1))
		   ((AND (EQ MODE '$FIXNUM) $TR_NUMER)
		    `($FLOAT . (//$ (FLOAT ,ARG1) (FLOAT ,ARG2))))
		   ((MEMQ MODE '($FIXNUM $RATIONAL))
		    `($RATIONAL RREMAINDER ,ARG1 ,ARG2))
		   (T `($ANY DIV ,ARG1 ,ARG2)))))

(defvar $tr_exponent nil "If True it allows translation of x^n to generate (expt $x $n) if $n is fixnum and $x is fixnum, or number" )

(DEF%TR MEXPT (FORM)
  (IF (EQ '$%E (CADR FORM)) (TRANSLATE `(($EXP) ,(CADDR FORM)))
      (LET   (BAS EXP)
	(SETQ BAS (TRANSLATE (CADR FORM)) EXP (TRANSLATE (CADDR FORM)))
	(COND ((EQ '$FIXNUM (CAR EXP))
	       (SETQ EXP (CDR EXP))
	       (COND ((EQ '$FLOAT (CAR BAS))
		      (COND ((NOT (INTEGERP EXP)) `($FLOAT ^$ ,(CDR BAS) ,EXP))
			    (T `($FLOAT EXPT$ ,(CDR BAS) ,EXP))))
		     ((AND (EQ (CAR BAS) '$FIXNUM)
			   $TR_NUMER)
		      ;; when NUMER:TRUE we have 1/2 evaluating to 0.5
		      ;; therefore we have a TR_NUMER switch to control
		      ;; this form numerical hackers at translate time
		      ;; where it does the most good. -gjc
		      `($FLOAT . (^$ (FLOAT ,(CDR BAS)) ,EXP)))
		     ;; This next optimization was just plain wrong!
		     ;; -gjc
		     ;;((MEMQ (CAR BAS) '($FIXNUM $NUMBER))
		     ;;`($NUMBER EXPT ,(CDR BAS) ,EXP))
		     #+cl  ;;It seems to me we can do this,
		     ;; although 2^-3 would result in a "cl rat'l number"
		     ((and $tr_exponent (MEMQ (CAR BAS) '($FIXNUM $NUMBER)))
		     `($NUMBER EXPT ,(CDR BAS) ,EXP))
		     (T `($ANY POWER ,(CDR BAS) ,EXP))))
	      ((AND (EQ '$FLOAT (CAR BAS))
		    (EQ '$RATIONAL (CAR EXP))
		    (NOT (ATOM (CADDR EXP)))
		    (COND ((EQUAL 2 (CADDR (CADDR EXP)))
			   (SETQ EXP (CADR (CADDR EXP)))
			   (COND ((= 1 EXP) `($FLOAT SQRT ,(CDR BAS)))
				 ((= -1 EXP) `($FLOAT //$ (SQRT ,(CDR BAS))))
				 (T `($FLOAT EXPT$ (SQRT ,(CDR BAS)) ,EXP))))
			  ((EQ 'RAT (CAAR (CADDR EXP)))
			   `($FLOAT EXPT ,(CDR BAS) ,($FLOAT (CADDR EXP)))))))
	      ((AND (COVERS '$NUMBER (CAR BAS)) (COVERS '$NUMBER (CAR EXP)))
	       `(,(*UNION-MODE (CAR BAS) (CAR EXP)) EXPT ,(CDR BAS) ,(CDR EXP)))
	      (T `($ANY POWER ,(CDR BAS) ,(CDR EXP)))))))



(DEF%TR RAT (FORM) `($RATIONAL . ',FORM))

(DEF%TR BIGFLOAT (FORM) `($ANY . ',FORM))



(DEF%TR %SQRT (FORM)
  (SETQ FORM (TRANSLATE (CADR FORM)))
  (IF (EQ '$FLOAT (CAR FORM)) `($FLOAT SQRT ,(CDR FORM))
      `($ANY SIMPLIFY (LIST '(%SQRT) ,(CDR FORM)))))

(DEF%TR MABS (FORM) 
  (SETQ FORM (TRANSLATE (CADR FORM)))
  (IF (COVERS '$NUMBER (CAR FORM)) (LIST (CAR FORM) 'ABS (CDR FORM))
      `($ANY SIMPLIFY (LIST '(MABS) ,(DCONVX FORM)))))


(DEF%TR %SIGNUM (FORM)
	(LET (( (MODE . ARG) (TRANSLATE (CADR FORM))))
	     (COND ((MEMQ MODE '($FIXNUM $FLOAT))
		    (LET ((TEMP (TR-GENSYM)))
			 `($FIXNUM . ((LAMBDA (,TEMP)
					      (DECLARE (,(IF (EQ MODE '$FLOAT)	
							     'flonum
							     'fixnum)
							,TEMP))
					      (COND ((MINUSP ,TEMP) -1)
						    ((PLUSP ,TEMP) 1)
						    (T 0)))
				      ,ARG))))
		   (T
		    ;; even in this unknown case we can do a hell
		    ;; of a lot better than consing up a form to
		    ;; call the macsyma simplifier. I mean, shoot
		    ;; have a little SUBR called SIG-NUM or something.
		    `($ANY SIMPLIFY (LIST '(%SIGNUM) ,ARG))))))

;; The optimization of using -1.0, +1.0 and 0.0 cannot be made unless we
;; know the TARGET MODE. The action of the simplifier is that
;; SIGNUM(3.3) => 1 , SIGNUM(3.3) does not give 0.0
;; Maybe this is a bug in the simplifier, maybe not. -gjc

;; There are many possible non-trivial optimizations possible involving
;; SIGNUM. MODE TARGETTING must be built in to get these easily of course,
;; examples are: SIGNUM(X*Y); No need to multiple X and Y, just multiply
;; there SIGN's, which is a conditional and comparisons. However, these
;; are only optimizations if X and Y are numeric. What if
;; X:'a,Y:'B, ASSUME(A*B>0), SIGNUM(X*Y). Well, here
;; SIGNUM(X)*SIGNUM(Y) won't be the same as SIGNUM(X*Y). -gjc

;; just to show the kind of brain damage...
;;(DEF%TR %SIGNUM (FORM)
;;   (SETQ FORM (TRANSLATE (CADR FORM)))
;;   (COND ((MEMQ (CAR FORM) 
;;	  (LET   ((X (CDR FORM)) (MODE (CAR FORM))
;;		    (ONE 1) (MINUS1 -1) (ZERO 0) (VAR '%%N)
;;		    (DECLARE-TYPE 'FIXNUM) COND-CLAUSE)
;;	     (IF (EQ '$FLOAT MODE) (SETQ ONE 1.0 MINUS1 -1.0 ZERO 0.0 VAR '$$X
;;					 DECLARE-TYPE 'FLONUM))
;;	     (SETQ COND-CLAUSE `(COND ((MINUSP ,X) ,MINUS1)
;;				      ((PLUSP ,X)  ,ONE)
;;				      (T ,ZERO)))
;;	     (IF (ATOM (CDR FORM)) `(,MODE . ,COND-CLAUSE)
;;		 (ADDL `(,DECLARE-TYPE ,VAR) DECLARES)
;;		 `(,MODE (LAMBDA (,VAR) ,COND-CLAUSE) ,X))))
;;	 (T `($ANY SIMPLIFY (LIST '(%SIGNUM) ,(CDR FORM))))))


(DEF%TR $ENTIER (FORM) 
  (SETQ FORM (TRANSLATE (CADR FORM)))
  (COND ((EQ '$FIXNUM (CAR FORM)) FORM)
        ((MEMQ (CAR FORM) '($FLOAT $NUMBER))
	 (IF (EQ 'SQRT (CADR FORM)) `($FIXNUM $ISQRT ,(CADDR FORM))
	     `($FIXNUM FIX ,(CDR FORM))))
        (T `(,(IF (EQ (CAR FORM) '$RATIONAL) '$FIXNUM '$ANY)
	      $ENTIER ,(CDR FORM)))))

(DEF%TR $FLOAT (FORM)
  (SETQ FORM (TRANSLATE (CADR FORM)))
  (IF (COVERS '$FLOAT (CAR FORM)) (CONS '$FLOAT (DCONV-$FLOAT FORM))
      `($ANY $FLOAT ,(CDR FORM))))



(DEF%TR $EXP (FORM)
  (SETQ FORM (TRANSLATE (CADR FORM)))
  (IF (EQ '$FLOAT (CAR FORM)) `($FLOAT EXP ,(CDR FORM))
      `($ANY SIMPLIFY ($EXP ,(CDR FORM)))))

(DEF%TR $ATAN2 (FORM)
   (SETQ FORM (CDR FORM))
   (LET   ((X (TRANSLATE (CAR FORM))) (Y (TRANSLATE (CADR FORM))))
      (IF (EQ '$FLOAT (*UNION-MODE (CAR X) (CAR Y)))
	  `($FLOAT ATAN2 ,(CDR X) ,(CDR Y))
	`($ANY SIMPLIFY (LIST '($ATAN2) ,(CDR X) ,(CDR Y))))))

(DEF%TR %ATAN (FORM)
   (SETQ FORM (CDR FORM))
   (LET   ((X (TRANSLATE (CAR FORM))))
      (IF (EQ '$FLOAT (CAR X)) `($FLOAT ATAN1 ,(CDR X))
	  `($ANY SIMPLIFY (LIST '(%ATAN) ,(CDR X))))))

