reduce-historical/r37/packages/matrix/matpri2.red

MODULE MATPRI; % matrix prettyprinter

% Author: Takeyuki Takahashi, Toyohashi University of Technology.

GLOBAL '(!&COUNT!& !&M!-P!-FLAG!& !&NAME !&NAMEARRAY);

% General functions.

SYMBOLIC PROCEDURE TERPRI!* U;
   BEGIN INTEGER N;
      IF !&M!-P!-FLAG!& THEN <<!&COUNT!& := T; GO TO C>>;
      IF !*FORT THEN RETURN FTERPRI U
       ELSE IF NOT PLINE!* OR NOT !*NAT THEN GO TO B;
      N := YMAX!*;
      PLINE!* := REVERSE PLINE!*;
    A:
      SCPRINT(PLINE!*,N);
      TERPRI();
      IF N=YMIN!* THEN GO TO B;
      N := N - 1;
      GO TO A;
    B:
      IF U THEN TERPRI();
    C:
      PLINE!* := NIL;
      POSN!* := ORIG!*;
      YCOORD!* := YMAX!* := YMIN!* := 0
   END;

SYMBOLIC PROCEDURE PLUS!-L U; PLUS!-L1(0,U);

SYMBOLIC PROCEDURE PLUS!-L1(N,U);
   IF NULL U THEN N ELSE <<N := N + CAR U; PLUS!-L1(N,CDR U)>>;

SYMBOLIC PROCEDURE DELNTH(N,L);
   IF N=1 THEN CDR L ELSE CAR L . DELNTH(N - 1,CDR L);


% MATRIX Pretty printer.

SYMBOLIC PROCEDURE MAT!-P!-PRINT U;
   BEGIN INTEGER C!-LENG1,ICOLN,PP,ICOL,COLUMN!-LENG,M,N;
         SCALAR COLUMN!-S!-POINT,MAXLENG,ELEMENT!-LENG;
      U := CDR U;
      ICOLN := LENGTH CAR U;
      ICOL := LINELENGTH NIL - 8;
      !&M!-P!-FLAG!& := T;
      ELEMENT!-LENG := !&COUNT U;
      !&M!-P!-FLAG!& := NIL;
    A:
      MAXLENG := !&MAX!-ROW ELEMENT!-LENG;
      C!-LENG1 := PLUS!-L MAXLENG + 3*(ICOLN - 1);
      IF C!-LENG1=COLUMN!-LENG THEN GO TO DUMP;
      COLUMN!-LENG := C!-LENG1;
      IF COLUMN!-LENG>ICOL
        THEN <<ELEMENT!-LENG :=
                SUBST( - 1,MAXL MAXLENG,ELEMENT!-LENG);
               GO TO A>>;
      PRIN2!* !&NAME;
      PRIN2!* " := ";
      TERPRI!* NIL;
      N := 0;
      COLUMN!-S!-POINT :=
       FOR EACH Y IN MAXLENG COLLECT <<N := N + Y;
                                       N := N + 3;
                                       N + 3>>;
      COLUMN!-S!-POINT := APPEND(LIST 3,COLUMN!-S!-POINT);
      TERPRI();
      PRIN2 "|-";
      SPACES (COLUMN!-LENG + 4);
      PRIN2 "-|";
      TERPRI();
      M := 1;
      FOR EACH Y IN U DO
         <<N := 1;
           FOR EACH Z IN Y DO
              <<POSN!* := NTH(COLUMN!-S!-POINT,N);
                IF NTH(NTH(ELEMENT!-LENG,M),N)<0
                  THEN <<PRIN2!* "*";
                         PRIN2!* "(";
                         PRIN2!* M;
                         PRIN2!* ",";
                         PRIN2!* N;
                         PRIN2!* ")">>
                 ELSE MAPRIN Z;
                N := N + 1>>;
           PP := COLUMN!-LENG + 7;
           FOR I := YMIN!*:YMAX!* DO
              <<PLINE!* := APPEND(PLINE!*, LIST(((0 . 1) . I) . "|"));
                PLINE!* := APPEND(LIST(((PP . (PP + 1)) . I) . "|"),
                                  PLINE!*)>>;
           TERPRI!* NIL;
           M := M + 1;
           PRIN2 "| ";
           SPACES (COLUMN!-LENG + 4);
           PRIN2 " |";
           TERPRI()>>;
      PRIN2 "|-";
      SPACES (COLUMN!-LENG + 4);
      PRIN2 "-|";
      TERPRI();
      TERPRI();
      M := 1;
      FOR EACH Y IN U DO
         <<N := 1;
           FOR EACH Z IN Y DO
              <<IF NTH(NTH(ELEMENT!-LENG,M),N)<0
                       THEN <<PRIN2!* "*";
                              PRIN2!* "(";
                              PRIN2!* M;
                              PRIN2!* ",";
                              PRIN2!* N;
                              PRIN2!* ")";
                              PRIN2!* " ";
                              MAPRIN Z;
                              TERPRI!* T>>;
                N := N + 1>>;
           M := M + 1>>;
      RETURN NIL;
    DUMP:
      PRIN2T "Column length too long";
      MATPRI!*('MAT . U,LIST MKQUOTE !&NAME,'ONLY)
   END;

SYMBOLIC PROCEDURE !&COUNT U;
   BEGIN INTEGER N;
      RETURN FOREACH Y IN U COLLECT
                FOREACH Z IN Y COLLECT
                   <<!&COUNT!& := NIL;
                     MAPRIN Z;
                     N := POSN!*;
                     PLINE!* := NIL;
                     POSN!* := ORIG!*;
                     YCOORD!* := YMAX!* := YMIN!* := 0;
                     IF NULL !&COUNT!& THEN N ELSE MINUS N>>;
   END;

