1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 ;;; The data in this file contains enhancements. ;;;;;
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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
12 (macsyma-module displa
)
14 ;; N.B. You must read the macro file before reading this file.
16 (load-macsyma-macros displm
)
18 (defmvar $stardisp nil
19 "Causes factors of products to be separated by * when displayed.")
21 (defmvar $leftjust nil
22 "Causes equations to be drawn left justified rather than centered.
25 (defmvar $noundisp nil
"Causes nouns to be displayed with a single quote")
27 (defmvar displayp nil
"Is T when inside of `displa'")
29 ;; Parameters which control how boxes, absolute value signs,
30 ;; evaluation-at-a-point bars, and matrices are drawn.
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.")
38 (defvar linearray
(make-array 80.
:initial-element nil
))
40 (defun maxima-display (form &key
(stream *standard-output
*) )
41 (let ((*standard-output
* stream
))
44 (defvar *alt-display2d
* nil
)
45 (defvar *alt-display1d
* nil
)
50 (cond (*alt-display2d
* (apply *alt-display2d
* form
()))
53 (linearray (if displayp
54 (make-array 80.
:initial-element nil
)
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)
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
))
69 ;; make sure the linearray gets cleared out.
70 (fill linearray nil
))))))
73 (apply *alt-display1d
* form
())
74 (linear-displa form
))))))
76 (defmspec $with_default_2d_display
(expr)
77 (let ((*alt-display2d
* nil
)
79 (mexpr (cons '(mprog) (cdr expr
))))
82 ;;; (LINEAR-DISPLA <thing-to-display>)
84 ;;; Display text linearly. This function should be usable in any case
85 ;;; DISPLA is usable and will attempt to do something reasonable with
88 (defun linear-displa (form)
89 (fresh-line *standard-output
*)
90 (mgrind form
*standard-output
*)
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")
98 (defun nformat-check (form)
99 (if (and $display_format_internal
100 (not (or (atom form
) (atom (car form
)) (specrepp form
))))
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
))
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
)))))
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.
123 ;; Referenced externally by RAT;FLOAT.
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
))))
133 ;; Referenced externally by anyone who wants to display something as
134 ;; a funny looking atom, e.g. Trace, Mformat.
136 (defun dimension-string (dummy result
&aux crp
)
137 (setq width
0 height
1 depth
0)
138 (do ((l dummy
(cdr l
)))
141 (if (char= (car l
) #\newline
) (setq crp t
)))
142 (cond ((or (and (checkfit width
) (not crp
)) (not break
))
143 (nreconc dummy result
))
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
)))
152 (when (and (= w width
) l
)
153 (forcebreak (cons #\\ result
) width
)
154 (setq result nil w
(+ $linel width
))
156 (setq result
(rplacd dummy result
))))))))
158 (defun makestring (atom)
160 (cond ((numberp atom
) (exploden atom
))
162 (setq dummy
(coerce atom
'list
))
164 (cons #\" (nconc dummy
(list #\")))
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
))
175 ((char= #\$
(car dummy
)) (cdr dummy
))
176 ((char= #\%
(car dummy
)) (cdr dummy
))
177 ($lispdisp
(cons #\? dummy
))
180 (defun dimension-paren (form result
)
181 (setq result
(cons #\
) (dimension form
(cons #\
( result
) 'mparen
'mparen
1 (1+ right
))))
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)))
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
)
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
))
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
))) ;; ?? !!
215 (if (and (> w11
0) (> w10 w11
)) (list (list (- w10 w11
) 0)))
216 (remove-if #'(lambda (l) (= (length l
) 2))
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
)))
224 height
(+ h-base
(max (+ d01 h01
) (+ d11 h11
)))
225 depth
(+ d-base
(max (+ d00 h00
) (+ d10 h10
))))))
226 (update-heights height depth
)
229 (defun dimension-indices (base-symbol indices
)
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
))
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
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))
251 (setq pre-subscripts-output
252 (let ((lop 'mparen
) (rop 'mparen
) (break nil
) (size 1))
253 (dimension-list (cons '(mlist) pre-subscripts
) nil separator
))
258 (setq pre-superscripts-output
259 (let ((lop 'mparen
) (rop 'mparen
) (break nil
) (size 1))
260 (dimension-list (cons '(mlist) pre-superscripts
) nil separator
))
265 (setq post-subscripts-output
266 (let ((lop 'mparen
) (rop 'mparen
) (break nil
) (size 1))
267 (dimension-list (cons '(mlist) post-subscripts
) nil separator
))
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
))
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
)))))
280 (defun extract-indices (indices display-indices index-flag
)
282 (loop for i from
0 to
(length display-indices
)
283 collect
(if (eq (nth i display-indices
) index-flag
) (nth i indices
)))))
285 (defun safe-$get
(x y
)
286 (and (symbolp x
) ($get x y
)))
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
)
303 (t (setq result
(let ((lop '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
))))
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
))
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
)))
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
)
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
)
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
)
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
))
355 (prog (dissym (symlength 0) (w 0) (h 0) (d 0) helper
)
356 (setq dissym
(safe-get (caar form
) 'dissym
)
357 symlength
(length dissym
)
359 ;; Look for a helper function. Fall back on default if none found.
360 helper
(or (safe-get (caar form
) 'dimension-nary-helper
) 'dimnary
)
362 result
(funcall helper
(cadr form
) result lop
(caar form
) (caar form
) 0)
367 (do ((l (cddr form
) (cdr l
)))
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
)
374 height
(max h height
)
378 (setq result
(funcall helper
(car l
) result
(caar form
) (caar form
) (caar form
) w
)
384 ;; Output for MTEXT, generated for example by print(...).
385 ;; Suppress parentheses which would be generated by DIMNARY.
387 (defun dimnary-mtext (form result lop op rop w
)
388 (declare (ignore op
))
389 (dimension form result lop rop w right
))
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).
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)
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)
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
)))
423 'mparen
'mparen
(if w
(1+ w
)) (1+ right
))))
426 (dimension form result lop rop w right
)))
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).
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)
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
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
)))
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
))))
472 (defun dimension-nofix (form result
)
473 (setq form
(safe-get (caar form
) 'dissym
)
475 (revappend form result
))
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
)))
485 (return (revappend (cdr dissym
) (revappend (car dissym
) result
))))
486 (t (setq result
(let ((lop '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
))))))
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))
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
))
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
)
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
))
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
)
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)
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
)
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
)))
558 (setq sw
(truncate (- sw width
) 2)
559 width
(+ sw width
))))
560 (setq dummy
(cons (cons (- sw w
) (cons (+ sh depth
) dummy
)) dummy2
)
563 h
(+ sh height depth
))
565 (setq dummy
(dimension (cadr form
) (cons (list (1+ (- w width
)) 0) dummy
)
566 (caar form
) rop w right
)
568 height
(max h height
)
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
" ::= ")
585 (defun dim-mdefine (form result
)
588 (dimension-infix (if (cdddr form
)
589 (list (car form
) (cadr form
) (cons '(mprogn) (cddr form
)))
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
"^^")
600 (defun dim-mncexpt (form result
)
601 (dimension-superscript (list '(mncexpt) (cadr form
) (cons '(mangle) (cddr form
)))
604 (displa-def mnctimes dimension-nary
" . ")
605 (displa-def %mnctimes dimension-nary
" . ")
607 (displa-def %product dim-%product
115.
)
609 (defun dim-%product
(form result
)
610 (dsumprod form result
'(d-prodsign) 5 3 1))
612 (displa-def rat dim-rat
"/")
613 (displa-def %rat dim-rat
"/")
615 (defun dim-rat (form result
)
617 (dimension-nary form result
)
618 (dim-mquotient form result
)))
620 (displa-def mquotient dim-mquotient
"/")
621 (displa-def %mquotient dim-mquotient
"/")
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
)
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
))))
641 ;; ------------------
646 ;; ------------------
647 ;; ----------------------------------
648 ;; (Likewise for X2, H2, D2, W2 in the denominator)
650 (defun dratio (result num w1 h1 d1 den w2 h2 d2
)
651 (setq width
(max w1 w2
)
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
)
663 (displa-def mtimes dimension-nary
" ")
664 (displa-def %mtimes dimension-nary
" ")
666 ;; This code gets run when STARDISP is assigned a value.
668 (defprop $stardisp stardisp assign
)
670 (defun stardisp (symbol val
)
671 (declare (ignore symbol
))
672 (putprop 'mtimes
(if val
'(#\
*) '(#\space
)) 'dissym
))
674 (displa-def %integrate dim-%integrate
115.
)
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
)))
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
))))
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
))
699 (displa-def %derivative dim-%derivative
125.
)
701 (defun dim-%derivative
(form result
)
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)))
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
))))))
716 (defun dmderivabbrev (form result
)
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
)))
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
)
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
)
761 (displa-def %at dim-%at
105.
105.
)
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
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
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
)
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
))))
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
)))
802 (error "Unknown char keyword: ~S~%" char-keyword
))
803 (code-char (second code
)))))
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
812 (defvar at-char-unicode
813 (get-unicode-char :box-drawings-light-vertical
))
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
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
835 (values nil
"2D Unicode display not supported with this Lisp")
838 (defun display2d-unicode-enabled ()
839 #+lisp-unicode-capable
840 (and $display2d_unicode
841 ;; Makes sure the version of CLISP being used has Unicode support.
843 (eq (ext:encoding-charset custom
:*terminal-encoding
*) 'charset
:utf-8
)
844 ;; other special cases go here as we learn about them ... But
845 ;; see also ADJUST-CHARACTER-ENCODING in init-cl.lisp that
846 ;; generally sets up Lisp to use :utf-8 always.
849 #-lisp-unicode-capable
852 (defun dim-%at
(form result
)
853 (prog (exp eqs
(w 0) (h 0) (d 0) at-char
)
854 (unless (= (length (cdr form
)) 2)
855 (return-from dim-%at
(dimension-function form result
)))
856 (setq at-char
(if (display2d-unicode-enabled) at-char-unicode
(car (coerce $absboxchar
'list
))))
857 (setq exp
(dimension (cadr form
) result lop
'%at nil
0)
861 (setq eqs
(dimension (cond ((not (eq 'mlist
(caar (caddr form
)))) (caddr form
))
862 ((null (cddr (caddr form
))) (cadr (caddr form
)))
863 (t (cons '(mcomma) (cdaddr form
))))
864 nil
'mparen
'mparen nil
0))
865 (unless (checkfit (+ 1 w width
))
866 (return (dimension-function form result
)))
867 (setq result
(cons (cons 0 (cons (- 0 1 d
) eqs
))
868 (cons `(d-vbar ,(1+ h
) ,(1+ d
) ,at-char
) exp
))
872 (update-heights height depth
)
875 (displa-def mplus dim-mplus
)
876 (displa-def %mplus dim-mplus
)
877 (defprop munaryplus
(#\
+ #\space
) dissym
)
879 (defun dim-mplus (form result
)
880 ;; If only 0 or 1 arguments, then print "+"() or +A
881 (cond ((and (null (cddr form
))
882 (not (member (cadar form
) '(trunc exact
) :test
#'eq
)))
883 (if (null (cdr form
))
884 (dimension-function form result
)
885 (dimension-prefix (cons '(munaryplus) (cdr form
)) result
)))
886 (t (setq result
(dimension (cadr form
) result lop
'mplus
0 0))
887 (checkbreak result width
)
888 (do ((l (cddr form
) (cdr l
))
889 (w width
) (h height
) (d depth
)
890 (trunc (member 'trunc
(cdar form
) :test
#'eq
)) (dissym))
891 ((null l
) (cond (trunc
892 (setq width
(+ 8 w
) height h depth d
)
893 (push-string " + . . ." result
)))
895 (if (mmminusp (car l
))
896 (setq dissym
'(#\space
#\-
#\space
) form
(cadar l
))
897 (setq dissym
'(#\space
#\
+ #\space
) form
(car l
)))
898 (cond ((and (not trunc
) (null (cdr l
)))
899 (setq result
(dimension form
(append dissym result
)
900 'mplus rop
(+ 3 w
) right
)
902 height
(max h height
)
906 (dimension form
(append dissym result
)
907 'mplus
'mplus
(+ 3 w
) 0)
911 (checkbreak result w
)))))))
913 (displa-def mminus dim-mminus
)
914 (displa-def %mminus dim-mminus
)
915 (defprop munaryminus
(#\-
#\space
) dissym
)
916 (def-rbp munaryminus
134)
917 (def-rbp munaryminus
100)
919 (defun dim-mminus (form result
)
920 (cond ((and (null (cddr form
))
921 (not (member (cadar form
) '(trunc exact
) :test
#'eq
)))
922 (if (null (cdr form
))
923 (dimension-function form result
)
924 (dimension-prefix (cons '(munaryminus) (cdr form
)) result
)))
926 (setq result
(dimension (cadr form
) result lop
'mminus
0 0))
927 (checkbreak result width
)
928 (do ((l (cddr form
) (cdr l
))
932 (trunc (member 'trunc
(cdar form
) :test
#'eq
))
939 (push-string " + . . ." result
)))
941 (if (mmminusp (car l
))
942 (setq dissym
'(#\space
#\
+ #\space
) form
(cadar l
))
943 (setq dissym
'(#\space
#\-
#\space
) form
(car l
)))
944 (cond ((and (not trunc
) (null (cdr l
)))
945 (setq result
(dimension form
(append dissym result
)
946 'mminus rop
(+ 3 w
) right
)
948 height
(max h height
)
953 (dimension form
(append dissym result
)
954 'mminus
'mminus
(+ 3 w
) 0)
958 (checkbreak result w
)))))))
960 (displa-def %sum dim-%sum
110.
)
961 (displa-def %limit dim-%limit
110.
110.
)
962 (displa-def %lsum dim-%lsum
110.
)
964 (defun dim-%lsum
(form result
)
965 (dsumprod form result
'(d-sumsign) 4 3 2))
967 (defun dim-%sum
(form result
)
968 (dsumprod form result
'(d-sumsign) 4 3 2))
970 (defun dim-%limit
(form result
)
971 (prog ((w 0) (h 0) (d 0) dummy
)
972 (unless (or (= (length (cdr form
)) 3) (= (length (cdr form
)) 4))
973 (return-from dim-%limit
(dimension-function form result
)))
974 (setq dummy
(dimension (third form
) nil
'mparen
'mparen nil
0)
975 w width h height d depth
)
976 (push-string " -> " dummy
)
977 (setq dummy
(dimension (fourth form
) dummy
'mparen
'mparen nil
0)
981 (cond ((null (cddddr form
)))
982 ((eq '$plus
(fifth form
))
987 (push-string "limit" result
)
988 (setq dummy
(cons (list* -
5 (- h
) dummy
) result
)
991 (setq dummy
(dimension (cadr form
) (cons '(1 0) dummy
) '%limit rop
(1+ w
) right
))
992 (setq width
(+ 1 w width
)
996 ;; Some scheme needs to be worked out to allow use of mathematical character
997 ;; sets on consoles which have them.
999 (displa-def marrow dimension-infix
" -> " 80.
80.
)
1000 (displa-def %marrow dimension-infix
" -> " 80.
80.
)
1001 (displa-def mgreaterp dimension-infix
" > ")
1002 (displa-def %mgreaterp dimension-infix
" > ")
1003 (displa-def mgeqp dimension-infix
" >= ")
1004 (displa-def %mgeqp dimension-infix
" >= ")
1005 (displa-def mequal dimension-infix
" = ")
1006 (displa-def %mequal dimension-infix
" = ")
1007 (displa-def mnotequal dimension-infix
" # ")
1008 (displa-def %mnotequal dimension-infix
" # ")
1009 (displa-def mleqp dimension-infix
" <= ")
1010 (displa-def %mleqp dimension-infix
" <= ")
1011 (displa-def mlessp dimension-infix
" < ")
1012 (displa-def %mlessp dimension-infix
" < ")
1013 (displa-def mnot dimension-prefix
"not ")
1014 (displa-def %mnot dimension-prefix
"not ")
1015 (displa-def mand dimension-nary
" and ")
1016 (displa-def %mand dimension-nary
" and ")
1017 (defprop mand dimnary-boolean dimension-nary-helper
)
1018 (displa-def mor dimension-nary
" or ")
1019 (displa-def %mor dimension-nary
" or ")
1020 (defprop mor dimnary-boolean dimension-nary-helper
)
1021 (displa-def mcond dim-mcond
)
1022 (displa-def %mcond dim-mcond
)
1024 ;; MCOND or %MCOND always has an even number of arguments.
1025 ;; The first two arguments are the foo and bar in 'if foo then bar .
1026 ;; Of the remaining pairs of arguments,
1027 ;; the first is MAYBE-ELSEIF and the second is ELSE-OR-THEN in the code below.
1028 ;; MAYBE-ELSEIF is T if the construct is 'if foo then bar else quux ,
1029 ;; otherwise the construct is 'if foo then bar elseif baz then quux
1030 ;; where baz is the value of MAYBE-ELSEIF.
1031 ;; If ELSE-OR-THEN is NIL, just omit the final "else".
1033 ;; The parser appends (T NIL) to any if-then which lacks an else.
1034 ;; DIM-MCOND renders both '((%MCOND) $A $B) and '((%MCOND) $A $B T NIL) as "if a then b".
1036 ;; Examples. The "<==>" here means that the stuff on the right parses as the stuff on the left,
1037 ;; and the stuff on the left displays as the stuff on the right.
1039 ;; ((%mcond) $a $b t nil) <==> 'if a then b
1040 ;; ((%mcond) $a $b t $d) <==> 'if a then b else d
1041 ;; ((%mcond) $a $b $c nil t nil) <==> 'if a then b elseif c then false
1042 ;; ((%mcond) $a $b $c $d t nil) <==> 'if a then b elseif c then d
1043 ;; ((%mcond) $a $b $c $d t $f) <==> 'if a then b elseif c then d else f
1044 ;; ((%mcond) $a $b $c $d $e nil t nil) <==> 'if a then b elseif c then d elseif e then false
1045 ;; ((%mcond) $a $b $c $d $e $f t nil) <==> 'if a then b elseif c then d elseif e then f
1046 ;; ((%mcond) $a $b $c $d $e $f t $h) <==> 'if a then b elseif c then d elseif e then f else h
1047 ;; ((%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
1048 ;; ((%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
1050 (defun dim-mcond (form result
)
1051 (prog ((w 0) (h 0) (d 0))
1052 (push-string "if " result
)
1053 (setq result
(dimension (cadr form
) result
'mcond
'mparen
3 0)
1057 (checkbreak result w
)
1058 (push-string " then " result
)
1059 (setq result
(dimension (caddr form
) result
'mcond
'mparen
(+ 6 w
) 0)
1063 (let ((args (cdddr form
)))
1064 (loop while
(>= (length args
) 2) do
1065 (let ((maybe-elseif (car args
)) (else-or-then (cadr args
)))
1067 ((and (eq maybe-elseif t
) (= (length args
) 2))
1068 (unless (or (eq '$false else-or-then
) (eq nil else-or-then
))
1069 (checkbreak result w
)
1070 (push-string " else " result
)
1071 (setq result
(dimension else-or-then result
'mcond rop
(+ 6 w
) right
)
1076 (checkbreak result w
)
1077 (push-string " elseif " result
)
1078 (setq result
(dimension maybe-elseif result
'mcond rop
(+ 8 w
) right
)
1082 (checkbreak result w
)
1083 (push-string " then " result
)
1084 (setq result
(dimension else-or-then result
'mcond rop
(+ 6 w
) right
)
1088 (setq args
(cddr args
))))
1089 (setq width w height h depth d
)
1093 (displa-def mdo dim-mdo
)
1094 (displa-def %mdo dim-mdo
)
1096 (defun dim-mdo (form result
)
1097 (prog ((w 0) (h 0) (d 0) brkflag
)
1098 (cond ((not (null (cadr form
)))
1099 (push-string "for " result
)
1100 (setq result
(cons #\space
(dimension (cadr form
) result
'mdo
'mparen
4 right
))
1101 w
(+ 4 width
) h height d depth brkflag t
)))
1102 (cond ((or (null (caddr form
)) (equal 1 (caddr form
))))
1103 (t (push-string "from " result
)
1104 (setq result
(cons #\space
(dimension (caddr form
) result
'mdo
'mparen
(+ 6 w
) 0))
1105 w
(+ 6 w width
) h
(max h height
) d
(max d depth
))))
1106 (setq form
(cdddr form
))
1107 (cond ((equal 1 (car form
)))
1108 ((not (null (car form
)))
1109 (push-string "step " result
)
1110 (setq result
(cons #\space
(dimension (car form
) result
'mdo
'mparen
(+ 6 w
) 0))
1111 w
(+ 6 w width
) h
(max h height
) d
(max d depth
)))
1112 ((not (null (cadr form
)))
1113 (push-string "next " result
)
1114 (setq result
(cons #\space
(dimension (cadr form
) result
'mdo
'mparen
(+ 6 w
) 0))
1115 w
(+ 6 w width
) h
(max h height
) d
(max d depth
))))
1116 (cond ((not (null (caddr form
)))
1117 (push-string "thru " result
)
1118 (setq result
(cons #\space
(dimension (caddr form
) result
'mdo
'mparen
(+ 6 w
) 0))
1119 w
(+ 6 w width
) h
(max h height
) d
(max d depth
) brkflag t
)))
1120 (cond ((not (null (cadddr form
)))
1121 (cond ((and (not (atom (cadddr form
))) (eq (caar (cadddr form
)) 'mnot
))
1122 (push-string "while " result
)
1123 (setq result
(cons #\space
(dimension (cadr (cadddr form
)) result
'mdo
'mparen
(+ 7 w
) 0))
1124 w
(+ 7 w width
) h
(max h height
) d
(max d depth
)))
1125 (t (push-string "unless " result
)
1127 (cons #\space
(dimension (cadddr form
) result
'mdo
'mparen
(+ 8 w
) 0))
1128 w
(+ 8 w width
) h
(max h height
) d
(max d depth
))))))
1129 (if brkflag
(checkbreak result w
))
1130 (push-string "do " result
)
1131 (setq result
(dimension (car (cddddr form
)) result
'mdo rop
(+ 4 w
) right
)
1132 width
(+ 4 w width
) height
(max h height
) depth
(max d depth
))
1136 (displa-def mdoin dim-mdoin
)
1137 (displa-def %mdoin dim-mdoin
)
1139 (defun dim-mdoin (form result
)
1140 (prog ((w 0) (h 0) ( d
0))
1141 (push-string "for " result
)
1142 (setq result
(dimension (cadr form
) result
'mdo
'mparen
4 0)
1143 w
(+ 4 width
) h height d depth
)
1144 (push-string " in " result
)
1145 (setq result
(dimension (caddr form
) result
'mdo
'mparen
(+ 4 w
) 0)
1146 w
(+ 4 w width
) h
(max h height
) d
(max d depth
))
1147 (setq form
(cdr (cddddr form
)))
1148 (cond ((not (null (car form
)))
1149 (push-string " thru " result
)
1150 (setq result
(dimension (car form
) result
'mdo
'mparen
(+ 6 w
) 0)
1151 w
(+ 6 w width
) h
(max h height
) d
(max d depth
))))
1152 (cond ((not (null (cadr form
)))
1153 (push-string " unless " result
)
1154 (setq result
(dimension (cadr form
) result
'mdo
'mparen
(+ 8 w
) 0)
1155 w
(+ 8 w width
) h
(max h height
) d
(max d depth
))))
1156 (push-string " do " result
)
1157 (setq result
(dimension (caddr form
) result
'mdo rop
(+ 4 w
) right
)
1158 width
(+ 4 w width
) height
(max h height
) depth
(max d depth
))
1161 (displa-def mprogn dimension-match
"(" ")")
1162 (displa-def %mprogn dimension-match
"(" ")")
1163 (displa-def mlist dimension-match
"[" "]")
1164 (displa-def %mlist dimension-match
"[" "]")
1165 (displa-def mangle dimension-match
"<" ">")
1166 (displa-def %mangle dimension-match
"<" ">")
1167 (displa-def mcomma dimension-nary
", " 10.
10.
)
1168 (displa-def %mcomma dimension-nary
", " 10.
10.
)
1169 (displa-def mabs dim-mabs
)
1170 (displa-def %mabs dim-mabs
)
1172 (defvar mabs-char-unicode
1173 (get-unicode-char :box-drawings-light-vertical
))
1175 ;; There is wired knowledge of character offsets here.
1177 (defvar *d-box-char-unicode-horz
*
1178 (get-unicode-char :box-drawings-double-horizontal
))
1179 (defvar *d-box-char-unicode-vert
*
1180 (get-unicode-char :box-drawings-double-vertical
))
1181 (defvar *d-box-char-unicode-upper-left
*
1182 (get-unicode-char :box-drawings-double-down-and-right
))
1183 (defvar *d-box-char-unicode-upper-right
*
1184 (get-unicode-char :box-drawings-double-down-and-left
))
1185 (defvar *d-box-char-unicode-lower-right
*
1186 (get-unicode-char :box-drawings-double-up-and-left
))
1187 (defvar *d-box-char-unicode-lower-left
*
1188 (get-unicode-char :box-drawings-double-up-and-right
))
1190 (defun dim-mabs (form result
&aux arg bar mabs-char
)
1191 (setq mabs-char
(if (display2d-unicode-enabled) mabs-char-unicode
(car (coerce $absboxchar
'list
))))
1192 (setq arg
(dimension (cadr form
) nil
'mparen
'mparen nil
0))
1193 (cond ((or (> (+ 2 width
) $linel
) (and (= 1 height
) (= 0 depth
)))
1194 (dimension-function form result
))
1195 (t (setq width
(+ 2 width
))
1196 (update-heights height depth
)
1197 (setq bar
`(d-vbar ,height
,depth
,mabs-char
))
1198 (cons bar
(nconc arg
(cons bar result
))))))
1200 (displa-def $matrix dim-$matrix
)
1201 (displa-def %matrix dim-$matrix
)
1203 (defun dim-$matrix
(form result
)
1204 (prog (dmstr rstr cstr consp cols
)
1205 (setq cols
(if ($listp
(cadr form
)) (length (cadr form
)) 0))
1206 (if (or (null (cdr form
))
1207 (memalike '((mlist simp
)) (cdr form
))
1208 ;; Check if the matrix has lists as rows with a equal number of
1210 (dolist (row (cdr form
))
1211 (if (or (not ($listp row
))
1212 (not (eql cols
(length row
))))
1214 ;; The matrix is not well formed. Display the matrix in linear mode.
1215 (return (dimension-function form result
)))
1216 (do ((l (cdadr form
) (cdr l
))) ((null l
))
1217 (setq dmstr
(cons nil dmstr
) cstr
(cons 0 cstr
)))
1218 (do ((r (cdr form
) (cdr r
)) (h1 0) (d1 0))
1219 ((or consp
(null r
))
1221 (do ((cs cstr
(cdr cs
))) ((null cs
)) (setq width
(+ 2 (car cs
) width
)))
1222 (if (display2d-unicode-enabled)
1223 (setq h1
(1+ (+ h1 d1
)) depth
(truncate h1
2) height
(- h1 depth
))
1224 (setq h1
(1- (+ h1 d1
)) depth
(truncate h1
2) height
(- h1 depth
))))
1225 (do ((c (cdar r
) (cdr c
))
1227 (cs cstr
(cdr cs
)) (dummy) (h2 0) (d2 0))
1228 ((null c
) (setq d1
(+ d1 h1 h2
) h1
(1+ d2
)))
1229 (setq dummy
(dimension (car c
) nil
'mparen
'mparen nil
0)
1230 h2
(max h2 height
) d2
(max d2 depth
))
1231 (cond ((not (checkfit (+ 14. width
))) (setq consp t
) (return nil
))
1232 (t (rplaca nc
(cons (list* width height depth dummy
) (car nc
)))
1233 (rplaca cs
(max width
(car cs
))))))
1234 (setq rstr
(cons d1 rstr
)))
1235 (if (> (+ height depth
) (length linearray
))
1238 (cond ((and (not consp
) (checkfit (+ 2 width
)))
1239 (matout dmstr cstr rstr result
))
1240 ((and (not consp
) (<= level
2)) (colout form result
))
1241 (t (dimension-function form result
))))))
1243 (defun matout (dmstr cstr rstr result
)
1244 (push `(d-matrix left
,height
,depth
) result
)
1245 (push #\space result
)
1246 (do ((d dmstr
(cdr d
)) (c cstr
(cdr c
)) (w 0 0))
1248 (do ((d (car d
) (cdr d
)) (r rstr
(cdr r
))) ((null d
))
1249 (rplaca (cddar d
) (- height
(car r
) (if (display2d-unicode-enabled) 1 0)))
1250 (rplaca (cdar d
) (- (truncate (- (car c
) (caar d
)) 2) w
))
1251 (setq w
(truncate (+ (car c
) (caar d
)) 2))
1252 (rplaca d
(cdar d
)))
1253 (setq result
(cons (list (+ 2 (- (car c
) w
)) 0) (nreconc (car d
) result
))))
1254 (setq width
(+ 2 width
))
1255 (update-heights height depth
)
1256 (rplaca (car result
) (1- (caar result
)))
1257 (push `(d-matrix right
,height
,depth
) result
)
1260 (defun colout (form result
)
1263 (loop for k from
1 to
($length
($first form
))
1264 collect
(list '(mequal) (format nil
" Col ~d" k
) ($col form k
))))
1267 (displa-def mbox dim-mbox
)
1268 (displa-def %mbox dim-mbox
)
1270 (defun dim-mbox (form result
&aux dummy
)
1271 (setq dummy
(dimension (cadr form
) nil
'mparen
'mparen nil
0))
1272 (cond ((not (checkfit (+ 2 width
)))
1273 (dimension-function (cons '($box
) (cdr form
)) result
))
1274 (t (push `(d-box ,height
,depth
,width
,(nreverse dummy
)) result
)
1275 (setq width
(+ 2 width
) height
(1+ height
) depth
(1+ depth
))
1276 (update-heights height depth
)
1279 (displa-def mlabox dim-mlabox
)
1280 (displa-def %mlabox dim-mlabox
)
1282 (defun dim-mlabox (form result
)
1283 (if (display2d-unicode-enabled)
1284 (dim-mlabox-unicode form result
)
1285 (dim-mlabox-ascii form result
)))
1287 (defun dim-mlabox-unicode (form result
)
1289 (setq dummy
(dimension (cadr form
) nil
'mparen
'mparen nil
0))
1290 (cond ((not (checkfit (+ 2 width
)))
1291 (return (dimension-function (cons '($box
) (cdr form
)) result
))))
1292 (setq width
(+ 2 width
) height
(1+ height
) depth
(1+ depth
))
1294 (cons (do ((l (mapcar #'(lambda (l) (char (symbol-name l
) 0))
1295 (makstring (caddr form
))) (cdr l
))
1297 ((or (null l
) (= width w
))
1298 (cons 0 (cons (1- height
)
1300 (cons *d-box-char-unicode-upper-right
* (cons `(d-hbar ,(- width w
1) ,*d-box-char-unicode-horz
*) nl
)))
1302 (setq nl
(cons (car l
) nl
) w
(1+ w
)))
1304 (setq result
(nconc dummy
(list* `(d-vbar ,(1- height
) ,(1- depth
) ,*d-box-char-unicode-vert
*)
1305 (list (- width
) 0) result
)))
1306 (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
))
1307 (setq result
(list* `(d-vbar ,(1- height
) ,(1- depth
) ,*d-box-char-unicode-vert
*) '(-1 0) result
))
1308 (update-heights height depth
)
1311 (defun dim-mlabox-ascii (form result
)
1313 (setq dummy
(dimension (cadr form
) nil
'mparen
'mparen nil
0))
1314 (cond ((not (checkfit (+ 2 width
)))
1315 (return (dimension-function (cons '($box
) (cdr form
)) result
))))
1316 (setq width
(+ 2 width
) height
(1+ height
) depth
(1+ depth
))
1317 (setq ch
(car (coerce $boxchar
'list
)))
1319 (cons (do ((l (mapcar #'(lambda (l) (char (symbol-name l
) 0))
1320 (makstring (caddr form
))) (cdr l
))
1322 ((or (null l
) (= width w
))
1323 (cons 0 (cons (1- height
)
1325 (cons `(d-hbar ,(- width w
) ,ch
) nl
))
1327 (setq nl
(cons (car l
) nl
) w
(1+ w
)))
1329 (setq result
(nconc dummy
(list* `(d-vbar ,(1- height
) ,(1- depth
) ,ch
)
1330 (list (- width
) 0) result
)))
1331 (setq result
(cons (list (- 1 width
) (- depth
) `(d-hbar ,width
,ch
)) result
))
1332 (setq result
(list* `(d-vbar ,(1- height
) ,(1- depth
) ,ch
) '(-1 0) result
))
1333 (update-heights height depth
)
1336 (displa-def mtext dim-mtext
1 1)
1337 (displa-def %mtext dim-mtext
1 1)
1338 (defprop mtext dimnary-mtext dimension-nary-helper
)
1340 (defun dim-mtext (form result
)
1341 (if (null (cddr form
)) (dimension (cadr form
) result lop rop
0 0)
1342 (dimension-nary form result
)))
1344 (displa-def mlabel dim-mlabel
0 0)
1345 (displa-def %mlabel dim-mlabel
0 0)
1346 (setf (get 'mlabel
'wxxml
) 'wxxml-mlable
) ;; backwards-compatibility for wxMaxima
1348 (defun dim-mlabel (form result
)
1349 (prog (dummy (w 0) (h 0) (d 0))
1350 (cond ((eq nil
(cadr form
)) (setq w
0 h
0 d
0))
1351 (mratp (setq result
(append mratp
(if *display-labels-p
*
1352 (dimension-paren (cadr form
) result
)))
1353 w
(+ 4 width
) h height d depth
))
1354 (t (setq result
(cons #\space
(if *display-labels-p
*
1355 (dimension-paren (cadr form
) result
)))
1356 w
(1+ width
) h height d depth
)))
1357 (let ((level $linel
)) (checkbreak result w
))
1358 (setq dummy
(list 0 0))
1359 (setq result
(dimension (caddr form
) (cons dummy result
) 'mlabel rop w right
))
1360 (cond ((and (not $leftjust
) (= 0 bkptout
))
1361 (rplaca dummy
(max 0 (- (truncate (- $linel width
) 2) w
)))
1362 (setq width
(+ (car dummy
) width
))))
1363 (setq width
(+ w width
) height
(max h height
) depth
(max d depth
))
1366 (defprop mparen -
1. lbp
)
1367 (defprop mparen -
1. rbp
)
1369 (defun checkrat (form)
1370 (cond ((atom form
) nil
)
1371 ((and (not (atom (car form
))) (eq (caar form
) 'mrat
))
1372 (if (member 'trunc
(cdar form
) :test
#'eq
)
1373 '(#\space
#\
/ #\T
#\
/)
1374 '(#\space
#\
/ #\R
#\
/)))
1375 ((and (not (atom (car form
))) (eq (caar form
) 'mpois
))
1376 '(#\space
#\
/ #\P
#\
/))
1378 (do ((l (cdr form
) (cdr l
)))
1381 (merror (intl:gettext
"display: not a well-formed Maxima expression: ~S") form
))
1382 ((setq form
(checkrat (car l
)))
1386 (or (not break
) (<= (- (+ w break right
1) bkptwd
) $linel
)))
1388 (defun checkbreak (result w
)
1390 ((> (- (setq w
(+ w break
)) bkptout
) $linel
)
1391 (if (or (null bkpt
) (eq result bkpt
))
1392 (merror (intl:gettext
"display: failed to break up a long expression.~%display: change '$linel' slightly and try again.")))
1393 (do ((l result
(cdr l
)))
1394 ;; THE NEED FOR EQUAL HERE IS PROBABLY THE SYMPTOM OF A BUG IN ECL !!
1395 ;; PROBABLY RELATED TO SIDE-EFFECTS OF NRECONC, RPLACD, ETC !!
1396 ((#+ecl equal
#-ecl eq bkpt
(cdr l
)) (rplacd l nil
))
1398 ;; MEANING OF FOLLOWING MESSAGE IS OBSCURE.
1399 (merror (intl:gettext
"display: 'checkbreak' not found."))))
1401 (setq lines
(1+ lines
)
1402 bkpt result bkptout bkptwd bkptwd w
1403 bkptht maxht bkptdp maxdp bkptlevel level maxht
1 maxdp
0))
1404 ((or (null bkpt
) (<= level bkptlevel
) (> (truncate $linel
2) (- bkptwd bkptout
)))
1405 (setq bkpt result bkptwd w bkptlevel level
1406 bkptht
(max maxht bkptht
) bkptdp
(max maxdp bkptdp
) maxht
1 maxdp
0))))
1408 (defun forcebreak (result w
)
1410 (setq lines
(+ 2 lines
)
1415 (defun update-heights (ht* dp
*)
1417 (setq maxht
(max maxht ht
*)
1418 maxdp
(max maxdp dp
*))))
1420 ;;; BKPT dimension structure for last breakpoint saved
1421 ;;; BKPTWD width at last bkpt
1422 ;;; BKPTHT height of current line to last bkpt
1423 ;;; BKPTDP depth of current line to last bkpt
1424 ;;; BKPTOUT width of stuff already output
1426 ;;; MAXHT height from last bkpt saved to current point
1427 ;;; MAXDP depth from last bkpt saved to current point
1429 ;;; BREAK width up to last call to DIMENSION
1430 ;;; RESULT dimension structure to current point minus output
1431 ;;; W width from last call to DIMENSION to current point
1433 ;; Code above this point deals with dimensioning and constructing
1434 ;; up dimension strings. Code past this point deals with printing
1437 ;; <dimension string> ::= () | (<string element> . <dimension string>)
1438 ;; <string element> ::= character |
1439 ;; (<column-relative> <row-relative> . <dimension string>) |
1440 ;; (<drawing function> . args)
1441 ;; <column-relative> ::= <fixnum>
1442 ;; <row-relative> ::= <fixnum>
1443 ;; <drawing function> ::= D-HBAR | D-VBAR | D-INTEGRALSIGN | ...
1445 ;; When a character appears in a dimension string, it is printed and
1446 ;; the cursor moves forward a single position. (The variable OLDCOL is
1447 ;; incremented) When a form with a fixnum car is encountered, the
1448 ;; first two elements of the form are taken to be relative displacements
1449 ;; for OLDCOL and OLDROW. *** NOTE *** After drawing the cddr of the form,
1450 ;; OLDROW is reset to its original value, but OLDCOL is left in the new
1451 ;; position. Why this is done is beyond me. It only appears to complicate
1454 ;; When a <drawing function> is invoked, the first argument passed to it is a
1455 ;; flag which is T for linear output and NIL for 2D output. A
1456 ;; <drawing function> is also expected to return the new column position.
1458 (defun output (result w
)
1459 ;; The following is a hack to attempt to determine if we're on an
1460 ;; interactive terminal, in which case the user's hitting of the ENTER
1461 ;; key will have caused a newline to be displayed already.
1462 #+(or gcl clisp
) (cond ((not (equal *query-io
* *standard-input
*)) (fresh-line)))
1463 #-
(or gcl clisp
) (cond ((not (interactive-stream-p *standard-input
*)) (fresh-line)))
1465 ;; If console output is disabled, don't output anything.
1467 ((> (+ bkptht bkptdp
) (length linearray
))
1468 ;; I suppose we could reallocate LINEARRAY to some larger size and keep going here ...
1469 (merror (intl:gettext
"display: expression is too tall to be displayed.")))
1471 (output-linear (nreverse result
) w
))))
1473 ;; Output function for terminals without cursor positioning capability.
1474 ;; Characters are drawn into LINEARRAY instead. Each element of LINEARRAY is a
1475 ;; list -- the car is how many spaces to indent; the cdr is a list of
1476 ;; characters to draw. After drawing into this array, lines are printed one at
1477 ;; a time. This is used for printing terminals and when writing to files.
1478 ;; Block mode i/o isn't needed since PRINC is used instead of WRITE-CHAR and
1481 (defun output-linear (result w
)
1482 (draw-linear result bkptdp w
)
1483 (do ((i (1- (+ bkptht bkptdp
)) (1- i
)))
1485 (cond ((null (aref linearray i
)))
1486 (t (output-linear-one-line i
)))))
1488 (defun output-linear-one-line (i)
1490 (setq line
(aref linearray i
)
1491 line
(nreverse (cdr line
))
1493 (setf (aref linearray i
) nil
)
1495 (loop for v in
(cdr line
) do
(write-char v
#+(or sbcl cmu
) *standard-output
*))
1498 ;; Move the cursor over N spaces to the left by outputting spaces.
1499 ;; This function assumes that the cursor is in the left margin when
1500 ;; it is called. This is only called from OUTPUT-LINEAR, so it is
1501 ;; used only for printing terminals or for file output.
1506 (write-char #\space
#+(or sbcl cmu
) *standard-output
*)
1509 (defun draw-linear (dmstr oldrow oldcol
)
1510 "This puts the LINE lists into LINEARRAY ready to be drawn.
1511 Each LINE consists of first an initial number of columns to space
1512 and then the characters to be printed.
1513 oldrow and oldcol are the starting points for the the (dx,dy) offsets
1514 given in the dimension string DMSTR. It does not check that oldrow
1515 is big enough for possible negative y offsets in DMSTR, but BKPTDP is the
1516 right global to use for oldrow."
1519 (cond ((atom (car dmstr
))
1520 (setq line
(aref linearray oldrow
))
1521 (cond ((null line
) (setq line
(list oldcol
)))
1523 (setq n
(car line
) line
(cdr line
))
1529 ((or (null dmstr
) (not (atom (car dmstr
))))
1530 (setf (aref linearray oldrow
) (cons oldcol line
)))
1532 (push (car dmstr
) line
)
1534 ((integerp (caar dmstr
))
1535 ;; Why update OLDCOL and not OLDROW? Should either update both
1536 ;; (requiring multiple value return) or neither (analogous to lambda
1538 (setq oldcol
(draw-linear (reverse (cddar dmstr
))
1539 (+ oldrow
(cadar dmstr
))
1540 (+ oldcol
(caar dmstr
))))
1542 (t (setq oldcol
(apply (caar dmstr
) t
(cdar dmstr
)))
1544 ;; Be sure to return this.
1547 ;; Special symbol drawing functions -- lines, boxes, summation signs, etc.
1548 ;; Every drawing function must take at least one argument. The first
1549 ;; argument is T if equations must be printed line-by-line. Otherwise,
1550 ;; draw them using cursor movement, character graphics, or line graphics
1553 ;; Most of these functions just invoke DRAW-XXX on some constant
1554 ;; list structure, so be careful about NREVERSEing. In other cases,
1555 ;; stuff is consed only for the linear case, but direct calls are used
1556 ;; in the 2D case. This should work for both cases. (See end of
1559 (defvar d-hbar-char-unicode
1560 (get-unicode-char :box-drawings-light-horizontal
))
1561 (defvar d-hbar-char-ascii
#\-
)
1563 (defun d-hbar (linear? w
&optional char
&aux nl
)
1564 (declare (ignore linear?
))
1566 (setq char
(if (display2d-unicode-enabled) d-hbar-char-unicode d-hbar-char-ascii
)))
1569 (draw-linear nl oldrow oldcol
))
1571 ;; Notice that in all of the height computations, an offset of 2 is added or
1572 ;; subtracted to the y-dimension. This is to get the lines to fit within the
1573 ;; character cell precisely and not get clipped when moving things around in
1574 ;; the equation editor.
1576 (defvar d-vbar-char-unicode
1577 (get-unicode-char :box-drawings-light-vertical
))
1578 (defvar d-vbar-char-ascii
#\|
)
1580 (defun d-vbar (linear? h d
&optional char-body char-head char-foot
)
1581 (declare (ignore linear?
))
1582 (when (null char-body
)
1583 (setq char-body
(if (display2d-unicode-enabled) d-vbar-char-unicode d-vbar-char-ascii
)))
1584 (when (null char-head
)
1585 (setq char-head char-body
))
1586 (when (null char-foot
)
1587 (setq char-foot char-body
))
1589 (do ((i (- h
2) (1- i
))
1590 (nl-head `((0 ,(1- h
) ,char-head
))))
1591 ((or (and (display2d-unicode-enabled) (<= i d
)) (and (not (display2d-unicode-enabled)) (< i d
)))
1592 (when (and (display2d-unicode-enabled) (= i d
))
1593 (push `(-1 ,i
,char-foot
) nl-head
))
1594 (draw-linear (nreverse nl-head
) oldrow oldcol
))
1595 (push `(-1 ,i
,char-body
) nl-head
)))
1597 (defvar d-integralsign-string-unicode
1598 #+lisp-unicode-capable
1599 `((0 2 ,(get-unicode-char :top-half-integral
))
1600 (-1 1 ,(get-unicode-char :integral-extension
))
1601 (-1 0 ,(get-unicode-char :integral-extension
))
1602 (-1 -
1 ,(get-unicode-char :integral-extension
))
1603 (-1 -
2 ,(get-unicode-char :bottom-half-integral
))))
1605 (defvar d-integralsign-string-ascii
`((0 2 #\
/) (-1 1 #\|
) (-1 0 #\|
) (-1 -
1 #\|
) (-1 -
2 #\
/)))
1607 (defun d-integralsign (linear?
&aux dmstr
)
1608 (declare (ignore linear?
))
1609 (setq dmstr
(if (display2d-unicode-enabled) d-integralsign-string-unicode d-integralsign-string-ascii
))
1610 (draw-linear dmstr oldrow oldcol
))
1612 (defvar d-prodsign-unicode-dmstr
1613 #+lisp-unicode-capable
1614 `((0 2 (d-hbar 1) ,(get-unicode-char :box-drawings-light-down-and-horizontal
) (d-hbar 3)
1615 ,(get-unicode-char :box-drawings-light-down-and-horizontal
) (d-hbar 1))
1616 (-6 0) (d-vbar 2 1) #\space
#\space
#\space
(d-vbar 2 1) (0 0)))
1618 (defvar d-prodsign-ascii-dmstr
1619 '((0 2 (d-hbar 5 #\_
)) (-5 0) (d-vbar 2 1 #\|
) #\space
#\space
#\space
1620 (d-vbar 2 1 #\|
) (0 0)))
1622 (defun d-prodsign (linear?
&aux dmstr
)
1623 (declare (ignore linear?
))
1624 (setq dmstr
(if (display2d-unicode-enabled) d-prodsign-unicode-dmstr d-prodsign-ascii-dmstr
))
1625 (draw-linear dmstr oldrow oldcol
))
1627 (defvar d-sumsign-unicode-dmstr
1628 #+lisp-unicode-capable
1629 `((0 2 (d-hbar 4 ,(get-unicode-char :low-line
)))
1630 (-4 1 ,(get-unicode-char :box-drawings-light-diagonal-upper-left-to-lower-right
))
1631 ,(get-unicode-char :mathematical-right-angle-bracket
)
1632 (-2 -
1 ,(get-unicode-char :box-drawings-light-diagonal-upper-right-to-lower-left
))
1633 (-1 -
2 (d-hbar 4 ,(get-unicode-char :overline
)))))
1635 (defvar d-sumsign-ascii-dmstr
'((0 2 (d-hbar 4 #\_
)) (-4 1 #\\) #\
> (-2 -
1 #\
/) (-1 -
2 (d-hbar 4 #\-
))))
1637 (defun d-sumsign (linear?
&aux dmstr
)
1638 (declare (ignore linear?
))
1639 (setq dmstr
(if (display2d-unicode-enabled) d-sumsign-unicode-dmstr d-sumsign-ascii-dmstr
))
1640 (draw-linear dmstr oldrow oldcol
))
1642 ;; Notice how this calls D-VBAR in the non-graphic case. The entire output
1643 ;; side should be structured this way, with no consing of intermediate
1644 ;; dimension strings.
1646 (defun d-matrix (linear? direction h d
)
1647 (if (display2d-unicode-enabled)
1648 (d-matrix-unicode linear? direction h d
)
1649 (d-matrix-ascii linear? direction h d
)))
1651 (defvar d-matrix-char-unicode-horz
1652 (get-unicode-char :box-drawings-light-horizontal
))
1653 (defvar d-matrix-char-unicode-vert
1654 (get-unicode-char :box-drawings-light-vertical
))
1655 (defvar d-matrix-char-unicode-upper-left
1656 (get-unicode-char :box-drawings-light-down-and-right
))
1657 (defvar d-matrix-char-unicode-upper-right
1658 (get-unicode-char :box-drawings-light-down-and-left
))
1659 (defvar d-matrix-char-unicode-lower-right
1660 (get-unicode-char :box-drawings-light-up-and-left
))
1661 (defvar d-matrix-char-unicode-lower-left
1662 (get-unicode-char :box-drawings-light-up-and-right
))
1664 (defun d-matrix-unicode (linear? direction h d
)
1665 (declare (ignore linear?
))
1667 ((char-upper-corner (if (eq direction
'right
) d-matrix-char-unicode-upper-right d-matrix-char-unicode-upper-left
))
1668 (char-lower-corner (if (eq direction
'right
) d-matrix-char-unicode-lower-right d-matrix-char-unicode-lower-left
))
1669 (dmstr `((d-vbar ,h
,d
,d-matrix-char-unicode-vert
,char-upper-corner
,char-lower-corner
))))
1670 (draw-linear dmstr oldrow oldcol
)))
1672 (defun d-matrix-ascii (linear? direction h d
)
1673 (d-vbar linear? h d
(car (coerce (if (eq direction
'right
)
1677 (defun d-box (linear? h d w body
)
1678 (declare (ignore linear?
))
1679 (if (display2d-unicode-enabled)
1680 (d-box-unicode h d w body
)
1681 (d-box-ascii h d w body
)))
1683 (defun d-box-unicode (h d w body
&aux dmstr
)
1684 (setq dmstr
`((0 ,h
,*d-box-char-unicode-upper-right
* (d-hbar ,w
,*d-box-char-unicode-horz
*) ,*d-box-char-unicode-upper-left
*)
1686 (d-vbar ,h
,d
,*d-box-char-unicode-vert
*)
1688 (,(- (1+ w
)) ,(- (1+ d
)) ,*d-box-char-unicode-lower-right
* (d-hbar ,w
,*d-box-char-unicode-horz
*) ,*d-box-char-unicode-lower-left
*)
1690 (d-vbar ,h
,d
,*d-box-char-unicode-vert
*)))
1691 (draw-linear dmstr oldrow oldcol
))
1693 (defun d-box-ascii (h d w body
&aux
(char 0) dmstr
)
1694 (setq char
(car (coerce $boxchar
'list
)))
1695 (setq dmstr
`((0 ,h
(d-hbar ,(+ 2 w
) ,char
))
1697 (d-vbar ,h
,d
,char
)
1699 (,(- (1+ w
)) ,(- (1+ d
)) (d-hbar ,(+ w
2) ,char
))
1701 (d-vbar ,h
,d
,char
)))
1702 (draw-linear dmstr oldrow oldcol
))
