unit SHP;
{
 Started: 2016/08/17
 By: Stuart "Stucuk" Carey
}

interface

uses Windows, Graphics, Classes;

 type
 TSHP_Header = record
  Zero, Width, Height, Count : Word;
 end;

 TSHP_Header_Image = record
  X, Y, W, H  : Word;
  Compression : Byte;
  Align       : Array [0..2] of byte;
  RadarColor  : TColor;
  Zero,
  Offset      : Integer;
 end;

 // Code above this line taken from SHP_File.Pas which in turn was taken from XCC.

 PSHP_Header_Image = ^TSHP_Header_Image;

 const
  IMGAREA_X = 0;
  IMGAREA_Y = 1;
  IMGAREA_W = 2;
  IMGAREA_H = 3;

 type
 TImgArea = Array [0..3] of Word;

 TSHP_Palette = Array [0..255] of TRGBTriple;

 TSHP_Frame = Record
  UsedArea : TImgArea;   // X,Y,W,H
  PalData  : PByte;      // Holds Image as Palette colours
  RGBData  : PRGBTriple; // Holds Image as RGB colours
  NeedUpd  : Boolean;    // When true RGBData holds an old image
  RadarCol : TColor;
 end;

 TSHP = Class(TObject)
 protected
  FW,FH     : Integer;
  FFrames   : Array of TSHP_Frame;
  FPalette  : TSHP_Palette;
  FTransCol : TRGBTriple;
  procedure Decode3(Input : TStream; Frame : Integer);
  procedure Decode2(Input : TStream; Frame : Integer);
  procedure Decode1(Input : TStream; Frame : Integer);
  function  GetFrame(Index : Integer)    : TSHP_Frame;
  function  GetRGBFrame(Index : Integer) : PRGBTriple;
  procedure EmptyFrameRGB(Index : Integer);
  procedure BuildFrameRGB(Index : Integer);
  function  GetCount() : Integer;
  procedure SetTransCol(Value : TRGBTriple);
  procedure MarkNeedUpd;
 public
  constructor Create;
  destructor Destroy; override;

  procedure LoadFromFile(Filename : AnsiString);
  procedure SaveToFile(Filename : AnsiString);

  procedure LoadFromStream(Stream : TStream);
  procedure SaveToStream(Stream : TStream);

  procedure SetPalette(Palette : TSHP_Palette);
  procedure LoadPalette(Filename : AnsiString);

  property Frame[Index : Integer]    : TSHP_Frame read GetFrame;
  property RGBFrame[Index : Integer] : PRGBTriple read GetRGBFrame;

  property Width  : Integer read FW;
  property Height : Integer read FH;
  property Count  : Integer read GetCount;

  property TransparentColour : TRGBTriple read FTransCol write SetTransCol;
 end;

implementation

uses SysUtils;

function SetRGBTriple(R,G,B : Byte) : TRGBTriple;
begin
 Result.rgbtRed   := R;
 Result.rgbtGreen := G;
 Result.rgbtBlue  := B;
end;

constructor TSHP.Create;
var
 X : Integer;
 C : Byte;
begin
 Inherited;
 SetLength(FFrames,0);

 // Make Black and White Palette as fallback!
 for X := 0 to 254 do
 begin
  C := Trunc(X/254*255);
  FPalette[X+1] := SetRGBTriple(C,C,C);
 end;

 FTransCol   := SetRGBTriple(0,0,255);
 FPalette[0] := FTransCol;
end;

destructor TSHP.Destroy;
var
 X : Integer;
begin
 Inherited;

 for X := 0 to High(FFrames) do
 begin
  FreeMem(FFrames[X].PalData);
  FreeMem(FFrames[X].RGBData);
 end;

 SetLength(FFrames,0);
end;

procedure TSHP.SetTransCol(Value : TRGBTriple);
begin
 FTransCol   := Value;
 FPalette[0] := Value;

 MarkNeedUpd;
end;

procedure TSHP.LoadFromFile(Filename : AnsiString);
var
 Stream : TStream;
begin
 Stream := TFileStream.Create(Filename,fmOpenRead or fmShareDenyWrite);
  LoadFromStream(Stream);
 Stream.Free;
end;

procedure TSHP.SaveToFile(Filename : AnsiString);
var
 Stream : TStream;
