Создание модели игры «Шашки» в среде программирования Delphi

 

  If vcbChess.Board.GetDraught(xP, yP)<>nil Then

  Begin

    If vcbChess.Board.GetDraught(xP, yP).Side=PlayerSide Then

      vcbChess.Cursor:=crHandPoint

  End;

end;

 

procedure TfmCheckers.vcbChessMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

Var

  xP, yP:Integer;

begin

  If StrikeMode Then Exit;

 

  vcbChess.GetCellNumberByCoord(X, Y, xP, yP);

 

  If Not(IsDraughtChosen) Then  //Если еще нет выбранной шашки

  Begin

    TrySelectNewDraught(xP, yP);

  End

  Else Begin  //Если уже есть выбранная шашка

    If vcbChess.Board.GetDraught(xP, yP)=nil Then

    Begin //Если клетка пустая, то обработаем как отпускание мыши

      vcbChessMouseUp(Sender, Button, Shift, X, Y);

    End

    Else Begin  //Если там стоит наша шашка, то сбросим выбор и рекурсируем

      If vcbChess.Board.GetDraught(xP, yP).Side=PlayerSide Then

      Begin

        vcbChess.Refresh;

        IsDraughtChosen:=False;

        vcbChessMouseDown(Sender, Button, Shift, X, Y);

      End;

    End;

  End;

end;

 

procedure TfmCheckers.vcbChessMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

Var

  xP, yP:Integer;

  Moves, Strikes, Strickens:TList;

begin

  vcbChess.GetCellNumberByCoord(X, Y, xP, yP);

 

  If IsDraughtChosen Then  //Если есть выбранная шашка

  Begin

   //Проверим: можно ли в принципе шагнуть  сюда

    If vcbChess.Board.GetDraught(xP, yP)<>nil Then Exit;

   //Клетка пустая

   //Проверим  правильность хода в эту клетку

    vcbChess.Board.FindMoves(DraughtPosition.X, DraughtPosition.Y, Moves, Strikes, Strickens);

    If Strikes.Count=0 Then //Нет рубки - пытаемся просто ходить

    Begin

      If CheckPosition(xP, yP, Moves)>=0 Then //Ход верен!

      Begin

        vcbChess.Board.MoveDraught(DraughtPosition.X, DraughtPosition.Y, xP, yP);

        IsDraughtChosen:=False;

        vcbChess.Refresh;

        vcbChessMouseMove(Sender, Shift, X, Y);

 

        SwitchCurrentPlayer;  //Ход сделан - переключем игрока

        CheckForWin;

      End;

    End

    Else Begin  //Есть возможность рубки - обязательно!

      TryMakeStrike(xP, yP);

    End;

    ClearMoves(Moves);

    ClearMoves(Strikes);

    ClearMoves(Strickens);

  End

  Else Begin  //Шашка не еще выбрана

 

  End;

end;

 

Procedure TfmCheckers.TrySelectNewDraught(x, y:Integer);

Var

  Moves, Strikes, Strickens:TList;

  StrikingDraughts:TList;

Begin

  If vcbChess.Board.GetDraught(x, y)=nil Then Exit;

  If vcbChess.Board.GetDraught(x, y).Side<>PlayerSide Then Exit;

//Проверим обязательные  рубки

  StrikingDraughts:=vcbChess.Board.FindStrikingDraughts(PlayerSide);

  If StrikingDraughts.Count>0 Then

  Begin

    If CheckPosition(x, y, StrikingDraughts)<0 Then

    Begin

      ClearMoves(StrikingDraughts);

      Exit;

    End;

  End;

  ClearMoves(StrikingDraughts);

 

  DraughtPosition.X:=x;

  DraughtPosition.Y:=y;

  IsDraughtChosen:=True;

//Отрисуем возможные ходы с учетом обязаловки рубки

  vcbChess.Board.FindMoves(x, y, Moves, Strikes, Strickens);

  If Strikes.Count=0 Then

    vcbChess.DrawMoves(Moves, nil)

  Else

    vcbChess.DrawMoves(nil, Strikes);

  ClearMoves(Moves);

  ClearMoves(Strikes);

  ClearMoves(Strickens);

End;

 

Procedure TfmCheckers.TryMakeStrike(x, y:Integer);

Var

  Moves, Strikes, Strickens:TList;

  CP:PCellPosition;