GLOBAL '(!&MAX!-L);

SYMBOLIC PROCEDURE !&MAX!-ROW U;
   BEGIN SCALAR V;
    A:
      IF NULL CAR U THEN RETURN V;
      U := !&MAX!-ROW1 U;
      V := APPEND(V,LIST !&MAX!-L);
      GO TO A
   END;

SYMBOLIC PROCEDURE !&MAX!-ROW1 U;
   BEGIN
      !&MAX!-L := 1;
      RETURN FOR EACH Y IN U COLLECT
                <<!&MAX!-L := IF CAR Y<0 THEN 6
                               ELSE MAX(!&MAX!-L,CAR Y);
                  CDR Y>>
   END;

SYMBOLIC PROCEDURE MAXL U; MAXL1(CDR U,CAR U);

SYMBOLIC PROCEDURE MAXL1(U,V);
   IF NULL U THEN V
    ELSE IF CAR U>V THEN MAXL1(CDR U,CAR U)
    ELSE MAXL1(CDR U,V);

SYMBOLIC PROCEDURE MPRINT U;
   BEGIN SCALAR V;
    A:
      IF NULL U THEN RETURN NIL
       ELSE IF ATOM CAR U AND (V := GET(CAR U,'MATRIX))
        THEN <<!&NAME := CAR U;
               MAT!-P!-PRINT V;
               !&NAME := NIL>>
       ELSE IF STRINGP CAR U THEN VARPRI(CAR U,NIL,'ONLY)
       ELSE IF V := ARRAYP CAR U
        THEN <<!&NAMEARRAY := CAR U;
               PRINT!-ARRAY2(LIST V,NIL);
               !&NAMEARRAY := NIL;
               NIL>>
       ELSE <<!&NAME := CAR U;
              RAT!-P!-PRINT AEVAL CAR U;
              !&NAME := NIL>>;
    B:
      U := CDR U;
      GO TO A
   END;

RLISTAT '(MPRINT);

SYMBOLIC PROCEDURE PRINT!-ARRAY2(U,W);
   BEGIN INTEGER N; SCALAR V;
      V := CAR U;
      IF CAR V EQ '!&VECTOR
        THEN BEGIN
                N := CADR V;
                V := CDR V;
                IF W THEN W := CAR W;
                FOR I := 0:N DO
                   <<V := CDR V;
                     PRINT!-ARRAY2(V,LIST APPEND(W,LIST I))>>
             END
       ELSE IF V NEQ 0
        THEN <<!&NAME := APPEND(LIST !&NAMEARRAY,CAR W);
               RAT!-P!-PRINT V;
               !&NAME := NIL>>
   END;


% Rational function Pretty printer.

SYMBOLIC PROCEDURE RAT!-P!-PRINT U;
   BEGIN INTEGER OS,LN,ORGNUM,ORGDEN,LL,LENNUM,LENDEN;
         SCALAR NAME,UDEN,UNUM;
      IF NULL U THEN RETURN NIL;
      IF NUMBERP U
        THEN <<VARPRI(U,LIST MKQUOTE !&NAME,'ONLY);
               TERPRI();
               !&NAME := NIL;
               RETURN NIL>>;
      U := CADR U;
      !&M!-P!-FLAG!& := T;
      LENDEN := !&COUNT!-LENGTH (UDEN := CDR U./1);
      LENNUM := !&COUNT!-LENGTH (UNUM := CAR U./1);
      !&M!-P!-FLAG!& := NIL;
      LN := (LINELENGTH NIL - LENGTHC !&NAME) - 4;
      OS := ORIG!*;
      IF CDR U=1 OR LENDEN>LN OR LENNUM>LN THEN GO TO DUMP;
      IF !&NAME
        THEN <<INPRINT('SETQ,2,LIST !&NAME);
               OPRIN 'SETQ;
               NAME := PLINE!*;
               OS := POSN!*;
               !&NAME := NIL;
               PLINE!* := NIL>>;
      IF LENDEN>LENNUM
        THEN <<ORGNUM := (LENDEN - LENNUM)/2; LL := LENDEN>>
       ELSE <<ORGDEN := (LENNUM - LENDEN)/2; LL := LENNUM>>;
      POSN!* := ORGNUM + OS + 1;
      MAPRIN MK!*SQ UNUM;
      TERPRI!* NIL;
      IF NAME THEN PLINE!* := NAME ELSE PLINE!* := NIL;
      POSN!* := OS;
      FOR I := 1:LL + 2 DO PRIN2!* "-";
      TERPRI!* NIL;
      POSN!* := ORGDEN + OS + 1;
      MAPRIN MK!*SQ UDEN;
      TERPRI!* T;
      RETURN NIL;
    DUMP:
      VARPRI(MK!*SQ U,LIST MKQUOTE !&NAME,'ONLY);
      TERPRI();
      !&NAME := NIL
   END;

SYMBOLIC PROCEDURE !&COUNT!-LENGTH U;
   BEGIN INTEGER N;
      !&COUNT!& := NIL;
      MAPRIN MK!*SQ U;
      N := POSN!* - ORIG!*;
      IF !&COUNT!& THEN N := LINELENGTH NIL + 10;
      PLINE!* := NIL;
      POSN!* := ORIG!*;
      YCOORD!* := YMAX!* := YMIN!* := 0;
      RETURN N
   END;

ENDMODULE;

END;