Category : Pascal Source Code
Archive   : TPTOOL19.ZIP
Filename : CHAPTER7.PAS
PROGRAM CHAPTER7;
{$I TOOLU.PAS}
PROCEDURE FORMAT;
CONST
CMD=PERIOD;
PAGENUM=SHARP;
PAGEWIDTH=60;
PAGELEN=66;
HUGE=10000;
TYPE
CMDTYPE=(BP,BR,CE,FI,FO,HE,IND,LS,NF,PL,
RM,SP,TI,UL,UNKNOWN);
VAR
CURPAGE,NEWPAGE,LINENO:INTEGER;
PLVAL,M1VAL,M2VAL,M3VAL,M4VAL:INTEGER;
BOTTOM:INTEGER;
HEADER,FOOTER:XSTRING;
FILL:BOOLEAN;
LSVAL,SPVAL,INVAL,RMVAL,TIVAL,CEVAL,ULVAL:INTEGER;
OUTP,OUTW,OUTWDS:INTEGER;
OUTBUF:XSTRING;
DIR:0..1;
INBUF:XSTRING;
PROCEDURE SKIPBL(VAR S:XSTRING;VAR I:INTEGER);
BEGIN
WHILE(S[I]=BLANK) OR(S[I]=TAB)DO
I:=I+1
END;
FUNCTION GETVAL(VAR BUF:XSTRING;VAR ARGTYPE:INTEGER):INTEGER;
VAR
I:INTEGER;
BEGIN
I:=1;
WHILE(NOT(BUF[I]IN[BLANK,TAB,NEWLINE]))DO
I:=I+1;
SKIPBL(BUF,I);
ARGTYPE:=BUF[I];
IF(ARGTYPE=PLUS) OR (ARGTYPE=MINUS) THEN
I:=I+1;
GETVAL:=CTOI(BUF,I)
END;
PROCEDURE SETPARAM(VAR PARAM:INTEGER;VAL,ARGTYPE,DEFVAL,MINVAL,MAXVAL:
INTEGER);
BEGIN
IF(ARGTYPE=NEWLINE)THEN
PARAM:=DEFVAL
ELSE IF (ARGTYPE=PLUS)THEN
PARAM:=PARAM+VAL
ELSE IF(ARGTYPE=MINUS) THEN
PARAM:=PARAM-VAL
ELSE PARAM:=VAL;
PARAM:=MIN(PARAM,MAXVAL);
PARAM:=MAX(PARAM,MINVAL)
END;
PROCEDURE SKIP(N:INTEGER);
VAR I:INTEGER;
BEGIN
FOR I:=1 TO N DO
PUTC(NEWLINE)
END;
PROCEDURE PUTTL(VAR BUF:XSTRING;PAGENO:INTEGER);
VAR I:INTEGER;
BEGIN
FOR I:=1 TO XLENGTH(BUF) DO
IF(BUF[I]=PAGENUM) THEN
PUTDEC(PAGENO,1)
ELSE
PUTC(BUF[I])
END;
PROCEDURE PUTFOOT;
BEGIN
SKIP(M3VAL);
IF(M4VAL>0) THEN BEGIN
PUTTL(FOOTER,CURPAGE);
SKIP(M4VAL-1)
END
END;
PROCEDURE PUTHEAD;
BEGIN
CURPAGE:=NEWPAGE;
NEWPAGE:=NEWPAGE+1;
IF(M1VAL>0)THEN BEGIN
SKIP(M1VAL-1);
PUTTL(HEADER,CURPAGE)
END;
SKIP(M2VAL);
LINENO:=M1VAL+M2VAL+1
END;
PROCEDURE PUT(VAR BUF:XSTRING);
VAR
I:INTEGER;
BEGIN
IF(LINENO<=0) OR(LINENO>BOTTOM) THEN
PUTHEAD;
FOR I:=1 TO INVAL+TIVAL DO
PUTC(BLANK);
TIVAL:=0;
PUTSTR(BUF,STDOUT);
SKIP(MIN(LSVAL-1,BOTTOM-LINENO));
LINENO:=LINENO+LSVAL;
IF(LINENO>BOTTOM)THEN PUTFOOT
END;
PROCEDURE BREAK;
BEGIN
IF(OUTP>0) THEN BEGIN
OUTBUF[OUTP]:=NEWLINE;
OUTBUF[OUTP+1]:=ENDSTR;
PUT(OUTBUF)
END;
OUTP:=0;
OUTW:=0;
OUTWDS:=0
END;
FUNCTION GETWORD(VAR S:XSTRING;I:INTEGER;
VAR OUT:XSTRING):INTEGER;
VAR
J:INTEGER;
BEGIN
WHILE(S[I] IN [BLANK,TAB,NEWLINE]) DO
I:=I+1;
J:=1;
WHILE(NOT (S[I] IN [ENDSTR,BLANK,TAB,NEWLINE])) DO BEGIN
OUT[J]:=S[I];
I:=I+1;
J:=J+1
END;
OUT[J]:=ENDSTR;
IF(S[I]=ENDSTR) THEN
GETWORD:=0
ELSE
GETWORD:=I
END;
PROCEDURE LEADBL(VAR BUF:XSTRING);
VAR I,J:INTEGER;
BEGIN
BREAK;
I:=1;
WHILE(BUF[I]=BLANK) DO
I:=I+1;
IF(BUF[I]<>NEWLINE) THEN
TIVAL:=TIVAL+I-1;
FOR J:=I TO XLENGTH(BUF)+1 DO
BUF[J-I+1]:=BUF[J]
END;
PROCEDURE GETTL(VAR BUF,TTL:XSTRING);
VAR
I:INTEGER;
BEGIN
I:=1;
WHILE(NOT(BUF[I]IN[BLANK,TAB,NEWLINE]))DO
I:=I+1;
SKIPBL(BUF,I);
IF(BUF[I]=SQUOTE) OR(BUF[I]=DQUOTE)THEN
I:=I+1;
SCOPY(BUF,I,TTL,1)
END;
PROCEDURE SPACE(N:INTEGER);
BEGIN
BREAK;
IF (LINENO<=BOTTOM) THEN BEGIN
IF(LINENO<=0)THEN
PUTHEAD;
SKIP(MIN(N,BOTTOM+1-LINENO));
LINENO:=LINENO+N;
IF(LINENO>BOTTOM) THEN
PUTFOOT
END
END;
PROCEDURE PAGE;
BEGIN
BREAK;
IF(LINENO>0) AND (LINENO<=BOTTOM) THEN BEGIN
SKIP(BOTTOM+1-LINENO);putfoot
END;
LINENO:=0
END;
FUNCTION WIDTH(VAR BUF:XSTRING):INTEGER;
VAR
I,W:INTEGER;
BEGIN
W:=0;
I:=1;
WHILE(BUF[I]<>ENDSTR) DO BEGIN
IF (BUF[I] = BACKSPACE) THEN
W:=W-1
ELSE IF (BUF[I]<>NEWLINE) THEN
W:=W+1;I:=I+1
END;
WIDTH:=W
END;
PROCEDURE SPREAD(VAR BUF:XSTRING;
OUTP,NEXTRA,OUTWDS:INTEGER);
VAR
I,J,NB,NHOLES:INTEGER;
BEGIN
IF(NEXTRA>0) AND (OUTWDS>1) THEN BEGIN
DIR:=1-DIR;
NHOLES:=OUTWDS-1;
I:=OUTP-1;
J:=MIN(MAXSTR-2,I+NEXTRA);
WHILE(I
IF(BUF[I]=BLANK) THEN BEGIN
IF(DIR=0) THEN
NB:=(NEXTRA-1) DIV NHOLES +1
ELSE NB:=NEXTRA DIV NHOLES;
NEXTRA:=NEXTRA - NB;
NHOLES:=NHOLES-1;
WHILE(NB>0) DO BEGIN
J:=J-1;
BUF[J]:=BLANK;
NB:=NB-1
END
END;
I:=I-1;
J:=J-1
END
END
END;
PROCEDURE PUTWORD(VAR WORDBUF:XSTRING);
VAR
LAST,LLVAL,NEXTRA,W:INTEGER;
BEGIN
W:=WIDTH(WORDBUF);
LAST:=XLENGTH(WORDBUF)+OUTP+1;
LLVAL:=RMVAL-TIVAL-INVAL;
IF(OUTP>0)
AND ((OUTW+W>LLVAL) OR (LAST >=MAXSTR)) THEN BEGIN
LAST:=LAST-OUTP;
NEXTRA:=LLVAL-OUTW+1;
IF(NEXTRA >0) AND(OUTWDS>1) THEN BEGIN
SPREAD(OUTBUF,OUTP,NEXTRA,OUTWDS);
OUTP:=OUTP+NEXTRA
END;
BREAK
END;
SCOPY(WORDBUF,1,OUTBUF,OUTP+1);
OUTP:=LAST;
OUTBUF[OUTP]:=BLANK;
OUTW:=OUTW+W+1;
OUTWDS:=OUTWDS+1
END;
PROCEDURE CENTER(VAR BUF:XSTRING);
BEGIN
TIVAL:=MAX((RMVAL+TIVAL-WIDTH(BUF)) DIV 2,0)
END;
PROCEDURE UNDERLN (VAR BUF:XSTRING;SIZE:INTEGER);
VAR
I,J:INTEGER;
TBUF:XSTRING;
BEGIN
J:=1;
I:=1;
WHILE(BUF[I]<>NEWLINE) AND (J
TBUF[J]:=UNDERLINE;
TBUF[J+1]:=BACKSPACE;
J:=J+2
END;
TBUF[J]:=BUF[I];
J:=J+1;
I:=I+1
END;
TBUF[J]:=NEWLINE;
TBUF[J+1]:=ENDSTR;
SCOPY(TBUF,1,BUF,1)
END;
PROCEDURE TEXT(VAR INBUF:XSTRING);
VAR
WORDBUF:XSTRING;
I:INTEGER;
BEGIN
IF(INBUF[1]=BLANK) OR (INBUF[1]=NEWLINE) THEN
LEADBL(INBUF);
IF(ULVAL>0) THEN BEGIN
UNDERLN(INBUF,MAXSTR);
ULVAL:=ULVAL-1
END;
IF(CEVAL>0)THEN BEGIN
CENTER(INBUF);
PUT(INBUF);
CEVAL:=CEVAL-1
END
ELSE IF (INBUF[1]=NEWLINE)THEN
PUT(INBUF)
ELSE IF(NOT FILL) THEN
PUT(INBUF)
ELSE BEGIN
I:=1;
REPEAT
I:=GETWORD(INBUF,I,WORDBUF);
IF(I>0)THEN
PUTWORD(WORDBUF)
UNTIL(I=0)
END
END;
PROCEDURE INITFMT;
BEGIN
FILL:=TRUE;
DIR:=0;
INVAL:=0;
RMVAL:=PAGEWIDTH;
TIVAL:=0;
LSVAL:=1;
SPVAL:=0;
CEVAL:=0;
ULVAL:=0;
LINENO:=0;
CURPAGE:=0;
NEWPAGE:=1;
PLVAL:=PAGELEN;
M1VAL:=3;M2VAL:=2;M3VAL:=2;M4VAL:=3;
BOTTOM:=PLVAL-M3VAL-M4VAL;
HEADER[1]:=NEWLINE;
HEADER[2]:=ENDSTR;
FOOTER[1]:=NEWLINE;
FOOTER[2]:=ENDSTR;
OUTP:=0;
OUTW:=0;
OUTWDS:=0
END;
FUNCTION GETCMD(VAR BUF:XSTRING):CMDTYPE;
VAR
CMD:PACKED ARRAY[1..2] OF CHAR;
BEGIN
CMD[1]:=CHR(BUF[2]);
CMD[2]:=CHR(BUF[3]);
IF(CMD='fi')THEN GETCMD:=FI
ELSE IF (CMD='nf')THEN GETCMD:=NF
ELSE IF (CMD='br')THEN GETCMD:=BR
ELSE IF (CMD='ls')THEN GETCMD:=LS
ELSE IF (CMD='bp')THEN GETCMD:=BP
ELSE IF (CMD='sp')THEN GETCMD:=SP
ELSE IF (CMD='in')THEN GETCMD:=IND
ELSE IF (CMD='rm')THEN GETCMD:=RM
ELSE IF (CMD='ce')THEN GETCMD:=CE
ELSE IF (CMD='ti')THEN GETCMD:=TI
ELSE IF (CMD='ul')THEN GETCMD:=UL
ELSE IF (CMD='he') THEN GETCMD:=HE
ELSE IF (CMD='fo') THEN GETCMD:=FO
ELSE IF (CMD='pl') THEN GETCMD:=PL
ELSE GETCMD:=UNKNOWN
END;
PROCEDURE COMMAND(VAR BUF:XSTRING);
VAR CMD:CMDTYPE;
ARGTYPE,SPVAL,VAL:INTEGER;
BEGIN
CMD:=GETCMD(BUF);
IF(CMD<>UNKNOWN)THEN
VAL:=GETVAL(BUF,ARGTYPE);
CASE CMD OF
FI:BEGIN
BREAK;
FILL:=TRUE END;
NF:BEGIN BREAK;
FILL:=FALSE END;
BR:BREAK;
LS:SETPARAM(LSVAL,VAL,ARGTYPE,1,1,HUGE);
CE:BEGIN BREAK;
SETPARAM(CEVAL,VAL,ARGTYPE,1,0,HUGE) END;
UL:SETPARAM(ULVAL,VAL,ARGTYPE,1,0,HUGE);
HE:GETTL(BUF,HEADER);
FO:GETTL(BUF,FOOTER);
BP:BEGIN PAGE;
SETPARAM(CURPAGE,VAL,ARGTYPE,CURPAGE+1,-HUGE,HUGE);
NEWPAGE:=CURPAGE END;
SP:BEGIN
SETPARAM(SPVAL,VAL,ARGTYPE,1,0,HUGE);
space(spval)
END;
IND:SETPARAM(INVAL,VAL,ARGTYPE,0,0,RMVAL-1);
RM:SETPARAM(RMVAL,VAL,ARGTYPE,PAGEWIDTH,
INVAL+TIVAL+1,HUGE);
TI:BEGIN BREAK;
SETPARAM(TIVAL,VAL,ARGTYPE,0,-HUGE,RMVAL) END;
PL:BEGIN
SETPARAM(PLVAL,VAL,ARGTYPE,PAGELEN,
M1VAL+M2VAL+M3VAL+M4VAL+1,HUGE);
BOTTOM:=PLVAL-M3VAL-M4VAL END;
UNKNOWN:
END
END;
BEGIN
INITFMT;
WHILE(GETLINE(INBUF,STDIN,MAXSTR))DO
IF(INBUF[1]=CMD) THEN
COMMAND(INBUF)
ELSE
TEXT(INBUF);
PAGE
END;
BEGIN
FORMAT;
ENDCMD;
END.
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/