source: tags/1.0.0/UGame.pas

unit UGame;

{$mode delphi}{$H+}

interface

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

type

  { TTile }

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

  TTiles = class(TFPGObjectList<TTile>)
  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 GetHighestTileValue: Integer;
    function GetEmptyTilesCount: Integer;
    procedure GetEmptyTiles(EmptyTiles: TTiles);
    procedure SaveToRegistry(RegContext: TRegistryContext);
    procedure LoadFromRegistry(RegContext: TRegistryContext);
    destructor Destroy; override;
    property Size: TPoint read FSize write SetSize;
  end;

  TDirection = (drLeft, drUp, drRight, drDown);

  { TGame }

  TGame = class
  private
    FMoving: Boolean;
    FOnChange: TNotifyEvent;
    FRunning: Boolean;
    FScore: Integer;
    FCanUndo: Boolean;
    FBoardUndo: TBoard;
    function CanMoveDirection(Direction: TDirection): Boolean;
    function GetTileColor(Value: Integer): TColor;
    procedure SetScore(AValue: Integer);
    procedure DoChange;
    procedure RenderTile(Canvas: TCanvas; Tile: TTile; TileRect: TRect);
    procedure GameOver;
    procedure Win;
    function FillRandomTile: Integer;
  public
    Board: TBoard;
    TopScore: Integer;
    AnimationDuration: Integer;
    WinScore: Integer;
    function CanUndo: Boolean;
    procedure Undo;
    function CanMove: Boolean;
    procedure Assign(Source: TGame);
    procedure New;
    procedure Render(Canvas: TCanvas; CanvasSize: TPoint);
    function MoveAll(Direction: TDirection): Integer;
    procedure MoveTile(SourceTile, TargetTile: TTile);
    function IsValidPos(Pos: TPoint): Boolean;
    procedure SaveToRegistry(RegContext: TRegistryContext);
    procedure LoadFromRegistry(RegContext: TRegistryContext);
    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 Moving: Boolean read FMoving;
  end;

const
  DirectionDiff: array[TDirection] of TPoint = (
    (X: -1; Y: 0), (X: 0; Y: -1), (X: 1; Y: 0), (X: 0; Y: 1)
  );

resourcestring
  SGameOverCaption = 'Lost';
  SGameOverMessage = 'Game over!';
  SWinCaption = 'Win';
  SWinMessage = 'You reached %d and won! You can continue to play to get higher score.';
  SScore = 'Score';
  STopScore = 'Top score';

implementation

{ 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
      Tiles[Y, X] := TTile.Create;
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(RegContext: TRegistryContext);
var
  X, Y: Integer;
  Value: string;
begin
  with TRegistryEx.Create do
  try
    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);
  finally
    Free;
  end;
end;

procedure TBoard.LoadFromRegistry(RegContext: TRegistryContext);
var
  X, Y: Integer;
  Items: TStringList;
  Lines: TStringList;
  Number: Integer;
begin
  with TRegistryEx.Create do
  try
    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;
  finally
    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.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.GameOver;
begin
  if Running then MessageDlg(SGameOverCaption, SGameOverMessage, mtInformation, [mbOK], 0);
  Running := False;
end;

procedure TGame.Win;
begin
  MessageDlg(SWinCaption, Format(SWinMessage, [WinScore]), mtInformation, [mbOk], 0);
end;

function TGame.FillRandomTile: Integer;
var
  EmptyTiles: TTiles;
begin
  Result := 0;
  EmptyTiles := TTiles.Create(False);
  Board.GetEmptyTiles(EmptyTiles);
  if EmptyTiles.Count > 0 then begin
    EmptyTiles[Random(EmptyTiles.Count)].Value := 2;
    Result := 1;
  end;
  EmptyTiles.Free;
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
  FScore := Source.FScore;
  TopScore := Source.TopScore;
  AnimationDuration := Source.AnimationDuration;
  Board.Assign(Source.Board);
end;

procedure TGame.New;
var
  I: Integer;
begin
  FCanUndo := False;
  Board.Clear;
  Score := 0;
  Running := True;
  for I := 0 to 1 do FillRandomTile;
  DoChange;
end;

procedure TGame.Render(Canvas: TCanvas; CanvasSize: TPoint);
var
  X, Y: Integer;
  TileSize: TPoint;
  ValueStr: string;
  Frame: TRect;
  TileRect: TRect;
  TopBarHeight: Integer;
  TileMargin: Integer;
