wil.pas.svn-base

Asphyre的传奇WIL,可以用Asphyre来写传奇了

unit WIL;

interface

uses
  Windows, Classes, Graphics, SysUtils, Dialogs,
  wmUtil, HUtil32,
  Direct3D, DIB, AsphyreDef, AsphyreDevices, AsphyreImages, DXTextures;

const
   UseDIBSurface : Boolean = FALSE;
   BoWilNoCache : Boolean = FALSE;

   WilVersion: integer = 20020;
   WixVersion: integer = 20021;

   WilTaiwan = 20030;
   WixTaiwan = 20031;

   WilChinesse = 20040;
   WixChinesse = 20041;

   WilEnglish = 20050;
   WixEnglish = 20051;

   WilMagicCode = $C02a1173;
   WixMagicCode = $B13a11F0;


type
   TLibType = (ltLoadBmp, ltLoadMemory, ltLoadMunual, ltUseCache);
   TInternationalVersion = (ivKorean, ivTaiwan, ivChinesse, ivEnglish);

   TBmpImage = record
      bmp: TBitmap;
      LatestTime: integer;
   end;
   PTBmpImage = ^TBmpImage;

   TBmpImageArr = array[0..MaxListSize div 4] of TBmpImage;
   TDxImageArr = array[0..MaxListSize div 4] of TDxImage;
   PTBmpImageArr = ^TBmpImageArr;
   PTDxImageArr = ^TDxImageArr;

   TWMImages = class (TComponent)
   private
      FFileName: string;
      FImageCount: integer;
      FLibType: TLibType;
      FDxDevice: TAsphyreDevice;

      FMaxMemorySize: integer;
      OldVersionWil: Boolean;
      procedure LoadAllData;
      procedure LoadAllDataBmp;
      procedure LoadIndex (idxfile: string);
      procedure LoadDxImage (position: integer; pdximg: PTDxImage);
      procedure LoadBmpImage (position: integer; pbmpimg: PTBmpImage);
      procedure FreeOldMemorys;
      function  FGetImageSurface (index: integer): TAsphyreImage;
      procedure FSetDxDevice (fdd: TAsphyreDevice);
      procedure FreeOldBmps;
      function  FGetImageBitmap (index: integer): TBitmap;
   protected
      //MemorySize: integer;
      lsDib: TDib;
      memchecktime: longword;
   public
      ImgArr: PTDxImageArr;
      BmpArr: PTBmpImageArr;
      IndexList: TList;
      //BmpList: TList;
      Stream: TFileStream;
      //MainSurfacePalette: TDirectDrawPalette;
      MainPalette: TRgbQuads;
      InternationalVersion: TInternationalVersion;

      constructor Create (AOwner: TComponent); override;
      destructor Destroy; override;

      procedure Initialize;
      procedure Finalize;
      procedure ClearCache;
      procedure LoadPalette;
      procedure FreeBitmap (index: integer);
      function  GetImage (index: integer; var px, py: integer): TAsphyreImage;
      function  GetCachedImage (index: integer; var px, py: integer): TAsphyreImage;
      function  GetCachedSurface (index: integer): TAsphyreImage;
      function  GetCachedBitmap (index: integer): TBitmap;
      procedure DrawZoom (paper: TCanvas; x, y, index: integer; zoom: Real);
      procedure DrawZoomEx (paper: TCanvas; x, y, index: integer; zoom: Real; leftzero: Boolean);
      property Images[index: integer]: TAsphyreImage read FGetImageSurface;
    	property Bitmaps[Index: Integer]: TBitmap read FGetImageBitmap;
   published
      property FileName: string read FFileName write FFileName;
      property ImageCount: integer read FImageCount;
      property DxDxDevice: TAsphyreDevice read FDxDevice write FSetDxDevice;
      property LibType: TLibType read FLibType write FLibType;
      property MaxMemorySize: integer read FMaxMemorySize write FMaxMemorySize;
   end;

function TDXDrawRGBQuadsToPaletteEntries(const RGBQuads: TRGBQuads; AllowPalette256: Boolean): TPaletteEntries;

procedure Register;


implementation

//uses
//   ClMain;  //唱吝俊 瘤匡 巴.

procedure Register;
begin
   RegisterComponents('Zura', [TWmImages]);
end;

constructor TWMImages.Create (AOwner: TComponent);
begin
   inherited Create (AOwner);
   FFileName := '';
   FLibType := ltLoadBmp;
   FImageCount := 0;
   //MemorySize := 0;
   FMaxMemorySize := 1024*1000; //1M

   FDxDevice := nil;
   Stream := nil;
   ImgArr := nil;
   BmpArr := nil;
   IndexList := TList.Create;
   lsDib := TDib.Create;
   lsDib.BitCount := 8;
   //BmpList := TList.Create;  //Bmp侩栏肺 荤侩且 锭巩 荤侩

   memchecktime := GetTickCount;
   OldVersionWil := FALSE;
   InternationalVersion := ivKorean;
end;

destructor TWMImages.Destroy;
begin
   IndexList.Free;
