source: trunk/UGame.pas

unit UGame;

{$mode delphi}{$H+}

interface

uses
  Classes, SysUtils, Dialogs, fgl, Graphics, Types, Forms, Math, DateUtils,
  Controls, URegistry;

type
  TGame = class;
  TMoveDirection = (drNone, drLeft, drUp, drRight, drDown);
  TTileAction = (taNone, taMove, taMerge, taAppear);

  { TTile }

  TTile = class
    Index: TPoint;
    Value: Integer;
    NewValue: Integer;
    Merged: Boolean;
    Action: TTileAction;
    Shift: TPoint;
    procedure Assign(Source: TTile);
  end;

  TTiles = class(TFPGObjectList<TTile>)
  end;

  { TArea }

  TArea = record
    P1, P2: TPoint;
    function Increment: TPoint;
    class function Create(P1, P2: TPoint): TArea; static; overload;
    class function Create(X1, Y1, X2, Y2: Integer): TArea; static; overload;
  end;

  { THistoryMove }

  THistoryMove = class
    Direction: TMoveDirection;
    NewItemPos: TPoint;
    NewItemValue: Integer;
    procedure SaveToRegistry(Reg: TRegistryEx; RegContext: TRegistryContext);
    procedure LoadFromRegistry(Reg: TRegistryEx; RegContext: TRegistryContext);
  end;

  { THistoryMoves }

  THistoryMoves = class(TFPGObjectList<THistoryMove>)
    procedure SaveToRegistry(Reg: TRegistryEx; RegContext: TRegistryContext);
    procedure LoadFromRegistry(Reg: TRegistryEx; RegContext: TRegistryContext);
  end;

  TTilePosValue = record
    Pos: TPoint;
    Value: Integer;
  end;

  { THistory }

  THistory = class
    Game: TGame;
    Moves: THistoryMoves;
    InitialTiles: array of TTilePosValue;
    procedure GetStep(GameStep: TGame; Step: Integer);
    procedure Clear;
    constructor Create;
    destructor Destroy; override;
    procedure SaveToRegistry(Reg: TRegistryEx; RegContext: TRegistryContext);
    procedure LoadFromRegistry(Reg: TRegistryEx; RegContext: TRegistryContext);
  end;

  { TBoard }

  TBoard = class
  private
    FSize: TPoint;
    procedure SetSize(AValue: TPoint);
  public
    Tiles: array of array of TTile;
    procedure Assign(Source: TBoard);
    procedure Clear;
    procedure ClearMerged;
    function GetValueSum: Integer;
    function GetHighestTileValue: Integer;
    function GetEmptyTilesCount: Integer;
    procedure GetEmptyTiles(EmptyTiles: TTiles);
    procedure SaveToRegistry(Reg: TRegistryEx; RegContext: TRegistryContext);
    procedure LoadFromRegistry(Reg: TRegistryEx; RegContext: TRegistryContext);
    destructor Destroy; override;
    property Size: TPoint read FSize write SetSize;
  end;

  TTileSkin = (tsLinear, tsPowerOfTwo, tsAlpha, tsRoman, tsBinary);

  { TGame }

  TGame = class
  private
    FMoving: Boolean;
    FOnChange: TNotifyEvent;
    FOnGameOver: TNotifyEvent;
    FOnPaint: TNotifyEvent;
    FOnWin: TNotifyEvent;
    FRecordHistory: Boolean;
    FRunning: Boolean;
    FScore: Integer;
    FCanUndo: Boolean;
    FBoardUndo: TBoard;
    FSkin: TTileSkin;
    function GetTileColor(Value: Integer): TColor;
    procedure SetRecordHistory(AValue: Boolean);
    procedure SetScore(AValue: Integer);
    procedure DoChange;
    procedure DoPaint;
    procedure RenderTile(Canvas: TCanvas; Tile: TTile; TileRect: TRect; WithText: Boolean);
    procedure GameOver;
    procedure SetSkin(AValue: TTileSkin);
    procedure Win;
    function FillRandomTile: TTile;
    function GetMoveArea(Direction: TMoveDirection): TArea;
    procedure MoveAllAnimate(Direction: TMoveDirection);
    function CanMergeTile(Value1, Value2: Integer): Boolean;
    function MergeTile(Value1, Value2: Integer): Integer;
    procedure AnimateTiles;
  public
    Board: TBoard;
    TopScore: Integer;
    AnimationDuration: Integer;
    AnimationTick: Integer;
    WinTileValue: Integer;
    UndoEnabled: Boolean;
    History: THistory;
    BackgroundColor: TColor;
    Value2Chance: Double;
    function CanUndo: Boolean;
    procedure Undo;
    function CanMergeDirection(Direction: TMoveDirection): Boolean;
    function CanMoveDirection(Direction: TMoveDirection): Boolean;
    function CanMove: Boolean;
    procedure Assign(Source: TGame);
    procedure New;
    procedure Render(Canvas: TCanvas; CanvasSize: TPoint);
    procedure MoveAll(Direction: TMoveDirection; Animation: Boolean);
    procedure MoveAllAndUpdate(Direction: TMoveDirection; Animation: Boolean);
    procedure MoveTile(SourceTile, TargetTile: TTile);
    function IsValidPos(Pos: TPoint): Boolean;
    procedure SaveToRegistry(RegContext: TRegistryContext);
    procedure LoadFromRegistry(RegContext: TRegistryContext);
    function GetTileSkinValue(Value: Integer): string;
    function GetTileSkinScore(Value: Integer): Integer;
    constructor Create;
    destructor Destroy; override;
    property Score: Integer read FScore write SetScore;
    property Running: Boolean read FRunning write FRunning;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
    property OnWin: TNotifyEvent read FOnWin write FOnWin;
    property OnGameOver: TNotifyEvent read FOnGameOver write FOnGameOver;
    property Moving: Boolean read FMoving;
    property RecordHistory: Boolean read FRecordHistory write SetRecordHistory;
    property Skin: TTileSkin read FSkin write SetSkin;
  end;

  TGames = class(TFPGObjectList<TGame>)
  end;

