share/contrib/format/format.lisp

   1 ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: CLIMAX; Base: 10 -*-
   2 ;;;>******************************************************************************************
   3 ;;;>   Software developed by Bruce R. Miller (miller@cam.nist.gov)
   4 ;;;>   using Symbolics Common Lisp (system 425.111, ivory revision 4)
   5 ;;;>   at NIST - Computing and Applied Mathematics Laboratory
   6 ;;;>   a part of the U.S. Government; it is therefore not subject to copyright.
   7 ;;;>******************************************************************************************
   8 ;;;;******************************************************************************************
   9 ;;;; FORMAT: Package for restructuring expressions in Macsyma
  10 ;;;;******************************************************************************************
  11
  12 (in-package :maxima)
  13
  14 (defun mrelationp (expr)
  15   (and (listp expr)
  16        (member (caar expr) '(mequal mnotequal mgreaterp mlessp mgeqp mleqp))))
  17
  18 ;;;;******************************************************************************************
  19 ;;; format(expr,template,...)
  20 ;;; Formats EXPR according to the TEMPLATEs given:
  21
  22 (defvar *template* nil "The current template")
  23 (defvar *templates* nil "The current template chain")
  24 (defvar *subtemplates* nil "Current template's subtemplates")
  25
  26 (defun $format (expr &rest templates) (format-from-chain expr templates))
  27
  28 ;; format according to chain in *templates*
  29 (defun format-from-chain (expr &optional (*templates* *templates*))
  30   (if (null *templates*) expr
  31       (format-one expr (pop *templates*))))
  32
  33 ;; format according to tmp, then pieces according to *templates*
  34 (defun format-one (expr tmp)
  35   (multiple-value-bind (*template* formatter parms *subtemplates*)(parse-template tmp)
  36     (cond (formatter (apply #'mfuncall formatter expr parms))
  37           ((or (symbolp tmp)                    ; Apply SPEC as function, if it CAN be
  38                (and (listp tmp)(or (eq (caar tmp) 'lambda)(member 'array (cdar tmp)))))
  39            (format-from-chain (let ((*templates* nil)) (mfuncall tmp expr))))
  40           (t (merror "FORMAT: template ~M must be a template or function." tmp)))))
  41
  42 ;;; Format a `piece' of an expression, accounting for any current subtemplates.
  43 ;;; If NTH is given, use NTH subtemplate for this piece, else use next subtemplate.
  44 ;;; Account for %DITTO'd templates.
  45 (defun $format_piece (piece &optional nth)
  46   (flet ((dittop (ptrn)                         ; If %ditto form, return repeated template
  47            (and (listp ptrn)(eq (caar ptrn) '$%ditto) (cadr ptrn))))
  48     (let ((subtmp (cond ((null *subtemplates*) nil)     ; no piecewise templates.
  49                         ((null nth)(or (dittop (car *subtemplates*))    ; next one %ditto's
  50                                        (pop *subtemplates*)))   ; otherwise, remove next one.
  51                         ((setq nth (nth (1- nth) *subtemplates*))       ; nth subtemplate?
  52                          (or (dittop nth) nth)) ; strip off possible %ditto
  53                         ((dittop (car (last *subtemplates*)))))))       ; last dittos, reuse it
  54       (if subtmp (format-one piece subtmp)(format-from-chain piece)))))
  55
  56 ;; Format expr according to remaining chain, but disallowing subtemplates.
  57 (defun format-w/o-subtemplates (expr)
  58   (when *subtemplates*
  59     (merror "FORMAT: Template ~M was given subtemplates ~M" *template*
  60             (mlist* *subtemplates*)))
  61   (format-from-chain expr))
  62
  63 ;;; given a candidate format template, return:
  64 ;;; template name, formatter function, parameters (if any) and subtemplates (if any),
  65 (defun parse-template (template)
  66   (let (op name formatter)
  67     (flet ((getform (symbol)
  68              (and (setq formatter (or ($get symbol '$formatter)(get symbol 'share-formatter)))
  69                   (setq name symbol))))
  70       (cond (($numberp template) nil)
  71             ((atom template) (values (getform template) formatter nil nil))
  72             ((eq (caar template) 'mqapply)      ; Template w/ subtemplates AND parms
  73              (when (and (listp (setq op (cadr template)))
  74                         (getform (caar op))
  75                         (not (member 'array (cdar op))))        ; but not T[...][...]
  76                (values name formatter (cdr op) (cddr template))))
  77             ((getform (caar template))          ; Template w/ parameters OR subtemplates
  78              (if (member 'array (cdar template))
  79                  (values name formatter nil (cdr template))
  80                  (values name formatter (cdr template) nil)))))))
  81
  82 ;;;;******************************************************************************************
  83 ;;; Defining format commands.
  84 ;;; (user defined ones go on the macsyma property list)
  85
  86 (defmacro def-formatter (names parms &body body)
  87   (let* ((names (if (listp names) names (list names)))
  88          (fmtr (if (atom parms) parms
  89                    (make-symbol (concatenate 'string (string (car names))
  90                                              (symbol-name '#:-share-formatter))))))
  91     `(progn
  92        ,(unless (atom parms) `(defun ,fmtr ,parms ,@body))
  93        ,@(mapcar #'(lambda (name) `(setf (get ',name 'share-formatter) ',fmtr)) names))))
  94
  95 ;;;;******************************************************************************************
  96 ;;; Subtemplate aids.
  97
  98 (def-formatter mlist (expr &rest elements)      ; merge elements w/ following chain.
  99   (format-from-chain expr (append elements *templates*)))
 100
 101 (def-formatter $%preformat (expr &rest templates)       ; preformat using template chain
 102   (format-w/o-subtemplates (format-from-chain expr templates)))
 103
 104 (def-formatter $%noop format-w/o-subtemplates)  ; subtemplate filler.
 105
 106 ;;;;******************************************************************************************
 107 ;;; Arithmetic template: eg.  a*%p(x)-b
 108
 109 (defun template-p (expr)                        ; is there a template in expr?
 110   (if (and (listp expr)(member (caar expr) '(mplus mtimes mexpt)))
 111       (some #'template-p (cdr expr))            ; for arithmetic, find a `real' format in args
 112       (parse-template expr)))
 113
 114 (defun partition-arithmetic-template (op args)
 115   ;; Find the 1 (!) term or factor with a regular template in it.
 116   (let ((pat (remove-if-not #'template-p args)))        ; find arg with template in it
 117     (when (or (null pat)(cdr pat))
 118       (merror "FORMAT: Pattern must contain exactly 1 template ~M" (cons (list op) args)))
 119     (values (car pat) (simplify (cons (list op) (remove (car pat) args))))))
 120
 121 (def-formatter mplus (expr &rest terms)
 122   (multiple-value-bind (template rest)(partition-arithmetic-template 'mplus terms)
 123     (add (format-one (sub expr rest) template) rest)))
 124
 125 (def-formatter mtimes (expr &rest factors)
 126   (multiple-value-bind (template rest)(partition-arithmetic-template 'mtimes factors)
 127     (mul (format-one (div expr rest) template) rest)))
 128
 129 (def-formatter mexpt (expr b p)                 ; b^p
 130   (cond ((template-p b)(power (format-one (power expr (inv p)) b) p))
 131         ((template-p p)(power b (format-one (div ($log expr)($log b)) p)))
 132         ((merror "FORMAT: Pattern must contain exactly 1 template ~M" (power b p)))))
 133
 134 ;;;;******************************************************************************************
 135 ;;; Control templates
 136
 137 ;;; IF ... ELSEIF ... ELSE
 138 (def-formatter $%if (expr &rest predicates)
 139   ($format_piece expr (do ((ps predicates (cdr ps))
 140                            (i 1 (1+ i)))
 141                           ((or (null ps)(is-boole-check (mfuncall (car ps) expr))) i))))
 142
 143 (def-formatter ($%expr $%expression)(expr)      ; format arguments/operands
 144   (when ($atom expr)
 145     (merror "FORMAT %EXPR: ~M doesn't have parts" expr))
 146   (map1 #'$format_piece expr))
 147
 148 ;;; Convenience templates
 149 (def-formatter $%subst (expr &rest listofeqns)
 150   (format-w/o-subtemplates ($substitute (mlist* listofeqns) expr)))
 151
 152 (def-formatter $%ratsubst (expr &rest listofeqns)
 153   (format-w/o-subtemplates (mfuncall '$lratsubst (mlist* listofeqns) expr)))
 154
 155 ;;;;******************************************************************************************
 156 ;;; `Bag' & Relation templates.
 157
 158 ;;; This function tries to get OPER at the top level of EXPR.
 159 ;;; OPER must be a BAG or RELATION, as must the top layers of EXPR
 160 ;;; (down to wherever OPER is found).
 161 ;;; The interpretation is that a list of equations is equivalent to an equation
 162 ;;; whose rhs & lhs are lists.  (and ditto for all permutations).
 163 (defun $coerce_bag (oper expr)
 164   (unless (or (mbagp expr)(mrelationp expr))
 165     (merror "Error: ~M is not a relation, list or array: can't be made into an ~M" expr oper))
 166   (setq oper (getopr oper))
 167   (flet ((swap (op x)
 168            (cons (list op)
 169                  (mapcar #'(lambda (l)(simplify (cons (car x) l)))
 170                          (transpose (mapcar #'(lambda (y)(cdr ($coerce_bag op y)))(cdr x)))))))
 171     (cond ((eq (caar expr) oper) expr)          ; oper is already at top level.
 172           ((eq (caar expr) '$matrix)            ; swap levels 2 & 3 (mlist & oper), then 1&2
 173            (swap oper (map1 #'(lambda (x)(swap oper x)) expr)))
 174           ((eq oper '$matrix)                   ; swap level 1 & 2 (oper & matrix), then 2 & 3.
 175            (map1 #'(lambda (l)(swap 'mlist l))(swap oper expr)))
 176           (t (swap oper expr)))))               ; swap 1st & 2nd levels.
 177
 178 (defun format-bag (expr op)
 179   (map1 #'$format_piece ($coerce_bag op expr)))
 180
 181 (def-formatter ($%eq $%equation $%rel $%relation) (r &optional (op 'mequal))
 182   (format-bag r op))
 183 (def-formatter $%list (expr)  (format-bag expr 'mlist))
 184 (def-formatter $%matrix (expr)(format-bag expr '$matrix))
 185 ;;; Note: %matrix subtemplates apply to ROWS. To target elements, use %list for rows.
 186
 187 ;;;;******************************************************************************************
 188 ;;; Targeting templates.
 189 ;;; mostly shorthand for things which can be done using subtemplates, but more concise.
 190
 191 (defun format-nth (expr n)
 192   (unless (and ($integerp n) (plusp n)(< n (length expr)))
 193     (merror "FORMAT ~M: ~M doesn't have an argument #~M" *template* expr n))
 194   (let ((new (copy-list expr)))
 195     (setf (nth n new)(format-w/o-subtemplates (nth n expr)))
 196     (simplify new)))
 197
 198 (def-formatter $%arg format-nth)
 199 (def-formatter $%lhs (expr &optional (op 'mequal))
 200   (format-nth ($coerce_bag op expr) 1))
 201 (def-formatter $%rhs (expr &optional (op 'mequal))
 202   (format-nth ($coerce_bag op expr) 2))
 203
 204 (def-formatter ($%el $%element)(expr &rest indices)
 205   (let ((array ($copymatrix ($coerce_bag '$matrix expr))))
 206     (apply #'marrayset ($format_piece (apply #'marrayref array indices)) array indices)
 207     array))
 208
 209 (def-formatter $%num (frac)
 210   (div (format-w/o-subtemplates ($num frac))($denom frac)))
 211 (def-formatter $%denom (frac)
 212   (div ($num frac)(format-w/o-subtemplates ($denom frac))))
 213
 214 (def-formatter $%match (expr predicate)
 215   (labels ((rec (xpr)
 216              (cond ((is-boole-check (mfuncall predicate xpr))(format-w/o-subtemplates xpr))
 217                    ((atom xpr) xpr)
 218                    (t (recur-apply #'rec xpr)))))
 219     (rec expr)))
 220
 221 ;; Actually, more like bothcoeff
 222 (def-formatter $%coeff (expr var &optional (n 1))
 223   (when (and (listp var)(eq (caar var) 'mexpt))
 224     (setq var (cadr var) n (mul n (caddr var))))
 225   (let ((coefs ($coeffs expr var)))
 226     (add (mul ($format_piece ($get_coef coefs n)) (power (car (cddadr coefs)) n))
 227          ($format_piece ($uncoef (delete n coefs :test #'alike1 :key #'caddr))))))
 228
 229 ;;;;******************************************************************************************
 230 ;;; Polynomial, Trig & Series templates.
 231
 232 (defun format-clist (clist &optional (function #'$format_piece))
 233   (flet ((mp1 (l)(mapcar #'(lambda (p)(mlist* (funcall function (cadr p)) (cddr p))) l)))
 234     ($uncoef (mlist* (cadr clist)
 235                      (case (cadadr clist)
 236                        (($%poly $%series $%taylor) (mp1 (cddr clist)))
 237                        ($%trig (mapcar #'(lambda (l)(mlist* (mp1 (cdr l))))(cddr clist))))))))
 238
 239 ;; %POLY(vars,...) : express EXPR as a polynomial in VARS, format the coeffs.
 240 (def-formatter ($%poly $%p) (expr &rest vars)
 241   (autoldchk '$coeffs)
 242   (format-clist (apply #'$coeffs expr vars)))
 243
 244 ;; %MONICPOLY : format leading coeff, then poly/lc.
 245 (def-formatter ($%monicpoly $%mp) (expr &rest vars)
 246   (autoldchk '$coeffs)
 247   (let* ((cl (apply #'$coeffs expr vars))
 248          (c0 (cadar (last cl))))
 249     (mul ($format_piece c0)(format-clist cl #'(lambda (c)($format_piece (div c c0)))))))
 250
 251 ;; %TRIG(vars,...): express EXPR as trig. series in VARS, format the coeffs.
 252 (def-formatter ($%trig $%t) (expr &rest vars)
 253   (autoldchk '$trig_coeffs)
 254   (format-clist (apply #'$trig_coeffs expr vars)))
 255
 256 ;; %SERIES(var,order), %TAYLOR(var,order): expand EXPR as series in VAR to order ORDER,
 257 ;; formats the coeffs.  %SERIES only expands arithmetic expressions.
 258 (def-formatter ($%series $%s) (expr var order)
 259   (autoldchk '$series_coeffs)
 260   (format-clist ($series_coeffs expr var order)))
 261
 262 (def-formatter $%taylor (expr var order)
 263   (autoldchk '$taylor_coeffs)
 264   (format-clist ($taylor_coeffs expr var order)))
 265
 266 ;;;;******************************************************************************************
 267 ;;; Sums
 268
 269 (defun format-sum (sum)
 270   (cond ((atom sum)($format_piece sum))
 271         ((specrepp sum) (format-sum (specdisrep sum)))
 272         ((eq (caar sum) 'mplus)(simplify (map1 #'format-sum sum)))
 273         ((eq (caar sum) '%sum) (cons (car sum) (cons ($format_piece (cadr sum))(cddr sum))))
 274         (t ($format_piece sum))))
 275
 276 (def-formatter $%sum format-sum)
 277 (def-formatter ($%partfrac $%pf)(expr var)
 278   (format-sum ($partfrac expr var)))
 279
 280 ;;;;******************************************************************************************
 281 ;;; Products
 282
 283 (defun format-product (prod)
 284   (cond ((atom prod) ($format_piece prod))
 285         ((specrepp prod) (format-product (specdisrep prod)))
 286         (t (case (caar prod)
 287              (mtimes (simplify (map1 #'format-product prod)))
 288              (mexpt (power (format-product (second prod))(third prod)))
 289              (%product (cons (car prod)(cons ($format_piece (cadr prod))(cddr prod))))
 290              (t ($format_piece prod))))))
 291
 292 (def-formatter ($%product $%prod) format-product)
 293 (def-formatter ($%sqfr $%sf)(expr)
 294   (format-product ($sqfr expr)))
 295 (def-formatter ($%factor $%f) (expr &optional minpoly)
 296   (format-product (cond (($numberp expr) expr)
 297                         (minpoly ($factor expr minpoly))
 298                         (t ($factor expr)))))
 299
 300 ;;;;******************************************************************************************
 301 ;;; Fractions
 302
 303 (defun format-fraction (frac)
 304   (div ($format_piece ($num frac))
 305        ($format_piece ($denom frac))))
 306
 307 (def-formatter $%frac format-fraction)
 308 (def-formatter ($%ratsimp $%r) (expr)
 309   (format-fraction ($ratsimp expr)))
 310
 311 ;;;;******************************************************************************************
 312 ;;; Complex number templates.
 313
 314 ;; Express EXPR = A+%I*B; format A & B.
 315 (def-formatter ($%rectform $%g) (expr)
 316   (let ((pair (trisplit expr)))
 317     (add ($format_piece (car pair))
 318          (mul ($format_piece (cdr pair)) '$%i))))
 319
 320 ;; Express EXPR = R*exp(%I*P); format R & P.
 321 (def-formatter $%polarform (expr)
 322   (let ((pair (absarg expr)))
 323     (mul ($format_piece (car pair))
 324          (power '$%e (mul '$%i ($format_piece (cdr pair)))))))
 325
 326 ;;;********************************************************************************
 327 ;;; Examples of user defined templates:
 328 ;;; format_piece automatically handles the piecewise templates & remaining templates.
 329 #||
 330 put(%myrectform,
 331      lambda([expr],
 332        block([pair:rectformlist(expr)],
 333           format_piece(pair[1]) +%I* format_piece(pair[2]))),
 334      formatter)$
 335
 336 put(%myif,
 337      lambda([expr,test],
 338         if test(expr) then format_piece(expr,1)
 339         else               format_piece(expr,2)),
 340      formatter)$
 341
 342 put(%part, /* Note workaround for substpart (a special form!) */
 343      lambda([expr,[spec]],
 344        apply(substpart,cons(format_piece(apply(part,cons(expr,spec))),cons(expr,spec)))),
 345     formatter)$
 346 ||#