importlbas.pas

N年前有个法国小组用Delphi写了一个2D网游（AD&D类型）

unit ImportLBAs;

{
 projet ADK-ISO (c)2002-2003 Paul TOTH <[e-mail]>

 http://www.web-synergy.net/naug-land/

}

interface

uses
  ADKImages,ImageTrees, ADKDepth,
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, StdCtrls;

type
  TImportLBA = class(TForm)
    Button1: TButton;
    Label1: TLabel;
    Animate1: TAnimate;
    ProgressBar1: TProgressBar;
    ProgressBar2: TProgressBar;
    ProgressBar3: TProgressBar;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    mem:TMemoryStream;
    bmp:TBitmap;
    fCancel:boolean;
    fFileName:string;
    fImageTree:TImageTree;
    procedure WMUser(Var Msg:TMessage); message WM_USER;
    procedure Convert8bit(Node:TTreeNode; id:integer; bmp:TBitmap; const Pos:TPoint);
  public
    { Public declarations }
  end;

var
  ImportLBA: TImportLBA;

procedure LBAImport(AFileName:string; AImageTree:TImageTree);

implementation

uses ADKUtils;

{$R *.dfm}

procedure LBAImport(AFileName:string; AImageTree:TImageTree);
begin
 if ImportLBA=nil then ImportLBA:=TImportLBA.Create(Application);
 ImportLBA.fFileName:=AFileName;
 ImportLBA.fImageTree:=AImageTree;
 PostMessage(ImportLBA.Handle,WM_USER,0,0);
 ImportLBA.ShowModal;
end;

procedure TImportLBA.Button1Click(Sender: TObject);
begin
 fCancel:=True;
end;

procedure TImportLBA.WMUser(Var Msg:TMessage);
type
 TDrawMode = (dmOpaque, DmNormal, DmAdd, DmAlpha, DmSub);
var
 lba:TFileStream;
 s:string;
 l1,count1:integer;
 l2,count2:integer;
 l3,count3:integer;
 item:integer;
 p:TPoint;
 bi:TBitmapInfoHeader;
 bf:TBitmapFileHeader;
 extra:cardinal;
 dm:TDrawMode;
 ma:byte;
 ts:boolean;
 cl:TColor;
 anim:boolean;
 id:integer;

 n1,n2:TTreeNode;