Begin

  If Not(IsDraughtChosen) Then Exit;

  vcbChess.Board.FindMoves(DraughtPosition.X, DraughtPosition.Y, Moves, Strikes, Strickens);

 //Возможна ли рубка в данную клетку

  If CheckPosition(x, y, Strikes)>=0 Then //Рубка верна!

  Begin //рубим

  //Определим  срубленную шашку

    CP:=Strickens.Items[CheckPosition(x, y, Strikes)];

    vcbChess.Board.DeleteDraught(CP^.X, CP^.Y);

  //Перескакиваем

    vcbChess.Board.MoveDraught(DraughtPosition.X, DraughtPosition.Y, x, y);

    DraughtPosition.X:=x; DraughtPosition.Y:=y;

 

    ClearMoves(Moves);

    ClearMoves(Strikes);

    ClearMoves(Strickens);

 

  //Определим:  возможно ли продолжение рубки

    vcbChess.Board.FindMoves(DraughtPosition.X, DraughtPosition.Y, Moves, Strikes, Strickens);

    If Strikes.Count>0 Then

    Begin

      StrikeMode:=True; //Установим режим рубки

    End

    Else Begin

      StrikeMode:=False;

      SwitchCurrentPlayer;  //Закончена рубка - переключим игрока

    End;

 

    ClearMoves(Moves);

    ClearMoves(Strikes);

    ClearMoves(Strickens);

 

    vcbChess.Refresh;

  End;

 

  If StrikeMode Then

  Begin

    IsDraughtChosen:=False;

    TrySelectNewDraught(DraughtPosition.X, DraughtPosition.Y);

  End;

 

  CheckForWin;

End;

 

Procedure TfmCheckers.SwitchCurrentPlayer;

Begin

  If CurrentPlayer=sdWhite Then CurrentPlayer:=sdBlack Else CurrentPlayer:=sdWhite;

  If LocalGame Then PlayerSide:=CurrentPlayer;

 

  If CurrentPlayer=sdWhite Then stCurrentPlayer.Caption:='Белые' Else stCurrentPlayer.Caption:='Черные';

  If PlayerSide=CurrentPlayer Then

  Begin

    pnChessBoard.Enabled:=True;

  End

  Else Begin

    pnChessBoard.Enabled:=False;

  End;

End;

 

Function TfmCheckers.CheckForWin:Integer;

Begin

  Result:=-1;

//Проверим победу  по срубам

  If vcbChess.Board.CountDraughts(sdWhite)=0 Then

  Begin

    Result:=sdBlack;

  End;

  If vcbChess.Board.CountDraughts(sdBlack)=0 Then

  Begin

    Result:=sdWhite;

  End;

//Проверим победу  по блокировкам

  If Not(vcbChess.Board.AbleToMove(CurrentPlayer)) Then

    If CurrentPlayer=sdWhite Then Result:=sdBlack Else Result:=sdWhite;

 

  If Result<0 Then Exit;

//Game Over!

  miCancelGameClick(Self);

  Case Result Of

    sdWhite: Application.MessageBox('Победила команда "Белых"', 'Победили Белые!', MB_OK+MB_ICONINFORMATION);

    sdBlack: Application.MessageBox('Победила команда "Черных"', 'Победили Черные!', MB_OK+MB_ICONINFORMATION);

  End;

End;

 

procedure TfmCheckers.Timer1Timer(Sender: TObject);

begin

//  Inc(PlayTime);

//  stTimer.Caption:=Format('%d:%.2d:%.2d', [PlayTime div 3600, (PlayTime mod 3600) div 60, (PlayTime mod 3600) mod 60]);

  stTimer.Caption:=TimeToStr(Now-StartTime);

end;

 

procedure TfmCheckers.miStartLocalGameClick(Sender: TObject);

begin

  LocalGame:=True;

 

  lbedWhiteName.ReadOnly:=True;

  lbedBlackName.ReadOnly:=True;

 

//  PlayTime:=0;

  StartTime:=Now;

  PlayerSide:=sdWhite;

  CurrentPlayer:=sdBlack;

  IsDraughtChosen:=False;

  StrikeMode:=False;

 

  vcbChess.Board.Respawn;

  vcbChess.Refresh;

 

  pnChessBoard.Enabled:=True;

 

  Timer1.Enabled:=True;

  SwitchCurrentPlayer;

end;

 

 

procedure TfmCheckers.miCancelGameClick(Sender: TObject);

begin

  Timer1.Enabled:=False;

  pnChessBoard.Enabled:=False;

  lbedWhiteName.ReadOnly:=False;

  lbedBlackName.ReadOnly:=False;

 

  Application.MessageBox('Игра зкончена', 'Игра закончена', MB_OK+MB_ICONINFORMATION);

end;

 

procedure TfmCheckers.miAboutClick(Sender: TObject);

begin

  fmAbout.ShowModal;

end;

 

end.

{$A8,B-,C+,D+,E-,F-,G+,H+,I+,J+,K-,L+,M-,N+,O-,P+,Q+,R+,S-,T-,U-,V+,W-,X+,Y+,Z1}

{$MINSTACKSIZE $00004000}

{$MAXSTACKSIZE $00100000}

{$IMAGEBASE $00400000}

{$APPTYPE GUI}

unit Draughts;

 

