index f9ebe0a83fc499ab110bf1718250b61d94178f0a..f3b3fade582900933aa608f587fe3c23e9479b12 100644 (file)
unit f_addresource_texture;
unit f_addresource_texture;
-{$MODE Delphi}
+{$INCLUDE ../shared/a_modes.inc}
interface
uses
LCLIntf, LCLType, LMessages, SysUtils, Variants, Classes,
Graphics, Controls, Forms, Dialogs, f_addresource,
interface
uses
LCLIntf, LCLType, LMessages, SysUtils, Variants, Classes,
Graphics, Controls, Forms, Dialogs, f_addresource,
- StdCtrls, ExtCtrls;
+ StdCtrls, ExtCtrls, utils, Imaging, ImagingTypes, ImagingUtility;
type
TAddTextureForm = class (TAddResourceForm)
type
TAddTextureForm = class (TAddResourceForm)
AddTextureForm: TAddTextureForm;
function IsAnim(Res: String): Boolean;
AddTextureForm: TAddTextureForm;
function IsAnim(Res: String): Boolean;
-function GetFrame(Res: String; var Data: Pointer;
+function GetFrame(Res: String; var Data: Pointer; var DataLen: Integer;
var Width, Height: Word): Boolean;
implementation
uses
var Width, Height: Word): Boolean;
implementation
uses
- BinEditor, WADEDITOR, f_main, g_textures, WADSTRUCT, CONFIG, g_map,
+ BinEditor, WADEDITOR, WADSTRUCT, f_main, g_textures, CONFIG, g_map,
g_language;
g_language;
-type
- TTGAHeader = packed record
- FileType: Byte;
- ColorMapType: Byte;
- ImageType: Byte;
- ColorMapSpec: Array [0..4] of Byte;
- OrigX: Array [0..1] of Byte;
- OrigY: Array [0..1] of Byte;
- Width: Array [0..1] of Byte;
- Height: Array [0..1] of Byte;
- BPP: Byte;
- ImageInfo: Byte;
- end;
-
{$R *.lfm}
function IsAnim(Res: String): Boolean;
{$R *.lfm}
function IsAnim(Res: String): Boolean;
Result := ok;
end;
Result := ok;
end;
-function GetFrame(Res: String; var Data: Pointer;
+function GetFrame(Res: String; var Data: Pointer; var DataLen: Integer;
var Width, Height: Word): Boolean;
var
AnimWAD: Pointer;
var Width, Height: Word): Boolean;
var
AnimWAD: Pointer;
Exit;
end;
Exit;
end;
+ DataLen := Len;
+
Height := config.ReadInt('', 'frameheight', 0);
Width := config.ReadInt('', 'framewidth', 0);
Height := config.ReadInt('', 'frameheight', 0);
Width := config.ReadInt('', 'framewidth', 0);
Result := True;
end;
Result := True;
end;
-function CreateBitMap(Data: Pointer): TBitMap;
+function CreateBitMap(Data: Pointer; DataSize: Cardinal): TBitMap;
var
var
- TGAHeader: TTGAHeader;
- image: Pointer;
+ img: TImageData;
+ clr: TColor32Rec;
+ bgc: Byte;
+ ii: PByte;
Width,
Height: Integer;
Width,
Height: Integer;
- ColorDepth: Integer;
- ImageSize: Integer;
- i: Integer;
+ x, y: Integer;
BitMap: TBitMap;
begin
Result := nil;
BitMap: TBitMap;
begin
Result := nil;
-// Читаем заголовок TGA:
- CopyMemory(@TGAHeader, Data, SizeOf(TGAHeader));
-
- if TGAHeader.ImageType <> 2 then
+ InitImage(img);
+ if not LoadImageFromMemory(Data, DataSize, img) then
Exit;
Exit;
- if TGAHeader.ColorMapType <> 0 then
- Exit;
- if TGAHeader.BPP < 24 then
- Exit;
-
- Width := TGAHeader.Width[0]+TGAHeader.Width[1]*256;
- Height := TGAHeader.Height[0]+TGAHeader.Height[1]*256;
- ColorDepth := TGAHeader.BPP;
- ImageSize := Width*Height*(ColorDepth div 8);
-
-// Само изображение:
- GetMem(Image, ImageSize);
- CopyMemory(Image, Pointer(Integer(Data)+SizeOf(TGAHeader)), ImageSize);
+ Width := img.width;
+ Height := img.height;
BitMap := TBitMap.Create();
BitMap := TBitMap.Create();
-
- if TGAHeader.BPP = 24 then
- BitMap.PixelFormat := pf24bit
- else
- BitMap.PixelFormat := pf32bit;
+ BitMap.PixelFormat := pf24bit;
BitMap.Width := Width;
BitMap.Height := Height;
// Копируем в BitMap:
BitMap.Width := Width;
BitMap.Height := Height;
// Копируем в BitMap:
- for I := Height-1 downto 0 do
- CopyMemory(BitMap.ScanLine[Height-1-I],
- Pointer(Integer(Image)+(Width*I*(TGAHeader.BPP div 8))),
- Width*(TGAHeader.BPP div 8));
-
- FreeMem(Image, ImageSize);
-
+ ii := BitMap.RawImage.Data;
+ for y := 0 to height-1 do
+ begin
+ for x := 0 to width-1 do
+ begin
+ clr := GetPixel32(img, x, y);
+ // HACK: Lazarus's TBitMap doesn't seem to have a working 32 bit mode, so
+ // mix color with checkered background. Also, can't really read
+ // CHECKERS.tga from here. FUCK!
+ if (((x shr 3) and 1) = 0) xor (((y shr 3) and 1) = 0) then
+ bgc := 255
+ else
+ bgc := 200;
+ clr.r := ClampToByte(((255 - clr.a) * bgc + clr.a * clr.r) div 255);
+ clr.g := ClampToByte(((255 - clr.a) * bgc + clr.a * clr.g) div 255);
+ clr.b := ClampToByte(((255 - clr.a) * bgc + clr.a * clr.b) div 255);
+ // TODO: check for RGB/BGR somehow?
+ ii^ := clr.b; Inc(ii);
+ ii^ := clr.g; Inc(ii);
+ ii^ := clr.r; Inc(ii);
+ end;
+ end;
+ FreeImage(img);
Result := BitMap;
end;
Result := BitMap;
end;
(WAD.GetLastError = DFWAD_NOERROR) then
begin
// Создаем BitMap из листа текстур:
(WAD.GetLastError = DFWAD_NOERROR) then
begin
// Создаем BitMap из листа текстур:
- Result := CreateBitMap(TextureData);
+ Result := CreateBitMap(TextureData, Len);
// Размеры одного кадра - виден только первый кадр:
Result.Height := config.ReadInt('', 'frameheight', 0);
// Размеры одного кадра - виден только первый кадр:
Result.Height := config.ReadInt('', 'frameheight', 0);
WAD.Free();
// Создаем на его основе BitMap:
WAD.Free();
// Создаем на его основе BitMap:
- Result := CreateBitMap(TextureData);
+ Result := CreateBitMap(TextureData, Len);
- FreeMem(TextureData, Len);
+ FreeMem(TextureData);
end;
procedure TAddTextureForm.FormActivate(Sender: TObject);
end;
procedure TAddTextureForm.FormActivate(Sender: TObject);
for i := 0 to lbResourcesList.Count-1 do
if lbResourcesList.Selected[i] then
begin
for i := 0 to lbResourcesList.Count-1 do
if lbResourcesList.Selected[i] then
begin
- AddTexture(cbWADlist.Text, cbSectionsList.Text,
- lbResourcesList.Items[i], False);
+ AddTexture(utf2win(cbWADlist.Text), utf2win(cbSectionsList.Text),
+ utf2win(lbResourcesList.Items[i]), False);
lbResourcesList.Selected[i] := False;
end;
end;
lbResourcesList.Selected[i] := False;
end;
end;