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