Patch from Brian, adds pawn promotion + some changes from me

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@1882 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
sekelsenmat
2011-09-01 05:41:04 +00:00
parent 6d981c0a9c
commit 60540877cb
5 changed files with 68 additions and 26 deletions

View File

@ -66,6 +66,7 @@ type
end; end;
TOnMoveCallback = procedure (AFrom, ATo: TPoint); TOnMoveCallback = procedure (AFrom, ATo: TPoint);
TPawnPromotionCallback = function (APawn: TChessTile): TChessTile of object;
{ TChessGame } { TChessGame }
@ -86,6 +87,7 @@ type
var AEnpassantSquare, AEnpassantSquareToClear: TPoint) : boolean; var AEnpassantSquare, AEnpassantSquareToClear: TPoint) : boolean;
function ValidatePawnSimpleCapture(AFrom,ATo: TPoint): Boolean; function ValidatePawnSimpleCapture(AFrom,ATo: TPoint): Boolean;
function IsSquareOccupied(ASquare: TPoint): Boolean; function IsSquareOccupied(ASquare: TPoint): Boolean;
procedure doPromotion(Position: TPoint);
public public
Board: TChessBoard; Board: TChessBoard;
msg : String; msg : String;
@ -108,6 +110,7 @@ type
// Callbacks // Callbacks
OnAfterMove: TOnMoveCallback; // For the modules OnAfterMove: TOnMoveCallback; // For the modules
OnBeforeMove: TOnMoveCallback; // For the UI OnBeforeMove: TOnMoveCallback; // For the UI
OnPawnPromotion: TPawnPromotionCallback;
// //
constructor Create; constructor Create;
procedure StartNewGame(APlayAsWhite: Boolean; AUseTimer: Boolean; APlayerTime: Integer); overload; procedure StartNewGame(APlayAsWhite: Boolean; AUseTimer: Boolean; APlayerTime: Integer); overload;
@ -261,6 +264,8 @@ begin
DoMovePiece(AFrom, ATo, LEnpassantToClear); DoMovePiece(AFrom, ATo, LEnpassantToClear);
if Castle then DoCastle(); if Castle then DoCastle();
if ((Board[ATo.X][Ato.Y]=ctWPawn) and (Ato.Y=8)) or ((Board[ATo.X][Ato.Y]=ctBPawn) and (ATo.Y=1)) then //If a pawn will be promoted
doPromotion(Ato);
// //
UpdateTimes(); UpdateTimes();
@ -286,6 +291,17 @@ begin
Board[AEnpassantToClear.X][AEnpassantToClear.Y] := ctEmpty; Board[AEnpassantToClear.X][AEnpassantToClear.Y] := ctEmpty;
end; end;
procedure TChessGame.doPromotion(Position: TPoint);
var
lNewPiece: TChessTile;
begin
if Assigned(OnPawnPromotion) then
begin
lNewPiece := OnPawnPromotion(Board[position.X][position.Y]);
Board[position.X][position.Y] := lNewPiece;
end;
end;
procedure TChessGame.DoCastle(); procedure TChessGame.DoCastle();
begin begin
if CastleCord.X=8 then if CastleCord.X=8 then

View File

@ -68,7 +68,7 @@
<PackageName Value="LCL"/> <PackageName Value="LCL"/>
</Item2> </Item2>
</RequiredPackages> </RequiredPackages>
<Units Count="15"> <Units Count="16">
<Unit0> <Unit0>
<Filename Value="fpchess.lpr"/> <Filename Value="fpchess.lpr"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
@ -144,6 +144,13 @@
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="mod_kcchess"/> <UnitName Value="mod_kcchess"/>
</Unit14> </Unit14>
<Unit15>
<Filename Value="selectpromotionpiece.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="formPromotion"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="selectPromotionPiece"/>
</Unit15>
</Units> </Units>
</ProjectOptions> </ProjectOptions>
<CompilerOptions> <CompilerOptions>

View File

