Реализация игры "Шашки" на Delphi

Размещено на http://www.allbest.ru/

Размещено на http://www.allbest.ru/

Федеральное агентство образования Республики Бурятия

Бурятский государственный университет

Институт математики и информатики

Кафедра информационных технологий

Курсовая работа

Реализация игры "Шашки" на Delphi

Выполнила: Раднаева М., группа 05470

Научный руководитель: Мордовской А. К.

Улан-Удэ

2010

Содержание

1. Из истории

2. Классификация

3. Правила игры

4. Код программы

1. Из истории

Как и большинство настольных игр, шашки появились достаточно давно и во все времена пользовались немалой популярностью. Точной истории возникновения проследить не удается, хотя при раскопках, которые проходили в Египте, была найдена древняя доска и набор из фишек двух разных цветов, которые отдаленно напоминали современный инвентарь.

Согласно другой теории, шашки взяли свое начало от игры "латрункули", которая была достаточно популярна в Риме. Правила практически полностью соответствовали современным шашкам, за исключением некоторых нюансов. Например, в этой игре не было возможности обратного хода, зато существовали аналоги дамок - ими считались фишки, которые перешли на территорию противника и тем самым получали некоторые преимущества перед остальными шашками.

Что касается происхождения, то здесь можно вспомнить и историю об игре "алькерк" - мавританской настольной версии, в которой присутствовало две армии по 12 шашек, а ход производился по пересечению клеток игрового поля.

Помимо теорий возникновения игры, которые имеют под собой определенные исторические факты, существует и легенда. В ней говорится о том, что шашки были придуманы греческим богом Гермесом, который благодаря партии, выиграл 5 дополнительных дней в году. После этого, они добавились к 360 дням, и получилась современная протяжённость года.

Когда говорится об истории, то зачастую упоминается рассказ о греческом воине Паламеде, который придумал игру подобную шашкам, чтобы убить скуку. Это было во времена десятилетней осады одного из городов. Преимуществом данной игры было то, что любой желающий мог в нее сыграть, используя доску или просто нарисовав игровое поле на земле.

Какая же из всех перечисленных теорий является правдивой и достоверной, установить так и не удалось, зато известно, что на территорию древней Руси шашки попали примерно в Х веке нашей эры. При археологических раскопках были найдены шашки из натурального камня, глины и других доступных в то время материалов.

Чуть позже, во времена правления Петра I, игра уже стала настолько популярна и известна, что для неё оборудовались отдельные комнаты. Позже стали устраиваться турниры и соревнования, что еще больше укоренило этот вид развлечений.

Первая статья о шашках в России появилась в 1803 году. Ее автор - Н.М.Карамзин. Любителями шашек были Державин, Пушкин. Л.Н.Толстой в “Войне и мире” сравнивает стратегию военного искусства со стратегией шашечной игры. Наполеон шахматам предпочитал шашки, черпая в этой игре идеи для тактики ведения боя, и никогда не расставался во своей перламутровой шашечной доской.

Шашки -- игра для двух игроков на многоклеточной доске, подобной шахматной, специальными фишками - шашками. Подобно шахматам, шашки воспроизводят действия сражающихся по определённым правилам сил.

2. Классификация

шашки игра программа код

Возможны различные классификации шашечных игр. Прежде всего, можно выделить собственно шашки и «игры шашечного типа», которые шашками обычно не называют (го, рэндзю, и пр., см. выше). Данная статья рассматривает только первую из этих категорий.

По размерам доски -- 12х12 (канадские), 10х10 (международные), 8х8 (подавляющее большинство вариантов шашек).

По особенностям правил игры. К ним относятся:

Начальное расположение шашек. Возможны разнообразные варианты.

Направление хода и взятия: по диагонали или по вертикали/горизонтали.

Возможность боя назад простой шашкой.

Правила предпочтения взятия: при наличии нескольких вариантов боя в одних играх игрок может выбрать любой вариант, в других -- его свобода выбора ограничена.

Правила превращения простой шашки в дамку: существуют различия в правиле превращения в дамку при прохождении дамочного поля во время взятия нескольких шашек противника. В одних правилах шашка, попавшая в середине хода на поле превращения, становится дамкой сразу же и может продолжать бить, как дамка, в других -- простая становится дамкой только на следующем ходу, если предыдущий завершился на поле превращения.

Варианты шашек

