Metropoli BBS
VIEWER: raw.pas MODE: TEXT (LATIN1)
{$I-}
uses Crt,Dos;

type
  TPCXHeader = record
    Manuf        : byte;
    Version      : byte;
    Encode       : byte;
    BitsPerPixel : byte;
    X1,Y1,X2,Y2  : integer;
    Xres,Yres    : integer;
    Palette      : Array [0..47] of byte;
    VideoMode    : byte;
    Planes       : byte;
    BytesPerLine : integer;
    Reserved     : Array [0..59] of byte;
  end;

  PPCXPic = ^TPCXPic;
  TPCXPic = record
    Header  : TPCXHeader;
    Palette : Array [0..767] of byte;
    Pixels  : Pointer;
  end;

procedure LoadPCX(FileName: string; var PCX: TPCXPic);
var
  F: File;
  Buf: Array [0..1024] of byte;
  BufPtr,Off,Size: word;
  Code,Count: byte;
begin
  Assign(F,FileName);
  Reset(F,1);
  BlockRead(F,PCX.Header,SizeOf(PCX.Header));
  with PCX.Header do
    if (Manuf <> 10) or (Version <> 5) or (Encode <> 1) or
       (BitsPerPixel <> 8) or (Planes <> 1) or
       (BytesPerLine > 320) or (Y2 - Y1 > 199) then begin
      PCX.Pixels := nil;
      Exit;
    end;
  Size := PCX.Header.BytesPerLine * Succ(PCX.Header.Y2 - PCX.Header.Y1);
  GetMem(PCX.Pixels,Size);
  if PCX.Pixels = nil then Exit;

  BufPtr := SizeOf(Buf);
  Off := 0;
  while Off < Size do begin
    if BufPtr >= SizeOf(Buf) then begin
      BlockRead(F,Buf,SizeOf(Buf));
      BufPtr := 0;
    end;
    Code := Buf[BufPtr]; Inc(BufPtr);
    if Code shr 6 = 3 then begin
      Count := Code and 63;
      if BufPtr >= SizeOf(Buf) then begin
        BlockRead(F,Buf,SizeOf(Buf));
        BufPtr := 0;
      end;
      Code := Buf[BufPtr]; Inc(BufPtr);
      FillChar(Mem[Seg(PCX.Pixels^):Ofs(PCX.Pixels^)+Off],Count,Code);
      Inc(Off,Count);
    end
    else begin
      Mem[Seg(PCX.Pixels^):Ofs(PCX.Pixels^)+Off] := Code;
      Inc(Off);
    end;
  end;
  if BufPtr >= SizeOf(Buf) then begin
    BlockRead(F,Buf,SizeOf(Buf));
    BufPtr := 0;
  end;
  Code := Buf[BufPtr]; Inc(BufPtr);
  if Code = 12 then begin
    for Off := 0 to 767 do begin
      if BufPtr >= SizeOf(Buf) then begin
        BlockRead(F,Buf,767-Off);
        BufPtr := 0;
      end;
      PCX.Palette[Off] := Buf[BufPtr]; Inc(BufPtr);
    end;
  end;
  Close(F);
end;

procedure FreePCX(var PCX: TPCXPic);
begin
  if PCX.Pixels <> nil then
    FreeMem(PCX.Pixels,PCX.Header.BytesPerLine*Succ(PCX.Header.Y2-PCX.Header.Y1));
end;

procedure WriteInfo(var PCX: TPCXPic);
begin
  Writeln('PCX Header Info: (debug)');
  with PCX.Header do begin
    Write('  Manuf: ',manuf);
    if Manuf <> 10 then WriteLn(' **10 expected') else Writeln;
    Write('Version: ',version);
    if Version <> 5 then WriteLn(' **5 expected') else Writeln;
    Write(' Encode: ',encode);
    if EnCode <> 1 then WriteLn(' **1 expected') else Writeln;
    Write('    BPP: ',bitsperpixel);
    if BitsPerPixel <> 8 then WriteLn(' **8 expected') else Writeln;
    Writeln('  X1,Y1: ',X1,',',Y1);
    Writeln('  X2,Y2: ',X2,',',Y2);
    Writeln('   Xres: ',Xres);
    Writeln('   Yres: ',Yres);
    Writeln('  VMode: ',VideoMode);
    Write(' Planes: ',Planes);
    if Planes <> 1 then Writeln(' **1 expected') else Writeln;
    Write('    BPL: ',bytesperline);
    if BytesPerLine > 320 then Writeln(' **max 320 pixels') else Writeln;
  end;
  Writeln;
end;

var
  PCX: TPCXPic;
  I: integer;
  F: file;
  Path: PathStr;
  Dir: DirStr;
  Name: NameStr;
  Ext: ExtStr;
  
begin
  Writeln('PCX to RAW Version 0.1รก Copyright (c) 1993 Carlos Hasan.');
  if ParamCount <> 1 then begin
    Writeln('Uso: RAW <filename>');
    Halt;
  end;

  FSplit(ParamStr(1),Dir,Name,Ext);
  if  Ext = '' then Path := Dir + Name + '.PCX' else Path := Dir + Name + Ext;

  {***Load PCX file}
  LoadPCX(Path,PCX);

  {***if error exit}
  if PCX.Pixels = nil then begin
    Writeln('Error reading PCX file: ',Path);
    Writeln;
    WriteInfo(PCX);
    Halt;
  end;

  {***set 320x200x256 mode}
  asm
    mov ax,13h
    int 10h
  end;

  {***set palette}
  Port[$3c8] := 0;
  for I := 0 to 767 do begin
    PCX.Palette[I] := PCX.Palette[I] shr 2;
    Port[$3c9] := PCX.Palette[I];
  end;

  {***putimage}
  with PCX do
    for I := Header.Y1 to Header.Y2 do
      Move(Mem[Seg(PCX.Pixels^):Ofs(PCX.Pixels^) + I*Header.BytesPerLine],
           Mem[$A000:320*I], Header.X2 - Header.X1 + 1);

  {**Write raw data}
  Assign(F, Name + '.RAW');
  Rewrite(F,1);
  with PCX do
    for I := Header.Y1 to Header.Y2 do
      BlockWrite(F,Mem[$A000:320*I],Header.X2 - Header.X1 + 1);
  Close(F);

  {**Write palette}
  Assign(F,Name + '.PAL');
  Rewrite(F,1);
  BlockWrite(F,PCX.Palette,768);
  Close(F);

  {***wait key}
  {ReadKey;}

  {***set 80x25x16 mode}
  asm
    mov ax,03h
    int 10h
  end;

  WriteInfo(PCX);
end.
[ RETURN TO DIRECTORY ]