begin
 if FileExists(Filename) then
  Stream := TFileStream.Create(Filename,fmCreate)
 else
  Stream := TFileStream.Create(Filename,fmOpenWrite or fmShareDenyRead);
   SaveToStream(Stream);
  Stream.Free;
end;

function SetArea(X,Y,W,H : Word) : TImgArea;
begin
 Result[0] := X;
 Result[1] := Y;
 Result[2] := W;
 Result[3] := H;
end;

function TSHP.GetFrame(Index : Integer) : TSHP_Frame;
begin
 Result := FFrames[Index];
end;

function TSHP.GetRGBFrame(Index : Integer) : PRGBTriple;
begin
 BuildFrameRGB(Index);

 Result := FFrames[Index].RGBData;
end;

function MakeBlankLine(Color : TRGBTriple; L : Integer) : PRGBTriple;
var
 X : Integer;
 T : Pointer;
begin
 GetMem(Result,L*3);
 T := Result;
 for X := 0 to L-1 do
 begin
  CopyMemory(T,@Color,3);
  Inc(Cardinal(T),3);
 end;
end;

procedure TSHP.EmptyFrameRGB(Index : Integer);
var
 Blank : PRGBTriple;
 T     : Pointer;
 Y     : Integer;
begin
 if not FFrames[Index].NeedUpd then
 Exit;

 Blank := MakeBlankLine(FPalette[0],FW);
 T     := FFrames[Index].RGBData;
 for Y := 0 to FH-1 do
 begin
  CopyMemory(T,Blank,FW*3);
  Inc(Cardinal(T),FW*3);
 end;
 FreeMem(Blank);
end;

function LS(Data : Pointer; Y : Integer; Area : TImgArea; W : Integer; Bytes : Byte = 1) : Pointer;
begin
 Result := Pointer(Cardinal(Data) + ((Y+Area[IMGAREA_Y])*W+Area[IMGAREA_X])*Bytes);
end;

function RGBLineStart(Data : Pointer; Y : Integer; Area : TImgArea; W : Integer) : Pointer;
begin
 Result := LS(Data,Y,Area,W,3);
end;

function PALLineStart(Data : Pointer; Y : Integer; Area : TImgArea; W : Integer) : Pointer;
begin
 Result := LS(Data,Y,Area,W,1);
end;

procedure TSHP.BuildFrameRGB(Index : Integer);
var
 RGB : PRGBTriple;
 PAL : PByte;
 X,Y : Integer;
begin
 if not FFrames[Index].NeedUpd then
 Exit;

 if not Assigned(FFrames[Index].RGBData) then
 GetMem(FFrames[Index].RGBData,FW*FH*3);

 EmptyFrameRGB(Index);

 for Y := 0 to FFrames[Index].UsedArea[IMGAREA_H]-1 do
 begin
  RGB := RGBLineStart(FFrames[Index].RGBData,Y,FFrames[Index].UsedArea,FW);
  PAL := PALLineStart(FFrames[Index].PalData,Y,FFrames[Index].UsedArea,FW);
  for X := 0 to FFrames[Index].UsedArea[IMGAREA_W]-1 do
  begin
   RGB^ := FPalette[PAL^];
   Inc(Cardinal(RGB),3);
   Inc(Cardinal(PAL),1);
  end;
 end;
end;

//Based on Decode3 from SHP_File.Pas
procedure TSHP.Decode3(Input : TStream; Frame : Integer);
var
 Output : Pointer;
 Count  : Word;
 V      : Byte;
 Y      : Integer;
begin
 try
  for Y := 0 to FFrames[Frame].UsedArea[IMGAREA_H]-1 do
  begin
   Output := PALLineStart(FFrames[Frame].PalData,Y,FFrames[Frame].UsedArea,FW);
   Input.Read(Count,2);
   Dec(Count,2);
   while Count > 0 do
   begin
    Dec(Count);
    Input.Read(V,1);
    if V <> 0 then
    begin
     Byte(Output^) := V;
     Inc(Cardinal(Output),1);
    end
    else
    begin
     Dec(Count);
     Input.Read(V,1);
     Inc(Cardinal(Output),V);
    end;
   end;
  end;
 except
 end;
end;

procedure TSHP.Decode2(Input : TStream; Frame : Integer);
var
 Count  : Word;
 Y      : Integer;