begin
  TopBarHeight := ScaleY(24, 96);
  TileMargin := Round(CanvasSize.X / Board.Size.X * 0.02);
  Canvas.Brush.Style := bsSolid;
  Canvas.Brush.Color := clBlack;
  Canvas.FillRect(0, 0, Canvas.Width, Canvas.Height);

  ValueStr := SScore + ': ' + IntToStr(Score);
  Canvas.Font.Color := clWhite;
  Canvas.Font.Height := Trunc(TopBarHeight * 0.7);
  Canvas.TextOut(ScaleY(16, 96), (TopBarHeight - Canvas.TextHeight(ValueStr)) div 2, ValueStr);

  ValueStr := STopScore + ': ' + IntToStr(TopScore);
  Canvas.Font.Color := clWhite;
  Canvas.Font.Height := Trunc(TopBarHeight * 0.7);
  Canvas.TextOut(ScaleY(136, 96), (TopBarHeight - Canvas.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);

  Canvas.Brush.Style := bsSolid;
  Canvas.Brush.Color := clGray;
  Canvas.FillRect(Frame);

  Canvas.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].Moving then Canvas.Brush.Color := GetTileColor(0)
        else Canvas.Brush.Color := GetTileColor(Board.Tiles[Y, X].Value);
      Canvas.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(Canvas, Board.Tiles[Y, X], TileRect);
    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].Moving then begin
      Canvas.Brush.Color := GetTileColor(Board.Tiles[Y, X].Value);
      Canvas.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(Canvas, Board.Tiles[Y, X], TileRect);
    end;
end;

procedure TGame.RenderTile(Canvas: TCanvas; Tile: TTile; TileRect: TRect);
var
  ValueStr: string;
  TextSize: TSize;
begin
  Canvas.FillRect(TileRect);
  if Tile.Value <> 0 then begin
    ValueStr := IntToStr(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 := FCanUndo;
end;

procedure TGame.Undo;
begin
  if CanUndo then begin
    Board.Assign(FBoardUndo);
    FCanUndo := False;
    FRunning := CanMove;
    DoChange;
  end;
end;

function TGame.CanMoveDirection(Direction: TDirection): Boolean;
var
  StartPoint: TPoint;
  AreaSize: TPoint;
  Increment: TPoint;
  P: TPoint;
  PNew: TPoint;
  PI: TPoint;
begin
  Result := False;
  case Direction of
    drLeft: begin
      StartPoint := Point(1, 0);
      AreaSize := Point(Board.Size.X - 2, Board.Size.Y - 1);
      Increment := Point(1, 1);
    end;
    drUp: begin
      StartPoint := Point(0, 1);
      AreaSize := Point(Board.Size.X - 1, Board.Size.Y - 2);
      Increment := Point(1, 1);
    end;
    drRight: begin
      StartPoint := Point(Board.Size.X - 2, 0);
      AreaSize := Point(Board.Size.X - 2, Board.Size.Y - 1);
      Increment := Point(-1, 1);
    end;
    drDown: begin
      StartPoint := Point(0, Board.Size.Y - 2);
      AreaSize := Point(Board.Size.X - 1, Board.Size.Y - 2);
      Increment := Point(1, -1);
    end;
  end;

  PI.Y := 0;
  while PI.Y <= AreaSize.Y do begin
    PI.X := 0;
    while PI.X <= AreaSize.X do begin
      P := Point(StartPoint.X + PI.X * Increment.X, StartPoint.Y + PI.Y * Increment.Y);
      PNew.X := P.X + DirectionDiff[Direction].X;
      PNew.Y := P.Y + DirectionDiff[Direction].Y;
      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
          (Board.Tiles[PNew.Y, PNew.X].Value = Board.Tiles[P.Y, P.X].Value) then begin
            Result := True;
            Break;
          end;
        end;
        P.X := PNew.X;
        P.Y := PNew.Y;
        PNew.X := P.X + DirectionDiff[Direction].X;
        PNew.Y := P.Y + DirectionDiff[Direction].Y;
      end;
      Inc(PI.X);
    end;
    if Result then Break;
    Inc(PI.Y);
  end;
end;

function TGame.MoveAll(Direction: TDirection): Integer;
var
  StartPoint: TPoint;
  AreaSize: TPoint;
  Increment: TPoint;
  MoveDirection: TPoint;
  P: TPoint;
  PNew: TPoint;
  PI: TPoint;
  MovedCount: Integer;
  X, Y: Integer;
  I: Integer;
  StartTime: TDateTime;
  EndTime: TDateTime;
  Time: TDateTime;
  Part: Double;
  HighestValue: Integer;
begin
  FMoving := True;
  HighestValue := Board.GetHighestTileValue;
  FBoardUndo.Assign(Board);
  FCanUndo := True;
  //Diff := DirectionDiff[Direction];
  case Direction of
    drLeft: begin
      StartPoint := Point(1, 0);
      AreaSize := Point(Board.Size.X - 2, Board.Size.Y - 1);
      Increment := Point(1, 1);
      MoveDirection := Point(-1, 0);
    end;
    drUp: begin
      StartPoint := Point(0, 1);
      AreaSize := Point(Board.Size.X - 1, Board.Size.Y - 2);
      Increment := Point(1, 1);
      MoveDirection := Point(0, -1);
    end;
    drRight: begin
      StartPoint := Point(Board.Size.X - 2, 0);
      AreaSize := Point(Board.Size.X - 2, Board.Size.Y - 1);
      Increment := Point(-1, 1);
      MoveDirection := Point(1, 0);
    end;
    drDown: begin
      StartPoint := Point(0, Board.Size.Y - 2);
      AreaSize := Point(Board.Size.X - 1, Board.Size.Y - 2);
      Increment := Point(1, -1);
      MoveDirection := Point(0, 1);
    end;
  end;
  MovedCount := 0;
  Board.ClearMerged;
  for I := 0 to Max(Board.Size.X, Board.Size.Y) - 1 do begin
    PI.Y := 0;
    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].Moving := False;
      end;

    while PI.Y <= AreaSize.Y do begin
      PI.X := 0;
      while PI.X <= AreaSize.X do begin
        P := Point(StartPoint.X + PI.X * Increment.X, StartPoint.Y + PI.Y * Increment.Y);
        PNew.X := P.X + DirectionDiff[Direction].X;
        PNew.Y := P.Y + DirectionDiff[Direction].Y;
        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].Moving := True;
              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;
              Inc(MovedCount);
            end else
            if (not Board.Tiles[P.Y, P.X].Merged) and (not Board.Tiles[PNew.Y, PNew.X].Merged) and
            (Board.Tiles[PNew.Y, PNew.X].NewValue = Board.Tiles[P.Y, P.X].NewValue) then begin
              Board.Tiles[P.Y, P.X].Moving := True;
              Board.Tiles[PNew.Y, PNew.X].NewValue := 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;
              Inc(MovedCount);
              Score := Score + Board.Tiles[PNew.Y, PNew.X].NewValue;
            end;
          end;
          P.X := PNew.X;
          P.Y := PNew.Y;
          PNew.X := P.X + DirectionDiff[Direction].X;
          PNew.Y := P.Y + DirectionDiff[Direction].Y;
        end;
        Inc(PI.X);
      end;
      Inc(PI.Y);
    end;

    // 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].Moving then
            Board.Tiles[Y, X].Shift := Point(Trunc(Part * MoveDirection.X * 100),
              Trunc(Part * MoveDirection.Y * 100));
        end;
      DoChange;
      Application.ProcessMessages;
      Sleep(1);
    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].Shift := Point(0, 0);
        Board.Tiles[Y, X].Moving := False;
        Board.Tiles[Y, X].Value := Board.Tiles[Y, X].NewValue;
      end;
    DoChange;
  end;
  Result := MovedCount;

  // Update state after move
  if MovedCount > 0 then FillRandomTile;
  if not CanMove and (Board.GetEmptyTilesCount = 0) then
    GameOver;
  if (HighestValue < WinScore) and
  (Board.GetHighestTileValue >= WinScore) then Win;

  FMoving := False;
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);
begin
  with TRegistryEx.Create do
  try
    CurrentContext := RegContext;

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