//   BmpList.Free;
   if Stream <> nil then Stream.Free;
   lsDib.Free;
   inherited Destroy;
end;

procedure TWMImages.Initialize;
var
   idxfile: string;
   headerEx: TWMImageHeaderEx;
begin
   if not (csDesigning in ComponentState) then begin
      if FFileName = '' then begin
         raise Exception.Create ('FileName not assigned..');
         exit;
      end;
      if (LibType <> ltLoadBmp) and (FDxDevice = nil) then begin
         raise Exception.Create ('AsphyreDevice not assigned..');
         exit;
      end;
      if FileExists (FFileName) then begin
         if Stream = nil then
            Stream := TFileStream.Create (FFileName, fmOpenRead or fmShareDenyNone);
         Stream.Read (headerex, sizeof(TWMImageHeaderex));

         case InternationalVersion of
            //ivKorean: wilv := WilVersion;
            ivTaiwan:
               begin
                  WilVersion := WilTaiwan;
                  WixVersion := WixTaiwan;
               end;
            ivChinesse:
               begin
                  WilVersion := WilChinesse;
                  WixVersion := WixChinesse;
               end;
            ivEnglish:
               begin
                  WilVersion := WilEnglish;
                  WixVersion := WixEnglish;
               end;
         end;
         if longword(headerex.VersionInfo) <> longword(WilVersion + headerex.ImageCount) xor WilMagicCode then begin //捞傈 滚傈 牢 版快
            OldVersionWil := TRUE;
            Stream.Seek (- sizeof(integer), soFromCurrent);
         end;

         FImageCount := headerex.ImageCount;

         if LibType = ltLoadBmp then begin
            BmpArr := AllocMem (sizeof(TBmpImage) * FImageCount);
            if BmpArr = nil then
               raise Exception.Create (self.Name + ' BmpArr = nil');
         end else begin
            ImgArr := AllocMem (sizeof(TDxImage) * FImageCount);
            if ImgArr = nil then

               raise Exception.Create (self.Name + ' ImgArr = nil');
         end;

         idxfile := ExtractFilePath(FFileName) + ExtractFileNameOnly(FFileName) + '.WIX';
         LoadPalette;
         if LibType = ltLoadMemory then
            LoadAllData
         else begin
            LoadIndex (idxfile);
         end;

      end else begin
         MessageDlg (FFileName + ' Cannot find file.', mtWarning, [mbOk], 0);
      end;
   end;
end;

procedure TWMImages.Finalize;
var
   i: integer;
begin
  if ImgArr <> nil then begin
    for i:=0 to FImageCount-1 do begin
      if ImgArr[i].Surface <> nil then begin
        ImgArr[i].Surface.Free;
        ImgArr[i].Surface := nil;
      end;
    end;
  end;
  if Stream <> nil then begin
    Stream.Free;
    Stream := nil;
  end;
end;

function TDXDrawRGBQuadsToPaletteEntries(const RGBQuads: TRGBQuads;
  AllowPalette256: Boolean): TPaletteEntries;
var
  Entries: TPaletteEntries;
  dc: THandle;
  i: Integer;
begin
  Result := RGBQuadsToPaletteEntries(RGBQuads);

  if not AllowPalette256 then
  begin
    dc := GetDC(0);
    GetSystemPaletteEntries(dc, 0, 256, Entries);
    ReleaseDC(0, dc);

    for i:=0 to 9 do
      Result[i] := Entries[i];

    for i:=256-10 to 255 do
      Result[i] := Entries[i];
  end;

  for i:=0 to 255 do
    Result[i].peFlags := D3DPAL_READONLY;
end;

//Cache绝捞 茄波锅俊 肺爹窃.
procedure TWMImages.LoadAllData;
var
   i: integer;
   imgi: TWMImageInfo;
   imgiEx: TWMImageInfoEx;
   dib: TDIB;
   dximg: TDxImage;
begin
   dib := TDIB.Create;
   for i:=0 to FImageCount-1 do begin
      if OldVersionWil then begin
         Stream.Read (imgi, sizeof(TWMImageInfo) - 4);

         dib.Width := imgi.Width;
         dib.Height := imgi.Height;
         dib.ColorTable := MainPalette;
         dib.UpdatePalette;
         Stream.Read (dib.PBits^, imgi.Width * imgi.Height);

         dximg.px := imgi.px;
         dximg.py := imgi.py;
         dximg.surface := TAsphyreImage.Create;
         dximg.surface.Quality      := aqLow;
         dximg.surface.AlphaLevel   := alNone;
         dximg.surface.PatternSize  := Point(imgi.Width, imgi.Height);
         dximg.surface.Size         := Point(256, 256);//TextureSize;
         dximg.surface.VisibleSize  := Point(imgi.Width, imgi.Height);
         {dximg.surface := TDirectDrawSurface.Create (FDDraw);
         dximg.surface.SystemMemory := TRUE;
         dximg.surface.SetSize (imgi.Width, imgi.Height);
         dximg.surface.Canvas.Draw (0, 0, dib);
         dximg.surface.Canvas.Release;}
         dib.Clear; //FreeImage;

         //dximg.surface.TransparentColor := 0;
         ImgArr[i] := dximg;
      end else begin
         Stream.Read (imgiex, sizeof(TWMImageInfoEx) - 4);

         dib.Width := imgiex.Width;
         dib.Height := imgiex.Height;
         dib.ColorTable := MainPalette;
         dib.UpdatePalette;
         Stream.Read (dib.PBits^, imgiex.Width * imgiex.Height);

         dximg.px := imgiex.px;
         dximg.py := imgiex.py;
         {dximg.surface := TDirectDrawSurface.Create (FDDraw);
         dximg.surface.SystemMemory := TRUE;
         dximg.surface.SetSize (imgiex.Width, imgiex.Height);
         dximg.surface.Canvas.Draw (0, 0, dib);
         dximg.surface.Canvas.Release;}
         dib.Clear; //FreeImage;

         //dximg.surface.TransparentColor := 0;
         ImgArr[i] := dximg;
      end;
   end;
   dib.Free;
