home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / MADTRB16.ZIP / HATCHZAP.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1986-02-06  |  7.3 KB  |  220 lines
  1. {|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|
  2.  - HatchZap - This program will remove the cross-hatching from a Lotus     -
  3.  | 1-2-3 bar graph.                                                        |
  4.  -                                                                         -
  5.  | Doug Senalik - Nov. 3, 1985                                             |
  6.  -                                                                         -
  7.  |-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|}
  8.  
  9. {These are the values which specify what type of information is to follow}
  10. const Font=$A7;     {Specify font to use for labels}
  11.       LblSiz=$AC;   {Set size of following label}
  12.       Labl=$A8;     {Text label follows}
  13.       PlotUp=$A0;   {Position "pen" without drawing}
  14.       PlotDn=$A2;   {Move "pen", drawing line}
  15.       Color=$B0;    {Select "pen" color with bits 0-3 of this byte}
  16.       MaxSiz=$00;   {Maximum coordinates of plane}
  17.       EndFile=$60;  {PIC file end of file marker}
  18.       CtrlZ=$1A;    {DOS end of file marker}
  19.  
  20. type FileString=string[80];
  21.      CharString=string[80];
  22.  
  23. var InstructionCount, HatchesZapped,
  24.       Skip, XStart, YStart, XEnd, YEnd,
  25.       XPos, YPos, I, J: integer;
  26.     DoingString: boolean;
  27.     InFileName, OutFileName: FileString;
  28.     InFile, OutFile: file of byte;
  29.     AByte, Byte1, Byte2, Byte3, Byte4: byte;
  30.  
  31.  
  32. procedure Strip (var AnyString: CharString);
  33. {Removes leading and trailing spaces from a string.}
  34.  
  35. begin
  36.   while (length(AnyString)>0) and (AnyString[1]=' ') do
  37.     delete (AnyString,1,1);
  38.   while (length(AnyString)>0) and (AnyString[length(AnyString)]=' ') do
  39.     AnyString[0]:=chr (length(AnyString)-1);  {Delete last character}
  40. end;  {Strip}
  41.  
  42.  
  43. function UpperCase (AnyString: CharString): CharString;
  44. {Converts a string to entirely upper case characters.}
  45.  
  46. var I: integer;
  47.  
  48. begin
  49.   UpperCase:=AnyString;  {Get new string of correct length first}
  50.   for I:=1 to length (AnyString) do
  51.     UpperCase[I]:=upcase (AnyString[I]);  {Now to upper case}
  52. end;  {UpperCase}
  53.  
  54.  
  55. procedure PicCheck (var AnyName: FileString);
  56. {Now check for the proper extension of PIC, or put it on if none supplied}
  57.  
  58. var I: integer;
  59.  
  60. begin
  61.   I:=pos('.',AnyName);
  62.   if (I=0) then
  63.     AnyName:=AnyName + '.PIC'
  64.   else
  65.     if (I=length(AnyName)) then
  66.       AnyName:=AnyName + 'PIC'
  67.     else
  68.       if copy(AnyName,I,4)<>'.PIC' then
  69.         begin
  70.           writeln ('Lotus picture files can only have an extension of .PIC');
  71.           writeln ('Program aborted!');
  72.           halt;
  73.         end;
  74. end;  {PicCheck}
  75.  
  76.  
  77. begin  {Main program}
  78.   InstructionCount:=0;  {Just to show user how many instructions done so far}
  79.   HatchesZapped:=0;  {How many cross-hatching lines deleted}
  80.   Skip:=12;  {Don't look at first 12 bytes.  Their function remains}
  81.              {unknown.  Transfer them to the new file unchanged.}
  82.   DoingString:=false;  {true when string instruction found}
  83.   XStart:=-1;
  84.   YStart:=-1;
  85.   clrscr;
  86.   normvideo;
  87.   gotoxy (25,1);
  88.   writeln ('HatchZap');
  89.   writeln;
  90.   writeln ('This handy program will remove the cross-hatching from a');
  91.   writeln ('Lotus-generated bar graph, leaving open bars.  Don''t use');
  92.   writeln ('this program on other graph types unless you want nonsense.');
  93.   writeln;
  94.   writeln;
  95.   if paramstr(1)='' then
  96.     begin
  97.       write ('Select input file: ');
  98.       readln (InFileName);
  99.     end
  100.   else
  101.     InFileName:=paramstr(1);
  102.   {Manipulate file names to remove spaces, make all upper case}
  103.   Strip (InFileName);
  104.   InFileName:=UpperCase (InFileName);
  105.   {Now check for the proper extension of PIC, or put it on if none supplied}
  106.   PicCheck (InFileName);
  107.   if paramstr(2)='' then
  108.     begin
  109.       write ('Select output file: ');
  110.       readln (OutFileName);
  111.     end
  112.   else
  113.     OutFileName:=paramstr(2);
  114.   Strip (OutFileName);
  115.   OutFileName:=UpperCase (OutFileName);
  116.   PicCheck (OutFileName);
  117.   if InFileName=OutFileName then
  118.     begin
  119.       writeln ('Big error!  You can''t use the same name for both files!');
  120.       halt;
  121.     end;
  122.   writeln;
  123.   writeln;
  124.   assign (InFile, InFileName);
  125.   assign (OutFile, OutFileName);
  126.   reset (InFile);
  127.   rewrite (OutFile);
  128.   writeln ('Now converting ', InFileName, ' to ', OutFileName);
  129.   writeln;
  130.   write ('  Instruction count = ');
  131.   XPos:=wherex;
  132.   YPos:=wherey;
  133.   writeln;
  134.   writeln ('Crosshatches zapped = 0');
  135.   writeln;
  136.  
  137.   {Now do the conversion}
  138.  
  139.   while not (eof(InFile)) do
  140.     begin
  141.       read (InFile, AByte);
  142.       if Skip>0 then
  143.         begin
  144.           Skip:=Skip-1;
  145.           write (OutFile, AByte);
  146.         end
  147.       else if DoingString then
  148.         begin
  149.           if AByte=0 then DoingString:=false;  {0 is end of string marker}
  150.           write (OutFile, AByte);
  151.         end
  152.       else if (AByte and $F0)=Color then
  153.         begin
  154.           write (OutFile, AByte);
  155.           InstructionCount:=InstructionCount + 1;
  156.           gotoxy (XPos, YPos);
  157.           write (InstructionCount);
  158.         end
  159.       else
  160.         begin
  161.           InstructionCount:=InstructionCount + 1;
  162.           gotoxy (XPos, YPos);
  163.           write (InstructionCount);
  164.           case AByte of
  165.           EndFile,
  166.             CtrlZ: write (OutFile, AByte);
  167.              Font:  begin
  168.                       Skip:=1;
  169.                       write (OutFile, AByte);
  170.                     end;
  171.            PlotUp: begin
  172.                      Read (InFile, Byte1, Byte2, Byte3, Byte4);
  173.                      XStart:=Byte1*256+Byte2;
  174.                      YStart:=Byte3*256+Byte4;
  175.                      write (OutFile, AByte, Byte1, Byte2, Byte3, Byte4);
  176.                    end;
  177.            LblSiz,
  178.            MaxSiz: begin
  179.                      Skip:=4;
  180.                      write (OutFile, AByte);
  181.                    end;
  182.              Labl: begin
  183.                      DoingString:=true;
  184.                      Skip:=1;  {Skip over the next byte, which is a flag,}
  185.                                {and can be 00, the end of string marker}
  186.                      write (OutFile, AByte);
  187.                    end;
  188.            PlotDn: begin
  189.                      Read (InFile, Byte1, Byte2, Byte3, Byte4);
  190.                      XEnd:=Byte1*256+Byte2;
  191.                      YEnd:=Byte3*256+Byte4;
  192.                      {Only send this command for horizontal or vertical lines}
  193.                      {This therefore excludes diagonal cross-hatching!}
  194.                      if (XStart=XEnd) or (YStart=YEnd) then
  195.                        write (OutFile, AByte, Byte1, Byte2, Byte3, Byte4)
  196.                      else
  197.                        begin
  198.                          HatchesZapped:=HatchesZapped + 1;
  199.                          gotoxy (XPos, YPos+1);
  200.                          write (HatchesZapped);
  201.                        end;
  202.                      XStart:=XEnd;
  203.                      YStart:=YEnd;
  204.                    end;
  205.           else
  206.             write (OutFile, AByte);  {Unanticipated stuff goes through}
  207.             write ('    Warning! - Unknown instruction of ',AByte:3);
  208.           end;  {case}
  209.         end;  {else}
  210.     end;  {while not eof}
  211.   close (InFile);
  212.   close (OutFile);
  213.   gotoxy (1,YPos+2);
  214.   writeln;
  215.   writeln ('Completed.');
  216.   writeln;
  217. end.
  218.  
  219.  
  220. {End of file}