src/editor/f_addresource_texture.pas

   1 unit f_addresource_texture;
   2
   3 {$INCLUDE ../shared/a_modes.inc}
   4
   5 interface
   6
   7 uses
   8   LCLIntf, LCLType, SysUtils, Variants, Classes,
   9   Graphics, Controls, Forms, Dialogs, f_addresource,
  10   StdCtrls, ExtCtrls, utils, Imaging, ImagingTypes, ImagingUtility;
  11
  12 type
  13
  14   { TAddTextureForm }
  15
  16   TAddTextureForm = class (TAddResourceForm)
  17     lStats: TLabel;
  18     PanelTexPreview: TPanel;
  19     iPreview: TImage;
  20     eTextureName: TEdit;
  21     bAddTexture: TButton;
  22     bClose: TButton;
  23     bAddClose: TButton;
  24
  25     procedure FormActivate(Sender: TObject);
  26     procedure lbResourcesListClick(Sender: TObject);
  27     procedure eTextureNameChange(Sender: TObject);
  28     procedure cbWADListChange(Sender: TObject);
  29     procedure cbSectionsListChange(Sender: TObject);
  30     procedure bCloseClick(Sender: TObject);
  31     procedure bAddTextureClick(Sender: TObject);
  32     procedure bAddCloseClick(Sender: TObject);
  33
  34   private
  35     {}
  36   public
  37     {}
  38   end;
  39
  40 var
  41   AddTextureForm: TAddTextureForm;
  42   NumFrames: Integer = 0;
  43
  44 function IsAnim(Res: String): Boolean;
  45 function GetFrame(Res: String; var Data: Pointer; var DataLen: Integer;
  46                   var Width, Height: Word): Boolean;
  47
  48 implementation
  49
  50 uses
  51   BinEditor, WADEDITOR, WADSTRUCT, f_main, g_textures, CONFIG, g_map,
  52   g_language;
  53
  54 {$R *.lfm}
  55
  56 function IsAnim(Res: String): Boolean;
  57 var
  58   WAD:          TWADEditor_1;
  59   WADName:      String;
  60   SectionName:  String;
  61   ResourceName: String;
  62   Data:         Pointer;
  63   Size:         Integer;
  64   Sign:         Array [0..4] of Char;
  65   Sections,
  66   Resources:    SArray;
  67   a:            Integer;
  68   ok:           Boolean;
  69
  70 begin
  71   Result := False;
  72   Data := nil;
  73   Size := 0;
  74
  75 // Читаем файл и ресурс в нем:
  76   g_ProcessResourceStr(Res, WADName, SectionName, ResourceName);
  77
  78   WAD := TWADEditor_1.Create();
  79
  80   if (not WAD.ReadFile(WADName)) or
  81      (not WAD.GetResource(utf2win(SectionName), utf2win(ResourceName), Data, Size)) then
  82   begin
  83     WAD.Free();
  84     Exit;
  85   end;
  86
  87   WAD.FreeWAD();
  88
  89 // Проверка сигнатуры. Если есть - это WAD внутри WAD:
  90   CopyMemory(@Sign[0], Data, 5);
  91
  92   if not (Sign = DFWAD_SIGNATURE) then
  93   begin
  94     WAD.Free();
  95     FreeMem(Data);
  96     Exit;
  97   end;
  98
  99 // Пробуем прочитать данные:
 100   if not WAD.ReadMemory(Data, Size) then
 101   begin
 102     WAD.Free();
 103     FreeMem(Data);
 104     Exit;
 105   end;
 106
 107   FreeMem(Data);
 108
 109 // Читаем секции:
 110   Sections := WAD.GetSectionList();
 111
 112   if Sections = nil then
 113   begin
 114     WAD.Free();
 115     Exit;
 116   end;
 117
 118 // Ищем в секциях "TEXT":
 119   ok := False;
 120   for a := 0 to High(Sections) do
 121     if Sections[a] = 'TEXT' then
 122     begin
 123       ok := True;
 124       Break;
 125     end;
 126
 127 // Ищем в секциях лист текстур - "TEXTURES":
 128   for a := 0 to High(Sections) do
 129     if Sections[a] = 'TEXTURES' then
 130     begin
 131       ok := ok and True;
 132       Break;
 133     end;
 134
 135   if not ok then
 136   begin
 137     WAD.Free();
 138     Exit;
 139   end;
 140
 141 // Получаем ресурсы секции "TEXT":
 142   Resources := WAD.GetResourcesList('TEXT');
 143
 144   if Resources = nil then
 145   begin
 146     WAD.Free();
 147     Exit;
 148   end;
 149
 150 // Ищем в них описание анимации - "ANIM":
 151   ok := False;
 152   for a := 0 to High(Resources) do
 153     if Resources[a] = 'ANIM' then
 154     begin
 155       ok := True;
 156       Break;
 157     end;
 158
 159   WAD.Free();
 160
 161 // Если все получилось, то это аним. текстура:
 162   Result := ok;
 163 end;
 164
 165 function GetFrame(Res: String; var Data: Pointer; var DataLen: Integer;
 166                   var Width, Height: Word): Boolean;
 167 var
 168   AnimWAD:      Pointer;
 169   WAD:          TWADEditor_1;
 170   WADName:      String;
 171   SectionName:  String;
 172   ResourceName: String;
 173   Len:          Integer;
 174   config:       TConfig;
 175   TextData:     Pointer;
 176
 177 begin
 178   Result := False;
 179   AnimWAD := nil;
 180   Len := 0;
 181   TextData := nil;
 182
 183 // Читаем WAD:
 184   g_ProcessResourceStr(Res, WADName, SectionName, ResourceName);
 185
 186   WAD := TWADEditor_1.Create();
 187
 188   if not WAD.ReadFile(WADName) then
 189   begin
 190     WAD.Free();
 191     Exit;
 192   end;
 193
 194 // Читаем WAD-ресурс из WAD:
 195   if not WAD.GetResource(utf2win(SectionName), utf2win(ResourceName), AnimWAD, Len) then
 196   begin
 197     WAD.Free();
 198     Exit;
 199   end;
 200
 201   WAD.FreeWAD();
 202
 203 // Читаем WAD в WAD'е:
 204   if not WAD.ReadMemory(AnimWAD, Len) then
 205   begin
 206     FreeMem(AnimWAD);
 207     WAD.Free();
 208     Exit;
 209   end;
 210
 211 // Читаем описание анимации:
 212   if not WAD.GetResource('TEXT', 'ANIM', TextData, Len) then
 213   begin
 214     FreeMem(TextData);
 215     FreeMem(AnimWAD);
 216     WAD.Free();
 217     Exit;
 218   end;
 219
 220   config := TConfig.CreateMem(TextData, Len);
 221
 222 // Читаем ресурс - лист текстур:
 223   if not WAD.GetResource('TEXTURES', config.ReadStr('', 'resource', ''), Data, Len) then
 224   begin
 225     FreeMem(TextData);
 226     FreeMem(AnimWAD);
 227     WAD.Free();
 228     Exit;
 229   end;
 230
 231   DataLen := Len;
 232
 233   Height := config.ReadInt('', 'frameheight', 0);
 234   Width := config.ReadInt('', 'framewidth', 0);
 235
 236   config.Free();
 237   WAD.Free();
 238
 239   FreeMem(TextData);
 240   FreeMem(AnimWAD);
 241
 242   Result := True;
 243 end;
 244
 245 function CreateBitMap(Data: Pointer; DataSize: Cardinal): TBitMap;
 246 var
 247   img:        TImageData;
 248   clr:        TColor32Rec;
 249   bgc:        TColor32Rec;
 250   ii:         PByte;
 251   Width,
 252   Height:     Integer;
 253   x, y:       Integer;
 254   BitMap:     TBitMap;
 255
 256 begin
 257   Result := nil;
 258
 259   InitImage(img);
 260   if not LoadImageFromMemory(Data, DataSize, img) then
 261     Exit;
 262
 263   Width  := img.width;
 264   Height := img.height;
 265
 266   BitMap := TBitMap.Create();
 267   BitMap.PixelFormat := pf24bit;
 268
 269   BitMap.Width := Width;
 270   BitMap.Height := Height;
 271
 272 // Копируем в BitMap:
 273   ii := BitMap.RawImage.Data;
 274   for y := 0 to height-1 do
 275   begin
 276     for x := 0 to width-1 do
 277     begin
 278       clr := GetPixel32(img, x, y);
 279       // HACK: Lazarus's TBitMap doesn't seem to have a working 32 bit mode, so
 280       //       mix color with checkered background. Also, can't really read
 281       //       CHECKERS.tga from here. FUCK!
 282       if UseCheckerboard then
 283         begin
 284           if (((x shr 3) and 1) = 0) xor (((y shr 3) and 1) = 0) then
 285             bgc.Color := $FDFDFD
 286           else
 287             bgc.Color := $CBCBCB;
 288         end
 289       else
 290         begin
 291           bgc.r := GetRValue(PreviewColor);
 292           bgc.g := GetGValue(PreviewColor);
 293           bgc.b := GetBValue(PreviewColor);
 294         end;
 295       clr.r := ClampToByte((Byte(255 - clr.a) * bgc.r + clr.a * clr.r) div 255);
 296       clr.g := ClampToByte((Byte(255 - clr.a) * bgc.g + clr.a * clr.g) div 255);
 297       clr.b := ClampToByte((Byte(255 - clr.a) * bgc.b + clr.a * clr.b) div 255);
 298       // TODO: check for RGB/BGR somehow?
 299       ii^ := clr.b; Inc(ii);
 300       ii^ := clr.g; Inc(ii);
 301       ii^ := clr.r; Inc(ii);
 302
 303       (* Why this works in linux? *)
 304       {$IFNDEF WINDOWS}Inc(ii){$ENDIF}
 305     end;
 306   end;
 307   FreeImage(img);
 308   Result := BitMap;
 309 end;
 310
 311 function ShowAnim(Res: String): TBitMap;
 312 var
 313   AnimWAD:      Pointer;
 314   WAD:          TWADEditor_1;
 315   WADName:      String;
 316   SectionName:  String;
 317   ResourceName: String;
 318   Len:          Integer;
 319   config:       TConfig;
 320   TextData:     Pointer;
 321   TextureData:  Pointer;
 322
 323 begin
 324   Result := nil;
 325   AnimWAD := nil;
 326   Len := 0;
 327   TextData := nil;
 328   TextureData := nil;
 329
 330 // Читаем WAD файл и ресурс в нем:
 331   g_ProcessResourceStr(Res, WADName, SectionName, ResourceName);
 332
 333   WAD := TWADEditor_1.Create();
 334   WAD.ReadFile(WADName);
 335   WAD.GetResource(utf2win(SectionName), utf2win(ResourceName), AnimWAD, Len);
 336   WAD.FreeWAD();
 337
 338 // Читаем описание анимации:
 339   WAD.ReadMemory(AnimWAD, Len);
 340   WAD.GetResource('TEXT', 'ANIM', TextData, Len);
 341
 342   config := TConfig.CreateMem(TextData, Len);
 343
 344 // Читаем лист текстур:
 345   WAD.GetResource('TEXTURES', config.ReadStr('', 'resource', ''), TextureData, Len);
 346   NumFrames := config.ReadInt('', 'framecount', 0);
 347
 348   if (TextureData <> nil) and
 349      (WAD.GetLastError = DFWAD_NOERROR) then
 350   begin
 351   // Создаем BitMap из листа текстур:
 352     Result := CreateBitMap(TextureData, Len);
 353
 354   // Размеры одного кадра - виден только первый кадр:
 355     Result.Height := config.ReadInt('', 'frameheight', 0);
 356     Result.Width := config.ReadInt('', 'framewidth', 0);
 357   end;
 358
 359   config.Free();
 360   WAD.Free();
 361
 362   FreeMem(TextureData);
 363   FreeMem(TextData);
 364   FreeMem(AnimWAD);
 365 end;
 366
 367 function ShowTGATexture(ResourceStr: String): TBitMap;
 368 var
 369   TextureData:  Pointer;
 370   WAD:          TWADEditor_1;
 371   WADName:      String;
 372   SectionName:  String;
 373   ResourceName: String;
 374   Len:          Integer;
 375
 376 begin
 377   Result := nil;
 378   TextureData := nil;
 379   Len := 0;
 380
 381 // Читаем WAD:
 382   g_ProcessResourceStr(ResourceStr, WADName, SectionName, ResourceName);
 383
 384   WAD := TWADEditor_1.Create();
 385   if not WAD.ReadFile(WADName) then
 386   begin
 387     WAD.Free();
 388     Exit;
 389   end;
 390
 391 // Читаем ресурс текстуры в нем:
 392   WAD.GetResource(utf2win(SectionName), utf2win(ResourceName), TextureData, Len);
 393
 394   WAD.Free();
 395
 396 // Создаем на его основе BitMap:
 397   Result := CreateBitMap(TextureData, Len);
 398
 399   FreeMem(TextureData);
 400 end;
 401
 402 procedure TAddTextureForm.FormActivate(Sender: TObject);
 403 begin
 404   Inherited;
 405
 406   lStats.Caption := '';
 407   cbWADList.Items.Add(_lc[I_WAD_SPECIAL_TEXS]);
 408
 409   eTextureName.Text := '';
 410   iPreview.Canvas.FillRect(iPreview.Canvas.ClipRect);
 411
 412   bOK.Visible := False;
 413   bCancel.Visible := False;
 414 end;
 415
 416 procedure TAddTextureForm.lbResourcesListClick(Sender: TObject);
 417 var
 418   Texture: TBitMap;
 419   wad: String;
 420   Anim: Boolean;
 421
 422 begin
 423   Inherited;
 424
 425   lStats.Caption := '';
 426   if lbResourcesList.ItemIndex = -1 then
 427     Exit;
 428   if FResourceName = '' then
 429     Exit;
 430   if cbWADList.Text = _lc[I_WAD_SPECIAL_TEXS] then
 431     Exit;
 432
 433   g_ProcessResourceStr(FFullResourceName, @wad, nil, nil);
 434   if wad = _lc[I_WAD_SPECIAL_TEXS] then
 435     Exit;
 436
 437   Anim := IsAnim(FFullResourceName);
 438   if Anim then
 439     Texture := ShowAnim(FFullResourceName)
 440   else
 441     Texture := ShowTGATexture(FFullResourceName);
 442
 443   if Texture = nil then
 444     Exit;
 445
 446   if Anim then
 447     lStats.Caption := Format(_lc[I_CAP_ANIMATION], [Texture.Width, Texture.Height, NumFrames])
 448   else
 449     lStats.Caption := Format(_lc[I_CAP_TEXTURE], [Texture.Width, Texture.Height]);
 450
 451   iPreview.Canvas.FillRect(iPreview.Canvas.ClipRect);
 452   iPreview.Canvas.CopyRect(Texture.Canvas.ClipRect, Texture.Canvas, Texture.Canvas.ClipRect);
 453   Texture.Free();
 454 end;
 455
 456 procedure TAddTextureForm.eTextureNameChange(Sender: TObject);
 457 var
 458   a: Integer;
 459   first: Boolean;
 460
 461 begin
 462 // Убираем старые выделения:
 463   for a := 0 to lbResourcesList.Items.Count-1 do
 464     lbResourcesList.Selected[a] := False;
 465
 466 // Нечего искать:
 467   if (lbResourcesList.Items.Count = 0) or
 468      (eTextureName.Text = '') then
 469     Exit;
 470
 471   first := True;
 472
 473   for a := 0 to lbResourcesList.Items.Count-1 do
 474     if LowerCase(Copy(lbResourcesList.Items[a], 1,
 475                  Length(eTextureName.Text))) =
 476        LowerCase(eTextureName.Text) then
 477     begin
 478       lbResourcesList.Selected[a] := True;
 479
 480       if first then
 481       begin
 482       // Показываем первую текстуру из найденных:
 483         lbResourcesList.TopIndex := a;
 484         lbResourcesList.OnClick(nil);
 485
 486         first := False;
 487       end;
 488     end;
 489 end;
 490
 491 procedure TAddTextureForm.cbWADListChange(Sender: TObject);
 492 begin
 493   if cbWADList.Text = _lc[I_WAD_SPECIAL_TEXS] then
 494   begin
 495     cbSectionsList.Clear();
 496     cbSectionsList.Items.Add('..');
 497     Exit;
 498   end;
 499
 500   Inherited;
 501 end;
 502
 503 procedure TAddTextureForm.cbSectionsListChange(Sender: TObject);
 504 begin
 505   if cbWADList.Text = _lc[I_WAD_SPECIAL_TEXS] then
 506   begin
 507     lbResourcesList.Clear();
 508     lbResourcesList.Items.Add(TEXTURE_NAME_WATER);
 509     lbResourcesList.Items.Add(TEXTURE_NAME_ACID1);
 510     lbResourcesList.Items.Add(TEXTURE_NAME_ACID2);
 511     Exit;
 512   end;
 513
 514   Inherited;
 515 end;
 516
 517 procedure TAddTextureForm.bCloseClick(Sender: TObject);
 518 begin
 519   Close();
 520 end;
 521
 522 procedure TAddTextureForm.bAddTextureClick(Sender: TObject);
 523 var
 524   i: Integer;
 525
 526 begin
 527   for i := 0 to lbResourcesList.Count-1 do
 528     if lbResourcesList.Selected[i] then
 529     begin
 530       AddTexture(cbWADlist.Text, cbSectionsList.Text,
 531                  lbResourcesList.Items[i], False);
 532       lbResourcesList.Selected[i] := False;
 533     end;
 534 end;
 535
 536 procedure TAddTextureForm.bAddCloseClick(Sender: TObject);
 537 begin
 538   bAddTextureClick(bAddTexture);
 539   Close();
 540 end;
 541
 542 end.