Artifact 4d5d9e2168b671680d6c15937aed48c3d41c0a4c30482ed0ace86dedfe0f577c:
- File
r30/pretty.red
— part of check-in
[eb17ceb7f6]
at
2020-04-21 19:40:01
on branch master
— Add Reduce 3.0 to the historical section of the archive, and some more
files relating to version sof PSL from the early 1980s. Thanks are due to
Paul McJones and Nelson Beebe for these, as well as to all the original
authors.git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 12368) [annotate] [blame] [check-ins using] [more...]
% This package prints list structures in an indented format that % is intended to make them legible. There are a number of special % cases recognized, but in general the intent of the algorithm % is that given a list (R1 R2 R3 ...), SUPERPRINT checks if % the list will fit directly on the current line and if so % prints it as: % (R1 R2 R3 ...) % if not it prints it as: % (R1 % R2 % R3 % ... ) % where each sublist is similarly treated. % % A. C. Norman. July 1978; % Functions: % SUPERPRINT(X) print expression X % SUPERPRINTM(X,M) print expression X with left margin M % PRETTYPRINT(X) = << SUPERPRINTM(X,POSN()), TERPRI() >> % % Flag: % !*SYMMETRIC If TRUE, print with escape characters, % otherwise do not (as PRIN1/PRIN2 % distinction). defaults to TRUE; % !*QUOTES If TRUE, (QUOTE x) gets displayed as 'x. % default is TRUE; % % Variable: % THIN!* if THIN!* expressions can be fitted onto % a single line they will be printed that way. % this is a parameter used to control the % formatting of long thin lists. default % value is 5; SYMBOLIC; GLOBAL '(!*SYMMETRIC !*QUOTES THIN!*); !*SYMMETRIC:=T; !*QUOTES:=T; THIN!*:=5; SYMBOLIC PROCEDURE SUPERPRINT X; << SUPERPRINM(X,0); TERPRI(); X>>; SYMBOLIC PROCEDURE PRETTYPRINT X; << SUPERPRINM(X,POSN()); %WHAT REDUCE DOES NOW; TERPRI(); TERPRI(); NIL>>; SYMBOLIC PROCEDURE SUPERPRINTM(X,LMAR); << SUPERPRINM(X,LMAR); TERPRI(); X >>; % FROM HERE DOWN THE FUNCTIONS ARE NOT INTENDED FOR DIRECT USE; % THE FOLLOWING FUNCTIONS ARE DEFINED HERE IN CASE THIS PACKAGE % IS CALLED FROM LISP RATHER THAN REDUCE; SYMBOLIC PROCEDURE EQCAR(A,B); PAIRP A AND CAR A EQ B; SYMBOLIC PROCEDURE SPACES N; FOR I=1:N DO PRIN2 '! ; % END OF COMPATIBILITY SECTION; FLUID '(STACK BUFFERI BUFFERO BN LMAR RMAR INITIALBLANKS PENDINGRPARS INDENTLEVEL INDBLANKS RPARCOUNT); SYMBOLIC PROCEDURE SUPERPRINM(X,LMAR); BEGIN SCALAR STACK,BUFFERI,BUFFERO,BN,INITIALBLANKS,RMAR, PENDINGRPARS,INDENTLEVEL,INDBLANKS,RPARCOUNT,W; BUFFERI:=BUFFERO:=LIST NIL; %FIFO BUFFER; INITIALBLANKS:=0; RPARCOUNT:=0; INDBLANKS:=0; RMAR:=LINELENGTH(NIL)-3; %RIGHT MARGIN; IF RMAR<25 THEN ERROR(0,LIST(RMAR+3, "LINELENGTH TOO SHORT FOR SUPERPRINTING")); BN:=0; %CHARACTERS IN BUFFER; INDENTLEVEL:=0; %NO INDENTATION NEEDED, YET; IF LMAR+20>=RMAR THEN LMAR:=RMAR-21; %NO ROOM FOR SPECIFIED MARGIN; W:=POSN(); IF W>LMAR THEN << TERPRI(); W:=0 >>; IF W<LMAR THEN INITIALBLANKS:=LMAR-W; PRINDENT(X,LMAR+3); %MAIN RECURSIVE PRINT ROUTINE; % TRAVERSE ROUTINE FINISHED - NOW TIDY UP BUFFERS; OVERFLOW 'NONE; %FLUSH OUT THE BUFFER; RETURN X END; % ACCESS FUNCTIONS FOR A STACK ENTRY; SMACRO PROCEDURE TOP; CAR STACK; SMACRO PROCEDURE DEPTH FRM; CAR FRM; SMACRO PROCEDURE INDENTING FRM; CADR FRM; SMACRO PROCEDURE BLANKCOUNT FRM; CADDR FRM; SMACRO PROCEDURE BLANKLIST FRM; CDDDR FRM; SMACRO PROCEDURE SETINDENTING(FRM,VAL); RPLACA(CDR FRM,VAL); SMACRO PROCEDURE SETBLANKCOUNT(FRM,VAL); RPLACA(CDDR FRM,VAL); SMACRO PROCEDURE SETBLANKLIST(FRM,VAL); RPLACD(CDDR FRM,VAL); SMACRO PROCEDURE NEWFRAME N; LIST(N,NIL,0); SMACRO PROCEDURE BLANKP CHAR; NUMBERP CAR CHAR; SYMBOLIC PROCEDURE PRINDENT(X,N); % PRINT LIST X WITH INDENTATION LEVEL N; IF ATOM X THEN IF VECTORP X THEN PRVECTOR(X,N) ELSE FOR EACH C IN (IF !*SYMMETRIC THEN IF STRINGP X THEN EXPLODES X ELSE EXPLODE X ELSE EXPLODEC X) DO PUTCH C ELSE IF QUOTEP X THEN << PUTCH '!'; PRINDENT(CADR X,N+1) >> ELSE BEGIN SCALAR CX; IF 4*N>3*RMAR THEN << %LIST IS TOO DEEP FOR SANITY; OVERFLOW 'ALL; N:=N/8; IF INITIALBLANKS>N THEN << LMAR:=LMAR-INITIALBLANKS+N; INITIALBLANKS:=N >> >>; STACK := (NEWFRAME N) . STACK; PUTCH ('LPAR . TOP()); CX:=CAR X; PRINDENT(CX,N+1); IF IDP CX AND NOT ATOM CDR X THEN CX:=GET(CX,'PPFORMAT) ELSE CX:=NIL; IF CX=2 AND ATOM CDDR X THEN CX:=NIL; IF CX='PROG THEN << PUTCH '! ; PRINDENT(CAR (X:=CDR X),N+3) >>; % CX NOW CONTROLS THE FORMATTING OF WHAT FOLLOWS: % NIL DEFAULT ACTION % <NUMBER> FIRST FEW BLANKS ARE NON-INDENTING % PROG DISPLAY ATOMS AS LABELS; X:=CDR X; SCAN: IF ATOM X THEN GO TO OUT; FINISHPENDING(); %ABOUT TO PRINT A BLANK; IF CX='PROG THEN << PUTBLANK(); OVERFLOW BUFFERI; %FORCE FORMAT FOR PROG; IF ATOM CAR X THEN << % A LABEL; LMAR:=INITIALBLANKS:=MAX(LMAR-6,0); PRINDENT(CAR X,N-3); % PRINT THE LABEL; X:=CDR X; IF NOT ATOM X AND ATOM CAR X THEN GO TO SCAN; IF LMAR+BN>N THEN PUTBLANK() ELSE FOR I=LMAR+BN:N-1 DO PUTCH '! ; IF ATOM X THEN GO TO OUT >> >> ELSE IF NUMBERP CX THEN << CX:=CX-1; IF CX=0 THEN CX:=NIL; PUTCH '! >> ELSE PUTBLANK(); PRINDENT(CAR X,N+3); X:=CDR X; GO TO SCAN; OUT: IF NOT NULL X THEN << FINISHPENDING(); PUTBLANK(); PUTCH '!.; PUTCH '! ; PRINDENT(X,N+5) >>; PUTCH ('RPAR . (N-3)); IF INDENTING TOP()='INDENT AND NOT NULL BLANKLIST TOP() THEN OVERFLOW CAR BLANKLIST TOP() ELSE ENDLIST TOP(); STACK:=CDR STACK END; SYMBOLIC PROCEDURE EXPLODES X; %dummy function just in case another format is needed; EXPLODE X; SYMBOLIC PROCEDURE PRVECTOR(X,N); BEGIN SCALAR BOUND; BOUND:=UPBV X; % LENGTH OF THE VECTOR; STACK:=(NEWFRAME N) . STACK; PUTCH ('LSQUARE . TOP()); PRINDENT(GETV(X,0),N+3); FOR I=1:BOUND DO << PUTCH '!,; PUTBLANK(); PRINDENT(GETV(X,I),N+3) >>; PUTCH('RSQUARE . (N-3)); ENDLIST TOP(); STACK:=CDR STACK END; SYMBOLIC PROCEDURE PUTBLANK(); BEGIN SCALAR B; PUTCH TOP(); %REPRESENTS A BLANK CHARACTER; SETBLANKCOUNT(TOP(),BLANKCOUNT TOP()+1); SETBLANKLIST(TOP(),BUFFERI . BLANKLIST TOP()); %REMEMBER WHERE I WAS; INDBLANKS:=INDBLANKS+1 END; SYMBOLIC PROCEDURE ENDLIST L; %FIX UP THE BLANKS IN A COMPLETE LIST SO THAT THEY %WILL NOT BE TURNED INTO INDENTATIONS; PENDINGRPARS:=L . PENDINGRPARS; % WHEN I HAVE PRINTED A ')' I WANT TO MARK ALL OF THE BLANKS % WITHIN THE PARENTHESES AS BEING UNINDENTED, ORDINARY BLANK % CHARACTERS. IT IS HOWEVER POSSIBLE THAT I MAY GET A BUFFER % OVERFLOW WHILE PRINTING A STRING OF )))))))))), AND SO THIS % MARKING SHOULD BE DELAYED UNTIL I GET ROUND TO PRINTING % A FURTHER BLANK (WHICH WILL BE A CANDIDATE FOR A PLACE TO % SPLIT LINES). THIS DELAY IS DEALT WITH BY THE LIST % PENDINGRPARS WHICH HOLDS A LIST OF LEVELS THAT, WHEN % CONVENIENT, CAN BE TIDIED UP AND CLOSED OUT; SYMBOLIC PROCEDURE FINISHPENDING(); << FOR EACH STACKFRAME IN PENDINGRPARS DO << IF INDENTING STACKFRAME NEQ 'INDENT THEN FOR EACH B IN BLANKLIST STACKFRAME DO << RPLACA(B,'! ); INDBLANKS:=INDBLANKS-1 >>; % BLANKLIST OF STACKFRAME MUST BE NON-NIL SO THAT OVERFLOW % WILL NOT TREAT THE '(' SPECIALLY; SETBLANKLIST(STACKFRAME,T) >>; PENDINGRPARS:=NIL >>; SYMBOLIC PROCEDURE QUOTEP X; !*QUOTES AND NOT ATOM X AND CAR X='QUOTE AND NOT ATOM CDR X AND NULL CDDR X; % PROPERTY PPFORMAT DRIVES THE PRETTYPRINTER - % PROG : SPECIAL FOR PROG ONLY % 1 : (FN A1 % A2 % ... ) % 2 : (FN A1 A2 % A3 % ... ) ; PUT('PROG,'PPFORMAT,'PROG); PUT('LAMBDA,'PPFORMAT,1); PUT('LAMBDAQ,'PPFORMAT,1); PUT('SETQ,'PPFORMAT,1); PUT('SET,'PPFORMAT,1); PUT('WHILE,'PPFORMAT,1); PUT('T,'PPFORMAT,1); PUT('DE,'PPFORMAT,2); PUT('DF,'PPFORMAT,2); PUT('DM,'PPFORMAT,2); PUT('FOREACH,'PPFORMAT,4); % (FOREACH X IN Y DO ...) ETC; % NOW FOR THE ROUTINES THAT BUFFER THINGS ON A CHARACTER BY CHARACTER % BASIS, AND DEAL WITH BUFFER OVERFLOW; SYMBOLIC PROCEDURE PUTCH C; BEGIN IF ATOM C THEN RPARCOUNT:=0 ELSE IF BLANKP C THEN << RPARCOUNT:=0; GO TO NOCHECK >> ELSE IF CAR C='RPAR THEN << RPARCOUNT:=RPARCOUNT+1; % FORMAT FOR A LONG STRING OF RPARS IS: % )))) ))) ))) ))) ))) ; IF RPARCOUNT>4 THEN << PUTCH '! ; RPARCOUNT:=2 >> >> ELSE RPARCOUNT:=0; WHILE LMAR+BN>=RMAR DO OVERFLOW 'MORE; NOCHECK: BUFFERI:=CDR RPLACD(BUFFERI,LIST C); BN:=BN+1 END; SYMBOLIC PROCEDURE OVERFLOW FLG; BEGIN SCALAR C,BLANKSTOSKIP; %THE CURRENT BUFFER HOLDS SO MUCH INFORMATION THAT IT WILL %NOT ALL FIT ON A LINE. TRY TO DO SOMETHING ABOUT IT; % FLG IS ONE OF: % 'NONE DO NOT FORCE MORE INDENTATION % 'MORE FORCE ONE LEVEL MORE INDENTATION % <A POINTER INTO THE BUFFER> % PRINTS UP TO AND INCLUDING THAT CHARACTER, WHICH % SHOULD BE A BLANK; IF INDBLANKS=0 AND INITIALBLANKS>3 AND FLG='MORE THEN << INITIALBLANKS:=INITIALBLANKS-3; LMAR:=LMAR-3; RETURN 'MOVED!-LEFT >>; FBLANK: IF BN=0 THEN << %NO BLANK FOUND - CAN DO NO MORE FOR NOW; % IF FLG='MORE I AM IN TROUBLE AND SO HAVE TO PRINT % A CONTINUATION MARK. IN THE OTHER CASES I CAN JUST EXIT; IF NOT(FLG = 'MORE) THEN RETURN 'EMPTY; IF ATOM CAR BUFFERO THEN % CONTINUATION MARK NOT NEEDED IF LAST CHAR PRINTED WAS % SPECIAL (E.G. LPAR OR RPAR); PRIN2 "%+"; %CONTINUATION MARKER; TERPRI(); LMAR:=0; RETURN 'CONTINUED >> ELSE << SPACES INITIALBLANKS; INITIALBLANKS:=0 >>; BUFFERO:=CDR BUFFERO; BN:=BN-1; LMAR:=LMAR+1; C:=CAR BUFFERO; IF ATOM C THEN << PRIN2 C; GO TO FBLANK >> ELSE IF BLANKP C THEN IF NOT ATOM BLANKSTOSKIP THEN << PRIN2 '! ; INDBLANKS:=INDBLANKS-1; % BLANKSTOSKIP = (STACK-FRAME . SKIP-COUNT); IF C EQ CAR BLANKSTOSKIP THEN << RPLACD(BLANKSTOSKIP,CDR BLANKSTOSKIP-1); IF CDR BLANKSTOSKIP=0 THEN BLANKSTOSKIP:=T >>; GO TO FBLANK >> ELSE GO TO BLANKFOUND ELSE IF CAR C='LPAR OR CAR C='LSQUARE THEN << PRIN2 GET(CAR C,'PPCHAR); IF FLG='NONE THEN GO TO FBLANK; % NOW I WANT TO FLAG THIS LEVEL FOR INDENTATION; C:=CDR C; %THE STACK FRAME; IF NOT NULL BLANKLIST C THEN GO TO FBLANK; IF DEPTH C>INDENTLEVEL THEN << %NEW INDENTATION; % THIS LEVEL HAS NOT EMITTED ANY BLANKS YET; INDENTLEVEL:=DEPTH C; SETINDENTING(C,'INDENT) >>; GO TO FBLANK >> ELSE IF CAR C='RPAR OR CAR C='RSQUARE THEN << IF CDR C<INDENTLEVEL THEN INDENTLEVEL:=CDR C; PRIN2 GET(CAR C,'PPCHAR); GO TO FBLANK >> ELSE ERROR(0,LIST(C,"UNKNOWN TAG IN OVERFLOW")); BLANKFOUND: IF EQCAR(BLANKLIST C,BUFFERO) THEN SETBLANKLIST(C,NIL); % AT LEAST ONE ENTRY ON BLANKLIST OUGHT TO BE VALID, SO IF I % PRINT THE LAST BLANK I MUST KILL BLANKLIST TOTALLY; INDBLANKS:=INDBLANKS-1; % CHECK IF NEXT LEVEL REPRESENTS NEW INDENTATION; IF DEPTH C>INDENTLEVEL THEN << IF FLG='NONE THEN << %JUST PRINT AN ORDINARY BLANK; PRIN2 '! ; GO TO FBLANK >>; % HERE I INCREASE THE INDENTATION LEVEL BY ONE; IF BLANKSTOSKIP THEN BLANKSTOSKIP:=NIL ELSE << INDENTLEVEL:=DEPTH C; SETINDENTING(C,'INDENT) >> >>; %OTHERWISE I WAS INDENTING AT THAT LEVEL ANYWAY; IF BLANKCOUNT C>(THIN!*-1) THEN << %LONG THIN LIST FIX-UP HERE; BLANKSTOSKIP:=C . ((BLANKCOUNT C) - 2); SETINDENTING(C,'THIN); SETBLANKCOUNT(C,1); INDENTLEVEL:=(DEPTH C)-1; PRIN2 '! ; GO TO FBLANK >>; SETBLANKCOUNT(C,(BLANKCOUNT C)-1); TERPRI(); LMAR:=INITIALBLANKS:=DEPTH C; IF BUFFERO EQ FLG THEN RETURN 'TO!-FLG; IF BLANKSTOSKIP OR NOT (FLG='MORE) THEN GO TO FBLANK; % KEEP GOING UNLESS CALL WAS OF TYPE 'MORE'; RETURN 'MORE; %TRY SOME MORE; END; PUT('LPAR,'PPCHAR,'!(); PUT('LSQUARE,'PPCHAR,'![); PUT('RPAR,'PPCHAR,'!)); PUT('RSQUARE,'PPCHAR,'!]); END;