reduce-historical/r30/pretty.red

% 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;