home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / ENTERPRS / CPM / UTILS / S / TUTOR.ARC / CHAPTER7.PAS < prev    next >
Pascal/Delphi Source File  |  1992-11-30  |  9KB  |  443 lines
  1.  
  2. {chapter7.pas}
  3.  
  4. {
  5.         copyright (c) 1981
  6.         by:     bell telephone laboratories, inc. and
  7.                 whitesmith's ltd.,
  8.  
  9.         this software is derived from the book
  10.                 "software tools in pascal", by
  11.                 brian w. kernighan and p. j. plauger
  12.                 addison-wesley, 1981
  13.                 isbn 0-201-10342-7
  14.  
  15.         right is hereby granted to freely distribute or duplicate this
  16.         software, providing distribution or duplication is not for profit
  17.         or other commercial gain and that this copyright notice remains
  18.         intact.
  19. }
  20.  
  21. procedure format;
  22. const
  23.   cmd=period;
  24.   pagenum=sharp;
  25.   pagewidth=60;
  26.   pagelen=66;
  27.   huge=10000;
  28. type
  29.   cmdtype=(bp,br,ce,fi,fo,he,ind,ls,nf,pl,
  30.     rm,sp,ti,ul,unknown);
  31. var
  32.   curpage,newpage,lineno:integer;
  33.   plval,m1val,m2val,m3val,m4val:integer;
  34.   bottom:integer;
  35.   header,footer:xstring;
  36.   
  37.   fill:boolean;
  38.   lsval,spval,inval,rmval,tival,ceval,ulval:integer;
  39.  
  40.   outp,outw,outwds:integer;
  41.   outbuf:xstring;
  42.   dir:0..1;
  43.   inbuf:xstring;
  44.   
  45. procedure skipbl(var s:xstring;var i:integer);
  46. begin
  47.   while(s[i]=blank) or(s[i]=tab)do
  48.     i:=i+1
  49.   end;
  50.   
  51. function getval(var buf:xstring;var argtype:integer):integer;
  52. var
  53.   i:integer;
  54. begin
  55.   i:=1;
  56.   while(not(buf[i]in[blank,tab,newline]))do
  57.     i:=i+1;
  58.   skipbl(buf,i);
  59.   argtype:=buf[i];
  60.   if(argtype=plus) or (argtype=minus) then
  61.     i:=i+1;
  62.   getval:=ctoi(buf,i)
  63. end;
  64.  
  65. procedure setparam(var param:integer;val,argtype,defval,minval,maxval:
  66.   integer);
  67. begin
  68.   if(argtype=newline)then
  69.     param:=defval
  70.   else if (argtype=plus)then
  71.     param:=param+val
  72.   else if(argtype=minus) then
  73.     param:=param-val
  74.   else param:=val;
  75.   param:=min(param,maxval);
  76.   param:=max(param,minval)
  77. end;
  78.  
  79. procedure skip(n:integer);
  80. var i:integer;
  81. begin
  82.   for i:=1 to n do
  83.     putc(newline)
  84. end;
  85.  
  86. procedure puttl(var buf:xstring;pageno:integer);
  87. var i:integer;
  88. begin
  89.   for i:=1 to xlength(buf) do
  90.     if(buf[i]=pagenum) then
  91.       putdec(pageno,1)
  92.     else
  93.       putc(buf[i])
  94. end;
  95.  
  96. procedure putfoot;
  97. begin
  98.   skip(m3val);
  99.   if(m4val>0) then begin
  100.     puttl(footer,curpage);
  101.     skip(m4val-1)
  102.   end
  103. end;
  104.  
  105. procedure puthead;
  106. begin
  107.   curpage:=newpage;
  108.   newpage:=newpage+1;
  109.   if(m1val>0)then begin
  110.     skip(m1val-1);
  111.     puttl(header,curpage)
  112.   end;
  113.   skip(m2val);
  114.   lineno:=m1val+m2val+1
  115. end;
  116.  
  117. procedure put(var buf:xstring);
  118. var
  119.   i:integer;
  120. begin
  121.   if(lineno<=0) or(lineno>bottom) then
  122.     puthead;
  123.   for i:=1 to inval+tival do
  124.     putc(blank);
  125.   tival:=0;
  126.   putstr(buf,stdout);
  127.   skip(min(lsval-1,bottom-lineno));
  128.   lineno:=lineno+lsval;
  129.   if(lineno>bottom)then putfoot
  130. end;
  131.  
  132.  
  133. procedure break;
  134. begin
  135.   if(outp>0) then begin
  136.     outbuf[outp]:=newline;
  137.     outbuf[outp+1]:=endstr;
  138.     put(outbuf)
  139.   end;
  140.   outp:=0;
  141.   outw:=0;
  142.   outwds:=0
  143. end;
  144.  
  145. function getword(var s:xstring;i:integer;
  146.   var out:xstring):integer;
  147. var
  148.   j:integer;
  149. begin
  150.   while(s[i] in [blank,tab,newline]) do
  151.     i:=i+1;
  152.   j:=1;
  153.   while(not (s[i] in [endstr,blank,tab,newline])) do begin
  154.     out[j]:=s[i];
  155.     i:=i+1;
  156.     j:=j+1
  157.   end;
  158.   out[j]:=endstr;
  159.   if(s[i]=endstr) then
  160.     getword:=0
  161.   else
  162.     getword:=i
  163. end;
  164.  
  165. procedure leadbl(var buf:xstring);
  166. var i,j:integer;
  167. begin
  168.   break;
  169.   i:=1;
  170.   while(buf[i]=blank) do
  171.     i:=i+1;
  172.   if(buf[i]<>newline) then
  173.     tival:=tival+i-1;
  174.   for j:=i to xlength(buf)+1 do
  175.     buf[j-i+1]:=buf[j]
  176. end;
  177.  
  178. procedure gettl(var buf,ttl:xstring);
  179. var
  180.   i:integer;
  181. begin
  182.   i:=1;
  183.   while(not(buf[i]in[blank,tab,newline]))do
  184.     i:=i+1;
  185.   skipbl(buf,i);
  186.   if(buf[i]=squote) or(buf[i]=dquote)then
  187.     i:=i+1;
  188.   scopy(buf,i,ttl,1)
  189. end;
  190.  
  191. procedure space(n:integer);
  192. begin
  193.   break;
  194.   if (lineno<=bottom) then begin
  195.     if(lineno<=0)then
  196.       puthead;
  197.     skip(min(n,bottom+1-lineno));
  198.     lineno:=lineno+n;
  199.     if(lineno>bottom) then
  200.       putfoot
  201.   end
  202. end;
  203.  
  204. procedure page;
  205. begin
  206.   break;
  207.   if(lineno>0) and (lineno<=bottom) then begin
  208.     skip(bottom+1-lineno);putfoot
  209.   end;
  210.   lineno:=0
  211. end;
  212.  
  213. function width(var buf:xstring):integer;
  214. var
  215.   i,w:integer;
  216. begin
  217.   w:=0;
  218.   i:=1;
  219.   while(buf[i]<>endstr) do begin
  220.     if (buf[i] = backspace) then
  221.       w:=w-1
  222.     else if (buf[i]<>newline) then
  223.       w:=w+1;i:=i+1
  224.   end;
  225.   width:=w
  226. end;
  227.  
  228. procedure spread(var buf:xstring;
  229. outp,nextra,outwds:integer);
  230. var
  231.   i,j,nb,nholes:integer;
  232. begin
  233.   if(nextra>0) and (outwds>1) then begin
  234.     dir:=1-dir;
  235.     nholes:=outwds-1;
  236.     i:=outp-1;
  237.     j:=min(maxstr-2,i+nextra);
  238.     while(i<j) do begin
  239.       buf[j]:=buf[i];
  240.       if(buf[i]=blank) then begin
  241.         if(dir=0) then
  242.           nb:=(nextra-1) div nholes +1
  243.         else nb:=nextra div nholes;
  244.         nextra:=nextra - nb;
  245.         nholes:=nholes-1;
  246.         while(nb>0) do begin
  247.           j:=j-1;
  248.           buf[j]:=blank;
  249.           nb:=nb-1
  250.         end
  251.       end;
  252.       i:=i-1;
  253.       j:=j-1
  254.     end
  255.   end
  256. end;
  257.  
  258. procedure putword(var wordbuf:xstring);
  259. var
  260.   last,llval,nextra,w:integer;
  261. begin
  262.   w:=width(wordbuf);
  263.   last:=xlength(wordbuf)+outp+1;
  264.   llval:=rmval-tival-inval;
  265.   if(outp>0)
  266.     and ((outw+w>llval) or (last >=maxstr)) then begin
  267.       last:=last-outp;
  268.       nextra:=llval-outw+1;
  269.       if(nextra >0) and(outwds>1) then begin
  270.         spread(outbuf,outp,nextra,outwds);
  271.         outp:=outp+nextra
  272.       end;
  273.       break
  274.     end;
  275.     scopy(wordbuf,1,outbuf,outp+1);
  276.     outp:=last;
  277.     outbuf[outp]:=blank;
  278.     outw:=outw+w+1;
  279.     outwds:=outwds+1
  280. end;
  281.  
  282. procedure center(var buf:xstring);
  283. begin
  284.   tival:=max((rmval+tival-width(buf)) div 2,0)
  285. end;
  286.  
  287. procedure underln (var buf:xstring;size:integer);
  288. var
  289.   i,j:integer;
  290.   tbuf:xstring;
  291. begin
  292.   j:=1;
  293.   i:=1;
  294.   while(buf[i]<>newline) and (j<size-1)do begin
  295.     if(isalphanum(buf[i])) then begin
  296.       tbuf[j]:=underline;
  297.       tbuf[j+1]:=backspace;
  298.       j:=j+2
  299.     end;
  300.     tbuf[j]:=buf[i];
  301.     j:=j+1;
  302.     i:=i+1
  303.   end;
  304.   tbuf[j]:=newline;
  305.   tbuf[j+1]:=endstr;
  306.   scopy(tbuf,1,buf,1)
  307. end;
  308.  
  309. procedure text(var inbuf:xstring);
  310. var
  311.   wordbuf:xstring;
  312.   i:integer;
  313. begin
  314.   if(inbuf[1]=blank) or (inbuf[1]=newline) then
  315.     leadbl(inbuf);
  316.   if(ulval>0) then begin
  317.     underln(inbuf,maxstr);
  318.     ulval:=ulval-1
  319.   end;
  320.   if(ceval>0)then begin
  321.     center(inbuf);
  322.     put(inbuf);
  323.     ceval:=ceval-1
  324.   end
  325.   else if (inbuf[1]=newline)then
  326.     put(inbuf)
  327.   else if(not fill) then
  328.     put(inbuf)
  329.   else begin
  330.     i:=1;
  331.     repeat
  332.       i:=getword(inbuf,i,wordbuf);
  333.       if(i>0)then
  334.         putword(wordbuf)
  335.       until(i=0)
  336.     end
  337.     
  338. end;
  339.   
  340.  
  341. procedure initfmt;
  342. begin
  343.   fill:=true;
  344.   dir:=0;
  345.   inval:=0;
  346.   rmval:=pagewidth;
  347.   tival:=0;
  348.   lsval:=1;
  349.   spval:=0;
  350.   ceval:=0;
  351.   ulval:=0;
  352.   lineno:=0;
  353.   curpage:=0;
  354.   newpage:=1;
  355.   plval:=pagelen;
  356.   m1val:=3;m2val:=2;m3val:=2;m4val:=3;
  357.   bottom:=plval-m3val-m4val;
  358.   header[1]:=newline;
  359.   header[2]:=endstr;
  360.   footer[1]:=newline;
  361.   footer[2]:=endstr;
  362.   outp:=0;
  363.   outw:=0;
  364.   outwds:=0
  365. end;
  366.  
  367. function getcmd(var buf:xstring):cmdtype;
  368. var
  369.   cmd:packed array[1..2] of char;
  370. begin
  371.   cmd[1]:=chr(buf[2]);
  372.   cmd[2]:=chr(buf[3]);
  373.   if(cmd='fi')then getcmd:=fi
  374.   else if (cmd='nf')then getcmd:=nf
  375.   else if (cmd='br')then getcmd:=br
  376.   else if (cmd='ls')then getcmd:=ls
  377.   else if (cmd='bp')then getcmd:=bp
  378.   else if (cmd='sp')then getcmd:=sp
  379.   else if (cmd='in')then getcmd:=ind
  380.   else if (cmd='rm')then getcmd:=rm
  381.   else if (cmd='ce')then getcmd:=ce
  382.   else if (cmd='ti')then getcmd:=ti
  383.   else if (cmd='ul')then getcmd:=ul
  384.   else if (cmd='he') then getcmd:=he
  385.   else if (cmd='fo') then getcmd:=fo
  386.   else if (cmd='pl') then getcmd:=pl
  387.   else getcmd:=unknown
  388. end;
  389.  
  390. procedure command(var buf:xstring);
  391. var cmd:cmdtype;
  392. argtype,spval,val:integer;
  393. begin
  394.   cmd:=getcmd(buf);
  395.   if(cmd<>unknown)then
  396.     val:=getval(buf,argtype);
  397.     case cmd of
  398.     fi:begin
  399.        break;
  400.        fill:=true end;
  401.     nf:begin break;
  402.        fill:=false end;
  403.     br:break;
  404.     ls:setparam(lsval,val,argtype,1,1,huge);
  405.     ce:begin break;
  406.        setparam(ceval,val,argtype,1,0,huge) end;
  407.     ul:setparam(ulval,val,argtype,1,0,huge);
  408.     he:gettl(buf,header);
  409.     fo:gettl(buf,footer);
  410.     bp:begin page;
  411.        setparam(curpage,val,argtype,curpage+1,-huge,huge);
  412.        newpage:=curpage end;
  413.     sp:begin
  414.        setparam(spval,val,argtype,1,0,huge);
  415.        space(spval)
  416.        end;
  417.     ind:setparam(inval,val,argtype,0,0,rmval-1);
  418.     rm:setparam(inval,val,argtype,pagewidth,
  419.         inval+tival+1,huge);
  420.     ti:begin break;
  421.        setparam(tival,val,argtype,0,-huge,rmval) end;
  422.     pl:begin
  423.        setparam(plval,val,argtype,pagelen,
  424.         m1val+m2val+m3val+m4val+1,huge);
  425.        bottom:=plval-m3val-m4val end;
  426.     unknown:
  427.     end
  428.   end;
  429.  
  430.        
  431.        
  432.  
  433. begin
  434.   
  435.   initfmt;
  436.   while(getline(inbuf,stdin,maxstr))do
  437.     if(inbuf[1]=cmd) then
  438.       command(inbuf)
  439.     else
  440.       text(inbuf);
  441.     page
  442. end;
  443.