source: trunk/Forms/FormComputer.pas

unit FormComputer;

interface

uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ComCtrls,
  Game, Generics.Collections, Generics.Defaults, FormEx, Board;

type
  { TGameTry }

  TGameTry = class
    Game: TGame;
    Moves: array of TMoveDirection;
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TGameTry);
  private
    function GetFitness: Double;
    function GetFitnessSnake: Double;
  end;

  TGameTries = class(TObjectList<TGameTry>)
  end;

  { TGameTryComparer }

  TGameTryComparer = class(TInterfacedObject, IComparer<TGameTry>)
    function Compare(constref Left, Right: TGameTry): Integer; overload;
  end;

  { TFormComputer }

  TFormComputer = class(TFormEx)
    ButtonStart: TButton;
    ButtonEnd: TButton;
    ButtonStep: TButton;
    Label1: TLabel;
    TrackBar1: TTrackBar;
    procedure ButtonStartClick(Sender: TObject);
    procedure ButtonEndClick(Sender: TObject);
    procedure ButtonStepClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    Running: Boolean;
    GameTries1: TGameTries;
    GameTries2: TGameTries;
    GameTries3: TGameTries;
    GameTries4: TGameTries;
    procedure Step;
    procedure TryAllDirections(GameTries: TGameTries; GameTry: TGameTry);
    procedure UpdateInterface;
  end;


implementation

{$R *.lfm}

uses
  Core;

{ TGameTry }

function TGameTry.GetFitness: Double;
const
  DirWeight: array[TMoveDirection] of Double = (0, 0.25, -10000, 0.5, 0.75);
var
  I: Integer;
  WeightSnake: Double;
  WeightMoves: Double;
  WeightScore: Double;
  WeightSteps: Double;
begin
  WeightSnake := 1000 * GetFitnessSnake;

  WeightMoves := 0;
  for I := 0 to Length(Moves) - 1 do
    WeightMoves := WeightMoves + DirWeight[Moves[I]];
  WeightMoves := WeightMoves / Length(Moves);

  WeightScore := 100 * Game.Score / Game.Board.GetValueSum;
  WeightSteps := 1 / Length(Moves) * 0.25;

  Result := WeightScore + WeightSteps + WeightSnake + WeightMoves;
end;

function TGameTry.GetFitnessSnake: Double;
var
  P: TPoint;
  HorizDir: Integer;
  Sequence: Integer;
  HighestValue: Integer;
begin
  HighestValue := Game.Board.GetHighestTileValue;
  Sequence := (Game.Board.Size.X * Game.Board.Size.Y);
  Result := 0;
  P := Point(Game.Board.Size.X, Game.Board.Size.Y - 1);
  HorizDir := -1;
  while (P.Y >= 0) do begin
    if ((P.X + HorizDir) < 0) or ((P.X + HorizDir) > (Game.Board.Size.X - 1)) then begin
      HorizDir := -HorizDir;
      Dec(P.Y);
      if P.Y < 0 then Break;
    end else Inc(P.X, HorizDir);
    if Game.Board.Tiles[P.Y, P.X].Value <> 0 then begin
      Result := Result + (Game.Board.Tiles[P.Y, P.X].Value / HighestValue) *
      (Sequence / (Game.Board.Size.X * Game.Board.Size.Y));
    end;
    Dec(Sequence);
  end;
  Result := Result / (Game.Board.Size.X * Game.Board.Size.Y);
end;

constructor TGameTry.Create;
begin
  Game := TGame.Create;
end;

destructor TGameTry.Destroy;
begin
  FreeAndNil(Game);
  inherited;
end;

procedure TGameTry.Assign(Source: TGameTry);
var
  I: Integer;
begin
  Game.Assign(Source.Game);
  SetLength(Moves, Length(Source.Moves));
  for I := 0 to Length(Moves) - 1 do
    Moves[I] := Source.Moves[I];
end;

{ TGameTryComparer }

function TGameTryComparer.Compare(constref Left, Right: TGameTry): Integer;
var
  ScoreLeft: Double;
  ScoreRight: Double;
begin
  ScoreLeft := Left.GetFitness;
  ScoreRight := Right.GetFitness;
  if ScoreLeft > ScoreRight then Result := -1
  else if ScoreLeft < ScoreRight then Result := 1
  else Result := 0;
end;

{ TFormComputer }

procedure TFormComputer.FormClose(Sender: TObject; var CloseAction: TCloseAction
  );
begin
  Running := False;
end;

