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

fpchess: Advances the FICS code

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@1904 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
sekelsenmat
2011-09-06 11:03:12 +00:00
parent 8ce0f66b60
commit 7f43f113b3
5 changed files with 184 additions and 27 deletions
Download Patch File Download Diff File Expand all files Collapse all files

33
applications/fpchess/chessgame.pas
View File

@ -116,8 +116,10 @@ type
procedure StartNewGame(APlayAsWhite: Boolean; AUseTimer: Boolean; APlayerTime: Integer); overload;
procedure StartNewGame(APlayAsWhite: Integer; AUseTimer: Boolean; APlayerTime: Integer); overload;
function ClientToBoardCoords(AClientCoords: TPoint): TPoint;
function BoardPosToChessCoords(APos: TPoint): string;
function ColumnNumToLetter(ACol: Integer): string;
class function BoardPosToChessCoords(APos: TPoint): string;
class function ChessCoordsToBoardPos(AStr: string): TPoint;
class procedure ChessMoveCoordsToBoardPos(AMoveStr: string; AFrom, ATo: TPoint);
class function ColumnNumToLetter(ACol: Integer): string;
function CheckStartMove(AFrom: TPoint): Boolean;
function CheckEndMove(ATo: TPoint): Boolean;
function FindKing(): TPoint;
@ -735,7 +737,7 @@ begin
Result.Y := 1 + (INT_CHESSBOARD_SIZE - AClientCoords.Y) div INT_CHESSTILE_SIZE;
end;
function TChessGame.BoardPosToChessCoords(APos: TPoint): string;
class function TChessGame.BoardPosToChessCoords(APos: TPoint): string;
var
lStr: string;
begin
@ -743,7 +745,30 @@ begin
Result := Format('%s%d', [lStr, APos.Y]);
end;
function TChessGame.ColumnNumToLetter(ACol: Integer): string;
class function TChessGame.ChessCoordsToBoardPos(AStr: string): TPoint;
var
lStr: string;
begin
if Length(AStr) < 2 then raise Exception.Create('[TChessGame.ChessCoordsToBoardPos] Length(AStr) < 2');
lStr := Copy(AStr, 1, 1);
lStr := LowerCase(lStr);
Result.X := Byte(lStr[1]) - 96;
lStr := Copy(AStr, 2, 1);
Result.Y := StrToInt(lStr);
end;
class procedure TChessGame.ChessMoveCoordsToBoardPos(AMoveStr: string; AFrom,
ATo: TPoint);
var
lStr: String;
begin
lStr := Copy(AMoveStr, 1, 2);
AFrom := TChessGame.ChessCoordsToBoardPos(lStr);
lStr := Copy(AMoveStr, 3, 2);
ATo := TChessGame.ChessCoordsToBoardPos(lStr);
end;
class function TChessGame.ColumnNumToLetter(ACol: Integer): string;
begin
Result := Char(ACol + 96);
end;

12
applications/fpchess/chessmodules.pas
View File

@ -27,6 +27,7 @@ type
function IsMovingAllowedNow(): Boolean; virtual;
function GetSecondPlayerName(): string; virtual; abstract;
procedure HandleOnMove(AFrom, ATo: TPoint); virtual; abstract;
procedure HandleOnTimer(); virtual;
end;
var
@ -36,6 +37,7 @@ var
procedure RegisterChessModule(AModule: TChessModule);
procedure PopulateChessModulesList(AList: TStrings);
function GetChessModule(AIndex: Integer): TChessModule;
function GetCurrentChessModule: TChessModule;
function GetChessModuleCount(): Integer;
procedure ChessModuleDebugLn(AStr: string);
procedure ChessModuleDebugOut(AStr: string);
@ -83,6 +85,11 @@ begin
Result := TChessModule(gChessModules.Items[AIndex]);
end;
function GetCurrentChessModule: TChessModule;
begin
Result := GetChessModule(gSelectedModuleIndex);
end;
function GetChessModuleCount: Integer;
begin
Result := gChessModules.Count;
@ -112,6 +119,11 @@ begin
Result := not (vChessGame.IsWhitePlayerTurn xor vChessGame.FirstPlayerIsWhite);
end;
procedure TChessModule.HandleOnTimer;
begin
end;
initialization
gChessModules := TList.Create;
vChessGame.OnAfterMove := @HandleOnMove;

12
applications/fpchess/ltelnetex.pas
View File