Международные шашки. Игра наиболее популярна в Европе. Используется доска 10Ч10 клеток. У каждого игрока в начальной позиции по 20 шашек, которые занимают первые четыре ряда с каждой стороны, «простая» шашка может бить вперёд и назад, дамка может ходить и бить на любое число полей. «Простая» превращается в дамку только тогда, когда она заканчивает свой ход на поле превращения. При бое «простой» через поле превращения она не превращается и продолжает бой как простая. Если после поля превращения «простая» может бить только как дамка, она остаётся на поле превращения и может продолжать бить как дамка только со следующего хода. Также как и в русских шашках существует правило «турецкого удара». При возможности нескольких вариантов взятия полагается бить максимально возможное количество шашек. Цель игры, как и в русских шашках, -- съесть или запереть все шашки противника.

Алтайские шашки. Сочетают в себе правила шашек и шахмат.

Бразильские шашки. Правила аналогичны международным шашкам, но игра ведётся на доске 8Ч8, по 12 шашек с каждой стороны.

Канадские шашки. В канадские шашки играют на доске 12Ч12, по 24 шашки с каждой стороны. В остальном правила аналогичны международным шашкам.

Английские шашки. Английские или американские шашки, или чекерс (англ. Checkers). Доска 8Ч8, в начальной позиции у каждого игрока по 12 шашек, расположенных в первых трёх рядах на чёрных клетках. Первый ход делают чёрные. «Простые» шашки могут ходить по диагонали на одну клетку вперёд и бить только вперёд, дамка может ходить на одну клетку по диагонали вперёд и назад и бить через одну клетку в любую сторону. Бить обязательно, если есть несколько путей, игрок может выбрать любой, не обязательно самый длинный, но пройти его до конца. В 2007 году Джонатан Шеффер доказал, что существует беспроигрышный алгоритм, следуя которому игрок может рассчитывать минимум на ничью в английских шашках, вне зависимости от того, каким цветом он играет. Являясь беспроигрышным, данный алгоритм тем не менее не является оптимальным.

Пул (Pool Checkers). Популярный в США вариант игры. Правила аналогичны международным шашкам, но игра ведётся на доске 8Ч8, по 12 шашек с каждой стороны. Ещё одно отличие -- не требуется бить максимальное количество шашек.

Итальянские шашки. В итальянские шашки играют на шахматной доске размером 8Ч8 клеток, которая повернута на 90 градусов по сравнению со стандартной. Шашки игроков занимают первые три ряда с каждой стороны, располагаясь на белых полях. Правила игры в итальянские шашки похожи на правила игры чекерс, но имеют некоторые отличия: простая шашка не может бить назад и не может бить дамку; бить нужно максимально возможное количество шашек соперника, а при равных вариантах боя нужно бить максимальное количество дамок.

Испанские шашки. Правила подобны бразильским шашкам, но доска повёрнута на 90 градусов по сравнению со стандартной. Шашки игроков занимают первые три ряда с каждой стороны, располагаясь на белых полях. Ещё одно отличие -- простые шашки не могут бить назад.

Турецкие шашки. Оригинальны по внешнему виду турецкие шашки. В них игра ведётся на стандартной 64-клеточной доске, но шашки ходят и бьют не по диагоналям, а по вертикалям и горизонталям, взятие назад для простой шашки запрещено. Ещё одна их особенность -- наличие «джентльменских правил» -- правил, требующих от игрока предупреждать противника, когда его шашки ставятся под удар и когда простая шашка оказывается на седьмой или восьмой горизонтали.

Поддавки (обратные шашки). Правила игры в поддавки (здесь также существуют варианты 8Ч8 и 10Ч10) аналогичны правилам в соответствующие русские и международные шашки, однако цель игры -- поддать или запереть все свои шашки.

Шашки-самоеды. Играются на доске 8*8. В отличие от русских шашек, каждый из игроков может (и обязан при возможности, то есть, с самого начала игры) бить как шашки противника, так и свои шашки (взятие всегда производится своей шашкой). Можно бить несколько шашек обоих цветов за один ход. В принципе, возможна игра на доске 10*10, но без правила обязательного взятия большинства.

Столбовые шашки. Старинный русский вариант, где побитая простая шашка не снимается с поля, а ставится под побившую её башню.

Ставропольские шашки. По сравнению с русскими шашками добавлено лишь одно новое правило, резко усложнившее характер борьбы: в ставропольских шашках любой из игроков вместо хода своей шашкой всегда может сделать ход за противника. Так, начиная игру, белые имеют право играть чёрной шашкой. Двигать чужие простые шашки можно только в свою сторону и брать ими следует только свои шашки. Взятие обязательно.

Диагональные шашки. Правила аналогичны правилам в русские шашки, но начальная расстановка -- иная (большая диагональ свободна, сверху и слева от нее все клетки заняты черными шашками, снизу и справа -- белыми).