function GameCompareScore(const Item1, Item2: TGameTry): Integer;
var
  Score1: Double;
  Score2: Double;
begin
  Score1 := Item1.GetFitness;
  Score2 := Item2.GetFitness;
  if Score1 > Score2 then Result := -1
  else if Score1 < Score2 then Result := 1
  else Result := 0;
end;

procedure TFormComputer.ButtonStartClick(Sender: TObject);
begin
  Running := True;
  while Core.Core.Game.CanMove and Running do begin
    Step;
  end;
  Running := False;
end;

procedure TFormComputer.ButtonEndClick(Sender: TObject);
begin
  Running := False;
end;

procedure TFormComputer.ButtonStepClick(Sender: TObject);
begin
  Step;
end;

procedure TFormComputer.FormCreate(Sender: TObject);
begin
  GameTries1 := TGameTries.Create;
  GameTries2 := TGameTries.Create;
  GameTries3 := TGameTries.Create;
  GameTries4 := TGameTries.Create;
  UpdateInterface;
end;

procedure TFormComputer.FormDestroy(Sender: TObject);
begin
  FreeAndNil(GameTries1);
  FreeAndNil(GameTries2);
  FreeAndNil(GameTries3);
  FreeAndNil(GameTries4);
end;

procedure TFormComputer.Step;
var
  NewTry: TGameTry;
  S: string;
  I: Integer;
  J: Integer;
  GameTries: TGameTries;
  GameTryComparer: TGameTryComparer;
  Delay: Integer;
begin
  with Core.Core.Game do begin
    NewTry := TGameTry.Create;
    NewTry.Game.Assign(Core.Core.Game);
    GameTries1.Clear;
    TryAllDirections(GameTries1, NewTry);
    FreeAndNil(NewTry);
    GameTries2.Clear;
    for I := 0 to GameTries1.Count - 1 do
      TryAllDirections(GameTries2, GameTries1[I]);
    GameTries3.Clear;
    for I := 0 to GameTries2.Count - 1 do
      TryAllDirections(GameTries3, GameTries2[I]);
    GameTries4.Clear;
    for I := 0 to GameTries3.Count - 1 do
      TryAllDirections(GameTries4, GameTries3[I]);

    GameTries := GameTries4;
    GameTryComparer := TGameTryComparer.Create;
    GameTries.Sort(GameTryComparer);
    S := '';
    for I := 0 to GameTries.Count - 1 do begin
      S := S + FormatFloat('0.000', GameTries[I].GetFitness) + '(';
      for J := 0 to Length(GameTries[I].Moves) - 1 do
        S := S + DirectionText[GameTries[I].Moves[J]] + ' ';
      S := S + '), ';
    end;
    MoveAllAndUpdate(GameTries[0].Moves[0], False);
  {      if CanMergeDirection(drDown) then MoveAllAnimate(drDown)
    else if CanMergeDirection(drRight) then MoveAllAnimate(drRight)
    else if CanMergeDirection(drLeft) then MoveAllAnimate(drLeft)
    else if CanMoveDirection(drDown) then MoveAllAnimate(drDown)
    else if CanMoveDirection(drRight) then MoveAllAnimate(drRight)
    else if CanMoveDirection(drLeft) then MoveAllAnimate(drLeft)
    else if CanMoveDirection(drUp) then MoveAllAnimate(drUp)
    else Break;
    }
    Delay := TrackBar1.Position;
    while Delay > 0 do begin
      Application.ProcessMessages;
      Sleep(10);
      Delay := Delay - 10;
    end;
  end;
  UpdateInterface;
end;

procedure TFormComputer.TryAllDirections(GameTries: TGameTries; GameTry: TGameTry);
var
  Direction: TMoveDirection;
  NewTry: TGameTry;
begin
  for Direction := drLeft to drDown do begin
    if GameTry.Game.CanMoveDirection(Direction) then begin
      NewTry := TGameTry.Create;
      NewTry.Assign(GameTry);
      NewTry.Game.UndoEnabled := False;
      NewTry.Game.AnimationDuration := 0;
      NewTry.Game.MoveAll(Direction, False);
      SetLength(NewTry.Moves, Length(NewTry.Moves) + 1);
      NewTry.Moves[Length(NewTry.Moves) - 1] := Direction;
      GameTries.Add(NewTry);
    end;
  end;
end;

procedure TFormComputer.UpdateInterface;
begin
  ButtonStart.Enabled := not Running;
  ButtonStep.Enabled := not Running;
  ButtonEnd.Enabled := Running;
end;

end.