lazarus-ccr/applications/tappytux/tappydrawer.pas
sekelsenmat e295603a2f tappytux: Implements the hammer throwing
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@2155 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2011-11-17 14:28:03 +00:00

477 lines
12 KiB
ObjectPascal

unit tappydrawer;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Controls, Graphics, LCLType, IntfGraphics, fpimage,
Math, LCLIntf,
tappyconfig, tappymodules;
type
{ TTappyTuxAnimation }
TTappyTuxAnimation = class
public
StartPoint, EndPoint: TPoint;
Position: TPoint;
CurrentStep: Integer;
StepCount: Integer; // In miliseconds
IsInfinite: Boolean; // if True the animation will never end
Stopped: Boolean;
// User data
UserData: TObject;
UserPosition: TPoint;
constructor Create; virtual;
procedure DrawToIntfImg(AIntfImage: TLazIntfImage); virtual;
procedure DrawToCanvas(ACanvas: TCanvas); virtual;
procedure CalculatePosition;
procedure ExecuteFinal; virtual;
end;
{ TTappySpriteAnimation }
TTappySpriteAnimation = class(TTappyTuxAnimation)
public
Images: array of TLazIntfImage;
SpriteChangeInterval: Integer;
constructor Create; override;
destructor Destroy; override;
procedure DrawToIntfImg(AIntfImage: TLazIntfImage); override;
procedure ExecuteFinal; override;
procedure LoadImageFromPng(AIndex: Integer; APath: string);
end;
{ TFallingText }
TFallingText = class(TTappyTuxAnimation)
public
Caption: String;
Value: Integer;
ProcessOnEnd: Boolean;
Image: TLazIntfImage;
constructor Create; override;
destructor Destroy; override;
procedure DrawToIntfImg(AIntfImage: TLazIntfImage); override;
procedure DrawToCanvas(ACanvas: TCanvas); override;
procedure ExecuteFinal; override;
procedure LoadImageFromPng(APath: string);
end;
{ TTappyTuxDrawer }
TTappyTuxDrawer = class(TCustomControl)
private
imgSomething: TPortableNetworkGraphic;
FAnimationList: TFPList;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure EraseBackground(DC: HDC); override;
procedure Paint; override;
procedure DrawToCanvas(ACanvas: TCanvas);
class procedure DrawImageWithTransparentColor(
ADest: TLazIntfImage; const ADestX, ADestY: Integer; AColor: TFPColor;
AImage: TLazIntfImage);
class function DateTimeToMilliseconds(aDateTime: TDateTime): Int64;
//function GetImage(ATile: TChessTile): TPortableNetworkGraphic;
procedure HandleMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure HandleMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure HandleMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure HandleOnTimer(Sender: TObject);
function AddAnimation(AAnimation: TTappyTuxAnimation): Integer;
function GetAnimation(AIndex: Integer): TTappyTuxAnimation;
function GetAnimationIndex(AAnimation: TTappyTuxAnimation): Integer;
function GetAnimationCount: Integer;
procedure RemoveAnimation(AIndex: Integer);
procedure HandleAnimationOnTimer(AInterval: Integer);
end;
var
vTappyTuxDrawer: TTappyTuxDrawer;
implementation
{ TTappySpriteAnimation }
constructor TTappySpriteAnimation.Create;
begin
inherited Create;
SpriteChangeInterval := 1000;
end;
destructor TTappySpriteAnimation.Destroy;
var
i: Integer;
begin
for i := 0 to Length(Images)-1 do
if Assigned(Images[i]) then Images[i].Free;
inherited Destroy;
end;
procedure TTappySpriteAnimation.DrawToIntfImg(AIntfImage: TLazIntfImage);
var
lNumBitmaps, lCurBmpIndex: Integer;
begin
lNumBitmaps := Length(Images);
if lNumBitmaps = 0 then Exit;
lCurBmpIndex := (CurrentStep div SpriteChangeInterval) mod lNumBitmaps;
TTappyTuxDrawer.DrawImageWithTransparentColor(AIntfImage,
Position.X, Position.Y, colFuchsia, Images[lCurBmpIndex]);
end;
procedure TTappySpriteAnimation.ExecuteFinal;
begin
GetCurrentModule().ProcessSpriteEnd(UserData, UserPosition);
end;
procedure TTappySpriteAnimation.LoadImageFromPng(AIndex: Integer; APath: string);
var
lBitmap: TPortableNetworkGraphic;
begin
lBitmap := TPortableNetworkGraphic.Create;
try
lBitmap.LoadFromFile(APath);
Images[AIndex] := TLazIntfImage.Create(0, 0);
Images[AIndex].LoadFromBitmap(lBitmap.Handle, 0);
finally
lBitmap.Free;
end;
end;
{TFallingText}
constructor TFallingText.Create;
begin
inherited Create;
ProcessOnEnd := True;
end;
destructor TFallingText.Destroy;
begin
if Assigned(Image) then Image.Free;
inherited Destroy;
end;
procedure TFallingText.DrawToIntfImg(AIntfImage: TLazIntfImage);
begin
TTappyTuxDrawer.DrawImageWithTransparentColor(AIntfImage,
Position.X, Position.Y, colFuchsia, Image);
end;
procedure TFallingText.DrawToCanvas(ACanvas: TCanvas);
begin
ACanvas.Brush.Style := bsSolid;
ACanvas.Brush.Color := clWhite;
ACanvas.Pen.Style := psSolid;
ACanvas.Pen.Color := clBlack;
ACanvas.Rectangle(Position.X + 25, Position.Y + 45,
Position.X + 30 + ACanvas.TextWidth(Caption)+5,
Position.Y + 50 + ACanvas.TextHeight(Caption)+5);
ACanvas.TextOut(Position.X + 30, Position.Y + 50, caption);
end;
procedure TFallingText.ExecuteFinal;
var
snowmanWrong: TFallingText;
begin
if ProcessOnEnd then
begin
snowmanWrong := TFallingText.Create;
snowmanWrong.IsInfinite := False;
snowmanWrong.StartPoint := Position;
snowmanWrong.EndPoint := Position;
snowmanWrong.Position := Position;
snowmanWrong.caption:= 'Oh-oh!';
snowmanWrong.ProcessOnEnd := False;
snowmanWrong.StepCount := 2000;
snowmanWrong.LoadImageFromPng(vTappyTuxConfig.GetResourcesDir() + 'images' + PathDelim + 'sprites' + PathDelim + 'snowmanwrong.png');
vTappyTuxDrawer.AddAnimation(snowmanWrong);
GetCurrentModule().ProcessFallingTextEnd();
end;
end;
procedure TFallingText.LoadImageFromPng(APath: string);
var
lBitmap: TPortableNetworkGraphic;
begin
lBitmap := TPortableNetworkGraphic.Create;
try
lBitmap.LoadFromFile(APath);
Image := TLazIntfImage.Create(0, 0);
Image.LoadFromBitmap(lBitmap.Handle, 0);
finally
lBitmap.Free;
end;
end;
{ TTappyTuxAnimation }
constructor TTappyTuxAnimation.Create;
begin
inherited Create;
CurrentStep := 0;
StepCount := 20000;
end;
procedure TTappyTuxAnimation.DrawToIntfImg(AIntfImage: TLazIntfImage);
begin
end;
procedure TTappyTuxAnimation.DrawToCanvas(ACanvas: TCanvas);
begin
end;
procedure TTappyTuxAnimation.CalculatePosition;
var
t: Double;
begin
t := CurrentStep / StepCount;
Position.X := Round(StartPoint.X + t * (EndPoint.X - StartPoint.X));
Position.Y := Round(StartPoint.Y + t * (EndPoint.Y - StartPoint.Y));
end;
procedure TTappyTuxAnimation.ExecuteFinal;
begin
// inherit from this class and add something to ExecuteFinal
end;
constructor TTappyTuxDrawer.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FAnimationList := TFPList.Create;
// Events
OnMouseMove := @HandleMouseMove;
OnMouseUp := @HandleMouseUp;
OnMouseDown := @HandleMouseDown;
end;
destructor TTappyTuxDrawer.Destroy;
begin
FAnimationList.Free;
inherited Destroy;
end;
procedure TTappyTuxDrawer.EraseBackground(DC: HDC);
begin
// Don't erase the background
end;
procedure TTappyTuxDrawer.Paint;
var
x, y: integer;
Bitmap: TBitmap;
begin
Bitmap := TBitmap.Create;
try
// Initializes the Bitmap Size
Bitmap.Height := Height;
Bitmap.Width := Width;
DrawToCanvas(Bitmap.Canvas);
Canvas.Draw(0, 0, Bitmap);
finally
Bitmap.Free;
end;
end;
procedure TTappyTuxDrawer.DrawToCanvas(ACanvas: TCanvas);
var
col, row: integer;
lIntfImage: TLazIntfImage;
lTmpBmp: TBitmap;
X, Y: integer;
i: Integer;
lAnimation: TTappyTuxAnimation;
lStartTime, lAnimTime, lTimeDiff: TDateTime;
begin
{$IFDEF TAPPY_PROFILER}
lStartTime := Now;
{$ENDIF}
lIntfImage := TLazIntfImage.Create(0, 0);
lTmpBmp := TBitmap.Create;
try
// First draw the background
lIntfImage.LoadFromBitmap(GetCurrentModule().GetBackgroundImage(2).Handle, 0{bmpBoard.MaskHandle});
// Draw all animations via TLazIntfImage
for i := 0 to FAnimationList.Count - 1 do
begin
lAnimation := TTappyTuxAnimation(FAnimationList.Items[i]);
lAnimation.CalculatePosition();
{$IFDEF TAPPY_PROFILER}
lAnimTime := Now;
{$ENDIF}
lAnimation.DrawToIntfImg(lIntfImage);
{$IFDEF TAPPY_PROFILER}
lTimeDiff := Now - lAnimTime;
WriteLn(Format('[TTappyTuxDrawer.DrawToCanvas] %s %d DrawToIntfImage Performance: %7d ms', [lAnimation.ClassName, i, DateTimeToMilliseconds(lTimeDiff)]));
{$ENDIF}
end;
lTmpBmp.LoadFromIntfImage(lIntfImage);
ACanvas.Draw(0, 0, lTmpBmp);
// -------------------------
// Now TCanvas drawings
// -------------------------
// Second pass of animation drawings, now draw via TCanvas for using fonts
for i := 0 to FAnimationList.Count - 1 do
begin
lAnimation := TTappyTuxAnimation(FAnimationList.Items[i]);
lAnimation.DrawToCanvas(ACanvas);
end;
finally
lTmpBmp.Free;
lIntfImage.Free;
end;
{$IFDEF TAPPY_PROFILER}
lTimeDiff := Now - lStartTime;
WriteLn(Format('[TTappyTuxDrawer.DrawToCanvas] Performance: %7d ms', [DateTimeToMilliseconds(lTimeDiff)]));
{$ENDIF}
end;
class procedure TTappyTuxDrawer.DrawImageWithTransparentColor(ADest: TLazIntfImage;
const ADestX, ADestY: Integer; AColor: TFPColor; AImage: TLazIntfImage);
var
x, y, CurX, CurY: Integer;
lDrawWidth, lDrawHeight: Integer;
CurColor: TFPColor;
begin
// Take care not to draw outside the destination area
lDrawWidth := Min(ADest.Width - ADestX, AImage.Width);
lDrawHeight := Min(ADest.Height - ADestY, AImage.Height);
for y := 0 to lDrawHeight - 1 do
begin
for x := 0 to lDrawWidth - 1 do
begin
CurX := ADestX + x;
CurY := ADestY + y;
// Never draw outside the destination
if (CurX < 0) or (CurY < 0) then Continue;
CurColor := AImage.Colors[x, y];
if (AColor.Green <> CurColor.Green) or (AColor.Red <> CurColor.Red)
or (AColor.Blue <> CurColor.Blue) then
ADest.Colors[CurX, CurY] := CurColor;
end;
end;
end;
class function TTappyTuxDrawer.DateTimeToMilliseconds(aDateTime: TDateTime
): Int64;
var
TimeStamp: TTimeStamp;
begin
{Call DateTimeToTimeStamp to convert DateTime to TimeStamp:}
TimeStamp:= DateTimeToTimeStamp (aDateTime);
{Multiply and add to complete the conversion:}
Result:= TimeStamp.Time;
end;
procedure TTappyTuxDrawer.HandleMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
{ if Assigned(FDelegate) and (FDrawerState in [dsIdle, dsDragging]) then
FDelegate.HandleMouseMove(Sender, Shift, X, Y);}
end;
procedure TTappyTuxDrawer.HandleMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
{ if Assigned(FDelegate) and (FDrawerState in [dsIdle, dsDragging]) then
FDelegate.HandleMouseUp(Sender, Button, Shift, X, Y);}
end;
procedure TTappyTuxDrawer.HandleMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
{ if Assigned(FDelegate) and (FDrawerState in [dsIdle, dsDragging]) then
FDelegate.HandleMouseDown(Sender, Button, Shift, X, Y);}
end;
procedure TTappyTuxDrawer.HandleOnTimer(Sender: TObject);
begin
{ if FDrawerState = dsRunningAnimation then
begin
Inc(FAnimation.CurrentStep);
if FAnimation.CurrentStep >= FAnimation.FinalStep then
begin
FAnimation.ExecuteFinal;
FAnimation.Free;
FAnimation := nil;
FDrawerState := dsIdle;
end;
Invalidate();
end;}
end;
function TTappyTuxDrawer.AddAnimation(AAnimation: TTappyTuxAnimation): Integer;
begin
Result := FAnimationList.Add(AAnimation);
end;
function TTappyTuxDrawer.GetAnimation(AIndex: Integer): TTappyTuxAnimation;
begin
Result := TTappyTuxAnimation(FAnimationList.Items[AIndex]);
end;
function TTappyTuxDrawer.GetAnimationIndex(AAnimation: TTappyTuxAnimation
): Integer;
begin
Result := FAnimationList.IndexOf(AAnimation);
end;
function TTappyTuxDrawer.GetAnimationCount: Integer;
begin
Result := FAnimationList.Count;
end;
procedure TTappyTuxDrawer.RemoveAnimation(AIndex: Integer);
begin
FAnimationList.Delete(AIndex);
end;
procedure TTappyTuxDrawer.HandleAnimationOnTimer(AInterval: Integer);
var
i: Integer;
lAnimation: TTappyTuxAnimation;
begin
i := 0;
while i < FAnimationList.Count do
begin
lAnimation := GetAnimation(i);
if (not lAnimation.Stopped) then Inc(lAnimation.CurrentStep, AInterval);
if (not lAnimation.IsInfinite) and (lAnimation.CurrentStep >= lAnimation.StepCount)
and (not lAnimation.Stopped) then
begin
lAnimation.ExecuteFinal();
RemoveAnimation(i);
Continue;
end;
Inc(i);
end;
Self.Invalidate;
end;
end.