{************************************************************}
{ }
{ Pixelgenaue Kollision Abfrage mit Bitmaske }
{ }
{ Copyright (c) 2007 Henning Brackmann [url]www.blubplayer.de[/url] }
{ Erweiterung der Klasse von Sfaizst }
{************************************************************}
unit U_KollisionAbfrage;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls;
type
TBitMask =
class
private
FMaske:
array of array of Cardinal;
FSegmentSize,
//Segment der Maske in Bit
Fwidth, Fheight,
FwidthSegmentCount: integer;
procedure initMask;
public
property Width : Integer
read FWidth
write FWidth;
property Height : Integer
read FHeight
write FHeight;
procedure LoadFromGraphic(aBild: TBitmap);
procedure LoadFromStream(MS : TStream);
procedure LoadFromStreamEx(MS : TMemoryStream);
procedure SaveToStream(MS : TStream);
procedure SaveToStreamEx(MS : TMemoryStream);
function Collision(x1, y1, x2, y2: integer; BitMask2: TBitMask): boolean;
end;
TBitMaskArray =
class
private
FSize : Integer;
public
Masks :
Array of TBitMask;
property Size : Integer
read FSize
write FSize;
procedure LoadFromGraphic(aBild: TBitmap);
procedure LoadFromStream(MS : TStream);
procedure LoadFromStreamEx(MS : TMemoryStream);
procedure SaveToStream(MS : TStream);
procedure SaveToStreamEx(MS : TMemoryStream);
end;
implementation
function RectinRect(rect1,rect2: Trect): boolean;
begin
result := true;
if (rect1.Left >= rect2.BottomRight.x)
then result:=false;
if (rect1.top >= rect2.BottomRight.y)
then result:=false;
if (rect2.Left >= rect1.BottomRight.x)
then result:=false;
if (rect2.top >= rect1.BottomRight.y)
then result:=false;
end;
{ TBitMask }
procedure TBitMask.initMask;
var
tempWidth,tempHeight: integer;
x,y: integer;
begin
FSegmentSize := sizeof(Cardinal)*8;
//Unterscheidung ob Rest oder nicht
//Bei Rest würde sonst Addition von 1 falsches Ergebnis ergeben
if (FWidth
mod FSegmentSize) = 0
then
tempWidth := FWidth
div FSegmentSize
else
tempWidth := trunc(FWidth/FSegmentSize)+1;
FwidthSegmentCount := tempWidth;
tempHeight := FHeight;
setlength(FMaske,tempWidth,tempHeight);
for x := 0
to tempWidth - 1
do
for y := 0
to tempHeight - 1
do
FMaske[x,y]:=0;
end;
procedure TBitMask.LoadFromGraphic(aBild: TBitmap);
type
PixArray =
Array [1..3]
of byte;
var
p: ^PixArray;
x,y: integer;
Color: longint;
Bild: TBitmap;
Segment: Cardinal;
begin
Fwidth := aBild.width;
Fheight := aBild.Height;
initMask;
Bild:= TBitmap.create;
Bild.Assign(aBild);
aBild.PixelFormat := pf24bit;
//Reihenfolge (Scanline) der Farbwerte pro Pixel: Blau - Grün - Rot.
Color:=ColortoRGB(aBild.TransparentColor);
for y:=0
to bild.Height-1
do
begin
p:= bild.ScanLine[y];
for x:=bild.Width-1
downto 0
do //downto wegen or 1 und nicht and 100000...
begin
Segment := FMaske[FwidthSegmentCount-1 - (x
div FSegmentSize),y];
if (GetBValue(Color)=p^[1])
and (GetGValue(Color)=p^[2])
and (GetRValue(Color)=p^[3])
then
begin
//transparentefarbe --> 0
Segment := Segment
shl 1;
end
else
begin
//nicht transparentefarbe --> 1
Segment := Segment
shl 1;
Segment := Segment
or 1;
end;
FMaske[FwidthSegmentCount-1 - (x
div FSegmentSize),y] := Segment;
Inc(p);
end;
end;
Bild.free;
end;
procedure TBitMask.LoadFromStreamEx(MS: TMemoryStream);
var x,y : Integer;
begin
InitMask;
for x := 0
to High(FMaske)
do
for y := 0
to High(FMaske[x])
do
MS.ReadBuffer(FMaske[x,y],sizeof(Cardinal));
end;
procedure TBitMask.LoadFromStream(MS: TStream);
var
TmpMs : TMemoryStream;
begin
TmpMs := TMemoryStream.Create;
try
MS.Position := 0;
TmpMs.CopyFrom(MS,MS.Size);
TmpMs.Position := 0;
TmpMs.ReadBuffer(FWidth,sizeof(Integer));
TmpMs.ReadBuffer(FHeight,sizeof(Integer));
LoadFromStreamEx(TmpMS);
MS.Position := 0;
finally
TmpMS.Free;
end;
end;
procedure TBitMask.SaveToStreamEx(MS: TMemoryStream);
var x,y : Integer;
begin
for x := 0
to High(FMaske)
do
for y := 0
to High(FMaske[x])
do
MS.WriteBuffer(FMaske[x,y],sizeof(Cardinal));
end;
procedure TBitMask.SaveToStream(MS: TStream);
var
TmpMS : TMemoryStream;
begin
TmpMS := TMemoryStream.Create;
try
TmpMs.WriteBuffer(FWidth,sizeof(Integer));
TmpMs.WriteBuffer(FHeight,sizeof(Integer));
SaveToStreamEx(TmpMS);
Ms.Position := 0;
MS.CopyFrom(TmpMs,TmpMs.Size);
Ms.Position := 0;
finally
TmpMS.Free;
end;
end;
function TBitMask.Collision(x1,y1: integer; x2,y2: integer; BitMask2: TBitMask): boolean;
var
y1start,y1ende: integer;
y2start,y2ende: integer;
x1SegmentStart,x1SegmentEnde: integer;
x2SegmentStart,x2SegmentEnde: integer;
tempSegment: Cardinal;
x,y: integer;
shiftcountRight: integer;
shiftcountLeft: integer;
indexLeftBild1Segment: integer;
indexRightBild1Segment: integer;
Bild1CalcWidth,Bild2CalcWidth: integer;
SchnittRect: TRect;
Bild1SchnittRect: TRect;
Bild2SchnittRect: TRect;
begin
if RectinRect(Rect(x1,y1,x1+Fwidth,y1+Fheight),Rect(x2,y2,x2+BitMask2.Fwidth,y2+BitMask2.Fheight))
then
begin
//Koordinaten umrechnen durch die einteilung in elemnet
//ist Bildbreite immer vielfaches von 32 Also muss Von der normalen breite
//umgerechnet werden
x1:=x1-(FwidthSegmentCount*FSegmentSize-FWidth);
x2:=x2-(BitMask2.FwidthSegmentCount*FSegmentSize-BitMask2.FWidth);
//Breite umrechnen
Bild1CalcWidth := self.FwidthSegmentCount*FSegmentSize;
Bild2CalcWidth := BitMask2.FwidthSegmentCount*FSegmentSize;
IntersectRect(SchnittRect,Rect(x1,y1,x1+Bild1CalcWidth,y1+Fheight),Rect(x2,y2,x2+Bild2CalcWidth,y2+BitMask2.Fheight));
Bild1SchnittRect := Rect(SchnittRect.Left-x1,SchnittRect.Top-y1,SchnittRect.Right-x1-1,SchnittRect.Bottom-y1-1);
Bild2SchnittRect := Rect(SchnittRect.Left-x2,SchnittRect.Top-y2,SchnittRect.Right-x2-1,SchnittRect.Bottom-y2-1);
y1start := Bild1SchnittRect.top;
y1ende := Bild1SchnittRect.bottom;
y2start := Bild2SchnittRect.top;
y2ende := Bild2SchnittRect.bottom;
x1SegmentStart := Bild1SchnittRect.Left
div FSegmentsize;
x1SegmentEnde := Bild1SchnittRect.Right
div FSegmentsize;
x2SegmentStart := Bild2SchnittRect.Left
div FSegmentsize;
x2SegmentEnde := Bild2SchnittRect.Right
div FSegmentsize;
shiftcountRight := (Bild2CalcWidth+(x2-x1))
mod FSegmentsize;
shiftcountLeft := FSegmentsize-shiftcountRight;
result := false;
for x := x2SegmentStart
to x2SegmentEnde
do
begin
if (x2+x*FSegmentsize)>=(x1+x1SegmentStart*FSegmentsize)
then
begin //Es gibt links vom Element ein Bild1 element
indexLeftBild1Segment := (x2+(x)*FSegmentsize-x1)
div FSegmentsize;
for y := y2start
to y2ende
do
begin
tempSegment := (BitMask2.Fmaske[x,y]
shr shiftcountRight);
if (FMaske[indexLeftBild1Segment,y1start+y-y2start]
and tempSegment)<>0
then
begin
result:=true;
exit;
end;
end;
end;
if (x2+x*FSegmentsize)<=(x1+x1SegmentEnde*FSegmentsize)
then
begin //Es gibt rechts vom Element ein Bild1 element
indexRightBild1Segment := ((x2-1-x1+FSegmentSize+(x*FSegmentsize))
div FSegmentsize);
for y := y2start
to y2ende
do
begin
tempSegment := (BitMask2.Fmaske[x,y]
shl shiftcountLeft);
if (FMaske[indexRightBild1Segment,y1start+y-y2start]
and tempSegment)<>0
then
begin
result:=true;
exit;
end;
end;
end;
end;
end;
end;
{ TBitMaskArray }
procedure TBitMaskArray.LoadFromGraphic(aBild: TBitmap);
var
TmpBild : tBitmap;
I, TilePosX, TilePosY : Integer;
begin
if FSize = 0
then fSize := 32;
TmpBild := TBitmap.Create;
TmpBild.Width := fSize;
TmpBild.Height := fSize;
SetLength(Masks,(aBild.Height * aBild.Width)
div FSize);
for I := 0
to ((aBild.Height * aBild.Width)
div FSize)-1
do
begin
if I = 0
then
begin
TilePosX := 0;
TilePosY := 0;
end Else
begin
if TilePosX < (aBild.Width
div FSize) -1
then
Inc(TilePosX)
Else
begin
TilePosX := 0;
Inc(TilePosY);
end;
end;
TmpBild.Canvas.CopyRect(Rect(0, 0, TmpBild.Width, TmpBild.Height), aBild.Canvas, Rect(TilePosX*FSize,TilePosY+FSize,(TilePosX+1)*fSize,(TilePosY+1)*FSize));
Masks[I] := TBitMask.Create;
with Masks[I]
do
begin
Width := fSize;
Height := fSize;
LoadFromGraphic(TmpBild);
end;
end;
end;
procedure TBitMaskArray.LoadFromStreamEx(MS: TMemoryStream);
var I : Integer;
begin
if FSize = 0
then fSize := 32;
for I := 0
to High(Masks)
do
begin
Masks[I] := TBitMask.Create;
with Masks[I]
do
begin
Width := fSize;
Height := fSize;
LoadFromStreamEx(MS);
end;
end;
end;
procedure TBitMaskArray.LoadFromStream(MS: TStream);
var
TmpMs : TMemoryStream;
CountInt : Integer;
begin
TmpMs := TMemoryStream.Create;
try
MS.Position := 0;
TmpMs.CopyFrom(MS,MS.Size);
TmpMs.Position := 0;
TmpMs.ReadBuffer(FSize,sizeof(Integer));
TmpMs.ReadBuffer(CountInt,sizeof(Integer));
SetLength(Masks,CountInt);
LoadFromStreamEx(TmpMS);
MS.Position := 0;
finally
TmpMS.Free;
end;
end;
procedure TBitMaskArray.SaveToStreamEx(MS: TMemoryStream);
var I : Integer;
begin
for I := 0
to High(Masks)
do
begin
Masks[I].SaveToStreamEx(MS);
end;
end;
procedure TBitMaskArray.SaveToStream(MS: TStream);
var
TmpMs : TMemoryStream;
CountInt : integer;
begin
TmpMs := TMemoryStream.Create;
try
TmpMs.WriteBuffer(FSize,sizeof(Integer));
CountInt := Length(Masks);
TmpMs.WriteBuffer(CountInt,sizeof(Integer));
SaveToStreamEx(TmpMS);
TmpMs.Position := 0;
Ms.CopyFrom(TmpMs,TmpMs.Size);
finally
TmpMS.Free;
end;
end;
end.