pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

Two new base files for tappytux

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@1917 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
sekelsenmat
2011-09-07 17:22:27 +00:00
parent 038e92b0a3
commit 0eb804c777
2 changed files with 394 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

78
applications/tappytux/tappytuxconfig.pas Normal file
View File

@@ -0,0 +1,78 @@
unit tappytuxconfig;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms;
type
{ TTappyTuxConfig }
TTappyTuxConfig = class
public
function GetResourcesDir: string;
function GetCurrentSkinDir: string;
end;
const
STR_LINUX_RESOURCES_FOLDER = '/usr/share/tappytux/';
var
vTappyTuxConfig: TTappyTuxConfig;
implementation
{$ifdef Darwin}
uses
MacOSAll;
{$endif}
const
BundleResourcesDirectory = '/Contents/Resources/';
{ TChessConfig }
function TTappyTuxConfig.GetResourcesDir: string;
{$ifdef Darwin}
var
pathRef: CFURLRef;
pathCFStr: CFStringRef;
pathStr: shortstring;
{$endif}
begin
{$ifdef UNIX}
{$ifdef Darwin}
pathRef := CFBundleCopyBundleURL(CFBundleGetMainBundle());
pathCFStr := CFURLCopyFileSystemPath(pathRef, kCFURLPOSIXPathStyle);
CFStringGetPascalString(pathCFStr, @pathStr, 255, CFStringGetSystemEncoding());
CFRelease(pathRef);
CFRelease(pathCFStr);
Result := pathStr + BundleResourcesDirectory;
{$else}
Result := STR_LINUX_RESOURCES_FOLDER;
{$endif}
{$endif}
{$ifdef Windows}
Result := ExtractFilePath(Application.EXEName);
{$endif}
end;
function TTappyTuxConfig.GetCurrentSkinDir: string;
begin
Result := GetResourcesDir() + 'skins' + PathDelim + 'classic' + PathDelim;
end;
initialization
vTappyTuxConfig := TTappyTuxConfig.Create;
finalization
vTappyTuxConfig.Free;
end.

316
applications/tappytux/tappytuxdrawer.pas Normal file
View File