begin
 fCancel:=False;

 lba:=TFileStream.Create(fFileName,fmOpenRead or fmShareDenyNone);
 try
  if getInteger(lba)<>$3D52 then Error('Biblioth鑡ue graphique invalide');

  s:=ChangeFileExt(fFileName,'.IML');
  CreateEmptyLib(s);
  fImageTree.ImageLib.LoadFromFile(s,False);
  fImageTree.TreeView.Items.BeginUpdate;
  fImageTree.TreeView.Items.Clear;

  lba.Seek(getInteger(lba)*20{SizeOf(TPosRecord)},soFromCurrent);
  Caption:=getString(lba); // Group
  getString(lba); // comment
  count1:=getInteger(lba); // nombre d'items
  ProgressBar1.Position:=0;
  ProgressBar1.Max:=count1;
  //setlength(tree,count1);
  for l1:=0 to count1-1 do begin
   ProgressBar1.StepIt;
   item:=getInteger(lba);
   //tree[l1].anim:=(item=$39C7);
   anim:=(item=$39C7);
   case item of
    $2F9C,$39C7: begin { TListOfStockage, TListOfStock8Anim }
     if getInteger(lba)<>$8E03 then error('Erreur de lecture de la biblioth鑡ue graphique');
     {tree[l1].ident:=}getInteger(lba); // Ident
     n1:=fImageTree.NewFolder(nil,getString(lba));
     //getString(lba); // Group //g0:=Dibs.AddGroup(getString(lba),0);
     getString(lba); // comment
     count2:=getInteger(lba);
     ProgressBar2.Position:=0;
     ProgressBar2.Max:=count2;
     //setlength(tree[l1].items,count2);
     for l2:=0 to count2-1 do begin
      ProgressBar2.StepIt;
      item:=getInteger(lba);
      case item of
       $5510,$3C7F: begin { TStockageListBitmaps, TStockageListAnim }
        if getInteger(lba)<>$8E03 then error('Erreur de lecture de la biblioth鑡ue graphique');
        {tree[l1].items[l2].ident:=}getInteger(lba); // Ident
        Label1.Caption:=getString(lba); // nom
        n2:=fImageTree.NewFolder(n1,Label1.Caption);
        //g1:=Dibs.AddGroup(Label1.Caption,g0);
        getString(lba); // comment
        count3:=getInteger(lba);
        ProgressBar3.Position:=0;
        ProgressBar3.Max:=count3;
        //setlength(tree[l1].items[l2].items,count3);
        for l3:=0 to count3-1 do begin
         Application.ProcessMessages;
         if fCancel then exit;
         ProgressBar3.StepIt;
         item:=getInteger(lba);
         case item of
          $1A57: begin { TBitmapItem }
           {tree[l1].items[l2].items[l3].ident:=}id:=getInteger(lba); // Ident
           //tree[l1].items[l2].items[l3].index:=Dibs.Count;
           lba.ReadBuffer(p,sizeof(p)); // Placement
           lba.Seek(2*SizeOf(Integer),soFromCurrent); // Reserved
           lba.ReadBuffer(bi,sizeof(bi));
           //if (l1=5)and(l2=0)and(l3=1) then
           // showmessage('c''est ici que 鏰 merde');
           if bi.biSize<>40 then error('erreur d''importation des dibs');
           extra:=0;
           if bi.biBitCount<=8 then begin
            extra:=4*(1 shl bi.biBitCount);
           end else begin
            if bi.biCompression=BI_BITFIELDS then extra:=3*4;
           end;
           // le DIB et la palette de couleur/le masque
           bf.bfType:=Ord('B') + Ord('M')*$100;
           bf.bfSize:=SizeOf(bf)+SizeOf(bi)+extra+bi.biSizeImage;
           bf.bfReserved1:=0;
           bf.bfReserved2:=0;
           bf.bfOffBits:=SizeOf(bf)+SizeOf(bi)+extra;
           mem.WriteBuffer(bf,sizeof(bf));
           mem.WriteBuffer(bi,sizeof(bi));
           mem.CopyFrom(lba,extra+bi.biSizeImage);

           lba.ReadBuffer(dm,SizeOf(dm)); // DrawMode
           lba.ReadBuffer(ma,SizeOf(ma)); // MasterAlpha
           lba.ReadBuffer(ts,SizeOf(ts)); // Transparent
           lba.ReadBuffer(cl,SizeOf(cl)); // Color

           if bi.biBitCount=8 then begin
            fImageTree.AddDIB(n2,IntToHex(id,8),TPalette32((@pchar(mem.Memory)[sizeof(bf)+sizeof(bi)])^),clYellow,bi.biWidth,bi.biHeight,@pchar(mem.Memory)[bf.bfOffBits],p);
           end else begin
            mem.Position:=0;
            bmp.LoadFromStream(mem);
            Convert8Bit(n2,id,bmp,p);
         //   bmp.SaveToFile(ExtractFilePath(fFileName)+IntToHex(id,8)+'.bmp');
            bmp.Dormant;
            bmp.FreeImage;
           end;

           mem.Clear;
          end;
          else error('Element graphique 3 inconnu '
                  +inttostr(l1)+'/'+inttostr(count1)+'-'
                  +inttostr(l2)+'/'+inttostr(count2)+'-'
                  +inttostr(l3)+'/'+inttostr(count3)+'-'
                  +'  $'+IntToHex(item,8));
         end;
        end; // l3
        lba.Seek(1,soFromCurrent); // UsePlacement
        if {tree[l1].}anim then begin
         lba.Seek(10,soFromCurrent); // animate, reserved 1&2, Options
        {
         lba.ReadBuffer(Fanimate, SizeOf(Fanimate));
         lba.ReadBuffer(FReserved1, SizeOf(FReserved1));
         lba.ReadBuffer(FReserved2, SizeOf(FReserved2));
         lba.ReadBuffer(FOptions, SizeOf(FOptions));
        }
        end;
       end;
       else error('Element graphique 2 inconnu '
                  +inttostr(l1)+'/'+inttostr(count1)+'-'
                  +inttostr(l2)+'/'+inttostr(count2)+'-'
                  +'  $'+IntToHex(item,8));
      end;
     end; // l2
     lba.Seek(2*SizeOf(Integer),soFromCurrent); // Reserved
     if {tree[l1].}anim then begin
      lba.ReadBuffer(p,sizeof(p)); // offset
      lba.Seek(1,soFromCurrent); // ZCorps
     end;
    end;
    else error('Element graphique 1 inconnu $'+IntToHex(item,8));
   end;
  end; // l1
  if lba.position<>lba.size then error('fin du flux non atteinte '+IntToStr(lba.position)+'/'+IntTostr(lba.size));
  //Dibs.Close;
  //SaveTree(dib);
 finally
  lba.Free;
  fImageTree.TreeView.Items.EndUpdate;
  ModalResult:=mrOK;
 end;