@ -20,6 +20,7 @@ type
FOnDebugOut: TLTelnetDebugOutProc;
RegexObj: TRegExpr;
public
LastMsg: string;
constructor Create(aOwner: TComponent); override;
destructor Destroy; override;
function WaitFor(FirstMatch, SecondMatch: string; ATimeOut: Cardinal): Integer;
@ -49,14 +50,17 @@ function TLTelnetClientEx.WaitFor(FirstMatch, SecondMatch: string;
ATimeOut: Cardinal): Integer;
var
lMsg: string;
lRemaining: Integer;
begin
lRemaining := ATimeOut;
Result := -1;
if (FirstMatch = '') and (SecondMatch = '') then Exit;
while True do
begin
repeat
if GetMessage(lMsg) > 0 then if Assigned(OnDebugOut) then OnDebugOut(lMsg);
LastMsg := lMsg;
if FirstMatch <> '' then
begin
RegexObj.Expression := FirstMatch;
@ -70,9 +74,13 @@ begin
end;
CallAction; // don't forget to make the clock tick :)
if lRemaining > 0 then // Don't sleep if the routine was called with ATimeOut=0
begin
Application.ProcessMessages;
Sleep(100);
end;
Dec(lRemaining, 100);
until lRemaining <= 0;
end;
end.

1
applications/fpchess/mainform.pas
View File

@ -99,6 +99,7 @@ begin
vChessGame.UpdateTimes();
UpdateCaptions();
vChessDrawer.HandleOnTimer(Sender);
GetCurrentChessModule().HandleOnTimer();
end;
function TformChess.FormatTime(ATimeInMiliseconds: Integer): string;

147
applications/fpchess/mod_fics.pas
View File

