DEADSOFTWARE

Fix locks again
[d2df-editor.git] / src / editor / f_addresource_texture.pas
1 unit f_addresource_texture;
3 {$INCLUDE ../shared/a_modes.inc}
5 interface
7 uses
8 LCLIntf, LCLType, SysUtils, Variants, Classes,
9 Graphics, Controls, Forms, Dialogs, f_addresource,
10 StdCtrls, ExtCtrls, utils, Imaging, ImagingTypes, ImagingUtility;
12 type
14 { TAddTextureForm }
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;
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);
34 private
35 {}
36 public
37 {}
38 end;
40 var
41 AddTextureForm: TAddTextureForm;
42 NumFrames: Integer = 0;
44 function IsAnim(Res: String): Boolean;
45 function GetFrame(Res: String; var Data: Pointer; var DataLen: Integer;
46 var Width, Height: Word): Boolean;
48 implementation
50 uses
51 BinEditor, WADEDITOR, WADSTRUCT, f_main, g_textures, CONFIG, g_map,
52 g_language, e_Log, g_resources;
54 {$R *.lfm}
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;
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;
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;
107 begin
108 Result := nil;
110 InitImage(img);
111 if not LoadImageFromMemory(Data, DataSize, img) then
112 Exit;
114 Width := img.width;
115 Height := img.height;
117 BitMap := TBitMap.Create();
118 BitMap.PixelFormat := pf24bit;
120 BitMap.Width := Width;
121 BitMap.Height := Height;
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);
154 (* Why this works in linux? *)
155 {$IFNDEF WINDOWS}Inc(ii){$ENDIF}
156 end;
157 end;
158 FreeImage(img);
159 Result := BitMap;
160 end;
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;
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;
203 procedure TAddTextureForm.FormActivate(Sender: TObject);
204 begin
205 Inherited;
207 lStats.Caption := '';
208 cbWADList.Items.Add(_lc[I_WAD_SPECIAL_TEXS]);
210 eTextureName.Text := '';
211 iPreview.Canvas.FillRect(iPreview.Canvas.ClipRect);
213 bOK.Visible := False;
214 bCancel.Visible := False;
215 end;
217 procedure TAddTextureForm.lbResourcesListClick(Sender: TObject);
218 var
219 Texture: TBitMap;
220 wad: String;
221 Anim: Boolean;
223 begin
224 Inherited;
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;
234 g_ProcessResourceStr(FFullResourceName, @wad, nil, nil);
235 if wad = _lc[I_WAD_SPECIAL_TEXS] then
236 Exit;
238 Anim := IsAnim(FFullResourceName);
239 if Anim then
240 Texture := ShowAnim(FFullResourceName)
241 else
242 Texture := ShowTGATexture(FFullResourceName);
244 if Texture = nil then
245 Exit;
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]);
252 iPreview.Canvas.FillRect(iPreview.Canvas.ClipRect);
253 iPreview.Canvas.CopyRect(Texture.Canvas.ClipRect, Texture.Canvas, Texture.Canvas.ClipRect);
254 Texture.Free();
255 end;
257 procedure TAddTextureForm.eTextureNameChange(Sender: TObject);
258 var
259 a: Integer;
260 first: Boolean;
262 begin
263 // Убираем старые выделения:
264 for a := 0 to lbResourcesList.Items.Count-1 do
265 lbResourcesList.Selected[a] := False;
267 // Нечего искать:
268 if (lbResourcesList.Items.Count = 0) or
269 (eTextureName.Text = '') then
270 Exit;
272 first := True;
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;
281 if first then
282 begin
283 // Показываем первую текстуру из найденных:
284 lbResourcesList.TopIndex := a;
285 lbResourcesList.OnClick(nil);
287 first := False;
288 end;
289 end;
290 end;
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;
301 Inherited;
302 end;
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;
315 Inherited;
316 end;
318 procedure TAddTextureForm.bCloseClick(Sender: TObject);
319 begin
320 Close();
321 end;
323 procedure TAddTextureForm.bAddTextureClick(Sender: TObject);
324 var
325 i: Integer;
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;
337 procedure TAddTextureForm.bAddCloseClick(Sender: TObject);
338 begin
339 bAddTextureClick(bAddTexture);
340 Close();
341 end;
343 end.