@ -8,7 +8,8 @@ uses
{$ENDIF}{$ENDIF} {$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset Interfaces, // this includes the LCL widgetset
Forms, lnetbase, mainform, chessdrawer, chessgame, chessconfig, Forms, lnetbase, mainform, chessdrawer, chessgame, chessconfig,
chesstcputils, chessmodules, mod_samecomputer, mod_fics, mod_kcchess chesstcputils, chessmodules, mod_samecomputer, mod_fics, mod_kcchess,
selectPromotionPiece
{$ifdef FPCHESS_WEBSERVICES} {$ifdef FPCHESS_WEBSERVICES}
,IDelphiChess_Intf ,IDelphiChess_Intf
{$endif}; {$endif};
@ -18,6 +19,7 @@ uses
begin begin
Application.Initialize; Application.Initialize;
Application.CreateForm(TformChess, formChess); Application.CreateForm(TformChess, formChess);
Application.CreateForm(TformPromotion, formPromotion);
Application.Run; Application.Run;
end. end.

View File

@ -14,7 +14,7 @@ object formChess: TformChess
Height = 500 Height = 500
Top = 0 Top = 0
Width = 360 Width = 360
PageIndex = 1 PageIndex = 0
Align = alClient Align = alClient
TabOrder = 0 TabOrder = 0
TabStop = True TabStop = True
@ -45,17 +45,17 @@ object formChess: TformChess
end end
object Label6: TLabel object Label6: TLabel
Left = 28 Left = 28
Height = 18 Height = 17
Top = 128 Top = 128
Width = 56 Width = 52
Caption = 'Start as:' Caption = 'Start as:'
ParentColor = False ParentColor = False
end end
object Label7: TLabel object Label7: TLabel
Left = 80 Left = 80
Height = 18 Height = 17
Top = 175 Top = 175
Width = 152 Width = 150
Caption = 'minutes for each player' Caption = 'minutes for each player'
ParentColor = False ParentColor = False
end end
@ -70,7 +70,7 @@ object formChess: TformChess
end end
object editPlayerName: TLabeledEdit object editPlayerName: TLabeledEdit
Left = 88 Left = 88
Height = 25 Height = 22
Top = 104 Top = 104
Width = 120 Width = 120
EditLabel.AnchorSideLeft.Control = editPlayerName EditLabel.AnchorSideLeft.Control = editPlayerName
@ -78,10 +78,10 @@ object formChess: TformChess
EditLabel.AnchorSideTop.Side = asrCenter EditLabel.AnchorSideTop.Side = asrCenter
EditLabel.AnchorSideRight.Control = editPlayerName EditLabel.AnchorSideRight.Control = editPlayerName
EditLabel.AnchorSideBottom.Control = editPlayerName EditLabel.AnchorSideBottom.Control = editPlayerName
EditLabel.Left = 2 EditLabel.Left = 6
EditLabel.Height = 18 EditLabel.Height = 17
EditLabel.Top = 107 EditLabel.Top = 107
EditLabel.Width = 83 EditLabel.Width = 79
EditLabel.Caption = 'Player Name' EditLabel.Caption = 'Player Name'
EditLabel.ParentColor = False EditLabel.ParentColor = False
LabelPosition = lpLeft LabelPosition = lpLeft
@ -89,7 +89,7 @@ object formChess: TformChess
end end
object comboStartColor: TComboBox object comboStartColor: TComboBox
Left = 88 Left = 88
Height = 27 Height = 21
Top = 128 Top = 128
Width = 120 Width = 120
ItemHeight = 0 ItemHeight = 0
@ -103,9 +103,9 @@ object formChess: TformChess
end end
object checkTimer: TCheckBox object checkTimer: TCheckBox
Left = 24 Left = 24
Height = 21 Height = 18
Top = 152 Top = 152
Width = 220 Width = 212
Caption = 'Set a time limit for each Player' Caption = 'Set a time limit for each Player'
Checked = True Checked = True
State = cbChecked State = cbChecked
@ -113,7 +113,7 @@ object formChess: TformChess
end end
object spinPlayerTime: TSpinEdit object spinPlayerTime: TSpinEdit
Left = 21 Left = 21
Height = 25 Height = 16
Top = 176 Top = 176
Width = 50 Width = 50
TabOrder = 4 TabOrder = 4
@ -121,7 +121,7 @@ object formChess: TformChess
end end
object comboGameMode: TComboBox object comboGameMode: TComboBox
Left = 8 Left = 8
Height = 27 Height = 21
Top = 74 Top = 74
Width = 346 Width = 346
ItemHeight = 0 ItemHeight = 0
@ -140,7 +140,7 @@ object formChess: TformChess
end end
object editLocalIP: TLabeledEdit object editLocalIP: TLabeledEdit
Left = 120 Left = 120
Height = 25 Height = 22
Top = 200 Top = 200
Width = 120 Width = 120
EditLabel.AnchorSideLeft.Control = editLocalIP EditLabel.AnchorSideLeft.Control = editLocalIP
@ -148,10 +148,10 @@ object formChess: TformChess
EditLabel.AnchorSideTop.Side = asrCenter EditLabel.AnchorSideTop.Side = asrCenter
EditLabel.AnchorSideRight.Control = editLocalIP EditLabel.AnchorSideRight.Control = editLocalIP
EditLabel.AnchorSideBottom.Control = editLocalIP EditLabel.AnchorSideBottom.Control = editLocalIP
EditLabel.Left = 15 EditLabel.Left = 12
EditLabel.Height = 18 EditLabel.Height = 17
EditLabel.Top = 203 EditLabel.Top = 203
EditLabel.Width = 102 EditLabel.Width = 105
EditLabel.Caption = 'Your IP Address:' EditLabel.Caption = 'Your IP Address:'
EditLabel.ParentColor = False EditLabel.ParentColor = False
LabelPosition = lpLeft LabelPosition = lpLeft
@ -169,8 +169,8 @@ object formChess: TformChess
end end
end end
object pageGame: TPage object pageGame: TPage
ClientWidth = 360 ClientWidth = 1440
ClientHeight = 500 ClientHeight = 2000
object labelPos: TLabel object labelPos: TLabel
Left = 8 Left = 8
Height = 18 Height = 18
@ -238,8 +238,8 @@ object formChess: TformChess
end end
end end
object pageWebservice: TPage object pageWebservice: TPage
ClientWidth = 5760 ClientWidth = 11520
ClientHeight = 6928 ClientHeight = 13856
object Label8: TLabel object Label8: TLabel
Left = 0 Left = 0
Height = 32 Height = 32

View File

@ -1,3 +1,5 @@
{
}
unit mainform; unit mainform;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
@ -9,7 +11,7 @@ uses
ExtCtrls, ComCtrls, StdCtrls, Buttons, Spin, ExtCtrls, ComCtrls, StdCtrls, Buttons, Spin,
// fpchess // fpchess
chessdrawer, chessgame, chessconfig, chesstcputils, chessdrawer, chessgame, chessconfig, chesstcputils,
chessmodules; chessmodules, selectpromotionpiece;
type type
@ -68,6 +70,7 @@ type
{ private declarations } { private declarations }
function FormatTime(ATimeInMiliseconds: Integer): string; function FormatTime(ATimeInMiliseconds: Integer): string;
procedure UpdateChessModulesUI(ANewIndex: Integer); procedure UpdateChessModulesUI(ANewIndex: Integer);
function HandlePawnPromotion(APiece: TChessTile): TChessTile;
public public
{ public declarations } { public declarations }
procedure UpdateCaptions; procedure UpdateCaptions;
@ -133,6 +136,19 @@ begin
GetChessModule(ANewIndex).ShowUserInterface(panelModules); GetChessModule(ANewIndex).ShowUserInterface(panelModules);
end; end;
function TformChess.HandlePawnPromotion(APiece: TChessTile): TChessTile;
var
dlgPromotion: TformPromotion;
begin
dlgPromotion := TformPromotion.Create(vChessGame.IsWhitePlayerTurn);
try
dlgPromotion.ShowModal;
finally
dlgPromotion.Free;
Result := selectPromotionPiece.pieceChosen;
end;
end;
procedure HandleOnMove(AFrom, ATo: TPoint); procedure HandleOnMove(AFrom, ATo: TPoint);
var var
lStr: String; lStr: String;
@ -196,8 +212,9 @@ begin
end; end;
gChessModulesDebugOutputDestiny := memoDebug; gChessModulesDebugOutputDestiny := memoDebug;
// Prepare the move callback // Prepare the callbacks
vChessGame.OnBeforeMove := @HandleOnMove; vChessGame.OnBeforeMove := @HandleOnMove;
vChessGame.OnPawnPromotion := @HandlePawnPromotion;
end; end;
procedure TformChess.btnQuitClick(Sender: TObject); procedure TformChess.btnQuitClick(Sender: TObject);