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