src/displa.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;     The data in this file contains enhancements.                   ;;;;;
   3 ;;;                                                                    ;;;;;
   4 ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
   5 ;;;     All rights reserved                                            ;;;;;
   6 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   7 ;;;     (c) Copyright 1982 Massachusetts Institute of Technology         ;;;
   8 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9
  10 (in-package :maxima)
  11
  12 (macsyma-module displa)
  13
  14 ;; N.B. You must read the macro file before reading this file.
  15
  16 (load-macsyma-macros displm)
  17
  18 (defmvar $stardisp nil
  19   "Causes factors of products to be separated by * when displayed.")
  20
  21 (defmvar $leftjust nil
  22   "Causes equations to be drawn left justified rather than centered.
  23          For slow consoles.")
  24
  25 (defmvar $noundisp nil "Causes nouns to be displayed with a single quote")
  26
  27 (defmvar displayp nil "Is T when inside of `displa'")
  28
  29 ;; Parameters which control how boxes, absolute value signs,
  30 ;; evaluation-at-a-point bars, and matrices are drawn.
  31
  32 (defmvar $boxchar "\""  "Character used for drawing boxes.")
  33 (defmvar $absboxchar "|"
  34   "Character used for drawing absolute value signs and 'evaluation at' signs.")
  35 (defmvar $lmxchar "["  "Character used for drawing the left edge of a matrix.")
  36 (defmvar $rmxchar "]"  "Character used for drawing the right edge of a matrix.")
  37
  38 (defvar linearray (make-array 80. :initial-element nil))
  39
  40 (defun maxima-display (form &key (stream *standard-output*) )
  41   (let ((*standard-output* stream))
  42     (displa form)))
  43
  44 (defvar *alt-display2d* nil)
  45 (defvar *alt-display1d* nil)
  46
  47 (defun displa (form)
  48   (if (not $ttyoff)
  49       (cond ($display2d
  50              (cond (*alt-display2d* (apply *alt-display2d* form ()))
  51                    (t
  52                     (let ((displayp t)
  53                           (linearray (if displayp
  54                                          (make-array 80. :initial-element nil)
  55                                          linearray))
  56                           (mratp (checkrat form))
  57                           (maxht     1) (maxdp   0) (width   0)
  58                           (height    0) (depth   0) (level   0) (size   2)
  59                           (break     0) (right   0) (lines   1) bkpt
  60                           (bkptwd    0) (bkptht  1) (bkptdp  0) (bkptout 0)
  61                           (bkptlevel 0) in-p)
  62                       (unwind-protect
  63                            (progn
  64                              (setq form (dimension form nil 'mparen 'mparen 0 0))
  65                              (checkbreak form width)
  66                              (output form (if (and (not $leftjust) (= 2 lines))
  67                                               (- $linel (- width bkptout))
  68                                               0)))
  69                         ;; make sure the linearray gets cleared out.
  70                         (fill linearray nil))))))
  71             (t
  72              (if *alt-display1d*
  73                  (apply *alt-display1d* form ())
  74                  (linear-displa form))))))
  75
  76 (defmspec $with_default_2d_display (expr)
  77   (let ((*alt-display2d* nil)
  78         ($display2d t)
  79         (mexpr (cons '(mprog) (cdr expr))))
  80     (meval mexpr)))
  81
  82 ;;; (LINEAR-DISPLA <thing-to-display>)
  83 ;;;
  84 ;;; Display text linearly. This function should be usable in any case
  85 ;;;  DISPLA is usable and will attempt to do something reasonable with
  86 ;;;  its input.
  87
  88 (defun linear-displa (form)
  89   (fresh-line *standard-output*)
  90   (mgrind form *standard-output*)
  91   (mterpri))
  92
  93 (defmvar $display_format_internal nil
  94   "Setting this TRUE can help give the user a greater understanding
  95          of the behavior of maxima on certain of his problems,
  96          especially those involving roots and quotients")
  97
  98 (defun nformat-check (form)
  99   (if (and $display_format_internal
 100            (not (or (atom form) (atom (car form)) (specrepp form))))
 101       form
 102       (nformat form)))
 103
 104 (defun dimension (form result lop rop w right)
 105   (let ((level (1+ level))
 106         (break (if (and w break) (+ w break))))
 107     (setq form (nformat-check form))
 108     (cond ((atom form)
 109            (dimension-atom form result))
 110           ((and (atom (car form)) (setq form (cons '(mprogn) form)) nil))
 111           ((or (<= (lbp (caar form)) (rbp lop)) (>= (lbp rop) (rbp (caar form))))
 112            (dimension-paren form result))
 113           ((member 'array (car form) :test #'eq) (dimension-array form result))
 114           ((safe-get (caar form) 'dimension)
 115            (funcall (get (caar form) 'dimension) form result))
 116           (t (dimension-function form result)))))
 117
 118 (defvar atom-context 'dimension-list)
 119 ;; bound by DIMENSION-ARRAY and DIMENSION-FUNCTION.
 120 ;; This ATOM-CONTEXT put in by GJC so that MCW could have a clean
 121 ;; hook by which to write his extensions for vector-underbars.
 122
 123 ;; Referenced externally by RAT;FLOAT.
 124
 125 (defun dimension-atom (form result)
 126   (cond ((and (symbolp form) (get form atom-context))
 127          (funcall (get form atom-context) form result))
 128         ((stringp form) (dimension-string (makestring form) result))
 129         ((member (marray-type form) '(array hash-table $functional))
 130          (dimension-array-object form result))
 131         (t (dimension-string (makestring form) result))))
 132
 133 ;; Referenced externally by anyone who wants to display something as
 134 ;; a funny looking atom, e.g. Trace, Mformat.
 135
 136 (defun dimension-string (dummy result &aux crp)
 137   (setq width 0 height 1 depth 0)
 138   (do ((l dummy (cdr l)))
 139       ((null l))
 140     (incf width)
 141     (if (char= (car l) #\newline) (setq crp t)))
 142   (cond ((or (and (checkfit width) (not crp)) (not break))
 143          (nreconc dummy result))
 144         (t (setq width 0)
 145            (do ((l dummy) (w (- $linel (- break bkptout))))
 146                ((null l) (checkbreak result width) result)
 147              (setq dummy l l (cdr l))
 148              (cond ((char= (car dummy) #\newline)
 149                     (if result (forcebreak result width) (forcebreak (list #\space) width))
 150                     (setq result nil w (+ $linel width)))
 151                    (t (incf width)
 152                       (when (and (= w width) l)
 153                         (forcebreak (cons #\\ result) width)
 154                         (setq result nil w (+ $linel width))
 155                         (incf width))
 156                       (setq result (rplacd dummy result))))))))
 157
 158 (defun makestring (atom)
 159   (let (dummy)
 160     (cond ((numberp atom) (exploden atom))
 161           ((stringp atom)
 162            (setq dummy (coerce atom 'list))
 163            (if $stringdisp
 164                (cons #\" (nconc dummy (list #\")))
 165                dummy))
 166           ((not (symbolp atom)) (exploden atom))
 167           ((and (setq dummy (get atom 'reversealias))
 168                 (not (and (member atom $aliases :test #'eq) (get atom 'noun))))
 169            (exploden (stripdollar dummy)))
 170           ((not (eq (getop atom) atom))
 171            (makestring (getop atom)))
 172           (t (setq dummy (exploden atom))
 173              (cond
 174                ((null dummy) nil)
 175                ((char= #\$ (car dummy)) (cdr dummy))
 176                ((char= #\% (car dummy)) (cdr dummy))
 177                ($lispdisp (cons #\? dummy))
 178                (t dummy))))))
 179
 180 (defun dimension-paren (form result)
 181   (setq result (cons #\) (dimension form (cons #\( result) 'mparen 'mparen 1 (1+ right))))
 182   (incf width 2)
 183   result)
 184
 185 (defun dimension-array (x result)
 186   (prog (dummy bas (w-base 0) (h-base 0) (d-base 0))
 187      (if (eq (caar x) 'mqapply)
 188      (setq dummy (cadr x) x (cdr x))
 189      (setq dummy (caar x)))
 190      (cond ((or (not $noundisp) (not (symbolp (caar x)))))
 191        ((and (get (caar x) 'verb) (get (caar x) 'alias))
 192         (push-string "''" result) (setq w-base 2))
 193        ((and (get (caar x) 'noun) (not (member (caar x) (cdr $aliases) :test #'eq))
 194          (not (get (caar x) 'reversealias)))
 195         (setq result (cons #\' result) w-base 1)))
 196      (setq
 197        bas (if (and (not (atom dummy)) (member 'array (car dummy) :test #'eq))
 198              (let ((break nil) (right 0)) (dimension-paren dummy nil))
 199              (let ((atom-context 'dimension-array))
 200                (dimension dummy nil lop 'mfunction nil 0)))
 201        w-base (+ w-base width)
 202        h-base height
 203        d-base depth)
 204      (multiple-value-bind (w00 w01 w10 w11 h00 h01 h10 h11 d00 d01 d10 d11 pre-subscripts-output pre-superscripts-output post-subscripts-output post-superscripts-output)
 205        (dimension-indices dummy (cdr x))
 206        (declare (special pre-subscripts pre-superscripts post-subscripts post-superscripts))
 207        (cond
 208          ((not (checkfit (setq width (+ w-base (max w00 w01) (max w10 w11))))) ;; ?? !!
 209           (return (dimension-function (cons '(subscript) (cons dummy (cdr x))) result)))
 210          ((and (atom (car bas)) (char= #\ (car bas))) ; Adding the test (atom (car bas))
 211           (setq result (cons (cons 0 (cons (- h-base) post-subscripts)) bas) depth (max (+ h-base d-base) depth))) ;; ?? !!
 212          (t
 213            (setq result
 214                  (append
 215                    (if (and (> w11 0) (> w10 w11)) (list (list (- w10 w11) 0)))
 216                    (remove-if #'(lambda (l) (= (length l) 2))
 217                               (list
 218                                 (append (list (- w10) (+ h-base d11)) post-superscripts-output)
 219                                 (append (list 0 (- h10)) post-subscripts-output)
 220                                 (append (list 0 0) bas)
 221                                 (append (list (if (> w00 0) (- w01) 0) (+ h-base d01)) pre-superscripts-output)
 222                                 (append (list (if (> w01 w00) (- w01 w00) 0) (- h00)) pre-subscripts-output)))
 223                    result)
 224                  height (+ h-base (max (+ d01 h01) (+ d11 h11)))
 225                  depth (+ d-base (max (+ d00 h00) (+ d10 h10))))))
 226        (update-heights height depth)
 227        (return result))))
 228
 229 (defun dimension-indices (base-symbol indices)
 230   (let
 231     ((display-indices (safe-mget base-symbol 'display-indices))
 232      (separator (let ((x (safe-$get base-symbol '$display_index_separator)))
 233                   (if (or (null x) (stringp x)) x (coerce (mstring x) 'string)))))
 234     (if (and (> (length display-indices) 0) (not (= (length display-indices) (length indices))))
 235       ;; Ignore DISPLAY-INDICES if it's nonempty and not the same size as INDICES.
 236       (setq display-indices nil))
 237     (let (pre-subscripts pre-superscripts post-subscripts post-superscripts)
 238       (declare (special pre-subscripts pre-superscripts post-subscripts post-superscripts))
 239       (if display-indices
 240         (setq pre-subscripts (extract-indices indices display-indices '$presubscript)
 241               pre-superscripts (extract-indices indices display-indices '$presuperscript)
 242               post-subscripts (extract-indices indices display-indices '$postsubscript)
 243               post-superscripts (extract-indices indices display-indices '$postsuperscript))
 244         (setq pre-subscripts nil
 245               pre-superscripts nil
 246               post-subscripts indices
 247               post-superscripts nil))
 248       (let (pre-subscripts-output pre-superscripts-output post-subscripts-output post-superscripts-output
 249             (w00 0) (w01 0) (w10 0) (w11 0) (h00 0) (h01 0) (h10 0) (h11 0) (d00 0) (d01 0) (d10 0) (d11 0))
 250         (if pre-subscripts
 251           (setq pre-subscripts-output
 252                 (let ((lop 'mparen) (rop 'mparen) (break nil) (size 1))
 253                   (dimension-list (cons '(mlist) pre-subscripts) nil separator))
 254                 w00 width
 255                 h00 height
 256                 d00 depth))
 257         (if pre-superscripts
 258           (setq pre-superscripts-output
 259                 (let ((lop 'mparen) (rop 'mparen) (break nil) (size 1))
 260                   (dimension-list (cons '(mlist) pre-superscripts) nil separator))
 261                 w01 width
 262                 h01 height
 263                 d01 depth))
 264         (if post-subscripts
 265           (setq post-subscripts-output
 266                 (let ((lop 'mparen) (rop 'mparen) (break nil) (size 1))
 267                   (dimension-list (cons '(mlist) post-subscripts) nil separator))
 268                 w10 width
 269                 h10 height
 270                 d10 depth))
 271         (if post-superscripts
 272           (setq post-superscripts-output
 273                 (let ((lop 'mparen) (rop 'mparen) (break nil) (size 1))
 274                   (dimension-list (cons '(mlist) post-superscripts) nil separator))
 275                 w11 width
 276                 h11 height
 277                 d11 depth))
 278         (values w00 w01 w10 w11 h00 h01 h10 h11 d00 d01 d10 d11 pre-subscripts-output pre-superscripts-output post-subscripts-output post-superscripts-output)))))
 279
 280 (defun extract-indices (indices display-indices index-flag)
 281   (remove nil
 282           (loop for i from 0 to (length display-indices)
 283                 collect (if (eq (nth i display-indices) index-flag) (nth i indices)))))
 284
 285 (defun safe-$get (x y)
 286   (and (symbolp x) ($get x y)))
 287
 288 (defun dimension-function (x result)
 289   (prog (fun (w 0) (h 0) (d 0))
 290      (cond ((or (not $noundisp) (not (symbolp (caar x)))))
 291            ((and (get (caar x) 'verb) (get (caar x) 'alias))
 292             (push-string "''" result) (setq w 2))
 293            ((and (get (caar x) 'noun) (not (member (caar x) (cdr $aliases) :test #'eq))
 294                  (not (get (caar x) 'reversealias)))
 295             (setq result (cons #\' result) w 1)))
 296      (if (eq (caar x) 'mqapply) (setq fun (cadr x) x (cdr x)) (setq fun (caar x)))
 297      (setq result (let ((atom-context 'dimension-function))
 298                     (dimension fun result lop 'mparen 0 1))
 299            w (+ w width) h height d depth)
 300      (cond ((null (cdr x))
 301             (setq result (list* #\) #\( result)
 302                   width (+ 2 w)))
 303            (t (setq result (let ((lop 'mparen)
 304                                  (rop 'mparen)
 305                                  (break (if break (+ 1 w break))))
 306                              (cons #\) (dimension-list x (cons #\( result))))
 307                     width (+ 2 w width) height (max h height) depth (max d depth))))
 308      (return result)))
 309
 310 (defun dimension-prefix (form result)
 311   (prog (dissym (symlength 0))
 312      (setq dissym (safe-get (caar form) 'dissym)
 313            symlength (length dissym))
 314      (setq result (dimension (cadr form) (revappend dissym result) (caar form) rop symlength right)
 315            width (+ symlength width))
 316      (return result)))
 317
 318 (defun dimension-list (form result &optional separator)
 319   (prog ((w 0) (h 0) (d 0))
 320      (setq result (dimension (cadr form) result lop 'mcomma 0 right)
 321            w width h height d depth)
 322      (do ((l (cddr form) (cdr l)))
 323          ((null l))
 324        (push-string (or separator ", ") result)
 325        (incf w (if separator (length separator) 2))
 326        (checkbreak result w)
 327        (setq result (dimension (car l) result 'mcomma 'mcomma w right)
 328              w (+ w width) h (max h height) d (max d depth)))
 329      (setq width w height h depth d)
 330      (return result)))
 331
 332 (defun dimension-infix (form result)
 333   (unless (= (length (cdr form)) 2)
 334     (return-from dimension-infix (dimension-function form result)))
 335   (prog (dissym (symlength 0) (w 0) (h 0) (d 0))
 336      (setq dissym (safe-get (caar form) 'dissym)
 337            symlength (length dissym)
 338            result (dimension (cadr form) result lop (caar form) 0 symlength)
 339            w width
 340            h height
 341            d depth)
 342      (setq result (revappend dissym result))
 343      (checkbreak result (+ symlength w))
 344      (setq result (dimension (caddr form) result (caar form) rop (+ symlength w) right)
 345            width (+ w symlength width)
 346            height (max h height)
 347            depth (max d depth))
 348      (return result)))
 349
 350 (defun dimension-nary (form result)
 351   ;; If only 0 or 1 arguments, then print "*"() or "*"(A)
 352   (cond ((null (cddr form))
 353          (dimension-function form result))
 354         (t
 355          (prog (dissym (symlength 0) (w 0) (h 0) (d 0) helper)
 356             (setq dissym (safe-get (caar form) 'dissym)
 357                   symlength (length dissym)
 358
 359           ;; Look for a helper function. Fall back on default if none found.
 360           helper (or (safe-get (caar form) 'dimension-nary-helper) 'dimnary)
 361
 362                   result (funcall helper (cadr form) result lop (caar form) (caar form) 0)
 363                   w width
 364                   h height
 365                   d depth
 366           )
 367             (do ((l (cddr form) (cdr l)))
 368                 (nil)
 369               (checkbreak result w)
 370               (setq result (revappend dissym result) w (+ symlength w))
 371               (cond ((null (cdr l))
 372                      (setq result (funcall helper (car l) result (caar form) (caar form) rop w)
 373                            width (+ w width)
 374                            height (max h height)
 375                            depth (max d depth))
 376                      (return t))
 377                     (t
 378                      (setq result (funcall helper (car l) result (caar form) (caar form) (caar form) w)
 379                            w (+ w width)
 380                            h (max h height)
 381                            d (max d depth)))))
 382             (return result)))))
 383
 384 ;; Output for MTEXT, generated for example by print(...).
 385 ;; Suppress parentheses which would be generated by DIMNARY.
 386
 387 (defun dimnary-mtext (form result lop op rop w)
 388   (declare (ignore op))
 389   (dimension form result lop rop w right))
 390
 391 ;; Output for general n-ary operators.
 392 ;; Heuristic: if some argument is displayed as an infix or n-ary operator,
 393 ;; then put parentheses around that argument (even if parentheses are not
 394 ;; necessary, according to operator precedence, to disambiguate the output).
 395 ;;
 396 ;; Examples:
 397 ;;
 398 ;; a * b * c;                   --> a b c
 399 ;; a . b . c;                   --> a . b . c
 400 ;; a * b . c;                   --> a (b . c)
 401 ;; (a * b) . c;                 --> (a b) . c
 402 ;; a . b * c;                   --> (a . b) c
 403 ;; a . (b * c);                 --> a . (b c)
 404 ;; a . b * c . d;               --> (a . b) (c . d)
 405 ;; a * b . c * d;               --> a (b . c) d
 406 ;; (a * b) . (c * d);           --> (a b) . (c d)
 407 ;; infix ("@@");
 408 ;; a @@ b * c @@ d;             --> (a @@ b) (c @@ d)
 409 ;; a @@ b . c @@ d;             --> (a @@ b) . (c @@ d)
 410 ;; a * b @@ c . d;              --> a ((b @@ c) . d)
 411 ;; (a * b) @@ (c . d);          --> (a b) @@ (c . d)
 412
 413 (defun dimnary (form result lop op rop w)
 414   (declare (ignore op))
 415   (if (and (consp form)
 416            (member (safe-get (caar form) 'dimension)
 417                    '(dimension-infix dimension-nary)))
 418       (progn
 419         (setq result
 420               (cons #\)
 421                     (dimension form
 422                                (cons #\( result)
 423                                'mparen 'mparen (if w (1+ w)) (1+ right))))
 424         (incf width 2)
 425         result)
 426       (dimension form result lop rop w right)))
 427
 428 ;; Output for Boolean n-ary operators.
 429 ;; Heuristic: if some argument is displayed as an infix or n-ary operator,
 430 ;; or the operator of the argument is MNOT, then put parentheses around that argument
 431 ;; (even if parentheses are not necessary, according to operator precedence,
 432 ;; to disambiguate the output).
 433 ;;
 434 ;; Examples:
 435 ;;
 436 ;; a and b and c;               --> a and b and c
 437 ;; a or b or c;                 --> a or b or c
 438 ;; a or b and c;                --> a or (b and c)
 439 ;; (a or b) and c;              --> (a or b) and c
 440 ;; a and b or c;                --> (a and b) or c
 441 ;; a and (b or c);              --> a and (b or c)
 442 ;; a and b or c and d;          --> (a and b) or (c and d)
 443 ;; a or b and c or d;           --> a or (b and c) or d
 444 ;; (a or b) and (c or d);       --> (a or b) and (c or d)
 445 ;; a < 0 and b < 0 or c < 0;    --> ((a < 0) and (b < 0)) or (c < 0)
 446 ;; a < 0 and not foo;           --> (a < 0) and (not foo)
 447 ;; a < 0 or not foo;            --> (a < 0) or (not foo)
 448 ;; infix ("=>");
 449 ;; a => b and a => c;           --> (a => b) and (a => c)
 450 ;; a => b or not b => c;        --> (a => b) or (not b => c)
 451 ;; a and b => c and d;          --> a and (b => c) and d
 452 ;; a or b => c and d;           --> a or ((b => c) and d)
 453 ;; (a and b) => (c and d);      --> (a and b) => (c and d)
 454 ;; if a and b then 1 else 0;    --> if a and b then 1 else 0
 455
 456 (defun dimnary-boolean (form result lop op rop w)
 457   (declare (ignore op))
 458   (if (and (consp form)
 459            (or (member (safe-get (caar form) 'dimension) '(dimension-infix dimension-nary))
 460                (eq (caar form) 'mnot)))
 461       (dimension-paren form result)
 462       (dimension form result lop rop w right)))
 463
 464 (defun dimension-postfix (form result)
 465   (prog (dissym (symlength 0))
 466      (setq dissym (safe-get (caar form) 'dissym)
 467            symlength (length dissym))
 468      (setq result (dimension (cadr form) result lop (caar form) 0 (+ symlength right))
 469            width (+ symlength width))
 470      (return (revappend dissym result))))
 471
 472 (defun dimension-nofix (form result)
 473   (setq form (safe-get (caar form) 'dissym)
 474         width (length form))
 475   (revappend form result))
 476
 477 (defun dimension-match (form result)
 478   (prog (dissym (symlength 0))
 479      (setq dissym (safe-get (caar form) 'dissym)
 480            symlength (length (car dissym)))
 481      (cond ((null (cdr form))
 482             (setq width (+ symlength (length (cdr dissym)))
 483                   height 1
 484                   depth 0)
 485             (return (revappend (cdr dissym) (revappend (car dissym) result))))
 486            (t (setq result (let ((lop 'mparen)
 487                                  (rop 'mparen)
 488                                  (break (if break (+ symlength break)))
 489                                  (right (+ symlength right)))
 490                              (dimension-list form (revappend (car dissym) result))))
 491               (setq width (+ (length (cdr dissym)) symlength width))
 492               (return (revappend (cdr dissym) result))))))
 493
 494 (defun dimension-superscript (form result)
 495   (prog (exp (w 0) (h 0) (d 0) bas)
 496      (setq exp (let ((size 1))
 497                  (dimension (caddr form) nil 'mparen 'mparen nil 0))
 498            w width
 499            h height
 500            d depth)
 501      (cond ((and (not (atom (cadr form))) (member 'array (cdaadr form) :test #'eq))
 502             (if (safe-mget (caaadr form) 'display-indices)
 503               (return (dimension-superscript `(,(first form) ((mprogn) ,(second form)) ,(third form)) result))
 504             (progn (prog (sub (w2 0) (h2 0) (d2 0))
 505                (setq sub (if (eq 'mqapply (caaadr form))
 506                              (cdadr form) (cadr form)))
 507                (setq sub (let ((lop 'mparen) (break nil) (size 1))
 508                            (dimension-list sub nil))
 509                      w2 width h2 height d2 depth)
 510                (setq bas (dimension (mop (cadr form)) result lop 'mexpt nil 0))
 511                (when (not (checkfit (+ width (max w w2))))
 512                  (setq result (dimension-function (cons '($expt) (cdr form)) result))
 513                  (return result))
 514                (setq result (cons (cons 0 (cons (+ height d) exp)) bas))
 515                (setq result (cons (cons (- w) (cons (- (+ depth h2)) sub)) result))
 516                (setq result (cons (list (- (max w w2) w2) 0) result)
 517                      width (+ width (max w w2)) height (+ h d height) depth (+ d2 h2 depth)))
 518             (update-heights height depth)
 519             (return result))))
 520            ((and (atom (caddr form))
 521                  (not (atom (cadr form)))
 522                  (not (safe-get (caaadr form) 'dimension))
 523                  (prog2 (setq bas (nformat-check (cadr form)))
 524                      (not (safe-get (caar bas) 'dimension))))
 525             (return (dimension-function
 526                      (list* '(mqapply) (list '(mexpt) (mop bas) (caddr form)) (margs bas))
 527                      result)))
 528            (t (setq bas (dimension (cadr form) result lop 'mexpt nil 0) width (+ w width))
 529               (if (not (checkfit width))
 530                   (return (dimension-function (cons '($expt) (cdr form)) result)))
 531               (if (eql #\) (car bas))
 532                   (setq result (cons (list* 0 (1+ d) exp) bas) height (max (+ 1 h d) height))
 533                   (setq result (cons (list* 0 (+ height d) exp) bas) height (+ h d height)))
 534               (update-heights height depth)
 535               (return result)))))
 536
 537 (defun dsumprod (form result d-form sw sh sd)
 538   (prog (str to dummy (w 0) (h 0) (d 0) dummy2 (lsum (eq (caar form) '%lsum)))
 539      (setq dummy2 (dimension (caddr form) nil 'mparen 'mequal nil 0)
 540            w width
 541            h height
 542            d depth)
 543      (if lsum
 544          (setq str " in " to "")
 545          (setq str " = "  to (cadr (cdddr form))))
 546      (push-string str dummy2)
 547      (setq dummy2 (dimension (cadddr form) dummy2 'mequal 'mparen nil 0)
 548            w (+ (length str) w width)
 549            h (max h height)
 550            d (max d depth))
 551      (setq dummy (dimension to nil 'mparen 'mparen nil 0))
 552      (unless (checkfit (max w width))
 553        (return (dimension-function form result)))
 554      (setq dummy2 (cons (cons (- sw) (cons (- (+ sd h)) dummy2)) (cons d-form result)))
 555      (cond ((> width sw)
 556             (setq sw 0))
 557            (t
 558             (setq sw (truncate (- sw width) 2)
 559                   width (+ sw width))))
 560      (setq dummy (cons (cons (- sw w) (cons (+ sh depth) dummy)) dummy2)
 561            w (max w width)
 562            d (+ sd h d)
 563            h (+ sh height depth))
 564      (update-heights h d)
 565      (setq dummy (dimension (cadr form) (cons (list (1+ (- w width)) 0) dummy)
 566                             (caar form) rop w right)
 567            width (+ 1 w width)
 568            height (max h height)
 569            depth (max d depth))
 570      (return dummy)))
 571
 572 (displa-def bigfloat  dim-bigfloat)
 573 (displa-def %bigfloat  dim-bigfloat)
 574 (displa-def mquote    dimension-prefix "'")
 575 (displa-def %mquote    dimension-prefix "'")
 576 (displa-def msetq     dimension-infix  " : ")
 577 (displa-def %msetq    dimension-infix  " : ")
 578 (displa-def mset      dimension-infix  " :: ")
 579 (displa-def %mset     dimension-infix  " :: ")
 580 (displa-def mdefine   dim-mdefine      " := ")
 581 (displa-def %mdefine  dim-mdefine      " := ")
 582 (displa-def mdefmacro dim-mdefine      " ::= ")
 583 (displa-def %mdefmacro dim-mdefine      " ::= ")
 584
 585 (defun dim-mdefine (form result)
 586   (let (($noundisp t)
 587         ($stringdisp t))
 588     (dimension-infix (if (cdddr form)
 589                          (list (car form) (cadr form) (cons '(mprogn) (cddr form)))
 590                          form)
 591                      result)))
 592
 593 (displa-def mfactorial dimension-postfix "!")
 594 (displa-def %mfactorial dimension-postfix "!")
 595 (displa-def mexpt      dimension-superscript)
 596 (displa-def %mexpt     dimension-superscript)
 597 (displa-def mncexpt    dim-mncexpt "^^")
 598 (displa-def %mncexpt   dim-mncexpt "^^")
 599
 600 (defun dim-mncexpt (form result)
 601   (dimension-superscript (list '(mncexpt) (cadr form) (cons '(mangle) (cddr form)))
 602                          result))
 603
 604 (displa-def mnctimes dimension-nary " . ")
 605 (displa-def %mnctimes dimension-nary " . ")
 606
 607 (displa-def %product dim-%product 115.)
 608
 609 (defun dim-%product (form result)
 610   (dsumprod form result '(d-prodsign) 5 3 1))
 611
 612 (displa-def rat dim-rat "/")
 613 (displa-def %rat dim-rat "/")
 614
 615 (defun dim-rat (form result)
 616   (if $pfeformat
 617       (dimension-nary form result)
 618       (dim-mquotient form result)))
 619
 620 (displa-def mquotient dim-mquotient "/")
 621 (displa-def %mquotient dim-mquotient "/")
 622
 623 (defun dim-mquotient (form result)
 624   (unless (= (length (cdr form)) 2)
 625     (return-from dim-mquotient (dimension-function form result)))
 626   (prog (num (w 0) (h 0) (d 0) den)
 627      (when (and (= 1 size) (atom (cadr form)) (atom (caddr form)))
 628        (return (dimension-nary form result)))
 629      (setq num (dimension (cadr form) nil 'mparen 'mparen nil right)
 630            w width
 631            h height
 632            d depth)
 633      (unless (checkfit w)
 634        (return (dimension-nary form result)))
 635      (setq den (dimension (caddr form) nil 'mparen 'mparen nil right))
 636      (unless (checkfit width)
 637        (return (dimension-nary form result)))
 638      (return (dratio result num w h d den width height depth))))
 639
 640 ;;            <--     W1     -->
 641 ;;            ------------------
 642 ;;            | ^              |
 643 ;;   <- X1 -> | | H1           |
 644 ;;            | | D1           |
 645 ;;            | v              |
 646 ;;            ------------------
 647 ;;    ----------------------------------
 648 ;; (Likewise for X2, H2, D2, W2 in the denominator)
 649
 650 (defun dratio (result num w1 h1 d1 den w2 h2 d2)
 651   (setq width (max w1 w2)
 652         height (+ 1 h1 d1)
 653         depth (+ h2 d2))
 654   (setq h1 (truncate (- width w1) 2)
 655         d2 (truncate (- width w2) 2))
 656   (update-heights height depth)
 657   (push `(,h1 ,(1+ d1) . ,num) result)
 658   (push `(,(- d2 (+ h1 w1)) ,(- h2) . ,den) result)
 659   (push `(,(- 0 d2 w2) 0) result)
 660   (push `(d-hbar ,width) result)
 661   result)
 662
 663 (displa-def mtimes dimension-nary " ")
 664 (displa-def %mtimes dimension-nary " ")
 665
 666 ;; This code gets run when STARDISP is assigned a value.
 667
 668 (defprop $stardisp stardisp assign)
 669
 670 (defun stardisp (symbol val)
 671   (declare (ignore symbol))
 672   (putprop 'mtimes (if val '(#\*) '(#\space)) 'dissym))
 673
 674 (displa-def %integrate dim-%integrate 115.)
 675
 676 (defun dim-%integrate (form result)
 677   (prog (dummy (w 0)(h 0)(d 0) dummy2)
 678      (cond ((not (or (= (length (cdr form)) 2) (= (length (cdr form)) 4)))
 679             (return-from dim-%integrate (dimension-function form result)))
 680            ((null (cdddr form))
 681             (setq dummy `(#\space (d-integralsign) . ,result) w 2 h 3 d 2))
 682            (t (setq dummy (dimension (cadr (cdddr form)) nil 'mparen 'mparen nil 0)
 683                     w width h height d depth)
 684               (setq dummy2 (dimension (cadddr form) nil 'mparen 'mparen nil 0))
 685               (if (not (checkfit (+ 2 (max w width))))
 686                   (return (dimension-function form result)))
 687               (setq dummy `((0 ,(+ 3 d) . ,dummy) (d-integralsign) . ,result))
 688               (setq dummy (cons (cons (- w) (cons (- (+ 2 height)) dummy2)) dummy)
 689                     w (+ 2 (max w width)) h (+ 3 h d) d (+ 2 height depth)
 690                     dummy (cons (list (- w 1 width) 0) dummy))))
 691      (update-heights h d)
 692      (setq dummy (dimension (cadr form) dummy '%integrate 'mparen w 2)
 693            w (+ w width) h (max h height) d (max d depth))
 694      (push-string " d" dummy)
 695      (setq dummy (dimension (caddr form) dummy 'mparen rop (+ 2 w) right)
 696            width (+ 2 w width) height (max h height) depth (max d depth))
 697      (return dummy)))
 698
 699 (displa-def %derivative dim-%derivative 125.)
 700
 701 (defun dim-%derivative (form result)
 702   (prog ()
 703      (cond ((null (cddr form))
 704             (return (dimension-function (cons '(%diff) (cdr form)) result))))
 705      (cond ((null (cdddr form)) (setq form (append form '(1)))))
 706      (cond ((and $derivabbrev
 707                  (do ((l (cddr form) (cddr l))) ((null l) t)
 708                    (cond ((and (atom (car l)) (integerp (cadr l)) (> (cadr l) 0)))
 709                          (t (return nil)))))
 710             (return (dmderivabbrev form result)))
 711            ((or (> (rbp lop) 130.) (> (lbp rop) 130.)
 712                 (and (not (atom (cadr form))) (or (> (rbp lop) 110.) (> (lbp rop) 110.))))
 713             (return (dimension-paren form result)))
 714            (t (return (dmderivlong form result))))))
 715
 716 (defun dmderivabbrev (form result)
 717   (prog (dummy (w 0))
 718      (do ((l (cddr form) (cddr l)) (var))
 719          ((null l) (setq dummy (cdr dummy) w (1- w)))
 720        (setq var (dimension (car l) nil 'mparen 'mparen nil 0))
 721        (do ((i (cadr l) (1- i)))
 722            ((= 1 i))
 723          (setq dummy (cons #\space (append var dummy))))
 724        (setq dummy (cons #\space (nconc var dummy)) w (+ w (cadr l) (* (cadr l) width))))
 725      (setq result (dimension (cadr form) result lop '%deriv 0 right))
 726      (setq result (cons (cons 0 (cons (- 0 depth 1) dummy)) result)
 727            width (+ w width) depth (max 1 (1+ depth)))
 728      (update-heights height depth)
 729      (return result)))
 730
 731 (defun dmderivlong (form result)
 732   (prog (num (w1 0) (h1 0) (d1 0) den (w2 0)( h2 0)  (d2 0))
 733      (setq num (list (cadddr form))
 734            den (cond ((equal 1 (cadddr form))
 735                       (dimension (caddr form)
 736                                  (list #\d) 'mparen 'mparen nil 0))
 737                      (t (dimension-superscript
 738                          (cons '(diff)(cddr form)) (list #\d))))
 739            w2 (1+ width) h2 height d2 depth)
 740      (do ((l (cddddr form) (cddr l))) ((null l))
 741        (setq num (cons (cadr l) num)
 742              den (cond ((equal 1 (cadr l))
 743                         (dimension (car l) (cons #\d (cons #\space den))
 744                                    'mparen 'mparen nil 0))
 745                        (t (dimension-superscript
 746                            (cons '(diff) l) (cons #\d (cons #\space den)))))
 747              w2 (+ 2 w2 width) h2 (max h2 height) d2 (+ d2 depth)))
 748      (setq num (nformat-check (addn num t)))
 749      (cond ((equal 1 num) (setq num (list #\d) w1 1 h1 1 d1 0))
 750            (t (setq num (dimension-superscript (list '(diff) #\d num) nil)
 751                     w1 width h1 height d1 depth)))
 752      (cond ((atom (setq form (nformat-check (cadr form))))
 753             (setq num (dimension form num '%deriv 'mparen nil 0) w1 (+ w1 width))
 754             (return (dratio result num w1 h1 d1 den w2 h2 d2)))
 755            (t (setq result (dratio result num w1 h1 d1 den w2 h2 d2) w1 width h1 height d1 depth)
 756               (setq result (dimension form (cons #\space result) '%deriv rop w1 right)
 757                     width (+ 1 w1 width) height (max h1 height) depth (max d1 depth))
 758               (update-heights height depth)
 759               (return result)))))
 760
 761 (displa-def %at dim-%at 105. 105.)
 762
 763 ;; We do it this way because there's no guarantee that all lisps use
 764 ;; the same name for these unicode characters or that there the lisp
 765 ;; impl even has names for these characters.
 766 #+lisp-unicode-capable
 767 (let ((alist
 768         ;; An alist whose key is represents the unicode character
 769         ;; we're looking for and whose value is the Unicode code for
 770         ;; the corresponding character
 771         ;;
 772         ;; The key is basically the Unicode name of the character as a
 773         ;; keyword, with underscore replaced by dash.
 774         `((:box-drawings-light-vertical #x2502)
 775           (:box-drawings-light-horizontal #x2500)
 776           (:box-drawings-light-down-and-right #x250c)
 777           (:box-drawings-light-down-and-left #x2510)
 778           (:box-drawings-light-up-and-left #x2518)
 779           (:box-drawings-light-up-and-right #x2514)
 780           (:box-drawings-light-down-and-horizontal #x252c)
 781           (:box-drawings-double-horizontal #x2550)
 782           (:box-drawings-double-vertical #x2551)
 783           (:box-drawings-double-down-and-right #x2554)
 784           (:box-drawings-double-down-and-left #x2557)
 785           (:box-drawings-double-up-and-left #x255d)
 786           (:box-drawings-double-up-and-right #x255a)
 787           (:mathematical-right-angle-bracket #x27E9)
 788           (:top-half-integral #x2320)
 789           (:integral-extension #x23ae)
 790           (:bottom-half-integral #x2321)
 791           (:low-line #x005f)
 792           (:box-drawings-light-diagonal-upper-left-to-lower-right #x2572)
 793           (:box-drawings-light-diagonal-upper-right-to-lower-left #x2571)
 794           (:overline #x203e))))
 795
 796   (defun get-unicode-char (char-keyword)
 797     "Return the Unicode character corresponding to the CHAR-KEYWORD.
 798   CHAR-KEYWORD must be a keyword describing the name of the Unicode
 799   character, where underscore is replaced by a dash."
 800     (let ((code (assoc char-keyword alist)))
 801       (unless code
 802         (error "Unknown char keyword: ~S~%" char-keyword))
 803       (code-char (second code)))))
 804
 805 #-lisp-unicode-capable
 806 (defun get-unicode-char (char-keyword)
 807   (declare (ignore char-keyword))
 808   ;; Just return NIL if the Lisp doesn't support unicode in the way we
 809   ;; need.
 810   nil)
 811
 812 (defvar at-char-unicode
 813   (get-unicode-char :box-drawings-light-vertical))
 814
 815 (defmvar $display2d_unicode
 816   #+lisp-unicode-capable t
 817   #-lisp-unicode-capable nil
 818   "Enable use of unicode characters for 2D display"
 819   :setting-predicate #'(lambda (arg)
 820                          ;; For Unicode-capable Lisps, check that we
 821                          ;; only assign true or false.  If not,
 822                          ;; produce an error with an appropriate
 823                          ;; message.
 824                          #+lisp-unicode-capable
 825                          (values (member arg '(nil t))
 826                                  (let ((*print-case* :downcase))
 827                                    (format nil "must be one of: ~{~A~^, ~}"
 828                                            (mapcar #'stripdollar '($false $true)))))
 829                          ;; For Lisps that don't support Unicode, It's
 830                          ;; an error if we try to set this to anything
 831                          ;; other than false (NIL).  Tell the user
 832                          ;; that it's not supported.
 833                          #-lisp-unicode-capable
 834                          (if arg
 835                              (values nil "2D Unicode display not supported with this Lisp")
 836                              t)))
 837
 838 (defun display2d-unicode-enabled ()
 839   #+(and clisp unicode)
 840   (setf custom:*terminal-encoding*
 841         (ext:make-encoding
 842          :charset "utf-8"
 843          :line-terminator
 844          (ext:encoding-line-terminator custom:*terminal-encoding*)))
 845   #+lisp-unicode-capable
 846   (and $display2d_unicode
 847        ;; Makes sure the version of CLISP being used has Unicode support.
 848        #+clisp
 849        (eq (ext:encoding-charset custom:*terminal-encoding*) 'charset:utf-8)
 850        ;; other special cases go here as we learn about them ...  But
 851        ;; see also ADJUST-CHARACTER-ENCODING in init-cl.lisp that
 852        ;; generally sets up Lisp to use :utf-8 always.
 853        #-clisp
 854        t)
 855   #-lisp-unicode-capable
 856   nil)
 857
 858 (defun dim-%at (form result)
 859   (prog (exp  eqs (w 0) (h 0) (d 0) at-char)
 860      (unless (= (length (cdr form)) 2)
 861        (return-from dim-%at (dimension-function form result)))
 862      (setq at-char (if (display2d-unicode-enabled) at-char-unicode (car (coerce $absboxchar 'list))))
 863      (setq exp (dimension (cadr form) result lop '%at nil 0)
 864            w width
 865            h height
 866            d depth)
 867      (setq eqs (dimension (cond ((not (eq 'mlist (caar (caddr form)))) (caddr form))
 868                                 ((null (cddr (caddr form))) (cadr (caddr form)))
 869                                 (t (cons '(mcomma) (cdaddr form))))
 870                           nil 'mparen 'mparen nil 0))
 871      (unless (checkfit (+ 1 w width))
 872        (return (dimension-function form result)))
 873      (setq result (cons (cons 0 (cons (- 0 1 d) eqs))
 874                         (cons `(d-vbar ,(1+ h) ,(1+ d) ,at-char) exp))
 875            width (+ 1 w width)
 876            height (1+ h)
 877            depth (+ 1 d depth))
 878      (update-heights height depth)
 879      (return result)))
 880
 881 (displa-def mplus  dim-mplus)
 882 (displa-def %mplus  dim-mplus)
 883 (defprop munaryplus (#\+ #\space) dissym)
 884
 885 (defun dim-mplus (form result)
 886   ;; If only 0 or 1 arguments, then print "+"() or +A
 887   (cond ((and (null (cddr form))
 888               (not (member (cadar form) '(trunc exact) :test #'eq)))
 889          (if (null (cdr form))
 890              (dimension-function form result)
 891              (dimension-prefix (cons '(munaryplus) (cdr form)) result)))
 892         (t (setq result (dimension (cadr form) result lop 'mplus 0 0))
 893            (checkbreak result width)
 894            (do ((l (cddr form) (cdr l))
 895                 (w width) (h height) (d depth)
 896                 (trunc (member 'trunc (cdar form) :test #'eq)) (dissym))
 897                ((null l) (cond (trunc
 898                                 (setq width (+ 8 w) height h depth d)
 899                                 (push-string " + . . ." result)))
 900                 result)
 901              (if (mmminusp (car l))
 902                  (setq dissym '(#\space #\- #\space) form (cadar l))
 903                  (setq dissym '(#\space #\+ #\space) form (car l)))
 904              (cond ((and (not trunc) (null (cdr l)))
 905                     (setq result (dimension form (append dissym result)
 906                                             'mplus rop (+ 3 w) right)
 907                           width (+ 3 w width)
 908                           height (max h height)
 909                           depth (max d depth))
 910                     (return result))
 911                    (t (setq result
 912                             (dimension form (append dissym result)
 913                                        'mplus 'mplus (+ 3 w) 0)
 914                             w (+ 3 w width)
 915                             h (max h height)
 916                             d (max d depth))
 917                       (checkbreak result w)))))))
 918
 919 (displa-def mminus dim-mminus)
 920 (displa-def %mminus dim-mminus)
 921 (defprop munaryminus (#\- #\space) dissym)
 922 (def-rbp munaryminus 134)
 923 (def-rbp munaryminus 100)
 924
 925 (defun dim-mminus (form result)
 926   (cond ((and (null (cddr form))
 927               (not (member (cadar form) '(trunc exact) :test #'eq)))
 928          (if (null (cdr form))
 929              (dimension-function form result)
 930              (dimension-prefix (cons '(munaryminus) (cdr form)) result)))
 931         (t
 932          (setq result (dimension (cadr form) result lop 'mminus 0 0))
 933          (checkbreak result width)
 934          (do ((l (cddr form) (cdr l))
 935               (w width)
 936               (h height)
 937               (d depth)
 938               (trunc (member 'trunc (cdar form) :test #'eq))
 939               (dissym))
 940              ((null l)
 941               (cond (trunc
 942                      (setq width (+ 8 w)
 943                            height h
 944                            depth d)
 945                      (push-string " + . . ." result)))
 946               result)
 947            (if (mmminusp (car l))
 948                (setq dissym '(#\space #\+ #\space) form (cadar l))
 949                (setq dissym '(#\space #\- #\space) form (car l)))
 950            (cond ((and (not trunc) (null (cdr l)))
 951                   (setq result (dimension form (append dissym result)
 952                                           'mminus rop (+ 3 w) right)
 953                         width (+ 3 w width)
 954                         height (max h height)
 955                         depth (max d depth))
 956                   (return result))
 957                  (t
 958                   (setq result
 959                         (dimension form (append dissym result)
 960                                    'mminus 'mminus (+ 3 w) 0)
 961                         w (+ 3 w width)
 962                         h (max h height)
 963                         d (max d depth))
 964                   (checkbreak result w)))))))
 965
 966 (displa-def %sum   dim-%sum 110.)
 967 (displa-def %limit dim-%limit 110. 110.)
 968 (displa-def %lsum   dim-%lsum 110.)
 969
 970 (defun dim-%lsum (form result)
 971   (dsumprod form result '(d-sumsign) 4 3 2))
 972
 973 (defun dim-%sum (form result)
 974   (dsumprod form result '(d-sumsign) 4 3 2))
 975
 976 (defun dim-%limit (form result)
 977   (prog ((w 0) (h 0) (d 0) dummy)
 978      (unless (or (= (length (cdr form)) 3) (= (length (cdr form)) 4))
 979        (return-from dim-%limit (dimension-function form result)))
 980      (setq dummy (dimension (third form) nil 'mparen 'mparen nil 0)
 981            w width h height d depth)
 982      (push-string " -> " dummy)
 983      (setq dummy (dimension (fourth form) dummy 'mparen 'mparen nil 0)
 984            w (+ 4 w width)
 985            h (max h height)
 986            d (max d depth))
 987      (cond ((null (cddddr form)))
 988            ((eq '$plus (fifth form))
 989             (push #\+ dummy)
 990             (incf w))
 991            (t (push #\- dummy)
 992               (incf w)))
 993      (push-string "limit" result)
 994      (setq dummy (cons (list* -5 (- h) dummy) result)
 995            d (+ h d))
 996      (update-heights 1 d)
 997      (setq dummy (dimension (cadr form) (cons '(1 0) dummy) '%limit rop (1+ w) right))
 998      (setq width (+ 1 w width)
 999            depth (max d depth))
1000      (return dummy)))
1001
1002 ;; Some scheme needs to be worked out to allow use of mathematical character
1003 ;; sets on consoles which have them.
1004
1005 (displa-def marrow    dimension-infix  " -> " 80. 80.)
1006 (displa-def %marrow   dimension-infix  " -> " 80. 80.)
1007 (displa-def mgreaterp dimension-infix  " > ")
1008 (displa-def %mgreaterp dimension-infix  " > ")
1009 (displa-def mgeqp     dimension-infix  " >= ")
1010 (displa-def %mgeqp    dimension-infix  " >= ")
1011 (displa-def mequal    dimension-infix  " = ")
1012 (displa-def %mequal   dimension-infix  " = ")
1013 (displa-def mnotequal dimension-infix  " # ")
1014 (displa-def %mnotequal dimension-infix  " # ")
1015 (displa-def mleqp     dimension-infix  " <= ")
1016 (displa-def %mleqp    dimension-infix  " <= ")
1017 (displa-def mlessp    dimension-infix  " < ")
1018 (displa-def %mlessp   dimension-infix  " < ")
1019 (displa-def mnot      dimension-prefix "not ")
1020 (displa-def %mnot     dimension-prefix "not ")
1021 (displa-def mand      dimension-nary   " and ")
1022 (displa-def %mand      dimension-nary   " and ")
1023 (defprop mand dimnary-boolean dimension-nary-helper)
1024 (displa-def mor       dimension-nary   " or ")
1025 (displa-def %mor      dimension-nary   " or ")
1026 (defprop mor dimnary-boolean dimension-nary-helper)
1027 (displa-def mcond     dim-mcond)
1028 (displa-def %mcond    dim-mcond)
1029
1030 ;; MCOND or %MCOND always has an even number of arguments.
1031 ;; The first two arguments are the foo and bar in 'if foo then bar .
1032 ;; Of the remaining pairs of arguments,
1033 ;; the first is MAYBE-ELSEIF and the second is ELSE-OR-THEN in the code below.
1034 ;; MAYBE-ELSEIF is T if the construct is 'if foo then bar else quux ,
1035 ;; otherwise the construct is 'if foo then bar elseif baz then quux
1036 ;; where baz is the value of MAYBE-ELSEIF.
1037 ;; If ELSE-OR-THEN is NIL, just omit the final "else".
1038
1039 ;; The parser appends (T NIL) to any if-then which lacks an else.
1040 ;; DIM-MCOND renders both '((%MCOND) $A $B) and '((%MCOND) $A $B T NIL) as "if a then b".
1041
1042 ;; Examples. The "<==>" here means that the stuff on the right parses as the stuff on the left,
1043 ;; and the stuff on the left displays as the stuff on the right.
1044
1045 ;; ((%mcond) $a $b t nil)                    <==> 'if a then b
1046 ;; ((%mcond) $a $b t $d)                     <==> 'if a then b else d
1047 ;; ((%mcond) $a $b $c nil t nil)             <==> 'if a then b elseif c then false
1048 ;; ((%mcond) $a $b $c $d t nil)              <==> 'if a then b elseif c then d
1049 ;; ((%mcond) $a $b $c $d t $f)               <==> 'if a then b elseif c then d else f
1050 ;; ((%mcond) $a $b $c $d $e nil t nil)       <==> 'if a then b elseif c then d elseif e then false
1051 ;; ((%mcond) $a $b $c $d $e $f t nil)        <==> 'if a then b elseif c then d elseif e then f
1052 ;; ((%mcond) $a $b $c $d $e $f t $h)         <==> 'if a then b elseif c then d elseif e then f else h
1053 ;; ((%mcond) $a $b $c $d $e $f $g nil t nil) <==> 'if a then b elseif c then d elseif e then f elseif g then false
1054 ;; ((%mcond) $a $b $c $d $e $f $g $h)        <==> 'if a then b elseif c then d elseif e then f elseif g then h
1055
1056 (defun dim-mcond (form result)
1057   (prog ((w 0) (h 0) (d 0))
1058      (push-string "if " result)
1059      (setq result (dimension (cadr form) result 'mcond 'mparen 3 0)
1060            w (+ 3 width)
1061            h height
1062            d depth)
1063      (checkbreak result w)
1064      (push-string " then " result)
1065      (setq result (dimension (caddr form) result 'mcond 'mparen (+ 6 w) 0)
1066            w (+ 6 w width)
1067            h (max h height)
1068            d (max d depth))
1069      (let ((args (cdddr form)))
1070        (loop while (>= (length args) 2) do
1071             (let ((maybe-elseif (car args)) (else-or-then (cadr args)))
1072               (cond
1073                 ((and (eq maybe-elseif t) (= (length args) 2))
1074                  (unless (or (eq '$false else-or-then) (eq nil else-or-then))
1075                    (checkbreak result w)
1076                    (push-string " else " result)
1077                    (setq result (dimension else-or-then result 'mcond rop (+ 6 w) right)
1078                          w (+ 6 w width)
1079                          h (max h height)
1080                          d (max d depth))))
1081                 (t
1082                  (checkbreak result w)
1083                  (push-string " elseif " result)
1084                  (setq result (dimension maybe-elseif result 'mcond rop (+ 8 w) right)
1085                        w (+ 8 w width)
1086                        h (max h height)
1087                        d (max d depth))
1088                  (checkbreak result w)
1089                  (push-string " then " result)
1090                  (setq result (dimension else-or-then result 'mcond rop (+ 6 w) right)
1091                        w (+ 6 w width)
1092                        h (max h height)
1093                        d (max d depth)))))
1094             (setq args (cddr args))))
1095      (setq width w height h depth d)
1096      (return result)))
1097
1098
1099 (displa-def mdo dim-mdo)
1100 (displa-def %mdo dim-mdo)
1101
1102 (defun dim-mdo (form result)
1103   (prog ((w 0) (h 0) (d 0) brkflag)
1104      (cond ((not (null (cadr form)))
1105             (push-string "for " result)
1106             (setq result (cons #\space (dimension (cadr form) result 'mdo 'mparen 4 right))
1107                   w (+ 4 width) h height d depth brkflag t)))
1108      (cond ((or (null (caddr form)) (equal 1 (caddr form))))
1109            (t (push-string "from " result)
1110               (setq result (cons #\space (dimension (caddr form) result 'mdo 'mparen (+ 6 w) 0))
1111                     w (+ 6 w width) h (max h height) d (max d depth))))
1112      (setq form (cdddr form))
1113      (cond ((equal 1 (car form)))
1114            ((not (null (car form)))
1115             (push-string "step " result)
1116             (setq result (cons #\space (dimension (car form) result 'mdo 'mparen (+ 6 w) 0))
1117                   w (+ 6 w width) h (max h height) d (max d depth)))
1118            ((not (null (cadr form)))
1119             (push-string "next " result)
1120             (setq result (cons #\space (dimension (cadr form) result 'mdo 'mparen (+ 6 w) 0))
1121                   w (+ 6 w width) h (max h height) d (max d depth))))
1122      (cond ((not (null (caddr form)))
1123             (push-string "thru " result)
1124             (setq result (cons #\space (dimension (caddr form) result 'mdo 'mparen (+ 6 w) 0))
1125                   w (+ 6 w width) h (max h height) d (max d depth) brkflag t)))
1126      (cond ((not (null (cadddr form)))
1127             (cond ((and (not (atom (cadddr form))) (eq (caar (cadddr form)) 'mnot))
1128                    (push-string "while " result)
1129                    (setq result (cons #\space (dimension (cadr (cadddr form)) result 'mdo 'mparen (+ 7 w) 0))
1130                          w (+ 7 w width) h (max h height) d (max d depth)))
1131                   (t (push-string "unless " result)
1132                      (setq result
1133                            (cons #\space (dimension (cadddr form) result 'mdo 'mparen (+ 8 w) 0))
1134                            w (+ 8 w width) h (max h height) d (max d depth))))))
1135      (if brkflag (checkbreak result w))
1136      (push-string "do " result)
1137      (setq result (dimension (car (cddddr form)) result 'mdo rop (+ 4 w) right)
1138            width (+ 4 w width) height (max h height) depth (max d depth))
1139      (return result)))
1140
1141
1142 (displa-def mdoin dim-mdoin)
1143 (displa-def %mdoin dim-mdoin)
1144
1145 (defun dim-mdoin (form result)
1146   (prog ((w 0) (h 0) ( d 0))
1147      (push-string "for " result)
1148      (setq result (dimension (cadr form) result 'mdo 'mparen 4 0)
1149            w (+ 4 width) h height d depth)
1150      (push-string " in " result)
1151      (setq result (dimension (caddr form) result 'mdo 'mparen (+ 4 w) 0)
1152            w (+ 4 w width) h (max h height) d (max d depth))
1153      (setq form (cdr (cddddr form)))
1154      (cond ((not (null (car form)))
1155             (push-string " thru " result)
1156             (setq result (dimension (car form) result 'mdo 'mparen (+ 6 w) 0)
1157                   w (+ 6 w width) h (max h height) d (max d depth))))
1158      (cond ((not (null (cadr form)))
1159             (push-string " unless " result)
1160             (setq result (dimension (cadr form) result 'mdo 'mparen (+ 8 w) 0)
1161                   w (+ 8 w width) h (max h height) d (max d depth))))
1162      (push-string " do " result)
1163      (setq result (dimension (caddr form) result 'mdo rop (+ 4 w) right)
1164            width (+ 4 w width) height (max h height) depth (max d depth))
1165      (return result)))
1166
1167 (displa-def mprogn dimension-match "(" ")")
1168 (displa-def %mprogn dimension-match "(" ")")
1169 (displa-def mlist  dimension-match "[" "]")
1170 (displa-def %mlist  dimension-match "[" "]")
1171 (displa-def mangle dimension-match "<" ">")
1172 (displa-def %mangle dimension-match "<" ">")
1173 (displa-def mcomma dimension-nary  ", " 10. 10.)
1174 (displa-def %mcomma dimension-nary  ", " 10. 10.)
1175 (displa-def mabs   dim-mabs)
1176 (displa-def %mabs  dim-mabs)
1177
1178 (defvar mabs-char-unicode
1179   (get-unicode-char :box-drawings-light-vertical))
1180
1181 ;; There is wired knowledge of character offsets here.
1182
1183 (defvar *d-box-char-unicode-horz*
1184   (get-unicode-char :box-drawings-double-horizontal))
1185 (defvar *d-box-char-unicode-vert*
1186   (get-unicode-char :box-drawings-double-vertical))
1187 (defvar *d-box-char-unicode-upper-left*
1188   (get-unicode-char :box-drawings-double-down-and-right))
1189 (defvar *d-box-char-unicode-upper-right*
1190   (get-unicode-char :box-drawings-double-down-and-left))
1191 (defvar *d-box-char-unicode-lower-right*
1192   (get-unicode-char :box-drawings-double-up-and-left))
1193 (defvar *d-box-char-unicode-lower-left*
1194   (get-unicode-char :box-drawings-double-up-and-right))
1195
1196 (defun dim-mabs (form result &aux arg bar mabs-char)
1197   (setq mabs-char (if (display2d-unicode-enabled) mabs-char-unicode (car (coerce $absboxchar 'list))))
1198   (setq arg (dimension (cadr form) nil 'mparen 'mparen nil 0))
1199   (cond ((or (> (+ 2 width) $linel) (and (= 1 height) (= 0 depth)))
1200          (dimension-function form result))
1201         (t (setq width (+ 2 width))
1202            (update-heights height depth)
1203            (setq bar `(d-vbar ,height ,depth ,mabs-char))
1204            (cons bar (nconc arg (cons bar result))))))
1205
1206 (displa-def $matrix dim-$matrix)
1207 (displa-def %matrix dim-$matrix)
1208
1209 (defun dim-$matrix (form result)
1210   (prog (dmstr rstr cstr consp cols)
1211      (setq cols (if ($listp (cadr form)) (length (cadr form)) 0))
1212      (if (or (null (cdr form))
1213              (memalike '((mlist simp)) (cdr form))
1214              ;; Check if the matrix has lists as rows with a equal number of
1215              ;; columns.
1216              (dolist (row (cdr form))
1217                (if (or (not ($listp row))
1218                        (not (eql cols (length row))))
1219                    (return t))))
1220          ;; The matrix is not well formed. Display the matrix in linear mode.
1221          (return (dimension-function form result)))
1222      (do ((l (cdadr form) (cdr l))) ((null l))
1223        (setq dmstr (cons nil dmstr) cstr (cons 0 cstr)))
1224      (do ((r (cdr form) (cdr r)) (h1 0) (d1 0))
1225          ((or consp (null r))
1226           (setq width 0)
1227           (do ((cs cstr (cdr cs))) ((null cs)) (setq width (+ 2 (car cs) width)))
1228           (if (display2d-unicode-enabled)
1229             (setq h1 (1+ (+ h1 d1)) depth (truncate h1 2) height (- h1 depth))
1230             (setq h1 (1- (+ h1 d1)) depth (truncate h1 2) height (- h1 depth))))
1231        (do ((c (cdar r) (cdr c))
1232             (nc dmstr (cdr nc))
1233             (cs cstr (cdr cs)) (dummy) (h2 0) (d2 0))
1234            ((null c) (setq d1 (+ d1 h1 h2) h1 (1+ d2)))
1235          (setq dummy (dimension (car c) nil 'mparen 'mparen nil 0)
1236                h2 (max h2 height) d2 (max d2 depth))
1237          (cond ((not (checkfit (+ 14. width))) (setq consp t) (return nil))
1238                (t (rplaca nc (cons (list* width height depth dummy) (car nc)))
1239                   (rplaca cs (max width (car cs))))))
1240        (setq rstr (cons d1 rstr)))
1241      (if (> (+ height depth) (length linearray))
1242          (setq consp t))
1243      (return
1244        (cond ((and (not consp) (checkfit (+ 2 width)))
1245               (matout dmstr cstr rstr result))
1246              ((and (not consp) (<= level 2)) (colout form result))
1247              (t (dimension-function form result))))))
1248
1249 (defun matout (dmstr cstr rstr result)
1250   (push `(d-matrix left ,height ,depth) result)
1251   (push #\space result)
1252   (do ((d dmstr (cdr d)) (c cstr (cdr c)) (w 0 0))
1253       ((null d))
1254     (do ((d (car d) (cdr d)) (r rstr (cdr r))) ((null d))
1255       (rplaca (cddar d) (- height (car r) (if (display2d-unicode-enabled) 1 0)))
1256       (rplaca (cdar d) (- (truncate (- (car c) (caar d)) 2) w))
1257       (setq w (truncate (+ (car c) (caar d)) 2))
1258       (rplaca d (cdar d)))
1259     (setq result (cons (list (+ 2 (- (car c) w)) 0) (nreconc (car d) result))))
1260   (setq width (+ 2 width))
1261   (update-heights height depth)
1262   (rplaca (car result) (1- (caar result)))
1263   (push `(d-matrix right ,height ,depth) result)
1264   result)
1265
1266 (defun colout (form result)
1267   (dimension-list
1268     (cons '(mlist)
1269           (loop for k from 1 to ($length ($first form))
1270                 collect (list '(mequal) (format nil " Col ~d" k) ($col form k))))
1271     result ""))
1272
1273 (displa-def mbox dim-mbox)
1274 (displa-def %mbox dim-mbox)
1275
1276 (defun dim-mbox (form result &aux dummy)
1277   (setq dummy (dimension (cadr form) nil 'mparen 'mparen nil 0))
1278   (cond ((not (checkfit (+ 2 width)))
1279          (dimension-function (cons '($box) (cdr form)) result))
1280         (t (push `(d-box ,height ,depth ,width ,(nreverse dummy)) result)
1281            (setq width (+ 2 width) height (1+ height) depth (1+ depth))
1282            (update-heights height depth)
1283            result)))
1284
1285 (displa-def mlabox dim-mlabox)
1286 (displa-def %mlabox dim-mlabox)
1287
1288 (defun dim-mlabox (form result)
1289   (if (display2d-unicode-enabled)
1290     (dim-mlabox-unicode form result)
1291     (dim-mlabox-ascii form result)))
1292
1293 (defun dim-mlabox-unicode (form result)
1294   (prog (dummy)
1295      (setq dummy (dimension (cadr form) nil 'mparen 'mparen nil 0))
1296      (cond ((not (checkfit (+ 2 width)))
1297             (return (dimension-function (cons '($box) (cdr form)) result))))
1298      (setq width (+ 2 width) height (1+ height) depth (1+ depth))
1299      (setq result
1300            (cons (do ((l (mapcar #'(lambda (l) (char (symbol-name l) 0))
1301                                  (makstring (caddr form))) (cdr l))
1302                       (w 0) (nl))
1303                      ((or (null l) (= width w))
1304                       (cons 0 (cons (1- height)
1305                                     (cond ((< w width)
1306                                            (cons *d-box-char-unicode-upper-right* (cons `(d-hbar ,(- width w 1) ,*d-box-char-unicode-horz*) nl)))
1307                                           (t nl)))))
1308                    (setq nl (cons (car l) nl) w (1+ w)))
1309                  result))
1310      (setq result (nconc dummy (list* `(d-vbar ,(1- height) ,(1- depth) ,*d-box-char-unicode-vert*)
1311                                       (list (- width) 0) result)))
1312      (setq result (cons (list (- 1 width) (- depth) *d-box-char-unicode-lower-right* `(d-hbar ,(- width 2) ,*d-box-char-unicode-horz*) *d-box-char-unicode-lower-left*) result))
1313      (setq result (list* `(d-vbar ,(1- height) ,(1- depth) ,*d-box-char-unicode-vert*) '(-1 0) result))
1314      (update-heights height depth)
1315      (return result)))
1316
1317 (defun dim-mlabox-ascii (form result)
1318   (prog (dummy ch)
1319      (setq dummy (dimension (cadr form) nil 'mparen 'mparen nil 0))
1320      (cond ((not (checkfit (+ 2 width)))
1321             (return (dimension-function (cons '($box) (cdr form)) result))))
1322      (setq width (+ 2 width) height (1+ height) depth (1+ depth))
1323      (setq ch (car (coerce $boxchar 'list)))
1324      (setq result
1325            (cons (do ((l (mapcar #'(lambda (l) (char (symbol-name l) 0))
1326                                  (makstring (caddr form))) (cdr l))
1327                       (w 0) (nl))
1328                      ((or (null l) (= width w))
1329                       (cons 0 (cons (1- height)
1330                                     (cond ((< w width)
1331                                            (cons `(d-hbar ,(- width w) ,ch) nl))
1332                                           (t nl)))))
1333                    (setq nl (cons (car l) nl) w (1+ w)))
1334                  result))
1335      (setq result (nconc dummy (list* `(d-vbar ,(1- height) ,(1- depth) ,ch)
1336                                       (list (- width) 0) result)))
1337      (setq result (cons (list (- 1 width) (- depth) `(d-hbar ,width ,ch)) result))
1338      (setq result (list* `(d-vbar ,(1- height) ,(1- depth) ,ch) '(-1 0) result))
1339      (update-heights height depth)
1340      (return result)))
1341
1342 (displa-def mtext dim-mtext 1 1)
1343 (displa-def %mtext dim-mtext 1 1)
1344 (defprop mtext dimnary-mtext dimension-nary-helper)
1345
1346 (defun dim-mtext (form result)
1347   (if (null (cddr form)) (dimension (cadr form) result lop rop 0 0)
1348       (dimension-nary form result)))
1349
1350 (displa-def mlabel dim-mlabel 0 0)
1351 (displa-def %mlabel dim-mlabel 0 0)
1352 (setf (get 'mlabel 'wxxml) 'wxxml-mlable) ;; backwards-compatibility for wxMaxima
1353
1354 (defun dim-mlabel (form result)
1355   (prog (dummy (w 0) (h 0) (d 0))
1356      (cond ((eq nil (cadr form)) (setq w 0 h 0 d 0))
1357            (mratp (setq result (append mratp (if *display-labels-p*
1358                                                  (dimension-paren (cadr form) result)))
1359                         w (+ 4 width) h height d depth))
1360            (t (setq result (cons #\space (if *display-labels-p*
1361                                              (dimension-paren (cadr form) result)))
1362                     w (1+ width) h height d depth)))
1363      (let ((level $linel)) (checkbreak result w))
1364      (setq dummy (list 0 0))
1365      (setq result (dimension (caddr form) (cons dummy result) 'mlabel rop w right))
1366      (cond ((and (not $leftjust) (= 0 bkptout))
1367             (rplaca dummy (max 0 (- (truncate (- $linel width) 2) w)))
1368             (setq width (+ (car dummy) width))))
1369      (setq width (+ w width) height (max h height) depth (max d depth))
1370      (return result)))
1371
1372 (defprop mparen -1. lbp)
1373 (defprop mparen -1. rbp)
1374
1375 (defun checkrat (form)
1376   (cond ((atom form) nil)
1377         ((and (not (atom (car form))) (eq (caar form) 'mrat))
1378          (if (member 'trunc (cdar form) :test #'eq)
1379              '(#\space #\/ #\T #\/)
1380              '(#\space #\/ #\R #\/)))
1381         ((and (not (atom (car form))) (eq (caar form) 'mpois))
1382          '(#\space #\/ #\P #\/))
1383         (t
1384          (do ((l (cdr form) (cdr l)))
1385              ((null l))
1386            (cond ((atom l)
1387                   (merror (intl:gettext "display: not a well-formed Maxima expression: ~S") form))
1388                  ((setq form (checkrat (car l)))
1389                   (return form)))))))
1390
1391 (defun checkfit (w)
1392   (or (not break) (<= (- (+ w break right 1) bkptwd) $linel)))
1393
1394 (defun checkbreak (result w)
1395   (cond ((not break))
1396         ((> (- (setq w (+ w break)) bkptout) $linel)
1397          (if (or (null bkpt) (eq result bkpt))
1398              (merror (intl:gettext "display: failed to break up a long expression.~%display: change '$linel' slightly and try again.")))
1399          (do ((l result (cdr l)))
1400              ;; THE NEED FOR EQUAL HERE IS PROBABLY THE SYMPTOM OF A BUG IN ECL !!
1401              ;; PROBABLY RELATED TO SIDE-EFFECTS OF NRECONC, RPLACD, ETC !!
1402              ((#+ecl equal #-ecl eq bkpt (cdr l)) (rplacd l nil))
1403            (if (null l)
1404          ;; MEANING OF FOLLOWING MESSAGE IS OBSCURE.
1405          (merror (intl:gettext "display: 'checkbreak' not found."))))
1406          (output bkpt 0)
1407          (setq lines (1+ lines)
1408                bkpt result bkptout bkptwd bkptwd w
1409                bkptht maxht bkptdp maxdp bkptlevel level maxht 1 maxdp 0))
1410         ((or (null bkpt) (<= level bkptlevel) (> (truncate $linel 2) (- bkptwd bkptout)))
1411          (setq bkpt result bkptwd w bkptlevel level
1412                bkptht (max maxht bkptht) bkptdp (max maxdp bkptdp) maxht 1 maxdp 0))))
1413
1414 (defun forcebreak (result w)
1415   (output result 0)
1416   (setq lines (+ 2 lines)
1417         bkpt nil
1418         bkptout (+ w break)
1419         maxht 1 maxdp 0))
1420
1421 (defun update-heights (ht* dp*)
1422   (if break
1423       (setq maxht (max maxht ht*)
1424             maxdp (max maxdp dp*))))
1425
1426 ;;; BKPT        dimension structure for last breakpoint saved
1427 ;;; BKPTWD      width at last bkpt
1428 ;;; BKPTHT      height of current line to last bkpt
1429 ;;; BKPTDP      depth of current line to last bkpt
1430 ;;; BKPTOUT     width of stuff already output
1431
1432 ;;; MAXHT       height from last bkpt saved to current point
1433 ;;; MAXDP       depth from last bkpt saved to current point
1434
1435 ;;; BREAK       width up to last call to DIMENSION
1436 ;;; RESULT      dimension structure to current point minus output
1437 ;;; W           width from last call to DIMENSION to current point
1438
1439 ;; Code above this point deals with dimensioning and constructing
1440 ;; up dimension strings.  Code past this point deals with printing
1441 ;; them.
1442
1443 ;; <dimension string> ::= () | (<string element> . <dimension string>)
1444 ;; <string element> ::= character |
1445 ;;                   (<column-relative> <row-relative> . <dimension string>) |
1446 ;;                   (<drawing function> . args)
1447 ;; <column-relative> ::= <fixnum>
1448 ;; <row-relative>    ::= <fixnum>
1449 ;; <drawing function> ::= D-HBAR | D-VBAR | D-INTEGRALSIGN | ...
1450
1451 ;; When a character appears in a dimension string, it is printed and
1452 ;; the cursor moves forward a single position.  (The variable OLDCOL is
1453 ;; incremented)  When a form with a fixnum car is encountered, the
1454 ;; first two elements of the form are taken to be relative displacements
1455 ;; for OLDCOL and OLDROW.  *** NOTE *** After drawing the cddr of the form,
1456 ;; OLDROW is reset to its original value, but OLDCOL is left in the new
1457 ;; position.  Why this is done is beyond me.  It only appears to complicate
1458 ;; things.
1459
1460 ;; When a <drawing function> is invoked, the first argument passed to it is a
1461 ;; flag which is T for linear output and NIL for 2D output.  A
1462 ;; <drawing function> is also expected to return the new column position.
1463
1464 (defun output (result w)
1465 ;; The following is a hack to attempt to determine if we're on an
1466 ;; interactive terminal, in which case the user's hitting of the ENTER
1467 ;; key will have caused a newline to be displayed already.
1468 #+(or gcl clisp) (cond ((not (equal *query-io* *standard-input*)) (fresh-line)))
1469 #-(or gcl clisp) (cond ((not (interactive-stream-p *standard-input*)) (fresh-line)))
1470   (cond
1471     ;; If console output is disabled, don't output anything.
1472     ($ttyoff)
1473     ((> (+ bkptht bkptdp) (length linearray))
1474      ;; I suppose we could reallocate LINEARRAY to some larger size and keep going here ...
1475      (merror (intl:gettext "display: expression is too tall to be displayed.")))
1476     (t
1477      (output-linear (nreverse result) w))))
1478
1479 ;; Output function for terminals without cursor positioning capability.
1480 ;; Characters are drawn into LINEARRAY instead.  Each element of LINEARRAY is a
1481 ;; list -- the car is how many spaces to indent; the cdr is a list of
1482 ;; characters to draw.  After drawing into this array, lines are printed one at
1483 ;; a time.  This is used for printing terminals and when writing to files.
1484 ;; Block mode i/o isn't needed since PRINC is used instead of WRITE-CHAR and
1485 ;; CURSORPOS.
1486
1487 (defun output-linear (result w)
1488   (draw-linear result bkptdp w)
1489   (do ((i (1- (+ bkptht bkptdp)) (1- i)))
1490       ((< i 0))
1491     (cond ((null (aref linearray i)))
1492           (t (output-linear-one-line i)))))
1493
1494 (defun output-linear-one-line (i)
1495   (prog (line (n 0))
1496      (setq line (aref linearray i)
1497            line (nreverse (cdr line))
1498            n (car line))
1499      (setf (aref linearray i) nil)
1500      (tyotbsp n)
1501      (loop for v in (cdr line) do (write-char v #+(or sbcl cmu) *standard-output*))
1502      (mterpri)))
1503
1504 ;; Move the cursor over N spaces to the left by outputting spaces.
1505 ;; This function assumes that the cursor is in the left margin when
1506 ;; it is called.  This is only called from OUTPUT-LINEAR, so it is
1507 ;; used only for printing terminals or for file output.
1508
1509 (defun tyotbsp (n)
1510   (do ()
1511       ((< n 1))
1512     (write-char #\space #+(or sbcl cmu) *standard-output*)
1513     (decf n)))
1514
1515 (defun draw-linear (dmstr oldrow oldcol)
1516   "This puts the LINE lists into LINEARRAY ready to be drawn.
1517    Each LINE consists of first an initial number of columns to space
1518    and then the characters to be printed.
1519    oldrow and oldcol are the starting points for the the (dx,dy) offsets
1520    given in the dimension string DMSTR.  It does not check that oldrow
1521    is big enough for possible negative y offsets in DMSTR, but BKPTDP is the
1522    right global to use for  oldrow."
1523   (do ((line))
1524       ((null dmstr))
1525     (cond ((atom (car dmstr))
1526            (setq line (aref linearray oldrow))
1527            (cond ((null line) (setq line (list oldcol)))
1528                  (t (prog (n)
1529                        (setq n (car line) line (cdr line))
1530                        (do ()
1531                            ((<= oldcol n))
1532                          (push #\space line)
1533                          (incf n)))))
1534            (do ()
1535                ((or (null dmstr) (not (atom (car dmstr))))
1536                 (setf (aref linearray oldrow) (cons oldcol line)))
1537              (incf oldcol)
1538              (push (car dmstr) line)
1539              (pop dmstr)))
1540           ((integerp (caar dmstr))
1541            ;; Why update OLDCOL and not OLDROW?  Should either update both
1542            ;; (requiring multiple value return) or neither (analogous to lambda
1543            ;; binding).
1544            (setq oldcol (draw-linear (reverse (cddar dmstr))
1545                                      (+ oldrow (cadar dmstr))
1546                                      (+ oldcol (caar dmstr))))
1547            (pop dmstr))
1548           (t (setq oldcol (apply (caar dmstr) t (cdar dmstr)))
1549              (pop dmstr))))
1550   ;; Be sure to return this.
1551   oldcol)
1552
1553 ;; Special symbol drawing functions -- lines, boxes, summation signs, etc.
1554 ;; Every drawing function must take at least one argument.  The first
1555 ;; argument is T if equations must be printed line-by-line.  Otherwise,
1556 ;; draw them using cursor movement, character graphics, or line graphics
1557 ;; if possible.
1558
1559 ;; Most of these functions just invoke DRAW-XXX on some constant
1560 ;; list structure, so be careful about NREVERSEing.  In other cases,
1561 ;; stuff is consed only for the linear case, but direct calls are used
1562 ;; in the 2D case.  This should work for both cases.  (See end of
1563 ;; program.)
1564
1565 (defvar d-hbar-char-unicode
1566   (get-unicode-char :box-drawings-light-horizontal))
1567 (defvar d-hbar-char-ascii #\-)
1568
1569 (defun d-hbar (linear? w &optional char &aux nl)
1570   (declare (ignore linear?))
1571   (when (null char)
1572     (setq char (if (display2d-unicode-enabled) d-hbar-char-unicode d-hbar-char-ascii)))
1573   (dotimes (i w)
1574     (push char nl))
1575   (draw-linear nl oldrow oldcol))
1576
1577 ;; Notice that in all of the height computations, an offset of 2 is added or
1578 ;; subtracted to the y-dimension.  This is to get the lines to fit within the
1579 ;; character cell precisely and not get clipped when moving things around in
1580 ;; the equation editor.
1581
1582 (defvar d-vbar-char-unicode
1583   (get-unicode-char :box-drawings-light-vertical))
1584 (defvar d-vbar-char-ascii #\|)
1585
1586 (defun d-vbar (linear? h d &optional char-body char-head char-foot)
1587   (declare (ignore linear?))
1588   (when (null char-body)
1589     (setq char-body (if (display2d-unicode-enabled) d-vbar-char-unicode d-vbar-char-ascii)))
1590   (when (null char-head)
1591     (setq char-head char-body))
1592   (when (null char-foot)
1593     (setq char-foot char-body))
1594   (setq d (- d))
1595   (do ((i (- h 2) (1- i))
1596        (nl-head `((0 ,(1- h) ,char-head))))
1597       ((or (and (display2d-unicode-enabled) (<= i d)) (and (not (display2d-unicode-enabled)) (< i d)))
1598        (when (and (display2d-unicode-enabled) (= i d))
1599          (push `(-1 ,i ,char-foot) nl-head))
1600        (draw-linear (nreverse nl-head) oldrow oldcol))
1601     (push `(-1 ,i ,char-body) nl-head)))
1602
1603 (defvar d-integralsign-string-unicode
1604   #+lisp-unicode-capable
1605   `((0 2 ,(get-unicode-char :top-half-integral))
1606     (-1 1 ,(get-unicode-char :integral-extension))
1607     (-1 0 ,(get-unicode-char :integral-extension))
1608     (-1 -1 ,(get-unicode-char :integral-extension))
1609     (-1 -2 ,(get-unicode-char :bottom-half-integral))))
1610
1611 (defvar d-integralsign-string-ascii `((0 2 #\/) (-1 1 #\|) (-1 0 #\|) (-1 -1 #\|) (-1 -2 #\/)))
1612
1613 (defun d-integralsign (linear? &aux dmstr)
1614   (declare (ignore linear?))
1615   (setq dmstr (if (display2d-unicode-enabled) d-integralsign-string-unicode d-integralsign-string-ascii))
1616   (draw-linear dmstr oldrow oldcol))
1617
1618 (defvar d-prodsign-unicode-dmstr
1619   #+lisp-unicode-capable
1620   `((0 2 (d-hbar 1) ,(get-unicode-char :box-drawings-light-down-and-horizontal) (d-hbar 3)
1621        ,(get-unicode-char :box-drawings-light-down-and-horizontal) (d-hbar 1))
1622     (-6 0) (d-vbar 2 1) #\space #\space #\space (d-vbar 2 1) (0 0)))
1623
1624 (defvar d-prodsign-ascii-dmstr
1625   '((0 2 (d-hbar 5 #\_)) (-5 0) (d-vbar 2 1 #\|) #\space #\space #\space
1626     (d-vbar 2 1 #\|) (0 0)))
1627
1628 (defun d-prodsign (linear? &aux dmstr)
1629   (declare (ignore linear?))
1630   (setq dmstr (if (display2d-unicode-enabled) d-prodsign-unicode-dmstr d-prodsign-ascii-dmstr))
1631   (draw-linear dmstr oldrow oldcol))
1632
1633 (defvar d-sumsign-unicode-dmstr
1634   #+lisp-unicode-capable
1635   `((0 2 (d-hbar 4 ,(get-unicode-char :low-line)))
1636     (-4 1 ,(get-unicode-char :box-drawings-light-diagonal-upper-left-to-lower-right))
1637     ,(get-unicode-char :mathematical-right-angle-bracket)
1638     (-2 -1 ,(get-unicode-char :box-drawings-light-diagonal-upper-right-to-lower-left))
1639     (-1 -2 (d-hbar 4 ,(get-unicode-char :overline)))))
1640
1641 (defvar d-sumsign-ascii-dmstr '((0 2 (d-hbar 4 #\_)) (-4 1 #\\) #\> (-2 -1 #\/) (-1 -2 (d-hbar 4 #\-))))
1642
1643 (defun d-sumsign (linear? &aux dmstr)
1644   (declare (ignore linear?))
1645   (setq dmstr (if (display2d-unicode-enabled) d-sumsign-unicode-dmstr d-sumsign-ascii-dmstr))
1646   (draw-linear dmstr oldrow oldcol))
1647
1648 ;; Notice how this calls D-VBAR in the non-graphic case.  The entire output
1649 ;; side should be structured this way, with no consing of intermediate
1650 ;; dimension strings.
1651
1652 (defun d-matrix (linear? direction h d)
1653   (if (display2d-unicode-enabled)
1654     (d-matrix-unicode linear? direction h d)
1655     (d-matrix-ascii linear? direction h d)))
1656
1657 (defvar d-matrix-char-unicode-horz
1658   (get-unicode-char :box-drawings-light-horizontal))
1659 (defvar d-matrix-char-unicode-vert
1660   (get-unicode-char :box-drawings-light-vertical))
1661 (defvar d-matrix-char-unicode-upper-left
1662   (get-unicode-char :box-drawings-light-down-and-right))
1663 (defvar d-matrix-char-unicode-upper-right
1664   (get-unicode-char :box-drawings-light-down-and-left))
1665 (defvar d-matrix-char-unicode-lower-right
1666   (get-unicode-char :box-drawings-light-up-and-left))
1667 (defvar d-matrix-char-unicode-lower-left
1668   (get-unicode-char :box-drawings-light-up-and-right))
1669
1670 (defun d-matrix-unicode (linear? direction h d)
1671   (declare (ignore linear?))
1672   (let*
1673     ((char-upper-corner (if (eq direction 'right) d-matrix-char-unicode-upper-right d-matrix-char-unicode-upper-left))
1674      (char-lower-corner (if (eq direction 'right) d-matrix-char-unicode-lower-right d-matrix-char-unicode-lower-left))
1675      (dmstr `((d-vbar ,h ,d ,d-matrix-char-unicode-vert ,char-upper-corner ,char-lower-corner))))
1676     (draw-linear dmstr oldrow oldcol)))
1677
1678 (defun d-matrix-ascii (linear? direction h d)
1679   (d-vbar linear? h d (car (coerce (if (eq direction 'right)
1680                                              $rmxchar
1681                                              $lmxchar) 'list))))
1682
1683 (defun d-box (linear? h d w body)
1684   (declare (ignore linear?))
1685   (if (display2d-unicode-enabled)
1686     (d-box-unicode h d w body)
1687     (d-box-ascii h d w body)))
1688
1689 (defun d-box-unicode (h d w body &aux dmstr)
1690   (setq dmstr `((0 ,h ,*d-box-char-unicode-upper-right* (d-hbar ,w ,*d-box-char-unicode-horz*) ,*d-box-char-unicode-upper-left*)
1691                 (,(- (+ w 2)) 0)
1692                 (d-vbar ,h ,d ,*d-box-char-unicode-vert*)
1693                 ,@body
1694                 (,(- (1+ w)) ,(- (1+ d)) ,*d-box-char-unicode-lower-right* (d-hbar ,w ,*d-box-char-unicode-horz*) ,*d-box-char-unicode-lower-left*)
1695                 (-1 0)
1696                 (d-vbar ,h ,d ,*d-box-char-unicode-vert*)))
1697   (draw-linear dmstr oldrow oldcol))
1698
1699 (defun d-box-ascii (h d w body &aux (char 0) dmstr)
1700   (setq char (car (coerce $boxchar 'list)))
1701   (setq dmstr `((0 ,h (d-hbar ,(+ 2 w) ,char))
1702                 (,(- (+ w 2)) 0)
1703                 (d-vbar ,h ,d ,char)
1704                 ,@body
1705                 (,(- (1+ w)) ,(- (1+ d)) (d-hbar ,(+ w 2) ,char))
1706                 (-1 0)
1707                 (d-vbar ,h ,d ,char)))
1708   (draw-linear dmstr oldrow oldcol))