interface

Uses

  Classes;

 

Type

  TMove=Record

    dX, dY:Integer;

  End;

 

Const

  ctWhite=0;

  ctBlack=1;

  ctNone=255;

 

  sdWhite=0;

  sdBlack=1;

  kdSimple=0;

  kdKing=1;

 

  MoveNW=1; {}

  MoveNE=2; {}

  MoveSW=3; {}

  MoveSE=4; {}

 

  DraughtMoves:Array[1..4] Of TMove=((dX:-1; dY:1), (dX:1; dY:1), (dX:-1; dY:-1), (dX:1; dY:-1));

 

Type

  TPossibleMoves=Set Of MoveNW..MoveSE;

  PCellPosition=^TCellPosition;

  TCellPosition=Record

    X, Y:Integer;

  End;

 

  TDraught=Class(TObject)

  Private

    _Side:Integer; {Сторона: Белая/Черная}

    _Kind:Integer; {Тип: Простая/Дамка}

    PossibleMoves:TPossibleMoves; {Возможные ходы}

 

    Procedure SetSide(Value:Integer);

    Procedure SetKind(Value:Integer);

  Public

    Constructor Create(sd:Integer);

    Destructor Destroy; Override;

 

    Property Side:Integer read _Side write SetSide;

    Property Kind:Integer read _Kind write SetKind;

  End;

 

  TBoardCell=Record

    CellType:Integer;

    Draught:TDraught;

  End;

  TChessBoard=Class(TObject)

 

  Private

    Cells:Array[0..9, 0..9] Of TBoardCell;

 

  Public

 

    Constructor Create;

    Destructor Destroy; Override;

 

    Function AddDraught(x, y:Integer; Side:Integer; Kind:Integer=kdSimple):TDraught;

    Procedure DeleteDraught(x, y:Integer);

    Function GetDraught(x, y:Integer):TDraught;

    Function SetDraught(x, y:Integer; Const Draught:TDraught):Boolean;

    Procedure Clear;

    Procedure Respawn;

    Function MoveDraught(FromX, FromY, ToX, ToY:Integer):Boolean;

    Procedure FindMoves(x, y:Integer; Var Moves, Strikes, Strickens:TList);

    Function FindStrikingDraughts(Side:Integer):TList;

    Function CountDraughts(Side:Integer):Integer;

    Function AbleToMove(Side:Integer):Boolean;

  End;

 

  Procedure ClearMoves(Var Moves:TList);

  Function CheckPosition(x, y:Integer; Const Positions:TList):Integer;

 

implementation

 

Procedure ClearMoves(Var Moves:TList);

Var

  i:Integer;

  CP:PCellPosition;

Begin

  If Moves=nil Then Exit;

  For i:=0 To Moves.Count-1 Do

  Begin

    CP:=Moves.Items[i];

    Dispose(CP);

  End;

  Moves.Free;

  Moves:=nil;

End;

 

Function CheckPosition(x, y:Integer; Const Positions:TList):Integer;

Var

  i:Integer;

  CP:PCellPosition;

Begin

  Result:=-1;

  If Positions=nil Then Exit;

  For i:=0 To Positions.Count-1 Do

  Begin

    CP:=Positions.Items[i];

    If ((CP^.X=x) And (CP^.Y=y)) Then

    Begin

      Result:=i;

      Exit;

    End;

  End;

End;

 

 

Constructor TDraught.Create(sd:Integer);

Begin

  Inherited Create;

 

  Side:=sd;

  Kind:=kdSimple;

End;

 

Destructor TDraught.Destroy;

Begin

 

  Inherited Destroy;

End;

 

Procedure TDraught.SetSide(Value:Integer);

Begin

  If Value=sdWhite Then

  Begin

    _Side:=sdWhite;

    PossibleMoves:=[MoveNW, MoveNE]

  End

  Else Begin

    _Side:=sdBlack;

    PossibleMoves:=[MoveSW, MoveSE];

  End;

  If Kind=kdKing Then PossibleMoves:=[MoveNW, MoveNE, MoveSW, MoveSE];

End;

 

Procedure TDraught.SetKind(Value:Integer);

Begin

  If Value=kdSimple Then

    _Kind:=kdSimple

  Else

    _Kind:=kdKing;

  SetSide(_Side);

End;

 

 

Constructor TChessBoard.Create;

Var

  x, y:Integer;

Begin

  Inherited Create;

 

  For y:=0 To 9 Do

  Begin

    For x:=0 To 9 Do

    Begin

      If ((x=0) Or (y=0) Or (x=9) Or (y=9)) Then

        Cells[y, x].CellType:=ctNone

      Else

        If ((Odd(x) And Odd(y)) Or (Not(Odd(x)) And Not(Odd(y)))) Then

          Cells[y, x].CellType:=ctBlack

        Else