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 / CHAPTER2.PAS < prev    next >
Pascal/Delphi Source File  |  1992-11-30  |  7KB  |  300 lines
  1.  
  2. {chapter2.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 translit;forward;
  22. procedure entab;forward;
  23. procedure expand;forward;
  24. procedure echo;forward;
  25. procedure compress;forward;
  26. procedure overstrike;forward;
  27.  
  28.  
  29. procedure overstrike;
  30. const
  31.   skip=blank;
  32.   noskip=plus;
  33. var
  34.   c:character;
  35.   col,newcol,i:integer;
  36. begin
  37.   col:=1;
  38.   repeat
  39.     newcol:=col;
  40.     while(getc(c)=backspace) do
  41.       newcol:=max(newcol-1,1);
  42.     if (newcol<col) then begin
  43.       putc(newline);
  44.       putc(noskip);
  45.       for i:=1 to newcol-1 do
  46.         putc(blank);
  47.       col:=newcol
  48.     end
  49.     else if (col=1) and (c<>endfile) then
  50.       putc(skip);
  51.     if(c<>endfile)then begin
  52.       putc(c);
  53.       if (c=newline) then
  54.         col:=1
  55.       else
  56.         col:=col+1
  57.       end
  58.     until (c=endfile)
  59.   end;
  60.  
  61. procedure compress;
  62. const
  63.   warning=caret;
  64. var
  65.   c,lastc:character;
  66.   n:integer;
  67.  
  68. procedure putrep(n:integer;c:character);const
  69.   maxrep=26;
  70.   thresh=4;
  71. begin
  72.   while(n>=thresh)or((c=warning)and(n>0))do begin
  73.     putc(warning);
  74.     putc(min(n,maxrep)-1+ord('a'));
  75.     putc(c);
  76.     n:=n-maxrep
  77.   end;
  78.   for n:=n downto 1 do
  79.     putc(c)
  80.   end;
  81.  
  82. begin(*compress*)
  83.   n:=1;
  84.   lastc:=getc(lastc);
  85.   while(lastc<>endfile) do begin
  86.     if(getc(c)=endfile)then begin
  87.       if(n>1) or(lastc=warning) then
  88.         putrep(n,lastc)
  89.       else
  90.         putc(lastc)
  91.       end
  92.       else if (c=lastc) then
  93.         n:=n+1
  94.       else if (n>1) or (lastc=warning) then begin
  95.         putrep(n,lastc);
  96.         n:=1
  97.       end
  98.       else
  99.          putc(lastc);
  100.       lastc:=c
  101.     end
  102.   end;
  103.   
  104.   procedure expand;
  105.   const
  106.     warning=caret;
  107.    var
  108.      c:character;
  109.      n:integer;
  110.   begin
  111.     while(getc(c)<>endfile) do
  112.       if (c<>warning)then
  113.         putc(c)
  114.       else if(isupper(getc(c))) then begin
  115.         n:=c-ord('a')+1;
  116.         if(getc(c)<>endfile)then
  117.           for n:=n downto 1 do
  118.             putc(c)
  119.           else begin
  120.             putc(warning);
  121.             putc(n-1+ord('a'))
  122.           end
  123.       end
  124.       else begin
  125.         putc(warning);
  126.         if(c<>endfile) then
  127.           putc(c)
  128.       end
  129.   end;
  130.  
  131.  
  132. procedure echo;
  133. var
  134.   i,j:integer;
  135.   argstr:xstring;
  136. begin
  137.   i:=2;
  138.   while(getarg(i,argstr,maxstr))do begin
  139.     if(i>1) then putc(blank);
  140.     for j:=1 to xlength(argstr) do
  141.       putc(argstr[j]);
  142.     i:=i+1
  143.   end;
  144.   if(i>1)then putc(newline)
  145. end;
  146.  
  147.  
  148.  
  149. procedure entab;
  150. const
  151.   maxline=1000;
  152. type
  153.   tabtype=array[1..maxline] of boolean;
  154. var
  155.   c:character;
  156.   col,newcol:integer;
  157.   tabstops:tabtype;
  158.  
  159. function tabpos(col:integer;var tabstops:tabtype):boolean;
  160. begin
  161.   if(col>maxline)then
  162.     tabpos:=true
  163.   else
  164.     tabpos:=tabstops[col]
  165. end;
  166.  
  167. procedure settabs(var tabstops:tabtype);
  168. const
  169.   tabspace=4;
  170. var
  171.   i:integer;
  172. begin
  173.   for i:=1 to maxline do
  174.     tabstops[i]:=(i mod tabspace = 1)
  175. end;
  176.  
  177.     begin
  178.   settabs(tabstops);
  179.   col:=1;
  180.   repeat
  181.     newcol:=col;
  182.     while(getc(c)=blank) do begin
  183.       newcol:=newcol+1;
  184.       if(tabpos(newcol,tabstops))then begin
  185.         putc(tab);
  186.         col:=newcol;
  187.       end
  188.     end;
  189.     while (col<newcol) do begin
  190.       putc(blank);
  191.       col:=col+1
  192.     end;
  193.     if(c<>endfile) then begin
  194.       putc(c);
  195.       if(c=newline) then
  196.         col:=1
  197.       else
  198.         col:=col+1
  199.       end
  200.     until(c=endfile)
  201.   end;
  202.  
  203.  
  204.  
  205. procedure translit;
  206. const
  207.   negate=caret;
  208. var
  209.   arg,fromset,toset:xstring;
  210.   c:character;
  211.   i,lastto:0..maxstr;
  212.   allbut,squash:boolean;
  213. function xindex(var inset:xstring;c:character;
  214.   allbut:boolean;lastto:integer):integer;
  215. begin
  216.   if(c=endfile)then xindex:=0
  217.   else if (not allbut) then
  218.     xindex:=index(inset,c)
  219.   else if(index(inset,c)>0)then
  220.     xindex:=0
  221.   else
  222.     xindex:=lastto+1
  223. end;
  224.   
  225. function makeset(var inset:xstring;k:integer;
  226.   var outset:xstring;maxset:integer):boolean;
  227.  
  228. var j:integer;
  229.  
  230. procedure dodash(delim:character;var src:xstring;
  231.   var i:integer;var dest:xstring;
  232.   var j:integer;maxset:integer);
  233. var
  234.   k:integer;
  235.   junk:boolean;
  236. begin
  237.   while (src[i]<>delim)and(src[i]<>endstr)do begin
  238.     if(src[i]=atsign)then
  239.       junk:=addstr(esc(src,i),dest,j,maxset)
  240.     else if (src[i]<>dash) then
  241.       junk:=addstr(src[i],dest,j,maxset)
  242.     else if (j<=1)or(src[i+1]=endstr)then
  243.       junk:=addstr(dash,dest,j,maxset)
  244.     else if (isalphanum(src[i-1]))
  245.       and (isalphanum(src[i+1]))
  246.       and (src[i-1]<=src[i+1]) then begin
  247.         for k:=src[i-1]+1 to src[i+1] do
  248.           junk:=addstr(k,dest,j,maxset);
  249.         i:=i+1
  250.       end
  251.     else
  252.       junk:=addstr(dash,dest,j,maxset);
  253.     i:=i+1
  254.   end
  255.   
  256. end;(*dodash*)
  257.  
  258. begin(*makeset*)
  259.   j:=1;
  260.   dodash(endstr,inset,k,outset,j,maxset);
  261.   makeset:=addstr(endstr,outset,j,maxset)
  262. end;(*makeset*)
  263.  
  264. begin(*translit*)
  265.   if (not getarg(2,arg,maxstr))then
  266.     error('usage:translit from to');
  267.   allbut:=(arg[1]=negate);
  268.   if(allbut)then
  269.     i:=2
  270.   else
  271.     i:=1;
  272.   if (not makeset(arg,i,fromset,maxstr)) then
  273.     error('translit:"from"set too large');
  274.   if(not getarg(3,arg,maxstr))then
  275.     toset[1]:=endstr
  276.   else if (not makeset(arg,1,toset,maxstr)) then
  277.     error('translit:"to"set too large')
  278.   else if (xlength(fromset)<xlength(toset))then
  279.     error('translit:"from"shorter than "to');
  280.   
  281.   lastto:=xlength(toset);
  282.   squash:=(xlength(fromset)>lastto) or (allbut);
  283.   repeat
  284.     i:=xindex(fromset,getc(c),allbut,lastto);
  285.     if (squash) and(i>=lastto) and (lastto>0) then begin
  286.       putc(toset[lastto]);
  287.       repeat
  288.         i:=xindex(fromset,getc(c),allbut,lastto)
  289.       until (i<lastto)
  290.     end;
  291.     if(c<>endfile) then begin
  292.       if(i>0)and(lastto>0) then
  293.         putc(toset[i])
  294.       else if (i=0)then
  295.         putc(c)
  296.       (*else delete*)
  297.     end
  298.   until(c=endfile)
  299. end;
  300.