unit Tetris;

interface

uses
  Classes, SysUtils, Game, Scene, Graphics, Generics.Collections, Math, DateUtils;

type

  { TSceneMain }

  TSceneMain = class(TScene)
  public
    Game: TGame;
    procedure Draw; override;
  end;

  { TBoard }

  TBoard = class
  private
    FSize: TPoint;
    procedure SetSize(AValue: TPoint);
  public
    Cells: array of array of TColor;
    procedure Clear;
    property Size: TPoint read FSize write SetSize;
  end;

  { TShape }

  TShape = class
    Color: TColor;
    Body: array of array of Byte;
    procedure AddRotation(ABody: array of Byte);
  end;

  { TShapes }

  TShapes = class(TObjecTList<TShape>)
    function AddNew(Body: array of Byte; Color: TColor): TShape;
  end;

  { TTetris }

  TTetris = class(TGame)
  private
    Shapes: TShapes;
    procedure PlaceShapeOnBoard(Pos: TPoint; Rotation: Byte);
    procedure ClearShapeOnBoard(Pos: TPoint; Rotation: Byte);
    function CheckShapeCollision(Pos: TPoint; Rotation: Byte): Boolean;
    procedure MoveShape(Pos: TPoint; Rotation: Byte);
    procedure MoveDown;
    procedure RemoveFullRows;
  public
    Winner: string;
    Board: TBoard;
    LastShapeRotation: Byte;
    LastShapePos: TPoint;
    ShapeRotation: Byte;
    ShapePos: TPoint;
    CurrentShape: TShape;
    NextShape: TShape;
    Score: Integer;
    MoveDownTime: TDateTime;
    KeyDownTime: TDateTime;
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
    procedure Tick; override;
    procedure Run; override;
    constructor Create; override;
    destructor Destroy; override;
  end;


implementation

resourcestring
  STetris = 'Tetris';

{ TSceneMain }

procedure TSceneMain.Draw;
var
  TetrisGame: TTetris;
  X, Y: Integer;
  CellColor: TColor;
  BoardRect: TRect;
  CellSize: TPoint;
begin
  Clear;
  TetrisGame := TTetris(Game);

  with Canvas do begin
    BoardRect := GetBoardRect(TetrisGame.Board.Size);
    CellSize := Point(BoardRect.Width div TetrisGame.Board.Size.X,
      BoardRect.Height div TetrisGame.Board.Size.Y);

    Brush.Color := clBlack;
    Pen.Color := clWhite;
    FillRect(BoardRect);

    Brush.Style := bsSolid;

    for Y := 0 to TetrisGame.Board.Size.Y - 1 do
      for X := 0 to TetrisGame.Board.Size.X - 1 do
        if TetrisGame.Board.Cells[Y, X] <> clBlack then begin
          CellColor := TetrisGame.Board.Cells[Y, X];
          Pen.Color := CellColor;
          Brush.Color := CellColor;
          FillRect(BoardRect.Left + X * CellSize.X,
            BoardRect.Top + Y * CellSize.Y,
            BoardRect.Left + (X + 1) * CellSize.X,
            BoardRect.Top + (Y + 1) * CellSize.Y);
        end;

    Brush.Style := bsClear;
    TextOut(10, 10, IntToStr(TetrisGame.Score));
  end;
end;

{ TBoard }

procedure TBoard.SetSize(AValue: TPoint);
begin
  if FSize = AValue then Exit;
  FSize := AValue;
  SetLength(Cells, AValue.Y, AValue.X);
end;

procedure TBoard.Clear;
var
  X, Y: Integer;
begin
  for Y := 0 to FSize.Y - 1 do
    for X := 0 to FSize.X - 1 do
      Cells[Y, X] := clBlack;
end;

{ TShape }

procedure TShape.AddRotation(ABody: array of Byte);
var
  I: Integer;
begin
  SetLength(Body, Length(Body) + 1);
  SetLength(Body[Length(Body) - 1], Length(ABody));
  for I := 0 to Length(ABody) - 1 do
    Body[Length(Body) - 1, I] := ABody[I];
end;

{ TShapes }

function TShapes.AddNew(Body: array of Byte; Color: TColor): TShape;
var
  I: Integer;
