fpchess: Advances the FICS code

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@1904 8e941d3f-bd1b-0410-a28a-d453659cc2b4

applications/fpchess/chessgame.pas

@@ -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;
+    class function BoardPosToChessCoords(APos: TPoint): string;
-    function ColumnNumToLetter(ACol: Integer): 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;

applications/fpchess/chessmodules.pas

@@ -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;

applications/fpchess/ltelnetex.pas

@@ -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
+  repeat
-  begin
     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.

applications/fpchess/mainform.pas

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

applications/fpchess/mod_fics.pas

@@ -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);
+  radioConnectionType := TRadioGroup.Create(nil);
-  textSecondPlayerName.SetBounds(20, 20, 180, 50);
+  radioConnectionType.SetBounds(10, 10, 300, 100);
-  textSecondPlayerName.Caption := 'Name of the second player';
+  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.SetBounds(200, 130, 150, 40);
-  editSecondPlayerName.Text := 'Second player';}
+  editSecondPlayerName.Text := '';
 end;
 
 procedure TFICSChessModule.ShowUserInterface(AParent: TWinControl);
 begin
-{  textSecondPlayerName.Parent := AParent;
+  radioConnectionType.Parent := AParent;
-  editSecondPlayerName.Parent := AParent;}
+  textPassword.Parent := AParent;
+  editPassword.Parent := AParent;
+  textSecondPlayerName.Parent := AParent;
+  editSecondPlayerName.Parent := AParent;
 end;
 
 procedure TFICSChessModule.HideUserInterface();
 begin
-{  textSecondPlayerName.Parent := nil;
+  radioConnectionType.Parent := nil;
-  editSecondPlayerName.Parent := nil;}
+  textPassword.Parent := nil;
+  editPassword.Parent := nil;
+  textSecondPlayerName.Parent := nil;
+  editSecondPlayerName.Parent := nil;
 end;
 
 procedure TFICSChessModule.FreeUserInterface;
 begin
-{  textSecondPlayerName.Free;
+  radioConnectionType.Free;
-  editSecondPlayerName.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);