[Simba] Tetris!

program Tetris;
(*
  A hacked together tetris game that uses the builtin debug image.
  Requires Simba 1.2-RC5 or later.
  > http://i.imgur.com/q7VhaaD.png
*)

const
  //** CONFIGUREATION **//
  TURN_RIGHT = VK_D;
  TURN_LEFT  = VK_A;

  MOVE_LEFT  = VK_LEFT;
  MOVE_RIGHT = VK_RIGHT;

  MOVE_DOWN  = VK_DOWN;
  DROP_DOWN  = VK_SPACE;

  RESTART_GAME = VK_F5;
  PAUSE_GAME = VK_P;

  START_LEVEL = 1;

  //special conf:
  GAME_WIDTH  = 10;
  GAME_HEIGHT = 20;

  BASE_TICK = 700;

  POINTSIZE = 24;


//----------------------------------------------------------------------------\\
//----------------------------------------------------------------------------\\

type
  TFace = (f0,f1,f2,f3);
  TState = (stRunning, stCompleted);

  TBrick = record
    id: Int32;
    pos: TPoint;
    face: TFace;
  end;
  TBrickArray = array of TBrick;

  TTetris = record
    Width,Height:Int32;
    Bounds:TBox;
    Board:TMufasaBitmap;
    Active, Original, Next:TBrick;
    State:TState;
    Score:Int32;

    Level:Int32;
    Tick:Int32;
    CollapseCount:Int32;
  end;

const
  GLOB_BRICKS:T2DPointArray = [
    [[0,0],[0,1],[1,0],[2,0]], // :''
    [[0,0],[1,0],[2,0],[3,0]], // ....
    [[0,0],[1,0],[2,0],[1,1]], // ':'
    [[1,0],[2,0],[0,1],[1,1]], // .:'
    [[0,0],[1,0],[1,1],[2,1]], // ':.
    [[0,0],[1,0],[0,1],[1,1]], // ::
    [[0,0],[1,0],[2,0],[2,1]]  // '':
  ];

  GLOB_COLORS:TIntegerArray = [
    $3388FF,  //orange
    $FFCC33,  //cyan
    $FF33BB,  //purple
    $33FF77,  //green
    $3333FF,  //red / pink
    $33DDFF,  //yellow
    $FF9000   //blue
  ];

  BACKGROUND = $333333;


function TBrick.GetBrickTPA(): TPointArray; constref;
begin
  Result := GLOB_BRICKS[self.id];
  case self.face of
    f0: Result := Copy(Result);
    f1: Result := RotatePoints(Result, radians(90), 1,0);
    f2: Result := RotatePoints(Result, radians(180), 1,0);
    f3: Result := RotatePoints(Result, radians(270), 1,0);
  end;
  OffsetTPA(Result, Self.pos);
end;

procedure TTetris.FillBox(x,y:Int32; color:Int32=BACKGROUND);
var
  h,s,l:Extended;
begin
  x *= POINTSIZE;
  y *= POINTSIZE;
  try
    self.Board.DrawTPA(TPAFromBox([x,y,x+POINTSIZE-2,y+POINTSIZE-2]), color);
    if color <> BACKGROUND then
    begin
      ColorToHSL(color, H,S,L);
      color := HSLToColor(H,S-15,L-15);
      self.Board.DrawTPA(EdgeFromBox([x,y,x+POINTSIZE-2,y+POINTSIZE-2]), color);
    end;
  except
  end;
end;

function TTetris.IsFilled(x,y:Int32): Boolean;
begin
  Result := (y > 0) and (self.board.GetPixel(x * POINTSIZE, y * POINTSIZE) <> BACKGROUND);
end;

procedure TTetris.DrawBrick(brick:TBrick);
var pt:TPoint;
begin
  for pt in brick.GetBrickTPA() do
    self.FillBox(pt.x,pt.y, GLOB_COLORS[brick.id]);
end;

procedure TTetris.UndrawBrick(brick:TBrick);
var pt:TPoint;
begin
  for pt in brick.GetBrickTPA() do
    self.FillBox(pt.x,pt.y);
end;

function TTetris.Collides(): Boolean;
var
  pt:TPoint;
begin
  for pt in active.GetBrickTPA() do
    if (not(InRange(pt.x, Bounds.x1, Bounds.x2) and InRange(pt.y, Bounds.y1, Bounds.y2))) or
       self.IsFilled(pt.x,pt.y) then
      Exit(True);
end;

function TTetris.TryRotateCW(): Boolean;
var
  pt:TPoint;
  oldface:TFace;
begin
  Result := True;
  self.UndrawBrick(self.Active);

  oldface := active.face;
  if active.face = f3 then active.face := f0
  else Inc(active.face);

  if self.Collides() then
  begin
    active.face := oldface;
    self.DrawBrick(self.Active);
    Result := False;
  end;
