src/nforma.lisp

   1 ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;     The data in this file contains enhancments.                    ;;;;;
   4 ;;;                                                                    ;;;;;
   5 ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
   6 ;;;     All rights reserved                                            ;;;;;
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package :maxima)
  12
  13 (macsyma-module nforma)
  14
  15 (declare-top (special 1//2 -1//2 in-p))
  16
  17 (defmvar $powerdisp nil)
  18 (defmvar $pfeformat nil)
  19 (defmvar $%edispflag nil)
  20 (defmvar $exptdispflag t)
  21 (defmvar $sqrtdispflag t)
  22 (defmvar $negsumdispflag t)
  23
  24 (setq in-p nil)
  25
  26 (defun nformat (form &aux (p nil))
  27   (cond ((atom form)
  28          (cond ((and (realp form) (minusp form) (not (float-inf-p form))) (list '(mminus) (- form)))
  29                ((eq t form) (if in-p t '$true))
  30                ((eq nil form) (if in-p nil '$false))
  31                ;; revision, extension by Richard Fateman 3/2013.
  32                ;;  Perhaps some object is an atom, maybe a CLOS object or structure.
  33                ;; Either its type is a symbolp..
  34                ;; e.g. a structure like (defstruct (ri ...)) is type ri.
  35                ;; so we look for a formatter on the type or car of the type.
  36                ;; OR
  37                ;; if car of the type is also not a symbol, we look for formatter on nil
  38                ;; where it isn't.
  39                ;; depending on the lisp, type-of may be more or less sophisticated.
  40                ;; a "good" lisp
  41                ;;  may return a list, e.g. (type-of "abc") is (simple-array character (3))
  42                ;; in some lisps, e.g. GCL the type is just  string.
  43
  44                ((and (setf p(type-of form))
  45                      (if (not (symbolp p)) (setf p (car p)) p)
  46                      (setf p (get (and (symbolp p) p) 'formatter))
  47                      ;; form is an atom of a type with a formatter property
  48                      (funcall p form)))
  49                ;; just display as a lisp symbol, number, or other atom.
  50                (t form)))
  51         ((atom (car form))  form) ;; probably an illegal form; just return it.
  52
  53     ;; Process FORM if it is simplified or has some other operator flag (e.g., TRUNC)
  54     ;; (ignoring line number annotations). Otherwise, return FORM unchanged.
  55     ((let ((foo (cdar form)))
  56        (or (null foo) ;; no CAR flags at all
  57            ;; only item in CAR is line number annotation
  58            ;; (is it worth the trouble to find a faster way to test that?)
  59            (and (eql (length foo) 1) (let ((bar (first foo))) (and (consp bar) (equal (last bar) '(src)))))))
  60      form)
  61
  62         ;; this next section is for the ordinary maxima objects that are tagged by
  63         ;; their main operator or CAAR,  e.g. ((mplus) a b) has CAAR mplus ...
  64         ((and (symbolp (caar form)) (setf p (get (caar form) 'formatter))) ;; find the formatter.  If there is one, call it.
  65          (funcall p form))
  66         (t form)))                      ; if there is no formatter. Just return form unchanged.
  67
  68
  69 (defun form-mplus (form &aux args trunc simplified)
  70   (setq args (mapcar #'nformat (cdr form)))
  71   (setq trunc (member 'trunc (cdar form) :test #'eq))
  72   (setq simplified (member 'simp (cdar form) :test #'eq))
  73   (cons (if trunc '(mplus trunc) '(mplus))
  74         (cond ((and (member 'ratsimp (cdar form) :test #'eq)
  75                     (not (member 'simp (cdar form) :test #'eq)))
  76                (if $powerdisp (nreverse args) args))
  77               ((and trunc (not (member 'simp (cdar form) :test #'eq))) (nreverse args))
  78               ((or $powerdisp trunc (member 'cf (cdar form) :test #'eq)) args)
  79               ((and $negsumdispflag (null (cdddr form)))
  80                (if (and (not (mmminusp (car args)))
  81                         (mmminusp (cadr args)))
  82                    args
  83                    (if simplified (nreverse args) args)))
  84               (t (if simplified (nreverse args) args)))))
  85
  86 (defun form-mtimes (form)
  87   (cond ((null (cdr form)) '((mtimes)))
  88         ((equal -1 (cadr form)) (list '(mminus) (form-mtimes (cdr form))))
  89         (t (prog (num den minus flag)
  90               (do ((l (cdr form) (cdr l)) (dummy)) ((null l))
  91                 (setq dummy (nformat (car l)))
  92                 (cond ((atom dummy) (setq num (cons dummy num)))
  93                       ((eq 'mminus (caar dummy))
  94                        (setq minus (not minus) l (append dummy (cdr l))))
  95                       ((or (eq 'mquotient (caar dummy))
  96                            (and (not $pfeformat) (eq 'rat (caar dummy))))
  97                        (cond ((not (equal 1 (cadr dummy)))
  98                               (setq num (cons (cadr dummy) num))))
  99                        (setq den (cons (caddr dummy) den)))
 100                       (t (setq num (cons dummy num)))))
 101               (setq num (cond ((null num) 1)
 102                               ((null (cdr num)) (car num))
 103                               (t (cons '(mtimes) (nreverse num))))
 104                     den (cond ((null den) (setq flag t) nil)
 105                               ((null (cdr den)) (car den))
 106                               (t (cons '(mtimes) (nreverse den)))))
 107               (if (not flag) (setq num (list '(mquotient) num den)))
 108               (return (if minus (list '(mminus) num) num))))))
 109
 110 (defun form-mexpt (form &aux exp)
 111   (cond ((and $sqrtdispflag (alike1 1//2 (caddr form))) (list '(%sqrt) (cadr form)))
 112         ((and $sqrtdispflag (alike1 -1//2 (caddr form)))
 113          (list '(mquotient) 1 (list '(%sqrt) (cadr form))))
 114         ((and (or (and $%edispflag (eq '$%e (cadr form)))
 115                   (and $exptdispflag (not (eq '$%e (cadr form)))))
 116               (not (atom (setq exp (nformat (caddr form)))))
 117               (eq 'mminus (caar exp)))
 118          (list '(mquotient) 1 (if (equal 1 (cadr exp)) (cadr form)
 119                                   (list '(mexpt) (cadr form) (cadr exp)))))
 120         (t (cons '(mexpt) (cdr form)))))
 121
 122 (defun form-mrat (form)
 123   (let ((trunc (member 'trunc (cdar form) :test #'eq)) exact)
 124     (if (and trunc (eq (cadr form) 'ps))
 125         (setq exact (null (car (cadddr form)))))
 126     (setq form (ratdisrepd form))
 127     (rdis1 form)
 128     (if (and trunc (or (atom form)
 129                        ;; A constant, e.g. ((mplus) $a 1)
 130                        (not (member (car form) '((mplus exact) (mplus trunc)) :test #'equal))))
 131         (cons (if exact '(mplus exact) '(mplus trunc)) (ncons form))
 132         (nformat form))))
 133
 134 (defun rdis1 (form)
 135   (cond ((or (atom form) (specrepp form)))
 136         ((null (cdar form)) (rplaca form (list (caar form) 'ratsimp)))
 137         (t (mapc #'rdis1 (cdr form)))))
 138
 139 ;;(DEFMFUN NFORMAT-ALL (FORM)
 140 ;;  (SETQ FORM (NFORMAT FORM))
 141 ;;  (IF (OR (ATOM FORM) (EQ (CAAR FORM) 'BIGFLOAT))
 142 ;;      FORM
 143 ;;      (CONS (DELSIMP (CAR FORM)) (MAPCAR #'NFORMAT-ALL (CDR FORM)))))
 144 ;;Update from F302
 145 ;; used only in comm.lisp substitute, mpart.
 146 (defun nformat-all (form)
 147   (setq form (nformat form))
 148   (if (or (atom form) (eq (caar form) 'bigfloat))
 149       form
 150       (cons (delsimp (car form))
 151             (if (member (caar form) '(mdo mdoin) :test #'eq)
 152                 (mapcar #'(lambda (u) (if u (nformat-all u))) (cdr form))
 153                 (mapcar #'nformat-all (cdr form))))))
 154
 155
 156 ;;; we should define all the formatters in the file after the helper functions like  form-mplus
 157
 158 (setf (get 'rat 'formatter)
 159   #'(lambda(form)(cond ((minusp (cadr form))
 160                         (list '(mminus) (list '(rat) (- (cadr form)) (caddr form))))
 161                        (t (cons '(rat) (cdr form))))))
 162
 163 (setf (get 'mmacroexpanded 'formatter)
 164   #'(lambda(form)(nformat (caddr form))))
 165
 166 (setf (get 'mplus 'formatter)  #'form-mplus)
 167 (setf (get 'mtimes 'formatter)  #'form-mtimes)
 168 (setf (get 'mexpt 'formatter)  #'form-mexpt)
 169 (setf (get 'mrat 'formatter)  #'form-mrat)
 170 (setf (get 'mpois 'formatter)  #'(lambda(form)(nformat ($outofpois form))))
 171
 172 (setf (get 'bigfloat 'formatter)
 173   #'(lambda(form)
 174          (if (minusp (cadr form))
 175              (list '(mminus) (list (car form) (- (cadr form)) (caddr form)))
 176            (cons (car form) (cdr form)))))
 177
 178 (setf (get 'ratio 'formatter)  ;; in case a common lisp ratio is returned somehow.
 179   #'(lambda (form)
 180       (cond ((minusp form)
 181                 (list '(mminus) (list '(rat) (- (numerator form)) (denominator form))))
 182             (t (list '(rat) (numerator form)(denominator form))))))
 183
 184 (setf (get 'complex 'formatter)  ;; in case a common lisp complex number is returned somehow.
 185   #'(lambda(form)
 186           (if (complexp form)
 187             (nformat `((mplus) ,(realpart form)
 188                      ((mtimes) ,(imagpart form) $%i)))
 189             ;; some random form with caar COMPLEX
 190             ;;not really a CL complex
 191             form)))
 192 #+gcl(setf (get 'si::complex* 'formatter) (get 'complex 'formatter))
 193
 194 ;; something I added for fun
 195 ;; (defstruct (ri (:constructor $interval (lo hi) ))lo hi)
 196 ;; (setf (get 'ri 'formatter) ;; in case a structure of type ri  [real interval] is computed
 197 ;;   #'(lambda(r) (list '($interval simp) (ri-lo r)(ri-hi r)))) ;; this prints it.
 198
 199 ;;  so in maxima, we can construct ri structures by typing interval(1,2)
 200 ;; and if we display it,  it  appear as  interval(1,2).
 201 ;; but ?print(interval(1,2))  shows the lisp value which is the structure,
 202 ;; #s(ri :lo 1 :hi 2).
 203
 204 ;; we could set up formatters for , say,  (simple-array single-float <dimensions>)
 205 ;; or share the burden with display program .
 206