{
        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<COL) THEN BEGIN
      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<NEWCOL) DO BEGIN
      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)<XLENGTH(TOSET))THEN
    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<LASTTO)
    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;