end;

procedure TImportLBA.Convert8bit(Node:TTreeNode; id:integer; bmp:TBitmap; const Pos:TPoint);
type
 TIntegers=array[word] of integer;
var
 pal:TPalette32;
 w,h,pitch:integer;
 dib:array of byte;
 z:integer;
 ccount:integer;
 p:^TIntegers;
 flags:array of array of boolean;

 function findColor(c:cardinal):integer;
 var
  i:integer;
  d,best:single;
 begin
  for i:=0 to ccount-1 do begin
   if pal[i]=c then begin
    result:=i;
    exit;
   end;
  end;
  if ccount<256 then begin
   pal[ccount]:=c;
   result:=ccount;
   inc(ccount);
   exit;
  end;
  result:=0;
  best:=DistanceColor(c,pal[0]);
  for i:=1 to 255 do begin
   d:=DistanceColor(c,pal[i]);
   if d<best then begin
    result:=i;
    best:=d;
   end;
  end;
 end;

 procedure check(x,y:integer);
 begin
  if flags[x,y] then exit;
  p:=bmp.ScanLine[h-y-1];
  dib[x+pitch*y]:=findColor(p[x] and $FFFFFF);
  p[x]:=0;
  flags[x,y]:=true;
 end;

 function scan(x1,y1,x2,y2,z:integer):boolean;
 var
  mx,my:integer;
 begin
  if (x1>=x2)or(y1>=y2) then begin
   result:=false;
   exit;
  end;
  mx:=(x1+x2+1) div 2;
  my:=(y1+y2+1) div 2;
  if z=0 then begin
   check(x1,y1);
   check(mx,y1);
   check(x2,y1);
   check(x1,my);
   check(mx,my);
   check(x2,my);
   check(x1,y2);
   check(mx,y2);
   check(x2,y2);
   result:=true;
   exit;
  end;
  result:=false;
  if (mx>x1+1)or(my>y1+1) then if scan(x1,y1,mx,my,z-1) then result:=true;
  if scan(mx,y1,x2,my,z-1) then result:=true;
  if scan(x1,my,mx,y2,z-1) then result:=true;
  if scan(mx,my,x2,y2,z-1) then result:=true;
 end;

begin
 w:=bmp.Width;
 h:=bmp.Height;
 pitch:=(w+3) and (not 3);
 setlength(dib,h*pitch);
 fillchar(pal,sizeof(pal),0);

 bmp.PixelFormat:=pf32bit;

 ccount:=0;
 setlength(flags,w,h);
 z:=0;
 while scan(0,0,w-1,h-1,z) do begin
//bmp.saveToFile(inttohex(id,8)+'-'+inttostr(z)+'.bmp');
  inc(z);
 end;
 fImageTree.AddDIB(node,IntToHex(id,8),pal,clYellow,w,h,@dib[0],Pos);
end;

procedure TImportLBA.FormCreate(Sender: TObject);
begin
 mem:=TMemoryStream.Create;
 bmp:=TBitmap.Create;
end;

procedure TImportLBA.FormDestroy(Sender: TObject);
begin
 mem.Free;
 bmp.Free;
end;

end.