;;; -*-  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)
  (destructuring-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))))))