end;

procedure TWMImages.LoadPalette;
var
   Entries: TPaletteEntries;
begin
   if OldVersionWil then
      Stream.Seek (sizeof(TWMImageHeader), 0)
   else
      Stream.Seek (sizeof(TWMImageHeaderEx), 0);

   Stream.Read (MainPalette, sizeof(TRgbQuad) * 256); //迫贰飘

   //Entries := TDXDrawRGBQuadsToPaletteEntries (MainPalette, TRUE);
   //MainSurfacePalette := TDirectDrawPalette.Create (FDDraw);
   ////MainSurfacePalette.SetEntries(0, 256, Entries);
   //MainSurfacePalette.CreatePalette(DDPCAPS_8BIT, Entries);
end;

//Cache绝捞 茄波锅俊 Bmp肺 肺爹窃.
procedure TWMImages.LoadAllDataBmp;
var
   i: integer;
   pbuf: PByte;
   imgi: TWMImageInfo;
   bmp: TBitmap;
begin
{   GetMem (pbuf, 1024*768);  //傍侩 滚欺积己, 漂喊茄 捞蜡啊 乐澜
   Stream.Seek (sizeof(TWMImageHeader), 0);
   Stream.Read (MainPalette, sizeof(TRgbQuad) * 256); //迫贰飘
   for i:=0 to ImageCount-1 do begin
      Stream.Read (imgi, sizeof(TWMImageInfo)-4);
      Stream.Read (pbuf^, imgi.Width * imgi.Height);
      bmp := MakeBmp (imgi.Width, imgi.Height, pbuf, MainPalette);
      BmpList.Add (bmp);     //BMP府胶飘甫 悼矫俊 包府.. (弊府靛俊 弊府扁侩)
   end;
   FreeMem (pbuf); }
end;

procedure TWMImages.LoadIndex (idxfile: string);
var
   fhandle, i, value: integer;
   header: TWMIndexHeader;
   headerex: TWMIndexHeaderex;
   pidx: PTWMIndexInfo;
   pvalue: PInteger;
begin
   indexlist.Clear;
   if FileExists (idxfile) then begin
      fhandle := FileOpen (idxfile, fmOpenRead or fmShareDenyNone);
      if fhandle > 0 then begin
         if OldVersionWil then begin
            FileRead (fhandle, header, sizeof(TWMIndexHeader));

            GetMem (pvalue, 4*header.IndexCount);
            FileRead (fhandle, pvalue^, 4*header.IndexCount);
            for i:=0 to header.IndexCount-1 do begin
               new (pidx);
               value := PInteger(integer(pvalue) + 4*i)^;
               IndexList.Add (pointer(value));
            end;
         end else begin
            FileRead (fhandle, headerex, sizeof(TWMIndexHeaderEx));

            GetMem (pvalue, 4*headerex.IndexCount);
            FileRead (fhandle, pvalue^, 4*headerex.IndexCount);
            for i:=0 to headerex.IndexCount-1 do begin
               new (pidx);
               value := PInteger(integer(pvalue) + 4*i)^;
               IndexList.Add (pointer(value));
            end;
         end;
         FreeMem (pvalue);
         FileClose (fhandle);
      end;
   end;
end;

{----------------- Private Variables ---------------------}

function  TWMImages.FGetImageSurface (index: integer): TAsphyreImage;
begin
   Result := nil;
   if LibType = ltUseCache then begin
      Result := GetCachedSurface (index);
   end else
      if LibType = ltLoadMemory then begin
         if (index >= 0) and (index < ImageCount) then
            Result := ImgArr[index].Surface;
      end;
         
end;

function  TWMImages.FGetImageBitmap (index: integer): TBitmap;
begin
   if LibType <> ltLoadBmp then exit;
   Result := GetCachedBitmap (index);
   {if index in [0..BmpList.Count-1] then begin
      Result := TBitmap (BmpList[index]);
   end else
      Result := nil;}
end;

procedure TWMImages.FSetDxDevice (fdd: TAsphyreDevice);
begin
   FDxDevice := fdd;
end;

// *** DirectDrawSurface Functions

procedure TWMImages.LoadDxImage (position: integer; pdximg: PTDxImage);