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