3. Правила игры

Правила игры в русские шашки

Для игры в русские шашки используется та же доска, что и для игры в шахматы. Игровыми полями являются только темные поля. У каждого игрока есть по 12 шашек. Первый ход всегда делают белые. Игроки ходят по очереди.

Начальное расположение показано на рисунке1:

Цель игры в шашки: выбить все шашки противника или заблокировать возможность их движения.

Ходят шашки только по диагонали на одно поле вперед.

Выбить шашку противника можно только перскочив ее. Для этого шашка должна находиться рядом с шашкой противника, а позади нее должо быть свободное поле. Причем выбивать можно не только ходом вперед, но и назад. Если после ударного хода, есть возможность выбить этой же шашкой другую враждебную шашку, то игрок делает еще один ударный ход, не передавая права хода сопернику. Т.е. за раз можно выбить одну-две-три и более шашек.

Если у игрока есть возможность выбить шашку противника, то он обязан сделать этот ударный ход, не зависимо от его желаний.

Шашка, которая дошла до противоположной стороны доски становится дамкой. Дамка может перемещаться на любой количество полей по диагонали вперед или назад. Если дамка выбила шашку соперника, то она может стать на любое свободное поле после того поля, где стояло выбитая шашка. Дамка, как и обычная шашка, обязана выбить чужую шашку, если такая возможность имеется. Дамка тоже может за раз выбить несколько шашек.

Если у игрока есть возможность выбить чужие шашки в разных направлениях, то он сам выбирает какой путь выбрать.

4. Код программы

const

MM_DOMOVE = WM_USER + 1;

MM_DEBUG = WM_USER + 2;

MM_IS_ANIMATION = WM_USER + 3;

implementation

uses GameTactics;

{$R *.DFM}

function Thinker(APosition: Pointer): Integer;

var

Position: TPosition;

Estimate: Integer;

begin

Position := TPosition(APosition^);

SelectMove(Position, MainForm.Deep, Estimate);

SendMessage(MainForm.Handle, MM_DOMOVE, Integer(@Position), Estimate);

Result := 0;

end;

procedure TMainForm.SelectCellBtnClick(Sender: TObject);

begin

PositionFrame.SelectCell(1, 6);

end;

procedure TMainForm.AcceptMove(Sender: TObject; const NewPosition: TPosition);

var

St: string;

begin

GameHistory.AddMove(NewPosition);

PositionFrame.SetPosition(NewPosition);

St := GameOver(NewPosition);

if St <> '' then

begin

ShowMessage(St);

PositionFrame.AcceptMove := False;

Exit;

end;

TuneState;

end;

procedure TMainForm.FormResize(Sender: TObject);

begin

PositionFrame.Left := 3;

PositionFrame.Top := 3;

Memo.Left := 3;

Memo.Top := PositionFrame.Top + PositionFrame.Height + 3;

Memo.Width := ClientWidth - 6;

Memo.Height := ClientHeight - PositionFrame.Height - 9;

PartyView.Left := PositionFrame.Left + PositionFrame.Width + 3;

PartyView.Width := ClientWidth - PositionFrame.Width - 9;

PartyView.Top := 3;

PartyView.Height := PositionFrame.Height;

PartyView.Columns[0].Width := 30;

PartyView.Columns[1].Width := (PartyView.Width - 40) div 2;

PartyView.Columns[2].Width := (PartyView.Width - 40) div 2;

end;

procedure TMainForm.DoMove(var Message: TMessage);

var

NewPosition: TPosition;

begin

NewPosition := TPosition(Pointer(Message.WParam)^);

CloseHandle(ThreadHandle);

ThreadHandle := 0;

AcceptMove(nil, NewPosition);

end;

procedure TMainForm.FormCreate(Sender: TObject);

begin

FMode := mdMachineBlack;

Memo.Clear;

DoubleBuffered := True;

FGameHistory := TGameHistory.Create;

end;

procedure TMainForm.TuneState;

var

RunThinker: Boolean;

ThreadId: Cardinal;

Index: Integer;

V: Integer;

begin

if ThreadHandle <> 0 then StopThinking;

PositionFrame.AcceptMove := (Mode = mdView)

or ((Mode = mdMachineWhite) and (PositionFrame.Position.Active = ActiveBlack))

or ((Mode = mdMachineBlack) and (PositionFrame.Position.Active = ActiveWhite));

RunThinker := (Mode = mdTwoMachine)

or ((Mode = mdMachineWhite) and (PositionFrame.Position.Active = ActiveWhite))

