86566cfa9627df9eeab1238aed7ad118dd19bc41
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
;
13 TAddTextureForm
= class (TAddResourceForm
)
14 PanelTexPreview
: TPanel
;
21 procedure FormActivate(Sender
: TObject
);
22 procedure lbResourcesListClick(Sender
: TObject
);
23 procedure eTextureNameChange(Sender
: TObject
);
24 procedure cbWADListChange(Sender
: TObject
);
25 procedure cbSectionsListChange(Sender
: TObject
);
26 procedure bCloseClick(Sender
: TObject
);
27 procedure bAddTextureClick(Sender
: TObject
);
28 procedure bAddCloseClick(Sender
: TObject
);
37 AddTextureForm
: TAddTextureForm
;
39 function IsAnim(Res
: String): Boolean;
40 function GetFrame(Res
: String; var Data
: Pointer; var DataLen
: Integer;
41 var Width
, Height
: Word): Boolean;
46 BinEditor
, WADEDITOR
, WADSTRUCT
, f_main
, g_textures
, CONFIG
, g_map
,
51 function IsAnim(Res
: String): Boolean;
59 Sign
: Array [0..4] of Char;
70 // Читаем файл и ресурс в нем:
71 g_ProcessResourceStr(Res
, WADName
, SectionName
, ResourceName
);
73 WAD
:= TWADEditor_1
.Create();
75 if (not WAD
.ReadFile(WADName
)) or
76 (not WAD
.GetResource(utf2win(SectionName
), utf2win(ResourceName
), Data
, Size
)) then
84 // Проверка сигнатуры. Если есть - это WAD внутри WAD:
85 CopyMemory(@Sign
[0], Data
, 5);
87 if not (Sign
= DFWAD_SIGNATURE
) then
94 // Пробуем прочитать данные:
95 if not WAD
.ReadMemory(Data
, Size
) then
105 Sections
:= WAD
.GetSectionList();
107 if Sections
= nil then
113 // Ищем в секциях "TEXT":
115 for a
:= 0 to High(Sections
) do
116 if Sections
[a
] = 'TEXT' then
122 // Ищем в секциях лист текстур - "TEXTURES":
123 for a
:= 0 to High(Sections
) do
124 if Sections
[a
] = 'TEXTURES' then
136 // Получаем ресурсы секции "TEXT":
137 Resources
:= WAD
.GetResourcesList('TEXT');
139 if Resources
= nil then
145 // Ищем в них описание анимации - "AINM":
147 for a
:= 0 to High(Resources
) do
148 if Resources
[a
] = 'ANIM' then
156 // Если все получилось, то это аним. текстура:
160 function GetFrame(Res
: String; var Data
: Pointer; var DataLen
: Integer;
161 var Width
, Height
: Word): Boolean;
167 ResourceName
: String;
179 g_ProcessResourceStr(Res
, WADName
, SectionName
, ResourceName
);
181 WAD
:= TWADEditor_1
.Create();
183 if not WAD
.ReadFile(WADName
) then
189 // Читаем WAD-ресурс из WAD:
190 if not WAD
.GetResource(utf2win(SectionName
), utf2win(ResourceName
), AnimWAD
, Len
) then
198 // Читаем WAD в WAD'е:
199 if not WAD
.ReadMemory(AnimWAD
, Len
) then
206 // Читаем описание анимации:
207 if not WAD
.GetResource('TEXT', 'ANIM', TextData
, Len
) then
215 config
:= TConfig
.CreateMem(TextData
, Len
);
217 // Читаем ресурс - лист текстур:
218 if not WAD
.GetResource('TEXTURES', config
.ReadStr('', 'resource', ''), Data
, Len
) then
228 Height
:= config
.ReadInt('', 'frameheight', 0);
229 Width
:= config
.ReadInt('', 'framewidth', 0);
240 function CreateBitMap(Data
: Pointer; DataSize
: Cardinal): TBitMap
;
255 if not LoadImageFromMemory(Data
, DataSize
, img
) then
259 Height
:= img
.height
;
261 BitMap
:= TBitMap
.Create();
262 BitMap
.PixelFormat
:= pf24bit
;
264 BitMap
.Width
:= Width
;
265 BitMap
.Height
:= Height
;
267 // Копируем в BitMap:
268 ii
:= BitMap
.RawImage
.Data
;
269 for y
:= 0 to height
-1 do
271 for x
:= 0 to width
-1 do
273 clr
:= GetPixel32(img
, x
, y
);
274 // HACK: Lazarus's TBitMap doesn't seem to have a working 32 bit mode, so
275 // mix color with checkered background. Also, can't really read
276 // CHECKERS.tga from here. FUCK!
277 if UseCheckerboard
then
279 if (((x
shr 3) and 1) = 0) xor (((y
shr 3) and 1) = 0) then
282 bgc
.Color
:= $CBCBCB;
286 bgc
.r
:= GetRValue(PreviewColor
);
287 bgc
.g
:= GetGValue(PreviewColor
);
288 bgc
.b
:= GetBValue(PreviewColor
);
290 clr
.r
:= ClampToByte((Byte(255 - clr
.a
) * bgc
.r
+ clr
.a
* clr
.r
) div 255);
291 clr
.g
:= ClampToByte((Byte(255 - clr
.a
) * bgc
.g
+ clr
.a
* clr
.g
) div 255);
292 clr
.b
:= ClampToByte((Byte(255 - clr
.a
) * bgc
.b
+ clr
.a
* clr
.b
) div 255);
293 // TODO: check for RGB/BGR somehow?
294 ii
^ := clr
.b
; Inc(ii
);
295 ii
^ := clr
.g
; Inc(ii
);
296 ii
^ := clr
.r
; Inc(ii
);
303 function ShowAnim(Res
: String): TBitMap
;
309 ResourceName
: String;
313 TextureData
: Pointer;
322 // Читаем WAD файл и ресурс в нем:
323 g_ProcessResourceStr(Res
, WADName
, SectionName
, ResourceName
);
325 WAD
:= TWADEditor_1
.Create();
326 WAD
.ReadFile(WADName
);
327 WAD
.GetResource(utf2win(SectionName
), utf2win(ResourceName
), AnimWAD
, Len
);
330 // Читаем описание анимации:
331 WAD
.ReadMemory(AnimWAD
, Len
);
332 WAD
.GetResource('TEXT', 'ANIM', TextData
, Len
);
334 config
:= TConfig
.CreateMem(TextData
, Len
);
336 // Читаем лист текстур:
337 WAD
.GetResource('TEXTURES', config
.ReadStr('', 'resource', ''), TextureData
, Len
);
339 if (TextureData
<> nil) and
340 (WAD
.GetLastError
= DFWAD_NOERROR
) then
342 // Создаем BitMap из листа текстур:
343 Result
:= CreateBitMap(TextureData
, Len
);
345 // Размеры одного кадра - виден только первый кадр:
346 Result
.Height
:= config
.ReadInt('', 'frameheight', 0);
347 Result
.Width
:= config
.ReadInt('', 'framewidth', 0);
353 FreeMem(TextureData
);
358 function ShowTGATexture(ResourceStr
: String): TBitMap
;
360 TextureData
: Pointer;
364 ResourceName
: String;
373 g_ProcessResourceStr(ResourceStr
, WADName
, SectionName
, ResourceName
);
375 WAD
:= TWADEditor_1
.Create();
376 if not WAD
.ReadFile(WADName
) then
382 // Читаем ресурс текстуры в нем:
383 WAD
.GetResource(utf2win(SectionName
), utf2win(ResourceName
), TextureData
, Len
);
387 // Создаем на его основе BitMap:
388 Result
:= CreateBitMap(TextureData
, Len
);
390 FreeMem(TextureData
);
393 procedure TAddTextureForm
.FormActivate(Sender
: TObject
);
397 cbWADList
.Items
.Add(_lc
[I_WAD_SPECIAL_TEXS
]);
399 eTextureName
.Text := '';
400 iPreview
.Canvas
.FillRect(iPreview
.Canvas
.ClipRect
);
402 bOK
.Visible
:= False;
403 bCancel
.Visible
:= False;
406 procedure TAddTextureForm
.lbResourcesListClick(Sender
: TObject
);
414 if lbResourcesList
.ItemIndex
= -1 then
416 if FResourceName
= '' then
418 if cbWADList
.Text = _lc
[I_WAD_SPECIAL_TEXS
] then
421 g_ProcessResourceStr(FFullResourceName
, @wad
, nil, nil);
422 if wad
= _lc
[I_WAD_SPECIAL_TEXS
] then
425 if IsAnim(FFullResourceName
) then
426 Texture
:= ShowAnim(FFullResourceName
)
428 Texture
:= ShowTGATexture(FFullResourceName
);
430 if Texture
= nil then
432 iPreview
.Canvas
.FillRect(iPreview
.Canvas
.ClipRect
);
433 iPreview
.Canvas
.CopyRect(Texture
.Canvas
.ClipRect
, Texture
.Canvas
, Texture
.Canvas
.ClipRect
);
437 procedure TAddTextureForm
.eTextureNameChange(Sender
: TObject
);
443 // Убираем старые выделения:
444 for a
:= 0 to lbResourcesList
.Items
.Count
-1 do
445 lbResourcesList
.Selected
[a
] := False;
448 if (lbResourcesList
.Items
.Count
= 0) or
449 (eTextureName
.Text = '') then
454 for a
:= 0 to lbResourcesList
.Items
.Count
-1 do
455 if LowerCase(Copy(lbResourcesList
.Items
[a
], 1,
456 Length(eTextureName
.Text))) =
457 LowerCase(eTextureName
.Text) then
459 lbResourcesList
.Selected
[a
] := True;
463 // Показываем первую текстуру из найденных:
464 lbResourcesList
.TopIndex
:= a
;
465 lbResourcesList
.OnClick(nil);
472 procedure TAddTextureForm
.cbWADListChange(Sender
: TObject
);
474 if cbWADList
.Text = _lc
[I_WAD_SPECIAL_TEXS
] then
476 cbSectionsList
.Clear();
477 cbSectionsList
.Items
.Add('..');
484 procedure TAddTextureForm
.cbSectionsListChange(Sender
: TObject
);
486 if cbWADList
.Text = _lc
[I_WAD_SPECIAL_TEXS
] then
488 lbResourcesList
.Clear();
489 lbResourcesList
.Items
.Add(TEXTURE_NAME_WATER
);
490 lbResourcesList
.Items
.Add(TEXTURE_NAME_ACID1
);
491 lbResourcesList
.Items
.Add(TEXTURE_NAME_ACID2
);
498 procedure TAddTextureForm
.bCloseClick(Sender
: TObject
);
503 procedure TAddTextureForm
.bAddTextureClick(Sender
: TObject
);
508 for i
:= 0 to lbResourcesList
.Count
-1 do
509 if lbResourcesList
.Selected
[i
] then
511 AddTexture(cbWADlist
.Text, cbSectionsList
.Text,
512 lbResourcesList
.Items
[i
], False);
513 lbResourcesList
.Selected
[i
] := False;
517 procedure TAddTextureForm
.bAddCloseClick(Sender
: TObject
);
519 bAddTextureClick(bAddTexture
);