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