end;

function TTetris.TryRotateCCW(): Boolean;
var
  pt:TPoint;
  oldface:TFace;
begin
  Result := True;
  self.UndrawBrick(self.Active);

  oldface := active.face;
  if active.face = f0 then active.face := f3
  else Dec(active.face);

  if self.Collides() then
  begin
    active.face := oldface;
    self.DrawBrick(self.Active);
    Result := False;
  end;
end;

function TTetris.TryMove(ox,oy:Int32): Boolean;
var
  pt:TPoint;
  oldpos:TPoint;
begin
  Result := True;
  self.UndrawBrick(self.Active);

  oldpos := active.pos;
  active.pos.x += ox;
  active.pos.y += oy;

  if self.Collides() then
  begin
    active.pos := oldpos;
    self.DrawBrick(self.Active);
    Result := False;
  end;
end;

procedure TTetris.UpdateBrick();
begin
  self.UndrawBrick(Original);
  self.DrawBrick(Active);
  self.Update();
end;

procedure TTetris.LevelUp();
begin
  self.Tick := Ceil(self.Tick*0.75);
  if self.Tick < 1 then self.Tick := 1;
  self.Level += 1;
  self.collapseCount := 0;
end;

procedure TTetris.CheckRows();
var
  x,y,counter:Int32;
  procedure RemoveRow(row:Int32);
  var x,y,color:Int32;
  begin
    counter += 1;
    for y:=row-1 downto 0 do
      for x:=0 to Bounds.X2 do
      begin
        color := self.board.GetPixel(x * POINTSIZE+1, y * POINTSIZE+1);
        self.FillBox(x,y);
        self.FillBox(x,y+1, color);
      end;
  end;
begin
  for y:=0 to Bounds.Y2 do
  begin
    for x:=0 to Bounds.X2 do
      if not self.IsFilled(x,y) then
        break;
    if (x = self.Width) then RemoveRow(y);
  end;
  self.Score += counter*self.Width;
  self.collapseCount += counter;
  if self.collapseCount >= 10 then self.LevelUp();
end;

procedure TTetris.NewBrick();
begin
  self.Original := self.Next;
  self.Active   := self.Next;

  self.Next.pos  := Point(self.Width div 2 - 1, -1);
  self.Next.face := f0;
  self.Next.id   := Random(0,High(GLOB_BRICKS));
end;

procedure TTetris.Debug();
var
  x:Int32;
  pt:TPoint;
  brick:TBrick;
  procedure _FillBrick(x,y:Int32; size:Int32=15);
  begin
    for pt in brick.GetBrickTPA() do
    begin
      pt.x := x+pt.x*size;
      pt.y := y+pt.y*size;
      self.Board.DrawTPA(TPAFromBox([pt.x,pt.y, pt.x+size-2,pt.y+size-2]), $FFFFFF);
    end;
  end;

begin
  x := self.Width*POINTSIZE + 20;

  if self.score = 0 then
  begin
    self.Board.setFontName('Arial Black');
    self.Board.setFontSize(14);
    self.Board.DrawText('Score:', Point(x,20),  $AAAAAA);
    self.Board.DrawText('Level:', Point(x,80),  $AAAAAA);
    self.Board.DrawText('Speed:', Point(x,140), $AAAAAA);
    self.Board.DrawText('Next: ', Point(x,200), $AAAAAA);
  end;

  //clear
  self.Board.DrawTPA(TPAFromBox([x,40,Board.GetWidth()-1,60]), 0);
  self.Board.DrawTPA(TPAFromBox([x,100,Board.GetWidth()-1,120]), 0);
  self.Board.DrawTPA(TPAFromBox([x,160,Board.GetWidth()-1,180]), 0);
  self.Board.DrawTPA(TPAFromBox([x,220,Board.GetWidth()-1, 220+50]), 0);

  //draw
  self.Board.setFontName('Arial');
  self.Board.DrawText(ToStr(self.Score), Point(x,40),  $FFFFFF);
  self.Board.DrawText(ToStr(self.Level), Point(x,100), $FFFFFF);
  self.Board.DrawText(ToStr(Round(BASE_TICK/self.Tick,2)), Point(x,160), $FFFFFF);

  brick := self.Next;
  brick.pos := [0,0];
  _FillBrick(x,220,15);

  //----
  if self.State = stCompleted then
  begin
     ClearDebug();
     WriteLn('Game over!!');
  end;
end;

procedure TTetris.RestartGame();
var x,y:Int32;
begin
  Self.Tick := 1000;
  for x:=0 to Width-1 do
    for y:=0 to Height-1 do
      Self.FillBox(x,y);

  Self.Level := 1;
  Self.Tick := BASE_TICK;
  for 1 to START_LEVEL-1 do Self.LevelUp();
  Self.Score := 0;
  Self.State := stRunning;
  Self.NewBrick();
  Self.Debug();
