Category : Pascal Source Code
Archive   : SOFTOOLS.ZIP
Filename : CHAPTER2.PAS

{chapter2.pas}

{
Copyright (c) 1981
By: Bell Telephone Laboratories, Inc. and
Whitesmith's Ltd.,

This software is derived from the book
"Software Tools in Pascal", by
Brian W. Kernighan and P. J. Plauger
Addison-Wesley, 1981
ISBN 0-201-10342-7

Right is hereby granted to freely distribute or duplicate this
software, providing distribution or duplication is not for profit
or other commercial gain and that this copyright notice remains
intact.
}

PROCEDURE TRANSLIT;FORWARD;
PROCEDURE ENTAB;FORWARD;
PROCEDURE EXPAND;FORWARD;
PROCEDURE ECHO;FORWARD;
PROCEDURE COMPRESS;FORWARD;
PROCEDURE OVERSTRIKE;FORWARD;


PROCEDURE OVERSTRIKE;
CONST
SKIP=BLANK;
NOSKIP=PLUS;
VAR
C:CHARACTER;
COL,NEWCOL,I:INTEGER;
BEGIN
COL:=1;
REPEAT
NEWCOL:=COL;
WHILE(GETC(C)=BACKSPACE) DO
NEWCOL:=MAX(NEWCOL-1,1);
IF (NEWCOL PUTC(NEWLINE);
PUTC(NOSKIP);
FOR I:=1 TO NEWCOL-1 DO
PUTC(BLANK);
COL:=NEWCOL
END
ELSE IF (COL=1) AND (C<>ENDFILE) THEN
PUTC(SKIP);
IF(C<>ENDFILE)THEN BEGIN
PUTC(C);
IF (C=NEWLINE) THEN
COL:=1
ELSE
COL:=COL+1
END
UNTIL (C=ENDFILE)
END;

PROCEDURE COMPRESS;
CONST
WARNING=CARET;
VAR
C,LASTC:CHARACTER;
N:INTEGER;

PROCEDURE PUTREP(N:INTEGER;C:CHARACTER);CONST
MAXREP=26;
THRESH=4;
BEGIN
WHILE(N>=THRESH)OR((C=WARNING)AND(N>0))DO BEGIN
PUTC(WARNING);
PUTC(MIN(N,MAXREP)-1+ORD('A'));
PUTC(C);
N:=N-MAXREP
END;
FOR N:=N DOWNTO 1 DO
PUTC(C)
END;

BEGIN(*COMPRESS*)
N:=1;
LASTC:=GETC(LASTC);
WHILE(LASTC<>ENDFILE) DO BEGIN
IF(GETC(C)=ENDFILE)THEN BEGIN
IF(N>1) OR(LASTC=WARNING) THEN
PUTREP(N,LASTC)
ELSE
PUTC(LASTC)
END
ELSE IF (C=LASTC) THEN
N:=N+1
ELSE IF (N>1) OR (LASTC=WARNING) THEN BEGIN
PUTREP(N,LASTC);
N:=1
END
ELSE
PUTC(LASTC);
LASTC:=C
END
END;

PROCEDURE EXPAND;
CONST
WARNING=CARET;
VAR
C:CHARACTER;
N:INTEGER;
BEGIN
WHILE(GETC(C)<>ENDFILE) DO
IF (C<>WARNING)THEN
PUTC(C)
ELSE IF(ISUPPER(GETC(C))) THEN BEGIN
N:=C-ORD('A')+1;
IF(GETC(C)<>ENDFILE)THEN
FOR N:=N DOWNTO 1 DO
PUTC(C)
ELSE BEGIN
PUTC(WARNING);
PUTC(N-1+ORD('A'))
END
END
ELSE BEGIN
PUTC(WARNING);
IF(C<>ENDFILE) THEN
PUTC(C)
END
END;


PROCEDURE ECHO;
VAR
I,J:INTEGER;
ARGSTR:XSTRING;
BEGIN
I:=2;
WHILE(GETARG(I,ARGSTR,MAXSTR))DO BEGIN
IF(I>1) THEN PUTC(BLANK);
FOR J:=1 TO XLENGTH(ARGSTR) DO
PUTC(ARGSTR[J]);
I:=I+1
END;
IF(I>1)THEN PUTC(NEWLINE)
END;



PROCEDURE ENTAB;
CONST
MAXLINE=1000;
TYPE
TABTYPE=ARRAY[1..MAXLINE] OF BOOLEAN;
VAR
C:CHARACTER;
COL,NEWCOL:INTEGER;
TABSTOPS:TABTYPE;

FUNCTION TABPOS(COL:INTEGER;VAR TABSTOPS:TABTYPE):BOOLEAN;
BEGIN
IF(COL>MAXLINE)THEN
TABPOS:=TRUE
ELSE
TABPOS:=TABSTOPS[COL]
END;

PROCEDURE SETTABS(VAR TABSTOPS:TABTYPE);
CONST
TABSPACE=4;
VAR
I:INTEGER;
BEGIN
FOR I:=1 TO MAXLINE DO
TABSTOPS[I]:=(I MOD TABSPACE = 1)
END;

BEGIN
SETTABS(TABSTOPS);
COL:=1;
REPEAT
NEWCOL:=COL;
WHILE(GETC(C)=BLANK) DO BEGIN
NEWCOL:=NEWCOL+1;
IF(TABPOS(NEWCOL,TABSTOPS))THEN BEGIN
PUTC(TAB);
COL:=NEWCOL;
END
END;
WHILE (COL PUTC(BLANK);
COL:=COL+1
END;
IF(C<>ENDFILE) THEN BEGIN
PUTC(C);
IF(C=NEWLINE) THEN
COL:=1
ELSE
COL:=COL+1
END
UNTIL(C=ENDFILE)
END;



PROCEDURE TRANSLIT;
CONST
NEGATE=CARET;
VAR
ARG,FROMSET,TOSET:XSTRING;
C:CHARACTER;
I,LASTTO:0..MAXSTR;
ALLBUT,SQUASH:BOOLEAN;
FUNCTION XINDEX(VAR INSET:XSTRING;C:CHARACTER;
ALLBUT:BOOLEAN;LASTTO:INTEGER):INTEGER;
BEGIN
IF(C=ENDFILE)THEN XINDEX:=0
ELSE IF (NOT ALLBUT) THEN
XINDEX:=INDEX(INSET,C)
ELSE IF(INDEX(INSET,C)>0)THEN
XINDEX:=0
ELSE
XINDEX:=LASTTO+1
END;

FUNCTION MAKESET(VAR INSET:XSTRING;K:INTEGER;
VAR OUTSET:XSTRING;MAXSET:INTEGER):BOOLEAN;

VAR J:INTEGER;

PROCEDURE DODASH(DELIM:CHARACTER;VAR SRC:XSTRING;
VAR I:INTEGER;VAR DEST:XSTRING;
VAR J:INTEGER;MAXSET:INTEGER);
VAR
K:INTEGER;
JUNK:BOOLEAN;
BEGIN
WHILE (SRC[I]<>DELIM)AND(SRC[I]<>ENDSTR)DO BEGIN
IF(SRC[I]=ATSIGN)THEN
JUNK:=ADDSTR(ESC(SRC,I),DEST,J,MAXSET)
ELSE IF (SRC[I]<>DASH) THEN
JUNK:=ADDSTR(SRC[I],DEST,J,MAXSET)
ELSE IF (J<=1)OR(SRC[I+1]=ENDSTR)THEN
JUNK:=ADDSTR(DASH,DEST,J,MAXSET)
ELSE IF (ISALPHANUM(SRC[I-1]))
AND (ISALPHANUM(SRC[I+1]))
AND (SRC[I-1]<=SRC[I+1]) THEN BEGIN
FOR K:=SRC[I-1]+1 TO SRC[I+1] DO
JUNK:=ADDSTR(K,DEST,J,MAXSET);
I:=I+1
END
ELSE
JUNK:=ADDSTR(DASH,DEST,J,MAXSET);
I:=I+1
END

END;(*DODASH*)

BEGIN(*MAKESET*)
J:=1;
DODASH(ENDSTR,INSET,K,OUTSET,J,MAXSET);
MAKESET:=ADDSTR(ENDSTR,OUTSET,J,MAXSET)
END;(*MAKESET*)

BEGIN(*TRANSLIT*)
IF (NOT GETARG(2,ARG,MAXSTR))THEN
ERROR('USAGE:TRANSLIT FROM TO');
ALLBUT:=(ARG[1]=NEGATE);
IF(ALLBUT)THEN
I:=2
ELSE
I:=1;
IF (NOT MAKESET(ARG,I,FROMSET,MAXSTR)) THEN
ERROR('TRANSLIT:"FROM"SET TOO LARGE');
IF(NOT GETARG(3,ARG,MAXSTR))THEN
TOSET[1]:=ENDSTR
ELSE IF (NOT MAKESET(ARG,1,TOSET,MAXSTR)) THEN
ERROR('TRANSLIT:"TO"SET TOO LARGE')
ELSE IF (XLENGTH(FROMSET) ERROR('TRANSLIT:"FROM"SHORTER THAN "TO');

LASTTO:=XLENGTH(TOSET);
SQUASH:=(XLENGTH(FROMSET)>LASTTO) OR (ALLBUT);
REPEAT
I:=XINDEX(FROMSET,GETC(C),ALLBUT,LASTTO);
IF (SQUASH) AND(I>=LASTTO) AND (LASTTO>0) THEN BEGIN
PUTC(TOSET[LASTTO]);
REPEAT
I:=XINDEX(FROMSET,GETC(C),ALLBUT,LASTTO)
UNTIL (I END;
IF(C<>ENDFILE) THEN BEGIN
IF(I>0)AND(LASTTO>0) THEN
PUTC(TOSET[I])
ELSE IF (I=0)THEN
PUTC(C)
(*ELSE DELETE*)
END
UNTIL(C=ENDFILE)
END;