home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / cpm / cpm86 / trbtol86.lbr / CHAPTER2.PQS / CHAPTER2.PAS
Pascal/Delphi Source File  |  1985-10-23  |  7KB  |  301 lines
  1.  
  2. {
  3.         Copyright (c) 1981
  4.         By:     Bell Telephone Laboratories, Inc. and
  5.                 Whitesmith's Ltd.,
  6.  
  7.         This software is derived from the book
  8.                 "Software Tools in Pascal", by
  9.                 Brian W. Kernighan and P. J. Plauger
  10.                 Addison-Wesley, 1981
  11.                 ISBN 0-201-10342-7
  12.  
  13.         Right is hereby granted to freely distribute or duplicate this
  14.         software, providing distribution or duplication is not for profit
  15.         or other commercial gain and that this copyright notice remains
  16.         intact.
  17. }
  18.  
  19. PROCEDURE TRANSLIT;FORWARD;
  20. PROCEDURE ENTAB;FORWARD;
  21. PROCEDURE EXPAND;FORWARD;
  22. PROCEDURE ECHO;FORWARD;
  23. PROCEDURE COMPRESS;FORWARD;
  24. PROCEDURE OVERSTRIKE;FORWARD;
  25.  
  26.  
  27. PROCEDURE OVERSTRIKE;
  28. CONST
  29.   SKIP=BLANK;
  30.   NOSKIP=PLUS;
  31. VAR
  32.   C:CHARACTER;
  33.   COL,NEWCOL,I:INTEGER;
  34. BEGIN
  35.   COL:=1;
  36.   REPEAT
  37.     NEWCOL:=COL;
  38.     WHILE(GETC(C)=BACKSPACE) DO
  39.       NEWCOL:=MAX(NEWCOL-1,1);
  40.     IF (NEWCOL<COL) THEN BEGIN
  41.       PUTC(NEWLINE);
  42.       PUTC(NOSKIP);
  43.       FOR I:=1 TO NEWCOL-1 DO
  44.         PUTC(BLANK);
  45.       COL:=NEWCOL
  46.     END
  47.     ELSE IF (COL=1) AND (C<>ENDFILE) THEN
  48.       PUTC(SKIP);
  49.     IF(C<>ENDFILE)THEN BEGIN
  50.       PUTC(C);
  51.       IF (C=NEWLINE) THEN
  52.         COL:=1
  53.       ELSE
  54.         COL:=COL+1
  55.       END
  56.     UNTIL (C=ENDFILE)
  57.   END;
  58.  
  59. PROCEDURE COMPRESS;
  60. CONST
  61.   WARNING=CARET;
  62. VAR
  63.   C,LASTC:CHARACTER;
  64.   N:INTEGER;
  65.  
  66. PROCEDURE PUTREP(N:INTEGER;C:CHARACTER);CONST
  67.   MAXREP=26;
  68.   THRESH=4;
  69. BEGIN
  70.   WHILE(N>=THRESH)OR((C=WARNING)AND(N>0))DO BEGIN
  71.     PUTC(WARNING);
  72.     PUTC(MIN(N,MAXREP)-1+ORD('A'));
  73.     PUTC(C);
  74.     N:=N-MAXREP
  75.   END;
  76.   FOR N:=N DOWNTO 1 DO
  77.     PUTC(C)
  78.   END;
  79.  
  80. BEGIN(*COMPRESS*)
  81.   N:=1;
  82.   LASTC:=GETC(LASTC);
  83.   WHILE(LASTC<>ENDFILE) DO BEGIN
  84.     IF(GETC(C)=ENDFILE)THEN BEGIN
  85.       IF(N>1) OR(LASTC=WARNING) THEN
  86.         PUTREP(N,LASTC)
  87.       ELSE
  88.         PUTC(LASTC)
  89.       END
  90.       ELSE IF (C=LASTC) THEN
  91.         N:=N+1
  92.       ELSE IF (N>1) OR (LASTC=WARNING) THEN BEGIN
  93.         PUTREP(N,LASTC);
  94.         N:=1
  95.       END
  96.       ELSE
  97.          PUTC(LASTC);
  98.       LASTC:=C
  99.     END
  100.   END;
  101.   
  102.   PROCEDURE EXPAND;
  103.   CONST
  104.     WARNING=CARET;
  105.    VAR
  106.      C:CHARACTER;
  107.      N:INTEGER;
  108.   BEGIN
  109.     WHILE(GETC(C)<>ENDFILE) DO
  110.       IF (C<>WARNING)THEN
  111.         PUTC(C)
  112.       ELSE IF(ISUPPER(GETC(C))) THEN BEGIN
  113.         N:=C-ORD('A')+1;
  114.         IF(GETC(C)<>ENDFILE)THEN
  115.           FOR N:=N DOWNTO 1 DO
  116.             PUTC(C)
  117.           ELSE BEGIN
  118.             PUTC(WARNING);
  119.             PUTC(N-1+ORD('A'))
  120.           END
  121.       END
  122.       ELSE BEGIN
  123.         PUTC(WARNING);
  124.         IF(C<>ENDFILE) THEN
  125.           PUTC(C)
  126.       END
  127.   END;
  128.  
  129.  
  130. PROCEDURE ECHO;
  131. VAR
  132.   I,J:INTEGER;
  133.   ARGSTR:XSTRING;
  134. BEGIN
  135.   I:=2;
  136.   WHILE(GETARG(I,ARGSTR,MAXSTR))DO BEGIN
  137.     IF(I>1) THEN PUTC(BLANK);
  138.     FOR J:=1 TO XLENGTH(ARGSTR) DO
  139.       PUTC(ARGSTR[J]);
  140.     I:=I+1
  141.   END;
  142.   IF(I>1)THEN PUTC(NEWLINE)
  143. END;
  144.  
  145.  
  146.  
  147. PROCEDURE ENTAB;
  148. CONST
  149.   MAXLINE=1000;
  150. TYPE
  151.   TABTYPE=ARRAY[1..MAXLINE] OF BOOLEAN;
  152. VAR
  153.   C:CHARACTER;
  154.   COL,NEWCOL:INTEGER;
  155.   TABSTOPS:TABTYPE;
  156.  
  157. FUNCTION TABPOS(COL:INTEGER;VAR TABSTOPS:TABTYPE):BOOLEAN;
  158. BEGIN
  159.   IF(COL>MAXLINE)THEN
  160.     TABPOS:=TRUE
  161.   ELSE
  162.     TABPOS:=TABSTOPS[COL]
  163. END;
  164.  
  165. PROCEDURE SETTABS(VAR TABSTOPS:TABTYPE);
  166. CONST
  167.   TABSPACE=4;
  168. VAR
  169.   I:INTEGER;
  170. BEGIN
  171.   FOR I:=1 TO MAXLINE DO
  172.     TABSTOPS[I]:=(I MOD TABSPACE = 1)
  173. END;
  174.  
  175.     BEGIN
  176.   SETTABS(TABSTOPS);
  177.   COL:=1;
  178.   REPEAT
  179.     NEWCOL:=COL;
  180.     WHILE(GETC(C)=BLANK) DO BEGIN
  181.       NEWCOL:=NEWCOL+1;
  182.       IF(TABPOS(NEWCOL,TABSTOPS))THEN BEGIN
  183.         PUTC(TAB);
  184.         COL:=NEWCOL;
  185.       END
  186.     END;
  187.     WHILE (COL<NEWCOL) DO BEGIN
  188.       PUTC(BLANK);
  189.       COL:=COL+1
  190.     END;
  191.     IF(C<>ENDFILE) THEN BEGIN
  192.       PUTC(C);
  193.       IF(C=NEWLINE) THEN
  194.         COL:=1
  195.       ELSE
  196.         COL:=COL+1
  197.       END
  198.     UNTIL(C=ENDFILE)
  199.   END;
  200.  
  201.  
  202.  
  203. PROCEDURE TRANSLIT;
  204. CONST
  205.   NEGATE=CARET;
  206. VAR
  207.   ARG,FROMSET,TOSET:XSTRING;
  208.   C:CHARACTER;
  209.   I,LASTTO:0..MAXSTR;
  210.   ALLBUT,SQUASH:BOOLEAN;
  211. FUNCTION XINDEX(VAR INSET:XSTRING;C:CHARACTER;
  212.   ALLBUT:BOOLEAN;LASTTO:INTEGER):INTEGER;
  213. BEGIN
  214.   IF(C=ENDFILE)THEN XINDEX:=0
  215.   ELSE IF (NOT ALLBUT) THEN
  216.     XINDEX:=INDEX(INSET,C)
  217.   ELSE IF(INDEX(INSET,C)>0)THEN
  218.     XINDEX:=0
  219.   ELSE
  220.     XINDEX:=LASTTO+1
  221. END;
  222.   
  223. FUNCTION MAKESET(VAR INSET:XSTRING;K:INTEGER;
  224.   VAR OUTSET:XSTRING;MAXSET:INTEGER):BOOLEAN;
  225.  
  226. VAR J:INTEGER;
  227.  
  228. PROCEDURE DODASH(DELIM:CHARACTER;VAR SRC:XSTRING;
  229.   VAR I:INTEGER;VAR DEST:XSTRING;
  230.   VAR J:INTEGER;MAXSET:INTEGER);
  231. VAR
  232.   K:INTEGER;
  233.   JUNK:BOOLEAN;
  234. BEGIN
  235.   WHILE (SRC[I]<>DELIM)AND(SRC[I]<>ENDSTR)DO BEGIN
  236.     IF(SRC[I]=ATSIGN)THEN
  237.       JUNK:=ADDSTR(ESC(SRC,I),DEST,J,MAXSET)
  238.     ELSE IF (SRC[I]<>DASH) THEN
  239.       JUNK:=ADDSTR(SRC[I],DEST,J,MAXSET)
  240.     ELSE IF (J<=1)OR(SRC[I+1]=ENDSTR)THEN
  241.       JUNK:=ADDSTR(DASH,DEST,J,MAXSET)
  242.     ELSE IF (ISALPHANUM(SRC[I-1]))
  243.       AND (ISALPHANUM(SRC[I+1]))
  244.       AND (SRC[I-1]<=SRC[I+1]) THEN BEGIN
  245.         FOR K:=SRC[I-1]+1 TO SRC[I+1] DO
  246.           JUNK:=ADDSTR(K,DEST,J,MAXSET);
  247.         I:=I+1
  248.       END
  249.     ELSE
  250.       JUNK:=ADDSTR(DASH,DEST,J,MAXSET);
  251.     I:=I+1
  252.   END
  253.   
  254. END;(*DODASH*)
  255.  
  256. BEGIN(*MAKESET*)
  257.   J:=1;
  258.   DODASH(ENDSTR,INSET,K,OUTSET,J,MAXSET);
  259.   MAKESET:=ADDSTR(ENDSTR,OUTSET,J,MAXSET)
  260. END;(*MAKESET*)
  261.  
  262. BEGIN(*TRANSLIT*)
  263.   IF (NOT GETARG(2,ARG,MAXSTR))THEN
  264.     ERROR('USAGE:TRANSLIT FROM TO');
  265.   ALLBUT:=(ARG[1]=NEGATE);
  266.   IF(ALLBUT)THEN
  267.     I:=2
  268.   ELSE
  269.     I:=1;
  270.   IF (NOT MAKESET(ARG,I,FROMSET,MAXSTR)) THEN
  271.     ERROR('TRANSLIT:"FROM"SET TOO LARGE');
  272.   IF(NOT GETARG(3,ARG,MAXSTR))THEN
  273.     TOSET[1]:=ENDSTR
  274.   ELSE IF (NOT MAKESET(ARG,1,TOSET,MAXSTR)) THEN
  275.     ERROR('TRANSLIT:"TO"SET TOO LARGE')
  276.   ELSE IF (XLENGTH(FROMSET)<XLENGTH(TOSET))THEN
  277.     ERROR('TRANSLIT:"FROM"SHORTER THAN "TO');
  278.   
  279.   LASTTO:=XLENGTH(TOSET);
  280.   SQUASH:=(XLENGTH(FROMSET)>LASTTO) OR (ALLBUT);
  281.   REPEAT
  282.     I:=XINDEX(FROMSET,GETC(C),ALLBUT,LASTTO);
  283.     IF (SQUASH) AND(I>=LASTTO) AND (LASTTO>0) THEN BEGIN
  284.       PUTC(TOSET[LASTTO]);
  285.       REPEAT
  286.         I:=XINDEX(FROMSET,GETC(C),ALLBUT,LASTTO)
  287.       UNTIL (I<LASTTO)
  288.     END;
  289.     IF(C<>ENDFILE) THEN BEGIN
  290.       IF(I>0)AND(LASTTO>0) THEN
  291.         PUTC(TOSET[I])
  292.       ELSE IF (I=0)THEN
  293.         PUTC(C)
  294.       (*ELSE DELETE*)
  295.     END
  296.   UNTIL(C=ENDFILE)
  297. END;
  298.  
  299.  
  300.  
  301.