From a0f6fd68a56068a20e7186e2dd2d7daccfbce4aa Mon Sep 17 00:00:00 2001 From: Pavel Perminov Date: Wed, 26 Sep 2012 19:02:53 +0000 Subject: Chess4Net_MI 2010.0 release (106 rev. truncated adjusted copy) git-svn-id: http://svn.miranda-ng.org/main/trunk@1666 1316c22d-e87f-b044-9b9b-93d7a3e3ba9c --- plugins/Chess4Net/ChessRulesEngine.pas | 1018 ++++++++++++++++++++++++++++++++ 1 file changed, 1018 insertions(+) create mode 100644 plugins/Chess4Net/ChessRulesEngine.pas (limited to 'plugins/Chess4Net/ChessRulesEngine.pas') diff --git a/plugins/Chess4Net/ChessRulesEngine.pas b/plugins/Chess4Net/ChessRulesEngine.pas new file mode 100644 index 0000000000..feb471b48b --- /dev/null +++ b/plugins/Chess4Net/ChessRulesEngine.pas @@ -0,0 +1,1018 @@ +unit ChessRulesEngine; + +interface + +uses + Classes; + +type + TFigureName = (K, Q, R, B, N, P); + TFigure = (WK, WQ, WR, WB, WN, WP, ES, + BK, BQ, BR, BB, BN, BP); // ES - Empty Square + TFigureColor = (fcWhite, fcBlack); + + PChessPosition = ^TChessPosition; + TChessPosition = record // шахматная позиция + board: array[1..8, 1..8] of TFigure; + color: TFigureColor; // Чей ход + castling: set of (WhiteKingSide, WhiteQueenSide, // Возможность рокировки + BlackKingSide, BlackQueenSide); + en_passant: 0..8; // Вертикаль возможности взятия e.p. 0 - нету e.p. + end; + + PMoveAbs = ^TMoveAbs; + TMoveAbs = record + i0, j0, i, j: byte; + prom_fig: TFigureName; + end; + + IChessRulesEngineable = interface + function AskPromotionFigure(FigureColor: TFigureColor): TFigureName; + end; + + TEvaluation = (evInGame, evMate, evStaleMate); + + TChessRulesEngine = class + private + m_ChessRulesEngineable: IChessRulesEngineable; + m_Position: TChessPosition; + m_i0, m_j0: integer; // Предыдущие координаты фигуры + m_fig: TFigure; // Перетаскиваемая фигура + m_lastMove: TMoveAbs; // Последний сделанный ход + m_strLastMoveStr: string; // last move in algebraic notation + m_lstPosition: TList; + + function FGetPosition: PChessPosition; + function FAskPromotionFigure(FigureColor: TFigureColor): TFigureName; + procedure FAddPosMoveToList; // Добавляет позицию и ход из неё в список + function FMove2Str(const pos: TChessPosition): string; + + function FCheckMove(const chp: TChessPosition; var chp_res: TChessPosition; + i0, j0, i, j: integer; var prom_fig: TFigureName): boolean; + + function FGetLastMove: PMoveAbs; + procedure FDelPosList; // Удаляет текущую позицию из списка + + function FDoMove(i, j: integer; prom_fig: TFigureName = K): boolean; overload; + + class function FFieldUnderAttack(const pos: TChessPosition; i0,j0: integer): boolean; // TODO: -> private ? + class function FCheckCheck(const pos: TChessPosition): boolean; + function FCanMove(pos: TChessPosition): boolean; + + property i0: integer read m_i0 write m_i0; + property j0: integer read m_j0 write m_j0; + property fig: TFigure read m_fig write m_fig; + + public + constructor Create(ChessRulesEngineable: IChessRulesEngineable = nil); + destructor Destroy; override; + + function DoMove(move_str: string): boolean; overload; + function DoMove(i0, j0, i, j: integer; prom_fig: TFigureName = K): boolean; overload; + function TakeBack: boolean; + function SetPosition(const posstr: string): boolean; + function GetPosition: string; + procedure InitNewGame; + procedure InitNewPPRandomGame; + procedure ResetMoveList; // очищает список позиций + function NMovesDone: integer; // amount of moves done + function GetEvaluation: TEvaluation; + + property Position: PChessPosition read FGetPosition; + property lastMove: PMoveAbs read FGetLastMove; + property lastMoveStr: string read m_strLastMoveStr; + property PositionsList: TList read m_lstPosition; + end; + + PPosMove = ^TPosMove; + TPosMove = record + pos: TChessPosition; + move: TMoveAbs; + end; + +const + INITIAL_CHESS_POSITION = 'rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq -'; + EMPTY_CHESS_POSITION = '8/8/8/8/8/8/8/8 w - -'; + +implementation + +{$J+} + +uses + SysUtils, StrUtils; + +type + TDeltaMove = array [TFigureName] of + record + longRange: boolean; + dx,dy: array[1..8] of Integer; + end; + +const + DELTA_MOVE: TDeltaMove = ((longRange: FALSE; // Король + dx: (1,0,-1,0, 1,-1,-1,1); dy: (0,1,0,-1, 1,1,-1,-1)), + (longRange: TRUE; // Ферзь + dx: (1,0,-1,0, 1,-1,-1,1); dy: (0,1,0,-1, 1,1,-1,-1)), + (longRange: TRUE; // Ладья + dx: (1,0,-1,0, 0,0,0,0); dy: (0,1,0,-1, 0,0,0,0)), + (longRange: TRUE; // Слон + dx: (1,-1,-1,1, 0,0,0,0); dy: (1,1,-1,-1, 0,0,0,0)), + (longRange: FALSE; // Конь + dx: (2,1,-1,-2, 2,1,-1,-2); dy: (1,2,2,1, -1,-2,-2,-1)), + (longRange: FALSE; // Пешка + dx: (0,0,-1,1, 0,0,0,0); dy: (2,1,1,1, 0,0,0,0))); + +//////////////////////////////////////////////////////////////////////////////// +// TChessRulesEngine + +constructor TChessRulesEngine.Create(ChessRulesEngineable: IChessRulesEngineable = nil); +begin + inherited Create; + m_ChessRulesEngineable := ChessRulesEngineable; + + // Инициализация списка позиций + m_lstPosition := TList.Create; +end; + + +destructor TChessRulesEngine.Destroy; +var + i: integer; +begin + for i := 0 to m_lstPosition.Count - 1 do + Dispose(m_lstPosition[i]); + m_lstPosition.Free; + + inherited; +end; + + +function TChessRulesEngine.FGetPosition: PChessPosition; +begin + Result := @m_Position; +end; + + +function TChessRulesEngine.FAskPromotionFigure(FigureColor: TFigureColor): TFigureName; +begin + if (Assigned(m_ChessRulesEngineable)) then + Result := m_ChessRulesEngineable.AskPromotionFigure(FigureColor) + else + Result := Q; +end; + + +class function TChessRulesEngine.FCheckCheck(const pos: TChessPosition): boolean; +label + l; +const + _i0: integer = 1; // для увеличения скорости обработки + _j0: integer = 1; +var + i, j: integer; +begin + with pos do + begin + if ((color = fcWhite) and (board[_i0, _j0] = WK)) or + ((color = fcBlack) and (board[_i0, _j0] = BK)) then goto l; + // поиск короля на доске + for i:= 1 to 8 do + begin + for j:= 1 to 8 do + begin + if ((color = fcWhite) and (board[i,j] = WK)) or + ((color = fcBlack) and (board[i,j] = BK)) then + begin + _i0 := i; + _j0 := j; + goto l; + end; + end; // for j + end; // for i +l: + Result := FFieldUnderAttack(pos, _i0, _j0); + end; +end; + + +class function TChessRulesEngine.FFieldUnderAttack(const pos: TChessPosition; i0, j0: integer): boolean; +var + f: TFigureName; + ef: TFigure; + l: byte; + ti,tj: Integer; + locLongRange: boolean; +begin + for f:= R to N do + for l:= 1 to 8 do + with DELTA_MOVE[f], pos do + begin + if (dx[l] = 0) and (dy[l] = 0) then break; // Все ходы просмотрены + ti:= i0; tj:= j0; + locLongRange:= FALSE; + repeat + ti:= ti + dx[l]; tj:= tj + dy[l]; + if not(ti in [1..8]) or not(tj in [1..8]) then break; + ef:= board[ti,tj]; + if ((color = fcWhite) and (ef < ES)) or ((color = fcBlack) and (ef > ES)) + then break; + case ef of + WK,BK: + if locLongRange or (f = N) then break; + WQ,BQ: + if f = N then break; + WR,BR: + if f <> R then break; + WB,BB: + if f <> B then break; + WN,BN: + if f <> N then break; + WP,BP: + if locLongRange or (f <> B) or + ((color = fcWhite) and not(tj > j0)) or + ((color = fcBlack) and not(tj < j0)) + then break; + ES: + begin + locLongRange:= TRUE; + continue; + end; + end; + Result:= TRUE; + exit; + until (not longRange); + end; + + Result := FALSE; +end; + + +function TChessRulesEngine.FCheckMove(const chp: TChessPosition; var chp_res: TChessPosition; + i0, j0, i, j: integer; var prom_fig: TFigureName): boolean; +label + here; +var + ti,tj: integer; + l: byte; + f: TFigureName; + _fig: TFigure; + pos: TChessPosition; +begin + Result:= FALSE; + if not ((i0 in [1..8]) and (j0 in [1..8]) and + (i in [1..8]) and (j in [1..8])) then exit; + + _fig := chp.board[i0, j0]; + if ((chp.color = fcWhite) and (_fig > ES)) or + ((chp.color = fcBlack) and (_fig < ES)) then + exit; + + f := TFigureName(ord(_fig) - ord(chp.color) * ord(BK)); + + for l:= 1 to 8 do + with DELTA_MOVE[f], chp do + begin + if (dx[l] = 0) and (dy[l] = 0) then break; // Все ходы просмотрены + ti:= i0; tj:= j0; + case f of + P: + begin + if (l = 1) and + not(((color = fcWhite) and (j0 = 2) and (board[i0,3] = ES)) or + ((color = fcBlack) and (j0 = 7) and (board[i0,6] = ES))) + then continue; // Пешка - не на 2/7 гор. - не делаем длинный ход. + case color of + fcWhite: + begin + ti:= ti + dx[l]; tj:= tj + dy[l]; + end; + fcBlack: + begin + ti:= ti - dx[l]; tj:= tj - dy[l]; + end; + end; + if not(ti in [1..8]) or not(tj in [1..8]) then continue; + if (l <= 2) and (board[ti,tj] <> ES) + then continue; // Перед пешкой фигура - выход + if (l >= 3) and not(((color = fcWhite) and ((board[ti,tj] > ES) or + ((j0 = 5) and (en_passant = ti)))) or + ((color = fcBlack) and ((board[ti,tj] < ES) or + ((j0 = 4) and (en_passant = ti))))) + then continue; + if (ti = i) and (tj = j) then goto here; + end; + else + repeat + ti:= ti + dx[l]; tj:= tj + dy[l]; + if not(ti in [1..8]) or not(tj in [1..8]) or + ((color = fcWhite) and ((board[ti,tj] < ES) or + ((board[ti,tj] > ES) and ((ti <> i) or (tj <> j))))) or + ((color = fcBlack) and ((board[ti,tj] > ES) or + ((board[ti,tj] < ES) and ((ti <> i) or (tj <> j))))) + then break; + if (ti = i) and (tj = j) then goto here; + until not longRange; + end; { case } + end; + + if f = K then // Проверка на возможность рокировки + with chp do + begin + if (i-i0 = 2) and (j = j0) and + (((color = fcWhite) and (WhiteKingSide in castling)) or + ((color = fcBlack) and (BlackKingSide in castling))) then + begin + if ((board[6,j0] <> ES) or (board[7,j0] <> ES) or // 0-0 + FFieldUnderAttack(chp,5,j0) or + FFieldUnderAttack(chp,6,j0)) then exit; + end + else if ((i-i0 = -2) and (j = j0) and + (((color = fcWhite) and (WhiteQueenSide in castling)) or + ((color = fcBlack) and (BlackQueenSide in castling)))) then + begin + if ((board[4,j0] <> ES) or (board[3,j0] <> ES) or // 0-0-0 + (board[2,j0] <> ES) or + FFieldUnderAttack(chp,5,j0) or + FFieldUnderAttack(chp,4,j0)) then + exit; + end + else exit; + + goto here; + end; + exit; // передвижение фигуры не по правилам +here: + // Реализация хода на pos + pos:= chp; + with pos do + begin + case f of + P: + begin + if (((color = fcWhite) and (j0 = 5)) or + ((color = fcBlack) and (j0 = 4))) and (i = en_passant) + then board[i,j0]:= ES; // убрать при e.p. враж. пешку + end; + K: + begin + if i-i0 = 2 then + begin + board[6,j0]:= board[8,j0]; // 0-0 + board[8,j0]:= ES; + end + else + if i0-i = 2 then + begin + board[4,j0]:= board[1,j0]; // 0-0-0 + board[1,j0]:= ES; + end; + case color of + fcWhite: + castling:= castling - [WhiteKingSide, WhiteQueenSide]; + fcBlack: + castling:= castling - [BlackKingSide, BlackQueenSide]; + end; + end; + R: + begin + if ((i0 = 8) and (j0 = 1)) or ((i = 8) and (j = 1)) + then castling:= castling - [WhiteKingSide] + else + if ((i0 = 1) and (j0 = 1)) or ((i = 1) and (j = 1)) + then castling:= castling - [WhiteQueenSide] + else + if ((i0 = 8) and (j0 = 8)) or ((i = 8) and (j = 8)) + then castling:= castling - [BlackKingSide] + else + if ((i0 = 1) and (j0 = 8)) or ((i = 1) and (j = 8)) + then castling:= castling - [BlackQueenSide]; + end; + end; + if (f = P) and (abs(j-j0) = 2) and + (((i > 1) and (((color = fcWhite) and (board[i-1,j] = BP)) or + ((color = fcBlack) and (board[i-1,j] = WP)))) or + ((i < 8) and (((color = fcWhite) and (board[i+1,j] = BP)) or + ((color = fcBlack) and (board[i+1,j] = WP))))) then + en_passant := i0 // вкл. e.p. + else + en_passant := 0; // выкл. e.p. + // Сделать ход + board[i0, j0]:= ES; + board[i, j] := _fig; + if (FCheckCheck(pos)) then + exit; // ход невозможен из-за шаха + if (f = P) and ((j = 1) or (j = 8)) then + begin + case prom_fig of + Q..N: ; + else + prom_fig := FAskPromotionFigure(pos.color); + end; // case + board[i, j] := TFigure(ord(color) * ord(BK) + ord(prom_fig)); + end; + if color = fcWhite then color:= fcBlack + else color:= fcWhite; + end; + + chp_res:= pos; + Result:= TRUE; +end; + + +function TChessRulesEngine.FCanMove(pos: TChessPosition): boolean; +var + i,j: integer; + ti,tj: integer; + l: byte; + f: TFigureName; + prom_fig: TFigureName; +begin + with pos do + for i:= 1 to 8 do + for j:= 1 to 8 do + begin + if ((color = fcWhite) and (board[i,j] >= ES)) or + ((color = fcBlack) and (board[i,j] <= ES)) then continue; + + f:= TFigureName(ord(board[i,j]) - ord(color) * ord(BK)); + for l:= 1 to 8 do + with DELTA_MOVE[f] do + begin + if (dx[l] = 0) and (dy[l] = 0) then break; // Все ходы просмотрены + ti:= i; tj:= j; + repeat + case color of + fcWhite: + begin + ti:= ti + dx[l]; tj:= tj + dy[l]; + end; + fcBlack: + begin + ti:= ti - dx[l]; tj:= tj - dy[l]; + end; + end; + if not ((ti in [1..8]) and (tj in [1..8])) then break; + prom_fig := Q; + if FCheckMove(pos, pos, i, j, ti, tj, prom_fig) then + begin + Result:= TRUE; + exit; + end; + until not longRange; + end; + end; + Result:= FALSE; +end; + + +function TChessRulesEngine.DoMove(move_str: string): boolean; +label + l1, l2; +var + l: byte; + f, prom_f: TFigureName; + i, j, ti,tj: integer; +begin + // Проверка на рокировку + if (move_str = '0-0') then + begin + if (Position.color = fcWhite) then + move_str:= 'Ke1g1' + else + move_str:= 'Ke8g8' + end + else if (move_str = '0-0-0') then + begin + if (Position.color = fcWhite) then + move_str:= 'Ke1c1' + else + move_str:= 'Ke8c8'; + end; + + i0 := 0; + j0 := 0; + i := 0; + j := 0; + + l := length(move_str); + prom_f := K; + case move_str[l] of + 'Q': prom_f := Q; + 'R': prom_f := R; + 'B': prom_f := B; + 'N': prom_f := N; + else goto l1; + end; + dec(l); +l1: + if move_str[l] in ['1'..'8'] then + begin + j:= StrToInt(move_str[l]); + dec(l); + end; + if move_str[l] in ['a'..'h'] then + begin + i:= ord(move_str[l]) - ord('a') + 1; + dec(l); + end; + if (l > 0) and (move_str[l] in ['1'..'8']) then + begin + j0 := StrToInt(move_str[l]); + dec(l); + end; + if (l > 0) and (move_str[l] in ['a'..'h']) then + begin + i0 := ord(move_str[l]) - ord('a') + 1; + dec(l); + end; + + if l = 0 then f:= P + else + case move_str[l] of + 'K': f:= K; + 'Q': f:= Q; + 'R': f:= R; + 'B': f:= B; + 'N': f:= N; + end; + + with Position^ do + begin + fig := TFigure(ord(f) + ord(Position.color) * ord(BK)); + + case f of + K..N: // Ход Кр - К + begin + for l:= 1 to 8 do + with DELTA_MOVE[f] do + begin + if (dx[l] = 0) and (dy[l] = 0) then break; // Все ходы просмотрены + ti:= i; tj:= j; + repeat + ti:= ti + dx[l]; tj:= tj + dy[l]; + if not ((ti in [1..8]) and (tj in [1..8])) or + ((board[ti,tj] <> ES) and (board[ti,tj] <> fig)) then break; + + if ((i0 = 0) or (i0 = ti)) and ((j0 = 0) or (j0 = tj)) and + (board[ti,tj] = fig) then + begin // Ходящая фигура найдена + i0 := ti; + j0 := tj; + goto l2; + end; + until (f = K) or (f = N); // Если Кр или К, то выход + end; + end; + P: // Ход пешкой + begin + if (i0 <> 0) and (i0 <> i) then // взятие пешкой + begin + for l:= 2 to 7 do + if (board[i0, l] = fig) and ((j0 = 0) or (j0 = l)) then + if color = fcWhite then + begin + if ((board[i,l+1] > ES) or + ((l = 5) and (en_passant = i))) and + ((j = 0) or (j = l+1)) and (abs(i - i0) = 1) then + begin + j0 := l; + j := l + 1; + goto l2; + end; + end + else // color = fcBlack + if ((board[i,l-1] < ES) or + ((l = 4) and (en_passant = i))) and + ((j = 0) or (j = l-1)) and (abs(i - i0) = 1) then + begin + j0 := l; + j := l-1; + goto l2; + end; + end + else // Ход прямо + begin + i0 := i; + if color = fcWhite then + begin + if board[i, j - 1] = fig then + j0 := j - 1 + else if (j = 4) and (board[i, 3] = ES) and + (board[i,2] = fig) then + j0 := 2; + end + else // color = fcBlack + if board[i,j+1] = fig then + j0 := j + 1 + else if (j = 5) and (board[i,6] = ES) and + (board[i, 7] = fig) then + j0 := 7; + end; + end; + end; + end; +l2: + Result := FDoMove(i, j, prom_f); +end; + + +function TChessRulesEngine.FDoMove(i, j: integer; prom_fig: TFigureName = K): boolean; +var + newPosition: TChessPosition; +begin + Result := FCheckMove(Position^, newPosition, i0, j0, i, j, prom_fig); + if (Result) then + begin + // запоминание сделанного хода + lastMove.i0 := i0; + lastMove.j0 := j0; + lastMove.i := i; + lastMove.j := j; + lastMove.prom_fig := prom_fig; + + FAddPosMoveToList; + + m_strLastMoveStr := FMove2Str(newPosition); + Position^ := newPosition; + end; +end; + + +function TChessRulesEngine.DoMove(i0, j0, i, j: integer; prom_fig: TFigureName = K): boolean; +begin + self.i0 := i0; + self.j0 := j0; + Result := FDoMove(i, j, prom_fig); +end; + + +function TChessRulesEngine.FGetLastMove: PMoveAbs; +begin + Result := @m_lastMove; +end; + + +procedure TChessRulesEngine.FAddPosMoveToList; +var + pm: PPosMove; +begin + new(pm); + pm.pos := Position^; + pm.move := lastMove^; + PositionsList.Add(pm); +end; + + +function TChessRulesEngine.FMove2Str(const pos: TChessPosition): string; +var + f: TFigureName; + l: byte; + ti, tj: integer; + ambig, hor, ver: boolean; + _fig: TFigure; +begin + if lastMove.i0 = 0 then // Ход не задан + begin + Result:= ''; + exit; + end; + + _fig := Position.board[lastMove.i0, lastMove.j0]; + f := TFigureName(ord(_fig) + (ord(pos.color) - 1) * ord(BK)); + // Ход пешкой + if (f = P) then + begin + with pos do + begin + if ((lastMove.i - lastMove.i0) = 0) then // ход + Result:= chr(ord('a') + lastMove.i - 1) + IntToStr(lastMove.j) + else // взятие + begin + Result:= chr(ord('a') + lastMove.i0 - 1) + chr(ord('a') + lastMove.i - 1); + + for l := 2 to 7 do // Проверка на двусмысленность взятия + if (((board[lastMove.i0, l] = WP) and ((Position.board[lastMove.i, l+1] > ES) or + ((Position.en_passant = lastMove.i) and (l = 5)))) and (color = fcBlack)) or + (((board[lastMove.i0, l] = BP) and ((Position.board[lastMove.i, l-1] < ES) or + ((Position.en_passant = lastMove.i) and (l = 4)))) and (color = fcWhite)) + then Result:= Result + IntToStr(lastMove.j); + end; + + if (lastMove.j = 8) or (lastMove.j = 1) then // Пешка превратилась + case board[lastMove.i,lastMove.j] of + WQ,BQ: Result:= Result + 'Q'; + WR,BR: Result:= Result + 'R'; + WB,BB: Result:= Result + 'B'; + WN,BN: Result:= Result + 'N'; + end; + exit; + end; + end; // if + + // <Фигура> + case f of + K: Result:= 'K'; + Q: Result:= 'Q'; + R: Result:= 'R'; + B: Result:= 'B'; + N: Result:= 'N'; + end; + // [<Вертикаль>][<Горизонталь>] + ambig:= FALSE; + hor:= FALSE; + ver:= FALSE; + for l := 1 to 8 do + with pos, DELTA_MOVE[f] do + begin + if (dx[l] = 0) and (dy[l] = 0) then + break; // Все ходы просмотрены + ti := lastMove.i; + tj := lastMove.j; + repeat + ti:= ti + dx[l]; tj:= tj + dy[l]; + if not (ti in [1..8]) or not (tj in [1..8]) or + ((board[ti,tj] <> ES) and (board[ti,tj] <> _fig)) then + break; + if (board[ti,tj] = _fig) then + begin + ambig:= TRUE; + ver:= ver or (ti = lastMove.i0); hor:= hor or (tj = lastMove.j0); + break; + end; + until (f = K) or (f = N); // Если Кр или К, то выход + end; + + if ambig then + begin + if not ver or hor then + Result:= Result + chr(ord('a') + lastMove.i0 - 1); + if ver then + Result := Result + IntToStr(lastMove.j0); + end; + + // <Конечное поле> + Result := Result + chr(ord('a') + lastMove.i - 1) + IntToStr(lastMove.j); + + // <Короткая рокировка> | <Длинная рокировка> + if f = K then + begin + if lastMove.i - lastMove.i0 = 2 then + Result:= '0-0' + else if lastMove.i0 - lastMove.i = 2 then + Result:= '0-0-0'; + end; +end; + + +function TChessRulesEngine.TakeBack: boolean; +begin + Result := (PositionsList.Count > 0); + if (Result) then + FDelPosList; +end; + + +procedure TChessRulesEngine.FDelPosList; +var + i: integer; +begin + i := PositionsList.Count - 1; + if (i >= 0) then + begin + Position^ := PPosMove(PositionsList[i]).pos; + Dispose(PositionsList[i]); + PositionsList.Delete(i); + end; +end; + + +function TChessRulesEngine.SetPosition(const posstr: string): boolean; +var + i, j, k: integer; + l: byte; + pos: TChessPosition; +begin + Result:= FALSE; + + l := 1; + for j := 8 downto 1 do + begin + i := 1; + repeat + case posstr[l] of + 'K': pos.board[i,j]:= WK; + 'Q': pos.board[i,j]:= WQ; + 'R': pos.board[i,j]:= WR; + 'B': pos.board[i,j]:= WB; + 'N': pos.board[i,j]:= WN; + 'P': pos.board[i,j]:= WP; + + 'k': pos.board[i,j]:= BK; + 'q': pos.board[i,j]:= BQ; + 'r': pos.board[i,j]:= BR; + 'b': pos.board[i,j]:= BB; + 'n': pos.board[i,j]:= BN; + 'p': pos.board[i,j]:= BP; + + '1'..'8': // Вставка пустых полей + begin + k:= StrToInt(posstr[l]); + repeat + pos.board[i,j]:= ES; + dec(k); inc(i); + until k = 0; + dec(i); + end; + + ' ': break; // Позиция прочитана - выход из цикла + + else exit; // ошибка в posstr + end; + inc(i); inc(l); + until (posstr[l] = '/') or (i > 8); // Повтор до появления '/' или пока на горизонтали + inc(l); + end; + + case posstr[l] of + 'w': pos.color:= fcWhite; + 'b': pos.color:= fcBlack; + else exit; + end; + + inc(l,2); + pos.castling:= []; + while posstr[l] <> ' ' do + begin + with pos do + case posstr[l] of + 'K': castling:= castling + [WhiteKingSide]; + 'Q': castling:= castling + [WhiteQueenSide]; + 'k': castling:= castling + [BlackKingSide]; + 'q': castling:= castling + [BlackQueenSide]; + '-': + if castling <> [] then exit + else + begin + inc(l); + break; + end; + else + exit; + end; + inc(l); + end; + + inc(l); + with pos do + case posstr[l] of + 'a'..'h': en_passant:= ord(posstr[l]) - ord('a') + 1; + '-': en_passant:= 0; + else + exit; + end; + + if (Trim(RightStr(posstr, length(posstr) - l)) <> '') then + exit; + + Position^ := pos; + lastMove.i0 := 0; // предыдущего хода ещё не было + + Result := TRUE; +end; + + +procedure TChessRulesEngine.InitNewGame; +begin + SetPosition(INITIAL_CHESS_POSITION); + ResetMoveList; +end; + + +procedure TChessRulesEngine.ResetMoveList; +var + i: integer; +begin + for i := 0 to PositionsList.Count - 1 do + Dispose(PositionsList[i]); + PositionsList.Clear; +end; + + +function TChessRulesEngine.GetPosition: string; +var + i,j: Integer; + k: byte; + chFig: char; +begin + Result:= ''; + + with Position^ do + begin + // Расстановка фигур + for j := 8 downto 1 do + begin + k:= 0; + for i:= 1 to 8 do + begin + case board[i,j] of + WK: chFig := 'K'; + WQ: chFig := 'Q'; + WR: chFig := 'R'; + WB: chFig := 'B'; + WN: chFig := 'N'; + WP: chFig := 'P'; + BK: chFig := 'k'; + BQ: chFig := 'q'; + BR: chFig := 'r'; + BB: chFig := 'b'; + BN: chFig := 'n'; + BP: chFig := 'p'; + ES: + begin + inc(k); + continue; + end; + end; + + if k > 0 then + begin + Result:= Result + IntToStr(k); + k:= 0; + end; + + Result := Result + chFig; + end; + + if k > 0 then Result:= Result + IntToStr(k); + if j = 1 then Result:= Result + ' ' + else Result:= Result + '/'; // i <= 7 + end; + + if color = fcWhite then Result:= Result + 'w ' + else Result:= Result + 'b '; // color = fcBlack + // Рокировка + if castling = [] then Result:= Result + '-' + else + begin + if WhiteKingSide in castling then Result:= Result + 'K'; + if WhiteQueenSide in castling then Result:= Result + 'Q'; + if BlackKingSide in castling then Result:= Result + 'k'; + if BlackQueenSide in castling then Result:= Result + 'q'; + end; + // en-passant + if (en_passant = 0) then + Result := Result + ' -' + else + Result := Result + ' ' + Chr(Ord('a') - 1 + en_passant); + end; +end; + + +procedure TChessRulesEngine.InitNewPPRandomGame; +const + FIG: array[0..5] of TFigureName = (B, B, Q, R, N, N); + SQR: array[0..5] of byte = (2, 3, 4, 6, 7, 0); +var + rnd_sqr: array[0..5] of byte; + i,j: integer; + f: boolean; +begin + InitNewGame; + if (Random(2) = 0) then + SQR[5] := 1 // с какой стороны оставляем ладью + else + SQR[5] := 8; + + for i := 0 to 5 do + begin + repeat + rnd_sqr[i] := SQR[Random(6)]; + f := FALSE; + for j := 0 to i-1 do f := f or (rnd_sqr[i] = rnd_sqr[j]); + until not (f or ((i = 1) and (((rnd_sqr[0] xor rnd_sqr[1]) and 1) = 0))); + Position.board[rnd_sqr[i], 1] := TFigure(ord(FIG[i])); + Position.board[rnd_sqr[i], 8] := TFigure(ord(BK) + ord(FIG[i])); + end; +end; + + +function TChessRulesEngine.NMovesDone: integer; +begin + Result := (PositionsList.Count + 1) shr 1; // div 2 +end; + + +function TChessRulesEngine.GetEvaluation: TEvaluation; +begin + Result := evInGame; + if (not FCanMove(Position^)) then + begin + if (FCheckCheck(Position^)) then + Result := evMate + else + Result := evStaleMate; + end; + // TODO: Evaluate position for possible technical draw +end; + +end. -- cgit v1.2.3