Das ist eine einfache Ausführung, kann aber als Fundament für erweiterte Programmierung genutzt werden.
Geprüft werden die FPS-Beschleunigung, Windows LineTo Api und der Algorithmus der Grafikberechnung.
Es wird benötigt : 3xImage, 3xButton, 1xTimer
Der Timer sollte auf 1 (ms) gestellt werden und die Images müssen dementsprechend umbenannt werden, um den Code anzuwenden.
Die Image "ImgScene" prüft die FPS und sollte ein Bitmap mit 24 oder 32 Bitpixel beinhalten.
Unit uBmpLine.pas
unit uBmpLine;
INTERFACE
uses Windows, Graphics, Dialogs, Types;
type
TColorRec = record
case integer of
0 : ( Color : TColor );
1 : ( R,G,B,A : Byte );
end;
TBmpMemInfos = record
BpP,
BpL,
Scan0,
W,
H : Integer;
HDC : THandle;
end;
TBmp24Line = Array of pRGBTriple;
TBmp32Line = Array of pRGBQuad;
TBmp24LineCol = Array of TRGBTriple;
TBmp32LineCol = Array of TRGBQuad;
var
gBmpCol : TColorRec;
function BmpGetMemInfos(BMP: TBitmap; var Infos: TBmpMemInfos): Boolean;
procedure BmpMoveTo (Infos: TBmpMemInfos; X,Y: Integer);
procedure Bmp24LineTo(Infos: TBmpMemInfos; x2,y2: Integer);
procedure Bmp32LineTo(Infos: TBmpMemInfos; x2,y2: Integer);
procedure BmpGetLine (Infos: TBmpMemInfos; var LineArray: TBmp24Line; x1,y1,x2,y2: Integer; DrawLastPt: Boolean = true); overload;
procedure BmpGetLine (Infos: TBmpMemInfos; var LineArray: TBmp32Line; x1,y1,x2,y2: Integer; DrawLastPt: Boolean = true); overload;
procedure BmpGetCol (InfosDest, InfosSrc: TBmpMemInfos; LineArray: TBmp24Line; var ColArray: TBmp24LineCol); overload;
procedure BmpGetCol (InfosDest, InfosSrc: TBmpMemInfos; LineArray: TBmp32Line; var ColArray: TBmp32LineCol); overload;
IMPLEMENTATION
function ClipLine(var x1,y1,x2,y2: Integer; BmpXmax,BmpYmax: Integer; var DrawLastPt: Boolean): Boolean;
const
W : Integer = 1;
E : Integer = 2;
S : Integer = 4;
N : Integer = 8;
var
Region1, Region2 : Integer;
fx1,fy1,fx2,fy2 : Double;
begin
Result := false;
if y1<0 then Region1 := N else if y1>BmpYmax then Region1 := S else Region1 := 0;
if x1<0 then Region1 := (Region1 or W) else if x1>BmpXmax then Region1 := (Region1 or E);
if y2<0 then Region2 := N else if y2>BmpYmax then Region2 := S else Region2 := 0;
if x2<0 then Region2 := (Region2 or W) else if x2>BmpXmax then Region2 := (Region2 or E);
if (Region1 and Region2)<>0 then Exit;
DrawLastPt := Region2<>0;
if (Region1 or Region2)<>0 then begin
fx1 := x1;
fy1 := y1;
fx2 := x2;
fy2 := y2;
repeat
if (Region1 or Region2)=0 then begin
x1 := Round(fx1);
y1 := Round(fy1);
x2 := Round(fx2);
y2 := Round(fy2);
Break;
end;
if (Region1 and Region2)<>0 then Exit
else begin
if Region1<>0 then begin
if (Region1 and N)=N then begin
fx1:= fx1 + (fx1-fx2)*fy1/(fy2-fy1);
fy1:= 0; end
else if (Region1 and S)=S then begin
fx1:= fx1 + (fx2-fx1)*(BmpYmax-fy1)/(fy2-fy1);
fy1:= BmpYmax; end
else if (Region1 and E)=E then begin
fy1:= fy1 + (fy2-fy1)*(BmpXmax-fx1)/(fx2-fx1);
fx1:= BmpXmax; end
else begin
fy1:= fy1 + (fy1-fy2)*fx1/(fx2-fx1);
fx1:= 0; end;
if fy1<0 then Region1 := N else if fy1>BmpYmax then Region1 := S else Region1 := 0;
if fx1<0 then Region1 := (Region1 or W) else if fx1>BmpXmax then Region1 := (Region1 or E);
end
else begin
if (Region2 and N)= N then begin
fx2 := fx1 + (fx1-fx2)*fy1/(fy2-fy1);
fy2 := 0; end
else if (Region2 and S)=S then begin
fx2 := fx1 + (fx2-fx1)*(BmpYmax-fy1)/(fy2-fy1);
fy2 := BmpYmax; end
else if (Region2 and E)=E then begin
fy2 := fy1 + (fy2-fy1)*(BmpXmax-fx1)/(fx2-fx1);
fx2 := BmpXmax; end
else begin
fy2 := fy1 + (fy1-fy2)*fx1/(fx2-fx1);
fx2 := 0; end;
if fy2<0 then Region2 := N else if fy2>BmpYmax then Region2 := S else Region2 := 0;
if fx2<0 then Region2 := (Region2 or W) else if fx2>BmpXmax then Region2 := (Region2 or E);
end;
end;
until false;
end;
Result := true;
end;
function BmpGetMemInfos(BMP: TBitmap; var Infos: TBmpMemInfos): Boolean;
begin
Result := true;
case BMP.PixelFormat of
pf24bit : Infos.BpP := 3;
pf32bit : Infos.BpP := 4;
else begin
ShowMessage('Bitmap format not supported !'#10#10'(pf24bit or pf32bit only)');
Result := false;
Exit;
end;
end;
Infos.W := BMP.Width;
Infos.H := BMP.Height;
if (Infos.W<>0) and (Infos.H<>0) and (BMP<>nil) then begin
Infos.Scan0 := Integer(BMP.ScanLine[0]);
Infos.BpL := (((BMP.Width * Infos.BpP shl 3) + 31) and -31) shr 3; end
else begin
ShowMessage('One or two dimensions of the Bitmap are zero !');
Result := false;
Exit;
end;
if (BMP.Height>1) and (Integer(BMP.ScanLine[1])-Infos.Scan0>0) then begin
ShowMessage('Top-Down DIB not supported !'#10#10'(Bottom-Up DIB only)');
Result := false;
Exit;
end;
Infos.HDC := BMP.Canvas.Handle;
end;
procedure BmpMoveTo(Infos: TBmpMemInfos; X,Y: Integer);
begin
MoveToEx(Infos.HDC,X,Y,nil);
end;
procedure Bmp24LineTo(Infos: TBmpMemInfos; x2,y2: Integer);
var
DrawLastPt : Boolean;
de,dx,dy : Integer;
x1,y1 : Integer;
Pt1 : TPoint;
Col3 : TRGBTriple;
pPix3 : pRGBTriple;
MemLineSize: Integer;
MemPixSize : Integer;
PixelNbr : Integer;
begin
MoveToEx(Infos.HDC,x2,y2,@Pt1);
x1 := Pt1.X;
y1 := Pt1.Y;
if not ClipLine(x1,y1,x2,y2,Infos.W-1,Infos.H-1,DrawLastPt) then Exit;
if x2<x1 then begin
dx := x1-x2;
MemPixSize := -Infos.BpP end
else begin
dx := x2-x1;
MemPixSize := Infos.BpP;
end;
if y2<y1 then begin
dy := y1-y2;
MemLineSize := -Infos.BpL; end
else begin
dy := y2-y1;
MemLineSize := Infos.BpL
end;
Col3.rgbtRed := gBmpCol.R;
Col3.rgbtGreen:= gBmpCol.G;
Col3.rgbtBlue := gBmpCol.B;
pPix3 := pRGBTriple(Infos.Scan0 - y1*Infos.BpL + x1*3);
if dx>=dy then begin
de := dx;
dx := dx shl 1;
dy := dy shl 1;
for PixelNbr := 1 to de do begin
pPix3^ := Col3;
Inc(Integer(pPix3),MemPixSize);
Dec(de,dy);
if de<0 then begin
Dec(Integer(pPix3),MemLineSize);
Inc(de,dx);
end;
end; end
else begin
de := dy;
dy := dy shl 1;
dx := dx shl 1;
for PixelNbr := 1 to de do begin
pPix3^ := Col3;
Dec(Integer(pPix3),MemLineSize);
Dec(de,dx);
if de<0 then begin
Inc(Integer(pPix3),MemPixSize);
Inc(de,dy);
end;
end;
end;
if DrawLastPt then pPix3^ := Col3;
end;
procedure Bmp32LineTo(Infos: TBmpMemInfos; x2,y2: Integer);
var
DrawLastPt : Boolean;
de,dx,dy : Integer;
x1,y1 : Integer;
Pt1 : TPoint;
Col4 : TRGBQuad;
pPix4 : pRGBQuad;
MemLineSize: Integer;
MemPixSize : Integer;
PixelNbr : Integer;
begin
MoveToEx(Infos.HDC,x2,y2,@Pt1);
x1 := Pt1.X;
y1 := Pt1.Y;
if not ClipLine(x1,y1,x2,y2,Infos.W-1,Infos.H-1,DrawLastPt) then Exit;
if x2<x1 then begin
dx := x1-x2;
MemPixSize := -Infos.BpP end
else begin
dx := x2-x1;
MemPixSize := Infos.BpP;
end;
if y2<y1 then begin
dy := y1-y2;
MemLineSize := -Infos.BpL; end
else begin
dy := y2-y1;
MemLineSize := Infos.BpL
end;
with Col4 do begin
rgbRed := gBmpCol.R;
rgbGreen := gBmpCol.G;
rgbBlue := gBmpCol.B;
rgbReserved := gBmpCol.A;
end;
pPix4 := pRGBQuad(Infos.Scan0 - y1*Infos.BpL + x1*4);
if dx>=dy then begin
de := dx;
dx := dx shl 1;
dy := dy shl 1;
for PixelNbr := 1 to de do begin
pPix4^ := Col4;
Inc(Integer(pPix4),MemPixSize);
Dec(de,dy);
if de<0 then begin
Dec(Integer(pPix4),MemLineSize);
Inc(de,dx);
end;
end; end
else begin
de := dy;
dy := dy shl 1;
dx := dx shl 1;
for PixelNbr := 1 to de do begin
pPix4^ := Col4;
Dec(Integer(pPix4),MemLineSize);
Dec(de,dx);
if de<0 then begin
Inc(Integer(pPix4),MemPixSize);
Inc(de,dy);
end;
end;
end;
if DrawLastPt then pPix4^ := Col4;
end;
procedure BmpGetLine(Infos: TBmpMemInfos; var LineArray: TBmp24Line; x1,y1,x2,y2:
Integer; DrawLastPt: Boolean = true); overload;
var
de,dx,dy : Integer;
pPix3 : pRGBTriple;
MemLineSize: Integer;
MemPixSize : Integer;
PixelNbr : Integer;
begin
if not ClipLine(x1,y1,x2,y2,Infos.W-1,Infos.H-1,DrawLastPt) then Exit;
if x2<x1 then begin
dx := x1-x2;
MemPixSize := -Infos.BpP end
else begin
dx := x2-x1;
MemPixSize := Infos.BpP;
end;
if y2<y1 then begin
dy := y1-y2;
MemLineSize := -Infos.BpL; end
else begin
dy := y2-y1;
MemLineSize := Infos.BpL
end;
pPix3 := pRGBTriple(Infos.Scan0 - y1*Infos.BpL + x1*3);
if dx>=dy then begin
if DrawLastPt then SetLength(LineArray,dx+1) else SetLength(LineArray,dx);
de := dx;
dx := dx shl 1;
dy := dy shl 1;
for PixelNbr := 0 to de-1 do begin
LineArray[PixelNbr] := pPix3;
Inc(Integer(pPix3),MemPixSize);
Dec(de,dy);
if de<0 then begin
Dec(Integer(pPix3),MemLineSize);
Inc(de,dx);
end;
end; end
else begin
if DrawLastPt then SetLength(LineArray,dy+1) else SetLength(LineArray,dy);
de := dy;
dy := dy shl 1;
dx := dx shl 1;
for PixelNbr := 0 to de-1 do begin
LineArray[PixelNbr] := pPix3;
Dec(Integer(pPix3),MemLineSize);
Dec(de,dx);
if de<0 then begin
Inc(Integer(pPix3),MemPixSize);
Inc(de,dy);
end;
end;
end;
if DrawLastPt then LineArray[High(LineArray)] := pPix3;
end;
procedure BmpGetLine(Infos: TBmpMemInfos; var LineArray: TBmp32Line; x1,y1,x2,y2:
Integer; DrawLastPt: Boolean = true); overload;
var
de,dx,dy : Integer;
pPix4 : pRGBQuad;
MemLineSize: Integer;
MemPixSize : Integer;
PixelNbr : Integer;
begin
if not ClipLine(x1,y1,x2,y2,Infos.W-1,Infos.H-1,DrawLastPt) then Exit;
if x2<x1 then begin
dx := x1-x2;
MemPixSize := -Infos.BpP end
else begin
dx := x2-x1;
MemPixSize := Infos.BpP;
end;
if y2<y1 then begin
dy := y1-y2;
MemLineSize := -Infos.BpL; end
else begin
dy := y2-y1;
MemLineSize := Infos.BpL
end;
pPix4 := pRGBQuad(Infos.Scan0 - y1*Infos.BpL + x1*4);
if dx>=dy then begin
if DrawLastPt then SetLength(LineArray,dx+1) else SetLength(LineArray,dx);
de := dx;
dx := dx shl 1;
dy := dy shl 1;
for PixelNbr := 0 to de-1 do begin
LineArray[PixelNbr] := pPix4;
Inc(Integer(pPix4),MemPixSize);
Dec(de,dy);
if de < 0 then begin
Dec(Integer(pPix4),MemLineSize);
Inc(de,dx);
end;
end; end
else begin
if DrawLastPt then SetLength(LineArray,dy+1) else SetLength(LineArray,dy);
de := dy;
dy := dy shl 1;
dx := dx shl 1;
for PixelNbr := 0 to de-1 do begin
LineArray[PixelNbr] := pPix4;
Dec(Integer(pPix4),MemLineSize);
Dec(de,dx);
if de < 0 then begin
Inc(Integer(pPix4),MemPixSize);
Inc(de,dy);
end;
end;
end;
if DrawLastPt then LineArray[High(LineArray)] := pPix4;
end;
procedure BmpGetCol (InfosDest,InfosSrc: TBmpMemInfos; LineArray: TBmp24Line; var ColArray: TBmp24LineCol); overload;
var
i, Shift : Integer;
begin
Shift := InfosSrc.Scan0 - InfosDest.Scan0;
SetLength(ColArray, Length(LineArray));
for i := 0 to High(ColArray) do ColArray[i] := pRGBTriple(Integer(LineArray[i]) + Shift)^;
end;
procedure BmpGetCol(InfosDest,InfosSrc: TBmpMemInfos; LineArray: TBmp32Line; var ColArray: TBmp32LineCol); overload;
var
i, Shift : Integer;
begin
Shift := InfosSrc.Scan0 - InfosDest.Scan0;
SetLength(ColArray, Length(LineArray));
for i := 0 to High(ColArray) do ColArray[i] := pRGBQuad(Integer(LineArray[i]) + Shift)^;
end;
END.
Algo de Bresenham brut en Delphi (pour pf32bit) :
procedure Bmp32BresenhamLineTo(var BmpInfo: TMemBmpInfos; x2,y2: Integer);
const
W : Integer = 1;
E : Integer = 2;
S : Integer = 4;
N : Integer = 8;
var
Region1, Region2 : Integer;
BmpXmax, BmpYmax : Integer;
fx1,fy1,fx2,fy2 : Double;
DrawLastPoint : Boolean;
de,dx,dy : Integer;
x1,y1 : Integer;
Col : TRGBQuad;
pPix : pRGBQuad;
MemLineSize : Integer;
MemPixSize : Integer;
i : Integer;
begin
with BmpInfo do begin
MoveToEx(HDC,x2,y2,@Pt1);
x1 := Pt1.X;
y1 := Pt1.Y;
BmpXmax := W-1;
BmpYmax := H-1;
end;
if y1<0 then Region1 := N else if y1>BmpYmax then Region1 := S else Region1 := 0;
if x1<0 then Region1 := (Region1 or W) else if x1>BmpXmax then Region1 := (Region1 or E);
if y2<0 then Region2 := N else if y2>BmpYmax then Region2 := S else Region2 := 0;
if x2<0 then Region2 := (Region2 or W) else if x2>BmpXmax then Region2 := (Region2 or E);
if (Region1 and Region2)<>0 then Exit;
DrawLastPoint := Region2<>0;
if (Region1 or Region2)<>0 then begin
fx1 := x1;
fy1 := y1;
fx2 := x2;
fy2 := y2;
repeat
if (Region1 or Region2)=0 then begin
x1 := Round(fx1);
y1 := Round(fy1);
x2 := Round(fx2);
y2 := Round(fy2);
Break;
end;
if (Region1 and Region2)<>0 then Exit
else begin
if Region1<>0 then begin
if (Region1 and N)=N then begin
fx1:= fx1 + (fx1-fx2)*fy1/(fy2-fy1);
fy1:= 0; end
else if (Region1 and S)=S then begin
fx1:= fx1 + (fx2-fx1)*(BmpYmax-fy1)/(fy2-fy1);
fy1:= BmpYmax; end
else if (Region1 and E)=E then begin
fy1:= fy1 + (fy2-fy1)*(BmpXmax-fx1)/(fx2-fx1);
fx1:= BmpXmax; end
else begin
fy1:= fy1 + (fy1-fy2)*fx1/(fx2-fx1);
fx1:= 0; end;
if fy1<0 then Region1 := N else if fy1>BmpYmax then Region1 := S else Region1 := 0;
if fx1<0 then Region1 := (Region1 or W) else if fx1>BmpXmax then Region1 := (Region1 or E);
end
else begin
if (Region2 and N)= N then begin
fx2 := fx1 + (fx1-fx2)*fy1/(fy2-fy1);
fy2 := 0; end
else if (Region2 and S)=S then begin
fx2 := fx1 + (fx2-fx1)*(BmpYmax-fy1)/(fy2-fy1);
fy2 := BmpYmax; end
else if (Region2 and E)=E then begin
fy2 := fy1 + (fy2-fy1)*(BmpXmax-fx1)/(fx2-fx1);
fx2 := BmpXmax; end
else begin
fy2 := fy1 + (fy1-fy2)*fx1/(fx2-fx1);
fx2 := 0; end;
if fy2<0 then Region2 := N else if fy2>BmpYmax then Region2 := S else Region2 := 0;
if fx2<0 then Region2 := (Region2 or W) else if fx2>BmpXmax then Region2 := (Region2 or E);
end;
end;
until false;
end;
Col.rgbRed := gBmpCol.R;
Col.rgbGreen := gBmpCol.G;
Col.rgbBlue := gBmpCol.B;
Col.rgbReserved := gBmpCol.A;
dx := x2-x1;
dy := y2-y1;
pPix := pRGBQuad(BmpInfo.Scan0 - y1*BmpInfo.BpL + x1*4);
MemLineSize := BmpInfo.BpL;
MemPixSize := BmpInfo.BpP;
if dy=0 then begin
if dx<0 then begin
for x1 := x1 downto x2+1 do begin
pPix^ := Col;
Dec(pPix);
end; end
else if dx>0 then begin
for x1 := x1 to x2-1 do begin
pPix^ := Col;
Inc(pPix);
end;
end;
if DrawLastPoint then pPix^ := Col;
Exit;
end;
if dx=0 then begin
if dy<0 then begin
for y1 := y1 downto y2+1 do begin
pPix^ := Col;
Inc(Integer(pPix), MemLineSize);
end; end
else begin
for y1 := y1 to y2-1 do begin
pPix^ := Col;
Dec(Integer(pPix), MemLineSize);
end;
end;
if DrawLastPoint then pPix^ := Col;
Exit;
end;
if dx<0 then begin
if dy>0 then begin
if dx+dy<=0 then begin
de := dx;
dx := dx shl 1;
dy := dy shl 1;
for i := 1 to -de do begin
pPix^ := Col;
Dec(Integer(pPix), MemPixSize);
Inc(de,dy);
if de >= 0 then begin
Dec(Integer(pPix), MemLineSize);
Inc(de,dx);
end;
end; end
else begin
de := dy;
dy := de shl 1;
dx := dx shl 1;
for i := 1 to de do begin
pPix^ := Col;
Dec(Integer(pPix), MemLineSize);
Inc(de,dx);
if de <= 0 then begin
Dec(Integer(pPix), MemPixSize);
Inc(de,dy);
end;
end;
end; end
else begin
if dx <= dy then begin
de := dx;
dx := de shl 1;
dy := dy shl 1;
for i := 1 to -de do begin
pPix^ := Col;
Dec(Integer(pPix), MemPixSize);
Dec(de,dy);
if de >= 0 then begin
Inc(Integer(pPix), MemLineSize);
Inc(de,dx);
end;
end; end
else begin
de := dy;
dy := de shl 1;
dx := dx shl 1;
for i := 1 to -de do begin
pPix^ := Col;
Inc(Integer(pPix), MemLineSize);
Dec(de,dx);
if de >= 0 then begin
Dec(Integer(pPix), MemPixSize);
Inc(de,dy);
end;
end;
end;
end; end
else begin
if dy>0 then begin
if dx>=dy then begin
de:= dx;
dx:= de shl 1;
dy:= dy shl 1;
for i := 1 to de do begin
pPix^ := Col;
Inc(Integer(pPix), MemPixSize);
Dec(de,dy);
if de<0 then begin
Dec(Integer(pPix), MemLineSize);
Inc(de,dx);
end;
end; end
else begin
de := dy;
dy := de shl 1;
dx := dx shl 1;
for i := 1 to de do begin
pPix^ := Col;
Dec(Integer(pPix), MemLineSize);
Dec(de,dx);
if de < 0 then begin
Inc(Integer(pPix), MemPixSize);
Inc(de,dy)
end;
end;
end; end
else begin
if dx+dy >= 0 then begin
de := dx;
dx := de shl 1;
dy := dy shl 1;
for i := 1 to de do begin
pPix^ := Col;
Inc(Integer(pPix), MemPixSize);
Inc(de,dy);
if de < 0 then begin
Inc(Integer(pPix), MemLineSize);
Inc(de,dx);
end;
end; end
else begin
de := dy;
dy := de shl 1;
dx := dx shl 1;
for i := 1 to -de do begin
pPix^ := Col;
Inc(Integer(pPix), MemLineSize);
Inc(de,dx);
if de > 0 then begin
Inc(Integer(pPix), MemPixSize);
Inc(de,dy);
end;
end;
end;
end;
end;
if DrawLastPoint then pPix^ := Col;
end;
uses Math, uBmpLine
type
TRocket = record
TrajectoryArray : TBmp32Line;
TrajectColArray : TBmp32LineCol;
ProgressIndex : Integer;
end;
TFleet = array of TRocket;
const
XMAX = 400;
XMIN = -200;
YMAX = 400;
YMIN = -200;
TIMES = 1000000;
QROCKET : TRGBQuad = (rgbBlue: 100; rgbGreen: 100; rgbRed: 100; rgbReserved: 0);
QNOZZLE : TRGBQuad = (rgbBlue: 255; rgbGreen: 255; rgbRed: 255; rgbReserved: 0);
QFLAME : TRGBQuad = (rgbBlue: 70; rgbGreen: 128; rgbRed: 255; rgbReserved: 0);
var
gInitialScene : TBitmap;
gInitialSceneInfos : TBmpMemInfos;
gMyFleet : TFleet;
gVirtualTarget : TPoint = (X:0; Y:-10);
gFramesCount : Integer;
gFPStime : Int64;
//
procedure TForm1.btnAPITestClick(Sender: TObject);
var Btn : TButton absolute Sender;
Start, Elapsed : Int64;
i : Integer;
begin
imgAPI.Canvas.FillRect(imgAPI.Canvas.ClipRect);
imgAPI.Refresh;
Screen.Cursor := crHourGlass;
RandSeed := 0;
Start := GetTickCount;
for i := 1 to TIMES do begin
imgAPI.Canvas.Pen.Color := RandomRange(0,16777215);
Windows.LineTo(imgAPI.Canvas.Handle, RandomRange(XMIN,XMAX), RandomRange(YMIN,YMAX));
end;
Elapsed := GetTickCount-Start;
if Btn.Tag>Elapsed then begin
Btn.Tag := Elapsed;
Btn.Caption := Format('API Windows.LineTo' + #13#10 +'Temps mini : %.0n ms',[Elapsed/1]);
end;
imgAPI.Refresh;
Screen.Cursor := crDefault;
end;
procedure TForm1.btnALGOTestClick(Sender: TObject);
var Btn : TButton absolute Sender;
Infos : TBmpMemInfos;
Start, Elapsed : Int64;
i : Integer;
begin
imgALGO.Canvas.FillRect(imgALGO.Canvas.ClipRect);
imgALGO.Refresh;
if not BmpGetMemInfos(imgALGO.Picture.Bitmap, Infos) then Exit;
Screen.Cursor := crHourGlass;
RandSeed := 0;
Start := GetTickCount;
for i := 1 to TIMES do begin
gBmpCol.Color := RandomRange(0,16777215);
gBmpCol.A := 111;
if Infos.BpP=3
then Bmp24LineTo(Infos, RandomRange(XMIN,XMAX), RandomRange(YMIN,YMAX))
else Bmp32LineTo(Infos, RandomRange(XMIN,XMAX), RandomRange(YMIN,YMAX));
end;
Elapsed := GetTickCount-Start;
if Btn.Tag>Elapsed then begin
Btn.Tag := Elapsed;
Btn.Caption := Format('Delphi Algorithm LineTo' + #13#10 +'Temps mini : %.0n ms',[Elapsed/1]);
end;
imgALGO.Refresh;
Screen.Cursor := crDefault;
end;
procedure DoProgress;
var RocketIndex : Integer;
i, R, G, B : Integer;
QTrail : TRGBQuad;
FirstPix : Integer;
begin
RocketIndex := 0;
repeat
with gMyFleet[RocketIndex] do begin
if ProgressIndex<Length(TrajectoryArray) then TrajectoryArray[ProgressIndex]^ := QROCKET;
case ProgressIndex of
0 : TrajectoryArray[0]^ := QFLAME;
1..3: TrajectoryArray[ProgressIndex]^ := QROCKET;
4 : TrajectoryArray[1]^ := QNOZZLE;
5 : TrajectoryArray[2]^ := QNOZZLE;
6 : TrajectoryArray[3]^ := QNOZZLE;
7 : begin TrajectoryArray[4]^ := QNOZZLE;
TrajectoryArray[1]^ := QFLAME; end;
8 : begin TrajectoryArray[5]^ := QNOZZLE;
TrajectoryArray[2]^ := QFLAME; end;
9 : begin TrajectoryArray[6]^ := QNOZZLE;
TrajectoryArray[3]^ := QFLAME; end;
10 : begin TrajectoryArray[7]^ := QNOZZLE;
TrajectoryArray[4]^ := QFLAME; end;
11 : begin TrajectoryArray[8]^ := QNOZZLE;
TrajectoryArray[5]^ := QFLAME; end;
12 : begin TrajectoryArray[9]^ := QNOZZLE;
TrajectoryArray[6]^ := QFLAME; end;
else begin if ProgressIndex<Length(TrajectoryArray)+3
then TrajectoryArray[ProgressIndex-3]^ := QNOZZLE;
if ProgressIndex<Length(TrajectoryArray)+6
then TrajectoryArray[ProgressIndex-6]^ := QFLAME;
if ProgressIndex<Length(TrajectoryArray)+12 then begin
R := TrajectColArray[ProgressIndex-12].rgbGreen shl 2;
G := TrajectColArray[ProgressIndex-12].rgbGreen shl 2;
B := TrajectColArray[ProgressIndex-12].rgbBlue shl 2;
if R>255 then QTrail.rgbRed := 255 else QTrail.rgbRed := R;
if G>255 then QTrail.rgbGreen := 255 else QTrail.rgbGreen := G;
if B>255 then QTrail.rgbBlue := 255 else QTrail.rgbBlue := B;
QTrail.rgbReserved := 0;
TrajectoryArray[ProgressIndex-12]^ := QTrail;
end;
if ProgressIndex>=Length(TrajectoryArray) then begin
FirstPix := ProgressIndex-Length(TrajectoryArray);
TrajectoryArray[FirstPix]^ := TrajectColArray[FirstPix];
for i := FirstPix+1 to Length(TrajectoryArray)-1 do begin
R := Round(TrajectoryArray[i]^.rgbRed -(TrajectoryArray[i]^.rgbRed -TrajectColArray[i].rgbRed )*2/i);
G := Round(TrajectoryArray[i]^.rgbGreen-(TrajectoryArray[i]^.rgbGreen-TrajectColArray[i].rgbGreen)*2/i);
B := Round(TrajectoryArray[i]^.rgbBlue -(TrajectoryArray[i]^.rgbBlue -TrajectColArray[i].rgbBlue )*2/i);
if R<0 then QTrail.rgbRed := 0 else QTrail.rgbRed := R;
if G<0 then QTrail.rgbGreen := 0 else QTrail.rgbGreen := G;
if B<0 then QTrail.rgbBlue := 0 else QTrail.rgbBlue := B;
TrajectoryArray[i]^ := QTrail;
end;
end;
end;
end;
Inc(ProgressIndex);
if ProgressIndex = Length(TrajectoryArray) shl 1 then begin
if RocketIndex <> Length(gMyFleet)-1 then gMyFleet[RocketIndex] := gMyFleet[Length(gMyFleet)-1];
Dec(RocketIndex);
SetLength(gMyFleet, Length(gMyFleet)-1);
end;
Inc(RocketIndex);
end;
until RocketIndex=Length(gMyFleet);
Form1.imgScene.Refresh;
Inc(gFramesCount);
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
if Length(gMyFleet)<>0 then DoProgress;
Application.ProcessMessages;
Inc(gVirtualTarget.X);
if (gVirtualTarget.X>450) then gVirtualTarget.X := -100;
if gFramesCount>35 then begin
btnRockets.Caption := Format('ROCKETS LAUNCHER' + #13#10 +'( %u FPS ) ',[Round(1000/(GetTickCount-gFPStime)*gFramesCount)]);
gFramesCount := 0;
gFPStime := GetTickCount;
end;
Timer1.Enabled := Length(gMyFleet)<>0;
end;
procedure TForm1.btnRocketsClick(Sender: TObject);
var Infos : TBmpMemInfos;
RandomLine : TBmp32Line;
ColArray : TBmp32LineCol;
x1,y1,x2,y2 : Integer;
begin
if not BmpGetMemInfos(imgScene.Picture.Bitmap, Infos) then Exit;
x1 := RandomRange( 12,150);
y1 := RandomRange(150,200);
x2 := gVirtualTarget.X;
y2 := gVirtualTarget.Y;
BmpGetLine(Infos,RandomLine,x1,y1,x2,y2);
SetLength(ColArray, Length(RandomLine));
BmpGetCol(Infos, gInitialSceneInfos, RandomLine, ColArray);
SetLength(gMyFleet, Length(gMyFleet) + 1);
with gMyFleet[High(gMyFleet)] do begin
TrajectoryArray := RandomLine;
TrajectColArray := ColArray;
ProgressIndex := 0;
end;
gFramesCount := 0;
gFPStime := GetTickCount;
Timer1.Enabled := true;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
imgAPI .Picture.Bitmap.Width := imgAPI.Width;
imgAPI .Picture.Bitmap.Height := imgAPI.Height;
imgAPI .Picture.Bitmap.PixelFormat := pf32bit;
imgALGO .Picture.Bitmap.Width := imgALGO.Width;
imgALGO .Picture.Bitmap.Height := imgALGO.Height;
imgALGO .Picture.Bitmap.PixelFormat := pf32bit;
imgScene.Picture.Bitmap.PixelFormat := pf32bit;
gInitialScene := TBitmap.Create;
gInitialScene.Assign(imgScene.Picture.Bitmap);
if not BmpGetMemInfos(gInitialScene, gInitialSceneInfos) then Exit;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
gInitialScene.Free;
end;
Keine Kommentare:
Kommentar veröffentlichen