{***************************************************************}
{***               FVision Unit Version1.0                   ***}
{***                    蓝蚂蚁工作室                         ***}
{***************************************************************}
{***                 PCX图形文件支持单元                     ***}
{***************************************************************}
{$F+,O+,X+,S-,D-}
Unit FPcx;
Interface
Uses
  Dos,FDac,FView,SvgaDrv,FWrite,FTool;

Type
  PcxHeader=record
   PcxID:Byte;
   Version:Byte;
   RleEncoding:Byte;
   BitsPerPixel:Byte;
   x1,y1:Integer;
   x2,y2:Integer;
   HRes:Integer;
   VRes:Integer;
   Palette:array[0..47] of Byte;
   Reserved:Byte;
   ColorPlanes:Byte;
   BytesPerLine:Integer;
   PaletteType:Integer;
   UnUsed:array[0..57] of Byte;
  end;

  PPcx=^TPcx;
  TPcx=object(TView)
   Fp:file;
   Result:Word;
   FileName:PathStr;
   PcxHead:PcxHeader;
   PcxDac:DacType;
   Line,Data:array[0..2047] of Byte;
   Height,Width,TrueWid:Integer;
   ColorNum:Integer;
   VideoMode256,VideoMode16:Word;
   TempAttr:Word;
   Center,ShowInfo,ReSetVideo,ReSetDac,BackGround:Boolean;
   Start:LongInt;
   InfoStr:String;
   constructor Init(AFileName:string;Intx,Inty:Integer);
   destructor Done;virtual;
   procedure SetOption(V256,V16:Word;Cen,ShIn,RV,RD,BC:Boolean);
   procedure SetPosition(x,y:Integer);
   procedure GetInfo(var Wid,Hig,Col:Integer);
   procedure ProHeader;
   procedure OpenFile;
   procedure Draw;virtual;
   procedure PutToLine(var Arr;x,y:Integer);
   procedure Creat(x,y:Integer);
  end;


Implementation
constructor TPcx.Init;
begin
  Inherited Init;
  FileName:=AFileName;
  Origin.x:=Intx;
  Origin.y:=Inty;
  Start:=0;
  SetOption($101,$12,False,False,False,False,False);
  TempAttr:=Archive;
end;

destructor TPcx.Done;
begin
  SetFAttr(Fp,TempAttr);
  {$i-}Close(Fp);{$i+}
end;

procedure TPcx.SetOption;
begin
  VideoMode256:=V256;
  VideoMode16:=V16;
  Center:=Cen;
  ShowInfo:=ShIn;
  ReSetVideo:=RV;
  ReSetDac:=RD;
  BackGround:=BC;
end;

procedure TPcx.SetPosition;
begin
  Origin.x:=x;
  Origin.y:=y;
end;

procedure TPcx.GetInfo;
begin
  Wid:=Width+1;
  Hig:=Height+1;
  Col:=ColorNum;
end;

procedure TPcx.ProHeader;
var
  DacMark:Byte;
  i:Integer;
begin
  case PcxHead.BitsPerPixel of
  1:ColorNum:=1 shl PcxHead.ColorPlanes;
  2:if PcxHead.ColorPlanes=4 then
      ColorNum:=16
    else
      ColorNum:=4;
  4:ColorNum:=16;
  8:if PcxHead.ColorPlanes=1 then
      ColorNum:=256
    else
      ColorNum:=0;
  end;
  if ColorNum=256 then
  begin
    Seek(Fp,FileSize(Fp)-769);
    BlockRead(Fp,DacMark,1,Result);
    BlockRead(Fp,PcxDac,Sizeof(DacType),Result);
    if DacMark=$0C then
    for i:=1 to 256*3 do
    PcxDac[i]:=PcxDac[i] shr 2;
  end else
  if ColorNum=16 then
  for i:=0 to 15 do
  begin
    PcxDac[GetDacIndex(i)*3+1]:=PcxHead.Palette[i*3] shr 2;
    PcxDac[GetDacIndex(i)*3+2]:=PcxHead.Palette[i*3+1] shr 2;
    PcxDac[GetDacIndex(i)*3+3]:=PcxHead.Palette[i*3+2] shr 2;
  end;
end;

procedure TPcx.OpenFile;
begin
  IsValid:=False;
  Assign(Fp,FileName);
  GetFAttr(Fp,TempAttr);
  SetFAttr(Fp,Archive);
  {$i-}Reset(Fp,1);{$i+}
  if IOResult<>0 then
  begin
    Writecs(10,10,'Open File '+FileName+' Error!',15);
    Exit;
  end;
  BlockRead(Fp,PcxHead,SizeOf(PcxHeader),Result);
  if PcxHead.PcxID<>10 then Exit;
  if PcxHead.RleEncoding<>1 then Exit;
  if not (PcxHead.Version in [0,2..5]) then Exit;
  if not (PcxHead.BitsPerPixel in [1,2,4,8]) then Exit;
  if not (PcxHead.ColorPlanes in [1,4]) then Exit;
  ProHeader;
  Width:=PcxHead.x2-PcxHead.x1;
  Height:=PcxHead.y2-PcxHead.y1;
  TrueWid:=PcxHead.BytesPerLine*PcxHead.ColorPlanes;
  IsValid:=True;