or ((Mode = mdMachineBlack) and (PositionFrame.Position.Active = ActiveBlack));

if DebugMenu.Visible then

begin

Index := Lib.IndexOf(FormatPosition(PositionFrame.Position));

if Index <> -1 then

begin

V := Integer(Lib.Objects[Index]);

Memo.Lines.Add(Format('Theory = %.3f', [V/200]));

end;

end;

if not RunThinker then Exit;

ThreadHandle := BeginThread(nil, 8*4096, @Thinker, @PositionFrame.Position, CREATE_SUSPENDED, ThreadId);

SetThreadPriority(ThreadHandle, THREAD_PRIORITY_BELOW_NORMAL);

ResumeThread(ThreadHandle);

end;

Position := Pointer(Message.WPAram);

Memo.Lines.Add(Format('E=%d N=%.3f M=%s',

[Message.LParam, Message.LParam/200, GetLastMove(Position^)]));

end;

const

MAX_LEN = 60;

procedure TMainForm.StopThinking;

begin

TerminateThread(ThreadHandle, 0);

CloseHandle(ThreadHandle);

ThreadHandle := 0;

end;

procedure TGameHistory.AddWhiteMove(const Move: string);

var

NewItem: TListItem;

begin

NewItem := PartyView.Items.Add;

NewItem.Caption := IntToStr((MoveNo div 2) + 1);

NewItem.Subitems.Add(Move);

PartyView.Selected := NewItem;

PartyView.Selected.MakeVisible(False);

end;

procedure TGameHistory.AddBlackMove(const Move: string);

var

Item: TListItem;

begin

Assert(MainForm.PartyView.Items.Count > 0);

Item := PartyView.Items[PartyView.Items.Count-1];

Item.Subitems.Add(Move);

PartyView.Selected := Item;

PartyView.Selected.MakeVisible(False);

end;

procedure TGameHistory.AddMove(NewPosition: TPosition);

var

Move: string;

begin

Move := GetLastMove(NewPosition);

if Move <> '' then

if FPositions[MoveNo].Active = ActiveWhite

then AddWhiteMove(Move)

else AddBlackMove(Move);

MoveNo := MoveNo + 1;

FPositions[MoveNo] := NewPosition;

end;

procedure TGameHistory.NewGame;

begin

MoveNo := 0;

PartyView.Items.Clear;

FPositions[0] := StartBoard;

PositionFrame.SetPosition(StartBoard);

end;

function TGameHistory.GetPartyView: TListView;

begin

Result := MainForm.PartyView;

end;

function TGameHistory.GetPositionFrame: TPositionFrame;

begin

Result := MainForm.PositionFrame;

end;

procedure TGameHistory.Undo;

var

Last: Integer;

Item: TListItem;

begin

Assert(MoveNo > 0);

MainForm.ViewItem.Click;

MoveNo := MoveNo - 1;

PositionFrame.SetPosition(FPositions[MoveNo], False);

Last := PartyView.Items.Count-1;

Assert(Last >= 0);

Item := PartyView.Items[Last];

if Item.SubItems.Count > 1

then Item.SubItems.Delete(1)

else PartyView.Items.Delete(Last);

end;

procedure TMainForm.NewGameActionExecute(Sender: TObject);

begin

StopThinking;

GameHistory.NewGame;

if Mode in [mdMachineWhite, mdTwoMachine] then MachineBlackItem.Click;

PositionFrame.AcceptMove := True;

end;

procedure TMainForm.Deselect(Action: TAction; const Category: string);

var

I: Integer;

begin

for I := 0 to ActionList.ActionCount - 1 do

begin

if ActionList.Actions[I].Category <> Category then Continue;

if ActionList.Actions[I] = Action then Continue;

(ActionList.Actions[I] as TAction).Checked := False;

end;

end;

procedure TMainForm.LevelActionExecute(Sender: TObject);

begin

Deselect(Sender as TAction, 'Level');

with Sender as TAction do

begin

Checked := True;

Deep := Tag;

end;

end;

procedure TMainForm.UndoMoveActionExecute(Sender: TObject);

begin

GameHistory.Undo;

end;

procedure TMainForm.ActionListUpdate(Action: TBasicAction;

var Handled: Boolean);

begin

UndoMoveAction.Enabled := GameHistory.MoveNo > 0;

end;

procedure TMainForm.ExitActionExecute(Sender: TObject);

begin

ViewItem.Click;

Close;

end;

procedure TMainForm.MachineWhiteActionExecute(Sender: TObject);

begin

