github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-03-23 17:22:35 +00:00
Code Issues Releases Wiki Activity
Files
2df88f35cb340263404e0153e6d22b5c6d5e9827
PDP-10.its/src/mrg/displa.780
Eric Swenson bf8f96b837 This fixes the declare command in macsyma. 
Also updates a bunch of Macsyma sources to latest versions, which
was needed to get declare working with consistent sources.
Resolves #960.
2018-07-08 07:06:20 -07:00

1589 lines
60 KiB
Common Lisp
Raw Blame History

This file contains invisible Unicode characters
This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
;; -*- Mode: Lisp; Package: Macsyma; -*-
;; (c) Copyright 1976, 1983 Massachusetts Institute of Technology
;; All Rights Reserved.
;; Enhancements (c) Copyright 1983 Symbolics Inc.
;; All Rights Reserved.
;; The data and information in the Enhancements is proprietary to, and
;; a valuable trade secret of, SYMBOLICS, INC., a Delaware corporation.
;; It is given in confidence by SYMBOLICS, and may not be used as the basis
;; of manufacture, or be reproduced or copied, or distributed to any other
;; party, in whole or in part, without the prior written consent of SYMBOLICS.
(macsyma-module displa)
;; N.B. You must read the macro file before reading this file.
(load-macsyma-macros displm)
;; Read time parameters. ITS only.
#.(SETQ %TDCRL #O 207)
#.(SETQ %TDLF #O 212)
#.(SETQ %TDQOT #O 215)
#.(SETQ %TDMV0 #O 217)
;; Global variables defined in this file. Most of these are switches
;; controlling display format
(DEFMVAR CHARACTER-GRAPHICS-TTY NIL
"If T, then console can draw lines and math symbols using
an extended character set.")
(DEFMVAR LINE-GRAPHICS-TTY NIL
"If T, then console can draw lines and math symbols using
vector graphics.")
(DEFMVAR $CURSORDISP T
"If T, causes expressions to be drawn by the displayer in logical
sequence. This only works with a console which can do cursor
movement.
If NIL, expressions are simply printed line by line.
CURSORDISP is NIL when a WRITEFILE is in effect."
NO-RESET)
(DEFMVAR $STARDISP NIL
"Causes factors of products are separated by * when displayed.")
(DEFMVAR $LEFTJUST NIL
"Causes equations to be drawn left justified rather than centered.
For slow consoles.")
(DEFMVAR $DISPLAY2D T
"Causes equations to be drawn in two dimensions. Otherwise, drawn
linearly.")
(DEFMVAR $LISPDISP NIL
"Causes symbols not having $ as the first character in their pnames
to be preceded with a ? when displayed.")
;; This may be flushed in the future if nobody dislikes the graphics crocks.
(DEFMVAR $LINEDISP T
"Causes quotients, matrices, and boxes to be drawn with straight
lines, if possible. This will work on graphic terminals or
video terminals with line drawing character sets. If enabled,
the values of LMXCHAR, RMXCHAR, ABSBOXCHAR, and BOXCHAR are ignored.")
(DEFMVAR $DERIVABBREV NIL)
(DEFMVAR $NOUNDISP NIL)
(DEFMVAR STRINGDISP NIL
"Causes strings to be bracketed in double quotes when displayed.
Normally this is off, but is turned on when a procedure definition is
being displayed.")
#+Franz
(defmvar $typeset nil
"Causes equations to be output in a typesetter readable form if t.")
(DEFMVAR DISPLAYP NIL "Is T when inside of DISPLA")
;; More messages which appear during the middle of display. Different
;; from those which appear during typein. MOREMSG and MOREFLUSH get
;; bound to these.
(DEFVAR D-MOREMSG "--More Display?--")
(DEFVAR D-MOREFLUSH "--Display Flushed--")
;; Parameters which control how boxes, absolute value signs,
;; evaluation-at-a-point bars, and matrices are drawn.
(DEFMVAR $BOXCHAR '|&/"|
"Character used for drawing boxes.")
(DEFMVAR $ABSBOXCHAR '|&!|
"Character used for drawing absolute value signs and 'evaluation at' signs.")
(DEFMVAR $LMXCHAR '|&[|
"Character used for drawing the left edge of a matrix.")
(DEFMVAR $RMXCHAR '|&]|
"Character used for drawing the right edge of a matrix.")
;; These variables are bound within Macsyma Listeners since they are different
;; for each window. Set them here, anyway, so that RETRIEVE can be called from
;; top level. The size of TOP-WINDOW is wired in here.
#+LISPM (SETQ SMART-TTY T RUBOUT-TTY T LINE-GRAPHICS-TTY T
SCROLLP NIL)
#+LISPM (MULTIPLE-VALUE (LINEL TTYHEIGHT)
(FUNCALL TERMINAL-IO ':SIZE-IN-CHARACTERS))
;; Default settings for random systems.
#-(OR ITS LISPM)
(SETQ SMART-TTY NIL RUBOUT-TTY NIL SCROLLP T
LINEL 79. $LINEL 79. TTYHEIGHT 24.)
;;;Multics Lisp doesn't fully expand top level Macros.
(DEFVAR LINEARRAY #-Multics(MAKE-LINEARRAY 80.)
#+Multics (*array nil t 80.))
(DEFMFUN DISPLA (FORM)
(IF (OR (NOT #.TTYOFF) #.WRITEFILEP)
(cond #+Franz ($typeset (apply #'$photot (list form)))
($DISPLAY2D
(LET ((DISPLAYP T)
(LINEARRAY (IF DISPLAYP (MAKE-LINEARRAY 80.) LINEARRAY))
(MRATP (CHECKRAT FORM))
(#.WRITEFILEP #.WRITEFILEP)
(MAXHT 1) (MAXDP 0) (WIDTH 0)
(HEIGHT 0) (DEPTH 0) (LEVEL 0) (SIZE 2)
(BREAK 0) (RIGHT 0) (LINES 1) BKPT
(BKPTWD 0) (BKPTHT 1) (BKPTDP 0) (BKPTOUT 0)
(BKPTLEVEL 0) IN-P
(MOREFLUSH D-MOREFLUSH)
MORE-^W
(MOREMSG D-MOREMSG))
(UNWIND-PROTECT
(PROGN (SETQ FORM (DIMENSION FORM NIL 'MPAREN 'MPAREN 0 0))
(CHECKBREAK FORM WIDTH)
(OUTPUT FORM (IF (AND (NOT $LEFTJUST) (= 2 LINES))
(- LINEL (- WIDTH BKPTOUT))
0))
(IF (AND SMART-TTY (NOT (AND SCROLLP (NOT $CURSORDISP)))
(> (CAR (CURSORPOS)) (- TTYHEIGHT 3)))
(LET (#.writefilep) (MTERPRI))))
;; make sure the linearray gets cleared out.
(CLEAR-LINEARRAY))))
(T (LINEAR-DISPLA FORM)))))
(DEFMVAR $DISPLAY_FORMAT_INTERNAL NIL
"Setting this TRUE can help give the user a greater understanding
of the behavior of macsyma on certain of his problems,
especially those involving roots and quotients")
(DEFUN NFORMAT-CHECK (FORM)
(IF (AND $DISPLAY_FORMAT_INTERNAL
(NOT (OR (ATOM FORM) (ATOM (CAR FORM)) (SPECREPP FORM))))
FORM
(NFORMAT FORM)))
(DEFUN DIMENSION (FORM RESULT LOP ROP W RIGHT)
(LET ((LEVEL (1+ LEVEL)) (BREAK (IF (AND W BREAK) (+ W BREAK))))
(SETQ FORM (NFORMAT-CHECK FORM))
(COND ((ATOM FORM)
(DIMENSION-ATOM FORM RESULT))
((AND (ATOM (CAR FORM)) (SETQ FORM (CONS '(MPROGN) FORM)) NIL))
((OR (<= (LBP (CAAR FORM)) (RBP LOP)) (> (LBP ROP) (RBP (CAAR FORM))))
(DIMENSION-PAREN FORM RESULT))
((MEMQ 'ARRAY (CAR FORM)) (DIMENSION-ARRAY FORM RESULT))
((GET (CAAR FORM) 'DIMENSION)
(FUNCALL (GET (CAAR FORM) 'DIMENSION) FORM RESULT))
(T (DIMENSION-FUNCTION FORM RESULT)))))
(DEFVAR ATOM-CONTEXT 'DIMENSION-LIST)
;; bound by DIMENSION-ARRAY and DIMENSION-FUNCTION.
;; This ATOM-CONTEXT put in by GJC so that MCW could have a clean
;; hook by which to write his extensions for vector-underbars.
(DECLARE (*EXPR DIMENSION-ARRAY-OBJECT)) ; to be defined someplace else.
;; Referenced externally by RAT;FLOAT.
(DEFMFUN DIMENSION-ATOM (FORM RESULT)
(COND ((AND (SYMBOLP FORM) (GET FORM ATOM-CONTEXT))
(FUNCALL (GET FORM ATOM-CONTEXT) FORM RESULT))
#+LISPM
((STRINGP FORM) (DIMENSION-STRING (MAKESTRING FORM) RESULT))
((ARRAYP FORM)
(DIMENSION-ARRAY-OBJECT FORM RESULT))
(T (DIMENSION-STRING (MAKESTRING FORM) RESULT))))
;; Referenced externally by anyone who wants to display something as
;; a funny looking atom, e.g. Trace, Mformat.
(DEFMFUN DIMENSION-STRING (DUMMY RESULT &AUX CRP)
;; N.B. String is a list of fixnums.
(SETQ WIDTH 0 HEIGHT 1 DEPTH 0)
(DO L DUMMY (CDR L) (NULL L)
(INCREMENT WIDTH)
(IF (= (CAR L) #\NEWLINE) (SETQ CRP T)))
(IF (OR (AND (CHECKFIT WIDTH) (NOT CRP)) (NOT BREAK)) (NRECONC DUMMY RESULT)
(SETQ WIDTH 0)
(DO ((L DUMMY) (W (- LINEL (- BREAK BKPTOUT))))
((NULL L) (CHECKBREAK RESULT WIDTH) RESULT)
(SETQ DUMMY L L (CDR L))
(COND ((= (CAR DUMMY) #\NEWLINE)
(FORCEBREAK RESULT WIDTH)
(SETQ RESULT NIL W (+ LINEL WIDTH)))
(T (INCREMENT WIDTH)
(WHEN (AND (= W WIDTH) L)
(FORCEBREAK (CONS #/# RESULT) WIDTH)
(SETQ RESULT NIL W (+ LINEL WIDTH))
(INCREMENT WIDTH))
(SETQ RESULT (RPLACD DUMMY RESULT)))))))
(DEFMFUN MAKESTRING (ATOM)
(LET (DUMMY)
(COND ((NUMBERP ATOM) (EXPLODEN ATOM))
#+NIL
((NOT (SYMBOLP ATOM)) (EXPLODEN ATOM))
((AND (SETQ DUMMY (GET ATOM 'REVERSEALIAS))
(NOT (AND (MEMQ ATOM $ALIASES) (GET ATOM 'NOUN))))
(EXPLODEN DUMMY))
((NOT (EQ (GETOP ATOM) ATOM))
(SETQ DUMMY (EXPLODEN (GETOP ATOM)))
(IF (= #/& (CAR DUMMY))
(CONS #/" (NCONC (CDR DUMMY) (LIST #/")))
(CDR DUMMY)))
(T (SETQ DUMMY (EXPLODEN ATOM))
(COND ((NULL DUMMY) ())
((= #/$ (CAR DUMMY)) (CDR DUMMY))
((AND STRINGDISP (= #/& (CAR DUMMY)))
(CONS #/" (NCONC (CDR DUMMY) (LIST #/"))))
((OR (= #/% (CAR DUMMY)) (= #/& (CAR DUMMY))) (CDR DUMMY))
($LISPDISP (CONS #/? DUMMY))
(T DUMMY))))))
(DEFUN DIMENSION-PAREN (FORM RESULT)
(SETQ RESULT (CONS #/) (DIMENSION FORM (CONS #/( RESULT) 'MPAREN 'MPAREN 1 (1+ RIGHT))))
(SETQ WIDTH (+ 2 WIDTH))
RESULT)
(DEFUN DIMENSION-ARRAY (X RESULT)
(PROG (DUMMY BAS W H D SUB) (DECLARE (FIXNUM W H D))
(SETQ W 0)
(IF (EQ (CAAR X) 'MQAPPLY) (SETQ DUMMY (CADR X) X (CDR X))
(SETQ DUMMY (CAAR X)))
(COND ((OR (NOT $NOUNDISP) (NOT (SYMBOLP (CAAR X)))))
((AND (GET (CAAR X) 'VERB) (GET (CAAR X) 'ALIAS))
(PUSH-STRING "''" RESULT) (SETQ W 2))
((AND (GET (CAAR X) 'NOUN) (NOT (MEMQ (CAAR X) (CDR $ALIASES)))
(NOT (GET (CAAR X) 'REVERSEALIAS)))
(SETQ RESULT (CONS #/' RESULT) W 1)))
(SETQ SUB (LET ((LOP 'MPAREN) (ROP 'MPAREN) (BREAK NIL) (SIZE 1))
(DIMENSION-LIST X NIL))
W (+ W WIDTH) H HEIGHT D DEPTH)
(SETQ BAS (IF (AND (NOT (ATOM DUMMY)) (MEMQ 'ARRAY (CAR DUMMY)))
(LET ((BREAK NIL) (RIGHT 0)) (DIMENSION-PAREN DUMMY RESULT))
(LET ((ATOM-CONTEXT 'DIMENSION-ARRAY))
(DIMENSION DUMMY RESULT LOP 'MFUNCTION NIL 0))))
(COND ((NOT (CHECKFIT (SETQ WIDTH (+ W WIDTH))))
(RETURN (DIMENSION-FUNCTION (CONS '(SUBSCRIPT) (CONS DUMMY (CDR X))) RESULT)))
((= #/) (CAR BAS))
(SETQ RESULT (CONS (CONS 0 (CONS (- H) SUB)) BAS) DEPTH (MAX (+ H D) DEPTH)))
(T (SETQ RESULT (CONS (CONS 0 (CONS (- (+ DEPTH H)) SUB)) BAS)
DEPTH (+ H D DEPTH))))
(UPDATE-HEIGHTS HEIGHT DEPTH)
(RETURN RESULT)))
(DEFUN DIMENSION-FUNCTION (X RESULT)
(PROG (FUN W H D) (DECLARE (FIXNUM W H D))
(SETQ W 0)
(COND ((NOT $NOUNDISP))
((AND (GET (CAAR X) 'VERB) (GET (CAAR X) 'ALIAS))
(PUSH-STRING "''" RESULT) (SETQ W 2))
((AND (GET (CAAR X) 'NOUN) (NOT (MEMQ (CAAR X) (CDR $ALIASES)))
(NOT (GET (CAAR X) 'REVERSEALIAS)))
(SETQ RESULT (CONS #/' RESULT) W 1)))
(IF (EQ (CAAR X) 'MQAPPLY) (SETQ FUN (CADR X) X (CDR X)) (SETQ FUN (CAAR X)))
(SETQ RESULT (LET ((ATOM-CONTEXT 'DIMENSION-FUNCTION))
(DIMENSION FUN RESULT LOP 'MPAREN 0 1))
W (+ W WIDTH) H HEIGHT D DEPTH)
(COND ((NULL (CDR X))
(SETQ RESULT (LIST* #/) #/( RESULT) WIDTH (+ 2 W)))
(T (SETQ RESULT (LET ((LOP 'MPAREN) (ROP 'MPAREN)
(BREAK (IF BREAK (+ 1 W BREAK))))
(CONS #/) (DIMENSION-LIST X (CONS #/( RESULT))))
WIDTH (+ 2 W WIDTH) HEIGHT (MAX H HEIGHT) DEPTH (MAX D DEPTH))))
(RETURN RESULT)))
(DEFMFUN DIMENSION-PREFIX (FORM RESULT)
(PROG (DISSYM SYMLENGTH)
(DECLARE (FIXNUM SYMLENGTH))
(SETQ DISSYM (GET (CAAR FORM) 'DISSYM) SYMLENGTH (LENGTH DISSYM))
(SETQ RESULT
(DIMENSION (CADR FORM) (RECONC DISSYM RESULT) (CAAR FORM) ROP SYMLENGTH RIGHT)
WIDTH (+ SYMLENGTH WIDTH))
(RETURN RESULT)))
(DEFUN DIMENSION-LIST (FORM RESULT)
(PROG (W H D)
(DECLARE (FIXNUM W H D))
(SETQ RESULT (DIMENSION (CADR FORM) RESULT LOP 'MCOMMA 0 RIGHT)
W WIDTH H HEIGHT D DEPTH)
(DO L (CDDR FORM) (CDR L) (NULL L)
(PUSH-STRING ", " RESULT)
(INCREMENT W 2)
(CHECKBREAK RESULT W)
(SETQ RESULT (DIMENSION (CAR L) RESULT 'MCOMMA 'MCOMMA W RIGHT)
W (+ W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH)))
(SETQ WIDTH W HEIGHT H DEPTH D)
(RETURN RESULT)))
(DEFMFUN DIMENSION-INFIX (FORM RESULT)
(IF (OR (NULL (CDDR FORM)) (CDDDR FORM)) (WNA-ERR (CAAR FORM)))
(PROG (DISSYM SYMLENGTH W H D)
(DECLARE (FIXNUM SYMLENGTH W H D))
(SETQ DISSYM (GET (CAAR FORM) 'DISSYM) SYMLENGTH (LENGTH DISSYM)
RESULT (DIMENSION (CADR FORM) RESULT LOP (CAAR FORM) 0 SYMLENGTH)
W WIDTH H HEIGHT D DEPTH)
(SETQ RESULT (RECONC DISSYM RESULT))
(CHECKBREAK RESULT (+ SYMLENGTH W))
(SETQ RESULT (DIMENSION (CADDR FORM) RESULT (CAAR FORM) ROP (+ SYMLENGTH W) RIGHT)
WIDTH (+ W SYMLENGTH WIDTH) HEIGHT (MAX H HEIGHT) DEPTH (MAX D DEPTH))
(RETURN RESULT)))
(DEFMFUN DIMENSION-NARY (FORM RESULT)
;; If only 0 or 1 arguments, then print "*"() or "*"(A)
(COND ((NULL (CDDR FORM)) (DIMENSION-FUNCTION FORM RESULT))
(T (PROG (DISSYM SYMLENGTH W H D)
(DECLARE (FIXNUM SYMLENGTH W H D))
(SETQ DISSYM (GET (CAAR FORM) 'DISSYM)
SYMLENGTH (LENGTH DISSYM)
RESULT (DIMNARY (CADR FORM) RESULT LOP (CAAR FORM) (CAAR FORM) 0)
W WIDTH H HEIGHT D DEPTH)
(DO ((L (CDDR FORM) (CDR L))) (NIL)
(CHECKBREAK RESULT W)
(SETQ RESULT (RECONC DISSYM RESULT) W (+ SYMLENGTH W))
(COND ((NULL (CDR L))
(SETQ RESULT (DIMNARY (CAR L) RESULT (CAAR FORM) (CAAR FORM) ROP W)
WIDTH (+ W WIDTH) HEIGHT (MAX H HEIGHT) DEPTH (MAX D DEPTH))
(RETURN T))
(T (SETQ RESULT (DIMNARY (CAR L) RESULT (CAAR FORM)
(CAAR FORM) (CAAR FORM) W)
W (+ W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH)))))
(RETURN RESULT)))))
;; Check for (* A (* B C)) --> A*(B*C)
(DEFUN DIMNARY (FORM RESULT LOP OP ROP W)
(IF (AND (NOT (ATOM FORM)) (EQ (CAAR FORM) OP))
(DIMENSION-PAREN FORM RESULT)
(DIMENSION FORM RESULT LOP ROP W RIGHT)))
(DEFMFUN DIMENSION-POSTFIX (FORM RESULT)
(PROG (DISSYM SYMLENGTH) (DECLARE (FIXNUM SYMLENGTH))
(SETQ DISSYM (GET (CAAR FORM) 'DISSYM) SYMLENGTH (LENGTH DISSYM))
(SETQ RESULT (DIMENSION (CADR FORM) RESULT LOP (CAAR FORM) 0 (+ SYMLENGTH RIGHT))
WIDTH (+ SYMLENGTH WIDTH))
(RETURN (RECONC DISSYM RESULT))))
(DEFMFUN DIMENSION-NOFIX (FORM RESULT)
(SETQ FORM (GET (CAAR FORM) 'DISSYM) WIDTH (LENGTH FORM))
(RECONC FORM RESULT))
(DEFUN DIMENSION-MATCH (FORM RESULT)
(PROG (DISSYM SYMLENGTH)
(DECLARE (FIXNUM SYMLENGTH))
(SETQ DISSYM (GET (CAAR FORM) 'DISSYM) SYMLENGTH (LENGTH (CAR DISSYM)))
(COND ((NULL (CDR FORM))
(SETQ WIDTH (+ SYMLENGTH (LENGTH (CDR DISSYM))) HEIGHT 1 DEPTH 0)
(RETURN (RECONC (CDR DISSYM) (RECONC (CAR DISSYM) RESULT))))
(T (SETQ RESULT (LET ((LOP 'MPAREN)
(ROP 'MPAREN)
(BREAK (IF BREAK (+ SYMLENGTH BREAK)))
(RIGHT (+ SYMLENGTH RIGHT)))
(DIMENSION-LIST FORM (RECONC (CAR DISSYM) RESULT))))
(SETQ WIDTH (+ (LENGTH (CDR DISSYM)) SYMLENGTH WIDTH))
(RETURN (RECONC (CDR DISSYM) RESULT))))))
(DEFMFUN DIMENSION-SUPERSCRIPT (FORM RESULT)
(PROG (EXP W H D BAS)
(DECLARE (FIXNUM W H D W2 H2 D2))
(SETQ EXP (LET ((SIZE 1)) (DIMENSION (CADDR FORM) NIL 'MPAREN 'MPAREN NIL 0))
W WIDTH H HEIGHT D DEPTH)
(COND ((AND (NOT (ATOM (CADR FORM))) (MEMQ 'ARRAY (CDAADR FORM)))
(PROG (SUB W2 H2 D2)
(SETQ SUB (IF (EQ 'MQAPPLY (CAAADR FORM))
(CDADR FORM) (CADR FORM)))
(SETQ SUB (LET ((LOP 'MPAREN) (BREAK NIL) (SIZE 1))
(DIMENSION-LIST SUB NIL))
W2 WIDTH H2 HEIGHT D2 DEPTH)
(SETQ BAS (DIMENSION (MOP (CADR FORM)) RESULT LOP 'MEXPT NIL 0))
(WHEN (NOT (CHECKFIT (+ WIDTH (MAX W W2))))
(SETQ RESULT (DIMENSION-FUNCTION (CONS '($EXPT) (CDR FORM)) RESULT))
(RETURN RESULT))
(SETQ RESULT (CONS (CONS 0 (CONS (+ HEIGHT D) EXP)) BAS))
(SETQ RESULT (CONS (CONS (- W) (CONS (- (+ DEPTH H2)) SUB)) RESULT))
(SETQ RESULT (CONS (LIST (- (MAX W W2) W2) 0) RESULT)
WIDTH (+ WIDTH (MAX W W2)) HEIGHT (+ H D HEIGHT) DEPTH (+ D2 H2 DEPTH)))
(UPDATE-HEIGHTS HEIGHT DEPTH)
(RETURN RESULT))
((AND (ATOM (CADDR FORM))
(NOT (ATOM (CADR FORM)))
(NOT (GET (CAAADR FORM) 'DIMENSION))
(PROG2 (SETQ BAS (NFORMAT-CHECK (CADR FORM)))
(NOT (GET (CAAR BAS) 'DIMENSION))))
(RETURN (DIMENSION-FUNCTION
(LIST* '(MQAPPLY) (LIST '(MEXPT) (MOP BAS) (CADDR FORM)) (MARGS BAS))
RESULT)))
(T (SETQ BAS (DIMENSION (CADR FORM) RESULT LOP 'MEXPT NIL 0) WIDTH (+ W WIDTH))
(IF (NOT (CHECKFIT WIDTH))
(RETURN (DIMENSION-FUNCTION (CONS '($EXPT) (CDR FORM)) RESULT)))
(IF (AND (NUMBERP (CAR BAS)) (= #/) (CAR BAS)))
(SETQ RESULT (CONS (LIST* 0 (1+ D) EXP) BAS) HEIGHT (MAX (+ 1 H D) HEIGHT))
(SETQ RESULT (CONS (LIST* 0 (+ HEIGHT D) EXP) BAS) HEIGHT (+ H D HEIGHT)))
(UPDATE-HEIGHTS HEIGHT DEPTH)
(RETURN RESULT)))))
(DEFUN DSUMPROD (FORM RESULT D-FORM SW SH SD)
(DECLARE (FIXNUM W H D SW SH SD))
(PROG (DUMMY W H D DUMMY2)
(SETQ DUMMY2 (DIMENSION (CADDR FORM) NIL 'MPAREN 'MEQUAL NIL 0)
W WIDTH H HEIGHT D DEPTH)
(PUSH-STRING " = " DUMMY2)
(SETQ DUMMY2 (DIMENSION (CADDDR FORM) DUMMY2 'MEQUAL 'MPAREN NIL 0)
W (+ 3 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH))
(SETQ DUMMY (DIMENSION (CADR (CDDDR FORM)) NIL 'MPAREN 'MPAREN NIL 0))
(COND ((NOT (CHECKFIT (MAX W WIDTH))) (RETURN (DIMENSION-FUNCTION FORM RESULT))))
(SETQ DUMMY2 (CONS (CONS (- SW) (CONS (- (+ SD H)) DUMMY2)) (CONS D-FORM RESULT)))
(COND ((> WIDTH SW) (SETQ SW 0))
(T (SETQ SW (// (- SW WIDTH) 2) WIDTH (+ SW WIDTH))))
(SETQ DUMMY (CONS (CONS (- SW W) (CONS (+ SH DEPTH) DUMMY)) DUMMY2)
W (MAX W WIDTH) D (+ SD H D) H (+ SH HEIGHT DEPTH))
(UPDATE-HEIGHTS H D)
(SETQ DUMMY (DIMENSION (CADR FORM) (CONS (LIST (1+ (- W WIDTH)) 0) DUMMY)
(CAAR FORM) ROP W RIGHT)
WIDTH (+ 1 W WIDTH) HEIGHT (MAX H HEIGHT) DEPTH (MAX D DEPTH))
(RETURN DUMMY)))
(DISPLA-DEF BIGFLOAT DIM-BIGFLOAT)
(DISPLA-DEF MQUOTE DIMENSION-PREFIX "'")
(DISPLA-DEF MSETQ DIMENSION-INFIX " : ")
(DISPLA-DEF MSET DIMENSION-INFIX " :: ")
(DISPLA-DEF MDEFINE DIM-MDEFINE " := ")
(DISPLA-DEF MDEFMACRO DIM-MDEFINE " ::= ")
(DEFUN DIM-MDEFINE (FORM RESULT)
(LET (($NOUNDISP T) (STRINGDISP T))
(DIMENSION-INFIX (IF (CDDDR FORM)
(LIST (CAR FORM) (CADR FORM) (CONS '(MPROGN) (CDDR FORM)))
FORM)
RESULT)))
(DISPLA-DEF MFACTORIAL DIMENSION-POSTFIX "!")
(DISPLA-DEF MEXPT DIMENSION-SUPERSCRIPT)
(DISPLA-DEF MNCEXPT DIM-MNCEXPT "^^")
(DEFUN DIM-MNCEXPT (FORM RESULT)
(DIMENSION-SUPERSCRIPT (LIST '(MNCEXPT) (CADR FORM) (CONS '(MANGLE) (CDDR FORM)))
RESULT))
(DISPLA-DEF MNCTIMES DIMENSION-NARY " . ")
(DISPLA-DEF %PRODUCT DIM-%PRODUCT 115.)
(DEFUN DIM-%PRODUCT (FORM RESULT) (DSUMPROD FORM RESULT '(D-PRODSIGN) 5 3 1))
(DISPLA-DEF RAT DIM-RAT "//")
(DEFUN DIM-RAT (FORM RESULT)
(IF $PFEFORMAT (DIMENSION-NARY FORM RESULT) (DIM-MQUOTIENT FORM RESULT)))
(DISPLA-DEF MQUOTIENT DIM-MQUOTIENT "//")
(DEFUN DIM-MQUOTIENT (FORM RESULT)
(IF (OR (NULL (CDDR FORM)) (CDDDR FORM)) (WNA-ERR (CAAR FORM)))
(PROG (NUM W H D DEN)
(DECLARE (FIXNUM W H D))
(IF (AND (= 1 SIZE) (ATOM (CADR FORM)) (ATOM (CADDR FORM)))
(RETURN (DIMENSION-NARY FORM RESULT)))
(SETQ NUM (DIMENSION (CADR FORM) NIL 'MPAREN 'MPAREN NIL RIGHT)
W WIDTH H HEIGHT D DEPTH)
(IF (NOT (CHECKFIT W)) (RETURN (DIMENSION-NARY FORM RESULT)))
(SETQ DEN (DIMENSION (CADDR FORM) NIL 'MPAREN 'MPAREN NIL RIGHT))
(IF (NOT (CHECKFIT WIDTH)) (RETURN (DIMENSION-NARY FORM RESULT)))
(RETURN (DRATIO RESULT NUM W H D DEN WIDTH HEIGHT DEPTH))))
;; <-- W1 -->
;; ------------------
;; | ^ |
;; <- X1 -> | | H1 |
;; | | D1 |
;; | v |
;; ------------------
;; ----------------------------------
;; (Likewise for X2, H2, D2, W2 in the denominator)
;; Hack to recycle slots on the stack. Compiler should be doing this.
;; Use different names to preserve sanity.
#.(PROG2 (SETQ X1 'H1 X2 'D2) T)
(DEFUN DRATIO (RESULT NUM W1 H1 D1 DEN W2 H2 D2)
(DECLARE (FIXNUM W1 H1 D1 W2 H2 D2))
(SETQ WIDTH (MAX W1 W2) HEIGHT (+ 1 H1 D1) DEPTH (+ H2 D2))
(SETQ #.X1 (// (- WIDTH W1) 2) #.X2 (// (- WIDTH W2) 2))
(UPDATE-HEIGHTS HEIGHT DEPTH)
(PUSH `(,#.X1 ,(1+ D1) . ,NUM) RESULT)
(PUSH `(,(- #.X2 (+ #.X1 W1)) ,(- H2) . ,DEN) RESULT)
(PUSH `(,(- 0 #.X2 W2) 0) RESULT)
(PUSH `(D-HBAR ,WIDTH) RESULT)
RESULT)
(DISPLA-DEF MTIMES DIMENSION-NARY " ")
;; This code gets run when STARDISP is assigned a value.
(DEFPROP $STARDISP STARDISP ASSIGN)
(DEFUN STARDISP (SYMBOL VAL)
SYMBOL ;ignored -- always bound to $STARDISP
(PUTPROP 'MTIMES (IF VAL '(#/*) '(#\SP)) 'DISSYM))
(DISPLA-DEF %INTEGRATE DIM-%INTEGRATE 115.)
(DEFUN DIM-%INTEGRATE (FORM RESULT)
(PROG (DUMMY W H D DUMMY2)
(DECLARE (FIXNUM W H D))
(COND ((NULL (CDDR FORM)) (WNA-ERR (CAAR FORM)))
((NULL (CDDDR FORM))
(SETQ DUMMY `(#\SP (D-INTEGRALSIGN) . ,RESULT) W 2 H 3 D 2))
(T (SETQ DUMMY (DIMENSION (CADR (CDDDR FORM)) NIL 'MPAREN 'MPAREN NIL 0)
W WIDTH H HEIGHT D DEPTH)
(SETQ DUMMY2 (DIMENSION (CADDDR FORM) NIL 'MPAREN 'MPAREN NIL 0))
(IF (NOT (CHECKFIT (+ 2 (MAX W WIDTH))))
(RETURN (DIMENSION-FUNCTION FORM RESULT)))
(SETQ DUMMY `((0 ,(+ 3 D) . ,DUMMY) (D-INTEGRALSIGN) . ,RESULT))
(SETQ DUMMY (CONS (CONS (- W) (CONS (- (+ 2 HEIGHT)) DUMMY2)) DUMMY)
W (+ 2 (MAX W WIDTH)) H (+ 3 H D) D (+ 2 HEIGHT DEPTH)
DUMMY (CONS (LIST (- W 1 WIDTH) 0) DUMMY))))
(UPDATE-HEIGHTS H D)
(SETQ DUMMY (DIMENSION (CADR FORM) DUMMY '%INTEGRATE 'MPAREN W 2)
W (+ W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH))
(PUSH-STRING " d" DUMMY)
(SETQ DUMMY (DIMENSION (CADDR FORM) DUMMY 'MPAREN ROP (+ 2 W) RIGHT)
WIDTH (+ 2 W WIDTH) HEIGHT (MAX H HEIGHT) DEPTH (MAX D DEPTH))
(RETURN DUMMY)))
(DISPLA-DEF %DERIVATIVE DIM-%DERIVATIVE 125.)
(DEFUN DIM-%DERIVATIVE (FORM RESULT)
(PROG ()
(COND ((NULL (CDDR FORM))
(RETURN (DIMENSION-FUNCTION (CONS '(%DIFF) (CDR FORM)) RESULT))))
(COND ((NULL (CDDDR FORM)) (SETQ FORM (APPEND FORM '(1)))))
(COND ((AND $DERIVABBREV
(DO ((L (CDDR FORM) (CDDR L))) ((NULL L) T)
(COND ((AND (ATOM (CAR L)) (FIXP (CADR L)) (> (CADR L) 0)))
(T (RETURN NIL)))))
(RETURN (DMDERIVABBREV FORM RESULT)))
((OR (> (RBP LOP) 130.) (> (LBP ROP) 130.)
(AND (NOT (ATOM (CADR FORM))) (OR (> (RBP LOP) 110.) (> (LBP ROP) 110.))))
(RETURN (DIMENSION-PAREN FORM RESULT)))
(T (RETURN (DMDERIVLONG FORM RESULT))))))
(DEFUN DMDERIVABBREV (FORM RESULT)
(PROG (DUMMY W) (DECLARE (FIXNUM W))
(SETQ W 0)
(DO ((L (CDDR FORM) (CDDR L)) (VAR))
((NULL L) (SETQ DUMMY (CDR DUMMY) W (1- W)))
(SETQ VAR (DIMENSION (CAR L) NIL 'MPAREN 'MPAREN NIL 0))
(DO I (CADR L) (1- I) (= 1 I) (SETQ DUMMY (CONS #\SP (APPEND VAR DUMMY))))
(SETQ DUMMY (CONS #\SP (NCONC VAR DUMMY)) W (+ W (CADR L) (* (CADR L) WIDTH))))
(SETQ RESULT (DIMENSION (CADR FORM) RESULT LOP '%DERIV 0 RIGHT))
(SETQ RESULT (CONS (CONS 0 (CONS (- 0 DEPTH 1) DUMMY)) RESULT)
WIDTH (+ W WIDTH) DEPTH (MAX 1 (1+ DEPTH)))
(UPDATE-HEIGHTS HEIGHT DEPTH)
(RETURN RESULT)))
(DEFUN DMDERIVLONG (FORM RESULT)
(PROG (NUM W1 H1 D1 DEN W2 H2 D2)
(DECLARE (FIXNUM W1 H1 D1 W2 H2 D2))
(SETQ NUM (LIST (CADDDR FORM))
DEN (COND ((EQUAL 1 (CADDDR FORM)) (DIMENSION (CADDR FORM) (LIST #/d) 'MPAREN 'MPAREN NIL 0))
(T (DIMENSION-SUPERSCRIPT (CONS '(DIFF) (CDDR FORM)) (LIST #/d))))
W2 (1+ WIDTH) H2 HEIGHT D2 DEPTH)
(DO L (CDDDDR FORM) (CDDR L) (NULL L)
(SETQ NUM (CONS (CADR L) NUM)
DEN (COND ((EQUAL 1 (CADR L))
(DIMENSION (CAR L) (CONS #/d (CONS #\SP DEN))
'MPAREN 'MPAREN NIL 0))
(T (DIMENSION-SUPERSCRIPT
(CONS '(DIFF) L) (CONS #/d (CONS #\SP DEN)))))
W2 (+ 2 W2 WIDTH) H2 (MAX H2 HEIGHT) D2 (+ D2 DEPTH)))
(SETQ NUM (NFORMAT-CHECK (ADDN NUM T)))
(COND ((EQUAL 1 NUM) (SETQ NUM (LIST #/d) W1 1 H1 1 D1 0))
(T (SETQ NUM (DIMENSION-SUPERSCRIPT (LIST '(DIFF) '|d| NUM) NIL)
W1 WIDTH H1 HEIGHT D1 DEPTH)))
(COND ((ATOM (SETQ FORM (NFORMAT-CHECK (CADR FORM))))
(SETQ NUM (DIMENSION FORM NUM '%DERIV 'MPAREN NIL 0) W1 (+ W1 WIDTH))
(RETURN (DRATIO RESULT NUM W1 H1 D1 DEN W2 H2 D2)))
(T (SETQ RESULT (DRATIO RESULT NUM W1 H1 D1 DEN W2 H2 D2) W1 WIDTH H1 HEIGHT D1 DEPTH)
(SETQ RESULT (DIMENSION FORM (CONS #\SP RESULT) '%DERIV ROP W1 RIGHT)
WIDTH (+ 1 W1 WIDTH) HEIGHT (MAX H1 HEIGHT) DEPTH (MAX D1 DEPTH))
(UPDATE-HEIGHTS HEIGHT DEPTH)
(RETURN RESULT)))))
(DISPLA-DEF %AT DIM-%AT 105. 105.)
(DEFUN DIM-%AT (FORM RESULT)
(PROG (EXP W H D EQS)
(DECLARE (FIXNUM W H D))
(IF (OR (NULL (CDDR FORM)) (CDDDR FORM)) (WNA-ERR (CAAR FORM)))
(SETQ EXP (DIMENSION (CADR FORM) RESULT LOP '%AT NIL 0)
W WIDTH H HEIGHT D DEPTH)
(SETQ EQS (DIMENSION (COND ((NOT (EQ 'MLIST (CAAR (CADDR FORM)))) (CADDR FORM))
((NULL (CDDR (CADDR FORM))) (CADR (CADDR FORM)))
(T (CONS '(MCOMMA) (CDADDR FORM))))
NIL 'MPAREN 'MPAREN NIL 0))
(COND ((NOT (CHECKFIT (+ 1 W WIDTH))) (RETURN (DIMENSION-FUNCTION FORM RESULT))))
(SETQ RESULT (CONS (CONS 0 (CONS (- 0 1 D) EQS))
(CONS `(D-VBAR ,(1+ H) ,(1+ D) ,(GETCHARN $ABSBOXCHAR 2)) EXP))
WIDTH (+ 1 W WIDTH) HEIGHT (1+ H) DEPTH (+ 1 D DEPTH))
(UPDATE-HEIGHTS HEIGHT DEPTH)
(RETURN RESULT)))
(DISPLA-DEF MMINUS DIMENSION-PREFIX "- ")
(DISPLA-DEF MPLUS DIM-MPLUS)
(DEFPROP MUNARYPLUS (#/+ #\SP) DISSYM)
(DEFUN DIM-MPLUS (FORM RESULT)
;; If only 0 or 1 arguments, then print "+"() or +A
(COND ((AND (NULL (CDDR FORM))
(NOT (MEMQ (CADAR FORM) '(TRUNC EXACT))))
(IF (NULL (CDR FORM))
(DIMENSION-FUNCTION FORM RESULT)
(DIMENSION-PREFIX (CONS '(MUNARYPLUS) (CDR FORM)) RESULT)))
(T (SETQ RESULT (DIMENSION (CADR FORM) RESULT LOP 'MPLUS 0 0))
(CHECKBREAK RESULT WIDTH)
(DO ((L (CDDR FORM) (CDR L))
(W WIDTH) (H HEIGHT) (D DEPTH)
(TRUNC (MEMQ 'TRUNC (CDAR FORM))) (DISSYM))
((NULL L) (COND (TRUNC (SETQ WIDTH (+ 8 W) HEIGHT H DEPTH D)
(PUSH-STRING " + . . ." RESULT)))
RESULT)
(DECLARE (FIXNUM W H D))
(IF (MMMINUSP (CAR L))
(SETQ DISSYM '(#\SP #/- #\SP) FORM (CADAR L))
(SETQ DISSYM '(#\SP #/+ #\SP) FORM (CAR L)))
(COND ((AND (NOT TRUNC) (NULL (CDR L)))
(SETQ RESULT (DIMENSION FORM (APPEND DISSYM RESULT)
'MPLUS ROP (+ 3 W) RIGHT)
WIDTH (+ 3 W WIDTH)
HEIGHT (MAX H HEIGHT)
DEPTH (MAX D DEPTH))
(RETURN RESULT))
(T (SETQ RESULT
(DIMENSION FORM (APPEND DISSYM RESULT)
'MPLUS 'MPLUS (+ 3 W) 0)
W (+ 3 W WIDTH)
H (MAX H HEIGHT)
D (MAX D DEPTH))
(CHECKBREAK RESULT W)))))))
(DISPLA-DEF %SUM DIM-%SUM 110.)
(DISPLA-DEF %LIMIT DIM-%LIMIT 90. 90.)
(DEFUN DIM-%SUM (FORM RESULT) (DSUMPROD FORM RESULT '(D-SUMSIGN) 4 3 2))
(DEFUN DIM-%LIMIT (FORM RESULT)
(PROG (DUMMY W H D) (DECLARE (FIXNUM W H D))
(IF (NULL (CDDR FORM)) (RETURN (DIMENSION-FUNCTION FORM RESULT)))
(IF (NULL (CDDDR FORM)) (WNA-ERR (CAAR FORM)))
(SETQ DUMMY (DIMENSION (THIRD FORM) NIL 'MPAREN 'MPAREN NIL 0)
W WIDTH H HEIGHT D DEPTH)
(PUSH-STRING " -> " DUMMY)
(SETQ DUMMY (DIMENSION (FOURTH FORM) DUMMY 'MPAREN 'MPAREN NIL 0)
W (+ 4 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH))
(COND ((NULL (CDDDDR FORM)))
((EQ '$PLUS (FIFTH FORM))
(PUSH #/+ DUMMY)
(INCREMENT W))
(T (PUSH #/- DUMMY)
(INCREMENT W)))
(PUSH-STRING "limit" RESULT)
(SETQ DUMMY (CONS (LIST* -5 (- H) DUMMY) RESULT) D (+ H D))
(UPDATE-HEIGHTS 1 D)
(SETQ DUMMY (DIMENSION (CADR FORM) (CONS '(1 0) DUMMY) '%LIMIT ROP (1+ W) RIGHT))
(SETQ WIDTH (+ 1 W WIDTH) DEPTH (MAX D DEPTH))
(RETURN DUMMY)))
;; Some scheme needs to be worked out to allow use of mathematical character
;; sets on consoles which have them.
(DISPLA-DEF MARROW DIMENSION-INFIX " -> " 80. 80.)
(DISPLA-DEF MGREATERP DIMENSION-INFIX " > ")
(DISPLA-DEF MGEQP DIMENSION-INFIX " >= ")
(DISPLA-DEF MEQUAL DIMENSION-INFIX " = ")
(DISPLA-DEF MNOTEQUAL DIMENSION-INFIX " # ")
(DISPLA-DEF MLEQP DIMENSION-INFIX " <= ")
(DISPLA-DEF MLESSP DIMENSION-INFIX " < ")
(DISPLA-DEF MNOT DIMENSION-PREFIX "NOT ")
(DISPLA-DEF MAND DIMENSION-NARY " AND ")
(DISPLA-DEF MOR DIMENSION-NARY " OR ")
(DISPLA-DEF MCOND DIM-MCOND)
(DEFUN DIM-MCOND (FORM RESULT)
(PROG (W H D) (DECLARE (FIXNUM W H D))
(PUSH-STRING "IF " RESULT)
(SETQ RESULT (DIMENSION (CADR FORM) RESULT 'MCOND 'MPAREN 3 0)
W (+ 3 WIDTH) H HEIGHT D DEPTH)
(CHECKBREAK RESULT W)
(PUSH-STRING " THEN " RESULT)
(SETQ RESULT (DIMENSION (CADDR FORM) RESULT 'MCOND 'MPAREN (+ 6 W) 0)
W (+ 6 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH))
(UNLESS (EQ '$FALSE (FIFTH FORM))
(CHECKBREAK RESULT W)
(PUSH-STRING " ELSE " RESULT)
(SETQ RESULT (DIMENSION (FIFTH FORM) RESULT 'MCOND ROP (+ 6 W) RIGHT)
W (+ 6 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH)))
(SETQ WIDTH W HEIGHT H DEPTH D)
(RETURN RESULT)))
(DISPLA-DEF MDO DIM-MDO)
(DEFUN DIM-MDO (FORM RESULT)
(PROG (W H D BRKFLAG) (DECLARE (FIXNUM W H D))
(SETQ W 0 H 0 D 0)
(COND ((NOT (NULL (CADR FORM)))
(PUSH-STRING "FOR " RESULT)
(SETQ RESULT (CONS #\SP (DIMENSION (CADR FORM) RESULT 'MDO 'MPAREN 4 RIGHT))
W (+ 4 WIDTH) H HEIGHT D DEPTH BRKFLAG T)))
(COND ((OR (NULL (CADDR FORM)) (EQUAL 1 (CADDR FORM))))
(T (PUSH-STRING "FROM " RESULT)
(SETQ RESULT
(CONS #\SP (DIMENSION (CADDR FORM) RESULT 'MDO 'MPAREN (+ 6 W) 0))
W (+ 6 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH))))
(SETQ FORM (CDDDR FORM))
(COND ((EQUAL 1 (CAR FORM)))
((NOT (NULL (CAR FORM)))
(PUSH-STRING "STEP " RESULT)
(SETQ RESULT (CONS #\SP (DIMENSION (CAR FORM) RESULT 'MDO 'MPAREN (+ 6 W) 0))
W (+ 6 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH)))
((NOT (NULL (CADR FORM)))
(PUSH-STRING "NEXT " RESULT)
(SETQ RESULT (CONS #\SP (DIMENSION (CADR FORM) RESULT 'MDO 'MPAREN (+ 6 W) 0))
W (+ 6 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH))))
(COND ((NOT (NULL (CADDR FORM)))
(PUSH-STRING "THRU " RESULT)
(SETQ RESULT (CONS #\SP (DIMENSION (CADDR FORM) RESULT 'MDO 'MPAREN (+ 6 W) 0))
W (+ 6 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH) BRKFLAG T)))
(COND ((NOT (NULL (CADDDR FORM)))
(COND ((AND (NOT (ATOM (CADDDR FORM))) (EQ (CAAR (CADDDR FORM)) 'MNOT))
(PUSH-STRING "WHILE " RESULT)
(SETQ RESULT
(CONS #\SP (DIMENSION (CADR (CADDDR FORM)) RESULT 'MDO 'MPAREN (+ 7 W) 0))
W (+ 7 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH)))
(T (PUSH-STRING "UNLESS " RESULT)
(SETQ RESULT
(CONS #\SP (DIMENSION (CADDDR FORM) RESULT 'MDO 'MPAREN (+ 8 W) 0))
W (+ 8 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH))))))
(IF BRKFLAG (CHECKBREAK RESULT W))
(PUSH-STRING "DO " RESULT)
(SETQ RESULT (DIMENSION (CAR (CDDDDR FORM)) RESULT 'MDO ROP (+ 4 W) RIGHT)
WIDTH (+ 4 W WIDTH) HEIGHT (MAX H HEIGHT) DEPTH (MAX D DEPTH))
(RETURN RESULT)))
(DISPLA-DEF MDOIN DIM-MDOIN)
(DEFUN DIM-MDOIN (FORM RESULT)
(PROG (W H D) (DECLARE (FIXNUM W H D))
(PUSH-STRING "FOR " RESULT)
(SETQ RESULT (DIMENSION (CADR FORM) RESULT 'MDO 'MPAREN 4 0)
W (+ 4 WIDTH) H HEIGHT D DEPTH)
(PUSH-STRING " IN " RESULT)
(SETQ RESULT (DIMENSION (CADDR FORM) RESULT 'MDO 'MPAREN (+ 4 W) 0)
W (+ 4 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH))
(SETQ FORM (CDR (CDDDDR FORM)))
(COND ((NOT (NULL (CAR FORM)))
(PUSH-STRING " THRU " RESULT)
(SETQ RESULT (DIMENSION (CAR FORM) RESULT 'MDO 'MPAREN (+ 6 W) 0)
W (+ 6 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH))))
(COND ((NOT (NULL (CADR FORM)))
(PUSH-STRING " UNLESS " RESULT)
(SETQ RESULT (DIMENSION (CADR FORM) RESULT 'MDO 'MPAREN (+ 8 W) 0)
W (+ 8 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH))))
(PUSH-STRING " DO " RESULT)
(SETQ RESULT (DIMENSION (CADDR FORM) RESULT 'MDO ROP (+ 4 W) RIGHT)
WIDTH (+ 4 W WIDTH) HEIGHT (MAX H HEIGHT) DEPTH (MAX D DEPTH))
(RETURN RESULT)))
(DISPLA-DEF MPROGN DIMENSION-MATCH "(" ")")
(DISPLA-DEF MLIST DIMENSION-MATCH "[" "]")
(DISPLA-DEF MANGLE DIMENSION-MATCH "<" ">")
(DISPLA-DEF MCOMMA DIMENSION-NARY ", " 20. 20.)
(DISPLA-DEF MABS DIM-MABS)
(DEFUN DIM-MABS (FORM RESULT &AUX ARG BAR)
(SETQ ARG (DIMENSION (CADR FORM) NIL 'MPAREN 'MPAREN NIL 0))
(COND ((OR (> (+ 2 WIDTH) LINEL) (AND (= 1 HEIGHT) (= 0 DEPTH)))
(DIMENSION-FUNCTION FORM RESULT))
(T (SETQ WIDTH (+ 2 WIDTH))
(UPDATE-HEIGHTS HEIGHT DEPTH)
(SETQ BAR `(D-VBAR ,HEIGHT ,DEPTH ,(GETCHARN $ABSBOXCHAR 2)))
(CONS BAR (NCONC ARG (CONS BAR RESULT))))))
(DISPLA-DEF $MATRIX DIM-$MATRIX)
(DEFUN DIM-$MATRIX (FORM RESULT)
(PROG (DMSTR RSTR CSTR LISTP)
(IF (OR (NULL (CDR FORM))
(NOT (MEMQ 'SIMP (CDAR FORM)))
(MEMALIKE '((MLIST SIMP)) (CDR FORM))
(DOLIST (ROW (CDR FORM)) (IF (NOT ($LISTP ROW)) (RETURN T))))
(RETURN (DIMENSION-FUNCTION FORM RESULT)))
(DO L (CDADR FORM) (CDR L) (NULL L)
(SETQ DMSTR (CONS NIL DMSTR) CSTR (CONS 0 CSTR)))
(DO ((R (CDR FORM) (CDR R)) (H1 0) (D1 0))
((OR LISTP (NULL R))
(SETQ WIDTH 0)
(DO CS CSTR (CDR CS) (NULL CS) (SETQ WIDTH (+ 2 (CAR CS) WIDTH)))
(SETQ H1 (1- (+ H1 D1)) DEPTH (// H1 2) HEIGHT (- H1 DEPTH)))
(DECLARE (FIXNUM H1 D1))
(DO ((C (CDAR R) (CDR C))
(NC DMSTR (CDR NC))
(CS CSTR (CDR CS)) (DUMMY) (H2 0) (D2 0))
((NULL C) (SETQ D1 (+ D1 H1 H2) H1 (1+ D2)))
(DECLARE (FIXNUM H2 D2))
(SETQ DUMMY (DIMENSION (CAR C) NIL 'MPAREN 'MPAREN NIL 0)
H2 (MAX H2 HEIGHT) D2 (MAX D2 DEPTH))
(COND ((NOT (CHECKFIT (+ 14. WIDTH))) (SETQ LISTP T) (RETURN NIL))
(T (RPLACA NC (CONS (LIST* WIDTH HEIGHT DEPTH DUMMY) (CAR NC)))
(RPLACA CS (MAX WIDTH (CAR CS))))))
(SETQ RSTR (CONS D1 RSTR)))
(IF (> (+ HEIGHT DEPTH)
(LINEARRAY-DIM)
)
(SETQ LISTP T))
(RETURN
(COND ((AND (NOT LISTP) (CHECKFIT (+ 2 WIDTH)))
(MATOUT DMSTR CSTR RSTR RESULT))
((AND (NOT LISTP) (<= LEVEL 2)) (COLOUT DMSTR CSTR RESULT))
(T (DIMENSION-FUNCTION FORM RESULT))))))
(DEFUN MATOUT (DMSTR CSTR RSTR RESULT)
(PUSH `(D-MATRIX LEFT ,HEIGHT ,DEPTH) RESULT)
(PUSH #\SP RESULT)
(DO ((D DMSTR (CDR D)) (C CSTR (CDR C)) (W 0 0)) ((NULL D))
(DECLARE (FIXNUM W))
(DO ((D (CAR D) (CDR D)) (R RSTR (CDR R))) ((NULL D))
(RPLACA (CDDAR D) (- HEIGHT (CAR R)))
(RPLACA (CDAR D) (- (// (- (CAR C) (CAAR D)) 2) W))
(SETQ W (// (+ (CAR C) (CAAR D)) 2))
(RPLACA D (CDAR D)))
(SETQ RESULT (CONS (LIST (+ 2 (- (CAR C) W)) 0) (NRECONC (CAR D) RESULT))))
(SETQ WIDTH (+ 2 WIDTH))
(UPDATE-HEIGHTS HEIGHT DEPTH)
(RPLACA (CAR RESULT) (1- (CAAR RESULT)))
(PUSH `(D-MATRIX RIGHT ,HEIGHT ,DEPTH) RESULT)
RESULT)
(DEFUN COLOUT (DMSTR CSTR RESULT)
(SETQ WIDTH 0 HEIGHT 1 DEPTH 0)
(DO ((R DMSTR (CDR R)) (C CSTR (CDR C)) (COL 1 (1+ COL)) (W 0 0) (H -1 -1) (D 0))
((NULL R))
(DECLARE (FIXNUM COL W H D))
(PUSH-STRING " Col " RESULT)
(SETQ RESULT (NRECONC (EXPLODEN COL) RESULT))
(PUSH-STRING " = " RESULT)
(SETQ WIDTH (+ 8 (FLATC COL) WIDTH))
(DO ((R (CAR R) (CDR R))) ((NULL R))
(SETQ H (+ 1 H (CADAR R) (CADDAR R)))
(RPLACA (CDDAR R) (- H (CADAR R)))
(RPLACA (CDAR R) (- (// (- (CAR C) (CAAR R)) 2) W))
(SETQ W (// (+ (CAR C) (CAAR R)) 2))
(RPLACA R (CDAR R)))
(SETQ D (// H 2) H (- H D))
(PUSH `(D-MATRIX LEFT ,H ,D) RESULT)
(PUSH #\SP RESULT)
(PUSH `(0 ,(- D) . ,(NREVERSE (CAR R))) RESULT)
(PUSH `(,(1+ (- (CAR C) W)) 0) RESULT)
(PUSH `(D-MATRIX RIGHT ,H ,D) RESULT)
(SETQ WIDTH (+ 4 (CAR C) WIDTH) HEIGHT (MAX H HEIGHT) DEPTH (MAX D DEPTH))
(UPDATE-HEIGHTS H D)
(CHECKBREAK RESULT WIDTH))
RESULT)
(DISPLA-DEF MBOX DIM-MBOX)
(DEFUN DIM-MBOX (FORM RESULT &AUX DUMMY)
(SETQ DUMMY (DIMENSION (CADR FORM) NIL 'MPAREN 'MPAREN NIL 0))
(COND ((NOT (CHECKFIT (+ 2 WIDTH)))
(DIMENSION-FUNCTION (CONS '($BOX) (CDR FORM)) RESULT))
(T (PUSH `(D-BOX ,HEIGHT ,DEPTH ,WIDTH ,(NREVERSE DUMMY)) RESULT)
(SETQ WIDTH (+ 2 WIDTH) HEIGHT (1+ HEIGHT) DEPTH (1+ DEPTH))
(UPDATE-HEIGHTS HEIGHT DEPTH)
RESULT)))
(DISPLA-DEF MLABOX DIM-MLABOX)
(DEFUN DIM-MLABOX (FORM RESULT)
(PROG (DUMMY CH)
(SETQ DUMMY (DIMENSION (CADR FORM) NIL 'MPAREN 'MPAREN NIL 0))
(COND ((NOT (CHECKFIT (+ 2 WIDTH)))
(RETURN (DIMENSION-FUNCTION (CONS '($BOX) (CDR FORM)) RESULT))))
(SETQ WIDTH (+ 2 WIDTH) HEIGHT (1+ HEIGHT) DEPTH (1+ DEPTH))
(SETQ CH (GETCHARN $BOXCHAR 2))
(SETQ RESULT
(CONS (DO ((L (MAPCAR #'(LAMBDA (L) (GETCHARN L 1))
(MAKSTRING (CADDR FORM))) (CDR L))
(W 0) (NL))
((OR (NULL L) (= WIDTH W))
(CONS 0 (CONS (1- HEIGHT)
(COND ((< W WIDTH)
(CONS `(D-HBAR ,(- WIDTH W) ,CH) NL))
(T NL)))))
(DECLARE (FIXNUM W))
(SETQ NL (CONS (CAR L) NL) W (1+ W)))
RESULT))
(SETQ RESULT (NCONC DUMMY (LIST* `(D-VBAR ,(1- HEIGHT) ,(1- DEPTH) ,CH)
(LIST (- WIDTH) 0) RESULT)))
(SETQ RESULT (CONS (LIST (- 1 WIDTH) (- DEPTH) `(D-HBAR ,WIDTH ,CH)) RESULT))
(SETQ RESULT (LIST* `(D-VBAR ,(1- HEIGHT) ,(1- DEPTH) ,CH) '(-1 0) RESULT))
(UPDATE-HEIGHTS HEIGHT DEPTH)
(RETURN RESULT)))
(DISPLA-DEF MTEXT DIM-MTEXT 1 1)
(DEFUN DIM-MTEXT (FORM RESULT)
(IF (NULL (CDDR FORM)) (DIMENSION (CADR FORM) RESULT LOP ROP 0 0)
(DIMENSION-NARY FORM RESULT)))
(DISPLA-DEF MLABLE DIM-MLABEL 0 0)
(DEFUN DIM-MLABEL (FORM RESULT)
(PROG (DUMMY W H D) (DECLARE (FIXNUM W H D))
(COND ((EQ NIL (CADR FORM)) (SETQ W 0 H 0 D 0))
(MRATP (SETQ RESULT (APPEND MRATP (DIMENSION-PAREN (CADR FORM) RESULT))
W (+ 4 WIDTH) H HEIGHT D DEPTH))
(T (SETQ RESULT (CONS #\SP (DIMENSION-PAREN (CADR FORM) RESULT))
W (1+ WIDTH) H HEIGHT D DEPTH)))
(LET ((LEVEL LINEL)) (CHECKBREAK RESULT W))
(SETQ DUMMY (LIST 0 0))
(SETQ RESULT (DIMENSION (CADDR FORM) (CONS DUMMY RESULT) 'MLABLE ROP W RIGHT))
(COND ((AND (NOT $LEFTJUST) (= 0 BKPTOUT))
(RPLACA DUMMY (MAX 0 (- (// (- LINEL WIDTH) 2) W)))
(SETQ WIDTH (+ (CAR DUMMY) WIDTH))))
(SETQ WIDTH (+ W WIDTH) HEIGHT (MAX H HEIGHT) DEPTH (MAX D DEPTH))
(RETURN RESULT)))
(DEFPROP MPAREN -1. LBP)
(DEFPROP MPAREN -1. RBP)
(DEFUN CHECKRAT (FORM)
(COND ((ATOM FORM) NIL)
((AND (NOT (ATOM (CAR FORM))) (EQ (CAAR FORM) 'MRAT))
(IF (MEMQ 'TRUNC (CDAR FORM)) '(#\SP #// #/T #//)
'(#\SP #// #/R #//)))
((AND (NOT (ATOM (CAR FORM))) (EQ (CAAR FORM) 'MPOIS))
'(#\SP #// #/P #//))
(T (DO L (CDR FORM) (CDR L) (NULL L)
(COND ((ATOM L)
(MERROR "~S has an atomic cdr - DISPLAY" FORM))
((SETQ FORM (CHECKRAT (CAR L))) (RETURN FORM)))))))
(DEFUN CHECKFIT (W)
(DECLARE (FIXNUM W))
(OR (NOT BREAK) (<= (- (+ W BREAK RIGHT 1) BKPTWD) LINEL)))
(DEFUN CHECKBREAK (RESULT W)
(DECLARE (FIXNUM W))
(COND ((NOT BREAK))
((> (- (SETQ W (+ W BREAK)) BKPTOUT) LINEL)
(IF (OR (NULL BKPT) (EQ RESULT BKPT))
(MERROR "Expression is too wide to be displayed."))
(DO ((L RESULT (CDR L))) ((EQ BKPT (CDR L)) (RPLACD L NIL))
(IF (NULL L) (MERROR "CHECKBREAK not found in DISPLAY")))
(OUTPUT BKPT 0)
#-Franz (LET ((#.TTYOFF (OR #.TTYOFF MORE-^W))) (MTERPRI))
(SETQ LINES (1+ LINES) BKPT RESULT BKPTOUT BKPTWD BKPTWD W
BKPTHT MAXHT BKPTDP MAXDP BKPTLEVEL LEVEL MAXHT 1 MAXDP 0))
((OR (NULL BKPT) (<= LEVEL BKPTLEVEL) (> (// LINEL 2) (- BKPTWD BKPTOUT)))
(SETQ BKPT RESULT BKPTWD W BKPTLEVEL LEVEL
BKPTHT (MAX MAXHT BKPTHT) BKPTDP (MAX MAXDP BKPTDP) MAXHT 1 MAXDP 0))))
(DEFUN FORCEBREAK (RESULT W)
(OUTPUT RESULT 0) (MTERPRI)
(SETQ LINES (+ 2 LINES) BKPT NIL BKPTOUT (+ W BREAK) MAXHT 1 MAXDP 0))
(DEFUN UPDATE-HEIGHTS (HT* DP*)
(DECLARE (FIXNUM HT* DP*))
(IF BREAK (SETQ MAXHT (MAX MAXHT HT*) MAXDP (MAX MAXDP DP*))))
;;; BKPT dimension structure for last breakpoint saved
;;; BKPTWD width at last bkpt
;;; BKPTHT height of current line to last bkpt
;;; BKPTDP depth of current line to last bkpt
;;; BKPTOUT width of stuff already output
;;; MAXHT height from last bkpt saved to current point
;;; MAXDP depth from last bkpt saved to current point
;;; BREAK width up to last call to DIMENSION
;;; RESULT dimension structure to current point minus output
;;; W width from last call to DIMENSION to current point
;; Code above this point deals with dimensioning and constructing
;; up dimension strings. Code past this point deals with printing
;; them.
;; <dimension string> ::= () | (<string element> . <dimension string>)
;; <string element> ::= character |
;; (<column-relative> <row-relative> . <dimension string>) |
;; (<drawing function> . args)
;; <column-relative> ::= <fixnum>
;; <row-relative> ::= <fixnum>
;; <drawing function> ::= D-HBAR | D-VBAR | D-INTEGRALSIGN | ...
;; When a character appears in a dimension string, it is printed and
;; the cursor moves forward a single position. (The variable OLDCOL is
;; incremented) When a form with a fixnum car is encountered, the
;; first two elements of the form are taken to be relative displacements
;; for OLDCOL and OLDROW. *** NOTE *** After drawing the cddr of the form,
;; OLDROW is reset to its original value, but OLDCOL is left in the new
;; position. Why this is done is beyond me. It only appears to complicate
;; things.
;; There are two basic output functions. OUTPUT-2D draws equations in the same
;; order they are dimensioned, and OUTPUT-LINEAR draws equations line by line.
;; When a <drawing function> is invoked, the first argument passed to it is a
;; flag which is T for linear output and NIL for 2D output. A
;; <drawing function> is also expected to return the new column position.
(DEFUN OUTPUT (RESULT W)
(DECLARE (FIXNUM W))
(IF (NOT (OR #.ttyoff MORE-^W (ZEROP (CHARPOS T)))) (MTERPRI))
(IF (AND (NOT (OR #.ttyoff MORE-^W))
SMART-TTY (NOT (AND SCROLLP (NOT $CURSORDISP)))
(< (+ BKPTHT BKPTDP) (1- TTYHEIGHT))
;;If (STATUS TTY) is NIL, then we don't have the console.
#+PDP10 (STATUS TTY)
(> (+ BKPTHT BKPTDP) (- (1- TTYHEIGHT) (CAR (CURSORPOS)))))
(MORE-FUN T))
(COND
;; If output is turned off to the console and no WRITEFILE is taking
;; place, then don't output anything.
((AND (OR #.ttyoff MORE-^W) (NOT #.writefilep)))
;; If the terminal can't do cursor movement, or we are writing
;; to a WRITEFILE (#.writefilep is on) or the terminal is scrolling or
;; something else random, then draw equations line by line.
((> (+ BKPTHT BKPTDP) 80.)
(MERROR "Expression is too high to be displayed."))
((OR (NOT (AND SMART-TTY $CURSORDISP))
#.writefilep SCROLLP (> (+ BKPTHT BKPTDP) (- TTYHEIGHT 2)))
(OUTPUT-LINEAR (NREVERSE RESULT) W))
;; Otherwise, draw equations in the same order as they are dimensioned.
(T (OUTPUT-2D (NREVERSE RESULT) W))))
;; Output function for terminals without cursor positioning capability.
;; Characters are drawn into LINEARRAY instead. Each element of LINEARRAY is a
;; list -- the car is how many spaces to indent; the cdr is a list of
;; characters to draw. After drawing into this array, lines are printed one at
;; a time. This is used for printing terminals and when writing to files.
;; Block mode i/o isn't needed since PRINC is used instead of TYO and
;; CURSORPOS.
(DEFUN OUTPUT-LINEAR (RESULT W)
(DECLARE (FIXNUM W))
(DRAW-LINEAR RESULT BKPTDP W)
(DO (#+PDP10 (TERPRI T) (I (1- (+ BKPTHT BKPTDP)) (1- I)))
((< I 0))
(DECLARE (FIXNUM I))
(COND ((NULL (LINEARRAY I)))
(MORE-^W (SAFE-PRINT (OUTPUT-LINEAR-ONE-LINE I)))
(T (OUTPUT-LINEAR-ONE-LINE I)))))
(DEFUN OUTPUT-LINEAR-ONE-LINE (I) (DECLARE (FIXNUM I N))
(PROG (LINE N)
(SETQ LINE (LINEARRAY I) LINE (NREVERSE (CDR LINE)) N (CAR LINE))
(SET-LINEARRAY I NIL)
(TYOTBSP N)
;; This is inefficient. Should cons up a string if possible.
(PRINC (MAKNAM (CDR LINE)))
(MTERPRI)))
;; Move the cursor over N spaces to the left by outputting tabs and spaces.
;; This function assumes that the cursor is in the left margin when
;; it is called. This is only called from OUTPUT-LINEAR, so it is
;; used only for printing terminals or for file output.
(DEFUN TYOTBSP (N)
(DECLARE (FIXNUM N))
(DO () ((< N (TABLEN))) (TYO #\TAB) (DECREMENT N (TABLEN)))
(DO () ((< N 1)) (TYO #\SP) (DECREMENT N)))
(DEFUN DRAW-LINEAR (DMSTR OLDROW OLDCOL)
(DO ((LINE)) ((NULL DMSTR))
(COND ((ATOM (CAR DMSTR))
(SETQ LINE (LINEARRAY OLDROW))
(COND ((NULL LINE) (SETQ LINE (LIST OLDCOL)))
(T (PROG (N) (DECLARE (FIXNUM N M))
(SETQ N (CAR LINE) LINE (CDR LINE))
(DO ((M (+ (TABLEN) (* (TABLEN) (// N (TABLEN))))
(+ (TABLEN) M)))
((NOT (< M OLDCOL)) (SETQ N (MAX N (- M (TABLEN)))))
(SETQ LINE (CONS #\TAB LINE)))
(DO () ((= OLDCOL N))
(PUSH #\SP LINE)
(INCREMENT N)))))
(DO () ((OR (NULL DMSTR) (NOT (ATOM (CAR DMSTR))))
(SET-LINEARRAY OLDROW (CONS OLDCOL LINE)))
(INCREMENT OLDCOL)
(PUSH (CAR DMSTR) LINE)
(POP DMSTR)))
((FIXP (CAAR DMSTR))
;; Why update OLDCOL and not OLDROW? Should either update both
;; (requiring multiple value return) or neither (analagous to lambda
;; binding).
(SETQ OLDCOL (DRAW-LINEAR (REVERSE (CDDAR DMSTR))
(+ OLDROW (CADAR DMSTR))
(+ OLDCOL (CAAR DMSTR))))
(POP DMSTR))
(T (SETQ OLDCOL (LEXPR-FUNCALL (CAAR DMSTR) T (CDAR DMSTR)))
(POP DMSTR))))
;; Be sure to return this.
OLDCOL)
;; Output function for terminals with cursor positioning capability. Draws
;; equations in the order they are dimensioned. To be efficient, it does block
;; mode i/o into a stream called DISPLAY-FILE, set up in ALJABR;LOADER.
;; This function is not used if a WRITEFILE is taking place.
;; TTY interrupts are turned off for some reason, probably to protect global
;; state.
;; Bug in COMPLR necessitates binding H to 0 initially.
;; (PROG (H) (DECLARE (FIXNUM H)) ...) doesn't try binding it to NIL as
;; this does.
#+ITS
(DEFUN OUTPUT-2D (RESULT W &AUX (H 0))
(DECLARE (FIXNUM W H CH))
(UNWIND-PROTECT
(PROGN (TTYINTSOFF)
(SETQ OLDROW (CAR (CURSORPOS)) OLDCOL 0 H (+ OLDROW BKPTHT BKPTDP))
;; Move the cursor to the left edge of the screen.
(CURSORPOS* OLDROW 0)
;; Then print CRLFs from the top of the expression to the bottom.
;; The purpose of this is to clear the appropriate section of the
;; screen. If RUBOUT-TTY is NIL (i.e. we are using a storage tube
;; display), then only print LFs since the entire screen is cleared
;; anyway. %TDCRL = carriage return, line feed. %TDLF = line feed.
(DO ((CH (IF RUBOUT-TTY #.%TDCRL #.%TDLF))) ((= H OLDROW))
(TYO* CH) (INCREMENT OLDROW))
(DRAW-2D RESULT (- OLDROW BKPTDP 1) W)
;; Why is this necessary? Presumably, we never go off the bottom
;; of the screen.
(SETQ H (MIN (- TTYHEIGHT 2) H))
;; Leave the cursor at the bottom of the expression.
(CURSORPOS* H 0)
;; Output is buffered for efficiency.
(FORCE-OUTPUT DISPLAY-FILE)
;; Let ITS know where the cursor is now. This does not do
;; cursor movement. :CALL SCPOS for information.
(SETCURSORPOS H 0)
;; Gobble any characters the poor user may have typed during display.
(LISTEN))
(TTYINTSON))
(NOINTERRUPT NIL))
;; I/O is much simpler on the Lisp Machine.
#+LISPM
(DEFUN OUTPUT-2D (RESULT W &AUX H)
(DECLARE (FIXNUM W H CH))
(SETQ OLDROW (CAR (CURSORPOS)) OLDCOL 0 H (+ OLDROW BKPTHT BKPTDP))
(CURSORPOS* OLDROW 0)
;; Move the cursor vertically until we are at the bottom line of the
;; new expression.
(DO () ((= H OLDROW)) (TYO* #\NEWLINE) (INCREMENT OLDROW))
(DRAW-2D RESULT (- OLDROW BKPTDP 1) W)
(CURSORPOS* (SETQ H (MIN (- TTYHEIGHT 2) H)) 0))
;; For now, cursor movement is only available on ITS and the Lisp
;; Machine. But define this to catch possible errors.
#-(OR LISPM ITS)
(DEFUN OUTPUT-2D (RESULT W)
RESULT W ;Ignored.
(MERROR "OUTPUT-2D called on system without display support."))
#+(OR LISPM ITS)
(DEFUN DRAW-2D (DMSTR ROW COL)
(DECLARE (FIXNUM ROW COL))
(CURSORPOS* ROW COL)
(DO ((L DMSTR)) ((NULL L))
(COND ((FIXP (CAR L)) (TYO* (CAR L)) (POP L))
((FIXP (CAAR L))
(SETQ COL OLDCOL)
(DO () ((OR (FIXP (CAR L)) (NOT (FIXP (CAAR L)))))
(IF (NULL (CDDAR L)) (SETQ COL (+ COL (CAAR L)))
(DRAW-2D (REVERSE (CDDAR L))
(- ROW (CADAR L)) (+ COL (CAAR L)))
(SETQ COL OLDCOL))
(POP L))
(CURSORPOS* ROW COL))
(T (LEXPR-FUNCALL (CAAR L) NIL (CDAR L))
(POP L)))))
#-(OR LISPM ITS)
(DEFUN DRAW-2D (DMSTR ROW COL)
DMSTR ROW COL ;Ignored.
(MERROR "DRAW-2D called on system without display support."))
;; Crude line graphics. The interface to a graphics device is via the
;; functions LG-SET-POINT, LG-DRAW-VECTOR, LG-END-VECTOR and via the
;; LG-CHARACTER specials. LG-END-VECTOR is needed since many consoles
;; (including those supporting ARDS protocol) must "exit" graphics mode.
;; LG-CHARACTER-X and LG-CHARACTER-Y give the width and height of a character
;; in pixels, and the -2 variables are simply those numbers divided by 2. LG
;; stands for "Line Graphics". See MAXSRC;ARDS for a sample ctl.
(DECLARE (*EXPR LG-SET-POINT LG-DRAW-VECTOR LG-END-VECTOR)
#-NIL
(NOTYPE (LG-SET-POINT FIXNUM FIXNUM)
(LG-DRAW-VECTOR FIXNUM FIXNUM)
(LG-END-VECTOR FIXNUM FIXNUM))
(SPECIAL LG-CHARACTER-X LG-CHARACTER-X-2
LG-CHARACTER-Y LG-CHARACTER-Y-2))
;; Make this work in the new window system at some point.
#+LISPM (PROGN 'COMPILE
(DECLARE (SPECIAL LG-OLD-X LG-OLD-Y))
(DEFUN LG-SET-POINT (X Y)
(SETQ LG-OLD-X (- X 1) LG-OLD-Y (- Y 2)))
(DEFUN LG-DRAW-VECTOR (X Y)
(SETQ X (- X 1) Y (- Y 2))
(FUNCALL STANDARD-OUTPUT ':DRAW-LINE LG-OLD-X LG-OLD-Y X Y)
(WHEN (> LG-CHARACTER-Y 20)
(LET ((DELTA-X (- X LG-OLD-X))
(DELTA-Y (- Y LG-OLD-Y)))
(IF (> (ABS DELTA-X) (ABS DELTA-Y))
(FUNCALL STANDARD-OUTPUT ':DRAW-LINE LG-OLD-X (1- LG-OLD-Y) X (1- Y))
(FUNCALL STANDARD-OUTPUT ':DRAW-LINE (1- LG-OLD-X) LG-OLD-Y (1- X) Y))))
(SETQ LG-OLD-X X LG-OLD-Y Y))
;; Set these so that DISPLA can be called from top-level. The size
;; of TERMINAL-IO is wired in here.
;; These should be bound at time of call to DISPLA.
(SETQ LG-CHARACTER-X (FUNCALL TERMINAL-IO ':CHAR-WIDTH))
(SETQ LG-CHARACTER-Y (FUNCALL TERMINAL-IO ':LINE-HEIGHT))
(SETQ LG-CHARACTER-X-2 (// LG-CHARACTER-X 2))
(SETQ LG-CHARACTER-Y-2 (// LG-CHARACTER-Y 2))
) ;; End of Lispm Graphics definitions.
;; Even cruder character graphics. Interface to the ctl is via functions
;; which draw lines and corners. CG means "Character Graphics". See
;; MAXSRC;VT100 for a sample ctl. Note that these functions do not modify
;; the values of OLDROW and OLDCOL.
(DECLARE (*EXPR CG-BEGIN-GRAPHICS CG-END-GRAPHICS
CG-UL-CORNER CG-UR-CORNER CG-LL-CORNER CG-LR-CORNER
CG-VERTICAL-BAR CG-HORIZONTAL-BAR
CG-D-SUMSIGN CG-D-PRODSIGN))
;; Special form for turning on and turning off character graphics.
;; Be sure to turn of character graphics if we throw out of here.
;; (DEFMACRO CG-WITH-GRAPHICS (&BODY BODY)
;; `(UNWIND-PROTECT (PROGN (CG-BEGIN-GRAPHICS) . ,BODY) (CG-END-GRAPHICS)))
;; Not needed after all. - JPG
;; Special symbol drawing functions -- lines, boxes, summation signs, etc.
;; Every drawing function must take at least one argument. The first
;; argument is T if equations must be printed line-by-line. Otherwise,
;; draw them using cursor movement, character graphics, or line graphics
;; if possible.
;; Most of these functions just invoke DRAW-XXX on some constant
;; list structure, so be careful about NREVERSEing. In other cases,
;; stuff is consed only for the linear case, but direct calls are used
;; in the 2D case. This should work for both cases. (See end of
;; program.)
(DEFUN D-HBAR (LINEAR? W &OPTIONAL (CHAR #/-) &AUX NL)
(DECLARE (FIXNUM W CHAR GY))
(COND (LINEAR? (DOTIMES (I W) (PUSH CHAR NL))
(DRAW-LINEAR NL OLDROW OLDCOL))
((AND LINE-GRAPHICS-TTY $LINEDISP)
(LET ((GY (+ (* LG-CHARACTER-Y OLDROW) LG-CHARACTER-Y-2)))
(LG-SET-POINT (* OLDCOL LG-CHARACTER-X) GY)
(LG-END-VECTOR (* (+ OLDCOL W) LG-CHARACTER-X) GY))
(CURSORPOS* OLDROW (+ OLDCOL W)))
((AND CHARACTER-GRAPHICS-TTY $LINEDISP)
(CG-BEGIN-GRAPHICS)
(DOTIMES (I W) (CG-HORIZONTAL-BAR))
(INCREMENT OLDCOL W)
(CG-END-GRAPHICS))
(T (DOTIMES (I W) (TYO* CHAR)))))
;; Notice that in all of the height computations, an offset of 2 is added or
;; subtracted to the y-dimension. This is to get the lines to fit within the
;; character cell precisely and not get clipped when moving things around in
;; the equation editor.
(DEFUN D-VBAR (LINEAR? H D &OPTIONAL (CHAR #/|))
(DECLARE (FIXNUM H D CHAR GX))
(COND (LINEAR? (SETQ D (- D))
(DO ((I (- H 2) (1- I))
(NL `((0 ,(1- H) ,CHAR))))
((< I D) (DRAW-LINEAR (NREVERSE NL) OLDROW OLDCOL))
(PUSH `(-1 ,I ,CHAR) NL)))
((AND LINE-GRAPHICS-TTY $LINEDISP)
(LET ((GX (+ (* LG-CHARACTER-X OLDCOL) LG-CHARACTER-X-2)))
(LG-SET-POINT GX (- (* (+ OLDROW D 1) LG-CHARACTER-Y) 2))
(LG-END-VECTOR GX (+ (* (+ OLDROW 1 (- H)) LG-CHARACTER-Y) 2)))
(CURSORPOS* OLDROW (1+ OLDCOL)))
((AND CHARACTER-GRAPHICS-TTY $LINEDISP)
(CURSORPOS* (+ OLDROW 1 (- H)) OLDCOL)
(CG-BEGIN-GRAPHICS)
(CG-VERTICAL-BAR)
(DOTIMES (I (+ H D -1))
(CURSORPOS* (1+ OLDROW) OLDCOL)
(CG-VERTICAL-BAR))
(CG-END-GRAPHICS)
(CURSORPOS* (- OLDROW D) (1+ OLDCOL)))
(T (CURSORPOS* (+ OLDROW 1 (- H)) OLDCOL)
(TYO* CHAR)
(DOTIMES (I (+ H D -1))
(CURSORPOS* (1+ OLDROW) (1- OLDCOL))
(TYO* CHAR))
(CURSORPOS* (- OLDROW D) OLDCOL))))
(DEFUN D-INTEGRALSIGN (LINEAR? &AUX DMSTR)
(DECLARE (FIXNUM X-MIN X-1 X-2 X-MAX Y-MIN Y-1 Y-2 Y-MAX))
(COND ((AND (NOT LINEAR?) LINE-GRAPHICS-TTY $LINEDISP)
(LET ((X-MIN (* LG-CHARACTER-X OLDCOL))
(X-1 (1- LG-CHARACTER-X-2))
(X-2 LG-CHARACTER-X-2)
(X-MAX (* LG-CHARACTER-X (1+ OLDCOL)))
(Y-MIN (+ (* LG-CHARACTER-Y (- OLDROW 2)) LG-CHARACTER-Y-2))
(Y-1 LG-CHARACTER-Y-2)
(Y-2 (+ LG-CHARACTER-Y LG-CHARACTER-Y-2))
(Y-MAX (+ (* LG-CHARACTER-Y (+ OLDROW 2)) LG-CHARACTER-Y-2)))
(DOLIST (X '(0 -1))
(LG-SET-POINT (+ X X-MAX) Y-MIN)
(LG-DRAW-VECTOR (+ X X-MAX (- X-1)) (+ Y-MIN Y-1))
(LG-DRAW-VECTOR (+ X X-MAX (- X-2)) (+ Y-MIN Y-2))
(LG-DRAW-VECTOR (+ X X-MIN X-2) (- Y-MAX Y-2))
(LG-DRAW-VECTOR (+ X X-MIN X-1) (- Y-MAX Y-1))
(LG-END-VECTOR (+ X X-MIN) Y-MAX)))
(CURSORPOS* OLDROW (1+ OLDCOL)))
(T (SETQ DMSTR
`((0 2 #//) (-1 1 #/[) (-1 0 #/I) (-1 -1 #/]) (-1 -2 #//)))
(IF LINEAR?
(DRAW-LINEAR DMSTR OLDROW OLDCOL)
(DRAW-2D DMSTR OLDROW OLDCOL)))))
(DEFUN D-PRODSIGN (LINEAR? &AUX DMSTR)
(COND ((AND (NOT LINEAR?) $LINEDISP (FBOUNDP 'CG-D-PRODSIGN))
(CG-BEGIN-GRAPHICS)
(CG-D-PRODSIGN)
(CG-END-GRAPHICS)
(INCREMENT OLDCOL 5))
(T (SETQ DMSTR '((0 2 #/\ (D-HBAR 3 #/=) #//)
(-4 0) (D-VBAR 2 1 #/!) #\SP (D-VBAR 2 1 #/!) (1 0)))
(IF LINEAR?
(DRAW-LINEAR DMSTR OLDROW OLDCOL)
(DRAW-2D DMSTR OLDROW OLDCOL)))))
(DEFUN D-SUMSIGN (LINEAR? &AUX DMSTR)
(DECLARE (FIXNUM X-MIN X-HALF X-MAX Y-MIN Y-HALF Y-MAX))
(COND ((AND (NOT LINEAR?) $LINEDISP LINE-GRAPHICS-TTY)
(LET ((X-MIN (* LG-CHARACTER-X OLDCOL))
(X-HALF (* LG-CHARACTER-X (+ OLDCOL 2)))
(X-MAX (* LG-CHARACTER-X (+ OLDCOL 4)))
(Y-MIN (+ (* LG-CHARACTER-Y (- OLDROW 2)) LG-CHARACTER-Y-2))
(Y-HALF (+ (* LG-CHARACTER-Y OLDROW) LG-CHARACTER-Y-2))
(Y-MAX (+ (* LG-CHARACTER-Y (+ OLDROW 2)) LG-CHARACTER-Y-2)))
(LG-SET-POINT (+ X-MAX 4) (+ Y-MIN 6))
(MAPC #'(LAMBDA (X) (LG-DRAW-VECTOR (CAR X) (CDR X)))
`((,X-MAX . ,Y-MIN)
(,(1+ X-MIN) . ,Y-MIN)
(,(1+ X-HALF) . ,Y-HALF)
(,(1+ X-MIN) . ,Y-MAX)
(,X-MIN . ,Y-MAX)
(,X-HALF . ,Y-HALF)
(,X-MIN . ,Y-MIN)
(,(1- X-MIN) . ,Y-MIN)
(,(1- X-HALF) . ,Y-HALF)))
(LG-SET-POINT (+ X-MAX 4) (- Y-MAX 6))
(LG-DRAW-VECTOR X-MAX Y-MAX)
(LG-DRAW-VECTOR X-MIN Y-MAX)
(LG-DRAW-VECTOR X-MIN (1- Y-MAX))
(LG-END-VECTOR X-MAX (1- Y-MAX)))
(CURSORPOS* OLDROW (+ OLDCOL 4)))
((AND (NOT LINEAR?) $LINEDISP (FBOUNDP 'CG-D-SUMSIGN))
(CG-BEGIN-GRAPHICS)
(CG-D-SUMSIGN)
(CG-END-GRAPHICS)
(INCREMENT OLDCOL 4))
(T (SETQ DMSTR '((0 2 (D-HBAR 4 #/=))
(-4 1 #/\) #/> (-2 -1 #//)
(-1 -2 (D-HBAR 4 #/=))))
(IF LINEAR?
(DRAW-LINEAR DMSTR OLDROW OLDCOL)
(DRAW-2D DMSTR OLDROW OLDCOL)))))
;; Notice how this calls D-VBAR in the non-graphic case. The entire output
;; side should be structured this way, with no consing of intermediate
;; dimension strings.
(DEFUN D-MATRIX (LINEAR? DIRECTION H D)
(DECLARE (FIXNUM H D X-MIN X-MAX Y-MIN Y-MAX))
(COND ((AND (NOT LINEAR?) LINE-GRAPHICS-TTY $LINEDISP)
(LET ((X-MIN (1+ (* LG-CHARACTER-X OLDCOL)))
(X-MAX (1- (* LG-CHARACTER-X (1+ OLDCOL))))
(Y-MIN (+ (* LG-CHARACTER-Y (+ OLDROW 1 (- H))) 2))
(Y-MAX (- (* LG-CHARACTER-Y (+ OLDROW 1 D)) 2)))
(IF (EQ DIRECTION 'RIGHT) (PSETQ X-MIN X-MAX X-MAX X-MIN))
(LG-SET-POINT X-MAX Y-MIN)
(LG-DRAW-VECTOR X-MIN Y-MIN)
(LG-DRAW-VECTOR X-MIN Y-MAX)
(LG-END-VECTOR X-MAX Y-MAX))
(CURSORPOS* OLDROW (1+ OLDCOL)))
((AND (NOT LINEAR?) CHARACTER-GRAPHICS-TTY $LINEDISP)
(COND ((= (+ H D) 1)
(TYO* (GETCHARN (IF (EQ DIRECTION 'RIGHT) $RMXCHAR $LMXCHAR)
2)))
(T (CURSORPOS* (+ OLDROW 1 (- H)) OLDCOL)
(CG-BEGIN-GRAPHICS)
(IF (EQ DIRECTION 'RIGHT) (CG-UR-CORNER) (CG-UL-CORNER))
(CG-END-GRAPHICS)
(CURSORPOS* (+ OLDROW -1 H) OLDCOL)
(COND ((> (+ H D) 2)
(D-VBAR NIL (1- H) (1- D))
(CURSORPOS* (+ OLDROW D) (1- OLDCOL)))
(T (CURSORPOS* (+ OLDROW D) OLDCOL)))
(CG-BEGIN-GRAPHICS)
(IF (EQ DIRECTION 'RIGHT) (CG-LR-CORNER) (CG-LL-CORNER))
(CG-END-GRAPHICS)
(CURSORPOS* (- OLDROW D) (1+ OLDCOL)))))
(T (D-VBAR LINEAR? H D
(GETCHARN (IF (EQ DIRECTION 'RIGHT) $RMXCHAR $LMXCHAR)
2)))))
;; There is wired knowledge of character offsets here.
(DEFUN D-BOX (LINEAR? H D W BODY &AUX (CHAR 0) DMSTR)
(DECLARE (FIXNUM H D W CHAR X-MIN X-MAX Y-MIN Y-MAX))
(COND ((AND (NOT LINEAR?) LINE-GRAPHICS-TTY $LINEDISP)
(LET ((X-MIN (* LG-CHARACTER-X OLDCOL))
(X-MAX (* LG-CHARACTER-X (+ OLDCOL W 2)))
(Y-MIN (+ (* LG-CHARACTER-Y (- OLDROW H)) 2))
(Y-MAX (- (* LG-CHARACTER-Y (+ OLDROW D 2)) 2)))
(LG-SET-POINT X-MIN Y-MIN)
(LG-DRAW-VECTOR X-MAX Y-MIN)
(LG-DRAW-VECTOR X-MAX Y-MAX)
(LG-DRAW-VECTOR X-MIN Y-MAX)
(LG-END-VECTOR X-MIN Y-MIN))
(CURSORPOS* OLDROW (1+ OLDCOL))
(DRAW-2D BODY OLDROW OLDCOL)
(CURSORPOS* OLDROW (+ OLDCOL 1)))
((AND (NOT LINEAR?) CHARACTER-GRAPHICS-TTY $LINEDISP)
(D-MATRIX NIL 'LEFT (1+ H) (1+ D))
(CURSORPOS* (- OLDROW H) OLDCOL)
(D-HBAR NIL W)
(CURSORPOS* (+ OLDROW H) (- OLDCOL W))
(DRAW-2D BODY OLDROW OLDCOL)
(CURSORPOS* (+ OLDROW D 1) (- OLDCOL W))
(D-HBAR NIL W)
(CURSORPOS* (- OLDROW D 1) OLDCOL)
(D-MATRIX NIL 'RIGHT (1+ H) (1+ D)))
(T (SETQ CHAR (GETCHARN $BOXCHAR 2))
(SETQ DMSTR
`((0 ,H (D-HBAR ,(+ 2 W) ,CHAR))
(,(- (+ W 2)) 0)
(D-VBAR ,H ,D ,CHAR)
,@BODY
(,(- (1+ W)) ,(- (1+ D)) (D-HBAR ,(+ W 2) ,CHAR))
(-1 0)
(D-VBAR ,H ,D ,CHAR)))
(IF LINEAR?
(DRAW-LINEAR DMSTR OLDROW OLDCOL)
(DRAW-2D DMSTR OLDROW OLDCOL)))))
;; Primitive functions for doing equation drawing.
;; Position the cursor at a given place on the screen. %TDMV0 does
;; absolute cursor movement.
#+ITS
(DEFUN CURSORPOS* (ROW COL)
(DECLARE (FIXNUM ROW COL))
(+TYO #.%TDMV0 DISPLAY-FILE)
(+TYO ROW DISPLAY-FILE)
(+TYO COL DISPLAY-FILE)
(SETQ OLDROW ROW OLDCOL COL))
#-ITS
(DEFUN CURSORPOS* (ROW COL)
(DECLARE (FIXNUM ROW COL))
(CURSORPOS ROW COL)
(SETQ OLDROW ROW OLDCOL COL))
;; This function is transmitting ITS output buffer codes in addition to
;; standard ascii characters. See INFO;ITSTTY > for documentation. This
;; should convert tabs to direct cursor positioning commands since otherwise
;; they get stuffed down the raw stream and appear as gammas on sail consoles
;; and lose completely on terminals which can't tab. Backspace also loses,
;; but its nearly impossible to get a string with backspace in it in Macsyma.
;; Also, DISPLA can't dimension it correctly.
#+ITS
(DEFUN TYO* (CHAR)
(DECLARE (FIXNUM CHAR))
(COND ((= #\BS CHAR) (SETQ OLDCOL (1- OLDCOL))) ;Backspace
((< CHAR 128.) (SETQ OLDCOL (1+ OLDCOL)))) ;Printing graphic
(+TYO CHAR DISPLAY-FILE))
#-ITS
(DEFUN TYO* (CHAR)
(DECLARE (FIXNUM CHAR))
(IF (< CHAR 128.) (SETQ OLDCOL (1+ OLDCOL))) ;Printing graphic
(TYO CHAR))
;; Functions used by the packages for doing character graphics.
;; See MAXSRC;H19 or VT100.
#+ITS (PROGN 'COMPILE
(DEFMFUN CG-TYO (CHAR) (+TYO CHAR DISPLAY-FILE))
;; ITS does not change its idea of where the cursor position is when characters
;; are slipped by it using %TDQOT. This is used for operations which just
;; change the state of the terminal without moving the cursor. For actually
;; drawing characters, we use ordinary tyo since the cursor does indeed get
;; moved forward a position. Fortunately, it only takes one character to draw
;; each of the special characters.
(DEFMFUN CG-IMAGE-TYO (CHAR)
(CG-TYO #.%TDQOT)
(CG-TYO CHAR))
) ;; End of conditional
#-ITS (PROGN 'COMPILE
(DEFMFUN CG-TYO (CHAR) `(TYO ,CHAR))
(DEFMFUN CG-IMAGE-TYO (CHAR) `(TYO ,CHAR))
) ;; End of conditional
(DEFMFUN CG-TYO-N (L) (MAPC #'CG-TYO L))
(DEFMFUN CG-IMAGE-TYO-N (L) (MAPC #'CG-IMAGE-TYO L))
;; Things to do:
;; * Rewrite TYO* and CURSORPOS* to be "stream" oriented, i.e. they
;; either draw directly to the screen or into the linearray depending
;; upon the mode of output. This way, the HBAR and VBAR drawing functions
;; can be written only in terms of TYO*, etc. and never cons.
;; DRAW-LINEAR and DRAW-2D can be merged into a single function.
;; * Instead of calling NREVERSE from OUTPUT, call a function which
;; reverses at all levels and remove calls to REVERSE from DRAW-LINEAR
;; and DRAW-2D.
;; * Dimension functions should know whether the output must be linear.
;; This way they can do variable sized summation and integral signs,
;; graphical square root or SQRT(X), %PI  , >=  , etc.
;; These are situations where the size of the dimensioned
;; result depends upon the form of the output.
;; * Fix display of MLABOX for graphic consoles.
Reference in New Issue View Git Blame Copy Permalink