
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@2155 8e941d3f-bd1b-0410-a28a-d453659cc2b4
477 lines
12 KiB
ObjectPascal
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.
|