dxteximg.pas

传奇客户端源码DClient很不错哦直的研究的游戏源码

unit DXTexImg;

interface

uses
  Windows, SysUtils, Classes, DXConsts;

const
  DXTextureImageGroupType_Normal = 0; // Normal group
  DXTextureImageGroupType_Mipmap = 1; // Mipmap group

type
  EDXTextureImageError = class(Exception);

  TDXTextureImageChannel = record
    Mask: DWORD;
    BitCount: Integer;

    {  Internal use  }
    _Mask2: DWORD;
    _rshift: Integer;
    _lshift: Integer;
    _BitCount2: Integer;
  end;

  TDXTextureImage_PaletteEntries =  array[0..255] of TPaletteEntry;

  TDXTextureImageType = (
    DXTextureImageType_PaletteIndexedColor,
    DXTextureImageType_RGBColor
  );

  TDXTextureImage = class;

  TDXTextureImageLoadFunc = procedure(Stream: TStream; Image: TDXTextureImage);

  TDXTextureImage = class
  private
    FOwner: TDXTextureImage;
    FSubImage: TList;
    FImageType: TDXTextureImageType;
    FWidth: Integer;
    FHeight: Integer;
    FPBits: Pointer;
    FBitCount: Integer;
    FPackedPixelOrder: Boolean;
    FWidthBytes: Integer;
    FNextLine: Integer;
    FSize: Integer;
    FTopPBits: Pointer;
    FTransparent: Boolean;
    FTransparentColor: DWORD;
    FImageGroupType: DWORD;
    FImageID: DWORD;
    FImageName: string;
    FAutoFreeImage: Boolean;
    procedure ClearImage;
    function GetPixel(x, y: Integer): DWORD;
    procedure SetPixel(x, y: Integer; c: DWORD);
    function GetScanLine(y: Integer): Pointer;
    function GetSubGroupImageCount(GroupTypeID: DWORD): Integer;
    function GetSubGroupImage(GroupTypeID: DWORD; Index: Integer): TDXTextureImage;
    function GetSubImageCount: Integer;
    function GetSubImage(Index: Integer): TDXTextureImage;
  public
    idx_index: TDXTextureImageChannel;
    idx_alpha: TDXTextureImageChannel;
    idx_palette: TDXTextureImage_PaletteEntries;
    rgb_red: TDXTextureImageChannel;
    rgb_green: TDXTextureImageChannel;
    rgb_blue: TDXTextureImageChannel;
    rgb_alpha: TDXTextureImageChannel;
    constructor Create;
    constructor CreateSub(AOwner: TDXTextureImage);
    destructor Destroy; override;
    procedure Assign(Source: TDXTextureImage);
    procedure Clear;
    procedure SetImage(ImageType: TDXTextureImageType; Width, Height, BitCount, WidthBytes, NextLine: Integer;
      PBits, TopPBits: Pointer; Size: Integer; AutoFree: Boolean);
    procedure SetSize(ImageType: TDXTextureImageType; Width, Height, BitCount, WidthBytes: Integer);
    procedure LoadFromFile(const FileName: string);
    procedure LoadFromStream(Stream: TStream);
    procedure SaveToFile(const FileName: string);
    procedure SaveToStream(Stream: TStream);
    function EncodeColor(R, G, B, A: Byte): DWORD;
    function PaletteIndex(R, G, B: Byte): DWORD;
    class procedure RegisterLoadFunc(LoadFunc: TDXTextureImageLoadFunc);
    class procedure UnRegisterLoadFunc(LoadFunc: TDXTextureImageLoadFunc);
    property BitCount: Integer read FBitCount;
    property PackedPixelOrder: Boolean read FPackedPixelOrder write FPackedPixelOrder;
    property Height: Integer read FHeight;
    property ImageType: TDXTextureImageType read FImageType;
    property ImageGroupType: DWORD read FImageGroupType write FImageGroupType;
    property ImageID: DWORD read FImageID write FImageID;
    property ImageName: string read FImageName write FImageName;
    property NextLine: Integer read FNextLine;
    property PBits: Pointer read FPBits;
    property Pixels[x, y: Integer]: DWORD read GetPixel write SetPixel;
    property ScanLine[y: Integer]: Pointer read GetScanLine;
    property Size: Integer read FSize;
    property SubGroupImageCount[GroupTypeID: DWORD]: Integer read GetSubGroupImageCount;
    property SubGroupImages[GroupTypeID: DWORD; Index: Integer]: TDXTextureImage read GetSubGroupImage;
    property SubImageCount: Integer read GetSubImageCount;
    property SubImages[Index: Integer]: TDXTextureImage read GetSubImage;
    property TopPBits: Pointer read FTopPBits;
    property Transparent: Boolean read FTransparent write FTransparent;
    property TransparentColor: DWORD read FTransparentColor write FTransparentColor;
    property Width: Integer read FWidth;
    property WidthBytes: Integer read FWidthBytes;
  end;