end;

procedure TPcx.Draw;
  procedure SetCenter;
  begin
    if Center then
    begin
      Origin.X:=0;
      Origin.Y:=0;
      if Maxx>Width then
      Origin.X:=(Maxx-Width) div 2;
      if Maxy>Height then
      Origin.Y:=(Maxy-Height) div 2;
      if MaxColor<256 then
        Start:=Origin.Y*ScanLeng + Origin.X div 8;
    end;
  end;

  procedure ReadPcxLine;
  var
    ByteCount,RunCount,Dtl:Integer;
    TempPos:LongInt;
  begin
    ByteCount:=0;
    Dtl:=0;
    TempPos:=FilePos(Fp);
    BlockRead(Fp,Data,2048,Result);
    while ByteCount<TrueWid do
    begin
      if Data[Dtl]>=$C0 then
      begin
        RunCount:=Data[Dtl] and $3F;
        Inc(Dtl);
        FillChar(Line[ByteCount],RunCount,Data[Dtl]);
        Inc(ByteCount,RunCount);
      end else
      begin
        Line[ByteCount]:=Data[Dtl];
        Inc(ByteCount);
      end;
      Inc(Dtl);
    end;
    Seek(Fp,TempPos+Dtl);
  end;

  procedure Draw_Pcx2;
  var
    i:Integer;
    OfsVideo:Longint;
  begin
    if ReSetVideo then SetVideoMode(VideoMode16);
    SetCenter;
    SetWPlane(1);
    for i:=0 to Height do
    begin
      OfsVideo:=Start+Longint(ScanLeng)*i;
      if (OfsVideo div $10000)<>Current_Page then
      SelectPageVESA(OfsVideo div $10000);
      ReadPcxLine;
      Move(Line,Ptr($A000,OfsVideo)^,pcxhead.BytesPerLine);
    end;
  end;

  procedure Draw_Pcx16;
  var
    i,j:Integer;
    OfsVideo:Longint;
  begin
    if ReSetVideo then SetVideoMode(VideoMode16);
    SetCenter;
    if ReSetDac then Dac.SetNewDac(PcxDac);
    for i:=0 to Height do
    begin
      ReadPcxLine;
      OfsVideo:=Start+Longint(ScanLeng)*i;
      if (OfsVideo div $10000)<>Current_Page then
      SelectPageVESA(OfsVideo div $10000);
      for j:=0 to 3 do
      begin
        SetWPlane(1 shl j);
        Move(Line[j*PcxHead.BytesPerLine],
             Ptr($A000,OfsVideo)^,PcxHead.BytesPerLine);
      end;
    end;
  end;

  procedure Draw_Pcx256;
  var
    i,j:integer;
  begin
    if ReSetVideo then SetVideoMode(VideoMode256);
    SetCenter;
    if ReSetDac then Dac.SetNewDac(PcxDac);
    for i:=0 to Height do
    begin
      ReadPcxLine;
      PutLine8(Origin.x,Origin.y+i,Seg(Line),Ofs(Line),Width+1);
    end;
  end;

begin
  if not IsValid then Exit;
  GetVideoMode;
  Seek(Fp,SizeOf(PcxHeader));
  if ColorNum=2 then Draw_Pcx2
  else if ColorNum=16 then Draw_Pcx16
  else if ColorNum=256 then Draw_Pcx256;
  if ShowInfo then
  begin
    SvgaDrv.SetColor(GetLightColor(DacRegsType(PcxDac)));
    SvgaDrv.MoveTo(Maxx div 2 - 70,Maxy-20);
    InfoStr:=Intstr(Width+1)+'*'+Intstr(Height+1)+' '+Intstr(ColorNum)+'Color';
    SvgaDrv.OutText(InfoStr);
  end;
end;

procedure TPcx.PutToLine;
  procedure ReadPcxLine;
  var
    ByteCount,RunCount,Dtl:Integer;
    TempPos:LongInt;
  begin
    ByteCount:=0;
    Dtl:=0;
    TempPos:=FilePos(Fp);
    BlockRead(Fp,Data,2048,Result);
    while ByteCount<TrueWid do
    begin
      if Data[Dtl]>=$C0 then
      begin
        RunCount:=Data[Dtl] and $3F;
        Inc(Dtl);
        FillChar(Line[ByteCount],RunCount,Data[Dtl]);
        Inc(ByteCount,RunCount);
      end else
      begin
        Line[ByteCount]:=Data[Dtl];
        Inc(ByteCount);
      end;
      Inc(Dtl);
    end;
    Seek(Fp,TempPos+Dtl);
  end;