var
  SkinText: array[TTileSkin] of string;

const
  DirectionDiff: array[TMoveDirection] of TPoint = (
    (X: 0; Y: 0), (X: -1; Y: 0), (X: 0; Y: -1), (X: 1; Y: 0), (X: 0; Y: 1)
  );
  DirectionText: array[TMoveDirection] of string = ('None', 'Left', 'Up', 'Right', 'Down');
  InitialTileCount = 2;

resourcestring
  SScore = 'Score';
  STopScore = 'Top score';
  SSkinLinear = 'Linear';
  SSkinPowerOfTwo = 'Power of two';
  SSkinAlpha = 'Alpha';
  SSkinRoman = 'Roman';
  SSkinBinary = 'Binary';
  STileShouldBeEmpty = 'Tile should be empty';


procedure Translate;


implementation

uses
  UCore, UMetaCanvas;

procedure Translate;
begin
  SkinText[tsLinear] := SSkinLinear;
  SkinText[tsPowerOfTwo] := SSkinPowerOfTwo;
  SkinText[tsAlpha] := SSkinAlpha;
  SkinText[tsRoman] := SSkinRoman;
  SkinText[tsBinary] := SSkinBinary;
end;

{ THistoryMoves }

procedure THistoryMoves.SaveToRegistry(Reg: TRegistryEx; RegContext: TRegistryContext);
var
  I: Integer;
