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
,
52 g_language
, e_Log
, g_resources
;
56 function IsAnim(Res
: String): Boolean;
60 WADName
, SectionName
, ResourceName
: String;
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;
71 function GetFrame (Res
: String; var Data
: Pointer; var DataLen
: Integer; var Width
, Height
: Word): Boolean;
75 WADName
, SectionName
, ResourceName
: String;
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
83 config
:= TConfig
.CreateMem(TextData
, Len
);
84 g_ReadSubResource(WADName
, SectionName
, ResourceName
, 'TEXTURES', config
.ReadStr('', 'resource', ''), Data
, DataLen
);
87 Height
:= config
.ReadInt('', 'frameheight', 0);
88 Width
:= config
.ReadInt('', 'framewidth', 0);
96 function CreateBitMap (Data
: Pointer; DataSize
: Cardinal): TBitMap
;
99 clr
, bgc
: TColor32Rec
;
100 Width
, Height
: Integer;
106 if not LoadImageFromMemory(Data
, DataSize
, img
) then
110 Height
:= img
.height
;
111 BitMap
:= TBitMap
.Create();
112 BitMap
.PixelFormat
:= pf24bit
;
113 BitMap
.Width
:= Width
;
114 BitMap
.Height
:= Height
;
115 for y
:= 0 to Height
- 1 do
117 for x
:= 0 to Width
- 1 do
119 clr
:= GetPixel32(img
, x
, y
);
120 // HACK: Lazarus's TBitMap doesn't seem to have a working 32 bit mode, so
121 // mix color with checkered background. Also, can't really read
122 // CHECKERS.tga from here. FUCK!
123 if UseCheckerboard
then
125 if (((x
shr 3) and 1) = 0) xor (((y
shr 3) and 1) = 0) then
132 bgc
.r
:= GetRValue(PreviewColor
);
133 bgc
.g
:= GetGValue(PreviewColor
);
134 bgc
.b
:= GetBValue(PreviewColor
)
136 clr
.r
:= ClampToByte((Byte(255 - clr
.a
) * bgc
.r
+ clr
.a
* clr
.r
) div 255);
137 clr
.g
:= ClampToByte((Byte(255 - clr
.a
) * bgc
.g
+ clr
.a
* clr
.g
) div 255);
138 clr
.b
:= ClampToByte((Byte(255 - clr
.a
) * bgc
.b
+ clr
.a
* clr
.b
) div 255);
139 BitMap
.Canvas
.Pixels
[x
, y
] := RGBToColor(clr
.r
, clr
.g
, clr
.b
)
146 function ShowAnim(Res
: String): TBitMap
;
149 TextData
, TextureData
: Pointer;
150 WADName
, SectionName
, ResourceName
: String;
154 g_ProcessResourceStr(Res
, WADName
, SectionName
, ResourceName
);
155 g_ReadSubResource(WADName
, SectionName
, ResourceName
, 'TEXT', 'ANIM', TextData
, Len
);
156 if TextData
<> nil then
158 config
:= TConfig
.CreateMem(TextData
, Len
);
159 g_ReadSubResource(WADName
, SectionName
, ResourceName
, 'TEXTURES', config
.ReadStr('', 'resource', ''), TextureData
, Len
);
160 if TextureData
<> nil then
162 Result
:= CreateBitMap(TextureData
, Len
);
163 (* view only first frame *)
164 NumFrames
:= config
.ReadInt('', 'framecount', 0);
165 Result
.Height
:= config
.ReadInt('', 'frameheight', 0);
166 Result
.Width
:= config
.ReadInt('', 'framewidth', 0);
174 function ShowTGATexture(ResourceStr
: String): TBitMap
;
177 TextureData
: Pointer;
178 WADName
, SectionName
, ResourceName
: String;
181 g_ProcessResourceStr(ResourceStr
, WADName
, SectionName
, ResourceName
);
182 g_ReadResource(WADName
, SectionName
, ResourceName
, TextureData
, Len
);
183 if TextureData
<> nil then
184 Result
:= CreateBitMap(TextureData
, Len
)
187 procedure TAddTextureForm
.FormActivate(Sender
: TObject
);
191 lStats
.Caption
:= '';
192 cbWADList
.Items
.Add(_lc
[I_WAD_SPECIAL_TEXS
]);
194 eTextureName
.Text := '';
195 iPreview
.Canvas
.FillRect(iPreview
.Canvas
.ClipRect
);
197 bOK
.Visible
:= False;
198 bCancel
.Visible
:= False;
201 procedure TAddTextureForm
.lbResourcesListClick(Sender
: TObject
);
210 lStats
.Caption
:= '';
211 if lbResourcesList
.ItemIndex
= -1 then
213 if FResourceName
= '' then
215 if cbWADList
.Text = _lc
[I_WAD_SPECIAL_TEXS
] then
218 g_ProcessResourceStr(FFullResourceName
, @wad
, nil, nil);
219 if wad
= _lc
[I_WAD_SPECIAL_TEXS
] then
222 Anim
:= IsAnim(FFullResourceName
);
224 Texture
:= ShowAnim(FFullResourceName
)
226 Texture
:= ShowTGATexture(FFullResourceName
);
228 if Texture
= nil then
232 lStats
.Caption
:= Format(_lc
[I_CAP_ANIMATION
], [Texture
.Width
, Texture
.Height
, NumFrames
])
234 lStats
.Caption
:= Format(_lc
[I_CAP_TEXTURE
], [Texture
.Width
, Texture
.Height
]);
236 iPreview
.Canvas
.FillRect(iPreview
.Canvas
.ClipRect
);
237 iPreview
.Canvas
.CopyRect(Texture
.Canvas
.ClipRect
, Texture
.Canvas
, Texture
.Canvas
.ClipRect
);
241 procedure TAddTextureForm
.eTextureNameChange(Sender
: TObject
);
247 // Убираем старые выделения:
248 for a
:= 0 to lbResourcesList
.Items
.Count
-1 do
249 lbResourcesList
.Selected
[a
] := False;
252 if (lbResourcesList
.Items
.Count
= 0) or
253 (eTextureName
.Text = '') then
258 for a
:= 0 to lbResourcesList
.Items
.Count
-1 do
259 if LowerCase(Copy(lbResourcesList
.Items
[a
], 1,
260 Length(eTextureName
.Text))) =
261 LowerCase(eTextureName
.Text) then
263 lbResourcesList
.Selected
[a
] := True;
267 // Показываем первую текстуру из найденных:
268 lbResourcesList
.TopIndex
:= a
;
269 lbResourcesList
.OnClick(nil);
276 procedure TAddTextureForm
.cbWADListChange(Sender
: TObject
);
278 if cbWADList
.Text = _lc
[I_WAD_SPECIAL_TEXS
] then
280 cbSectionsList
.Clear();
281 cbSectionsList
.Items
.Add('..');
288 procedure TAddTextureForm
.cbSectionsListChange(Sender
: TObject
);
290 if cbWADList
.Text = _lc
[I_WAD_SPECIAL_TEXS
] then
292 lbResourcesList
.Clear();
293 lbResourcesList
.Items
.Add(TEXTURE_NAME_WATER
);
294 lbResourcesList
.Items
.Add(TEXTURE_NAME_ACID1
);
295 lbResourcesList
.Items
.Add(TEXTURE_NAME_ACID2
);
302 procedure TAddTextureForm
.bCloseClick(Sender
: TObject
);
307 procedure TAddTextureForm
.bAddTextureClick(Sender
: TObject
);
312 for i
:= 0 to lbResourcesList
.Count
-1 do
313 if lbResourcesList
.Selected
[i
] then
315 AddTexture(cbWADlist
.Text, cbSectionsList
.Text,
316 lbResourcesList
.Items
[i
], False);
317 lbResourcesList
.Selected
[i
] := False;
321 procedure TAddTextureForm
.bAddCloseClick(Sender
: TObject
);
323 bAddTextureClick(bAddTexture
);