begin
 try
  for Y := 0 to FFrames[Frame].UsedArea[IMGAREA_H]-1 do
  begin
   Input.Read(Count,2);
   if Count-2 > 0 then
   Input.Read(PALLineStart(FFrames[Frame].PalData,Y,FFrames[Frame].UsedArea,FW)^,Count-2);
  end;
 except

 end;
end;

procedure TSHP.Decode1(Input : TStream; Frame : Integer);
var
 Y : Integer;
begin
 try
  for Y := 0 to FFrames[Frame].UsedArea[IMGAREA_H]-1 do
   Input.Read(PALLineStart(FFrames[Frame].PalData,Y,FFrames[Frame].UsedArea,FW)^,FFrames[Frame].UsedArea[IMGAREA_W]);
 except

 end;
end;

procedure TSHP.LoadFromStream(Stream : TStream);
var
 Header        : TSHP_Header;
 Image_Header,
 Image_Headers : PSHP_Header_Image;
 X             : Integer;
 Mem           : TMemoryStream;
 MemStart      : Int64;
begin
 Stream.Read(Header,SizeOf(TSHP_Header));
 if (Header.Zero <> 0) or (Header.Width = 0) or (Header.Height = 0) or (Header.Count = 0) then
 Exit;

 FW := Header.Width;
 FH := Header.Height;

 SetLength(FFrames,Header.Count);
 GetMem(Image_Headers,SizeOf(TSHP_Header_Image)*Header.Count);
 Stream.Read(Image_Headers^,SizeOf(TSHP_Header_Image)*Header.Count);

 MemStart := Stream.Position;
 //Load the rest of the file in a MemoryStream to reduce overheads
 Mem := TMemoryStream.Create;
 Mem.CopyFrom(Stream,Stream.Size-Stream.Position);
 Mem.Position := 0;

 Image_Header := Image_Headers;
 for X := 0 to Header.Count-1 do
 begin
  FFrames[X].PalData := Nil;
  FFrames[X].RGBData := Nil;
  FFrames[X].NeedUpd := True;

  if Image_Header^.offset <> 0 then
  begin
   FFrames[X].UsedArea := SetArea(Image_Header^.X,Image_Header^.Y,Image_Header^.W,Image_Header^.H);
   FFrames[X].RadarCol := Image_Header^.RadarColor;
   GetMem(FFrames[X].PalData,FW*FH);
   ZeroMemory(FFrames[X].PalData,FW*FH);

   Mem.Seek(Image_Header^.offset-MemStart,soFromBeginning);
   case Image_Header^.compression of
    3 : Decode3(Mem,X);
    2 : Decode2(Mem,X);
    1,
    0 : Decode1(Mem,X);
    else
    begin
     FFrames[X].UsedArea := SetArea(0,0,0,0);
     asm nop end; //Break Point
    end;
   end;
  end;

  Inc(Cardinal(Image_Header),SizeOf(TSHP_Header_Image));
 end;

 Mem.Free;
end;


procedure TSHP.SaveToStream(Stream : TStream);
begin
 //TODO!!!
end;

procedure TSHP.SetPalette(Palette : TSHP_Palette);
begin
 CopyMemory(@FPalette[0],@Palette[0],SizeOf(TSHP_Palette));

 MarkNeedUpd;
end;

procedure TSHP.MarkNeedUpd;
var
 X : Integer;
begin
 for X := 0 to High(FFrames) do
 FFrames[X].NeedUpd := True;
end;

function TSHP.GetCount() : Integer;
begin
 Result := High(FFrames)+1;
end;

procedure TSHP.LoadPalette(Filename : AnsiString);
var
 Stream : TStream;
 X      : Integer;
 T      : Byte;
begin
 Stream := TFileStream.Create(Filename,fmOpenRead or fmShareDenyWrite);
  Stream.Read(FPalette[0],SizeOf(TSHP_Palette));
 Stream.Free;

 for X := 0 to 255 do
 begin
  T                     := FPalette[X].rgbtBlue;
  FPalette[X].rgbtBlue  := FPalette[X].rgbtRed*4;
  FPalette[X].rgbtGreen := FPalette[X].rgbtGreen*4;
  FPalette[X].rgbtRed   := T*4;
 end;

 FPalette[0] := FTransCol;

 MarkNeedUpd;
end;

end.