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;
64 Sign
: Array [0..4] of Char;
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 // Проверка сигнатуры. Если есть - это WAD внутри WAD:
90 CopyMemory(@Sign
[0], Data
, 5);
92 if not (Sign
= DFWAD_SIGNATURE
) then
99 // Пробуем прочитать данные:
100 if not WAD
.ReadMemory(Data
, Size
) then
110 Sections
:= WAD
.GetSectionList();
112 if Sections
= nil then
118 // Ищем в секциях "TEXT":
120 for a
:= 0 to High(Sections
) do
121 if Sections
[a
] = 'TEXT' then
127 // Ищем в секциях лист текстур - "TEXTURES":
128 for a
:= 0 to High(Sections
) do
129 if Sections
[a
] = 'TEXTURES' then
141 // Получаем ресурсы секции "TEXT":
142 Resources
:= WAD
.GetResourcesList('TEXT');
144 if Resources
= nil then
150 // Ищем в них описание анимации - "ANIM":
152 for a
:= 0 to High(Resources
) do
153 if Resources
[a
] = 'ANIM' then
161 // Если все получилось, то это аним. текстура:
165 function GetFrame(Res
: String; var Data
: Pointer; var DataLen
: Integer;
166 var Width
, Height
: Word): Boolean;
172 ResourceName
: String;
184 g_ProcessResourceStr(Res
, WADName
, SectionName
, ResourceName
);
186 WAD
:= TWADEditor_1
.Create();
188 if not WAD
.ReadFile(WADName
) then
194 // Читаем WAD-ресурс из WAD:
195 if not WAD
.GetResource(utf2win(SectionName
), utf2win(ResourceName
), AnimWAD
, Len
) then
203 // Читаем WAD в WAD'е:
204 if not WAD
.ReadMemory(AnimWAD
, Len
) then
211 // Читаем описание анимации:
212 if not WAD
.GetResource('TEXT', 'ANIM', TextData
, Len
) then
220 config
:= TConfig
.CreateMem(TextData
, Len
);
222 // Читаем ресурс - лист текстур:
223 if not WAD
.GetResource('TEXTURES', config
.ReadStr('', 'resource', ''), Data
, Len
) then
233 Height
:= config
.ReadInt('', 'frameheight', 0);
234 Width
:= config
.ReadInt('', 'framewidth', 0);
245 function CreateBitMap(Data
: Pointer; DataSize
: Cardinal): TBitMap
;
260 if not LoadImageFromMemory(Data
, DataSize
, img
) then
264 Height
:= img
.height
;
266 BitMap
:= TBitMap
.Create();
267 BitMap
.PixelFormat
:= pf24bit
;
269 BitMap
.Width
:= Width
;
270 BitMap
.Height
:= Height
;
272 // Копируем в BitMap:
273 ii
:= BitMap
.RawImage
.Data
;
274 for y
:= 0 to height
-1 do
276 for x
:= 0 to width
-1 do
278 clr
:= GetPixel32(img
, x
, y
);
279 // HACK: Lazarus's TBitMap doesn't seem to have a working 32 bit mode, so
280 // mix color with checkered background. Also, can't really read
281 // CHECKERS.tga from here. FUCK!
282 if UseCheckerboard
then
284 if (((x
shr 3) and 1) = 0) xor (((y
shr 3) and 1) = 0) then
287 bgc
.Color
:= $CBCBCB;
291 bgc
.r
:= GetRValue(PreviewColor
);
292 bgc
.g
:= GetGValue(PreviewColor
);
293 bgc
.b
:= GetBValue(PreviewColor
);
295 clr
.r
:= ClampToByte((Byte(255 - clr
.a
) * bgc
.r
+ clr
.a
* clr
.r
) div 255);
296 clr
.g
:= ClampToByte((Byte(255 - clr
.a
) * bgc
.g
+ clr
.a
* clr
.g
) div 255);
297 clr
.b
:= ClampToByte((Byte(255 - clr
.a
) * bgc
.b
+ clr
.a
* clr
.b
) div 255);
298 // TODO: check for RGB/BGR somehow?
299 ii
^ := clr
.b
; Inc(ii
);
300 ii
^ := clr
.g
; Inc(ii
);
301 ii
^ := clr
.r
; Inc(ii
);
303 (* Why this works in linux? *)
304 {$IFNDEF WINDOWS}Inc(ii
){$ENDIF}
311 function ShowAnim(Res
: String): TBitMap
;
317 ResourceName
: String;
321 TextureData
: Pointer;
330 // Читаем WAD файл и ресурс в нем:
331 g_ProcessResourceStr(Res
, WADName
, SectionName
, ResourceName
);
333 WAD
:= TWADEditor_1
.Create();
334 WAD
.ReadFile(WADName
);
335 WAD
.GetResource(utf2win(SectionName
), utf2win(ResourceName
), AnimWAD
, Len
);
338 // Читаем описание анимации:
339 WAD
.ReadMemory(AnimWAD
, Len
);
340 WAD
.GetResource('TEXT', 'ANIM', TextData
, Len
);
342 config
:= TConfig
.CreateMem(TextData
, Len
);
344 // Читаем лист текстур:
345 WAD
.GetResource('TEXTURES', config
.ReadStr('', 'resource', ''), TextureData
, Len
);
346 NumFrames
:= config
.ReadInt('', 'framecount', 0);
348 if (TextureData
<> nil) and
349 (WAD
.GetLastError
= DFWAD_NOERROR
) then
351 // Создаем BitMap из листа текстур:
352 Result
:= CreateBitMap(TextureData
, Len
);
354 // Размеры одного кадра - виден только первый кадр:
355 Result
.Height
:= config
.ReadInt('', 'frameheight', 0);
356 Result
.Width
:= config
.ReadInt('', 'framewidth', 0);
362 FreeMem(TextureData
);
367 function ShowTGATexture(ResourceStr
: String): TBitMap
;
369 TextureData
: Pointer;
373 ResourceName
: String;
382 g_ProcessResourceStr(ResourceStr
, WADName
, SectionName
, ResourceName
);
384 WAD
:= TWADEditor_1
.Create();
385 if not WAD
.ReadFile(WADName
) then
391 // Читаем ресурс текстуры в нем:
392 WAD
.GetResource(utf2win(SectionName
), utf2win(ResourceName
), TextureData
, Len
);
396 // Создаем на его основе BitMap:
397 Result
:= CreateBitMap(TextureData
, Len
);
399 FreeMem(TextureData
);
402 procedure TAddTextureForm
.FormActivate(Sender
: TObject
);
406 lStats
.Caption
:= '';
407 cbWADList
.Items
.Add(_lc
[I_WAD_SPECIAL_TEXS
]);
409 eTextureName
.Text := '';
410 iPreview
.Canvas
.FillRect(iPreview
.Canvas
.ClipRect
);
412 bOK
.Visible
:= False;
413 bCancel
.Visible
:= False;
416 procedure TAddTextureForm
.lbResourcesListClick(Sender
: TObject
);
425 lStats
.Caption
:= '';
426 if lbResourcesList
.ItemIndex
= -1 then
428 if FResourceName
= '' then
430 if cbWADList
.Text = _lc
[I_WAD_SPECIAL_TEXS
] then
433 g_ProcessResourceStr(FFullResourceName
, @wad
, nil, nil);
434 if wad
= _lc
[I_WAD_SPECIAL_TEXS
] then
437 Anim
:= IsAnim(FFullResourceName
);
439 Texture
:= ShowAnim(FFullResourceName
)
441 Texture
:= ShowTGATexture(FFullResourceName
);
443 if Texture
= nil then
447 lStats
.Caption
:= Format(_lc
[I_CAP_ANIMATION
], [Texture
.Width
, Texture
.Height
, NumFrames
])
449 lStats
.Caption
:= Format(_lc
[I_CAP_TEXTURE
], [Texture
.Width
, Texture
.Height
]);
451 iPreview
.Canvas
.FillRect(iPreview
.Canvas
.ClipRect
);
452 iPreview
.Canvas
.CopyRect(Texture
.Canvas
.ClipRect
, Texture
.Canvas
, Texture
.Canvas
.ClipRect
);
456 procedure TAddTextureForm
.eTextureNameChange(Sender
: TObject
);
462 // Убираем старые выделения:
463 for a
:= 0 to lbResourcesList
.Items
.Count
-1 do
464 lbResourcesList
.Selected
[a
] := False;
467 if (lbResourcesList
.Items
.Count
= 0) or
468 (eTextureName
.Text = '') then
473 for a
:= 0 to lbResourcesList
.Items
.Count
-1 do
474 if LowerCase(Copy(lbResourcesList
.Items
[a
], 1,
475 Length(eTextureName
.Text))) =
476 LowerCase(eTextureName
.Text) then
478 lbResourcesList
.Selected
[a
] := True;
482 // Показываем первую текстуру из найденных:
483 lbResourcesList
.TopIndex
:= a
;
484 lbResourcesList
.OnClick(nil);
491 procedure TAddTextureForm
.cbWADListChange(Sender
: TObject
);
493 if cbWADList
.Text = _lc
[I_WAD_SPECIAL_TEXS
] then
495 cbSectionsList
.Clear();
496 cbSectionsList
.Items
.Add('..');
503 procedure TAddTextureForm
.cbSectionsListChange(Sender
: TObject
);
505 if cbWADList
.Text = _lc
[I_WAD_SPECIAL_TEXS
] then
507 lbResourcesList
.Clear();
508 lbResourcesList
.Items
.Add(TEXTURE_NAME_WATER
);
509 lbResourcesList
.Items
.Add(TEXTURE_NAME_ACID1
);
510 lbResourcesList
.Items
.Add(TEXTURE_NAME_ACID2
);
517 procedure TAddTextureForm
.bCloseClick(Sender
: TObject
);
522 procedure TAddTextureForm
.bAddTextureClick(Sender
: TObject
);
527 for i
:= 0 to lbResourcesList
.Count
-1 do
528 if lbResourcesList
.Selected
[i
] then
530 AddTexture(cbWADlist
.Text, cbSectionsList
.Text,
531 lbResourcesList
.Items
[i
], False);
532 lbResourcesList
.Selected
[i
] := False;
536 procedure TAddTextureForm
.bAddCloseClick(Sender
: TObject
);
538 bAddTextureClick(bAddTexture
);