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, e_Log, g_resources;
  53
  54 {$R *.lfm}
  55
  56 function IsAnim(Res: String): Boolean;
  57   var
  58     data: Pointer;
  59     len: Integer;
  60     WADName, SectionName, ResourceName: String;
  61 begin
  62   g_ProcessResourceStr(Res, WADName, SectionName, ResourceName);
  63   (* just check file existance *)
  64   g_ReadSubResource(WADName, SectionName, ResourceName, 'TEXT', 'ANIM', data, len);
  65   (* TODO check section TEXTURES *)
  66   Result := data <> nil;
  67   if data <> nil then
  68     FreeMem(data)
  69 end;
  70
  71 function GetFrame (Res: String; var Data: Pointer; var DataLen: Integer; var Width, Height: Word): Boolean;
  72   var
  73     Len: Integer;
  74     TextData: Pointer;
  75     WADName, SectionName, ResourceName: String;
  76     config: TConfig;
  77 begin
  78   Result := False; Data := nil; DataLen := 0; Width := 0; Height := 0;
  79   g_ProcessResourceStr(Res, WADName, SectionName, ResourceName);
  80   g_ReadSubResource(WADName, SectionName, ResourceName, 'TEXT', 'ANIM', TextData, Len);
  81   if TextData <> nil then
  82   begin
  83     config := TConfig.CreateMem(TextData, Len);
  84     g_ReadSubResource(WADName, SectionName, ResourceName, 'TEXTURES', config.ReadStr('', 'resource', ''), Data, DataLen);
  85     if Data <> nil then
  86     begin
  87       Height := config.ReadInt('', 'frameheight', 0);
  88       Width := config.ReadInt('', 'framewidth', 0);
  89       Result := True
  90     end;
  91     config.Free();
  92     FreeMem(TextData)
  93   end
  94 end;
  95
  96 function CreateBitMap(Data: Pointer; DataSize: Cardinal): TBitMap;
  97 var
  98   img:        TImageData;
  99   clr:        TColor32Rec;
 100   bgc:        TColor32Rec;
 101   ii:         PByte;
 102   Width,
 103   Height:     Integer;
 104   x, y:       Integer;
 105   BitMap:     TBitMap;
 106
 107 begin
 108   Result := nil;
 109
 110   InitImage(img);
 111   if not LoadImageFromMemory(Data, DataSize, img) then
 112     Exit;
 113
 114   Width  := img.width;
 115   Height := img.height;
 116
 117   BitMap := TBitMap.Create();
 118   BitMap.PixelFormat := pf24bit;
 119
 120   BitMap.Width := Width;
 121   BitMap.Height := Height;
 122
 123 // Копируем в BitMap:
 124   ii := BitMap.RawImage.Data;
 125   for y := 0 to height-1 do
 126   begin
 127     for x := 0 to width-1 do
 128     begin
 129       clr := GetPixel32(img, x, y);
 130       // HACK: Lazarus's TBitMap doesn't seem to have a working 32 bit mode, so
 131       //       mix color with checkered background. Also, can't really read
 132       //       CHECKERS.tga from here. FUCK!
 133       if UseCheckerboard then
 134         begin
 135           if (((x shr 3) and 1) = 0) xor (((y shr 3) and 1) = 0) then
 136             bgc.Color := $FDFDFD
 137           else
 138             bgc.Color := $CBCBCB;
 139         end
 140       else
 141         begin
 142           bgc.r := GetRValue(PreviewColor);
 143           bgc.g := GetGValue(PreviewColor);
 144           bgc.b := GetBValue(PreviewColor);
 145         end;
 146       clr.r := ClampToByte((Byte(255 - clr.a) * bgc.r + clr.a * clr.r) div 255);
 147       clr.g := ClampToByte((Byte(255 - clr.a) * bgc.g + clr.a * clr.g) div 255);
 148       clr.b := ClampToByte((Byte(255 - clr.a) * bgc.b + clr.a * clr.b) div 255);
 149       // TODO: check for RGB/BGR somehow?
 150       ii^ := clr.b; Inc(ii);
 151       ii^ := clr.g; Inc(ii);
 152       ii^ := clr.r; Inc(ii);
 153
 154       (* Why this works in linux? *)
 155       {$IFNDEF WINDOWS}Inc(ii){$ENDIF}
 156     end;
 157   end;
 158   FreeImage(img);
 159   Result := BitMap;
 160 end;
 161
 162 function ShowAnim(Res: String): TBitMap;
 163   var
 164     Len: Integer;
 165     TextData, TextureData: Pointer;
 166     WADName, SectionName, ResourceName: String;
 167     config: TConfig;
 168 begin
 169   Result := nil;
 170   g_ProcessResourceStr(Res, WADName, SectionName, ResourceName);
 171   g_ReadSubResource(WADName, SectionName, ResourceName, 'TEXT', 'ANIM', TextData, Len);
 172   if TextData <> nil then
 173   begin
 174     config := TConfig.CreateMem(TextData, Len);
 175     g_ReadSubResource(WADName, SectionName, ResourceName, 'TEXTURES', config.ReadStr('', 'resource', ''), TextureData, Len);
 176     if TextureData <> nil then
 177     begin
 178       Result := CreateBitMap(TextureData, Len);
 179       (* view only first frame *)
 180       NumFrames := config.ReadInt('', 'framecount', 0);
 181       Result.Height := config.ReadInt('', 'frameheight', 0);
 182       Result.Width := config.ReadInt('', 'framewidth', 0);
 183       FreeMem(TextureData)
 184     end;
 185     config.Free();
 186     FreeMem(TextData)
 187   end
 188 end;
 189
 190 function ShowTGATexture(ResourceStr: String): TBitMap;
 191   var
 192     Len: Integer;
 193     TextureData: Pointer;
 194     WADName, SectionName, ResourceName: String;
 195 begin
 196   Result := nil;
 197   g_ProcessResourceStr(ResourceStr, WADName, SectionName, ResourceName);
 198   g_ReadResource(WADName, SectionName, ResourceName, TextureData, Len);
 199   if TextureData <> nil then
 200     Result := CreateBitMap(TextureData, Len)
 201 end;
 202
 203 procedure TAddTextureForm.FormActivate(Sender: TObject);
 204 begin
 205   Inherited;
 206
 207   lStats.Caption := '';
 208   cbWADList.Items.Add(_lc[I_WAD_SPECIAL_TEXS]);
 209
 210   eTextureName.Text := '';
 211   iPreview.Canvas.FillRect(iPreview.Canvas.ClipRect);
 212
 213   bOK.Visible := False;
 214   bCancel.Visible := False;
 215 end;
 216
 217 procedure TAddTextureForm.lbResourcesListClick(Sender: TObject);
 218 var
 219   Texture: TBitMap;
 220   wad: String;
 221   Anim: Boolean;
 222
 223 begin
 224   Inherited;
 225
 226   lStats.Caption := '';
 227   if lbResourcesList.ItemIndex = -1 then
 228     Exit;
 229   if FResourceName = '' then
 230     Exit;
 231   if cbWADList.Text = _lc[I_WAD_SPECIAL_TEXS] then
 232     Exit;
 233
 234   g_ProcessResourceStr(FFullResourceName, @wad, nil, nil);
 235   if wad = _lc[I_WAD_SPECIAL_TEXS] then
 236     Exit;
 237
 238   Anim := IsAnim(FFullResourceName);
 239   if Anim then
 240     Texture := ShowAnim(FFullResourceName)
 241   else
 242     Texture := ShowTGATexture(FFullResourceName);
 243
 244   if Texture = nil then
 245     Exit;
 246
 247   if Anim then
 248     lStats.Caption := Format(_lc[I_CAP_ANIMATION], [Texture.Width, Texture.Height, NumFrames])
 249   else
 250     lStats.Caption := Format(_lc[I_CAP_TEXTURE], [Texture.Width, Texture.Height]);
 251
 252   iPreview.Canvas.FillRect(iPreview.Canvas.ClipRect);
 253   iPreview.Canvas.CopyRect(Texture.Canvas.ClipRect, Texture.Canvas, Texture.Canvas.ClipRect);
 254   Texture.Free();
 255 end;
 256
 257 procedure TAddTextureForm.eTextureNameChange(Sender: TObject);
 258 var
 259   a: Integer;
 260   first: Boolean;
 261
 262 begin
 263 // Убираем старые выделения:
 264   for a := 0 to lbResourcesList.Items.Count-1 do
 265     lbResourcesList.Selected[a] := False;
 266
 267 // Нечего искать:
 268   if (lbResourcesList.Items.Count = 0) or
 269      (eTextureName.Text = '') then
 270     Exit;
 271
 272   first := True;
 273
 274   for a := 0 to lbResourcesList.Items.Count-1 do
 275     if LowerCase(Copy(lbResourcesList.Items[a], 1,
 276                  Length(eTextureName.Text))) =
 277        LowerCase(eTextureName.Text) then
 278     begin
 279       lbResourcesList.Selected[a] := True;
 280
 281       if first then
 282       begin
 283       // Показываем первую текстуру из найденных:
 284         lbResourcesList.TopIndex := a;
 285         lbResourcesList.OnClick(nil);
 286
 287         first := False;
 288       end;
 289     end;
 290 end;
 291
 292 procedure TAddTextureForm.cbWADListChange(Sender: TObject);
 293 begin
 294   if cbWADList.Text = _lc[I_WAD_SPECIAL_TEXS] then
 295   begin
 296     cbSectionsList.Clear();
 297     cbSectionsList.Items.Add('..');
 298     Exit;
 299   end;
 300
 301   Inherited;
 302 end;
 303
 304 procedure TAddTextureForm.cbSectionsListChange(Sender: TObject);
 305 begin
 306   if cbWADList.Text = _lc[I_WAD_SPECIAL_TEXS] then
 307   begin
 308     lbResourcesList.Clear();
 309     lbResourcesList.Items.Add(TEXTURE_NAME_WATER);
 310     lbResourcesList.Items.Add(TEXTURE_NAME_ACID1);
 311     lbResourcesList.Items.Add(TEXTURE_NAME_ACID2);
 312     Exit;
 313   end;
 314
 315   Inherited;
 316 end;
 317
 318 procedure TAddTextureForm.bCloseClick(Sender: TObject);
 319 begin
 320   Close();
 321 end;
 322
 323 procedure TAddTextureForm.bAddTextureClick(Sender: TObject);
 324 var
 325   i: Integer;
 326
 327 begin
 328   for i := 0 to lbResourcesList.Count-1 do
 329     if lbResourcesList.Selected[i] then
 330     begin
 331       AddTexture(cbWADlist.Text, cbSectionsList.Text,
 332                  lbResourcesList.Items[i], False);
 333       lbResourcesList.Selected[i] := False;
 334     end;
 335 end;
 336
 337 procedure TAddTextureForm.bAddCloseClick(Sender: TObject);
 338 begin
 339   bAddTextureClick(bAddTexture);
 340   Close();
 341 end;
 342
 343 end.