function dxtMakeChannel(Mask: DWORD; indexed: Boolean): TDXTextureImageChannel;
function dxtEncodeChannel(const Channel: TDXTextureImageChannel; c: DWORD): DWORD;
function dxtDecodeChannel(const Channel: TDXTextureImageChannel; c: DWORD): DWORD;

implementation

function GetWidthBytes(Width, BitCount: Integer): Integer;
begin
  Result := (((Width*BitCount)+31) div 32)*4;
end;

function dxtEncodeChannel(const Channel: TDXTextureImageChannel; c: DWORD): DWORD;
begin
  Result := ((c shl Channel._rshift) shr Channel._lshift) and Channel.Mask;
end;

function dxtDecodeChannel(const Channel: TDXTextureImageChannel; c: DWORD): DWORD;
begin
  Result := ((c  and Channel.Mask) shr Channel._rshift) shl Channel._lshift;
  Result := Result or (Result shr Channel._BitCount2);
end;

function dxtMakeChannel(Mask: DWORD; indexed: Boolean): TDXTextureImageChannel;

  function GetMaskBitCount(b: Integer): Integer;
  var
    i: Integer;
  begin
    i := 0;
    while (i<31) and (((1 shl i) and b)=0) do Inc(i);

    Result := 0;
    while ((1 shl i) and b)<>0 do
    begin
      Inc(i);
      Inc(Result);
    end;
  end;

  function GetBitCount2(b: Integer): Integer;
  begin
    Result := 0;
    while (Result<31) and (((1 shl Result) and b)=0) do Inc(Result);
  end;

begin
  Result.BitCount := GetMaskBitCount(Mask);
  Result.Mask := Mask;

  if indexed then
  begin
    Result._rshift := GetBitCount2(Mask);
    Result._lshift := 0;
    Result._Mask2 := 1 shl Result.BitCount-1;
    Result._BitCount2 := 0;
  end else
  begin
    Result._rshift := GetBitCount2(Mask)-(8-Result.BitCount);
    if Result._rshift<0 then
    begin
      Result._lshift := -Result._rshift;
      Result._rshift := 0;
    end else
      Result._lshift := 0;
    Result._Mask2 := (1 shl Result.BitCount-1) shl (8-Result.BitCount);
    Result._BitCount2 := 8-Result.BitCount;
  end;
end;

{  TDXTextureImage  }

var
  _DXTextureImageLoadFuncList: TList;

procedure DXTextureImage_LoadDXTextureImageFunc(Stream: TStream; Image: TDXTextureImage); forward;
procedure DXTextureImage_LoadBitmapFunc(Stream: TStream; Image: TDXTextureImage); forward;

function DXTextureImageLoadFuncList: TList;
begin
  if _DXTextureImageLoadFuncList=nil then
  begin
    _DXTextureImageLoadFuncList := TList.Create;
    _DXTextureImageLoadFuncList.Add(@DXTextureImage_LoadDXTextureImageFunc);
    _DXTextureImageLoadFuncList.Add(@DXTextureImage_LoadBitmapFunc);
  end;
  Result := _DXTextureImageLoadFuncList;