begin
  Result := TShape.Create;
  Result.Color := Color;
  SetLength(Result.Body, 1);
  SetLength(Result.Body[0], Length(Body));
  for I := 0 to Length(Body) - 1 do
    Result.Body[0, I] := Body[I];
  Add(Result);
end;

{ TTetris }

procedure TTetris.PlaceShapeOnBoard(Pos: TPoint; Rotation: Byte);
var
  Y, X: Integer;
begin
  for Y := 0 to Length(CurrentShape.Body[Rotation]) - 1 do begin
    for X := 0 to 3 do
      if ((CurrentShape.Body[Rotation, Y] shr X) and 1) = 1 then
        if ((Pos.Y + Y) < Board.Size.Y) and ((Pos.X + X) < Board.Size.X) and
        ((Pos.Y + Y) >= 0) and ((Pos.X + X) >= 0) then
          Board.Cells[Pos.Y + Y, Pos.X + X] := CurrentShape.Color;
  end;
end;

procedure TTetris.ClearShapeOnBoard(Pos: TPoint; Rotation: Byte);
var
  Y, X: Integer;
begin
  for Y := 0 to Length(CurrentShape.Body[Rotation]) - 1 do begin
    for X := 0 to 3 do
      if ((CurrentShape.Body[Rotation, Y] shr X) and 1) = 1 then
        if ((Pos.Y + Y) < Board.Size.Y) and ((Pos.X + X) < Board.Size.X) and
        ((Pos.Y + Y) >= 0) and ((Pos.X + X) >= 0) then
          Board.Cells[Pos.Y + Y, Pos.X + X] := clBlack;
  end;
end;

function TTetris.CheckShapeCollision(Pos: TPoint; Rotation: Byte): Boolean;
var
  Y, X: Integer;
begin
  Result := False;
  for Y := 0 to Length(CurrentShape.Body[Rotation]) - 1 do begin
    for X := 0 to 3 do
      if ((CurrentShape.Body[Rotation, Y] shr X) and 1) = 1 then
        if ((Pos.Y + Y) >= Board.Size.Y) or ((Pos.X + X) >= Board.Size.X) or
        ((Pos.Y + Y) < 0) or ((Pos.X + X) < 0) or
        (Board.Cells[Pos.Y + Y, Pos.X + X] <> clBlack) then begin
          Result := True;
          Break;
        end;
  end;
end;

procedure TTetris.MoveShape(Pos: TPoint; Rotation: Byte);
begin
  ShapePos := Pos;
  ShapeRotation := Rotation;
  if (ShapePos <> LastShapePos) or (ShapeRotation <> LastShapeRotation) then begin
    ClearShapeOnBoard(LastShapePos, LastShapeRotation);
    LastShapePos := ShapePos;
    LastShapeRotation := ShapeRotation;
    PlaceShapeOnBoard(LastShapePos, LastShapeRotation);
  end;
end;

procedure TTetris.MoveDown;
var
  NewShapePos: TPoint;
begin
  NewShapePos := Point(ShapePos.X, ShapePos.Y + 1);
  ClearShapeOnBoard(ShapePos, ShapeRotation);
  if CheckShapeCollision(NewShapePos, ShapeRotation) then begin
    PlaceShapeOnBoard(ShapePos, ShapeRotation);
    RemoveFullRows;
    ShapePos := Point(Board.Size.X div 2 - 2, 0);
    ShapeRotation := 0;
    LastShapePos := ShapePos;
    LastShapeRotation := 0;
    CurrentShape := NextShape;
    NextShape := Shapes[Random(Shapes.Count)];
    if CheckShapeCollision(ShapePos, ShapeRotation) then State := gsStopped
      else PlaceShapeOnBoard(ShapePos, ShapeRotation);
  end else begin
    MoveShape(NewShapePos, ShapeRotation);
  end;
end;

procedure TTetris.RemoveFullRows;
var
  X, Y: Integer;
  I: Integer;
  IsFull: Boolean;