procedure TGame.LoadFromRegistry(RegContext: TRegistryContext);
begin
  with TRegistryEx.Create do
  try
    CurrentContext := RegContext;
    AnimationDuration := ReadIntegerWithDefault('AnimationDuration', 30);
    TopScore := ReadIntegerWithDefault('TopScore', 0);
    Score := ReadIntegerWithDefault('Score', 0);
    FRunning := ReadBoolWithDefault('GameRunning', False);
    FCanUndo := ReadBoolWithDefault('CanUndo', False);
  finally
    Free;
  end;
  FBoardUndo.LoadFromRegistry(TRegistryContext.Create(RegContext.RootKey, RegContext.Key + '\BoardUndo'));
  Board.LoadFromRegistry(TRegistryContext.Create(RegContext.RootKey, RegContext.Key + '\Board'));
  DoChange;
end;

constructor TGame.Create;
begin
  AnimationDuration := 30;
  WinScore := 2048;
  Board := TBoard.Create;
  FBoardUndo := TBoard.Create;
end;

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

function TGame.GetTileColor(Value: Integer): TColor;
begin
  case Value of
    0: Result := $f2f6f9;
    2: Result := $dae4ee;
    4: Result := $c8e0ed;
    8: Result := $79b1f2;
    16: Result := $6395f5;
    32: Result := $5f7cf6;
    64: Result := $3b5ef6;
    128: Result := $72cfed;
    256: Result := $61cced;
    512: Result := $50c8ed;
    1024: Result := $3fc5ed;
    2048: Result := $2ec2ed;
    else Result := $323a3c;
  end;
end;

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

end.