1 unit f_addresource_texture
;
3 {$INCLUDE ../shared/a_modes.inc}
8 LCLIntf
, LCLType
, SysUtils
, Variants
, Classes
,
9 Graphics
, Controls
, Forms
, Dialogs
, f_addresource
,
10 StdCtrls
, ExtCtrls
, utils
, Imaging
, ImagingTypes
, ImagingUtility
;
16 TAddTextureForm
= class (TAddResourceForm
)
19 PanelTexPreview
: TPanel
;
26 procedure FormActivate(Sender
: TObject
);
27 procedure lbResourcesListClick(Sender
: TObject
);
28 procedure eTextureNameChange(Sender
: TObject
);
29 procedure cbWADListChange(Sender
: TObject
);
30 procedure cbSectionsListChange(Sender
: TObject
);
31 procedure bCloseClick(Sender
: TObject
);
32 procedure bAddTextureClick(Sender
: TObject
);
33 procedure bAddCloseClick(Sender
: TObject
);
42 AddTextureForm
: TAddTextureForm
;
43 NumFrames
: Integer = 0;
45 function IsAnim(Res
: String): Boolean;
46 function GetFrame(Res
: String; var Data
: Pointer; var DataLen
: Integer;
47 var Width
, Height
: Word): Boolean;
52 BinEditor
, WADEDITOR
, WADSTRUCT
, f_main
, g_textures
, CONFIG
, g_map
,
57 function IsAnim(Res
: String): Boolean;
75 // Читаем файл и ресурс в нем:
76 g_ProcessResourceStr(Res
, WADName
, SectionName
, ResourceName
);
78 WAD
:= TWADEditor_1
.Create();
80 if (not WAD
.ReadFile(WADName
)) or
81 (not WAD
.GetResource(utf2win(SectionName
), utf2win(ResourceName
), Data
, Size
)) then
89 // Пробуем прочитать данные:
90 if not WAD
.ReadMemory(Data
, Size
) then
100 Sections
:= WAD
.GetSectionList();
102 if Sections
= nil then
108 // Ищем в секциях "TEXT":
110 for a
:= 0 to High(Sections
) do
111 if Sections
[a
] = 'TEXT' then
117 // Ищем в секциях лист текстур - "TEXTURES":
118 for a
:= 0 to High(Sections
) do
119 if Sections
[a
] = 'TEXTURES' then
131 // Получаем ресурсы секции "TEXT":
132 Resources
:= WAD
.GetResourcesList('TEXT');
134 if Resources
= nil then
140 // Ищем в них описание анимации - "ANIM":
142 for a
:= 0 to High(Resources
) do
143 if Resources
[a
] = 'ANIM' then
151 // Если все получилось, то это аним. текстура:
155 function GetFrame(Res
: String; var Data
: Pointer; var DataLen
: Integer; var Width
, Height
: Word): Boolean;
161 ResourceName
: String;
173 g_ProcessResourceStr(Res
, WADName
, SectionName
, ResourceName
);
175 WAD
:= TWADEditor_1
.Create();
177 if not WAD
.ReadFile(WADName
) then
183 // Читаем WAD-ресурс из WAD:
184 if not WAD
.GetResource(utf2win(SectionName
), utf2win(ResourceName
), AnimWAD
, Len
) then
192 // Читаем WAD в WAD'е:
193 if not WAD
.ReadMemory(AnimWAD
, Len
) then
200 // Читаем описание анимации:
201 if not WAD
.GetResource('TEXT', 'ANIM', TextData
, Len
) then
209 config
:= TConfig
.CreateMem(TextData
, Len
);
211 // Читаем ресурс - лист текстур:
212 if not WAD
.GetResource('TEXTURES', config
.ReadStr('', 'resource', ''), Data
, Len
) then
222 Height
:= config
.ReadInt('', 'frameheight', 0);
223 Width
:= config
.ReadInt('', 'framewidth', 0);
234 function CreateBitMap (Data
: Pointer; DataSize
: Cardinal): TBitMap
;
237 clr
, bgc
: TColor32Rec
;
238 Width
, Height
: Integer;
244 if not LoadImageFromMemory(Data
, DataSize
, img
) then
248 Height
:= img
.height
;
249 BitMap
:= TBitMap
.Create();
250 BitMap
.PixelFormat
:= pf24bit
;
251 BitMap
.Width
:= Width
;
252 BitMap
.Height
:= Height
;
253 for y
:= 0 to Height
- 1 do
255 for x
:= 0 to Width
- 1 do
257 clr
:= GetPixel32(img
, x
, y
);
258 // HACK: Lazarus's TBitMap doesn't seem to have a working 32 bit mode, so
259 // mix color with checkered background. Also, can't really read
260 // CHECKERS.tga from here. FUCK!
261 if UseCheckerboard
then
263 if (((x
shr 3) and 1) = 0) xor (((y
shr 3) and 1) = 0) then
270 bgc
.r
:= GetRValue(PreviewColor
);
271 bgc
.g
:= GetGValue(PreviewColor
);
272 bgc
.b
:= GetBValue(PreviewColor
)
274 clr
.r
:= ClampToByte((Byte(255 - clr
.a
) * bgc
.r
+ clr
.a
* clr
.r
) div 255);
275 clr
.g
:= ClampToByte((Byte(255 - clr
.a
) * bgc
.g
+ clr
.a
* clr
.g
) div 255);
276 clr
.b
:= ClampToByte((Byte(255 - clr
.a
) * bgc
.b
+ clr
.a
* clr
.b
) div 255);
277 BitMap
.Canvas
.Pixels
[x
, y
] := RGBToColor(clr
.r
, clr
.g
, clr
.b
)
284 function ShowAnim(Res
: String): TBitMap
;
290 ResourceName
: String;
294 TextureData
: Pointer;
303 // Читаем WAD файл и ресурс в нем:
304 g_ProcessResourceStr(Res
, WADName
, SectionName
, ResourceName
);
306 WAD
:= TWADEditor_1
.Create();
307 WAD
.ReadFile(WADName
);
308 WAD
.GetResource(utf2win(SectionName
), utf2win(ResourceName
), AnimWAD
, Len
);
311 // Читаем описание анимации:
312 WAD
.ReadMemory(AnimWAD
, Len
);
313 WAD
.GetResource('TEXT', 'ANIM', TextData
, Len
);
315 config
:= TConfig
.CreateMem(TextData
, Len
);
317 // Читаем лист текстур:
318 WAD
.GetResource('TEXTURES', config
.ReadStr('', 'resource', ''), TextureData
, Len
);
319 NumFrames
:= config
.ReadInt('', 'framecount', 0);
321 if (TextureData
<> nil) and
322 (WAD
.GetLastError
= DFWAD_NOERROR
) then
324 // Создаем BitMap из листа текстур:
325 Result
:= CreateBitMap(TextureData
, Len
);
327 // Размеры одного кадра - виден только первый кадр:
328 Result
.Height
:= config
.ReadInt('', 'frameheight', 0);
329 Result
.Width
:= config
.ReadInt('', 'framewidth', 0);
335 FreeMem(TextureData
);
340 function ShowTGATexture(ResourceStr
: String): TBitMap
;
342 TextureData
: Pointer;
346 ResourceName
: String;
355 g_ProcessResourceStr(ResourceStr
, WADName
, SectionName
, ResourceName
);
357 WAD
:= TWADEditor_1
.Create();
358 if not WAD
.ReadFile(WADName
) then
364 // Читаем ресурс текстуры в нем:
365 WAD
.GetResource(utf2win(SectionName
), utf2win(ResourceName
), TextureData
, Len
);
369 // Создаем на его основе BitMap:
370 Result
:= CreateBitMap(TextureData
, Len
);
372 FreeMem(TextureData
);
375 procedure TAddTextureForm
.FormActivate(Sender
: TObject
);
379 lStats
.Caption
:= '';
380 cbWADList
.Items
.Add(MsgWadSpecialTexs
);
382 eTextureName
.Text := '';
383 iPreview
.Canvas
.FillRect(iPreview
.Canvas
.ClipRect
);
385 bOK
.Visible
:= False;
386 bCancel
.Visible
:= False;
389 procedure TAddTextureForm
.lbResourcesListClick(Sender
: TObject
);
398 lStats
.Caption
:= '';
399 if lbResourcesList
.ItemIndex
= -1 then
401 if FResourceName
= '' then
403 if cbWADList
.Text = MsgWadSpecialTexs
then
406 g_ProcessResourceStr(FFullResourceName
, @wad
, nil, nil);
407 if wad
= MsgWadSpecialTexs
then
410 Anim
:= IsAnim(FFullResourceName
);
412 Texture
:= ShowAnim(FFullResourceName
)
414 Texture
:= ShowTGATexture(FFullResourceName
);
416 if Texture
= nil then
420 lStats
.Caption
:= Format(MsgCapAnimation
, [Texture
.Width
, Texture
.Height
, NumFrames
])
422 lStats
.Caption
:= Format(MsgCapTexture
, [Texture
.Width
, Texture
.Height
]);
424 iPreview
.Canvas
.FillRect(iPreview
.Canvas
.ClipRect
);
425 iPreview
.Canvas
.CopyRect(Texture
.Canvas
.ClipRect
, Texture
.Canvas
, Texture
.Canvas
.ClipRect
);
429 procedure TAddTextureForm
.eTextureNameChange(Sender
: TObject
);
435 // Убираем старые выделения:
436 for a
:= 0 to lbResourcesList
.Items
.Count
-1 do
437 lbResourcesList
.Selected
[a
] := False;
440 if (lbResourcesList
.Items
.Count
= 0) or
441 (eTextureName
.Text = '') then
446 for a
:= 0 to lbResourcesList
.Items
.Count
-1 do
447 if LowerCase(Copy(lbResourcesList
.Items
[a
], 1,
448 Length(eTextureName
.Text))) =
449 LowerCase(eTextureName
.Text) then
451 lbResourcesList
.Selected
[a
] := True;
455 // Показываем первую текстуру из найденных:
456 lbResourcesList
.TopIndex
:= a
;
457 lbResourcesList
.OnClick(nil);
464 procedure TAddTextureForm
.cbWADListChange(Sender
: TObject
);
466 if cbWADList
.Text = MsgWadSpecialTexs
then
468 cbSectionsList
.Clear();
469 cbSectionsList
.Items
.Add('..');
476 procedure TAddTextureForm
.cbSectionsListChange(Sender
: TObject
);
478 if cbWADList
.Text = MsgWadSpecialTexs
then
480 lbResourcesList
.Clear();
481 lbResourcesList
.Items
.Add(TEXTURE_NAME_WATER
);
482 lbResourcesList
.Items
.Add(TEXTURE_NAME_ACID1
);
483 lbResourcesList
.Items
.Add(TEXTURE_NAME_ACID2
);
490 procedure TAddTextureForm
.bCloseClick(Sender
: TObject
);
495 procedure TAddTextureForm
.bAddTextureClick(Sender
: TObject
);
500 for i
:= 0 to lbResourcesList
.Count
-1 do
501 if lbResourcesList
.Selected
[i
] then
503 MainForm
.AddTexture(cbWADlist
.Text, cbSectionsList
.Text, lbResourcesList
.Items
[i
], False);
504 lbResourcesList
.Selected
[i
] := False;
508 procedure TAddTextureForm
.bAddCloseClick(Sender
: TObject
);
510 bAddTextureClick(bAddTexture
);
515 AddTextureForm
:= TAddTextureForm
.Create(Application
);