Deselect(Sender as TAction, 'Mode');

(Sender as TAction).Checked := True;

if Mode = mdMachineWhite then Exit;

FMode := mdMachineWhite;

PositionFrame.FlipBoard := True;

TuneState;

end;

procedure TMainForm.MachineBlackActionExecute(Sender: TObject);

begin

Deselect(Sender as TAction, 'Mode');

(Sender as TAction).Checked := True;

if Mode = mdMachineBlack then Exit;

FMode := mdMachineBlack;

PositionFrame.FlipBoard := False;

TuneState;

end;

procedure TMainForm.TwoMachineActionExecute(Sender: TObject);

begin

Deselect(Sender as TAction, 'Mode');

(Sender as TAction).Checked := True;

if Mode = mdTwoMachine then Exit;

FMode := mdTwoMachine;

TuneState;

end;

procedure TMainForm.ViewGameActionExecute(Sender: TObject);

begin

Deselect(Sender as TAction, 'Mode');

(Sender as TAction).Checked := True;

if Mode = mdView then Exit;

FMode := mdView;

ViewItem.Checked := True;

if ThreadHandle <> 0 then StopThinking;

end;

procedure TMainForm.SetPositionActionExecute(Sender: TObject);

var

Position: TPosition;

begin

ViewItem.Click;

FillChar(Position.Field, 32, $00);

Position.Field[31] := -20;

Position.Field[29] := 70;

Position.Active := ActiveWhite;

// Position.Field[0] := 20;

// Position.Field[2] := -70;

// Position.Active := ActiveBlack;

Position.MoveCount := 0;

PositionFrame.SetPosition(Position);

end;

procedure TMainForm.AddToLibraryActionExecute(Sender: TObject);

var

V: Integer;

Estimate: string;

PositionFmt: string;

Index: Integer;

begin

DecimalSeparator := '.';

Estimate := InputBox('Input', 'Please, enter estimate', '');

if Estimate = '' then Exit;

Estimate := StringReplace(Estimate, ',', '.', []);

V := Round(200 * StrToFloat(Estimate));

PositionFmt := FormatPosition(PositionFrame.Position);

Index := Lib.IndexOf(PositionFmt);

if Index = -1 then

Lib.AddObject(PositionFmt, TObject(V))

else begin

Lib.Sorted := False;

Lib[Index] := PositionFmt;

Lib.Objects[Index] := TObject(V);

Lib.Sorted := True;

end;

SaveLib;

end;

procedure TMainForm.CopyGameActionExecute(Sender: TObject);

var

MoveNo: Integer;

Item: TListItem;

CurrentSt: string;

AllParty: TStringList;

procedure Add(const St: string);

begin

if Length(CurrentSt) + Length(St) + 1 > MAX_LEN then

begin

AllParty.Add(CurrentSt);

CurrentSt := '';

end;

if CurrentSt <> '' then CurrentSt := CurrentSt + ' ';

CurrentSt := CurrentSt + St;

end;

begin

AllParty := TStringList.Create;

try

CurrentSt := '';

for MoveNo := 0 to PartyView.Items.Count-1 do

begin

Item := PartyView.Items[MoveNo];

Add(Item.Caption + '.');

Add(Item.SubItems[0]);

if Item.SubItems.Count > 1 then

Add(Item.SubItems[1]);

end;

if CurrentSt <> '' then AllParty.Add(CurrentSt);

Clipboard.AsText := AllParty.Text;

finally

AllParty.Free;

end;

end;

end.

procedure TPositionFrame.BeginDebug;

begin

{$IFDEF SELECT_DEBUG}

if Assigned(Debug) then

begin

Debug.BeginUpdate;

Debug.Clear;

end;

{$ENDIF}

end;

procedure TPositionFrame.EndDebug;

begin

{$IFDEF SELECT_DEBUG}

if Assigned(Debug) then Debug.EndUpdate;

{$ENDIF}

end;

procedure TPositionFrame.OutputDebug(const St: string);

begin

{$IFDEF SELECT_DEBUG}

Debug.Add(St);

{$ENDIF}

end;

procedure TPositionFrame.OutputDebug(const St: string; const Args: array of const);

begin

{$IFDEF SELECT_DEBUG}

OutputDebug(Format(St, Args));

{$ENDIF}

end;

procedure TPositionFrame.OutputDebugSelectMove;

{$IFDEF SELECT_DEBUG}

var

I, J: Integer;

St: string;

{$ENDIF}

begin

{$IFDEF SELECT_DEBUG}

OutputDebug('Возможные хода:');

for I := 0 to FAnswersCount - 1 do