end;

class procedure TDXTextureImage.RegisterLoadFunc(LoadFunc: TDXTextureImageLoadFunc);
begin
  if DXTextureImageLoadFuncList.IndexOf(@LoadFunc)=-1 then
    DXTextureImageLoadFuncList.Add(@LoadFunc);
end;

class procedure TDXTextureImage.UnRegisterLoadFunc(LoadFunc: TDXTextureImageLoadFunc);
begin
  DXTextureImageLoadFuncList.Remove(@LoadFunc);
end;

constructor TDXTextureImage.Create;
begin
  inherited Create;
  FSubImage := TList.Create;
end;

constructor TDXTextureImage.CreateSub(AOwner: TDXTextureImage);
begin
  Create;

  FOwner := AOwner;
  try           
    FOwner.FSubImage.Add(Self);
  except
    FOwner := nil;
    raise;
  end;
end;

destructor TDXTextureImage.Destroy;
begin
  Clear;
  FSubImage.Free;
  if FOwner<>nil then
    FOwner.FSubImage.Remove(Self);
  inherited Destroy;
end;

procedure TDXTextureImage.Assign(Source: TDXTextureImage);
var
  y: Integer;
begin
  SetSize(Source.ImageType, Source.Width, Source.Height, Source.BitCount, Source.WidthBytes);

  idx_index := Source.idx_index;
  idx_alpha := Source.idx_alpha;
  idx_palette := Source.idx_palette;

  rgb_red := Source.rgb_red;
  rgb_green := Source.rgb_green;
  rgb_blue := Source.rgb_blue;
  rgb_alpha := Source.rgb_alpha;

  for y:=0 to Height-1 do
    Move(Source.ScanLine[y]^, ScanLine[y]^, WidthBytes);

  Transparent := Source.Transparent;
  TransparentColor := Source.TransparentColor;
  ImageGroupType := Source.ImageGroupType;
  ImageID := Source.ImageID;
  ImageName := Source.ImageName;
end;

procedure TDXTextureImage.ClearImage;
begin
  if FAutoFreeImage then
    FreeMem(FPBits);

  FImageType := DXTextureImageType_PaletteIndexedColor;
  FWidth := 0;
  FHeight := 0;
  FBitCount := 0;
  FWidthBytes := 0;
  FNextLine := 0;
  FSize := 0;
  FPBits := nil;
  FTopPBits := nil;
  FAutoFreeImage := False;
end;

procedure TDXTextureImage.Clear;
begin
  ClearImage;

  while SubImageCount>0 do
    SubImages[SubImageCount-1].Free;

  FImageGroupType := 0;
  FImageID := 0;
  FImageName := '';

  FTransparent := False;
  FTransparentColor := 0;

  FillChar(idx_index, SizeOf(idx_index), 0);
  FillChar(idx_alpha, SizeOf(idx_alpha), 0);
  FillChar(idx_palette, SizeOf(idx_palette), 0);
  FillChar(rgb_red, SizeOf(rgb_red), 0);
  FillChar(rgb_green, SizeOf(rgb_green), 0);
  FillChar(rgb_blue, SizeOf(rgb_blue), 0);
  FillChar(rgb_alpha, SizeOf(rgb_alpha), 0);
end;

procedure TDXTextureImage.SetImage(ImageType: TDXTextureImageType; Width, Height, BitCount, WidthBytes, NextLine: Integer;
  PBits, TopPBits: Pointer; Size: Integer; AutoFree: Boolean);
begin
  ClearImage;

  FAutoFreeImage := AutoFree;
  FImageType := ImageType;
  FWidth := Width;
  FHeight := Height;
  FBitCount := BitCount;
  FWidthBytes := WidthBytes;
  FNextLine := NextLine;
  FSize := Size;
  FPBits := PBits;
  FTopPBits := TopPBits;