@@ -0,0 +1,316 @@
unit tappytuxdrawer;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Controls, Graphics, LCLType, IntfGraphics, fpimage,
Math,
tappytuxgamedata, tappytuxconfig;
type
TTappyTuxAnimation = class
CurrentStep: Integer;
FinalStep: Integer;
constructor Create;
procedure DrawToIntfImg(AIntfImg: TLazIntfImage); virtual; abstract;
procedure ExecuteFinal; virtual; abstract;
end;
{ TFireAnimation }
TFireAnimation = class(TTappyTuxAnimation)
public
procedure DrawToIntfImg(AIntfImg: TLazIntfImage); override;
procedure ExecuteFinal; override;
end;
{ TTappyTuxDrawer }
TTappyTuxDrawer = class(TCustomControl)
private
imgSomething: TPortableNetworkGraphic;
FAnimationList: TFPList;
public
constructor Create(AOwner: TComponent); override;
procedure EraseBackground(DC: HDC); override;
procedure Paint; override;
procedure DrawToCanvas(ACanvas: TCanvas);
procedure DrawImageWithTransparentColor(
ADest: TLazIntfImage; const ADestX, ADestY: Integer; AColor: TFPColor;
AImage: TFPImageBitmap);
function GetChessTileImage(ATile: TChessTile): TPortableNetworkGraphic;
procedure LoadImages();
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);
procedure AddAnimation(AAnimation: TTappyTuxAnimation);
end;
var
vTappyTuxDrawer: TTappyTuxDrawer;
implementation
{ TFireAnimation }
procedure TFireAnimation.DrawToIntfImg(AIntfImg: TLazIntfImage);
var
lTileBmp: TPortableNetworkGraphic;
X, Y, SourceX, SourceY, DestX, DestY: integer;
dx, dy: Integer;
t: Double;
lTile: TChessTile;
begin
{ // Draw the moving tile
//WriteLn(Format('[TChessMoveAnimation.DrawToIntfImg] Afrom=%d,%d', [AFrom.X, AFrom.Y]));
lTile := vChessGame.Board[AFrom.X][AFrom.Y];
lTileBmp := vChessDrawer.GetChessTileImage(lTile);
if lTileBmp = nil then Exit;
SourceX := (AFrom.X - 1) * INT_CHESSTILE_SIZE;
SourceY := (8 - AFrom.Y) * INT_CHESSTILE_SIZE;
DestX := (ATo.X - 1) * INT_CHESSTILE_SIZE;
DestY := (8 - ATo.Y) * INT_CHESSTILE_SIZE;
t := CurrentStep / FinalStep;
X := Round(t * DestX + (1-t) * SourceX);
Y := Round(t * DestY + (1-t) * SourceY);
vChessDrawer.DrawImageWithTransparentColor(AIntfImg, X, Y, FPCOLOR_TRANSPARENT_TILE, lTileBmp);}
end;
procedure TFireAnimation.ExecuteFinal;
begin
vChessGame.MovePiece(AFrom, ATo);
end;
{ TTappyTuxAnimation }
constructor TTappyTuxAnimation.Create;
begin
inherited Create;
CurrentStep := 0;
FinalStep := 20;
end;
constructor TTappyTuxDrawer.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
{ imgBoard := TPortableNetworkGraphic.Create;
imgWPawn := TPortableNetworkGraphic.Create;
imgWKnight := TPortableNetworkGraphic.Create;
imgWBishop := TPortableNetworkGraphic.Create;
imgWRook := TPortableNetworkGraphic.Create;
imgWQueen := TPortableNetworkGraphic.Create;
imgWKing := TPortableNetworkGraphic.Create;
imgBPawn := TPortableNetworkGraphic.Create;
imgBKnight := TPortableNetworkGraphic.Create;
imgBBishop := TPortableNetworkGraphic.Create;
imgBRook := TPortableNetworkGraphic.Create;
imgBQueen := TPortableNetworkGraphic.Create;
imgBKing := TPortableNetworkGraphic.Create;}
// Events
OnMouseMove := @HandleMouseMove;
OnMouseUp := @HandleMouseUp;
OnMouseDown := @HandleMouseDown;
end;
procedure TTappyTuxDrawer.EraseBackground(DC: HDC);
begin
// Uncomment this to enable default background erasing
//inherited EraseBackground(DC);
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;
// inherited Paint;
end;
procedure TTappyTuxDrawer.DrawToCanvas(ACanvas: TCanvas);
var
col, row: integer;
lIntfImage: TLazIntfImage;
lTmpBmp: TBitmap;
lTileBmp: TPortableNetworkGraphic;
X, Y: integer;
begin
lIntfImage := TLazIntfImage.Create(0, 0);
lTmpBmp := TBitmap.Create;
try
// First draw the board
lIntfImage.LoadFromBitmap(imgBoard.Handle, 0{bmpBoard.MaskHandle});
// Now all pieces
for col := 1 to 8 do
for row := 1 to 8 do
begin
// Check if the animation wants us to skip drawing this piece
if Assigned(FAnimation) and FAnimation.SkipDrawingPiece(col, row) then Continue;
lTileBmp := GetChessTileImage(vChessGame.Board[col][row]);
if lTileBmp = nil then Continue;
X := (col - 1) * INT_CHESSTILE_SIZE;
Y := (8 - row) * INT_CHESSTILE_SIZE;
DrawImageWithTransparentColor(lIntfImage, X, Y, FPCOLOR_TRANSPARENT_TILE, lTileBmp);
end;
// Now animations
if Assigned(FAnimation) then FAnimation.DrawToIntfImg(lIntfImage);
lTmpBmp.LoadFromIntfImage(lIntfImage);
ACanvas.Draw(0, 0, lTmpBmp);
finally
lTmpBmp.Free;
lIntfImage.Free;
end;
end;
procedure TTappyTuxDrawer.DrawImageWithTransparentColor(ADest: TLazIntfImage;
const ADestX, ADestY: Integer; AColor: TFPColor; AImage: TFPImageBitmap);
var
x, y, CurX, CurY: Integer;
IntfImage: TLazIntfImage;
lDrawWidth, lDrawHeight: Integer;
CurColor: TFPColor;
lCurColorDiv, lTranspColorDiv: Byte;
begin
IntfImage := TLazIntfImage.Create(0,0);
try
IntfImage.LoadFromBitmap(AImage.Handle, AImage.MaskHandle);
// 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 := IntfImage.Colors[x, y]; // Good for debugging
lCurColorDiv := CurColor.Green div $FF;
lTranspColorDiv := AColor.Green div $FF;
if lCurColorDiv <> lTranspColorDiv then
ADest.Colors[CurX, CurY] := IntfImage.Colors[x, y];
end;
end;
finally
IntfImage.Free;
end;
end;
function TTappyTuxDrawer.GetChessTileImage(ATile: TChessTile): TPortableNetworkGraphic;
begin
{ case ATile of
ctWPawn: Result := imgWPawn;
ctWKnight: Result := imgWKnight;
ctWBishop: Result := imgWBishop;
ctWRook: Result := imgWRook;
ctWQueen: Result := imgWQueen;
ctWKing: Result := imgWKing;
ctBPawn: Result := imgBPawn;
ctBKnight: Result := imgBKnight;
ctBBishop: Result := imgBBishop;
ctBRook: Result := imgBRook;
ctBQueen: Result := imgBQueen;
ctBKing: Result := imgBKing;
else
Result := nil;
end;}
end;
procedure TTappyTuxDrawer.LoadImages();
var
lDir: string;
begin
lDir := vChessConfig.GetCurrentSkinDir();
{ imgBoard.LoadFromFile(lDir + 'base.png');
imgWPawn.LoadFromFile(lDir + 'wpawn.png');
imgWKnight.LoadFromFile(lDir + 'wknight.png');
imgWBishop.LoadFromFile(lDir + 'wbishop.png');
imgWRook.LoadFromFile(lDir + 'wrook.png');
imgWQueen.LoadFromFile(lDir + 'wqueen.png');
imgWKing.LoadFromFile(lDir + 'wking.png');
imgBPawn.LoadFromFile(lDir + 'bpawn.png');
imgBKnight.LoadFromFile(lDir + 'bknight.png');
imgBBishop.LoadFromFile(lDir + 'bbishop.png');
imgBRook.LoadFromFile(lDir + 'brook.png');
imgBQueen.LoadFromFile(lDir + 'bqueen.png');
imgBKing.LoadFromFile(lDir + 'bking.png');}
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;
procedure TTappyTuxDrawer.AddAnimation(AAnimation: TChessAnimation);
begin
{ FDrawerState := dsRunningAnimation;
FAnimation := AAnimation;}
end;
end.