begin

St := PointsDef[FAnswers[I].MoveStr[0]];

J := 1;

repeat

if FAnswers[I].MoveStr[J] = -1 then Break;

St := St + FAnswers[I].TakeChar + PointsDef[FAnswers[I].MoveStr[J]];

J := J + 1;

until False;

OutputDebug('(%d) %s', [I, St]);

end;

OutputDebug('');

St := '';

for I := 0 to 31 do

if FSelectedCells[I] then St := ' ' + PointsDef[I];

OutputDebug('Selected =' + St);

St := '';

for I := 0 to FAnswersCount-1 do

St := St + Format(' %d(%d)', [FEnabledAnswer[I], I]);

OutputDebug('EnabledAnswer =' + St);

St := '';

for I := 0 to FUserSelectCount-1 do

St := St + ' ' + PointsDef[FUserSelect[I]];

OutputDebug('UserSelect =' + St);

{$ENDIF}

end;

function TPositionFrame.CellToField(X, Y: Integer): Integer;

begin

if FlipBoard

then Result := 4*Y + (7-X) div 2

else Result := 28 - 4*Y + (X div 2);

end;

procedure TPositionFrame.ClearSelect;

begin

FSelected := -1;

RefreshView;

end;

procedure TPositionFrame.DrawField(X, Y, Index: Integer);

begin

ImageList.Draw(Image.Canvas, X*ImageList.Width, Y*ImageList.Height, Index);

end;

function TPositionFrame.IsWhite(X, Y: Integer): Boolean;

begin

Result := ((X xor Y) and 1) = 0;

end;

procedure TPositionFrame.Loaded;

begin

inherited;

FSelected := -1;

end;

procedure TPositionFrame.RefreshView;

var

X, Y: Integer;

X1, X2, Y1, Y2: Integer;

P, Q: Single;

FieldIndex: Integer;

OutPosition: PPosition;

begin

if Animate

then OutPosition := @FAnimatePosition

else OutPosition := @FPosition;

ClientWidth := 8 * ImageList.Width;

ClientWidth := 8 * ImageList.Height;

for Y := 0 to 7 do

for X := 0 to 7 do

if IsWhite(X, Y) then

DrawField(X, Y, 0)

else begin

FieldIndex := CellToField(X, Y);

if Animate and (Position.MoveStr[0] = FieldIndex) then

DrawField(X, Y, 1)

else

case OutPosition.Field[FieldIndex] of

brWhiteSingle: DrawField(X, Y, 2);

brBlackSingle: DrawField(X, Y, 3);

brWhiteMam: DrawField(X, Y, 4);

brBlackMam: DrawField(X, Y, 5);

brEmpty: DrawField(X, Y, 1)

else DrawField(X, Y, 6)

end;

if FSelectedCells[FieldIndex] then

begin

Image.Canvas.Brush.Style := bsClear;

Image.Canvas.Pen.Width := 1;

Image.Canvas.Pen.Color := clGreen;

Image.Canvas.Rectangle(CellRect(X, Y));

Image.Canvas.Rectangle(CellRect(X, Y, -1));

end;

end;

if Animate then

begin

if FlipBoard then

begin

X1 := ImageList.Width * (7 - FAnimateWay[FAnimateStep-1] mod 8);

Y1 := ImageList.Height * (FAnimateWay[FAnimateStep-1] div 8);

X2 := ImageList.Width * (7 - FAnimateWay[FAnimateStep] mod 8);

Y2 := ImageList.Height * (FAnimateWay[FAnimateStep] div 8);

end

else begin

X1 := ImageList.Width * (FAnimateWay[FAnimateStep-1] mod 8);

Y1 := ImageList.Height * (7 - FAnimateWay[FAnimateStep-1] div 8);

X2 := ImageList.Width * (FAnimateWay[FAnimateStep] mod 8);

Y2 := ImageList.Height * (7 - FAnimateWay[FAnimateStep] div 8);

end;

P := FAnimateSubStep /ANIMATE_SUBSTEP_COUNT;

Q := 1 - P;

X := Round(Q*X1+P*X2);

Y := Round(Q*Y1+P*Y2);

TransparentImages.Draw(Image.Canvas, X, Y, FAnimateObject);

end;

Image.Refresh;

end;

procedure TPositionFrame.SelectCell(X, Y: Integer);

begin

if IsWhite(X, Y) then Exit;

FSelected := CellToField(X, Y);

RefreshView;

end;

procedure TPositionFrame.SetFlipBoard(const Value: Boolean);

begin

if FFlipBoard = Value then Exit;