end;

procedure TTetris.HandleEvent();
var t,t2:UInt64;
begin
  t := GetTickCount() + Tick;
  while GetTickCount() < t do
  begin
    self.UpdateBrick();
    Original := Active;
    t2 := GetTickCount() + 150;
    if isKeyDown(TURN_RIGHT) then
    begin
      TryRotateCW();
      while isKeyDown(TURN_RIGHT) and (GetTickCount() < t2) do Wait(2);
    end
    else if isKeyDown(TURN_LEFT) then
    begin
      TryRotateCCW();
      while isKeyDown(TURN_LEFT) and (GetTickCount() < t2) do Wait(2);
    end
    else if isKeyDown(MOVE_LEFT) then
    begin
      TryMove(-1,0);
      while isKeyDown(MOVE_LEFT) and (GetTickCount() < t2) do Wait(2);
    end
    else if isKeyDown(MOVE_RIGHT) then
    begin
      TryMove(1,0);
      while isKeyDown(MOVE_RIGHT) and (GetTickCount() < t2) do Wait(2);
    end
    else if isKeyDown(MOVE_DOWN) then
    begin
      while isKeyDown(MOVE_DOWN) and TryMove(0,1) do
      begin
        self.UpdateBrick();
        Wait(4);
      end;
    end
    else if isKeyDown(DROP_DOWN) then
    begin
      while TryMove(0,1) do
      begin
        self.UpdateBrick();
        Wait(4);
      end;
    end
    else if isKeyDown(RESTART_GAME) then
    begin
      self.RestartGame();
    end
    else if isKeyDown(PAUSE_GAME) then
    begin
      ClearDebug();
      WriteLn(self.Score);
      WriteLn('Game is paused!');
      while isKeyDown(PAUSE_GAME) do Wait(16);
      while not isKeyDown(PAUSE_GAME) do Wait(16);
      while isKeyDown(PAUSE_GAME) do Wait(16);
      ClearDebug();
      WriteLn(self.Score);
      WriteLn('Game has been resumed!');
    end;
    Wait(2);
  end;
  self.UpdateBrick();
end;

function TTetris.Create(AWidth,AHeight:Int32): TTetris; static;
var
  x,y:Int32;
begin
  Result.Width  := AWidth;
  Result.Height := AHeight;
  Result.Board.Init(client.getMBitmaps);
  Result.Board.SetSize(AWidth*POINTSIZE+150, AHeight*POINTSIZE);
  Result.Bounds := [0,-3,Result.Width-1,Result.Height-1];

  x := AWidth*POINTSIZE;
  Result.Board.DrawTPA(TPAFromBox([x,0,x, AHeight*POINTSIZE-1]), $999999);

  Result.Level := 1;
  Result.Tick := BASE_TICK;
  for 1 to START_LEVEL-1 do Result.LevelUp();

  for x:=0 to AWidth-1 do
    for y:=0 to AHeight-1 do
      Result.FillBox(x,y);
end;

procedure TTetris.Display(); constref;
begin
  DisplayDebugImgWindow(Self.board.GetWidth,Self.Board.GetHeight);
  DrawBitmapDebugImg(Self.Board.GetIndex());
end;

procedure TTetris.Update(); constref;
begin
  DrawBitmapDebugImg(Self.Board.GetIndex());
end;

procedure TTetris.Focus(); constref;
{$IFNDEF LINUX}
var proc:TSysProc;
function SetForegroundWindow(HWND:UInt64): LongBool; external 'SetForegroundWindow@User32.dll';
begin
  for proc in GetProcesses() do
    if proc.Title = 'DebugImgForm' then
      SetForegroundWindow(proc.Handle);
end;
{$ELSE}
begin
  WriteLn('Click / Focus the debug window manually, starting in 1 second');
  Wait(1000);
end;
{$ENDIF}

function TTetris.Run(): Boolean;
begin
  self.State := stRunning;
  self.Display();
  self.Focus();
  self.NewBrick();
  self.Debug();

  while True do
  begin
    self.HandleEvent();
    Original := Active;

    if not self.TryMove(0,1) then
    begin
      self.Score += self.Active.pos.y;

      if self.Active.pos.y = -1 then
        self.State := stCompleted
      else
      begin
        self.CheckRows();
        self.NewBrick();
        self.Debug();
        Wait(170);
      end;
    end;

    while self.State = stCompleted do
    begin
      Self.Debug();
      self.HandleEvent();
      Wait(8);
    end;
  end;
end;


var
  Tetris:TTetris;
  tmp:TBrick;
begin
  Tetris := TTetris.Create(GAME_WIDTH,GAME_HEIGHT);
  Tetris.Run();
end.