WebSVN – spacemission – Blame – /VCL_DELPHIX_D6/DXTexImg.pas

Rev	Author	Line No.	Line
1	daniel-mar	1	unit DXTexImg;
		2
		3	interface
		4
		5	uses
		6	Windows, SysUtils, Classes, DXConsts;
		7
		8	const
		9	DXTextureImageGroupType_Normal = 0; // Normal group
		10	DXTextureImageGroupType_Mipmap = 1; // Mipmap group
		11
		12	type
		13	EDXTextureImageError = class(Exception);
		14
		15	TDXTextureImageChannel = record
		16	Mask: DWORD;
		17	BitCount: Integer;
		18
		19	{ Internal use }
		20	_Mask2: DWORD;
		21	_rshift: Integer;
		22	_lshift: Integer;
		23	_BitCount2: Integer;
		24	end;
		25
		26	TDXTextureImage_PaletteEntries = array[0..255] of TPaletteEntry;
		27
		28	TDXTextureImageType = (
		29	DXTextureImageType_PaletteIndexedColor,
		30	DXTextureImageType_RGBColor
		31	);
		32
		33	TDXTextureImage = class;
		34
		35	TDXTextureImageLoadFunc = procedure(Stream: TStream; Image: TDXTextureImage);
		36
		37	TDXTextureImage = class
		38	private
		39	FOwner: TDXTextureImage;
		40	FSubImage: TList;
		41	FImageType: TDXTextureImageType;
		42	FWidth: Integer;
		43	FHeight: Integer;
		44	FPBits: Pointer;
		45	FBitCount: Integer;
		46	FPackedPixelOrder: Boolean;
		47	FWidthBytes: Integer;
		48	FNextLine: Integer;
		49	FSize: Integer;
		50	FTopPBits: Pointer;
		51	FTransparent: Boolean;
		52	FTransparentColor: DWORD;
		53	FImageGroupType: DWORD;
		54	FImageID: DWORD;
		55	FImageName: string;
		56	FAutoFreeImage: Boolean;
		57	procedure ClearImage;
		58	function GetPixel(x, y: Integer): DWORD;
		59	procedure SetPixel(x, y: Integer; c: DWORD);
		60	function GetScanLine(y: Integer): Pointer;
		61	function GetSubGroupImageCount(GroupTypeID: DWORD): Integer;
		62	function GetSubGroupImage(GroupTypeID: DWORD; Index: Integer): TDXTextureImage;
		63	function GetSubImageCount: Integer;
		64	function GetSubImage(Index: Integer): TDXTextureImage;
		65	public
		66	idx_index: TDXTextureImageChannel;
		67	idx_alpha: TDXTextureImageChannel;
		68	idx_palette: TDXTextureImage_PaletteEntries;
		69	rgb_red: TDXTextureImageChannel;
		70	rgb_green: TDXTextureImageChannel;
		71	rgb_blue: TDXTextureImageChannel;
		72	rgb_alpha: TDXTextureImageChannel;
		73	constructor Create;
		74	constructor CreateSub(AOwner: TDXTextureImage);
		75	destructor Destroy; override;
		76	procedure Assign(Source: TDXTextureImage);
		77	procedure Clear;
		78	procedure SetImage(ImageType: TDXTextureImageType; Width, Height, BitCount, WidthBytes, NextLine: Integer;
		79	PBits, TopPBits: Pointer; Size: Integer; AutoFree: Boolean);
		80	procedure SetSize(ImageType: TDXTextureImageType; Width, Height, BitCount, WidthBytes: Integer);
		81	procedure LoadFromFile(const FileName: string);
		82	procedure LoadFromStream(Stream: TStream);
		83	procedure SaveToFile(const FileName: string);
		84	procedure SaveToStream(Stream: TStream);
		85	function EncodeColor(R, G, B, A: Byte): DWORD;
		86	function PaletteIndex(R, G, B: Byte): DWORD;
		87	class procedure RegisterLoadFunc(LoadFunc: TDXTextureImageLoadFunc);
		88	class procedure UnRegisterLoadFunc(LoadFunc: TDXTextureImageLoadFunc);
		89	property BitCount: Integer read FBitCount;
		90	property PackedPixelOrder: Boolean read FPackedPixelOrder write FPackedPixelOrder;
		91	property Height: Integer read FHeight;
		92	property ImageType: TDXTextureImageType read FImageType;
		93	property ImageGroupType: DWORD read FImageGroupType write FImageGroupType;
		94	property ImageID: DWORD read FImageID write FImageID;
		95	property ImageName: string read FImageName write FImageName;
		96	property NextLine: Integer read FNextLine;
		97	property PBits: Pointer read FPBits;
		98	property Pixels[x, y: Integer]: DWORD read GetPixel write SetPixel;
		99	property ScanLine[y: Integer]: Pointer read GetScanLine;
		100	property Size: Integer read FSize;
		101	property SubGroupImageCount[GroupTypeID: DWORD]: Integer read GetSubGroupImageCount;
		102	property SubGroupImages[GroupTypeID: DWORD; Index: Integer]: TDXTextureImage read GetSubGroupImage;
		103	property SubImageCount: Integer read GetSubImageCount;
		104	property SubImages[Index: Integer]: TDXTextureImage read GetSubImage;
		105	property TopPBits: Pointer read FTopPBits;
		106	property Transparent: Boolean read FTransparent write FTransparent;
		107	property TransparentColor: DWORD read FTransparentColor write FTransparentColor;
		108	property Width: Integer read FWidth;
		109	property WidthBytes: Integer read FWidthBytes;
		110	end;
		111
		112	function dxtMakeChannel(Mask: DWORD; indexed: Boolean): TDXTextureImageChannel;
		113	function dxtEncodeChannel(const Channel: TDXTextureImageChannel; c: DWORD): DWORD;
		114	function dxtDecodeChannel(const Channel: TDXTextureImageChannel; c: DWORD): DWORD;
		115
		116	implementation
		117
		118	function GetWidthBytes(Width, BitCount: Integer): Integer;
		119	begin
		120	Result := (((WidthBitCount)+31) div 32)4;
		121	end;
		122
		123	function dxtEncodeChannel(const Channel: TDXTextureImageChannel; c: DWORD): DWORD;
		124	begin
		125	Result := ((c shl Channel._rshift) shr Channel._lshift) and Channel.Mask;
		126	end;
		127
		128	function dxtDecodeChannel(const Channel: TDXTextureImageChannel; c: DWORD): DWORD;
		129	begin
		130	Result := ((c and Channel.Mask) shr Channel._rshift) shl Channel._lshift;
		131	Result := Result or (Result shr Channel._BitCount2);
		132	end;
		133
		134	function dxtMakeChannel(Mask: DWORD; indexed: Boolean): TDXTextureImageChannel;
		135
		136	function GetMaskBitCount(b: Integer): Integer;
		137	var
		138	i: Integer;
		139	begin
		140	i := 0;
		141	while (i<31) and (((1 shl i) and b)=0) do Inc(i);
		142
		143	Result := 0;
		144	while ((1 shl i) and b)<>0 do
		145	begin
		146	Inc(i);
		147	Inc(Result);
		148	end;
		149	end;
		150
		151	function GetBitCount2(b: Integer): Integer;
		152	begin
		153	Result := 0;
		154	while (Result<31) and (((1 shl Result) and b)=0) do Inc(Result);
		155	end;
		156
		157	begin
		158	Result.BitCount := GetMaskBitCount(Mask);
		159	Result.Mask := Mask;
		160
		161	if indexed then
		162	begin
		163	Result._rshift := GetBitCount2(Mask);
		164	Result._lshift := 0;
		165	Result._Mask2 := 1 shl Result.BitCount-1;
		166	Result._BitCount2 := 0;
		167	end else
		168	begin
		169	Result._rshift := GetBitCount2(Mask)-(8-Result.BitCount);
		170	if Result._rshift<0 then
		171	begin
		172	Result._lshift := -Result._rshift;
		173	Result._rshift := 0;
		174	end else
		175	Result._lshift := 0;
		176	Result._Mask2 := (1 shl Result.BitCount-1) shl (8-Result.BitCount);
		177	Result._BitCount2 := 8-Result.BitCount;
		178	end;
		179	end;
		180
		181	{ TDXTextureImage }
		182
		183	var
		184	_DXTextureImageLoadFuncList: TList;
		185
		186	procedure DXTextureImage_LoadDXTextureImageFunc(Stream: TStream; Image: TDXTextureImage); forward;
		187	procedure DXTextureImage_LoadBitmapFunc(Stream: TStream; Image: TDXTextureImage); forward;
		188
		189	function DXTextureImageLoadFuncList: TList;
		190	begin
		191	if _DXTextureImageLoadFuncList=nil then
		192	begin
		193	_DXTextureImageLoadFuncList := TList.Create;
		194	_DXTextureImageLoadFuncList.Add(@DXTextureImage_LoadDXTextureImageFunc);
		195	_DXTextureImageLoadFuncList.Add(@DXTextureImage_LoadBitmapFunc);
		196	end;
		197	Result := _DXTextureImageLoadFuncList;
		198	end;
		199
		200	class procedure TDXTextureImage.RegisterLoadFunc(LoadFunc: TDXTextureImageLoadFunc);
		201	begin
		202	if DXTextureImageLoadFuncList.IndexOf(@LoadFunc)=-1 then
		203	DXTextureImageLoadFuncList.Add(@LoadFunc);
		204	end;
		205
		206	class procedure TDXTextureImage.UnRegisterLoadFunc(LoadFunc: TDXTextureImageLoadFunc);
		207	begin
		208	DXTextureImageLoadFuncList.Remove(@LoadFunc);
		209	end;
		210
		211	constructor TDXTextureImage.Create;
		212	begin
		213	inherited Create;
		214	FSubImage := TList.Create;
		215	end;
		216
		217	constructor TDXTextureImage.CreateSub(AOwner: TDXTextureImage);
		218	begin
		219	Create;
		220
		221	FOwner := AOwner;
		222	try
		223	FOwner.FSubImage.Add(Self);
		224	except
		225	FOwner := nil;
		226	raise;
		227	end;
		228	end;
		229
		230	destructor TDXTextureImage.Destroy;
		231	begin
		232	Clear;
		233	FSubImage.Free;
		234	if FOwner<>nil then
		235	FOwner.FSubImage.Remove(Self);
		236	inherited Destroy;
		237	end;
		238
		239	procedure TDXTextureImage.Assign(Source: TDXTextureImage);
		240	var
		241	y: Integer;
		242	begin
		243	SetSize(Source.ImageType, Source.Width, Source.Height, Source.BitCount, Source.WidthBytes);
		244
		245	idx_index := Source.idx_index;
		246	idx_alpha := Source.idx_alpha;
		247	idx_palette := Source.idx_palette;
		248
		249	rgb_red := Source.rgb_red;
		250	rgb_green := Source.rgb_green;
		251	rgb_blue := Source.rgb_blue;
		252	rgb_alpha := Source.rgb_alpha;
		253
		254	for y:=0 to Height-1 do
		255	Move(Source.ScanLine[y]^, ScanLine[y]^, WidthBytes);
		256
		257	Transparent := Source.Transparent;
		258	TransparentColor := Source.TransparentColor;
		259	ImageGroupType := Source.ImageGroupType;
		260	ImageID := Source.ImageID;
		261	ImageName := Source.ImageName;
		262	end;
		263
		264	procedure TDXTextureImage.ClearImage;
		265	begin
		266	if FAutoFreeImage then
		267	FreeMem(FPBits);
		268
		269	FImageType := DXTextureImageType_PaletteIndexedColor;
		270	FWidth := 0;
		271	FHeight := 0;
		272	FBitCount := 0;
		273	FWidthBytes := 0;
		274	FNextLine := 0;
		275	FSize := 0;
		276	FPBits := nil;
		277	FTopPBits := nil;
		278	FAutoFreeImage := False;
		279	end;
		280
		281	procedure TDXTextureImage.Clear;
		282	begin
		283	ClearImage;
		284
		285	while SubImageCount>0 do
		286	SubImages[SubImageCount-1].Free;
		287
		288	FImageGroupType := 0;
		289	FImageID := 0;
		290	FImageName := '';
		291
		292	FTransparent := False;
		293	FTransparentColor := 0;
		294
		295	FillChar(idx_index, SizeOf(idx_index), 0);
		296	FillChar(idx_alpha, SizeOf(idx_alpha), 0);
		297	FillChar(idx_palette, SizeOf(idx_palette), 0);
		298	FillChar(rgb_red, SizeOf(rgb_red), 0);
		299	FillChar(rgb_green, SizeOf(rgb_green), 0);
		300	FillChar(rgb_blue, SizeOf(rgb_blue), 0);
		301	FillChar(rgb_alpha, SizeOf(rgb_alpha), 0);
		302	end;
		303
		304	procedure TDXTextureImage.SetImage(ImageType: TDXTextureImageType; Width, Height, BitCount, WidthBytes, NextLine: Integer;
		305	PBits, TopPBits: Pointer; Size: Integer; AutoFree: Boolean);
		306	begin
		307	ClearImage;
		308
		309	FAutoFreeImage := AutoFree;
		310	FImageType := ImageType;
		311	FWidth := Width;
		312	FHeight := Height;
		313	FBitCount := BitCount;
		314	FWidthBytes := WidthBytes;
		315	FNextLine := NextLine;
		316	FSize := Size;
		317	FPBits := PBits;
		318	FTopPBits := TopPBits;
		319	end;
		320
		321	procedure TDXTextureImage.SetSize(ImageType: TDXTextureImageType; Width, Height, BitCount, WidthBytes: Integer);
		322	var
		323	APBits: Pointer;
		324	begin
		325	ClearImage;
		326
		327	if WidthBytes=0 then
		328	WidthBytes := GetWidthBytes(Width, BitCount);
		329
		330	GetMem(APBits, WidthBytes*Height);
		331	SetImage(ImageType, Width, Height, BitCount, WidthBytes, WidthBytes, APBits, APBits, WidthBytes*Height, True);
		332	end;
		333
		334	function TDXTextureImage.GetScanLine(y: Integer): Pointer;
		335	begin
		336	Result := Pointer(Integer(FTopPBits)+FNextLine*y);
		337	end;
		338
		339	function TDXTextureImage.GetSubGroupImageCount(GroupTypeID: DWORD): Integer;
		340	var
		341	i: Integer;
		342	begin
		343	Result := 0;
		344	for i:=0 to SubImageCount-1 do
		345	if SubImages[i].ImageGroupType=GroupTypeID then
		346	Inc(Result);
		347	end;
		348
		349	function TDXTextureImage.GetSubGroupImage(GroupTypeID: DWORD; Index: Integer): TDXTextureImage;
		350	var
		351	i, j: Integer;
		352	begin
		353	j := 0;
		354	for i:=0 to SubImageCount-1 do
		355	if SubImages[i].ImageGroupType=GroupTypeID then
		356	begin
		357	if j=Index then
		358	begin
		359	Result := SubImages[i];
		360	Exit;
		361	end;
		362
		363	Inc(j);
		364	end;
		365
		366	Result := nil;
		367	SubImages[-1];
		368	end;
		369
		370	function TDXTextureImage.GetSubImageCount: Integer;
		371	begin
		372	Result := FSubImage.Count;
		373	end;
		374
		375	function TDXTextureImage.GetSubImage(Index: Integer): TDXTextureImage;
		376	begin
		377	Result := FSubImage[Index];
		378	end;
		379
		380	function TDXTextureImage.EncodeColor(R, G, B, A: Byte): DWORD;
		381	begin
		382	if ImageType=DXTextureImageType_PaletteIndexedColor then
		383	begin
		384	Result := dxtEncodeChannel(idx_index, PaletteIndex(R, G, B)) or
		385	dxtEncodeChannel(idx_alpha, A);
		386	end else
		387	begin
		388	Result := dxtEncodeChannel(rgb_red, R) or
		389	dxtEncodeChannel(rgb_green, G) or
		390	dxtEncodeChannel(rgb_blue, B) or
		391	dxtEncodeChannel(rgb_alpha, A);
		392	end;
		393	end;
		394
		395	function TDXTextureImage.PaletteIndex(R, G, B: Byte): DWORD;
		396	var
		397	i, d, d2: Integer;
		398	begin
		399	Result := 0;
		400	if ImageType=DXTextureImageType_PaletteIndexedColor then
		401	begin
		402	d := MaxInt;
		403	for i:=0 to (1 shl idx_index.BitCount)-1 do
		404	with idx_palette[i] do
		405	begin
		406	d2 := Abs((peRed-R))Abs((peRed-R)) + Abs((peGreen-G))Abs((peGreen-G)) + Abs((peBlue-B))*Abs((peBlue-B));
		407	if d>d2 then
		408	begin
		409	d := d2;
		410	Result := i;
		411	end;
		412	end;
		413	end;
		414	end;
		415
		416	const
		417	Mask1: array[0..7] of DWORD= (1, 2, 4, 8, 16, 32, 64, 128);
		418	Mask2: array[0..3] of DWORD= (3, 12, 48, 192);
		419	Mask4: array[0..1] of DWORD= ($0F, $F0);
		420
		421	Shift1: array[0..7] of DWORD= (0, 1, 2, 3, 4, 5, 6, 7);
		422	Shift2: array[0..3] of DWORD= (0, 2, 4, 6);
		423	Shift4: array[0..1] of DWORD= (0, 4);
		424
		425	type
		426	PByte3 = ^TByte3;
		427	TByte3 = array[0..2] of Byte;
		428
		429	function TDXTextureImage.GetPixel(x, y: Integer): DWORD;
		430	begin
		431	Result := 0;
		432	if (x>=0) and (x<FWidth) and (y>=0) and (y<FHeight) then
		433	begin
		434	case FBitCount of
		435	1 : begin
		436	if FPackedPixelOrder then
		437	Result := (PByte(Integer(FTopPBits)+FNextLine*y+x shr 3)^ and Mask1[7-x and 7]) shr Shift1[7-x and 7]
		438	else
		439	Result := (PByte(Integer(FTopPBits)+FNextLine*y+x shr 3)^ and Mask1[x and 7]) shr Shift1[x and 7];
		440	end;
		441	2 : begin
		442	if FPackedPixelOrder then
		443	Result := (PByte(Integer(FTopPBits)+FNextLine*y+x shr 2)^ and Mask2[3-x and 3]) shr Shift2[3-x and 3]
		444	else
		445	Result := (PByte(Integer(FTopPBits)+FNextLine*y+x shr 2)^ and Mask2[x and 3]) shr Shift2[x and 3];
		446	end;
		447	4 : begin
		448	if FPackedPixelOrder then
		449	Result := (PByte(Integer(FTopPBits)+FNextLine*y+x shr 1)^ and Mask4[1-x and 1]) shr Shift4[1-x and 1]
		450	else
		451	Result := (PByte(Integer(FTopPBits)+FNextLine*y+x shr 1)^ and Mask4[x and 1]) shr Shift4[x and 1];
		452	end;
		453	8 : Result := PByte(Integer(FTopPBits)+FNextLine*y+x)^;
		454	16: Result := PWord(Integer(FTopPBits)+FNextLiney+x2)^;
		455	24: PByte3(@Result)^ := PByte3(Integer(FTopPBits)+FNextLiney+x3)^;
		456	32: Result := PDWORD(Integer(FTopPBits)+FNextLiney+x4)^;
		457	end;
		458	end;
		459	end;
		460
		461	procedure TDXTextureImage.SetPixel(x, y: Integer; c: DWORD);
		462	var
		463	P: PByte;
		464	begin
		465	if (x>=0) and (x<FWidth) and (y>=0) and (y<FHeight) then
		466	begin
		467	case FBitCount of
		468	1 : begin
		469	P := Pointer(Integer(FTopPBits)+FNextLine*y+x shr 3);
		470	if FPackedPixelOrder then
		471	P^ := (P^ and (not Mask1[7-x and 7])) or ((c and 1) shl Shift1[7-x and 7])
		472	else
		473	P^ := (P^ and (not Mask1[x and 7])) or ((c and 1) shl Shift1[x and 7]);
		474	end;
		475	2 : begin
		476	P := Pointer(Integer(FTopPBits)+FNextLine*y+x shr 2);
		477	if FPackedPixelOrder then
		478	P^ := (P^ and (not Mask2[3-x and 3])) or ((c and 3) shl Shift2[3-x and 3])
		479	else
		480	P^ := (P^ and (not Mask2[x and 3])) or ((c and 3) shl Shift2[x and 3]);
		481	end;
		482	4 : begin
		483	P := Pointer(Integer(FTopPBits)+FNextLine*y+x shr 1);
		484	if FPackedPixelOrder then
		485	P^ := (P^ and (not Mask4[1-x and 1])) or ((c and 7) shl Shift4[1-x and 1])
		486	else
		487	P^ := (P^ and (not Mask4[x and 1])) or ((c and 7) shl Shift4[x and 1]);
		488	end;
		489	8 : PByte(Integer(FTopPBits)+FNextLine*y+x)^ := c;
		490	16: PWord(Integer(FTopPBits)+FNextLiney+x2)^ := c;
		491	24: PByte3(Integer(FTopPBits)+FNextLiney+x3)^ := PByte3(@c)^;
		492	32: PDWORD(Integer(FTopPBits)+FNextLiney+x4)^ := c;
		493	end;
		494	end;
		495	end;
		496
		497	procedure TDXTextureImage.LoadFromFile(const FileName: string);
		498	var
		499	Stream: TFileStream;
		500	begin
		501	Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
		502	try
		503	LoadFromStream(Stream);
		504	finally
		505	Stream.Free;
		506	end;
		507	end;
		508
		509	procedure TDXTextureImage.LoadFromStream(Stream: TStream);
		510	var
		511	i, p: Integer;
		512	begin
		513	Clear;
		514
		515	p := Stream.Position;
		516	for i:=0 to DXTextureImageLoadFuncList.Count-1 do
		517	begin
		518	Stream.Position := p;
		519	try
		520	TDXTextureImageLoadFunc(DXTextureImageLoadFuncList[i])(Stream, Self);
		521	Exit;
		522	except
		523	Clear;
		524	end;
		525	end;
		526
		527	raise EDXTextureImageError.Create(SNotSupportGraphicFile);
		528	end;
		529
		530	procedure TDXTextureImage.SaveToFile(const FileName: string);
		531	var
		532	Stream: TFileStream;
		533	begin
		534	Stream := TFileStream.Create(FileName, fmCreate);
		535	try
		536	SaveToStream(Stream);
		537	finally
		538	Stream.Free;
		539	end;
		540	end;
		541
		542	procedure DXTextureImage_SaveDXTextureImageFunc(Stream: TStream; Image: TDXTextureImage); forward;
		543
		544	procedure TDXTextureImage.SaveToStream(Stream: TStream);
		545	begin
		546	DXTextureImage_SaveDXTextureImageFunc(Stream, Self);
		547	end;
		548
		549	{ DXTextureImage_LoadDXTextureImageFunc }
		550
		551	const
		552	DXTextureImageFile_Type = 'dxt:';
		553	DXTextureImageFile_Version = $100;
		554
		555	DXTextureImageCompress_None = 0;
		556
		557	DXTextureImageFileCategoryType_Image = $100;
		558
		559	DXTextureImageFileBlockID_EndFile = 0;
		560	DXTextureImageFileBlockID_EndGroup = 1;
		561	DXTextureImageFileBlockID_StartGroup = 2;
		562	DXTextureImageFileBlockID_Image_Format = DXTextureImageFileCategoryType_Image + 1;
		563	DXTextureImageFileBlockID_Image_PixelData = DXTextureImageFileCategoryType_Image + 2;
		564	DXTextureImageFileBlockID_Image_GroupInfo = DXTextureImageFileCategoryType_Image + 3;
		565	DXTextureImageFileBlockID_Image_Name = DXTextureImageFileCategoryType_Image + 4;
		566	DXTextureImageFileBlockID_Image_TransparentColor = DXTextureImageFileCategoryType_Image + 5;
		567
		568	type
		569	TDXTextureImageFileHeader = packed record
		570	FileType: array[0..4] of Char;
		571	ver: DWORD;
		572	end;
		573
		574	TDXTextureImageFileBlockHeader = packed record
		575	ID: DWORD;
		576	Size: Integer;
		577	end;
		578
		579	TDXTextureImageFileBlockHeader_StartGroup = packed record
		580	CategoryType: DWORD;
		581	end;
		582
		583	TDXTextureImageHeader_Image_Format = packed record
		584	ImageType: TDXTextureImageType;
		585	Width: DWORD;
		586	Height: DWORD;
		587	BitCount: DWORD;
		588	WidthBytes: DWORD;
		589	end;
		590
		591	TDXTextureImageHeader_Image_Format_Index = packed record
		592	idx_index_Mask: DWORD;
		593	idx_alpha_Mask: DWORD;
		594	idx_palette: array[0..255] of TPaletteEntry;
		595	end;
		596
		597	TDXTextureImageHeader_Image_Format_RGB = packed record
		598	rgb_red_Mask: DWORD;
		599	rgb_green_Mask: DWORD;
		600	rgb_blue_Mask: DWORD;
		601	rgb_alpha_Mask: DWORD;
		602	end;
		603
		604	TDXTextureImageHeader_Image_GroupInfo = packed record
		605	ImageGroupType: DWORD;
		606	ImageID: DWORD;
		607	end;
		608
		609	TDXTextureImageHeader_Image_TransparentColor = packed record
		610	Transparent: Boolean;
		611	TransparentColor: DWORD;
		612	end;
		613
		614	procedure DXTextureImage_LoadDXTextureImageFunc(Stream: TStream; Image: TDXTextureImage);
		615
		616	procedure ReadGroup_Image(Image: TDXTextureImage);
		617	var
		618	i: Integer;
		619	BlockHeader: TDXTextureImageFileBlockHeader;
		620	NextPos: Integer;
		621	SubImage: TDXTextureImage;
		622	Header_StartGroup: TDXTextureImageFileBlockHeader_StartGroup;
		623	Header_Image_Format: TDXTextureImageHeader_Image_Format;
		624	Header_Image_Format_Index: TDXTextureImageHeader_Image_Format_Index;
		625	Header_Image_Format_RGB: TDXTextureImageHeader_Image_Format_RGB;
		626	Header_Image_GroupInfo: TDXTextureImageHeader_Image_GroupInfo;
		627	Header_Image_TransparentColor: TDXTextureImageHeader_Image_TransparentColor;
		628	ImageName: string;
		629	begin
		630	while True do
		631	begin
		632	Stream.ReadBuffer(BlockHeader, SizeOf(BlockHeader));
		633	NextPos := Stream.Position + BlockHeader.Size;
		634
		635	case BlockHeader.ID of
		636	DXTextureImageFileBlockID_EndGroup:
		637	begin
		638	{ End of group }
		639	Break;
		640	end;
		641	DXTextureImageFileBlockID_StartGroup:
		642	begin
		643	{ Beginning of group }
		644	Stream.ReadBuffer(Header_StartGroup, SizeOf(Header_StartGroup));
		645	case Header_StartGroup.CategoryType of
		646	DXTextureImageFileCategoryType_Image:
		647	begin
		648	{ Image group }
		649	SubImage := TDXTextureImage.CreateSub(Image);
		650	try
		651	ReadGroup_Image(SubImage);
		652	except
		653	SubImage.Free;
		654	raise;
		655	end;
		656	end;
		657	end;
		658	end;
		659	DXTextureImageFileBlockID_Image_Format:
		660	begin
		661	{ Image information reading (size etc.) }
		662	Stream.ReadBuffer(Header_Image_Format, SizeOf(Header_Image_Format));
		663
		664	if (Header_Image_Format.ImageType<>DXTextureImageType_PaletteIndexedColor) and
		665	(Header_Image_Format.ImageType<>DXTextureImageType_RGBColor) then
		666	raise EDXTextureImageError.Create(SInvalidDXTFile);
		667
		668	Image.SetSize(Header_Image_Format.ImageType, Header_Image_Format.Width, Header_Image_Format.Height,
		669	Header_Image_Format.BitCount, Header_Image_Format.Widthbytes);
		670
		671	if Header_Image_Format.ImageType=DXTextureImageType_PaletteIndexedColor then
		672	begin
		673	{ INDEX IMAGE }
		674	Stream.ReadBuffer(Header_Image_Format_Index, SizeOf(Header_Image_Format_Index));
		675
		676	Image.idx_index := dxtMakeChannel(Header_Image_Format_Index.idx_index_Mask, True);
		677	Image.idx_alpha := dxtMakeChannel(Header_Image_Format_Index.idx_alpha_Mask, False);
		678
		679	for i:=0 to 255 do
		680	Image.idx_palette[i] := Header_Image_Format_Index.idx_palette[i];
		681	end else if Header_Image_Format.ImageType=DXTextureImageType_RGBColor then
		682	begin
		683	{ RGB IMAGE }
		684	Stream.ReadBuffer(Header_Image_Format_RGB, SizeOf(Header_Image_Format_RGB));
		685
		686	Image.rgb_red := dxtMakeChannel(Header_Image_Format_RGB.rgb_red_Mask, False);
		687	Image.rgb_green := dxtMakeChannel(Header_Image_Format_RGB.rgb_green_Mask, False);
		688	Image.rgb_blue := dxtMakeChannel(Header_Image_Format_RGB.rgb_blue_Mask, False);
		689	Image.rgb_alpha := dxtMakeChannel(Header_Image_Format_RGB.rgb_alpha_Mask, False);
		690	end;
		691	end;
		692	DXTextureImageFileBlockID_Image_Name:
		693	begin
		694	{ Name reading }
		695	SetLength(ImageName, BlockHeader.Size);
		696	Stream.ReadBuffer(ImageName[1], BlockHeader.Size);
		697
		698	Image.ImageName := ImageName;
		699	end;
		700	DXTextureImageFileBlockID_Image_GroupInfo:
		701	begin
		702	{ Image group information reading }
		703	Stream.ReadBuffer(Header_Image_GroupInfo, SizeOf(Header_Image_GroupInfo));
		704
		705	Image.ImageGroupType := Header_Image_GroupInfo.ImageGroupType;
		706	Image.ImageID := Header_Image_GroupInfo.ImageID;
		707	end;
		708	DXTextureImageFileBlockID_Image_TransparentColor:
		709	begin
		710	{ Transparent color information reading }
		711	Stream.ReadBuffer(Header_Image_TransparentColor, SizeOf(Header_Image_TransparentColor));
		712
		713	Image.Transparent := Header_Image_TransparentColor.Transparent;
		714	Image.TransparentColor := Header_Image_TransparentColor.TransparentColor;
		715	end;
		716	DXTextureImageFileBlockID_Image_PixelData:
		717	begin
		718	{ Pixel data reading }
		719	for i:=0 to Image.Height-1 do
		720	Stream.ReadBuffer(Image.ScanLine[i]^, Header_Image_Format.Widthbytes);
		721	end;
		722	end;
		723
		724	Stream.Seek(NextPos, soFromBeginning);
		725	end;
		726	end;
		727
		728	var
		729	FileHeader: TDXTextureImageFileHeader;
		730	BlockHeader: TDXTextureImageFileBlockHeader;
		731	Header_StartGroup: TDXTextureImageFileBlockHeader_StartGroup;
		732	NextPos: Integer;
		733	begin
		734	{ File header reading }
		735	Stream.ReadBuffer(FileHeader, SizeOf(FileHeader));
		736
		737	if FileHeader.FileType<>DXTextureImageFile_Type then
		738	raise EDXTextureImageError.Create(SInvalidDXTFile);
		739	if FileHeader.ver<>DXTextureImageFile_Version then
		740	raise EDXTextureImageError.Create(SInvalidDXTFile);
		741
		742	while True do
		743	begin
		744	Stream.ReadBuffer(BlockHeader, SizeOf(BlockHeader));
		745	NextPos := Stream.Position + BlockHeader.Size;
		746
		747	case BlockHeader.ID of
		748	DXTextureImageFileBlockID_EndFile:
		749	begin
		750	{ End of file }
		751	Break;
		752	end;
		753	DXTextureImageFileBlockID_StartGroup:
		754	begin
		755	{ Beginning of group }
		756	Stream.ReadBuffer(Header_StartGroup, SizeOf(Header_StartGroup));
		757	case Header_StartGroup.CategoryType of
		758	DXTextureImageFileCategoryType_Image: ReadGroup_Image(Image);
		759	end;
		760	end;
		761	end;
		762
		763	Stream.Seek(NextPos, soFromBeginning);
		764	end;
		765	end;
		766
		767	type
		768	PDXTextureImageFileBlockHeaderWriter_BlockInfo = ^TDXTextureImageFileBlockHeaderWriter_BlockInfo;
		769	TDXTextureImageFileBlockHeaderWriter_BlockInfo = record
		770	BlockID: DWORD;
		771	StreamPos: Integer;
		772	end;
		773
		774	TDXTextureImageFileBlockHeaderWriter = class
		775	private
		776	FStream: TStream;
		777	FList: TList;
		778	public
		779	constructor Create(Stream: TStream);
		780	destructor Destroy; override;
		781	procedure StartBlock(BlockID: DWORD);
		782	procedure EndBlock;
		783	procedure WriteBlock(BlockID: DWORD);
		784	procedure StartGroup(CategoryType: DWORD);
		785	procedure EndGroup;
		786	end;
		787
		788	constructor TDXTextureImageFileBlockHeaderWriter.Create(Stream: TStream);
		789	begin
		790	inherited Create;
		791	FStream := Stream;
		792	FList := TList.Create;
		793	end;
		794
		795	destructor TDXTextureImageFileBlockHeaderWriter.Destroy;
		796	var
		797	i: Integer;
		798	begin
		799	for i:=0 to FList.Count-1 do
		800	Dispose(PDXTextureImageFileBlockHeaderWriter_BlockInfo(FList[i]));
		801	FList.Free;
		802	inherited Destroy;
		803	end;
		804
		805	procedure TDXTextureImageFileBlockHeaderWriter.StartBlock(BlockID: DWORD);
		806	var
		807	BlockInfo: PDXTextureImageFileBlockHeaderWriter_BlockInfo;
		808	BlockHeader: TDXTextureImageFileBlockHeader;
		809	begin
		810	New(BlockInfo);
		811	BlockInfo.BlockID := BlockID;
		812	BlockInfo.StreamPos := FStream.Position;
		813	FList.Add(BlockInfo);
		814
		815	BlockHeader.ID := BlockID;
		816	BlockHeader.Size := 0;
		817	FStream.WriteBuffer(BlockHeader, SizeOf(BlockHeader));
		818	end;
		819
		820	procedure TDXTextureImageFileBlockHeaderWriter.EndBlock;
		821	var
		822	BlockHeader: TDXTextureImageFileBlockHeader;
		823	BlockInfo: PDXTextureImageFileBlockHeaderWriter_BlockInfo;
		824	CurStreamPos: Integer;
		825	begin
		826	CurStreamPos := FStream.Position;
		827	try
		828	BlockInfo := FList[FList.Count-1];
		829
		830	FStream.Position := BlockInfo.StreamPos;
		831	BlockHeader.ID := BlockInfo.BlockID;
		832	BlockHeader.Size := CurStreamPos-(BlockInfo.StreamPos+SizeOf(TDXTextureImageFileBlockHeader));
		833	FStream.WriteBuffer(BlockHeader, SizeOf(BlockHeader));
		834	finally
		835	FStream.Position := CurStreamPos;
		836
		837	Dispose(FList[FList.Count-1]);
		838	FList.Count := FList.Count-1;
		839	end;
		840	end;
		841
		842	procedure TDXTextureImageFileBlockHeaderWriter.WriteBlock(BlockID: DWORD);
		843	var
		844	BlockHeader: TDXTextureImageFileBlockHeader;
		845	begin
		846	BlockHeader.ID := BlockID;
		847	BlockHeader.Size := 0;
		848	FStream.WriteBuffer(BlockHeader, SizeOf(BlockHeader));
		849	end;
		850
		851	procedure TDXTextureImageFileBlockHeaderWriter.StartGroup(CategoryType: DWORD);
		852	var
		853	Header_StartGroup: TDXTextureImageFileBlockHeader_StartGroup;
		854	begin
		855	StartBlock(DXTextureImageFileBlockID_StartGroup);
		856
		857	Header_StartGroup.CategoryType := CategoryType;
		858	FStream.WriteBuffer(Header_StartGroup, SizeOf(Header_StartGroup));
		859	end;
		860
		861	procedure TDXTextureImageFileBlockHeaderWriter.EndGroup;
		862	begin
		863	WriteBlock(DXTextureImageFileBlockID_EndGroup);
		864	EndBlock;
		865	end;
		866
		867	procedure DXTextureImage_SaveDXTextureImageFunc(Stream: TStream; Image: TDXTextureImage);
		868	var
		869	BlockHeaderWriter: TDXTextureImageFileBlockHeaderWriter;
		870
		871	function CalcProgressCount(Image: TDXTextureImage): Integer;
		872	var
		873	i: Integer;
		874	begin
		875	Result := Image.WidthBytes*Image.Height;
		876	for i:=0 to Image.SubImageCount-1 do
		877	Inc(Result, CalcProgressCount(Image.SubImages[i]));
		878	end;
		879
		880	procedure WriteGroup_Image(Image: TDXTextureImage);
		881	var
		882	i: Integer;
		883	Header_Image_Format: TDXTextureImageHeader_Image_Format;
		884	Header_Image_Format_Index: TDXTextureImageHeader_Image_Format_Index;
		885	Header_Image_Format_RGB: TDXTextureImageHeader_Image_Format_RGB;
		886	Header_Image_GroupInfo: TDXTextureImageHeader_Image_GroupInfo;
		887	Header_Image_TransparentColor: TDXTextureImageHeader_Image_TransparentColor;
		888	begin
		889	BlockHeaderWriter.StartGroup(DXTextureImageFileCategoryType_Image);
		890	try
		891	{ Image format writing }
		892	if Image.Size>0 then
		893	begin
		894	Header_Image_Format.ImageType := Image.ImageType;
		895	Header_Image_Format.Width := Image.Width;
		896	Header_Image_Format.Height := Image.Height;
		897	Header_Image_Format.BitCount := Image.BitCount;
		898	Header_Image_Format.WidthBytes := Image.WidthBytes;
		899
		900	BlockHeaderWriter.StartBlock(DXTextureImageFileBlockID_Image_Format);
		901	try
		902	Stream.WriteBuffer(Header_Image_Format, SizeOf(Header_Image_Format));
		903
		904	case Image.ImageType of
		905	DXTextureImageType_PaletteIndexedColor:
		906	begin
		907	{ INDEX IMAGE }
		908	Header_Image_Format_Index.idx_index_Mask := Image.idx_index.Mask;
		909	Header_Image_Format_Index.idx_alpha_Mask := Image.idx_alpha.Mask;
		910	for i:=0 to 255 do
		911	Header_Image_Format_Index.idx_palette[i] := Image.idx_palette[i];
		912
		913	Stream.WriteBuffer(Header_Image_Format_Index, SizeOf(Header_Image_Format_Index));
		914	end;
		915	DXTextureImageType_RGBColor:
		916	begin
		917	{ RGB IMAGE }
		918	Header_Image_Format_RGB.rgb_red_Mask := Image.rgb_red.Mask;
		919	Header_Image_Format_RGB.rgb_green_Mask := Image.rgb_green.Mask;
		920	Header_Image_Format_RGB.rgb_blue_Mask := Image.rgb_blue.Mask;
		921	Header_Image_Format_RGB.rgb_alpha_Mask := Image.rgb_alpha.Mask;
		922
		923	Stream.WriteBuffer(Header_Image_Format_RGB, SizeOf(Header_Image_Format_RGB));
		924	end;
		925	end;
		926	finally
		927	BlockHeaderWriter.EndBlock;
		928	end;
		929	end;
		930
		931	{ Image group information writing }
		932	BlockHeaderWriter.StartBlock(DXTextureImageFileBlockID_Image_GroupInfo);
		933	try
		934	Header_Image_GroupInfo.ImageGroupType := Image.ImageGroupType;
		935	Header_Image_GroupInfo.ImageID := Image.ImageID;
		936
		937	Stream.WriteBuffer(Header_Image_GroupInfo, SizeOf(Header_Image_GroupInfo));
		938	finally
		939	BlockHeaderWriter.EndBlock;
		940	end;
		941
		942	{ Name writing }
		943	BlockHeaderWriter.StartBlock(DXTextureImageFileBlockID_Image_Name);
		944	try
		945	Stream.WriteBuffer(Image.ImageName[1], Length(Image.ImageName));
		946	finally
		947	BlockHeaderWriter.EndBlock;
		948	end;
		949
		950	{ Transparent color writing }
		951	BlockHeaderWriter.StartBlock(DXTextureImageFileBlockID_Image_TransparentColor);
		952	try
		953	Header_Image_TransparentColor.Transparent := Image.Transparent;
		954	Header_Image_TransparentColor.TransparentColor := Image.TransparentColor;
		955
		956	Stream.WriteBuffer(Header_Image_TransparentColor, SizeOf(Header_Image_TransparentColor));
		957	finally
		958	BlockHeaderWriter.EndBlock;
		959	end;
		960
		961	{ Pixel data writing }
		962	if Image.Size>0 then
		963	begin
		964	BlockHeaderWriter.StartBlock(DXTextureImageFileBlockID_Image_PixelData);
		965	try
		966	for i:=0 to Image.Height-1 do
		967	Stream.WriteBuffer(Image.ScanLine[i]^, Image.Widthbytes);
		968	finally
		969	BlockHeaderWriter.EndBlock;
		970	end;
		971	end;
		972
		973	{ Sub-image writing }
		974	for i:=0 to Image.SubImageCount-1 do
		975	WriteGroup_Image(Image.SubImages[i]);
		976	finally
		977	BlockHeaderWriter.EndGroup;
		978	end;
		979	end;
		980
		981	var
		982	FileHeader: TDXTextureImageFileHeader;
		983	begin
		984	{ File header writing }
		985	FileHeader.FileType := DXTextureImageFile_Type;
		986	FileHeader.ver := DXTextureImageFile_Version;
		987	Stream.WriteBuffer(FileHeader, SizeOf(FileHeader));
		988
		989	{ Image writing }
		990	BlockHeaderWriter := TDXTextureImageFileBlockHeaderWriter.Create(Stream);
		991	try
		992	{ Image writing }
		993	WriteGroup_Image(Image);
		994
		995	{ End of file }
		996	BlockHeaderWriter.WriteBlock(DXTextureImageFileBlockID_EndFile);
		997	finally
		998	BlockHeaderWriter.Free;
		999	end;
		1000	end;
		1001
		1002	{ DXTextureImage_LoadBitmapFunc }
		1003
		1004	procedure DXTextureImage_LoadBitmapFunc(Stream: TStream; Image: TDXTextureImage);
		1005	type
		1006	TDIBPixelFormat = packed record
		1007	RBitMask, GBitMask, BBitMask: DWORD;
		1008	end;
		1009	var
		1010	TopDown: Boolean;
		1011	BF: TBitmapFileHeader;
		1012	BI: TBitmapInfoHeader;
		1013
		1014	procedure DecodeRGB;
		1015	var
		1016	y: Integer;
		1017	begin
		1018	for y:=0 to Image.Height-1 do
		1019	begin
		1020	if TopDown then
		1021	Stream.ReadBuffer(Image.ScanLine[y]^, Image.WidthBytes)
		1022	else
		1023	Stream.ReadBuffer(Image.ScanLine[Image.Height-y-1]^, Image.WidthBytes);
		1024	end;
		1025	end;
		1026
		1027	procedure DecodeRLE4;
		1028	var
		1029	SrcDataP: Pointer;
		1030	B1, B2, C: Byte;
		1031	Dest, Src, P: PByte;
		1032	X, Y, i: Integer;
		1033	begin
		1034	GetMem(SrcDataP, BI.biSizeImage);
		1035	try
		1036	Stream.ReadBuffer(SrcDataP^, BI.biSizeImage);
		1037
		1038	Dest := Image.TopPBits;
		1039	Src := SrcDataP;
		1040	X := 0;
		1041	Y := 0;
		1042
		1043	while True do
		1044	begin
		1045	B1 := Src^; Inc(Src);
		1046	B2 := Src^; Inc(Src);
		1047
		1048	if B1=0 then
		1049	begin
		1050	case B2 of
		1051	0: begin { End of line }
		1052	X := 0; Inc(Y);
		1053	Dest := Image.ScanLine[Y];
		1054	end;
		1055	1: Break; { End of bitmap }
		1056	2: begin { Difference of coordinates }
		1057	Inc(X, B1); Inc(Y, B2); Inc(Src, 2);
		1058	Dest := Image.ScanLine[Y];
		1059	end;
		1060	else
		1061	{ Absolute mode }
		1062	C := 0;
		1063	for i:=0 to B2-1 do
		1064	begin
		1065	if i and 1=0 then
		1066	begin
		1067	C := Src^; Inc(Src);
		1068	end else
		1069	begin
		1070	C := C shl 4;
		1071	end;
		1072
		1073	P := Pointer(Integer(Dest)+X shr 1);
		1074	if X and 1=0 then
		1075	P^ := (P^ and $0F) or (C and $F0)
		1076	else
		1077	P^ := (P^ and $F0) or ((C and $F0) shr 4);
		1078
		1079	Inc(X);
		1080	end;
		1081	end;
		1082	end else
		1083	begin
		1084	{ Encoding mode }
		1085	for i:=0 to B1-1 do
		1086	begin
		1087	P := Pointer(Integer(Dest)+X shr 1);
		1088	if X and 1=0 then
		1089	P^ := (P^ and $0F) or (B2 and $F0)
		1090	else
		1091	P^ := (P^ and $F0) or ((B2 and $F0) shr 4);
		1092
		1093	Inc(X);
		1094
		1095	// Swap nibble
		1096	B2 := (B2 shr 4) or (B2 shl 4);
		1097	end;
		1098	end;
		1099
		1100	{ Word arrangement }
		1101	Inc(Src, Longint(Src) and 1);
		1102	end;
		1103	finally
		1104	FreeMem(SrcDataP);
		1105	end;
		1106	end;
		1107
		1108	procedure DecodeRLE8;
		1109	var
		1110	SrcDataP: Pointer;
		1111	B1, B2: Byte;
		1112	Dest, Src: PByte;
		1113	X, Y: Integer;
		1114	begin
		1115	GetMem(SrcDataP, BI.biSizeImage);
		1116	try
		1117	Stream.ReadBuffer(SrcDataP^, BI.biSizeImage);
		1118
		1119	Dest := Image.TopPBits;
		1120	Src := SrcDataP;
		1121	X := 0;
		1122	Y := 0;
		1123
		1124	while True do
		1125	begin
		1126	B1 := Src^; Inc(Src);
		1127	B2 := Src^; Inc(Src);
		1128
		1129	if B1=0 then
		1130	begin
		1131	case B2 of
		1132	0: begin { End of line }
		1133	X := 0; Inc(Y);
		1134	Dest := Pointer(Longint(Image.TopPBits)+Y*Image.NextLine+X);
		1135	end;
		1136	1: Break; { End of bitmap }
		1137	2: begin { Difference of coordinates }
		1138	Inc(X, B1); Inc(Y, B2); Inc(Src, 2);
		1139	Dest := Pointer(Longint(Image.TopPBits)+Y*Image.NextLine+X);
		1140	end;
		1141	else
		1142	{ Absolute mode }
		1143	Move(Src^, Dest^, B2); Inc(Dest, B2); Inc(Src, B2);
		1144	end;
		1145	end else
		1146	begin
		1147	{ Encoding mode }
		1148	FillChar(Dest^, B1, B2); Inc(Dest, B1);
		1149	end;
		1150
		1151	{ Word arrangement }
		1152	Inc(Src, Longint(Src) and 1);
		1153	end;
		1154	finally
		1155	FreeMem(SrcDataP);
		1156	end;
		1157	end;
		1158
		1159	var
		1160	BC: TBitmapCoreHeader;
		1161	RGBTriples: array[0..255] of TRGBTriple;
		1162	RGBQuads: array[0..255] of TRGBQuad;
		1163	i, PalCount, j: Integer;
		1164	OS2: Boolean;
		1165	PixelFormat: TDIBPixelFormat;
		1166	begin
		1167	{ File header reading }
		1168	i := Stream.Read(BF, SizeOf(TBitmapFileHeader));
		1169	if i=0 then Exit;
		1170	if i<>SizeOf(TBitmapFileHeader) then
		1171	raise EDXTextureImageError.Create(SInvalidDIB);
		1172
		1173	{ Is the head 'BM'? }
		1174	if BF.bfType<>Ord('B') + Ord('M')*$100 then
		1175	raise EDXTextureImageError.Create(SInvalidDIB);
		1176
		1177	{ Reading of size of header }
		1178	i := Stream.Read(BI.biSize, 4);
		1179	if i<>4 then
		1180	raise EDXTextureImageError.Create(SInvalidDIB);
		1181
		1182	{ Kind check of DIB }
		1183	OS2 := False;
		1184
		1185	case BI.biSize of
		1186	SizeOf(TBitmapCoreHeader):
		1187	begin
		1188	{ OS/2 type }
		1189	Stream.ReadBuffer(Pointer(Integer(@BC)+4)^, SizeOf(TBitmapCoreHeader)-4);
		1190
		1191	FilLChar(BI, SizeOf(BI), 0);
		1192	with BI do
		1193	begin
		1194	biClrUsed := 0;
		1195	biCompression := BI_RGB;
		1196	biBitCount := BC.bcBitCount;
		1197	biHeight := BC.bcHeight;
		1198	biWidth := BC.bcWidth;
		1199	end;
		1200
		1201	OS2 := True;
		1202	end;
		1203	SizeOf(TBitmapInfoHeader):
		1204	begin
		1205	{ Windows type }
		1206	Stream.ReadBuffer(Pointer(Integer(@BI)+4)^, SizeOf(TBitmapInfoHeader)-4);
		1207	end;
		1208	else
		1209	raise EDXTextureImageError.Create(SInvalidDIB);
		1210	end;
		1211
		1212	{ Bit mask reading }
		1213	if BI.biCompression = BI_BITFIELDS then
		1214	begin
		1215	Stream.ReadBuffer(PixelFormat, SizeOf(PixelFormat));
		1216	end else
		1217	begin
		1218	if BI.biBitCount=16 then
		1219	begin
		1220	PixelFormat.RBitMask := $7C00;
		1221	PixelFormat.GBitMask := $03E0;
		1222	PixelFormat.BBitMask := $001F;
		1223	end else if (BI.biBitCount=24) or (BI.biBitCount=32) then
		1224	begin
		1225	PixelFormat.RBitMask := $00FF0000;
		1226	PixelFormat.GBitMask := $0300FF00;
		1227	PixelFormat.BBitMask := $000000FF;
		1228	end;
		1229	end;
		1230
		1231	{ DIB making }
		1232	if BI.biHeight<0 then
		1233	begin
		1234	BI.biHeight := -BI.biHeight;
		1235	TopDown := True;
		1236	end else
		1237	TopDown := False;
		1238
		1239	if BI.biBitCount in [1, 4, 8] then
		1240	begin
		1241	Image.SetSize(DXTextureImageType_PaletteIndexedColor, BI.biWidth, BI.biHeight, BI.biBitCount,
		1242	(((BI.biWidthBI.biBitCount)+31) div 32)4);
		1243
		1244	Image.idx_index := dxtMakeChannel(1 shl BI.biBitCount-1, True);
		1245	Image.PackedPixelOrder := True;
		1246	end else
		1247	begin
		1248	Image.SetSize(DXTextureImageType_RGBColor, BI.biWidth, BI.biHeight, BI.biBitCount,
		1249	(((BI.biWidthBI.biBitCount)+31) div 32)4);
		1250
		1251	Image.rgb_red := dxtMakeChannel(PixelFormat.RBitMask, False);
		1252	Image.rgb_green := dxtMakeChannel(PixelFormat.GBitMask, False);
		1253	Image.rgb_blue := dxtMakeChannel(PixelFormat.BBitMask, False);
		1254
		1255	j := Image.rgb_red.BitCount+Image.rgb_green.BitCount+Image.rgb_blue.BitCount;
		1256	if j<BI.biBitCount then
		1257	Image.rgb_alpha := dxtMakeChannel((1 shl (BI.biBitCount-j)-1) shl j, False);
		1258
		1259	Image.PackedPixelOrder := False;
		1260	end;
		1261
		1262	{ palette reading }
		1263	PalCount := BI.biClrUsed;
		1264	if (PalCount=0) and (BI.biBitCount<=8) then
		1265	PalCount := 1 shl BI.biBitCount;
		1266	if PalCount>256 then PalCount := 256;
		1267
		1268	if OS2 then
		1269	begin
		1270	{ OS/2 type }
		1271	Stream.ReadBuffer(RGBTriples, SizeOf(TRGBTriple)*PalCount);
		1272	for i:=0 to PalCount-1 do
		1273	begin
		1274	Image.idx_palette[i].peRed := RGBTriples[i].rgbtRed;
		1275	Image.idx_palette[i].peGreen := RGBTriples[i].rgbtGreen;
		1276	Image.idx_palette[i].peBlue := RGBTriples[i].rgbtBlue;
		1277	end;
		1278	end else
		1279	begin
		1280	{ Windows type }
		1281	Stream.ReadBuffer(RGBQuads, SizeOf(TRGBQuad)*PalCount);
		1282	for i:=0 to PalCount-1 do
		1283	begin
		1284	Image.idx_palette[i].peRed := RGBQuads[i].rgbRed;
		1285	Image.idx_palette[i].peGreen := RGBQuads[i].rgbGreen;
		1286	Image.idx_palette[i].peBlue := RGBQuads[i].rgbBlue;
		1287	end;
		1288	end;
		1289
		1290	{ Pixel data reading }
		1291	case BI.biCompression of
		1292	BI_RGB : DecodeRGB;
		1293	BI_BITFIELDS: DecodeRGB;
		1294	BI_RLE4 : DecodeRLE4;
		1295	BI_RLE8 : DecodeRLE8;
		1296	else
		1297	raise EDXTextureImageError.Create(SInvalidDIB);
		1298	end;
		1299	end;
		1300
		1301	initialization
		1302	finalization
		1303	_DXTextureImageLoadFuncList.Free;
		1304	end.

Subversion Repositories spacemission

spacemission/VCL_DELPHIX_D6/DXTexImg.pas – Rev 1