@ -15,16 +15,22 @@ interface
uses
Classes, SysUtils,
StdCtrls, Forms, Controls,
StdCtrls, Forms, Controls, ExtCtrls, maskedit,
lTelnetex, lnet,
sorokinregexpr, // Rename to regexpr when FPC 2.8 comes with this
chessmodules, chessgame;
chessmodules, chessgame, chessdrawer;
type
{ TFICSChessModule }
TFICSChessModule = class(TChessModule)
private
radioConnectionType: TRadioGroup;
textPassword: TStaticText;
editPassword: TMaskEdit;
textSecondPlayerName: TStaticText;
editSecondPlayerName: TEdit;
public
SecondPlayerName: string;
TelnetComm: TLTelnetClientEx;
@ -32,8 +38,6 @@ type
FICS_PORT: Integer;
FICS_USER: string;
FICS_PASSWORD: string;
// Frequency to issue commands to avoid disconnection, in miliseconds
PROTECT_LOGOUT_FREQ: Integer;
constructor Create(); override;
destructor Destroy; override;
procedure CreateUserInterface(); override;
@ -43,12 +47,14 @@ type
procedure PrepareForGame(); override;
function GetSecondPlayerName(): string; override;
procedure HandleOnMove(AFrom, ATo: TPoint); override;
procedure HandleOnTimer(); override;
procedure HandleOnDebugOut(AStr: string);
end;
const
FICS_LineEnding = #10;
OPEN_TIMEOUT = 10000;
OPEN_TIMEOUT = 1000000;
PROTECT_LOGOUT_FREQ = 45 * 60 * 1000; // Frequency to issue commands to avoid disconnection, in miliseconds
implementation
@ -75,7 +81,6 @@ begin
FICS_PORT := 5000;
FICS_USER := 'FPChess';
FICS_PASSWORD := '';
PROTECT_LOGOUT_FREQ := 45 * 60 * 1000;
end;
destructor TFICSChessModule.Destroy;
@ -87,31 +92,54 @@ end;
procedure TFICSChessModule.CreateUserInterface;
begin
{ textSecondPlayerName := TStaticText.Create(nil);
textSecondPlayerName.SetBounds(20, 20, 180, 50);
textSecondPlayerName.Caption := 'Name of the second player';
radioConnectionType := TRadioGroup.Create(nil);
radioConnectionType.SetBounds(10, 10, 300, 100);
radioConnectionType.Caption := 'FICS Connection Type';
radioConnectionType.Items.Add('Wait for a friend to connect to me');
radioConnectionType.Items.Add('Connect to a friend (he needs to be waiting for the connection)');
textPassword := TStaticText.Create(nil);
textPassword.SetBounds(10, 110, 180, 20);
textPassword.Caption := 'Your FICS Password';
editPassword := TMaskEdit.Create(nil);
editPassword.SetBounds(200, 110, 150, 20);
editPassword.Text := '';
textSecondPlayerName := TStaticText.Create(nil);
textSecondPlayerName.SetBounds(10, 130, 180, 40);
textSecondPlayerName.Caption := 'FICS Login of the other player';
editSecondPlayerName := TEdit.Create(nil);
editSecondPlayerName.SetBounds(200, 20, 150, 50);
editSecondPlayerName.Text := 'Second player';}
editSecondPlayerName.SetBounds(200, 130, 150, 40);
editSecondPlayerName.Text := '';
end;
procedure TFICSChessModule.ShowUserInterface(AParent: TWinControl);
begin
{ textSecondPlayerName.Parent := AParent;
editSecondPlayerName.Parent := AParent;}
radioConnectionType.Parent := AParent;
textPassword.Parent := AParent;
editPassword.Parent := AParent;
textSecondPlayerName.Parent := AParent;
editSecondPlayerName.Parent := AParent;
end;
procedure TFICSChessModule.HideUserInterface();
begin
{ textSecondPlayerName.Parent := nil;
editSecondPlayerName.Parent := nil;}
radioConnectionType.Parent := nil;
textPassword.Parent := nil;
editPassword.Parent := nil;
textSecondPlayerName.Parent := nil;
editSecondPlayerName.Parent := nil;
end;
procedure TFICSChessModule.FreeUserInterface;
begin
{ textSecondPlayerName.Free;
editSecondPlayerName.Free;}
radioConnectionType.Free;
textPassword.Free;
editPassword.Free;
textSecondPlayerName.Free;
editSecondPlayerName.Free;
end;
procedure TFICSChessModule.PrepareForGame;
@ -119,6 +147,9 @@ var
lResult, WaitTerminated: Boolean;
lMsg: string;
begin
FICS_USER := 'FPChess';
FICS_PASSWORD := editPassword.Text;
// SecondPlayerName := editSecondPlayerName.Text;
ChessModuleDebugLn('[TFICSChessModule.PrepareForGame]');
@ -207,6 +238,53 @@ begin
'',
OPEN_TIMEOUT);
end;
// Remove those annoying message of people seeking chess adversaries
TelnetComm.WaitFor(
'.*fics%.*',
'',
OPEN_TIMEOUT);
TelnetComm.SendMessage('set seek 0' + FICS_LineEnding);
// Set the style
TelnetComm.WaitFor(
'.*fics%.*',
'',
OPEN_TIMEOUT);
TelnetComm.SendMessage('set style 11' + FICS_LineEnding);
// Wait for a match
if radioConnectionType.ItemIndex = 0 then
begin
// Challenge: GuestZMYL (----) fpchess (----) unrated blitz 2 12.
// You can "accept" or "decline", or propose different parameters.
TelnetComm.WaitFor(
'.*You can "accept" or "decline", or propose different parameters*',
'',
OPEN_TIMEOUT);
TelnetComm.SendMessage('accept ' + FICS_LineEnding);
// You accept the match offer from GuestZMYL.
TelnetComm.WaitFor(
'.*You accept the match offer from*',
'',
OPEN_TIMEOUT);
end
// Challenge a partner
else
begin
TelnetComm.WaitFor(
'.*fics%.*',
'',
OPEN_TIMEOUT);
TelnetComm.SendMessage('match ' + editSecondPlayerName.Text + FICS_LineEnding);
// fpchess accepts the match offer.
TelnetComm.WaitFor(
'.*accepts the match offer*',
'',
OPEN_TIMEOUT);
end;
end;
function TFICSChessModule.GetSecondPlayerName: string;
@ -215,10 +293,43 @@ begin
end;
// If a move came, it is because the local player did a move
// so send this move and start listening for a move
// so send this move
procedure TFICSChessModule.HandleOnMove(AFrom, ATo: TPoint);
var
lMsg: String;
begin
lMsg := Format('%s-%s', [TChessGame.BoardPosToChessCoords(AFrom), TChessGame.BoardPosToChessCoords(ATo)]);
TelnetComm.WaitFor(
'.*fics%.*',
'',
OPEN_TIMEOUT);
TelnetComm.SendMessage(lMsg + FICS_LineEnding);
end;
// listen for moves
procedure TFICSChessModule.HandleOnTimer;
var
lIndex: Integer;
lAnimation: TChessMoveAnimation;
lFrom, lTo: TPoint;
lMoveStr: String;
begin
// Example output in style 11
// #@#086GuestZMYL :fpchess *RNBQKBNR PPP PP P PP p p ppp ppprnbqkbnr003B3939-1628-0163P/a2-a4(1:03)@#@
lIndex := TelnetComm.WaitFor(
'.*[PRNBQK]/[abcdefgh][0123456789]-[abcdefgh][0123456789].*',
'',
0);
if lIndex = 0 then
begin
lMoveStr := Copy(TelnetComm.LastMsg, Pos('/', TelnetComm.LastMsg)+1, 5);
TChessGame.ChessMoveCoordsToBoardPos(lMoveStr, lFrom, lTo);
lAnimation := TChessMoveAnimation.Create;
lAnimation.AFrom := lFrom;
lAnimation.ATo := lTo;
vChessDrawer.AddAnimation(lAnimation);
end;
end;
procedure TFICSChessModule.HandleOnDebugOut(AStr: string);