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
)
18 PanelTexPreview
: TPanel
;
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
);
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;
51 BinEditor
, WADEDITOR
, WADSTRUCT
, f_main
, g_textures
, CONFIG
, g_map
,
56 function IsAnim(Res
: String): Boolean;
74 // Читаем файл и ресурс в нем:
75 g_ProcessResourceStr(Res
, WADName
, SectionName
, ResourceName
);
77 WAD
:= TWADEditor_1
.Create();
79 if (not WAD
.ReadFile(WADName
)) or
80 (not WAD
.GetResource(utf2win(SectionName
), utf2win(ResourceName
), Data
, Size
)) then
88 // Пробуем прочитать данные:
89 if not WAD
.ReadMemory(Data
, Size
) then
99 Sections
:= WAD
.GetSectionList();
101 if Sections
= nil then
107 // Ищем в секциях "TEXT":
109 for a
:= 0 to High(Sections
) do
110 if Sections
[a
] = 'TEXT' then
116 // Ищем в секциях лист текстур - "TEXTURES":
117 for a
:= 0 to High(Sections
) do
118 if Sections
[a
] = 'TEXTURES' then
130 // Получаем ресурсы секции "TEXT":
131 Resources
:= WAD
.GetResourcesList('TEXT');
133 if Resources
= nil then
139 // Ищем в них описание анимации - "ANIM":
141 for a
:= 0 to High(Resources
) do
142 if Resources
[a
] = 'ANIM' then
150 // Если все получилось, то это аним. текстура:
154 function GetFrame(Res
: String; var Data
: Pointer; var DataLen
: Integer; var Width
, Height
: Word): Boolean;
160 ResourceName
: String;
172 g_ProcessResourceStr(Res
, WADName
, SectionName
, ResourceName
);
174 WAD
:= TWADEditor_1
.Create();
176 if not WAD
.ReadFile(WADName
) then
182 // Читаем WAD-ресурс из WAD:
183 if not WAD
.GetResource(utf2win(SectionName
), utf2win(ResourceName
), AnimWAD
, Len
) then
191 // Читаем WAD в WAD'е:
192 if not WAD
.ReadMemory(AnimWAD
, Len
) then
199 // Читаем описание анимации:
200 if not WAD
.GetResource('TEXT', 'ANIM', TextData
, Len
) then
208 config
:= TConfig
.CreateMem(TextData
, Len
);
210 // Читаем ресурс - лист текстур:
211 if not WAD
.GetResource('TEXTURES', config
.ReadStr('', 'resource', ''), Data
, Len
) then
221 Height
:= config
.ReadInt('', 'frameheight', 0);
222 Width
:= config
.ReadInt('', 'framewidth', 0);
233 function CreateBitMap (Data
: Pointer; DataSize
: Cardinal): TBitMap
;
236 clr
, bgc
: TColor32Rec
;
237 Width
, Height
: Integer;
243 if not LoadImageFromMemory(Data
, DataSize
, img
) then
247 Height
:= img
.height
;
248 BitMap
:= TBitMap
.Create();
249 BitMap
.PixelFormat
:= pf24bit
;
250 BitMap
.Width
:= Width
;
251 BitMap
.Height
:= Height
;
252 for y
:= 0 to Height
- 1 do
254 for x
:= 0 to Width
- 1 do
256 clr
:= GetPixel32(img
, x
, y
);
257 // HACK: Lazarus's TBitMap doesn't seem to have a working 32 bit mode, so
258 // mix color with checkered background. Also, can't really read
259 // CHECKERS.tga from here. FUCK!
260 if UseCheckerboard
then
262 if (((x
shr 3) and 1) = 0) xor (((y
shr 3) and 1) = 0) then
269 bgc
.r
:= GetRValue(PreviewColor
);
270 bgc
.g
:= GetGValue(PreviewColor
);
271 bgc
.b
:= GetBValue(PreviewColor
)
273 clr
.r
:= ClampToByte((Byte(255 - clr
.a
) * bgc
.r
+ clr
.a
* clr
.r
) div 255);
274 clr
.g
:= ClampToByte((Byte(255 - clr
.a
) * bgc
.g
+ clr
.a
* clr
.g
) div 255);
275 clr
.b
:= ClampToByte((Byte(255 - clr
.a
) * bgc
.b
+ clr
.a
* clr
.b
) div 255);
276 BitMap
.Canvas
.Pixels
[x
, y
] := RGBToColor(clr
.r
, clr
.g
, clr
.b
)
283 function ShowAnim(Res
: String): TBitMap
;
289 ResourceName
: String;
293 TextureData
: Pointer;
302 // Читаем WAD файл и ресурс в нем:
303 g_ProcessResourceStr(Res
, WADName
, SectionName
, ResourceName
);
305 WAD
:= TWADEditor_1
.Create();
306 WAD
.ReadFile(WADName
);
307 WAD
.GetResource(utf2win(SectionName
), utf2win(ResourceName
), AnimWAD
, Len
);
310 // Читаем описание анимации:
311 WAD
.ReadMemory(AnimWAD
, Len
);
312 WAD
.GetResource('TEXT', 'ANIM', TextData
, Len
);
314 config
:= TConfig
.CreateMem(TextData
, Len
);
316 // Читаем лист текстур:
317 WAD
.GetResource('TEXTURES', config
.ReadStr('', 'resource', ''), TextureData
, Len
);
318 NumFrames
:= config
.ReadInt('', 'framecount', 0);
320 if (TextureData
<> nil) and
321 (WAD
.GetLastError
= DFWAD_NOERROR
) then
323 // Создаем BitMap из листа текстур:
324 Result
:= CreateBitMap(TextureData
, Len
);
326 // Размеры одного кадра - виден только первый кадр:
327 Result
.Height
:= config
.ReadInt('', 'frameheight', 0);
328 Result
.Width
:= config
.ReadInt('', 'framewidth', 0);
334 FreeMem(TextureData
);
339 function ShowTGATexture(ResourceStr
: String): TBitMap
;
341 TextureData
: Pointer;
345 ResourceName
: String;
354 g_ProcessResourceStr(ResourceStr
, WADName
, SectionName
, ResourceName
);
356 WAD
:= TWADEditor_1
.Create();
357 if not WAD
.ReadFile(WADName
) then
363 // Читаем ресурс текстуры в нем:
364 WAD
.GetResource(utf2win(SectionName
), utf2win(ResourceName
), TextureData
, Len
);
368 // Создаем на его основе BitMap:
369 Result
:= CreateBitMap(TextureData
, Len
);
371 FreeMem(TextureData
);
374 procedure TAddTextureForm
.FormActivate(Sender
: TObject
);
378 lStats
.Caption
:= '';
379 cbWADList
.Items
.Add(MsgWadSpecialTexs
);
381 eTextureName
.Text := '';
382 iPreview
.Canvas
.FillRect(iPreview
.Canvas
.ClipRect
);
384 bOK
.Visible
:= False;
385 bCancel
.Visible
:= False;
388 procedure TAddTextureForm
.lbResourcesListClick(Sender
: TObject
);
397 lStats
.Caption
:= '';
398 if lbResourcesList
.ItemIndex
= -1 then
400 if FResourceName
= '' then
402 if cbWADList
.Text = MsgWadSpecialTexs
then
405 g_ProcessResourceStr(FFullResourceName
, @wad
, nil, nil);
406 if wad
= MsgWadSpecialTexs
then
409 Anim
:= IsAnim(FFullResourceName
);
411 Texture
:= ShowAnim(FFullResourceName
)
413 Texture
:= ShowTGATexture(FFullResourceName
);
415 if Texture
= nil then
419 lStats
.Caption
:= Format(MsgCapAnimation
, [Texture
.Width
, Texture
.Height
, NumFrames
])
421 lStats
.Caption
:= Format(MsgCapTexture
, [Texture
.Width
, Texture
.Height
]);
423 iPreview
.Canvas
.FillRect(iPreview
.Canvas
.ClipRect
);
424 iPreview
.Canvas
.CopyRect(Texture
.Canvas
.ClipRect
, Texture
.Canvas
, Texture
.Canvas
.ClipRect
);
428 procedure TAddTextureForm
.eTextureNameChange(Sender
: TObject
);
434 // Убираем старые выделения:
435 for a
:= 0 to lbResourcesList
.Items
.Count
-1 do
436 lbResourcesList
.Selected
[a
] := False;
439 if (lbResourcesList
.Items
.Count
= 0) or
440 (eTextureName
.Text = '') then
445 for a
:= 0 to lbResourcesList
.Items
.Count
-1 do
446 if LowerCase(Copy(lbResourcesList
.Items
[a
], 1,
447 Length(eTextureName
.Text))) =
448 LowerCase(eTextureName
.Text) then
450 lbResourcesList
.Selected
[a
] := True;
454 // Показываем первую текстуру из найденных:
455 lbResourcesList
.TopIndex
:= a
;
456 lbResourcesList
.OnClick(nil);
463 procedure TAddTextureForm
.cbWADListChange(Sender
: TObject
);
465 if cbWADList
.Text = MsgWadSpecialTexs
then
467 cbSectionsList
.Clear();
468 cbSectionsList
.Items
.Add('..');
475 procedure TAddTextureForm
.cbSectionsListChange(Sender
: TObject
);
477 if cbWADList
.Text = MsgWadSpecialTexs
then
479 lbResourcesList
.Clear();
480 lbResourcesList
.Items
.Add(TEXTURE_NAME_WATER
);
481 lbResourcesList
.Items
.Add(TEXTURE_NAME_ACID1
);
482 lbResourcesList
.Items
.Add(TEXTURE_NAME_ACID2
);
489 procedure TAddTextureForm
.bCloseClick(Sender
: TObject
);
494 procedure TAddTextureForm
.bAddTextureClick(Sender
: TObject
);
499 for i
:= 0 to lbResourcesList
.Count
-1 do
500 if lbResourcesList
.Selected
[i
] then
502 AddTexture(cbWADlist
.Text, cbSectionsList
.Text,
503 lbResourcesList
.Items
[i
], False);
504 lbResourcesList
.Selected
[i
] := False;
508 procedure TAddTextureForm
.bAddCloseClick(Sender
: TObject
);
510 bAddTextureClick(bAddTexture
);