home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / cpm / cpm86 / trbtol86.lbr / CHAPTER7.PQS / CHAPTER7.PAS
Pascal/Delphi Source File  |  1985-10-23  |  9KB  |  443 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 FORMAT;
  20. CONST
  21.   CMD=PERIOD;
  22.   PAGENUM=SHARP;
  23.   PAGEWIDTH=60;
  24.   PAGELEN=66;
  25.   HUGE=10000;
  26. TYPE
  27.   CMDTYPE=(BP,BR,CE,FI,FO,HE,IND,LS,NF,PL,
  28.     RM,SP,TI,UL,UNKNOWN);
  29. VAR
  30.   CURPAGE,NEWPAGE,LINENO:INTEGER;
  31.   PLVAL,M1VAL,M2VAL,M3VAL,M4VAL:INTEGER;
  32.   BOTTOM:INTEGER;
  33.   HEADER,FOOTER:XSTRING;
  34.   
  35.   FILL:BOOLEAN;
  36.   LSVAL,SPVAL,INVAL,RMVAL,TIVAL,CEVAL,ULVAL:INTEGER;
  37.  
  38.   OUTP,OUTW,OUTWDS:INTEGER;
  39.   OUTBUF:XSTRING;
  40.   DIR:0..1;
  41.   INBUF:XSTRING;
  42.   
  43. PROCEDURE SKIPBL(VAR S:XSTRING;VAR I:INTEGER);
  44. BEGIN
  45.   WHILE(S[I]=BLANK) OR(S[I]=TAB)DO
  46.     I:=I+1
  47.   END;
  48.   
  49. FUNCTION GETVAL(VAR BUF:XSTRING;VAR ARGTYPE:INTEGER):INTEGER;
  50. VAR
  51.   I:INTEGER;
  52. BEGIN
  53.   I:=1;
  54.   WHILE(NOT(BUF[I]IN[BLANK,TAB,NEWLINE]))DO
  55.     I:=I+1;
  56.   SKIPBL(BUF,I);
  57.   ARGTYPE:=BUF[I];
  58.   IF(ARGTYPE=PLUS) OR (ARGTYPE=MINUS) THEN
  59.     I:=I+1;
  60.   GETVAL:=CTOI(BUF,I)
  61. END;
  62.  
  63. PROCEDURE SETPARAM(VAR PARAM:INTEGER;VAL,ARGTYPE,DEFVAL,MINVAL,MAXVAL:
  64.   INTEGER);
  65. BEGIN
  66.   IF(ARGTYPE=NEWLINE)THEN
  67.     PARAM:=DEFVAL
  68.   ELSE IF (ARGTYPE=PLUS)THEN
  69.     PARAM:=PARAM+VAL
  70.   ELSE IF(ARGTYPE=MINUS) THEN
  71.     PARAM:=PARAM-VAL
  72.   ELSE PARAM:=VAL;
  73.   PARAM:=MIN(PARAM,MAXVAL);
  74.   PARAM:=MAX(PARAM,MINVAL)
  75. END;
  76.  
  77. PROCEDURE SKIP(N:INTEGER);
  78. VAR I:INTEGER;
  79. BEGIN
  80.   FOR I:=1 TO N DO
  81.     PUTC(NEWLINE)
  82. END;
  83.  
  84. PROCEDURE PUTTL(VAR BUF:XSTRING;PAGENO:INTEGER);
  85. VAR I:INTEGER;
  86. BEGIN
  87.   FOR I:=1 TO XLENGTH(BUF) DO
  88.     IF(BUF[I]=PAGENUM) THEN
  89.       PUTDEC(PAGENO,1)
  90.     ELSE
  91.       PUTC(BUF[I])
  92. END;
  93.  
  94. PROCEDURE PUTFOOT;
  95. BEGIN
  96.   SKIP(M3VAL);
  97.   IF(M4VAL>0) THEN BEGIN
  98.     PUTTL(FOOTER,CURPAGE);
  99.     SKIP(M4VAL-1)
  100.   END
  101. END;
  102.  
  103. PROCEDURE PUTHEAD;
  104. BEGIN
  105.   CURPAGE:=NEWPAGE;
  106.   NEWPAGE:=NEWPAGE+1;
  107.   IF(M1VAL>0)THEN BEGIN
  108.     SKIP(M1VAL-1);
  109.     PUTTL(HEADER,CURPAGE)
  110.   END;
  111.   SKIP(M2VAL);
  112.   LINENO:=M1VAL+M2VAL+1
  113. END;
  114.  
  115. PROCEDURE PUT(VAR BUF:XSTRING);
  116. VAR
  117.   I:INTEGER;
  118. BEGIN
  119.   IF(LINENO<=0) OR(LINENO>BOTTOM) THEN
  120.     PUTHEAD;
  121.   FOR I:=1 TO INVAL+TIVAL DO
  122.     PUTC(BLANK);
  123.   TIVAL:=0;
  124.   PUTSTR(BUF,STDOUT);
  125.   SKIP(MIN(LSVAL-1,BOTTOM-LINENO));
  126.   LINENO:=LINENO+LSVAL;
  127.   IF(LINENO>BOTTOM)THEN PUTFOOT
  128. END;
  129.  
  130.  
  131. PROCEDURE BREAK;
  132. BEGIN
  133.   IF(OUTP>0) THEN BEGIN
  134.     OUTBUF[OUTP]:=NEWLINE;
  135.     OUTBUF[OUTP+1]:=ENDSTR;
  136.     PUT(OUTBUF)
  137.   END;
  138.   OUTP:=0;
  139.   OUTW:=0;
  140.   OUTWDS:=0
  141. END;
  142.  
  143. FUNCTION GETWORD(VAR S:XSTRING;I:INTEGER;
  144.   VAR OUT:XSTRING):INTEGER;
  145. VAR
  146.   J:INTEGER;
  147. BEGIN
  148.   WHILE(S[I] IN [BLANK,TAB,NEWLINE]) DO
  149.     I:=I+1;
  150.   J:=1;
  151.   WHILE(NOT (S[I] IN [ENDSTR,BLANK,TAB,NEWLINE])) DO BEGIN
  152.     OUT[J]:=S[I];
  153.     I:=I+1;
  154.     J:=J+1
  155.   END;
  156.   OUT[J]:=ENDSTR;
  157.   IF(S[I]=ENDSTR) THEN
  158.     GETWORD:=0
  159.   ELSE
  160.     GETWORD:=I
  161. END;
  162.  
  163. PROCEDURE LEADBL(VAR BUF:XSTRING);
  164. VAR I,J:INTEGER;
  165. BEGIN
  166.   BREAK;
  167.   I:=1;
  168.   WHILE(BUF[I]=BLANK) DO
  169.     I:=I+1;
  170.   IF(BUF[I]<>NEWLINE) THEN
  171.     TIVAL:=TIVAL+I-1;
  172.   FOR J:=I TO XLENGTH(BUF)+1 DO
  173.     BUF[J-I+1]:=BUF[J]
  174. END;
  175.  
  176. PROCEDURE GETTL(VAR BUF,TTL:XSTRING);
  177. VAR
  178.   I:INTEGER;
  179. BEGIN
  180.   I:=1;
  181.   WHILE(NOT(BUF[I]IN[BLANK,TAB,NEWLINE]))DO
  182.     I:=I+1;
  183.   SKIPBL(BUF,I);
  184.   IF(BUF[I]=SQUOTE) OR(BUF[I]=DQUOTE)THEN
  185.     I:=I+1;
  186.   SCOPY(BUF,I,TTL,1)
  187. END;
  188.  
  189. PROCEDURE SPACE(N:INTEGER);
  190. BEGIN
  191.   BREAK;
  192.   IF (LINENO<=BOTTOM) THEN BEGIN
  193.     IF(LINENO<=0)THEN
  194.       PUTHEAD;
  195.     SKIP(MIN(N,BOTTOM+1-LINENO));
  196.     LINENO:=LINENO+N;
  197.     IF(LINENO>BOTTOM) THEN
  198.       PUTFOOT
  199.   END
  200. END;
  201.  
  202. PROCEDURE PAGE;
  203. BEGIN
  204.   BREAK;
  205.   IF(LINENO>0) AND (LINENO<=BOTTOM) THEN BEGIN
  206.     SKIP(BOTTOM+1-LINENO);putfoot
  207.   END;
  208.   LINENO:=0
  209. END;
  210.  
  211. FUNCTION WIDTH(VAR BUF:XSTRING):INTEGER;
  212. VAR
  213.   I,W:INTEGER;
  214. BEGIN
  215.   W:=0;
  216.   I:=1;
  217.   WHILE(BUF[I]<>ENDSTR) DO BEGIN
  218.     IF (BUF[I] = BACKSPACE) THEN
  219.       W:=W-1
  220.     ELSE IF (BUF[I]<>NEWLINE) THEN
  221.       W:=W+1;I:=I+1
  222.   END;
  223.   WIDTH:=W
  224. END;
  225.  
  226. PROCEDURE SPREAD(VAR BUF:XSTRING;
  227. OUTP,NEXTRA,OUTWDS:INTEGER);
  228. VAR
  229.   I,J,NB,NHOLES:INTEGER;
  230. BEGIN
  231.   IF(NEXTRA>0) AND (OUTWDS>1) THEN BEGIN
  232.     DIR:=1-DIR;
  233.     NHOLES:=OUTWDS-1;
  234.     I:=OUTP-1;
  235.     J:=MIN(MAXSTR-2,I+NEXTRA);
  236.     WHILE(I<J) DO BEGIN
  237.       BUF[J]:=BUF[I];
  238.       IF(BUF[I]=BLANK) THEN BEGIN
  239.         IF(DIR=0) THEN
  240.           NB:=(NEXTRA-1) DIV NHOLES +1
  241.         ELSE NB:=NEXTRA DIV NHOLES;
  242.         NEXTRA:=NEXTRA - NB;
  243.         NHOLES:=NHOLES-1;
  244.         WHILE(NB>0) DO BEGIN
  245.           J:=J-1;
  246.           BUF[J]:=BLANK;
  247.           NB:=NB-1
  248.         END
  249.       END;
  250.       I:=I-1;
  251.       J:=J-1
  252.     END
  253.   END
  254. END;
  255.  
  256. PROCEDURE PUTWORD(VAR WORDBUF:XSTRING);
  257. VAR
  258.   LAST,LLVAL,NEXTRA,W:INTEGER;
  259. BEGIN
  260.   W:=WIDTH(WORDBUF);
  261.   LAST:=XLENGTH(WORDBUF)+OUTP+1;
  262.   LLVAL:=RMVAL-TIVAL-INVAL;
  263.   IF(OUTP>0)
  264.     AND ((OUTW+W>LLVAL) OR (LAST >=MAXSTR)) THEN BEGIN
  265.       LAST:=LAST-OUTP;
  266.       NEXTRA:=LLVAL-OUTW+1;
  267.       IF(NEXTRA >0) AND(OUTWDS>1) THEN BEGIN
  268.         SPREAD(OUTBUF,OUTP,NEXTRA,OUTWDS);
  269.         OUTP:=OUTP+NEXTRA
  270.       END;
  271.       BREAK
  272.     END;
  273.     SCOPY(WORDBUF,1,OUTBUF,OUTP+1);
  274.     OUTP:=LAST;
  275.     OUTBUF[OUTP]:=BLANK;
  276.     OUTW:=OUTW+W+1;
  277.     OUTWDS:=OUTWDS+1
  278. END;
  279.  
  280. PROCEDURE CENTER(VAR BUF:XSTRING);
  281. BEGIN
  282.   TIVAL:=MAX((RMVAL+TIVAL-WIDTH(BUF)) DIV 2,0)
  283. END;
  284.  
  285. PROCEDURE UNDERLN (VAR BUF:XSTRING;SIZE:INTEGER);
  286. VAR
  287.   I,J:INTEGER;
  288.   TBUF:XSTRING;
  289. BEGIN
  290.   J:=1;
  291.   I:=1;
  292.   WHILE(BUF[I]<>NEWLINE) AND (J<SIZE-1)DO BEGIN
  293.     IF(ISALPHANUM(BUF[I])) THEN BEGIN
  294.       TBUF[J]:=UNDERLINE;
  295.       TBUF[J+1]:=BACKSPACE;
  296.       J:=J+2
  297.     END;
  298.     TBUF[J]:=BUF[I];
  299.     J:=J+1;
  300.     I:=I+1
  301.   END;
  302.   TBUF[J]:=NEWLINE;
  303.   TBUF[J+1]:=ENDSTR;
  304.   SCOPY(TBUF,1,BUF,1)
  305. END;
  306.  
  307. PROCEDURE TEXT(VAR INBUF:XSTRING);
  308. VAR
  309.   WORDBUF:XSTRING;
  310.   I:INTEGER;
  311. BEGIN
  312.   IF(INBUF[1]=BLANK) OR (INBUF[1]=NEWLINE) THEN
  313.     LEADBL(INBUF);
  314.   IF(ULVAL>0) THEN BEGIN
  315.     UNDERLN(INBUF,MAXSTR);
  316.     ULVAL:=ULVAL-1
  317.   END;
  318.   IF(CEVAL>0)THEN BEGIN
  319.     CENTER(INBUF);
  320.     PUT(INBUF);
  321.     CEVAL:=CEVAL-1
  322.   END
  323.   ELSE IF (INBUF[1]=NEWLINE)THEN
  324.     PUT(INBUF)
  325.   ELSE IF(NOT FILL) THEN
  326.     PUT(INBUF)
  327.   ELSE BEGIN
  328.     I:=1;
  329.     REPEAT
  330.       I:=GETWORD(INBUF,I,WORDBUF);
  331.       IF(I>0)THEN
  332.         PUTWORD(WORDBUF)
  333.       UNTIL(I=0)
  334.     END
  335.     
  336. END;
  337.   
  338.  
  339. PROCEDURE INITFMT;
  340. BEGIN
  341.   FILL:=TRUE;
  342.   DIR:=0;
  343.   INVAL:=0;
  344.   RMVAL:=PAGEWIDTH;
  345.   TIVAL:=0;
  346.   LSVAL:=1;
  347.   SPVAL:=0;
  348.   CEVAL:=0;
  349.   ULVAL:=0;
  350.   LINENO:=0;
  351.   CURPAGE:=0;
  352.   NEWPAGE:=1;
  353.   PLVAL:=PAGELEN;
  354.   M1VAL:=3;M2VAL:=2;M3VAL:=2;M4VAL:=3;
  355.   BOTTOM:=PLVAL-M3VAL-M4VAL;
  356.   HEADER[1]:=NEWLINE;
  357.   HEADER[2]:=ENDSTR;
  358.   FOOTER[1]:=NEWLINE;
  359.   FOOTER[2]:=ENDSTR;
  360.   OUTP:=0;
  361.   OUTW:=0;
  362.   OUTWDS:=0
  363. END;
  364.  
  365. FUNCTION GETCMD(VAR BUF:XSTRING):CMDTYPE;
  366. VAR
  367.   CMD:PACKED ARRAY[1..2] OF CHAR;
  368. BEGIN
  369.   CMD[1]:=CHR(BUF[2]);
  370.   CMD[2]:=CHR(BUF[3]);
  371.   IF(CMD='fi')THEN GETCMD:=FI
  372.   ELSE IF (CMD='nf')THEN GETCMD:=NF
  373.   ELSE IF (CMD='br')THEN GETCMD:=BR
  374.   ELSE IF (CMD='ls')THEN GETCMD:=LS
  375.   ELSE IF (CMD='bp')THEN GETCMD:=BP
  376.   ELSE IF (CMD='sp')THEN GETCMD:=SP
  377.   ELSE IF (CMD='in')THEN GETCMD:=IND
  378.   ELSE IF (CMD='rm')THEN GETCMD:=RM
  379.   ELSE IF (CMD='ce')THEN GETCMD:=CE
  380.   ELSE IF (CMD='ti')THEN GETCMD:=TI
  381.   ELSE IF (CMD='ul')THEN GETCMD:=UL
  382.   ELSE IF (CMD='he') THEN GETCMD:=HE
  383.   ELSE IF (CMD='fo') THEN GETCMD:=FO
  384.   ELSE IF (CMD='pl') THEN GETCMD:=PL
  385.   ELSE GETCMD:=UNKNOWN
  386. END;
  387.  
  388. PROCEDURE COMMAND(VAR BUF:XSTRING);
  389. VAR CMD:CMDTYPE;
  390. ARGTYPE,SPVAL,VAL:INTEGER;
  391. BEGIN
  392.   CMD:=GETCMD(BUF);
  393.   IF(CMD<>UNKNOWN)THEN
  394.     VAL:=GETVAL(BUF,ARGTYPE);
  395.     CASE CMD OF
  396.     FI:BEGIN
  397.        BREAK;
  398.        FILL:=TRUE END;
  399.     NF:BEGIN BREAK;
  400.        FILL:=FALSE END;
  401.     BR:BREAK;
  402.     LS:SETPARAM(LSVAL,VAL,ARGTYPE,1,1,HUGE);
  403.     CE:BEGIN BREAK;
  404.        SETPARAM(CEVAL,VAL,ARGTYPE,1,0,HUGE) END;
  405.     UL:SETPARAM(ULVAL,VAL,ARGTYPE,1,0,HUGE);
  406.     HE:GETTL(BUF,HEADER);
  407.     FO:GETTL(BUF,FOOTER);
  408.     BP:BEGIN PAGE;
  409.        SETPARAM(CURPAGE,VAL,ARGTYPE,CURPAGE+1,-HUGE,HUGE);
  410.        NEWPAGE:=CURPAGE END;
  411.     SP:BEGIN
  412.        SETPARAM(SPVAL,VAL,ARGTYPE,1,0,HUGE);
  413.        space(spval)
  414.        END;
  415.     IND:SETPARAM(INVAL,VAL,ARGTYPE,0,0,RMVAL-1);
  416.     RM:SETPARAM(INVAL,VAL,ARGTYPE,PAGEWIDTH,
  417.         INVAL+TIVAL+1,HUGE);
  418.     TI:BEGIN BREAK;
  419.        SETPARAM(TIVAL,VAL,ARGTYPE,0,-HUGE,RMVAL) END;
  420.     PL:BEGIN
  421.        SETPARAM(PLVAL,VAL,ARGTYPE,PAGELEN,
  422.         M1VAL+M2VAL+M3VAL+M4VAL+1,HUGE);
  423.        BOTTOM:=PLVAL-M3VAL-M4VAL END;
  424.     UNKNOWN:
  425.     END
  426.   END;
  427.  
  428.        
  429.        
  430.  
  431. BEGIN
  432.   
  433.   INITFMT;
  434.   WHILE(GETLINE(INBUF,STDIN,MAXSTR))DO
  435.     IF(INBUF[1]=CMD) THEN
  436.       COMMAND(INBUF)
  437.     ELSE
  438.       TEXT(INBUF);
  439.     PAGE
  440. END;
  441.  
  442.  
  443.