;;; -*-  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 1981 Massachusetts Institute of Technology         ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

(declare-top (SPECIAL 1//2 -1//2 DISPLAYP ALIASLIST IN-P))

(DEFMVAR $POWERDISP NIL)
(DEFMVAR $PFEFORMAT NIL)
(DEFMVAR $%EDISPFLAG NIL)
(DEFMVAR $EXPTDISPFLAG T)
(DEFMVAR $SQRTDISPFLAG T)
(DEFMVAR $NEGSUMDISPFLAG T)
(SETQ IN-P NIL)

(defun $extendp (x) x nil)
;;for new types that answer (send x :macsyma-extended-type) and such like.

(DEFMFUN NFORMAT (FORM)
  (COND ((ATOM FORM)
	 (COND ((AND (NUMBERP FORM) (MINUSP FORM)) (LIST '(MMINUS) (MINUS FORM)))
	       ((EQ T FORM) (IF IN-P T '$TRUE))
	       ((EQ NIL FORM) (IF IN-P NIL '$FALSE))
	       ((AND DISPLAYP (CAR (ASSQR FORM ALIASLIST))))
	       (($EXTENDP FORM)
		(NFORMAT (transform-extends form)))
	       (T FORM)))
	((ATOM (CAR FORM))
	 FORM)
	((EQ 'RAT (CAAR FORM))
	 (COND ((MINUSP (CADR FORM))
		(LIST '(MMINUS) (LIST '(RAT) (MINUS (CADR FORM)) (CADDR FORM))))
	       (T (CONS '(RAT) (CDR FORM)))))
	((EQ 'MMACROEXPANDED (CAAR FORM)) (NFORMAT (CADDR FORM)))
	((NULL (CDAR FORM)) FORM)
	((EQ 'MPLUS (CAAR FORM)) (FORM-MPLUS FORM))
	((EQ 'MTIMES (CAAR FORM)) (FORM-MTIMES FORM))
	((EQ 'MEXPT (CAAR FORM)) (FORM-MEXPT FORM))
	((EQ 'MRAT (CAAR FORM)) (FORM-MRAT FORM))
	((EQ 'MPOIS (CAAR FORM)) (NFORMAT ($OUTOFPOIS FORM)))
	((EQ 'BIGFLOAT (CAAR FORM))
	 (IF (MINUSP (CADR FORM))
	     (LIST '(MMINUS) (LIST (CAR FORM) (MINUS (CADR FORM)) (CADDR FORM)))
	     (CONS (CAR FORM) (CDR FORM))))
	(T FORM)))

(DEFUN FORM-MPLUS (FORM &AUX ARGS TRUNC)
    (SETQ ARGS (MAPCAR #'NFORMAT (CDR FORM)))
    (SETQ TRUNC (MEMQ 'TRUNC (CDAR FORM)))
    (CONS (IF TRUNC '(MPLUS TRUNC) '(MPLUS))
	  (COND ((AND (MEMQ 'RATSIMP (CDAR FORM)) (NOT (MEMQ 'SIMP (CDAR FORM))))
		 (IF $POWERDISP (NREVERSE ARGS) ARGS))
		((AND TRUNC (NOT (MEMQ 'SIMP (CDAR FORM)))) (NREVERSE ARGS))
		((OR $POWERDISP TRUNC (MEMQ 'CF (CDAR FORM))) ARGS)
		((AND $NEGSUMDISPFLAG (NULL (CDDDR FORM)))
		 (IF (AND (NOT (MMMINUSP (CAR ARGS)))
			  (MMMINUSP (CADR ARGS)))
		     ARGS
		     (NREVERSE ARGS)))
		(T (NREVERSE ARGS)))))

(DEFUN FORM-MTIMES (FORM)
  (COND ((NULL (CDR FORM)) '((MTIMES)))
	((EQUAL -1 (CADR FORM)) (LIST '(MMINUS) (FORM-MTIMES (CDR FORM))))
        (T (PROG (NUM DEN MINUS FLAG)
		(DO ((L (CDR FORM) (CDR L)) (DUMMY)) ((NULL L))
		    (SETQ DUMMY (NFORMAT (CAR L)))
		    (COND ((ATOM DUMMY) (SETQ NUM (CONS DUMMY NUM)))
			  ((EQ 'MMINUS (CAAR DUMMY))
			   (SETQ MINUS (NOT MINUS) L (APPEND DUMMY (CDR L))))
			  ((OR (EQ 'MQUOTIENT (CAAR DUMMY))
			       (AND (NOT $PFEFORMAT) (EQ 'RAT (CAAR DUMMY))))
			   (COND ((NOT (EQUAL 1 (CADR DUMMY)))
				  (SETQ NUM (CONS (CADR DUMMY) NUM))))
			   (SETQ DEN (CONS (CADDR DUMMY) DEN)))
			  (T (SETQ NUM (CONS DUMMY NUM)))))
	      (SETQ NUM (COND ((NULL NUM) 1)
			      ((NULL (CDR NUM)) (CAR NUM))
			      (T (CONS '(MTIMES) (NREVERSE NUM))))
		    DEN (COND ((NULL DEN) (SETQ FLAG T) NIL)
			      ((NULL (CDR DEN)) (CAR DEN))
			      (T (CONS '(MTIMES) (NREVERSE DEN)))))
	      (IF (NOT FLAG) (SETQ NUM (LIST '(MQUOTIENT) NUM DEN)))
	      (RETURN (IF MINUS (LIST '(MMINUS) NUM) NUM))))))

(DEFUN FORM-MEXPT (FORM &AUX EXP)
    (COND ((AND $SQRTDISPFLAG (ALIKE1 1//2 (CADDR FORM))) (LIST '(%SQRT) (CADR FORM)))
	  ((AND $SQRTDISPFLAG (ALIKE1 -1//2 (CADDR FORM)))
	   (LIST '(MQUOTIENT) 1 (LIST '(%SQRT) (CADR FORM))))
	  ((AND (OR (AND $%EDISPFLAG (EQ '$%E (CADR FORM)))
		    (AND $EXPTDISPFLAG (NOT (EQ '$%E (CADR FORM)))))
		(NOT (ATOM (SETQ EXP (NFORMAT (CADDR FORM)))))
		(EQ 'MMINUS (CAAR EXP)))
	   (LIST '(MQUOTIENT) 1 (IF (EQUAL 1 (CADR EXP)) (CADR FORM)
				    (LIST '(MEXPT) (CADR FORM) (CADR EXP)))))
	  (T (CONS '(MEXPT) (CDR FORM)))))

(DEFUN FORM-MRAT (FORM)
  (LET ((TRUNC (MEMQ 'TRUNC (CDAR FORM))) EXACT)
    (IF (AND TRUNC (EQ (CADR FORM) 'PS))
	(SETQ EXACT (NULL (CAR (CADDDR FORM)))))
    (SETQ FORM (RATDISREPD FORM))
    (RDIS1 FORM)
    (IF (AND TRUNC (OR (ATOM FORM)
		       ;; A constant, e.g. ((mplus) $a 1)
		       (not (zl-MEMBER (car form)
				    '((mplus exact) (mplus trunc))))))
	(CONS (IF EXACT '(MPLUS EXACT) '(MPLUS TRUNC)) (NCONS FORM))
	(NFORMAT FORM))))

(DEFUN RDIS1 (FORM)
  (COND ((OR (ATOM FORM) (SPECREPP FORM)))
	((NULL (CDAR FORM)) (RPLACA FORM (LIST (CAAR FORM) 'RATSIMP)))
	(T (MAPC #'RDIS1 (CDR FORM)))))

;(DEFMFUN NFORMAT-ALL (FORM)
;  (SETQ FORM (NFORMAT FORM))
;  (IF (OR (ATOM FORM) (EQ (CAAR FORM) 'BIGFLOAT))
;      FORM
;      (CONS (DELSIMP (CAR FORM)) (MAPCAR #'NFORMAT-ALL (CDR FORM)))))
;Update from F302
(DEFMFUN NFORMAT-ALL (FORM)
  (SETQ FORM (NFORMAT FORM))
  (IF (OR (ATOM FORM) (EQ (CAAR FORM) 'BIGFLOAT))
      FORM
      (CONS (DELSIMP (CAR FORM))
	    (IF (MEMQ (CAAR FORM) '(MDO MDOIN))
		(MAPCAR #'(LAMBDA (U) (IF U (NFORMAT-ALL U))) (CDR FORM))
		(MAPCAR #'NFORMAT-ALL (CDR FORM))))))