FFlipBoard := Value;

RefreshView;

end;

procedure TPositionFrame.SetPosition(const Position: TPosition; NeedAnimate: Boolean);

begin

FAnimatePosition := FPosition;

FPosition := Position;

if AcceptMove then PrepareAccept;

if NeedAnimate and (Position.MoveStr[0] <> -1)

then BeginAnimate(Position)

else RefreshView

end;

function TPositionFrame.CellRect(X, Y: Integer; Grow: Integer = 0): TRect;

begin

Result.Left := X * ImageList.Width - Grow;

Result.Top := Y * ImageList.Height - Grow;

Result.Right := Result.Left + ImageList.Width + 2*Grow;

Result.Bottom := Result.Top + ImageList.Height + 2*Grow;

end;

procedure TPositionFrame.SetAcceptMove(const Value: Boolean);

begin

if FAcceptMove = Value then Exit;

if Value and not PrepareAccept then Exit;

FAcceptMove := Value;

end;

procedure TPositionFrame.InitSelectMoveVars;

begin

FillChar(FSelectedCells, SizeOf(FSelectedCells), $00);

FillChar(FEnabledAnswer, SizeOf(FEnabledAnswer), $00);

FUserSelectCount := 0;

end;

function TPositionFrame.PrepareAccept: Boolean;

begin

FAnswersCount := GetMoves(FPosition, @FAnswers, ANSWERS_SIZE);

Result := (FAnswersCount <> 0) and (FAnswersCount <= ANSWERS_SIZE);

InitSelectMoveVars;

end;

procedure TPositionFrame.AddCellToMove(X, Y: Integer);

begin

if IsWhite(X, Y) then Exit;

if FUserSelectCount = 0 then

begin

BeginMove(CellToField(X, Y));

Exit;

end;

if Unselect(CellToField(X, Y)) then Exit;

if ThinkBetter(CellToField(X, Y)) then Exit;

if MoveComplete(CellToField(X, Y)) then Exit;

ContinueMove(CellToField(X, Y));

end;

procedure TPositionFrame.BeginMove(Field: Integer);

var

I: Integer;

FindMove: Boolean;

begin

FindMove := False;

for I := 0 to FAnswersCount-1 do

if FAnswers[I].MoveStr[0] = Field then

begin

FindMove := True;

FEnabledAnswer[I] := 1;

end;

if not FindMove then Exit;

FUserSelect[0] := Field;

FUserSelectCount := 1;

FSelectedCells[Field] := True;

RefreshView;

end;

function TPositionFrame.Unselect(Field: Integer): Boolean;

var

I: Integer;

begin

Result := False;

if FUserSelectCount = 0 then Exit;

if FUserSelect[FUserSelectCount-1] <> Field then Exit;

FSelectedCells[Field] := False;

for I := 0 to FAnswersCount-1 do

if FEnabledAnswer[I] = FUserSelectCount then

FEnabledAnswer[I] := FEnabledAnswer[I] - 1;

FUserSelectCount := FUserSelectCount - 1;

RefreshView;

Result := True;

end;

function TPositionFrame.ThinkBetter(Field: Integer): Boolean;

var

I: Integer;

begin

Result := False;

if FUserSelectCount <> 1 then Exit;

for I := 0 to FAnswersCount-1 do

begin

if FAnswers[I].MoveStr[0] = Field then

begin

InitSelectMoveVars;

BeginMove(Field);

Result := True;

Exit;

end;

end;

end;

function TPositionFrame.MoveComplete(Field: Integer): Boolean;

var

I, J: Integer;

UserMove: Integer;

begin

Result := False;

UserMove := -1;

for I := 0 to FAnswersCount-1 do

begin

if FEnabledAnswer[I] <> FUserSelectCount then Continue;

J := 2;

while FAnswers[I].MoveStr[J] <> -1 do J := J + 1;

if FAnswers[I].MoveStr[J-1] = Field then

if UserMove <> -1 then Exit

else UserMove := I;

end;

if UserMove = -1 then Exit;

AcceptMove := False;

FillChar(FSelectedCells, SizeOf(FSelectedCells), $00);

if Assigned(FOnAcceptMove) then FOnAcceptMove(Self, FAnswers[UserMove]);

Result := True;

end;

procedure TPositionFrame.ContinueMove(Field: Integer);

var

I: Integer;

FindMove: Boolean;

function FreeWay(Field1, Field2: Integer): Boolean;

var

NextI: Integer;

Direction: TDirection;

begin

Result := False;

for Direction := Low(TDirection) to High(TDirection) do

begin

NextI := Field1;