Type
  ArrType=array[1..$FFFF] of Byte;
var
  i,j:Integer;
begin
  if ColorNum<>256 then Exit;
  Seek(Fp,SizeOf(PcxHeader));
  for i:=0 to Height do
  if (i<y) then
  begin
    ReadPcxLine;
    Move(Line[0],ArrType(Arr)[1+i*x],x);
  end;
end;

procedure TPcx.Creat;
  procedure ConvertDac;
  var
    i:Integer;
  begin
    if Maxcolor=0 then Exit;
    if Maxcolor=16 then
     for i:=0 to Maxcolor-1 do
     begin
      PcxHead.Palette[i*3]:=PcxDac[getdacindex(i)*3+1] shl 2;
      PcxHead.Palette[i*3+1]:=PcxDac[getdacindex(i)*3+2] shl 2;
      PcxHead.Palette[i*3+2]:=PcxDac[getdacindex(i)*3+3] shl 2;
     end
    else
    if MaxColor=256 then
    for i:=1 to 768 do
    PcxDac[i]:=PcxDac[i] shl 2;
  end;

  procedure WritePcxLine;
  var
    ByteCount,RunCount,Dtl:Integer;
    TempData:byte;
  begin
    ByteCount:=0;
    Dtl:=0;
    while ByteCount<TrueWid do
    begin
      TempData:=Line[ByteCount];
      RunCount:=1;
      Inc(ByteCount);
      while (ByteCount<TrueWid) and
            (Line[ByteCount]=TempData) and (RunCount<$3f) do
      begin
        Inc(RunCount);
        Inc(ByteCount);
      end;
      if (RunCount>1)or(TempData>=$C0) then
      begin
        Data[Dtl]:=$C0 or RunCount;
        Data[Dtl+1]:=TempData;
        Inc(Dtl);
      end else
        Data[Dtl]:=TempData;
      Inc(Dtl);
    end;
    BlockWrite(Fp,Data,Dtl,Result);
  end;

  procedure WritePcx16;
  var
    i,j,k:Integer;
  begin
   for i:=0 to Height-1 do
   begin
    for j:=0 to 3 do
    begin
      SetRPlane(j);
      Move(Ptr($A000,ScanLeng*(Origin.y+i)+Origin.x div 8)^,
           Line[j*PcxHead.BytesPerLine],PcxHead.BytesPerLine);
    end;
    WritePcxLine;
   end;
  end;

  procedure WritePcx256;
  var
    i,j:Integer;
    Mark:Byte;
  begin
   for i:=0 to Height-1 do
   begin
    for j:=0 to TrueWid-1 do
    Line[j]:=GetPixel8(Origin.x+j,Origin.y+i);
    WritePcxLine;
   end;
   Mark:=$0C;
   BlockWrite(Fp,Mark,1,Result);
   BlockWrite(Fp,PcxDac,Sizeof(DacType),Result);
  end;

begin
  GetVideoMode;
  if (MaxColor<>16)and(MaxColor<>256) then Exit;
  Assign(Fp,FileName);
  {$i-}ReWrite(Fp,1);{$i+}
  if IOResult<>0 then Exit;
  Width:=x;
  Height:=y;
  PcxHead.PcxID:=$0A;
  PcxHead.Version:=5;
  PcxHead.RleEncoding:=1;
  PcxHead.x1:=0;
  PcxHead.y1:=0;
  PcxHead.x2:=Width-1;
  PcxHead.y2:=Height-1;
  PcxHead.HRes:=Maxx;
  PcxHead.VRes:=Maxy;
  PcxHead.Reserved:=0;
  PcxHead.PaletteType:=2;
  fillchar(PcxHead.UnUsed,58,0);
  PcxHead.ColorPlanes:=1;
  if MaxColor=16 then
  begin
    PcxHead.BitsPerPixel:=1;
    PcxHead.ColorPlanes:=4;
  end else
  if MaxColor=256 then PcxHead.BitsPerPixel:=8;
  PcxHead.BytesPerLine:=PcxHead.BitsPerPixel*width div 8;
  truewid:=pcxhead.BytesPerLine*pcxhead.ColorPlanes;
  Dac.GetDac(PcxDac);
  ConvertDac;
  BlockWrite(Fp,PcxHead,SizeOf(PcxHeader),Result);
  if MaxColor=16 then WritePcx16
  else if MaxColor=256 then WritePcx256;
end;

end.