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

Rev	Author	Line No.	Line
1	daniel-mar	1	unit DXSprite;
		2
		3	interface
		4
		5	{$INCLUDE DelphiXcfg.inc}
		6
		7	uses
		8	Windows, SysUtils, Classes, DXClass, DXDraws, DirectX;
		9
		10	type
		11
		12	{ ESpriteError }
		13
		14	ESpriteError = class(Exception);
		15
		16	{ TSprite }
		17
		18	TSpriteEngine = class;
		19
		20	TSprite = class
		21	private
		22	FEngine: TSpriteEngine;
		23	FParent: TSprite;
		24	FList: TList;
		25	FDeaded: Boolean;
		26	FDrawList: TList;
		27	FCollisioned: Boolean;
		28	FMoved: Boolean;
		29	FVisible: Boolean;
		30	FX: Double;
		31	FY: Double;
		32	FZ: Integer;
		33	FWidth: Integer;
		34	FHeight: Integer;
		35	procedure Add(Sprite: TSprite);
		36	procedure Remove(Sprite: TSprite);
		37	procedure AddDrawList(Sprite: TSprite);
		38	procedure Collision2;
		39	procedure Draw;
		40	function GetClientRect: TRect;
		41	function GetCount: Integer;
		42	function GetItem(Index: Integer): TSprite;
		43	function GetWorldX: Double;
		44	function GetWorldY: Double;
		45	procedure SetZ(Value: Integer);
		46	protected
		47	procedure DoCollision(Sprite: TSprite; var Done: Boolean); virtual;
		48	procedure DoDraw; virtual;
		49	procedure DoMove(MoveCount: Integer); virtual;
		50	function GetBoundsRect: TRect; virtual;
		51	function TestCollision(Sprite: TSprite): Boolean; virtual;
		52	public
		53	constructor Create(AParent: TSprite); virtual;
		54	destructor Destroy; override;
		55	procedure Clear;
		56	function Collision: Integer;
		57	procedure Dead;
		58	procedure Move(MoveCount: Integer);
		59	function GetSpriteAt(X, Y: Integer): TSprite;
		60	property BoundsRect: TRect read GetBoundsRect;
		61	property ClientRect: TRect read GetClientRect;
		62	property Collisioned: Boolean read FCollisioned write FCollisioned;
		63	property Count: Integer read GetCount;
		64	property Engine: TSpriteEngine read FEngine;
		65	property Items[Index: Integer]: TSprite read GetItem; default;
		66	property Moved: Boolean read FMoved write FMoved;
		67	property Parent: TSprite read FParent;
		68	property Visible: Boolean read FVisible write FVisible;
		69	property Width: Integer read FWidth write FWidth;
		70	property WorldX: Double read GetWorldX;
		71	property WorldY: Double read GetWorldY;
		72	property Height: Integer read FHeight write FHeight;
		73	property X: Double read FX write FX;
		74	property Y: Double read FY write FY;
		75	property Z: Integer read FZ write SetZ;
		76	end;
		77
		78	{ TImageSprite }
		79
		80	TImageSprite = class(TSprite)
		81	private
		82	FAnimCount: Integer;
		83	FAnimLooped: Boolean;
		84	FAnimPos: Double;
		85	FAnimSpeed: Double;
		86	FAnimStart: Integer;
		87	FImage: TPictureCollectionItem;
		88	FPixelCheck: Boolean;
		89	FTile: Boolean;
		90	FTransparent: Boolean;
		91	function GetDrawImageIndex: Integer;
		92	function GetDrawRect: TRect;
		93	protected
		94	procedure DoDraw; override;
		95	procedure DoMove(MoveCount: Integer); override;
		96	function GetBoundsRect: TRect; override;
		97	function TestCollision(Sprite: TSprite): Boolean; override;
		98	public
		99	constructor Create(AParent: TSprite); override;
		100	property AnimCount: Integer read FAnimCount write FAnimCount;
		101	property AnimLooped: Boolean read FAnimLooped write FAnimLooped;
		102	property AnimPos: Double read FAnimPos write FAnimPos;
		103	property AnimSpeed: Double read FAnimSpeed write FAnimSpeed;
		104	property AnimStart: Integer read FAnimStart write FAnimStart;
		105	property PixelCheck: Boolean read FPixelCheck write FPixelCheck;
		106	property Image: TPictureCollectionItem read FImage write FImage;
		107	property Tile: Boolean read FTile write FTile;
		108	end;
		109
		110	{ TImageSpriteEx }
		111
		112	TImageSpriteEx = class(TImageSprite)
		113	private
		114	FAngle: Integer;
		115	FAlpha: Integer;
		116	protected
		117	procedure DoDraw; override;
		118	function GetBoundsRect: TRect; override;
		119	function TestCollision(Sprite: TSprite): Boolean; override;
		120	public
		121	constructor Create(AParent: TSprite); override;
		122	property Angle: Integer read FAngle write FAngle;
		123	property Alpha: Integer read FAlpha write FAlpha;
		124	end;
		125
		126	{ TBackgroundSprite }
		127
		128	TBackgroundSprite = class(TSprite)
		129	private
		130	FImage: TPictureCollectionItem;
		131	FCollisionMap: Pointer;
		132	FMap: Pointer;
		133	FMapWidth: Integer;
		134	FMapHeight: Integer;
		135	FTile: Boolean;
		136	function GetCollisionMapItem(X, Y: Integer): Boolean;
		137	function GetChip(X, Y: Integer): Integer;
		138	procedure SetChip(X, Y: Integer; Value: Integer);
		139	procedure SetCollisionMapItem(X, Y: Integer; Value: Boolean);
		140	procedure SetMapHeight(Value: Integer);
		141	procedure SetMapWidth(Value: Integer);
		142	protected
		143	procedure DoDraw; override;
		144	function GetBoundsRect: TRect; override;
		145	function TestCollision(Sprite: TSprite): Boolean; override;
		146	public
		147	constructor Create(AParent: TSprite); override;
		148	destructor Destroy; override;
		149	procedure SetMapSize(AMapWidth, AMapHeight: Integer);
		150	property Chips[X, Y: Integer]: Integer read GetChip write SetChip;
		151	property CollisionMap[X, Y: Integer]: Boolean read GetCollisionMapItem write SetCollisionMapItem;
		152	property Image: TPictureCollectionItem read FImage write FImage;
		153	property MapHeight: Integer read FMapHeight write SetMapHeight;
		154	property MapWidth: Integer read FMapWidth write SetMapWidth;
		155	property Tile: Boolean read FTile write FTile;
		156	end;
		157
		158	{ TSpriteEngine }
		159
		160	TSpriteEngine = class(TSprite)
		161	private
		162	FAllCount: Integer;
		163	FCollisionCount: Integer;
		164	FCollisionDone: Boolean;
		165	FCollisionRect: TRect;
		166	FCollisionSprite: TSprite;
		167	FDeadList: TList;
		168	FDrawCount: Integer;
		169	FSurface: TDirectDrawSurface;
		170	FSurfaceRect: TRect;
		171	procedure SetSurface(Value: TDirectDrawSurface);
		172	public
		173	constructor Create(AParent: TSprite); override;
		174	destructor Destroy; override;
		175	procedure Dead;
		176	procedure Draw;
		177	property AllCount: Integer read FAllCount;
		178	property DrawCount: Integer read FDrawCount;
		179	property Surface: TDirectDrawSurface read FSurface write SetSurface;
		180	property SurfaceRect: TRect read FSurfaceRect;
		181	end;
		182
		183	{ EDXSpriteEngineError }
		184
		185	EDXSpriteEngineError = class(Exception);
		186
		187	{ TCustomDXSpriteEngine }
		188
		189	TCustomDXSpriteEngine = class(TComponent)
		190	private
		191	FDXDraw: TCustomDXDraw;
		192	FEngine: TSpriteEngine;
		193	procedure DXDrawNotifyEvent(Sender: TCustomDXDraw; NotifyType: TDXDrawNotifyType);
		194	procedure SetDXDraw(Value: TCustomDXDraw);
		195	protected
		196	procedure Notification(AComponent: TComponent; Operation: TOperation); override;
		197	public
		198	constructor Create(AOnwer: TComponent); override;
		199	destructor Destroy; override;
		200	procedure Dead;
		201	procedure Draw;
		202	procedure Move(MoveCount: Integer);
		203	property DXDraw: TCustomDXDraw read FDXDraw write SetDXDraw;
		204	property Engine: TSpriteEngine read FEngine;
		205	end;
		206
		207	{ TDXSpriteEngine }
		208
		209	TDXSpriteEngine = class(TCustomDXSpriteEngine)
		210	published
		211	property DXDraw;
		212	end;
		213
		214	implementation
		215
		216	uses DXConsts;
		217
		218	function Mod2(i, i2: Integer): Integer;
		219	begin
		220	Result := i mod i2;
		221	if Result<0 then
		222	Result := i2+Result;
		223	end;
		224
		225	function Mod2f(i: Double; i2: Integer): Double;
		226	begin
		227	if i2=0 then
		228	Result := i
		229	else
		230	begin
		231	Result := i-Trunc(i/i2)*i2;
		232	if Result<0 then
		233	Result := i2+Result;
		234	end;
		235	end;
		236
		237	{ TSprite }
		238
		239	constructor TSprite.Create(AParent: TSprite);
		240	begin
		241	inherited Create;
		242	FParent := AParent;
		243	if FParent<>nil then
		244	begin
		245	FParent.Add(Self);
		246	if FParent is TSpriteEngine then
		247	FEngine := TSpriteEngine(FParent)
		248	else
		249	FEngine := FParent.Engine;
		250	Inc(FEngine.FAllCount);
		251	end;
		252
		253	FCollisioned := True;
		254	FMoved := True;
		255	FVisible := True;
		256	end;
		257
		258	destructor TSprite.Destroy;
		259	begin
		260	Clear;
		261	if FParent<>nil then
		262	begin
		263	Dec(FEngine.FAllCount);
		264	FParent.Remove(Self);
		265	FEngine.FDeadList.Remove(Self);
		266	end;
		267	FList.Free;
		268	FDrawList.Free;
		269	inherited Destroy;
		270	end;
		271
		272	procedure TSprite.Add(Sprite: TSprite);
		273	begin
		274	if FList=nil then
		275	begin
		276	FList := TList.Create;
		277	FDrawList := TList.Create;
		278	end;
		279	FList.Add(Sprite);
		280	AddDrawList(Sprite);
		281	end;
		282
		283	procedure TSprite.Remove(Sprite: TSprite);
		284	begin
		285	FList.Remove(Sprite);
		286	FDrawList.Remove(Sprite);
		287	if FList.Count=0 then
		288	begin
		289	FList.Free;
		290	FList := nil;
		291	FDrawList.Free;
		292	FDrawList := nil;
		293	end;
		294	end;
		295
		296	procedure TSprite.AddDrawList(Sprite: TSprite);
		297	var
		298	L, H, I, C: Integer;
		299	begin
		300	L := 0;
		301	H := FDrawList.Count - 1;
		302	while L <= H do
		303	begin
		304	I := (L + H) div 2;
		305	C := TSprite(FDrawList[I]).Z-Sprite.Z;
		306	if C < 0 then L := I + 1 else
		307	H := I - 1;
		308	end;
		309	FDrawList.Insert(L, Sprite);
		310	end;
		311
		312	procedure TSprite.Clear;
		313	begin
		314	while Count>0 do
		315	Items[Count-1].Free;
		316	end;
		317
		318	function TSprite.Collision: Integer;
		319	var
		320	i: Integer;
		321	begin
		322	Result := 0;
		323	if (FEngine<>nil) and (not FDeaded) and (Collisioned) then
		324	begin
		325	with FEngine do
		326	begin
		327	FCollisionCount := 0;
		328	FCollisionDone := False;
		329	FCollisionRect := Self.BoundsRect;
		330	FCollisionSprite := Self;
		331
		332	for i:=0 to Count-1 do
		333	Items[i].Collision2;
		334
		335	Result := FCollisionCount;
		336	end;
		337	end;
		338	end;
		339
		340	procedure TSprite.Collision2;
		341	var
		342	i: Integer;
		343	begin
		344	if Collisioned then
		345	begin
		346	if (Self<>FEngine.FCollisionSprite) and OverlapRect(BoundsRect, FEngine.FCollisionRect) and
		347	FEngine.FCollisionSprite.TestCollision(Self) and TestCollision(FEngine.FCollisionSprite) then
		348	begin
		349	Inc(FEngine.FCollisionCount);
		350	FEngine.FCollisionSprite.DoCollision(Self, FEngine.FCollisionDone);
		351	if (not FEngine.FCollisionSprite.Collisioned) or (FEngine.FCollisionSprite.FDeaded) then
		352	begin
		353	FEngine.FCollisionDone := True;
		354	end;
		355	end;
		356	if FEngine.FCollisionDone then Exit;
		357	for i:=0 to Count-1 do
		358	Items[i].Collision2;
		359	end;
		360	end;
		361
		362	procedure TSprite.Dead;
		363	begin
		364	if (FEngine<>nil) and (not FDeaded) then
		365	begin
		366	FDeaded := True;
		367	FEngine.FDeadList.Add(Self);
		368	end;
		369	end;
		370
		371	procedure TSprite.DoMove;
		372	begin
		373	end;
		374
		375	procedure TSprite.DoDraw;
		376	begin
		377	end;
		378
		379	procedure TSprite.DoCollision(Sprite: TSprite; var Done: Boolean);
		380	begin
		381	end;
		382
		383	function TSprite.TestCollision(Sprite: TSprite): Boolean;
		384	begin
		385	Result := True;
		386	end;
		387
		388	procedure TSprite.Move(MoveCount: Integer);
		389	var
		390	i: Integer;
		391	begin
		392	if FMoved then
		393	begin
		394	DoMove(MoveCount);
		395	for i:=0 to Count-1 do
		396	Items[i].Move(MoveCount);
		397	end;
		398	end;
		399
		400	procedure TSprite.Draw;
		401	var
		402	i: Integer;
		403	begin
		404	if FVisible then
		405	begin
		406	if FEngine<>nil then
		407	begin
		408	if OverlapRect(FEngine.FSurfaceRect, BoundsRect) then
		409	begin
		410	DoDraw;
		411	Inc(FEngine.FDrawCount);
		412	end;
		413	end;
		414
		415	if FDrawList<>nil then
		416	begin
		417	for i:=0 to FDrawList.Count-1 do
		418	TSprite(FDrawList[i]).Draw;
		419	end;
		420	end;
		421	end;
		422
		423	function TSprite.GetSpriteAt(X, Y: Integer): TSprite;
		424
		425	procedure Collision_GetSpriteAt(X, Y: Double; Sprite: TSprite);
		426	var
		427	i: Integer;
		428	X2, Y2: Double;
		429	begin
		430	if Sprite.Visible and PointInRect(Point(Round(X), Round(Y)), Bounds(Round(Sprite.X), Round(Sprite.Y), Sprite.Width, Sprite.Width)) then
		431	begin
		432	if (Result=nil) or (Sprite.Z>Result.Z) then
		433	Result := Sprite;
		434	end;
		435
		436	X2 := X-Sprite.X;
		437	Y2 := Y-Sprite.Y;
		438	for i:=0 to Sprite.Count-1 do
		439	Collision_GetSpriteAt(X2, Y2, Sprite.Items[i]);
		440	end;
		441
		442	var
		443	i: Integer;
		444	X2, Y2: Double;
		445	begin
		446	Result := nil;
		447
		448	X2 := X-Self.X;
		449	Y2 := Y-Self.Y;
		450	for i:=0 to Count-1 do
		451	Collision_GetSpriteAt(X2, Y2, Items[i]);
		452	end;
		453
		454	function TSprite.GetBoundsRect: TRect;
		455	begin
		456	Result := Bounds(Trunc(WorldX), Trunc(WorldY), Width, Height);
		457	end;
		458
		459	function TSprite.GetClientRect: TRect;
		460	begin
		461	Result := Bounds(0, 0, Width, Height);
		462	end;
		463
		464	function TSprite.GetCount: Integer;
		465	begin
		466	if FList<>nil then
		467	Result := FList.Count
		468	else
		469	Result := 0;
		470	end;
		471
		472	function TSprite.GetItem(Index: Integer): TSprite;
		473	begin
		474	if FList<>nil then
		475	Result := FList[Index]
		476	else
		477	raise ESpriteError.CreateFmt(SListIndexError, [Index]);
		478	end;
		479
		480	function TSprite.GetWorldX: Double;
		481	begin
		482	if Parent<>nil then
		483	Result := Parent.WorldX+FX
		484	else
		485	Result := FX;
		486	end;
		487
		488	function TSprite.GetWorldY: Double;
		489	begin
		490	if Parent<>nil then
		491	Result := Parent.WorldY+FY
		492	else
		493	Result := FY;
		494	end;
		495
		496	procedure TSprite.SetZ(Value: Integer);
		497	begin
		498	if FZ<>Value then
		499	begin
		500	FZ := Value;
		501	if Parent<>nil then
		502	begin
		503	Parent.FDrawList.Remove(Self);
		504	Parent.AddDrawList(Self);
		505	end;
		506	end;
		507	end;
		508
		509	{ TImageSprite }
		510
		511	constructor TImageSprite.Create(AParent: TSprite);
		512	begin
		513	inherited Create(AParent);
		514	FTransparent := True;
		515	end;
		516
		517	function TImageSprite.GetBoundsRect: TRect;
		518	var
		519	dx, dy: Integer;
		520	begin
		521	dx := Trunc(WorldX);
		522	dy := Trunc(WorldY);
		523	if FTile then
		524	begin
		525	dx := Mod2(dx, FEngine.SurfaceRect.Right+Width);
		526	dy := Mod2(dy, FEngine.SurfaceRect.Bottom+Height);
		527
		528	if dx>FEngine.SurfaceRect.Right then
		529	dx := (dx-FEngine.SurfaceRect.Right)-Width;
		530
		531	if dy>FEngine.SurfaceRect.Bottom then
		532	dy := (dy-FEngine.SurfaceRect.Bottom)-Height;
		533	end;
		534
		535	Result := Bounds(dx, dy, Width, Height);
		536	end;
		537
		538	procedure TImageSprite.DoMove(MoveCount: Integer);
		539	begin
		540	FAnimPos := FAnimPos + FAnimSpeed*MoveCount;
		541
		542	if FAnimLooped then
		543	begin
		544	if FAnimCount>0 then
		545	FAnimPos := Mod2f(FAnimPos, FAnimCount)
		546	else
		547	FAnimPos := 0;
		548	end else
		549	begin
		550	if FAnimPos>=FAnimCount then
		551	begin
		552	FAnimPos := FAnimCount-1;
		553	FAnimSpeed := 0;
		554	end;
		555	if FAnimPos<0 then
		556	begin
		557	FAnimPos := 0;
		558	FAnimSpeed := 0;
		559	end;
		560	end;
		561	end;
		562
		563	function TImageSprite.GetDrawImageIndex: Integer;
		564	begin
		565	Result := FAnimStart+Trunc(FAnimPos);
		566	end;
		567
		568	function TImageSprite.GetDrawRect: TRect;
		569	begin
		570	Result := BoundsRect;
		571	OffsetRect(Result, (Width-Image.Width) div 2, (Height-Image.Height) div 2);
		572	end;
		573
		574	procedure TImageSprite.DoDraw;
		575	var
		576	ImageIndex: Integer;
		577	r: TRect;
		578	begin
		579	ImageIndex := GetDrawImageIndex;
		580	r := GetDrawRect;
		581	Image.Draw(FEngine.Surface, r.Left, r.Top, ImageIndex);
		582	end;
		583
		584	function ImageCollisionTest(suf1, suf2: TDirectDrawSurface; const rect1, rect2: TRect;
		585	x1,y1,x2,y2: Integer; DoPixelCheck: Boolean): Boolean;
		586
		587	function ClipRect(var DestRect: TRect; const DestRect2: TRect): Boolean;
		588	begin
		589	with DestRect do
		590	begin
		591	Left := Max(Left, DestRect2.Left);
		592	Right := Min(Right, DestRect2.Right);
		593	Top := Max(Top, DestRect2.Top);
		594	Bottom := Min(Bottom, DestRect2.Bottom);
		595
		596	Result := (Left < Right) and (Top < Bottom);
		597	end;
		598	end;
		599
		600	type
		601	PRGB = ^TRGB;
		602	TRGB = packed record
		603	R, G, B: Byte;
		604	end;
		605	var
		606	ddsd1, ddsd2: TDDSurfaceDesc;
		607	r1, r2: TRect;
		608	tc1, tc2: DWORD;
		609	x, y, w, h: Integer;
		610	P1, P2: Pointer;
		611	begin
		612	r1 := rect1;
		613	with rect2 do r2 := Bounds(x2-x1, y2-y1, Right-Left, Bottom-Top);
		614
		615	Result := OverlapRect(r1, r2);
		616
		617	if (suf1=nil) or (suf2=nil) then Exit;
		618
		619	if DoPixelCheck and Result then
		620	begin
		621	{ Get Overlapping rectangle }
		622	with r1 do r1 := Bounds(Max(x2-x1, 0), Max(y2-y1, 0), Right-Left, Bottom-Top);
		623	with r2 do r2 := Bounds(Max(x1-x2, 0), Max(y1-y2, 0), Right-Left, Bottom-Top);
		624
		625	ClipRect(r1, rect1);
		626	ClipRect(r2, rect2);
		627
		628	w := Min(r1.Right-r1.Left, r2.Right-r2.Left);
		629	h := Min(r1.Bottom-r1.Top, r2.Bottom-r2.Top);
		630
		631	ClipRect(r1, bounds(r1.Left, r1.Top, w, h));
		632	ClipRect(r2, bounds(r2.Left, r2.Top, w, h));
		633
		634	{ Pixel check !!! }
		635	ddsd1.dwSize := SizeOf(ddsd1);
		636	if suf1.Lock(r1, ddsd1) then
		637	begin
		638	try
		639	ddsd2.dwSize := SizeOf(ddsd2);
		640	if (suf1=suf2) or suf2.Lock(r2, ddsd2) then
		641	begin
		642	try
		643	if suf1=suf2 then ddsd2 := ddsd1;
		644	if ddsd1.ddpfPixelFormat.dwRGBBitCount<>ddsd2.ddpfPixelFormat.dwRGBBitCount then Exit;
		645
		646	{ Get transparent color }
		647	tc1 := ddsd1.ddckCKSrcBlt.dwColorSpaceLowValue;
		648	tc2 := ddsd2.ddckCKSrcBlt.dwColorSpaceLowValue;
		649
		650	case ddsd1.ddpfPixelFormat.dwRGBBitCount of
		651	8 : begin
		652	for y:=0 to h-1 do
		653	begin
		654	P1 := Pointer(Integer(ddsd1.lpSurface)+y*ddsd1.lPitch);
		655	P2 := Pointer(Integer(ddsd2.lpSurface)+y*ddsd2.lPitch);
		656	for x:=0 to w-1 do
		657	begin
		658	if (PByte(P1)^<>tc1) and (PByte(P2)^<>tc2) then Exit;
		659	Inc(PByte(P1));
		660	Inc(PByte(P2));
		661	end;
		662	end;
		663	end;
		664	16: begin
		665	for y:=0 to h-1 do
		666	begin
		667	P1 := Pointer(Integer(ddsd1.lpSurface)+y*ddsd1.lPitch);
		668	P2 := Pointer(Integer(ddsd2.lpSurface)+y*ddsd2.lPitch);
		669	for x:=0 to w-1 do
		670	begin
		671	if (PWord(P1)^<>tc1) and (PWord(P2)^<>tc2) then Exit;
		672	Inc(PWord(P1));
		673	Inc(PWord(P2));
		674	end;
		675	end;
		676	end;
		677	24: begin
		678	for y:=0 to h-1 do
		679	begin
		680	P1 := Pointer(Integer(ddsd1.lpSurface)+y*ddsd1.lPitch);
		681	P2 := Pointer(Integer(ddsd2.lpSurface)+y*ddsd2.lPitch);
		682	for x:=0 to w-1 do
		683	begin
		684	if ((PRGB(P1)^.R shl 16) or (PRGB(P1)^.G shl 8) or PRGB(P1)^.B<>tc1) and
		685	((PRGB(P2)^.R shl 16) or (PRGB(P2)^.G shl 8) or PRGB(P2)^.B<>tc2) then Exit;
		686	Inc(PRGB(P1));
		687	Inc(PRGB(P2));
		688	end;
		689	end;
		690	end;
		691	32: begin
		692	for y:=0 to h-1 do
		693	begin
		694	P1 := Pointer(Integer(ddsd1.lpSurface)+y*ddsd1.lPitch);
		695	P2 := Pointer(Integer(ddsd2.lpSurface)+y*ddsd2.lPitch);
		696	for x:=0 to w-1 do
		697	begin
		698	if (PDWORD(P1)^ and $FFFFFF<>tc1) and (PDWORD(P2)^ and $FFFFFF<>tc2) then Exit;
		699	Inc(PDWORD(P1));
		700	Inc(PDWORD(P2));
		701	end;
		702	end;
		703	end;
		704	end;
		705	finally
		706	if suf1<>suf2 then suf2.UnLock;
		707	end;
		708	end;
		709	finally
		710	suf1.UnLock;
		711	end;
		712	end;
		713
		714	Result := False;
		715	end;
		716	end;
		717
		718	function TImageSprite.TestCollision(Sprite: TSprite): Boolean;
		719	var
		720	img1, img2: Integer;
		721	b1, b2: TRect;
		722	begin
		723	if (Sprite is TImageSprite) and FPixelCheck then
		724	begin
		725	b1 := GetDrawRect;
		726	b2 := TImageSprite(Sprite).GetDrawRect;
		727
		728	img1 := GetDrawImageIndex;
		729	img2 := TImageSprite(Sprite).GetDrawImageIndex;
		730
		731	Result := ImageCollisionTest(Image.PatternSurfaces[img1], TImageSprite(Sprite).Image.PatternSurfaces[img2],
		732	Image.PatternRects[img1], TImageSprite(Sprite).Image.PatternRects[img2],
		733	b1.Left, b1.Top, b2.Left, b2.Top, True);
		734	end else
		735	Result := inherited TestCollision(Sprite);
		736	end;
		737
		738	{ TImageSpriteEx }
		739
		740	constructor TImageSpriteEx.Create(AParent: TSprite);
		741	begin
		742	inherited Create(AParent);
		743	FAlpha := 255;
		744	end;
		745
		746	procedure TImageSpriteEx.DoDraw;
		747	var
		748	r: TRect;
		749	begin
		750	r := Bounds(Trunc(WorldX), Trunc(WorldY), Width, Height);
		751
		752	if FAngle and $FF=0 then
		753	begin
		754	if FAlpha<255 then
		755	begin
		756	Image.DrawAlpha(FEngine.FSurface, r, GetDrawImageIndex, FAlpha)
		757	end else
		758	begin
		759	Image.StretchDraw(FEngine.FSurface, r, GetDrawImageIndex);
		760	end;
		761	end else
		762	begin
		763	if FAlpha<255 then
		764	begin
		765	Image.DrawRotateAlpha(FEngine.FSurface, (r.Left+r.Right) div 2, (r.Top+r.Bottom) div 2,
		766	Width, Height, GetDrawImageIndex, 0.5, 0.5, FAngle, FAlpha)
		767	end else
		768	begin
		769	Image.DrawRotate(FEngine.FSurface, (r.Left+r.Right) div 2, (r.Top+r.Bottom) div 2,
		770	Width, Height, GetDrawImageIndex, 0.5, 0.5, FAngle)
		771	end;
		772	end;
		773	end;
		774
		775	function TImageSpriteEx.GetBoundsRect: TRect;
		776	begin
		777	Result := FEngine.SurfaceRect;
		778	end;
		779
		780	function TImageSpriteEx.TestCollision(Sprite: TSprite): Boolean;
		781	begin
		782	if Sprite is TImageSpriteEx then
		783	begin
		784	Result := OverlapRect(Bounds(Trunc(Sprite.WorldX), Trunc(Sprite.WorldY), Sprite.Width, Sprite.Height),
		785	Bounds(Trunc(WorldX), Trunc(WorldY), Width, Height));
		786	end else
		787	begin
		788	Result := OverlapRect(Sprite.BoundsRect, Bounds(Trunc(WorldX), Trunc(WorldY), Width, Height));
		789	end;
		790	end;
		791
		792	{ TBackgroundSprite }
		793
		794	constructor TBackgroundSprite.Create(AParent: TSprite);
		795	begin
		796	inherited Create(AParent);
		797	Collisioned := False;
		798	end;
		799
		800	destructor TBackgroundSprite.Destroy;
		801	begin
		802	SetMapSize(0, 0);
		803	inherited Destroy;
		804	end;
		805
		806	procedure TBackgroundSprite.DoDraw;
		807	var
		808	_x, _y, cx, cy, cx2, cy2, c, ChipWidth, ChipHeight: Integer;
		809	StartX, StartY, EndX, EndY, StartX_, StartY_, OfsX, OfsY, dWidth, dHeight: Integer;
		810	r: TRect;
		811	begin
		812	if Image=nil then Exit;
		813
		814	if (FMapWidth<=0) or (FMapHeight<=0) then Exit;
		815
		816	r := Image.PatternRects[0];
		817	ChipWidth := r.Right-r.Left;
		818	ChipHeight := r.Bottom-r.Top;
		819
		820	dWidth := (FEngine.SurfaceRect.Right+ChipWidth) div ChipWidth+1;
		821	dHeight := (FEngine.SurfaceRect.Bottom+ChipHeight) div ChipHeight+1;
		822
		823	_x := Trunc(WorldX);
		824	_y := Trunc(WorldY);
		825
		826	OfsX := _x mod ChipWidth;
		827	OfsY := _y mod ChipHeight;
		828
		829	StartX := _x div ChipWidth;
		830	StartX_ := 0;
		831
		832	if StartX<0 then
		833	begin
		834	StartX_ := -StartX;
		835	StartX := 0;
		836	end;
		837
		838	StartY := _y div ChipHeight;
		839	StartY_ := 0;
		840
		841	if StartY<0 then
		842	begin
		843	StartY_ := -StartY;
		844	StartY := 0;
		845	end;
		846
		847	EndX := Min(StartX+FMapWidth-StartX_, dWidth);
		848	EndY := Min(StartY+FMapHeight-StartY_, dHeight);
		849
		850	if FTile then
		851	begin
		852	for cy:=-1 to dHeight do
		853	begin
		854	cy2 := Mod2((cy-StartY+StartY_), FMapHeight);
		855	for cx:=-1 to dWidth do
		856	begin
		857	cx2 := Mod2((cx-StartX+StartX_), FMapWidth);
		858	c := Chips[cx2, cy2];
		859	if c>=0 then
		860	Image.Draw(FEngine.Surface, cxChipWidth+OfsX, cyChipHeight+OfsY, c);
		861	end;
		862	end;
		863	end else
		864	begin
		865	for cy:=StartY to EndY-1 do
		866	for cx:=StartX to EndX-1 do
		867	begin
		868	c := Chips[cx-StartX+StartX_, cy-StartY+StartY_];
		869	if c>=0 then
		870	Image.Draw(FEngine.Surface, cxChipWidth+OfsX, cyChipHeight+OfsY, c);
		871	end;
		872	end;
		873	end;
		874
		875	function TBackgroundSprite.TestCollision(Sprite: TSprite): Boolean;
		876	var
		877	b, b1, b2: TRect;
		878	cx, cy, ChipWidth, ChipHeight: Integer;
		879	r: TRect;
		880	begin
		881	Result := True;
		882	if Image=nil then Exit;
		883	if (FMapWidth<=0) or (FMapHeight<=0) then Exit;
		884
		885	r := Image.PatternRects[0];
		886	ChipWidth := r.Right-r.Left;
		887	ChipHeight := r.Bottom-r.Top;
		888
		889
		890
		891	b1 := Sprite.BoundsRect;
		892	b2 := BoundsRect;
		893
		894	IntersectRect(b, b1, b2);
		895
		896	OffsetRect(b, -Trunc(WorldX), -Trunc(WorldY));
		897	OffsetRect(b1, -Trunc(WorldX), -Trunc(WorldY));
		898
		899	for cy:=(b.Top-ChipHeight+1) div ChipHeight to b.Bottom div ChipHeight do
		900	for cx:=(b.Left-ChipWidth+1) div ChipWidth to b.Right div ChipWidth do
		901	if CollisionMap[Mod2(cx, MapWidth), Mod2(cy, MapHeight)] then
		902	begin
		903	if OverlapRect(Bounds(cxChipWidth, cyChipHeight, ChipWidth, ChipHeight), b1) then Exit;
		904	end;
		905
		906	Result := False;
		907	end;
		908
		909	function TBackgroundSprite.GetChip(X, Y: Integer): Integer;
		910	begin
		911	if (X>=0) and (X<FMapWidth) and (Y>=0) and (Y<FMapHeight) then
		912	Result := PInteger(Integer(FMap)+(YFMapWidth+X)SizeOf(Integer))^
		913	else
		914	Result := -1;
		915	end;
		916
		917	type
		918	PBoolean = ^Boolean;
		919
		920	function TBackgroundSprite.GetCollisionMapItem(X, Y: Integer): Boolean;
		921	begin
		922	if (X>=0) and (X<FMapWidth) and (Y>=0) and (Y<FMapHeight) then
		923	Result := PBoolean(Integer(FCollisionMap)+(YFMapWidth+X)SizeOf(Boolean))^
		924	else
		925	Result := False;
		926	end;
		927
		928	function TBackgroundSprite.GetBoundsRect: TRect;
		929	begin
		930	if FTile then
		931	Result := FEngine.SurfaceRect
		932	else
		933	begin
		934	if Image<>nil then
		935	Result := Bounds(Trunc(WorldX), Trunc(WorldY),
		936	Image.WidthFMapWidth, Image.HeightFMapHeight)
		937	else
		938	Result := Rect(0, 0, 0, 0);
		939	end;
		940	end;
		941
		942	procedure TBackgroundSprite.SetChip(X, Y: Integer; Value: Integer);
		943	begin
		944	if (X>=0) and (X<FMapWidth) and (Y>=0) and (Y<FMapHeight) then
		945	PInteger(Integer(FMap)+(YFMapWidth+X)SizeOf(Integer))^ := Value;
		946	end;
		947
		948	procedure TBackgroundSprite.SetCollisionMapItem(X, Y: Integer; Value: Boolean);
		949	begin
		950	if (X>=0) and (X<FMapWidth) and (Y>=0) and (Y<FMapHeight) then
		951	PBoolean(Integer(FCollisionMap)+(YFMapWidth+X)SizeOf(Boolean))^ := Value;
		952	end;
		953
		954	procedure TBackgroundSprite.SetMapHeight(Value: Integer);
		955	begin
		956	SetMapSize(FMapWidth, Value);
		957	end;
		958
		959	procedure TBackgroundSprite.SetMapWidth(Value: Integer);
		960	begin
		961	SetMapSize(Value, FMapHeight);
		962	end;
		963
		964	procedure TBackgroundSprite.SetMapSize(AMapWidth, AMapHeight: Integer);
		965	begin
		966	if (FMapWidth<>AMapWidth) or (FMapHeight<>AMapHeight) then
		967	begin
		968	if (AMapWidth<=0) or (AMapHeight<=0) then
		969	begin
		970	AMapWidth := 0;
		971	AMapHeight := 0;
		972	end;
		973	FMapWidth := AMapWidth;
		974	FMapHeight := AMapHeight;
		975	ReAllocMem(FMap, FMapWidthFMapHeightSizeOf(Integer));
		976	FillChar(FMap^, FMapWidthFMapHeightSizeOf(Integer), 0);
		977
		978	ReAllocMem(FCollisionMap, FMapWidthFMapHeightSizeOf(Boolean));
		979	FillChar(FCollisionMap^, FMapWidthFMapHeightSizeOf(Boolean), 1);
		980	end;
		981	end;
		982
		983	{ TSpriteEngine }
		984
		985	constructor TSpriteEngine.Create(AParent: TSprite);
		986	begin
		987	inherited Create(AParent);
		988	FDeadList := TList.Create;
		989	end;
		990
		991	destructor TSpriteEngine.Destroy;
		992	begin
		993	FDeadList.Free;
		994	inherited Destroy;
		995	end;
		996
		997	procedure TSpriteEngine.Dead;
		998	begin
		999	while FDeadList.Count>0 do
		1000	TSprite(FDeadList[FDeadList.Count-1]).Free;
		1001	end;
		1002
		1003	procedure TSpriteEngine.Draw;
		1004	begin
		1005	FDrawCount := 0;
		1006	inherited Draw;
		1007	end;
		1008
		1009	procedure TSpriteEngine.SetSurface(Value: TDirectDrawSurface);
		1010	begin
		1011	FSurface := Value;
		1012	if FSurface<>nil then
		1013	begin
		1014	FSurfaceRect := Surface.ClientRect;
		1015	Width := FSurfaceRect.Right-FSurfaceRect.Left;
		1016	Height := FSurfaceRect.Bottom-FSurfaceRect.Top;
		1017	end;
		1018	end;
		1019
		1020	{ TCustomDXSpriteEngine }
		1021
		1022	constructor TCustomDXSpriteEngine.Create(AOnwer: TComponent);
		1023	begin
		1024	inherited Create(AOnwer);
		1025	FEngine := TSpriteEngine.Create(nil);
		1026	end;
		1027
		1028	destructor TCustomDXSpriteEngine.Destroy;
		1029	begin
		1030	FEngine.Free;
		1031	inherited Destroy;
		1032	end;
		1033
		1034	procedure TCustomDXSpriteEngine.Notification(AComponent: TComponent;
		1035	Operation: TOperation);
		1036	begin
		1037	inherited Notification(AComponent, Operation);
		1038	if (Operation=opRemove) and (DXDraw=AComponent) then
		1039	DXDraw := nil;
		1040	end;
		1041
		1042	procedure TCustomDXSpriteEngine.Dead;
		1043	begin
		1044	FEngine.Dead;
		1045	end;
		1046
		1047	procedure TCustomDXSpriteEngine.Draw;
		1048	begin
		1049	if (FDXDraw<>nil) and (FDXDraw.Initialized) then
		1050	FEngine.Draw;
		1051	end;
		1052
		1053	procedure TCustomDXSpriteEngine.Move(MoveCount: Integer);
		1054	begin
		1055	FEngine.Move(MoveCount);
		1056	end;
		1057
		1058	procedure TCustomDXSpriteEngine.DXDrawNotifyEvent(Sender: TCustomDXDraw;
		1059	NotifyType: TDXDrawNotifyType);
		1060	begin
		1061	case NotifyType of
		1062	dxntDestroying: DXDraw := nil;
		1063	dxntInitialize: FEngine.Surface := Sender.Surface;
		1064	dxntFinalize : FEngine.Surface := nil;
		1065	end;
		1066	end;
		1067
		1068	procedure TCustomDXSpriteEngine.SetDXDraw(Value: TCustomDXDraw);
		1069	begin
		1070	if FDXDraw<>nil then
		1071	FDXDraw.UnRegisterNotifyEvent(DXDrawNotifyEvent);
		1072
		1073	FDXDraw := Value;
		1074
		1075	if FDXDraw<>nil then
		1076	FDXDraw.RegisterNotifyEvent(DXDrawNotifyEvent);
		1077	end;
		1078
		1079	end.

Subversion Repositories spacemission

spacemission/VCL_DELPHIX_D6/DXSprite.pas – Rev 1