home *** CD-ROM | disk | FTP | other *** search
/ Media Share 9 / MEDIASHARE_09.ISO / progmisc / fakesrc.zip / MISC / RAW.PAS < prev   
Pascal/Delphi Source File  |  1993-11-19  |  5KB  |  192 lines
  1. {$I-}
  2. uses Crt,Dos;
  3.  
  4. type
  5.   TPCXHeader = record
  6.     Manuf        : byte;
  7.     Version      : byte;
  8.     Encode       : byte;
  9.     BitsPerPixel : byte;
  10.     X1,Y1,X2,Y2  : integer;
  11.     Xres,Yres    : integer;
  12.     Palette      : Array [0..47] of byte;
  13.     VideoMode    : byte;
  14.     Planes       : byte;
  15.     BytesPerLine : integer;
  16.     Reserved     : Array [0..59] of byte;
  17.   end;
  18.  
  19.   PPCXPic = ^TPCXPic;
  20.   TPCXPic = record
  21.     Header  : TPCXHeader;
  22.     Palette : Array [0..767] of byte;
  23.     Pixels  : Pointer;
  24.   end;
  25.  
  26. procedure LoadPCX(FileName: string; var PCX: TPCXPic);
  27. var
  28.   F: File;
  29.   Buf: Array [0..1024] of byte;
  30.   BufPtr,Off,Size: word;
  31.   Code,Count: byte;
  32. begin
  33.   Assign(F,FileName);
  34.   Reset(F,1);
  35.   BlockRead(F,PCX.Header,SizeOf(PCX.Header));
  36.   with PCX.Header do
  37.     if (Manuf <> 10) or (Version <> 5) or (Encode <> 1) or
  38.        (BitsPerPixel <> 8) or (Planes <> 1) or
  39.        (BytesPerLine > 320) or (Y2 - Y1 > 199) then begin
  40.       PCX.Pixels := nil;
  41.       Exit;
  42.     end;
  43.   Size := PCX.Header.BytesPerLine * Succ(PCX.Header.Y2 - PCX.Header.Y1);
  44.   GetMem(PCX.Pixels,Size);
  45.   if PCX.Pixels = nil then Exit;
  46.  
  47.   BufPtr := SizeOf(Buf);
  48.   Off := 0;
  49.   while Off < Size do begin
  50.     if BufPtr >= SizeOf(Buf) then begin
  51.       BlockRead(F,Buf,SizeOf(Buf));
  52.       BufPtr := 0;
  53.     end;
  54.     Code := Buf[BufPtr]; Inc(BufPtr);
  55.     if Code shr 6 = 3 then begin
  56.       Count := Code and 63;
  57.       if BufPtr >= SizeOf(Buf) then begin
  58.         BlockRead(F,Buf,SizeOf(Buf));
  59.         BufPtr := 0;
  60.       end;
  61.       Code := Buf[BufPtr]; Inc(BufPtr);
  62.       FillChar(Mem[Seg(PCX.Pixels^):Ofs(PCX.Pixels^)+Off],Count,Code);
  63.       Inc(Off,Count);
  64.     end
  65.     else begin
  66.       Mem[Seg(PCX.Pixels^):Ofs(PCX.Pixels^)+Off] := Code;
  67.       Inc(Off);
  68.     end;
  69.   end;
  70.   if BufPtr >= SizeOf(Buf) then begin
  71.     BlockRead(F,Buf,SizeOf(Buf));
  72.     BufPtr := 0;
  73.   end;
  74.   Code := Buf[BufPtr]; Inc(BufPtr);
  75.   if Code = 12 then begin
  76.     for Off := 0 to 767 do begin
  77.       if BufPtr >= SizeOf(Buf) then begin
  78.         BlockRead(F,Buf,767-Off);
  79.         BufPtr := 0;
  80.       end;
  81.       PCX.Palette[Off] := Buf[BufPtr]; Inc(BufPtr);
  82.     end;
  83.   end;
  84.   Close(F);
  85. end;
  86.  
  87. procedure FreePCX(var PCX: TPCXPic);
  88. begin
  89.   if PCX.Pixels <> nil then
  90.     FreeMem(PCX.Pixels,PCX.Header.BytesPerLine*Succ(PCX.Header.Y2-PCX.Header.Y1));
  91. end;
  92.  
  93. procedure WriteInfo(var PCX: TPCXPic);
  94. begin
  95.   Writeln('PCX Header Info: (debug)');
  96.   with PCX.Header do begin
  97.     Write('  Manuf: ',manuf);
  98.     if Manuf <> 10 then WriteLn(' **10 expected') else Writeln;
  99.     Write('Version: ',version);
  100.     if Version <> 5 then WriteLn(' **5 expected') else Writeln;
  101.     Write(' Encode: ',encode);
  102.     if EnCode <> 1 then WriteLn(' **1 expected') else Writeln;
  103.     Write('    BPP: ',bitsperpixel);
  104.     if BitsPerPixel <> 8 then WriteLn(' **8 expected') else Writeln;
  105.     Writeln('  X1,Y1: ',X1,',',Y1);
  106.     Writeln('  X2,Y2: ',X2,',',Y2);
  107.     Writeln('   Xres: ',Xres);
  108.     Writeln('   Yres: ',Yres);
  109.     Writeln('  VMode: ',VideoMode);
  110.     Write(' Planes: ',Planes);
  111.     if Planes <> 1 then Writeln(' **1 expected') else Writeln;
  112.     Write('    BPL: ',bytesperline);
  113.     if BytesPerLine > 320 then Writeln(' **max 320 pixels') else Writeln;
  114.   end;
  115.   Writeln;
  116. end;
  117.  
  118. var
  119.   PCX: TPCXPic;
  120.   I: integer;
  121.   F: file;
  122.   Path: PathStr;
  123.   Dir: DirStr;
  124.   Name: NameStr;
  125.   Ext: ExtStr;
  126.   
  127. begin
  128.   Writeln('PCX to RAW Version 0.1ß Copyright (c) 1993 Carlos Hasan.');
  129.   if ParamCount <> 1 then begin
  130.     Writeln('Uso: RAW <filename>');
  131.     Halt;
  132.   end;
  133.  
  134.   FSplit(ParamStr(1),Dir,Name,Ext);
  135.   if  Ext = '' then Path := Dir + Name + '.PCX' else Path := Dir + Name + Ext;
  136.  
  137.   {***Load PCX file}
  138.   LoadPCX(Path,PCX);
  139.  
  140.   {***if error exit}
  141.   if PCX.Pixels = nil then begin
  142.     Writeln('Error reading PCX file: ',Path);
  143.     Writeln;
  144.     WriteInfo(PCX);
  145.     Halt;
  146.   end;
  147.  
  148.   {***set 320x200x256 mode}
  149.   asm
  150.     mov ax,13h
  151.     int 10h
  152.   end;
  153.  
  154.   {***set palette}
  155.   Port[$3c8] := 0;
  156.   for I := 0 to 767 do begin
  157.     PCX.Palette[I] := PCX.Palette[I] shr 2;
  158.     Port[$3c9] := PCX.Palette[I];
  159.   end;
  160.  
  161.   {***putimage}
  162.   with PCX do
  163.     for I := Header.Y1 to Header.Y2 do
  164.       Move(Mem[Seg(PCX.Pixels^):Ofs(PCX.Pixels^) + I*Header.BytesPerLine],
  165.            Mem[$A000:320*I], Header.X2 - Header.X1 + 1);
  166.  
  167.   {**Write raw data}
  168.   Assign(F, Name + '.RAW');
  169.   Rewrite(F,1);
  170.   with PCX do
  171.     for I := Header.Y1 to Header.Y2 do
  172.       BlockWrite(F,Mem[$A000:320*I],Header.X2 - Header.X1 + 1);
  173.   Close(F);
  174.  
  175.   {**Write palette}
  176.   Assign(F,Name + '.PAL');
  177.   Rewrite(F,1);
  178.   BlockWrite(F,PCX.Palette,768);
  179.   Close(F);
  180.  
  181.   {***wait key}
  182.   {ReadKey;}
  183.  
  184.   {***set 80x25x16 mode}
  185.   asm
  186.     mov ax,03h
  187.     int 10h
  188.   end;
  189.  
  190.   WriteInfo(PCX);
  191. end.
  192.