begin
  for Y := ShapePos.Y to Min(ShapePos.Y + 3, Board.Size.Y - 1) do begin
    IsFull := True;
    for X := 0 to Board.Size.X - 1 do
      if Board.Cells[Y, X] = clBlack then begin
        IsFull := False;
        Break;
      end;

    if IsFull then begin
      for I := Y downto 1 do
        for X := 0 to Board.Size.X - 1 do
          Board.Cells[I, X] := Board.Cells[I - 1, X];
      Inc(Score);
    end;
  end;
end;

procedure TTetris.KeyUp(var Key: Word; Shift: TShiftState);
var
  NewShapePos: TPoint;
  NewShapeRotation: Byte;
begin
  if not (State = gsRunning) then Exit;
  case Key of
    KeyCodeUp: begin
      NewShapeRotation := (ShapeRotation + 1) mod Length(CurrentShape.Body);
      ClearShapeOnBoard(ShapePos, ShapeRotation);
      if not CheckShapeCollision(ShapePos, NewShapeRotation) then begin
        MoveShape(ShapePos, NewShapeRotation);
      end else PlaceShapeOnBoard(ShapePos, ShapeRotation);
      Scene.Redraw;
    end;
    KeyCodeLeft: begin
      NewShapePos := Point(ShapePos.X - 1, ShapePos.Y);
      ClearShapeOnBoard(ShapePos, ShapeRotation);
      if not CheckShapeCollision(NewShapePos, ShapeRotation) then begin
        MoveShape(NewShapePos, ShapeRotation);
      end else PlaceShapeOnBoard(ShapePos, ShapeRotation);

      Scene.Redraw;
    end;
    KeyCodeRight: begin
      NewShapePos := Point(ShapePos.X + 1, ShapePos.Y);
      ClearShapeOnBoard(ShapePos, ShapeRotation);
      if not CheckShapeCollision(NewShapePos, ShapeRotation) then begin
        MoveShape(NewShapePos, ShapeRotation);
      end else PlaceShapeOnBoard(ShapePos, ShapeRotation);

      Scene.Redraw;
    end;
  end;
end;

procedure TTetris.Tick;
begin
  if Time > MoveDownTime + 500 * OneMillisecond then begin
    MoveDownTime := Time;
    MoveDown;
    Scene.Redraw;
  end;

  if Time > KeyDownTime + 50 * OneMillisecond then begin
    KeyDownTime := Time;
    if KeyPressed(KeyCodeDown) then begin
      MoveDown;
      Scene.Redraw;
    end;
  end;
end;

procedure TTetris.Run;
begin
  Winner := '';
  Board.Clear;
  ShapePos := Point(Board.Size.X div 2 - 2, 0);
  CurrentShape := Shapes[Random(Shapes.Count)];
  NextShape := Shapes[Random(Shapes.Count)];
  PlaceShapeOnBoard(ShapePos, ShapeRotation);
  inherited;
end;

constructor TTetris.Create;
begin
  Name := STetris;
  Scene := TSceneMain.Create;
  TSceneMain(Scene).Game := Self;
  Board := TBoard.Create;
  Board.Size := Point(10, 20);
  Shapes := TShapes.Create;
  with Shapes.AddNew([2, 2, 2, 2], clRed) do  // I
    AddRotation([0, $f, 0, 0]);
  Shapes.AddNew([0, 6, 6, 0], clBlue); // Square
  with Shapes.AddNew([2, 2, 6, 0], clYellow) do begin // L
    AddRotation([0, 4, 7, 0]);
    AddRotation([6, 4, 4, 0]);
    AddRotation([0, 7, 1, 0]);
  end;
  with Shapes.AddNew([2, 6, 2, 0], clGreen) do begin // T
    AddRotation([0, 7, 2, 0]);
    AddRotation([4, 6, 4, 0]);
    AddRotation([0, 2, 7, 0]);
  end;
  with Shapes.AddNew([2, 6, 4, 0], clMaroon) do begin // Zig-zag
    AddRotation([0, 6, 3, 0]);
    AddRotation([4, 6, 2, 0]);
    AddRotation([0, 3, 6, 0]);
  end;
end;

destructor TTetris.Destroy;
begin
  FreeAndNil(Shapes);
  FreeAndNil(Board);
  FreeAndNil(Scene);
  inherited;
end;

end.