end;

procedure TDXTextureImage.SetSize(ImageType: TDXTextureImageType; Width, Height, BitCount, WidthBytes: Integer);
var
  APBits: Pointer;
begin
  ClearImage;

  if WidthBytes=0 then
    WidthBytes := GetWidthBytes(Width, BitCount);

  GetMem(APBits, WidthBytes*Height);
  SetImage(ImageType, Width, Height, BitCount, WidthBytes, WidthBytes, APBits, APBits, WidthBytes*Height, True);
end;

function TDXTextureImage.GetScanLine(y: Integer): Pointer;
begin
  Result := Pointer(Integer(FTopPBits)+FNextLine*y);
end;

function TDXTextureImage.GetSubGroupImageCount(GroupTypeID: DWORD): Integer;
var
  i: Integer;
begin
  Result := 0;
  for i:=0 to SubImageCount-1 do
    if SubImages[i].ImageGroupType=GroupTypeID then
      Inc(Result);
end;

function TDXTextureImage.GetSubGroupImage(GroupTypeID: DWORD; Index: Integer): TDXTextureImage;
var
  i, j: Integer;
begin
  j := 0;
  for i:=0 to SubImageCount-1 do
    if SubImages[i].ImageGroupType=GroupTypeID then
    begin
      if j=Index then
      begin
        Result := SubImages[i];
        Exit;
      end;

      Inc(j);
    end;

  Result := nil;
  SubImages[-1];
end;

function TDXTextureImage.GetSubImageCount: Integer;
begin
  Result := FSubImage.Count;
end;

function TDXTextureImage.GetSubImage(Index: Integer): TDXTextureImage;
begin
  Result := FSubImage[Index];
end;

function TDXTextureImage.EncodeColor(R, G, B, A: Byte): DWORD;
begin
  if ImageType=DXTextureImageType_PaletteIndexedColor then
  begin
    Result := dxtEncodeChannel(idx_index, PaletteIndex(R, G, B)) or
      dxtEncodeChannel(idx_alpha, A);
  end else
  begin
    Result := dxtEncodeChannel(rgb_red, R) or
      dxtEncodeChannel(rgb_green, G) or
      dxtEncodeChannel(rgb_blue, B) or
      dxtEncodeChannel(rgb_alpha, A);
 end;
end;

function TDXTextureImage.PaletteIndex(R, G, B: Byte): DWORD;
var
  i, d, d2: Integer;
begin
  Result := 0;
  if ImageType=DXTextureImageType_PaletteIndexedColor then
  begin
    d := MaxInt;
    for i:=0 to (1 shl idx_index.BitCount)-1 do
      with idx_palette[i] do
      begin
        d2 := Abs((peRed-R))*Abs((peRed-R)) + Abs((peGreen-G))*Abs((peGreen-G)) + Abs((peBlue-B))*Abs((peBlue-B));
        if d>d2 then
        begin
          d := d2;
          Result := i;
        end;
      end;
  end;
end;

const
  Mask1: array[0..7] of DWORD= (1, 2, 4, 8, 16, 32, 64, 128);
  Mask2: array[0..3] of DWORD= (3, 12, 48, 192);
  Mask4: array[0..1] of DWORD= ($0F, $F0);

  Shift1: array[0..7] of DWORD= (0, 1, 2, 3, 4, 5, 6, 7);
  Shift2: array[0..3] of DWORD= (0, 2, 4, 6);
  Shift4: array[0..1] of DWORD= (0, 4);

type
  PByte3 = ^TByte3;
  TByte3 = array[0..2] of Byte;

function TDXTextureImage.GetPixel(x, y: Integer): DWORD;
begin
  Result := 0;
  if (x>=0) and (x<FWidth) and (y>=0) and (y<FHeight) then
  begin
    case FBitCount of
      1 : begin