home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 18 / CD_ASCQ_18_111294_W.iso / dos / prg / pas / gfxfx / pakpic.pas < prev    next >
Pascal/Delphi Source File  |  1994-03-20  |  2KB  |  73 lines
  1.  
  2. {$i-}
  3. program packpicture;
  4. { pack picture to file - use 'displaypackedpic' to unpack - by Bas van Gaalen }
  5. uses dos;
  6. const
  7.   zero : byte = 0;
  8. var
  9.   infile,outfile : file of byte;
  10.   infname,outfname : pathstr;
  11.   fp : longint;
  12.   num : word;
  13.   prevbyte : integer;
  14.   inbyte,tbyte : byte;
  15.  
  16. begin
  17.   { file i/o }
  18.   if paramstr(1) = '' then begin
  19.     write(' infile: '); readln(infname); end else infname := paramstr(1);
  20.   assign(infile,infname);
  21.   reset(infile);
  22.   if ioresult <> 0 then begin
  23.     writeln('error opening ',infname); halt; end;
  24.   if paramstr(2) = '' then begin
  25.     write('outfile: '); readln(outfname); end else outfname := paramstr(2);
  26.   assign(outfile,outfname);
  27.   rewrite(outfile);
  28.   if ioresult <> 0 then begin
  29.     writeln('error creating ',outfname); halt; end;
  30.  
  31.   { copy palette }
  32.   seek(infile,$20); { place filepointer after header! }
  33.   for num := 0 to 767 do begin
  34.     read(infile,inbyte);
  35.     write(outfile,inbyte);
  36.   end;
  37.  
  38.   { read'n'pack }
  39.   seek(infile,$320); { place filepointer after header and palette! }
  40.   fp := filesize(infile)-filepos(infile); prevbyte := -1;
  41.   writeln; write(#13,fp:6);
  42.   while not eof(infile) do begin
  43.     read(infile,inbyte);
  44.     if prevbyte = inbyte then begin
  45.       seek(outfile,filepos(outfile)-1);
  46.       num := 1;
  47.       while (prevbyte = inbyte) and (not eof(infile)) do begin
  48.         read(infile,inbyte);
  49.         inc(num);
  50.       end;
  51.       write(outfile,zero);
  52.       tbyte := lo(prevbyte); write(outfile,tbyte);
  53.       tbyte := lo(num); write(outfile,tbyte);
  54.       tbyte := hi(num); write(outfile,tbyte);
  55.       if not eof(infile) then write(outfile,inbyte);
  56.       dec(fp,num); write(#13,fp:6);
  57.       prevbyte := inbyte;
  58.     end
  59.     else begin
  60.       if prevbyte = 0 then begin
  61.         tbyte := 0; write(outfile,tbyte);
  62.         tbyte := 1; write(outfile,tbyte);
  63.         tbyte := 0; write(outfile,tbyte);
  64.       end;
  65.       write(outfile,inbyte);
  66.       dec(fp);
  67.       prevbyte := inbyte;
  68.     end;
  69.   end;
  70.   close(infile);
  71.   close(outfile);
  72. end.
  73.