repeat

NextI := DirectionTable[Direction, NextI];

if NextI = -1 then Break;

if FPosition.Field[NextI] <> 0 then Break;

if NextI = Field2 then

begin

Result := True;

Exit;

end;

until False;

end;

end;

function SameDiagonal(StartField, Field1, Field2, Field3: Integer): Boolean;

var

FindCount: Integer;

NextI: Integer;

Direction: TDirection;

begin

Result := False;

for Direction := Low(TDirection) to High(TDirection) do

begin

NextI := StartField;

FindCount := 0;

repeat

NextI := DirectionTable[Direction, NextI];

if NextI = -1 then Break;

if NextI = Field1 then FindCount := FindCount + 1;

if NextI = Field2 then FindCount := FindCount + 1;

if NextI = Field3 then FindCount := FindCount + 1;

if FindCount = 3 then

begin

Result := True;

Exit;

end;

until False;

end;

end;

function AcceptMarginaly: Boolean;

begin

Assert(FUserSelectCount > 0);

Result :=

(FAnswers[I].MoveStr[FUserSelectCount+1] <> -1) and // это не последнее поле

FreeWay(FAnswers[I].MoveStr[FUserSelectCount], Field) and // можно пройти

SameDiagonal( // Одна диагональ

FAnswers[I].MoveStr[FUserSelectCount-1],

FAnswers[I].MoveStr[FUserSelectCount],

Field,

FAnswers[I].MoveStr[FUserSelectCount+1])

end;

function AcceptDirectly: Boolean;

begin

Result := Field = FAnswers[I].MoveStr[FUserSelectCount];

end;

function AcceptVariant: Boolean;

begin

Result := AcceptDirectly or AcceptMarginaly;

end;

begin

FindMove := False;

for I := 0 to FAnswersCount-1 do

begin if FEnabledAnswer[I] <> FUserSelectCount then Continue;

if AcceptVariant then

begin

FindMove := True;

FEnabledAnswer[I] := FEnabledAnswer[I] + 1;

end; end;

if FindMove then

begin

FUserSelect[FUserSelectCount] := Field;

FUserSelectCount := FUserSelectCount + 1;

FSelectedCells[Field] := True;

RefreshView; end;

end;

function TPositionFrame.GetAnimate: Boolean;

begin

Result := Timer.Enabled;

end;

procedure TPositionFrame.BeginAnimate(const Position: TPosition);

var

AnimateWayPos: Integer;

I: Integer;

procedure ProcessPair(Field1, Field2: Integer);

var

Delta: Integer;

Step: Integer;

NextI: Integer;

begin

Delta := Abs(Field1 - Field2);

if Field1 > Field2 then

begin

if Delta mod 9 = 0

then Step := -9

else Step := -7

end

else begin

if Delta mod 9 = 0

then Step := 9

else Step := 7

end;

NextI := Field1;

repeat

NextI := NextI + Step;

FAnimateWay[AnimateWayPos] := NextI;

AnimateWayPos := AnimateWayPos + 1;

until NextI = Field2;

end;

begin

with Position do // Вычисляем путь

begin if MoveStr[0] = -1 then Exit;

FAnimateWay[0] := DecodeField[MoveStr[0]];

AnimateWayPos := 1; I := 1;

while MoveStr[I] <> -1 do begin

ProcessPair(DecodeField[MoveStr[I-1]], DecodeField[MoveStr[I]]);

I := I + 1; end;

case FAnimatePosition.Field[MoveStr[0]] of

brWhiteSingle: FAnimateObject := 0;

brBlackSingle: FAnimateObject := 1;

brWhiteMam: FAnimateObject := 2;

brBlackMam: FAnimateObject := 3; end;

end;

FAnimateWay[AnimateWayPos] := -1;

FAnimateStep := 1;

FAnimateSubStep := 0;

Timer.Enabled := True;

end;

procedure TPositionFrame.TimerTimer(Sender: TObject);

begin

FAnimateSubStep := FAnimateSubStep + 1;

if FAnimateSubStep = ANIMATE_SUBSTEP_COUNT then

begin

FAnimateStep := FAnimateStep + 1;

if FAnimateWay[FAnimateStep] = -1 then Timer.Enabled := False;

if (FAnimateObject = 0) and (FAnimateWay[FAnimateStep] >= 56) then FAnimateObject := 2;

if (FAnimateObject = 1) and (FAnimateWay[FAnimateStep] <= 7) then FAnimateObject := 3;

FAnimateSubStep := 0;

end;

RefreshView;

end;

end.

Размещено на Allbest.ru