begin
  with Reg do begin
    CurrentContext := RegContext;
    WriteInteger('Count', Count);
    for I := 0 to Count - 1 do begin
      Items[I].SaveToRegistry(Reg, TRegistryContext.Create(RegContext.RootKey, RegContext.Key + '\' + IntToStr(I)));
    end;
  end;
end;

procedure THistoryMoves.LoadFromRegistry(Reg: TRegistryEx; RegContext: TRegistryContext);
var
  I: Integer;
begin
  with Reg do begin
    CurrentContext := RegContext;
    Count := ReadIntegerWithDefault('Count', 0);
    for I := 0 to Count - 1 do begin
      Items[I] := THistoryMove.Create;
      THistoryMove(Items[I]).LoadFromRegistry(Reg, TRegistryContext.Create(RegContext.RootKey, RegContext.Key + '\' + IntToStr(I)));
    end;
  end;
end;

{ THistoryMove }

procedure THistoryMove.SaveToRegistry(Reg: TRegistryEx; RegContext: TRegistryContext);
begin
  with Reg do begin
    CurrentContext := RegContext;
    WriteInteger('Direction', Integer(Direction));
    WriteInteger('NewItemPosX', NewItemPos.X);
    WriteInteger('NewItemPosY', NewItemPos.Y);
    WriteInteger('NewItemValue', NewItemValue);
  end;
end;

procedure THistoryMove.LoadFromRegistry(Reg: TRegistryEx; RegContext: TRegistryContext);
begin
  with Reg do begin
    CurrentContext := RegContext;
    Direction := TMoveDirection(ReadIntegerWithDefault('Direction', Integer(drNone)));
    NewItemPos := Point(ReadIntegerWithDefault('NewItemPosX', 0),
      ReadIntegerWithDefault('NewItemPosY', 0));
    NewItemValue := ReadIntegerWithDefault('NewItemValue', 0);
  end;
end;

{ THistory }

procedure THistory.GetStep(GameStep: TGame; Step: Integer);
var
  I: Integer;
begin
  GameStep.Board.Size := Game.Board.Size;
  GameStep.Board.Clear;
  GameStep.Skin := Game.Skin;
  GameStep.Score := 0;
  for I := 0 to Length(InitialTiles) - 1 do
    GameStep.Board.Tiles[InitialTiles[I].Pos.Y, InitialTiles[I].Pos.X].Value := InitialTiles[I].Value;
  for I := 0 to Step - 1 do
  with Moves[I] do begin
    GameStep.MoveAll(Direction, False);
    if GameStep.Board.Tiles[NewItemPos.Y, NewItemPos.X].Value = 0 then
      GameStep.Board.Tiles[NewItemPos.Y, NewItemPos.X].Value := NewItemValue
      else raise Exception.Create(STileShouldBeEmpty);
  end;
end;

procedure THistory.Clear;
begin
  Moves.Clear;
  SetLength(InitialTiles, 0);
end;

constructor THistory.Create;
begin
  Moves := THistoryMoves.Create;
end;

destructor THistory.Destroy;
begin
  FreeAndNil(Moves);
  inherited Destroy;
end;

procedure THistory.SaveToRegistry(Reg: TRegistryEx; RegContext: TRegistryContext);
var
  I: Integer;
begin
  with Reg do begin
    CurrentContext := TRegistryContext.Create(RegContext.RootKey, RegContext.Key + '\InitialTilesPos');
    WriteInteger('Count', Length(InitialTiles));
    for I := 0 to Length(InitialTiles) - 1 do begin
      WriteInteger('X' + IntToStr(I), InitialTiles[I].Pos.X);
      WriteInteger('Y' + IntToStr(I), InitialTiles[I].Pos.Y);
      WriteInteger('Value' + IntToStr(I), InitialTiles[I].Value);
    end;
    Moves.SaveToRegistry(Reg, RegContext);
  end;
end;

procedure THistory.LoadFromRegistry(Reg: TRegistryEx; RegContext: TRegistryContext);
var
  I: Integer;
begin
  with Reg do begin
    CurrentContext := TRegistryContext.Create(RegContext.RootKey, RegContext.Key + '\InitialTilesPos');
    SetLength(InitialTiles, ReadIntegerWithDefault('Count', 0));
    for I := 0 to Length(InitialTiles) - 1 do begin
      InitialTiles[I].Pos := Point(ReadIntegerWithDefault('X' + IntToStr(I), 0),
        ReadIntegerWithDefault('Y' + IntToStr(I), 0));
      InitialTiles[I].Value := ReadIntegerWithDefault('Value' + IntToStr(I), 0);
    end;
  end;
  Moves.LoadFromRegistry(Reg, RegContext);
end;

{ TArea }

function TArea.Increment: TPoint;
begin
  Result := Point(Sign(P2.X - P1.X), Sign(P2.Y - P1.Y));
  if Result.X = 0 then Result.X := 1;
  if Result.Y = 0 then Result.Y := 1;
end;

class function TArea.Create(P1, P2: TPoint): TArea;
begin
  Result.P1 := P1;
  Result.P2 := P2;
end;

class function TArea.Create(X1, Y1, X2, Y2: Integer): TArea;
begin
  Result.P1 := Point(X1, Y1);
  Result.P2 := Point(X2, Y2);
end;

{ TBoard }

procedure TBoard.SetSize(AValue: TPoint);
var
  X, Y: Integer;
begin
  if FSize = AValue then Exit;
  for Y := 0 to FSize.Y - 1 do
    for X := 0 to FSize.X - 1 do
      Tiles[Y, X].Free;
  FSize := AValue;
  SetLength(Tiles, FSize.Y, FSize.X);
  for Y := 0 to FSize.Y - 1 do
    for X := 0 to FSize.X - 1 do begin
      Tiles[Y, X] := TTile.Create;
      Tiles[Y, X].Index := Point(X, Y);
    end;
end;

procedure TBoard.Assign(Source: TBoard);
var
  X, Y: Integer;
begin
  Size := Source.Size;
  for Y := 0 to Size.Y - 1 do
    for X := 0 to Size.X - 1 do
      Tiles[Y, X].Assign(Source.Tiles[Y, X]);
end;

procedure TBoard.GetEmptyTiles(EmptyTiles: TTiles);
var
  X, Y: Integer;
begin
  EmptyTiles.Clear;
  for Y := 0 to Size.Y - 1 do
    for X := 0 to Size.X - 1 do
      if Tiles[Y, X].Value = 0 then
        EmptyTiles.Add(Tiles[Y, X]);
end;

procedure TBoard.SaveToRegistry(Reg: TRegistryEx; RegContext: TRegistryContext);
var
  X, Y: Integer;
  Value: string;
begin
  with Reg do begin
    CurrentContext := RegContext;

    WriteInteger('SizeX', Size.X);
    WriteInteger('SizeY', Size.Y);
    Value := '';
    for Y := 0 to Size.Y - 1 do begin
      for X := 0 to Size.X - 1 do begin
        Value := Value + IntToStr(Tiles[Y, X].Value);
        if X < Size.X - 1 then Value := Value + ',';
      end;
      if Y < Size.Y - 1 then Value := Value + ';'
    end;
    WriteString('TileValues', Value);
  end;
end;

procedure TBoard.LoadFromRegistry(Reg: TRegistryEx; RegContext: TRegistryContext);
var
  X, Y: Integer;
  Items: TStringList;
  Lines: TStringList;
  Number: Integer;
begin
  with Reg do begin
    CurrentContext := RegContext;

    Size := Point(ReadIntegerWithDefault('SizeX', 4), ReadIntegerWithDefault('SizeY', 4));
    Items := TStringList.Create;
    Items.Delimiter := ',';
    Lines := TStringList.Create;
    Lines.Delimiter := ';';
    Lines.DelimitedText := ReadStringWithDefault('TileValues', '');
    for Y := 0 to Lines.Count - 1 do begin
      Items.DelimitedText := Lines[Y];
      for X := 0 to Items.Count - 1 do begin
        if TryStrToInt(Items[X], Number) and (X < Size.X) and (Y < Size.Y) then
          Tiles[Y, X].Value := Number;
      end;
    end;
    Lines.Free;
    Items.Free;
  end;
end;

destructor TBoard.Destroy;
begin
  Size := Point(0, 0);
  inherited Destroy;
end;

procedure TBoard.ClearMerged;
var
  X, Y: Integer;
begin
  for Y := 0 to Size.Y - 1 do
    for X := 0 to Size.X - 1 do
      Tiles[Y, X].Merged := False;
end;

function TBoard.GetValueSum: Integer;
var
  X, Y: Integer;
begin
  Result := 0;
  for Y := 0 to Size.Y - 1 do
    for X := 0 to Size.X - 1 do
      Inc(Result, Tiles[Y, X].Value);
end;

function TBoard.GetEmptyTilesCount: Integer;
var
  X, Y: Integer;
begin
  Result := 0;
  for Y := 0 to Size.Y - 1 do
    for X := 0 to Size.X - 1 do
      if Tiles[Y, X].Value = 0 then
        Inc(Result);
end;

function TBoard.GetHighestTileValue: Integer;
var
  X, Y: Integer;
begin
  Result := 0;
  for Y := 0 to Size.Y - 1 do
    for X := 0 to Size.X - 1 do
      if Result < Tiles[Y, X].Value then Result := Tiles[Y, X].Value;
end;

procedure TBoard.Clear;
var
  X, Y: Integer;
begin
  for Y := 0 to Size.Y - 1 do
    for X := 0 to Size.X - 1 do
      Tiles[Y, X].Value := 0;
end;


{ TTile }

procedure TTile.Assign(Source: TTile);
begin
  Value := Source.Value;
  Merged := Source.Merged;
end;

{ TGame }

procedure TGame.DoChange;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TGame.DoPaint;
begin
  if Assigned(FOnPaint) then FOnPaint(Self);
end;

procedure TGame.GameOver;
begin
  if Running and Assigned(FOnGameOver) then FOnGameOver(Self);
  Running := False;
end;

procedure TGame.SetSkin(AValue: TTileSkin);
begin
  if FSkin = AValue then Exit;
  FSkin := AValue;
  DoPaint;
end;

procedure TGame.Win;
begin
  if Assigned(FOnWin) then FOnWin(Self);
end;

function TGame.FillRandomTile: TTile;
var
  EmptyTiles: TTiles;
  NewValue: Integer;
begin
  Result := nil;
  EmptyTiles := TTiles.Create(False);
  Board.GetEmptyTiles(EmptyTiles);
  if EmptyTiles.Count > 0 then begin
    if Random < Value2Chance then NewValue := 2 else NewValue := 1;
    Result := EmptyTiles[Random(EmptyTiles.Count)];
    Result.Value := NewValue;
    Result.Action := taAppear;
  end;
  EmptyTiles.Free;
end;

function TGame.GetMoveArea(Direction: TMoveDirection): TArea;
begin
  case Direction of
    drNone: Result := TArea.Create(0, 0, 0, 0);
    drLeft: Result := TArea.Create(1, 0, Board.Size.X - 1, Board.Size.Y - 1);
    drUp: Result := TArea.Create(0, 1, Board.Size.X - 1, Board.Size.Y - 1);
    drRight: Result := TArea.Create(Board.Size.X - 2, 0, 0, Board.Size.Y - 1);
    drDown: Result := TArea.Create(0, Board.Size.Y - 2, Board.Size.X - 1, 0);
  end;
end;

function TGame.CanMove: Boolean;
begin
  Result := CanMoveDirection(drLeft) or CanMoveDirection(drRight) or
    CanMoveDirection(drUp) or CanMoveDirection(drDown);
end;

procedure TGame.Assign(Source: TGame);
begin
  Board.Assign(Source.Board);
  FBoardUndo.Assign(Source.FBoardUndo);
  FCanUndo := Source.FCanUndo;
  TopScore := Source.TopScore;
  AnimationDuration := Source.AnimationDuration;
  WinTileValue := Source.WinTileValue;
  UndoEnabled := Source.UndoEnabled;
  FScore := Source.FScore;
  FRunning := Source.FRunning;
  Skin := Source.Skin;
end;

procedure TGame.New;
var
  I: Integer;
  Tile: TTile;
begin
  FCanUndo := False;
  Board.Clear;
  Score := 0;
  Running := True;
  History.Clear;
  if RecordHistory then begin
    for I := 0 to InitialTileCount - 1 do begin
      SetLength(History.InitialTiles, Length(History.InitialTiles) + 1);
      Tile := FillRandomTile;
      History.InitialTiles[Length(History.InitialTiles) - 1].Pos := Tile.Index;
      History.InitialTiles[Length(History.InitialTiles) - 1].Value := Tile.Value;
    end;
  end else begin
    for I := 0 to InitialTileCount - 1 do
      FillRandomTile;
  end;
  AnimateTiles;
  DoChange;
  DoPaint;
end;

procedure TGame.Render(Canvas: TCanvas; CanvasSize: TPoint);
var
  X, Y: Integer;
  TileSize: TPoint;
  ValueStr: string;
  Frame: TRect;
  TileRect: TRect;
  TopBarHeight: Integer;
  TileMargin: Integer;
  TileCenter: TPoint;
  S: TPoint;
  MetaCanvas: TMetaCanvas;
begin
  MetaCanvas := TMetaCanvas.Create;
  MetaCanvas.Size := Point(Canvas.Width, Canvas.Height);

  TopBarHeight := ScaleY(24, 96);
  MetaCanvas.Brush.Style := bsSolid;
  MetaCanvas.Brush.Color := Core.ThemeManager1.Theme.ColorControl;
  MetaCanvas.FillRect(0, 0, MetaCanvas.Width, MetaCanvas.Height);

  ValueStr := SScore + ': ' + IntToStr(Score);
  MetaCanvas.Brush.Style := bsClear;
  MetaCanvas.Font.Color := Core.ThemeManager1.Theme.ColorControlText;
  MetaCanvas.Font.Height := Trunc(TopBarHeight * 0.7);
  MetaCanvas.TextOut(ScaleY(16, 96), (TopBarHeight - MetaCanvas.TextHeight(ValueStr)) div 2, ValueStr);

  ValueStr := STopScore + ': ' + IntToStr(TopScore);
  MetaCanvas.Font.Color := Core.ThemeManager1.Theme.ColorControlText;
  MetaCanvas.Font.Height := Trunc(TopBarHeight * 0.7);
  MetaCanvas.TextOut(ScaleY(136, 96), (TopBarHeight - MetaCanvas.TextHeight(ValueStr)) div 2, ValueStr);

  // Form.Canvas.Width and Form.Canvas.Height is not working correctly under Windows.
  // So dimensions are provided by CanvasSize parameter.
  Frame := Rect(2, TopBarHeight, CanvasSize.X - 2, CanvasSize.Y - 2);
  TileSize := Point(Frame.Width div Board.Size.X, Frame.Height div Board.Size.Y);
  if TileSize.X < TileSize.Y then TileSize.Y := TileSize.X;
  if TileSize.Y < TileSize.X then TileSize.X := TileSize.Y;
  Frame := Rect(Frame.Width div 2 - (Board.Size.X * TileSize.X) div 2,
    Frame.Top + Frame.Height div 2 - (Board.Size.Y * TileSize.Y) div 2,
    Frame.Width div 2 + (Board.Size.X * TileSize.X) div 2,
    Frame.Top + Frame.Height div 2 + (Board.Size.Y * TileSize.Y) div 2);

  TileMargin := Round(Frame.Width / Board.Size.X * 0.03);

  MetaCanvas.Brush.Style := bsSolid;
  MetaCanvas.Brush.Color := clGray;
  MetaCanvas.Pen.Style := psClear;
  MetaCanvas.RoundRect(Frame, ScaleX(Frame.Width div (20 * Board.Size.X), 96),
    ScaleY(Frame.Height div (20 * Board.Size.Y), 96));

  Frame := Rect(Frame.Left + TileMargin, Frame.Top + TileMargin,
    Frame.Right - TileMargin, Frame.Bottom - TileMargin);
  TileSize := Point(Frame.Width div Board.Size.X, Frame.Height div Board.Size.Y);

  MetaCanvas.Font.Color := clBlack;

  // Draw static tiles
  for Y := 0 to Board.Size.Y - 1 do
    for X := 0 to Board.Size.X - 1 do begin
      if (Board.Tiles[Y, X].Action <> taNone) then MetaCanvas.Brush.Color := GetTileColor(0)
        else MetaCanvas.Brush.Color := GetTileColor(Board.Tiles[Y, X].Value);
      MetaCanvas.Brush.Style := bsSolid;
      TileRect := Bounds(
        Frame.Left + X * TileSize.X + TileMargin,
        Frame.Top + Y * TileSize.Y + TileMargin,
        TileSize.X - 2 * TileMargin, TileSize.Y - 2 * TileMargin);
      RenderTile(MetaCanvas, Board.Tiles[Y, X], TileRect, Board.Tiles[Y, X].Action = taNone);
    end;

  // Draw moving tiles
  for Y := 0 to Board.Size.Y - 1 do
    for X := 0 to Board.Size.X - 1 do
    if Board.Tiles[Y, X].Action = taMove then begin
      MetaCanvas.Brush.Color := GetTileColor(Board.Tiles[Y, X].Value);
      MetaCanvas.Brush.Style := bsSolid;
      TileRect := Bounds(
        Frame.Left + X * TileSize.X + Trunc(Board.Tiles[Y, X].Shift.X / 100 * TileSize.X + TileMargin),
        Frame.Top + Y * TileSize.Y + Trunc(Board.Tiles[Y, X].Shift.Y / 100 * TileSize.Y + TileMargin),
        TileSize.X - 2 * TileMargin, TileSize.Y - 2 * TileMargin);
      RenderTile(MetaCanvas, Board.Tiles[Y, X], TileRect, True);
    end;

  // Draw appearing tiles
  for Y := 0 to Board.Size.Y - 1 do
    for X := 0 to Board.Size.X - 1 do
    if Board.Tiles[Y, X].Action = taAppear then begin
      MetaCanvas.Brush.Color := GetTileColor(Board.Tiles[Y, X].Value);
      MetaCanvas.Brush.Style := bsSolid;
      TileRect := Bounds(
        Frame.Left + X * TileSize.X + TileMargin,
        Frame.Top + Y * TileSize.Y + TileMargin,
        TileSize.X - 2 * TileMargin,
        TileSize.Y - 2 * TileMargin);
      TileCenter := TileRect.CenterPoint;
      S := Point(
        Trunc(Board.Tiles[Y, X].Shift.X / 100 * (TileSize.X - TileMargin)),
        Trunc(Board.Tiles[Y, X].Shift.Y / 100 * (TileSize.Y - TileMargin))
      );
      TileRect := Rect(TileCenter.X - S.X div 2, TileCenter.Y - S.Y div 2,
        TileCenter.X + S.X div 2, TileCenter.Y + S.Y div 2);
      RenderTile(MetaCanvas, Board.Tiles[Y, X], TileRect, True);
    end;

  // Draw merging tiles
  for Y := 0 to Board.Size.Y - 1 do
    for X := 0 to Board.Size.X - 1 do
    if Board.Tiles[Y, X].Action = taMerge then begin
      MetaCanvas.Brush.Color := GetTileColor(Board.Tiles[Y, X].Value);
      MetaCanvas.Brush.Style := bsSolid;
      TileRect := Bounds(
        Frame.Left + X * TileSize.X + TileMargin,
        Frame.Top + Y * TileSize.Y + TileMargin,
        TileSize.X - 2 * TileMargin,
        TileSize.Y - 2 * TileMargin);
      S := Point(
        Trunc((50 - Abs(Board.Tiles[Y, X].Shift.X - 50)) / 50 * TileMargin),
        Trunc((50 - Abs(Board.Tiles[Y, X].Shift.Y - 50)) / 50 * TileMargin)
      );
      TileRect := Rect(TileRect.Left - S.X, TileRect.Top - S.Y,
        TileRect.Right + S.X, TileRect.Bottom + S.Y);
      RenderTile(MetaCanvas, Board.Tiles[Y, X], TileRect, True);
    end;

  MetaCanvas.DrawTo(Canvas);
  MetaCanvas.Free;
end;

procedure TGame.MoveAll(Direction: TMoveDirection; Animation: Boolean);
var
  P: TPoint;
  PNew: TPoint;
  I: Integer;
  Area: TArea;
  DstTile: TTile;
  SrcTile: TTile;
  TileMoved: Boolean;
begin
  if Animation then begin
    MoveAllAnimate(Direction);
    Exit;
  end;
  if Direction = drNone then Exit;
  if not CanMoveDirection(Direction) then Exit;
  FMoving := True;
  FBoardUndo.Assign(Board);
  FCanUndo := True;
  Area := GetMoveArea(Direction);
  Board.ClearMerged;
  for I := 0 to Max(Board.Size.X, Board.Size.Y) - 1 do begin
    TileMoved := False;
    P := Area.P1;
    while P.Y <> Area.P2.Y + Area.Increment.Y do begin
      P.X := Area.P1.X;
      while P.X <> Area.P2.X + Area.Increment.X do begin
        PNew := P + DirectionDiff[Direction];
        if IsValidPos(PNew) then begin
          SrcTile := Board.Tiles[P.Y, P.X];
          DstTile := Board.Tiles[PNew.Y, PNew.X];
          if SrcTile.Value <> 0 then begin
            if DstTile.Value = 0 then begin
              DstTile.Value := SrcTile.Value;
              DstTile.Merged := SrcTile.Merged;
              SrcTile.Value := 0;
              SrcTile.Merged := False;
              TileMoved := True;
            end else
            if (not SrcTile.Merged) and (not DstTile.Merged) and
            CanMergeTile(DstTile.Value, SrcTile.Value) then begin
              DstTile.Value := MergeTile(DstTile.Value, SrcTile.Value);
              DstTile.Merged := True;
              SrcTile.Value := 0;
              SrcTile.Merged := False;
              Score := Score + GetTileSkinScore(SrcTile.Value);
              TileMoved := True;
            end;
          end;
        end;
        Inc(P.X, Area.Increment.X);
      end;
      Inc(P.Y, Area.Increment.Y);
    end;
    if not TileMoved then Break;
  end;
  DoPaint;
  FMoving := False;
end;

procedure TGame.RenderTile(Canvas: TCanvas; Tile: TTile; TileRect: TRect; WithText: Boolean);
var
  ValueStr: string;
  TextSize: TSize;
begin
  Canvas.Pen.Style := psClear;
  Canvas.RoundRect(TileRect, ScaleX(TileRect.Width div 20, 96), ScaleY(TileRect.Height div 20, 96));
  if WithText and (Tile.Value <> 0) then begin
    ValueStr := GetTileSkinValue(Tile.Value);
    Canvas.Brush.Style := bsClear;
    Canvas.Font.Height := Trunc(TileRect.Height * 0.7);
    TextSize := Canvas.TextExtent(ValueStr);
    if TextSize.Width > TileRect.Width then
      Canvas.Font.Height := Trunc(Canvas.Font.Height / TextSize.Width * TileRect.Width);
    TextSize := Canvas.TextExtent(ValueStr);
    Canvas.TextOut(TileRect.Left + TileRect.Width div 2 - TextSize.Width div 2,
      TileRect.Top + TileRect.Height div 2 - TextSize.Height div 2, ValueStr);
  end;
end;

function TGame.CanUndo: Boolean;
begin
  Result := UndoEnabled and FCanUndo;
end;

procedure TGame.Undo;
begin
  if UndoEnabled and CanUndo then begin
    Board.Assign(FBoardUndo);
    FCanUndo := False;
    FRunning := CanMove;
    if RecordHistory then History.Moves.Delete(History.Moves.Count - 1);
    DoChange;
    DoPaint;
  end;
end;

function TGame.CanMergeDirection(Direction: TMoveDirection): Boolean;
var
  P: TPoint;
  PNew: TPoint;
  I: Integer;
  Area: TArea;
begin
  Result := False;
  if Direction = drNone then Exit;
  Area := GetMoveArea(Direction);
  for I := 0 to Max(Board.Size.X, Board.Size.Y) - 1 do begin
    P := Area.P1;
    while P.Y <> Area.P2.Y + Area.Increment.Y do begin
      P.X := Area.P1.X;
      while P.X <> Area.P2.X + Area.Increment.X do begin
        PNew := P + DirectionDiff[Direction];
        if IsValidPos(PNew) then begin
          if (Board.Tiles[PNew.Y, PNew.X].Value = 0) then begin
            Board.Tiles[PNew.Y, PNew.X].Value := Board.Tiles[P.Y, P.X].Value;
            Board.Tiles[P.Y, P.X].Value := 0;
          end else
          if (Board.Tiles[P.Y, P.X].Value <> 0) then begin
            if CanMergeTile(Board.Tiles[PNew.Y, PNew.X].Value, Board.Tiles[P.Y, P.X].Value) then begin
              Result := True;
              Break;
            end;
          end;
        end;
        Inc(P.X, Area.Increment.Y);
      end;
      if Result then Break;
      Inc(P.Y, Area.Increment.Y);
    end;
  end;
end;

function TGame.CanMoveDirection(Direction: TMoveDirection): Boolean;
var
  P: TPoint;
  PNew: TPoint;
  Area: TArea;
begin
  Result := False;
  if Direction = drNone then Exit;
  Area := GetMoveArea(Direction);
  P := Area.P1;
  while P.Y <> Area.P2.Y + Area.Increment.Y do begin
    P.X := Area.P1.X;
    while P.X <> Area.P2.X + Area.Increment.X do begin
      PNew := P + DirectionDiff[Direction];
      if IsValidPos(PNew) then begin
        if (Board.Tiles[P.Y, P.X].Value <> 0) then begin
          if (Board.Tiles[PNew.Y, PNew.X].Value = 0) or
          CanMergeTile(Board.Tiles[PNew.Y, PNew.X].Value, Board.Tiles[P.Y, P.X].Value) then begin
            Result := True;
            Break;
          end;
        end;
      end;
      Inc(P.X, Area.Increment.X);
    end;
    if Result then Break;
    Inc(P.Y, Area.Increment.Y);
  end;
end;

procedure TGame.MoveAllAnimate(Direction: TMoveDirection);
var
  P: TPoint;
  PNew: TPoint;
  X, Y: Integer;
  I: Integer;
  StartTime: TDateTime;
  EndTime: TDateTime;
  Time: TDateTime;
  Part: Double;
  Area: TArea;
  TileMoved: Boolean;
begin
  if Direction = drNone then Exit;
  if not CanMoveDirection(Direction) then Exit;
  FMoving := True;
  FBoardUndo.Assign(Board);
  FCanUndo := True;
  Area := GetMoveArea(Direction);
  Board.ClearMerged;
  for I := 0 to Max(Board.Size.X, Board.Size.Y) - 1 do begin
    for Y := 0 to Board.Size.Y - 1 do
      for X := 0 to Board.Size.X - 1 do begin
        Board.Tiles[Y, X].NewValue := Board.Tiles[Y, X].Value;
        Board.Tiles[Y, X].Action := taNone;
      end;

    TileMoved := False;
    P := Area.P1;
    while P.Y <> Area.P2.Y + Area.Increment.Y do begin
      P.X := Area.P1.X;
      while P.X <> Area.P2.X + Area.Increment.X do begin
        PNew := P + DirectionDiff[Direction];
        if IsValidPos(PNew) then begin
          if (Board.Tiles[P.Y, P.X].NewValue <> 0) then begin
            if (Board.Tiles[PNew.Y, PNew.X].NewValue = 0) then begin
              Board.Tiles[P.Y, P.X].Action := taMove;
              Board.Tiles[PNew.Y, PNew.X].NewValue := Board.Tiles[P.Y, P.X].NewValue;
              Board.Tiles[PNew.Y, PNew.X].Merged := Board.Tiles[P.Y, P.X].Merged;
              Board.Tiles[P.Y, P.X].NewValue := 0;
              Board.Tiles[P.Y, P.X].Merged := False;
              TileMoved := True;
            end else
            if (not Board.Tiles[P.Y, P.X].Merged) and (not Board.Tiles[PNew.Y, PNew.X].Merged) and
            CanMergeTile(Board.Tiles[PNew.Y, PNew.X].NewValue, Board.Tiles[P.Y, P.X].NewValue) then begin
              Board.Tiles[P.Y, P.X].Action := taMove;
              Board.Tiles[PNew.Y, PNew.X].NewValue := MergeTile(Board.Tiles[PNew.Y, PNew.X].NewValue, Board.Tiles[P.Y, P.X].NewValue);
              Board.Tiles[PNew.Y, PNew.X].Merged := True;
              Board.Tiles[P.Y, P.X].NewValue := 0;
              Board.Tiles[P.Y, P.X].Merged := False;
              Score := Score + GetTileSkinScore(Board.Tiles[PNew.Y, PNew.X].NewValue);
              TileMoved := True;
            end;
          end;
        end;
        Inc(P.X, Area.Increment.X);
      end;
      Inc(P.Y, Area.Increment.Y);
    end;
    if not TileMoved then Break;

    // Animate tiles move
    StartTime := Now;
    EndTime := StartTime + AnimationDuration / 300 * OneSecond / Max(Board.Size.X, Board.Size.Y);
    if AnimationDuration > 0 then
    repeat
      Time := Now;
      Part := (Time - StartTime) / (EndTime - StartTime);
      if Part > 1 then Part := 1;
      for Y := 0 to Board.Size.Y - 1 do
        for X := 0 to Board.Size.X - 1 do begin
          if Board.Tiles[Y, X].Action = taMove then
            Board.Tiles[Y, X].Shift := Point(Trunc(Part * DirectionDiff[Direction].X * 100),
              Trunc(Part * DirectionDiff[Direction].Y * 100));
        end;
      DoPaint;
      //Application.ProcessMessages;
      Sleep(AnimationTick);
    until Time > EndTime;

    // Set final tiles values
    for Y := 0 to Board.Size.Y - 1 do
      for X := 0 to Board.Size.X - 1 do begin
        Board.Tiles[Y, X].Value := Board.Tiles[Y, X].NewValue;
      end;
  end;

  // Set final tiles values
  for Y := 0 to Board.Size.Y - 1 do
    for X := 0 to Board.Size.X - 1 do begin
      if Board.Tiles[Y, X].Merged then
        Board.Tiles[Y, X].Action := taMerge;
      Board.Tiles[Y, X].Shift := Point(0, 0);
      if Board.Tiles[Y, X].Action = taMove then begin
        Board.Tiles[Y, X].Action := taNone;
      end;
      Board.Tiles[Y, X].Value := Board.Tiles[Y, X].NewValue;
    end;
  DoPaint;
  FMoving := False;
end;

function TGame.CanMergeTile(Value1, Value2: Integer): Boolean;
begin
  Result := MergeTile(Value1, Value2) <> -1;
end;

function TGame.MergeTile(Value1, Value2: Integer): Integer;
begin
  if Value1 = Value2 then Result := Value1 + 1
  else Result := -1;
end;

procedure TGame.AnimateTiles;
var
  StartTime: TDateTime;
  EndTime: TDateTime;
  Time: TDateTime;
  Part: Double;
  X, Y: Integer;
begin
  FMoving := True;

  // Animate tiles move
  StartTime := Now;
  EndTime := StartTime + AnimationDuration / 300 * OneSecond / Max(Board.Size.X, Board.Size.Y);
  if AnimationDuration > 0 then
  repeat
    Time := Now;
    Part := (Time - StartTime) / (EndTime - StartTime);
    if Part > 1 then Part := 1;
    for Y := 0 to Board.Size.Y - 1 do
      for X := 0 to Board.Size.X - 1 do begin
        if Board.Tiles[Y, X].Action = taAppear then
          Board.Tiles[Y, X].Shift := Point(Trunc(Part * 100), Trunc(Part * 100));
        if Board.Tiles[Y, X].Action = taMerge then
          Board.Tiles[Y, X].Shift := Point(Trunc(Part * 100), Trunc(Part * 100));
      end;
    DoPaint;
    //Application.ProcessMessages;
    Sleep(AnimationTick);
  until Time > EndTime;

  for Y := 0 to Board.Size.Y - 1 do
    for X := 0 to Board.Size.X - 1 do
      if Board.Tiles[Y, X].Action <> taNone then begin
        Board.Tiles[Y, X].Action := taNone;
        Board.Tiles[Y, X].Shift := Point(0, 0);
      end;
  DoPaint;
  FMoving := False;
end;

function IntToStrRoman(Num: Integer): string;
const
  Nvals = 13;
  Vals: array [1..Nvals] of Word =
    (1, 4, 5, 9, 10, 40, 50, 90, 100, 400, 500, 900, 1000);
  Roms: array [1..Nvals] of string[2] =
    ('I', 'IV', 'V', 'IX', 'X', 'XL', 'L', 'XC', 'C', 'CD', 'D', 'CM', 'M');
var
  B: 1..Nvals;
begin
  Result := '';
  B := Nvals;
  while Num > 0 do
  begin
    while Vals[b] > Num do
      Dec(B);
    Dec(Num, Vals[B]);
    Result := Result + Roms[B];
  end;
end;

function IntToBin(Num: Integer): string;
begin
  Result := '';
  while Num > 0 do begin
    Result := IntToStr(Num mod 2) + Result;
    Num := Num shr 1;
  end;
end;

function TGame.GetTileSkinValue(Value: Integer): string;
begin
  case FSkin of
    tsLinear: Result := IntToStr(Value);
    tsPowerOfTwo: Result := IntToStr(1 shl Value);
    tsAlpha: Result := Chr(Ord('A') + Value - 1);
    tsRoman: Result := IntToStrRoman(Value);
    tsBinary: Result := IntToBin(Value);
    else Result := IntToStr(Value);
  end;
end;

function TGame.GetTileSkinScore(Value: Integer): Integer;
begin
  case FSkin of
    tsLinear: Result := 1 shl Value;
    tsPowerOfTwo: Result := 1 shl Value;
    tsAlpha: Result := 1 shl Value;
    tsRoman: Result := 1 shl Value;
    tsBinary: Result := 1 shl Value;
    else Result := 1 shl Value;
  end;
end;

procedure TGame.MoveAllAndUpdate(Direction: TMoveDirection; Animation: Boolean);
var
  HighestValue: Integer;
  HistoryMove: THistoryMove;
  NewTile: TTile;
  X, Y: Integer;
begin
  if CanMoveDirection(Direction) then begin
    HighestValue := Board.GetHighestTileValue;
    MoveAll(Direction, Animation);

    NewTile := FillRandomTile;
    if Animation then AnimateTiles else begin
      for Y := 0 to Board.Size.Y - 1 do
        for X := 0 to Board.Size.X - 1 do
          if Board.Tiles[Y, X].Action <> taNone then begin
            Board.Tiles[Y, X].Action := taNone;
            Board.Tiles[Y, X].Shift := Point(0, 0);
          end;
      DoPaint;
    end;

    if RecordHistory then begin
      HistoryMove := THistoryMove.Create;
      HistoryMove.Direction := Direction;
      HistoryMove.NewItemPos := NewTile.Index;
      HistoryMove.NewItemValue := NewTile.Value;
      History.Moves.Add(HistoryMove);
    end;

    if not CanMove and (Board.GetEmptyTilesCount = 0) then
      GameOver;
    if (HighestValue < WinTileValue) and
    (Board.GetHighestTileValue >= WinTileValue) then Win;
    DoChange;
  end;
end;

procedure TGame.MoveTile(SourceTile, TargetTile: TTile);
begin
  TargetTile.Value := SourceTile.Value;
  SourceTile.Value := 0;
  TargetTile.Merged := SourceTile.Merged;
  SourceTile.Merged := False;
end;

function TGame.IsValidPos(Pos: TPoint): Boolean;
begin
  Result := (Pos.X >= 0) and (Pos.X < Board.Size.X) and
    (Pos.Y >= 0) and (Pos.Y < Board.Size.Y);
end;

procedure TGame.SaveToRegistry(RegContext: TRegistryContext);
var
  Reg: TRegistryEx;
begin
  Reg := TRegistryEx.Create;
  with Reg do
  try
    CurrentContext := RegContext;

    WriteInteger('TopScore', TopScore);
    WriteInteger('AnimationDuration', AnimationDuration);
    WriteInteger('Score', Score);
    WriteBool('GameRunning', FRunning);
    WriteBool('CanUndo', FCanUndo);
    WriteBool('UndoEnabled', UndoEnabled);
    WriteBool('RecordHistory', RecordHistory);
    WriteInteger('Skin', Integer(Skin));
    FBoardUndo.SaveToRegistry(Reg, TRegistryContext.Create(RegContext.RootKey, RegContext.Key + '\BoardUndo'));
    Board.SaveToRegistry(Reg, TRegistryContext.Create(RegContext.RootKey, RegContext.Key + '\Board'));
    History.SaveToRegistry(Reg, TRegistryContext.Create(RegContext.RootKey, RegContext.Key + '\History'));
  finally
    Free;
  end;
end;

procedure TGame.LoadFromRegistry(RegContext: TRegistryContext);
var
  Reg: TRegistryEx;
begin
  Reg := TRegistryEx.Create;
  with Reg do
  try
    CurrentContext := RegContext;
    AnimationDuration := ReadIntegerWithDefault('AnimationDuration', 30);
    TopScore := ReadIntegerWithDefault('TopScore', 0);
    Score := ReadIntegerWithDefault('Score', 0);
    FRunning := ReadBoolWithDefault('GameRunning', False);
    FCanUndo := ReadBoolWithDefault('CanUndo', False);
    UndoEnabled := ReadBoolWithDefault('UndoEnabled', True);
    RecordHistory := ReadBoolWithDefault('RecordHistory', False);
    Skin := TTileSkin(ReadIntegerWithDefault('Skin', Integer(tsPowerOfTwo)));
    FBoardUndo.LoadFromRegistry(Reg, TRegistryContext.Create(RegContext.RootKey, RegContext.Key + '\BoardUndo'));
    Board.LoadFromRegistry(Reg, TRegistryContext.Create(RegContext.RootKey, RegContext.Key + '\Board'));
    History.LoadFromRegistry(Reg, TRegistryContext.Create(RegContext.RootKey, RegContext.Key + '\History'));
  finally
    Free;
  end;
  DoChange;
  DoPaint;
end;

constructor TGame.Create;
begin
  AnimationDuration := 30;
  AnimationTick := 10; // ms
  WinTileValue := 11; // 2^11 = 2048
  Board := TBoard.Create;
  FBoardUndo := TBoard.Create;
  History := THistory.Create;
  History.Game := Self;
  Value2Chance := 0.1;
end;

destructor TGame.Destroy;
begin
  FreeAndNil(History);
  FreeAndNil(FBoardUndo);
  FreeAndNil(Board);
  inherited;
end;

function TGame.GetTileColor(Value: Integer): TColor;
begin
  if Core.ThemeManager1.Theme.Name = 'Dark' then begin
    case Value of
      0: Result := $222629;
      1: Result := $dae4ee;
      2: Result := $c8e0ed;
      3: Result := $79b1f2;
      4: Result := $6395f5;
      5: Result := $5f7cf6;
      6: Result := $3b5ef6;
      7: Result := $72cfed;
      8: Result := $61cced;
      9: Result := $50c8ed;
      10: Result := $3fc5ed;
      11: Result := $2ec2ed;
      else Result := $323a3c;
    end;
  end else begin
    case Value of
      0: Result := $f2f6f9;
      1: Result := $dae4ee;
      2: Result := $c8e0ed;
      3: Result := $79b1f2;
      4: Result := $6395f5;
      5: Result := $5f7cf6;
      6: Result := $3b5ef6;
      7: Result := $72cfed;
      8: Result := $61cced;
      9: Result := $50c8ed;
      10: Result := $3fc5ed;
      11: Result := $2ec2ed;
      else Result := $323a3c;
    end;
  end;
end;

procedure TGame.SetRecordHistory(AValue: Boolean);
begin
  if FRecordHistory = AValue then Exit;
  FRecordHistory := AValue;
  if not FRecordHistory then History.Clear;
end;

procedure TGame.SetScore(AValue: Integer);
begin
  if FScore = AValue then Exit;
  FScore := AValue;
  if FScore > TopScore then TopScore := FScore;
end;

initialization
  Translate;

end.